theory PhiSem_Mem_C
  imports PhiSem_Mem_C_Base "HOL-Library.Word"
begin

section \<open>Semantics\<close>

subsection \<open>Models\<close>

subsubsection \<open>Type\<close>

virtual_datatype c_mem_ty =
  T_pointer :: unit

debt_axiomatization T_pointer :: \<open>unit type_entry\<close>
  where c_mem_ty_ax: \<open>c_mem_ty TY_CONS_OF T_pointer\<close>

interpretation c_mem_ty TY_CONS_OF \<open>TYPE(TY_N)\<close> \<open>TYPE(TY)\<close> T_pointer using c_mem_ty_ax .

abbreviation \<open>pointer \<equiv> T_pointer.mk ()\<close>

subsubsection \<open>Value\<close>

paragraph \<open>Memory Address\<close>

consts addrspace_bits :: "nat" \<comment> \<open>bit width of address space, in unit of bits\<close>
specification (addrspace_bits) addrspace_bits_L0: "0 < addrspace_bits" by blast

typedecl addr_cap \<comment> \<open>size of address space\<close>

instantiation addr_cap :: len begin
definition [simp]: "len_of_addr_cap (_::addr_cap itself) = addrspace_bits"
instance apply standard using addrspace_bits_L0 by simp
end

type_synonym size_t = \<open>addr_cap word\<close>
abbreviation to_size_t :: \<open>nat \<Rightarrow> size_t\<close> where \<open>to_size_t \<equiv> of_nat\<close>

declare [[typedef_overloaded]]
datatype segidx = Null | Segment nat \<comment> \<open>nonce\<close> (layout: TY)

hide_const (open) layout

datatype 'index memaddr = memaddr (segment: segidx) (index: 'index) (infixl "|:" 60)
declare [[typedef_overloaded = false]]

declare memaddr.sel[iff]
hide_const (open) segment index

type_synonym logaddr = "nat list memaddr" (* the index of logaddr is non empty *)
type_synonym rawaddr = \<open>size_t memaddr\<close> \<comment> \<open>having physical offset\<close>

instantiation segidx :: zero begin
definition [simp]: "zero_segidx = Null"
instance ..
end

instantiation memaddr :: (zero) zero begin
definition "zero_memaddr = (0 |: 0)"
instance ..
end

lemma infinite_UNIV_int [simp]: "infinite (UNIV::int set)"
proof
  assume "finite (UNIV::int set)"
  moreover have "inj (\<lambda>i::int. 2 * i)"
    by (rule injI) simp
  ultimately have "surj (\<lambda>i::int. 2 * i)"
    by (rule finite_UNIV_inj_surj)
  thm finite_UNIV_inj_surj
  then obtain i :: int where "1 = 2 * i" by (rule surjE)
  then show False by presburger
qed

lemma segidx_infinite[simp]:
  \<open>infinite (UNIV :: segidx set)\<close>
  using inj_on_finite[where A = \<open>UNIV::nat set\<close> and B = \<open>(UNIV :: segidx set)\<close>
        and f = \<open>\<lambda>n. Segment n undefined\<close>]
  by (meson infinite_UNIV_char_0 injI segidx.inject top_greatest)

lemma segidx_infinite_TY:
  \<open>infinite {a. segidx.layout a = TY}\<close>
  using inj_on_finite[where A = \<open>UNIV::nat set\<close> and B = \<open>{a. segidx.layout a = TY}\<close>
        and f = \<open>\<lambda>n. Segment n TY\<close>]
  using inj_def by fastforce

abbreviation shift_addr :: "'idx memaddr \<Rightarrow> ('idx::monoid_add) \<Rightarrow> 'idx memaddr" (infixl "||+" 60)
  where "shift_addr addr delta \<equiv> map_memaddr (\<lambda>x. x + delta) addr"

lemma mem_shift_shift[simp]: "a ||+ i ||+ j = a ||+ (i + j)" by (cases a) (simp add: add.assoc)

lemma memaddr_segment_shift[simp]:
  \<open>memaddr.segment (a ||+ i) = memaddr.segment a\<close>
  by (cases a, simp)

lemma memaddr_index_shift[simp]:
  \<open>memaddr.index (a ||+ i) = memaddr.index a + i\<close>
  by (cases a, simp)

lemma mem_shift_add_cancel[simp]:
  \<open>(a ||+ i) = (a ||+ j) \<longleftrightarrow> i = j\<close>
  for i :: \<open>'a::{monoid_add,cancel_semigroup_add}\<close>
  by (cases a, simp)

paragraph \<open>Model\<close>

virtual_datatype c_mem_val = V_pointer :: rawaddr

debt_axiomatization V_pointer :: \<open>rawaddr value_entry\<close>
  where c_mem_val_ax: \<open>c_mem_val VAL_CONS_OF V_pointer\<close>

interpretation c_mem_val VAL_CONS_OF \<open>TYPE(VAL_N)\<close> \<open>TYPE(VAL)\<close> V_pointer using c_mem_val_ax .

subsubsection \<open>Resource\<close>

setup \<open>Sign.mandatory_path "RES"\<close>

type_synonym mem = \<open>segidx \<rightharpoonup> VAL nosep\<close>

setup \<open>Sign.parent_path\<close>

resource_space c_mem =
  C_mem :: \<open>{h::RES.mem. finite (dom h) \<and> (\<forall>seg \<in> dom h. h seg \<in> Some ` nosep ` Well_Type (segidx.layout seg))}\<close>
  (partial_map_resource) ..

term RES.C_mem.basic_fiction

thm RES.C_mem.basic_fiction_def

definition In_Mem :: \<open> resource \<Rightarrow> segidx \<Rightarrow> bool\<close>
  where \<open>In_Mem res seg \<equiv> seg \<in> dom (RES.C_mem.get res)\<close>

subsection \<open>Semantics\<close>

abbreviation \<open>type_storable_in_mem T \<equiv> MemObj_Size T < 2^addrspace_bits\<close>

definition \<open>Valid_Segment seg = (
    case seg of Null \<Rightarrow> True
              | Segment _ ty \<Rightarrow> type_storable_in_mem ty
    )\<close>

lemma Valid_Segment_zero[simp]: \<open>Valid_Segment Null\<close>
  unfolding Valid_Segment_def zero_segidx_def by simp

abbreviation valid_rawaddr :: \<open>rawaddr \<Rightarrow> bool\<close>
  where \<open>valid_rawaddr addr \<equiv> Valid_Segment (memaddr.segment addr)\<close>

definition valid_logaddr :: "logaddr \<Rightarrow> bool"
  where "valid_logaddr addr \<longleftrightarrow>
    Valid_Segment (memaddr.segment addr) \<and>
    (memaddr.segment addr = Null \<longrightarrow> memaddr.index addr = []) \<and>
    valid_index (segidx.layout (memaddr.segment addr)) (memaddr.index addr)"

lemma valid_rawaddr_0[simp]: \<open>valid_rawaddr (0 |: 0)\<close>
  by (simp add: zero_prod_def Valid_Segment_def zero_memaddr_def zero_segidx_def)

lemma valid_logaddr_0[simp]: \<open>valid_logaddr (0 |: [])\<close>
  by (simp add: valid_logaddr_def zero_prod_def Valid_Segment_def zero_memaddr_def zero_segidx_def)

debt_axiomatization
    can_eqcmp_ptr[simp]: "Can_EqCompare res (V_pointer.mk rp1) (V_pointer.mk rp2)
           \<longleftrightarrow> (memaddr.segment rp1 = memaddr.segment rp2) \<or> (rp1 = 0) \<or> (rp2 = 0) \<or>
               (In_Mem res (memaddr.segment rp1) \<and> In_Mem res (memaddr.segment rp2))"
and eqcmp_ptr[simp]: "EqCompare (V_pointer.mk rp1) (V_pointer.mk rp2) \<longleftrightarrow> rp1 = rp2"
and zero_ptr[simp]: \<open>Zero pointer = Some (V_pointer.mk 0)\<close>
and WT_ptr[simp]: \<open>Well_Type \<tau>Pointer = { V_pointer.mk addr |addr. valid_rawaddr addr }\<close>

(*
definition Valid_Mem :: "('TY,'VAL) R_mem set"
  where "Valid_Mem = { Fine h |h. finite (dom h)
                                \<and> (\<forall>seg \<in> dom h. h seg \<in> Some ` Well_Type (segidx.layout seg))}"

lemma Valid_Mem_1[simp]: \<open>1 \<in> Valid_Mem\<close>
  unfolding Valid_Mem_def one_fun_def one_fine_def by simp
*)

lemma Mem_freshness:
  \<open>finite (dom f) \<Longrightarrow> \<exists>k. f k = None \<and> segidx.layout k = TY\<close>
  unfolding dom_def
  by (smt (verit, del_insts) Collect_mono finite_Collect_disjI finite_subset segidx_infinite_TY)

paragraph \<open>Address & Pointer\<close>

abbreviation logaddr_type :: \<open>logaddr \<Rightarrow> TY\<close>
  where \<open>logaddr_type addr \<equiv> index_type (memaddr.index addr) (segidx.layout (memaddr.segment addr))\<close>

lemma MemObj_Size_LE_idx:
  \<open>valid_index T (base@idx) \<Longrightarrow> MemObj_Size (index_type (base@idx) T) \<le> MemObj_Size (index_type base T)\<close>
  apply (induct base arbitrary: T idx; simp)
  subgoal for T idx apply (induct idx arbitrary: T; simp)
    using memobj_size_step order.trans by blast .

lemmas MemObj_Size_LE_idx_0 = MemObj_Size_LE_idx[where base = "[]", simplified]

lemma index_type_type_storable_in_mem:
  \<open>type_storable_in_mem T \<Longrightarrow> valid_index T idx \<Longrightarrow> type_storable_in_mem (index_type idx T)\<close>
  using MemObj_Size_LE_idx_0 order.strict_trans1 by blast

lemma logaddr_storable_in_mem:
  \<open>valid_logaddr addr \<Longrightarrow> addr \<noteq> 0 \<Longrightarrow> type_storable_in_mem (logaddr_type addr)\<close>
  unfolding valid_logaddr_def Valid_Segment_def zero_memaddr_def
  apply (cases addr; simp)
  subgoal for seg idx by (cases seg; simp add: index_type_type_storable_in_mem) .

definition logaddr_to_raw :: \<open>logaddr \<Rightarrow> rawaddr\<close>
  where \<open>logaddr_to_raw addr =
    (case addr of seg |: idx \<Rightarrow> seg |: to_size_t (index_offset (segidx.layout seg) idx))\<close>

lemma logaddr_to_raw_0[simp]:
  \<open>logaddr_to_raw (0 |: []) = (0 |: 0)\<close>
  unfolding logaddr_to_raw_def by simp

lemma logaddr_to_raw_segment[simp]:
  \<open>memaddr.segment (logaddr_to_raw addr) = memaddr.segment addr\<close>
  unfolding logaddr_to_raw_def by (cases addr) simp

lemma valid_logaddr_rawaddr [simp]:
  \<open>valid_logaddr addr \<Longrightarrow> valid_rawaddr (logaddr_to_raw addr)\<close>
  unfolding valid_logaddr_def by simp

lemma index_offset_inj:
  assumes prems:
    \<open>valid_index T index1\<close>
    \<open>valid_index T index2\<close>
    \<open>index_type index2 T = index_type index1 T\<close>
    \<open>0 < MemObj_Size (index_type index1 T)\<close>
  shows \<open>index_offset T index1 = index_offset T index2 \<longrightarrow> index1 = index2\<close>
proof -
  consider (either_nil) \<open>index1 = [] \<or> index2 = []\<close>
      |   (both_notnil) \<open>index1 \<noteq> [] \<and> index2 \<noteq> []\<close>
      by blast
  then show ?thesis
  proof cases
    case either_nil
      then show ?thesis using prems index_type_idem by metis
  next
    case both_notnil
    have \<open>index1 \<noteq> index2 \<longrightarrow> index_offset T index1 \<noteq> index_offset T index2\<close> (is \<open>?neq \<longrightarrow> ?goal\<close>)
    proof
      assume neq: ?neq

      have t1: \<open>\<And>idx1 idx2. idx1 \<noteq> [] \<and> idx2 \<noteq> [] \<and> idx1 \<noteq> idx2 \<and> \<not>(\<exists>d. idx1@d = idx2) \<and> \<not>(\<exists>d. idx2@d = idx1)
          \<Longrightarrow> \<exists>i. i < length idx1 \<and> i < length idx2 \<and> idx1 ! i \<noteq> idx2 ! i \<close>
        unfolding list_eq_iff_nth_eq nth_append apply simp apply clarify
        subgoal premises prems for idx1 idx2
          apply (cases \<open>length idx1 \<le> length idx2\<close>)
          using prems(4)[THEN spec[where x=\<open>drop (length idx1) idx2\<close>], simplified]
           apply (metis le_add_diff_inverse linordered_semidom_class.add_diff_inverse nth_drop)
          using prems(5)[THEN spec[where x=\<open>drop (length idx2) idx1\<close>], simplified]
           by (metis add_diff_inverse_nat le_add_diff_inverse nat_le_linear nth_drop)
         done

       moreover have t2: \<open>\<And>i idx1 idx2. i < length idx1 \<and> i < length idx2 \<and> idx1 ! i \<noteq> idx2 ! i
          \<Longrightarrow> \<exists>i. i < length idx1 \<and> i < length idx2 \<and> idx1 ! i \<noteq> idx2 ! i \<and> take i idx1 = take i idx2\<close>
         unfolding list_eq_iff_nth_eq apply simp
         subgoal for i idx1 idx2
           apply (induct i arbitrary: idx1 idx2 rule: nat_less_induct)
           by (smt (verit, ccfv_threshold) min.absorb4 min_less_iff_conj)
         done

       ultimately have t3:
          \<open>\<And>idx1 idx2. idx1 \<noteq> [] \<and> idx2 \<noteq> [] \<and> idx1 \<noteq> idx2 \<and> \<not>(\<exists>d. idx1@d = idx2) \<and> \<not>(\<exists>d. idx2@d = idx1)
          \<Longrightarrow> \<exists>i. i < length idx1 \<and> i < length idx2 \<and> idx1 ! i \<noteq> idx2 ! i \<and> take i idx1 = take i idx2\<close>
         by (smt (verit, ccfv_threshold))

       note t4 = t3[of \<open>index1\<close> \<open>index2\<close>, simplified both_notnil, simplified]

       have \<open>\<not>((\<exists>d. index1@d = index2) \<or> (\<exists>d. index2@d = index1))\<close>
       proof
         assume A: \<open>(\<exists>d. index1 @ d = index2) \<or> (\<exists>d. index2 @ d = index1)\<close>
         then consider (L) \<open>\<exists>d. index1 @ d = index2\<close> |
                       (R) \<open>(\<exists>d. index2 @ d = index1)\<close> by blast
         then show False
         proof cases
           case L
           then obtain d where D: \<open>index2 = index1@d\<close> by blast
           then have \<open>valid_index (index_type index1 T) d\<close> using valid_index_cat prems by blast
           then have \<open>d = []\<close> using fold_append prems D by (simp add: index_type_idem)
           then show False using neq D by blast
         next
           case R
           then obtain d where D: \<open>index1 = index2@d\<close> by blast
           then have \<open>valid_index (index_type index2 T) d\<close> using valid_index_cat prems by blast
           then have \<open>d = []\<close> using fold_append prems D by (metis comp_def index_type_idem)
           then show False using neq D by blast
         qed
       qed
      then have \<open>\<exists>base i1 idx1 i2 idx2. index1 = (base@[i1])@idx1 \<and> index2 = (base@[i2])@idx2 \<and> i1 \<noteq> i2\<close>
        using neq both_notnil t4
        by (metis append.assoc append_Cons append_Nil id_take_nth_drop)
      then obtain base i1 idx1 i2 idx2 where
        obt: \<open>(base@[i1])@idx1 = index1 \<and> (base@[i2])@idx2 = index2 \<and> i1 \<noteq> i2\<close>
        by blast

      have valid_idx_step_i1: \<open>valid_idx_step (index_type base T) i1\<close>
        using prems valid_index_cat valid_index_cons obt by blast
      have valid_idx_step_i2: \<open>valid_idx_step (index_type base T) i2\<close>
        using prems valid_index_cat valid_index_cons obt by blast
      have \<open>index_offset T index1 \<noteq> index_offset T index2\<close>
        using index_offset_bound_strict[where base = \<open>base@[i1]\<close> and idx = idx1 and T = T,
                                        simplified index_offset_tail obt prems fold_tail]
              index_offset_bound_strict[where base = \<open>base@[i2]\<close> and idx = idx2 and T = T,
                                        simplified index_offset_tail obt prems fold_tail]
              idx_step_offset_disj[where T = \<open>index_type base T\<close> and i = i1 and j = i2]
        by (smt (verit, ccfv_SIG) comp_def group_cancel.add1 idx_step_offset_disj nat_add_left_cancel_less nat_le_linear obt order.strict_trans1 valid_idx_step_i1 valid_idx_step_i2)
      then show ?goal
        using obt prems by presburger
    qed
    then show ?thesis using prems by blast
    qed
  qed

lemma logaddr_to_raw_inj:
    \<open>valid_logaddr addr1 \<Longrightarrow>
     valid_logaddr addr2 \<Longrightarrow>
     logaddr_type addr1 = logaddr_type addr2 \<Longrightarrow>
     0 < MemObj_Size (logaddr_type addr1) \<Longrightarrow>
     logaddr_to_raw addr1 = logaddr_to_raw addr2 \<longrightarrow> addr1 = addr2\<close>
  unfolding logaddr_to_raw_def valid_logaddr_def
  apply (cases addr1; cases addr2; simp)
  by (smt (verit, ccfv_SIG) Valid_Segment_def add_leD1 index_offset_inj index_offset_upper_bound_0 len_of_addr_cap_def order_le_less_trans segidx.case_eq_if take_bit_nat_eq_self_iff word_of_nat_eq_iff)

definition \<open>rawaddr_to_log T raddr = (@laddr. logaddr_to_raw laddr = raddr \<and> logaddr_type laddr = T \<and> valid_logaddr laddr)\<close>

lemma rawaddr_to_log[simp]:
  \<open>valid_logaddr addr \<Longrightarrow> 0 < MemObj_Size (logaddr_type addr)
    \<Longrightarrow> rawaddr_to_log (logaddr_type addr) (logaddr_to_raw addr) = addr\<close>
  unfolding rawaddr_to_log_def
  by (rule some_equality, simp) (metis logaddr_to_raw_inj)

subsection \<open>Fiction\<close>

definition sem_read_mem :: \<open>logaddr \<Rightarrow> resource \<Rightarrow> VAL\<close>
  where \<open>sem_read_mem addr res =
    index_value (memaddr.index addr) (nosep.dest (the (RES.mem.get res (memaddr.segment addr))))\<close>

definition sem_write_mem :: \<open>logaddr \<Rightarrow> VAL \<Rightarrow> resource \<Rightarrow> resource\<close>
  where \<open>sem_write_mem addr val res =
    (let seg = memaddr.segment addr
       ; mem = RES.mem.get res
       ; val' = index_mod_value (memaddr.index addr) (\<lambda>_. val) (nosep.dest (the (mem seg)))
       ; mem' = mem(seg \<mapsto> nosep val')
      in res(RES.mem #= mem'))\<close>

(*

fiction_space (in agmem_sem) agmem_fic :: \<open>'RES_N \<Rightarrow> 'RES\<close> = \<phi>min_fic +
  FIC_mem :: share_mem

(* TODO: agmem_sem should be a locale expression! ! *)

locale agmem = agmem_fic
  where TYPES = \<open>TYPE(('TY_N \<Rightarrow> 'TY)
                    \<times> ('VAL_N \<Rightarrow> 'VAL::nonsepable_semigroup)
                    \<times> ('RES_N \<Rightarrow> 'RES::{comm_monoid_mult,no_inverse}))\<close>
    and TYPE'NAME = \<open>TYPE('FIC_N)\<close>
    and TYPE'REP = \<open>TYPE('FIC::{no_inverse,comm_monoid_mult})\<close>
+ fixes TYPES :: \<open>(('TY_N \<Rightarrow> 'TY) \<times> ('VAL_N \<Rightarrow> 'VAL) \<times> ('RES_N \<Rightarrow> 'RES) \<times> ('FIC_N \<Rightarrow> 'FIC)) itself\<close>
begin

lemma R_mem_valid_split: \<open>res \<in> Valid_Resource \<longleftrightarrow>
    R_mem.clean res \<in> Valid_Resource \<and> (\<exists>m. res R_mem.name = R_mem.inject m \<and> m \<in> Valid_Mem)\<close>
  by (subst R_mem.split, simp add: Valid_Resource_def times_fun_def res_valid_mem image_iff, blast)

lemma R_mem_valid_split': \<open>NO_MATCH (R_mem.clean res') res \<Longrightarrow> res \<in> Valid_Resource \<longleftrightarrow>
    R_mem.clean res \<in> Valid_Resource \<and> (\<exists>m. res R_mem.name = R_mem.inject m \<and> m \<in> Valid_Mem)\<close>
  using R_mem_valid_split .

end
*)

section \<open>\<phi>Type for Semantic Models\<close>

subsection \<open>Pointers\<close>

subsubsection \<open>Raw Pointer\<close>

definition RawPointer :: "(VAL, rawaddr) \<phi>"
  where "RawPointer x = ({ V_pointer.mk x } \<s>\<u>\<b>\<j> valid_rawaddr x)"

lemma RawPointer_expn[\<phi>expns]:
  "v \<in> (p \<Ztypecolon> RawPointer) \<longleftrightarrow> v = V_pointer.mk p \<and> valid_rawaddr p"
  by (simp add: \<phi>Type_def RawPointer_def \<phi>expns)

lemma RawPointer_inhabited[elim!, \<phi>inhabitance_rule]:
  "Inhabited (p \<Ztypecolon> RawPointer) \<Longrightarrow> (valid_rawaddr p \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding Inhabited_def by (simp add: \<phi>expns)

declare [[\<phi>trace_reasoning = 1]]

lemma RawPointer_zero[\<phi>reason 1200]:
  "\<phi>Zero pointer RawPointer (Null |: 0)"
  unfolding \<phi>Zero_def by (simp add: \<phi>expns zero_prod_def zero_memaddr_def)

lemma RawPointer_eqcmp[\<phi>reason 1200]:
  "\<phi>Equal RawPointer (\<lambda>x y. x = 0 |: 0 \<or> y = 0 |: 0 \<or> memaddr.segment x = memaddr.segment y) (=)"
  unfolding \<phi>Equal_def by (simp add: \<phi>expns zero_memaddr_def) blast

lemma RawPointer_semty[\<phi>reason 1200]:
  \<open>\<phi>SemType (x \<Ztypecolon> RawPointer) pointer\<close>
  unfolding \<phi>SemType_def subset_iff
  by (simp add: \<phi>expns)

subsubsection \<open>Typed Pointer\<close>

definition TypPtr :: "TY \<Rightarrow> (VAL, logaddr) \<phi>"
  where "TypPtr TY x = ({ V_pointer.mk (logaddr_to_raw x) }
              \<s>\<u>\<b>\<j> valid_logaddr x \<and> x \<noteq> 0 \<and> logaddr_type x = TY \<and> 0 < MemObj_Size TY)"

lemma TypPtr_expn[\<phi>expns]:
  "v \<in> (addr \<Ztypecolon> TypPtr TY) \<longleftrightarrow>
      v = V_pointer.mk (logaddr_to_raw addr) \<and> valid_logaddr addr
    \<and> addr \<noteq> 0 \<and> logaddr_type addr = TY \<and> 0 < MemObj_Size TY"
  unfolding \<phi>Type_def by (simp add: TypPtr_def Subjection_expn)

lemma TypPtr_inhabited[elim!, \<phi>inhabitance_rule]:
  "Inhabited (addr \<Ztypecolon> TypPtr TY) \<Longrightarrow>
      (valid_logaddr addr \<and> addr \<noteq> 0 \<and> logaddr_type addr = TY \<and> 0 < MemObj_Size TY \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding Inhabited_def by (simp add: \<phi>expns)

lemma TypPtr_eqcmp[\<phi>reason 1000]:
    "\<phi>Equal (TypPtr TY) (\<lambda>x y. memaddr.segment x = memaddr.segment y) (=)"
  unfolding \<phi>Equal_def
  by (simp add: \<phi>expns) (metis logaddr_to_raw_inj)

lemma TypPtr_semty[\<phi>reason 1000]:
  \<open>\<phi>SemType (x \<Ztypecolon> TypPtr TY) pointer\<close>
  unfolding \<phi>SemType_def subset_iff
  by (simp add: \<phi>expns valid_logaddr_def)

subsubsection \<open>Slice Pointer\<close>

text \<open>A limitation of TypPtr is that it cannot point to the end of an array,
  because there is no object at all at the end. To address this, there is a slice pointer which
  can range over a piece of the array including the end.\<close>

definition SlicePtr :: "TY \<Rightarrow> (VAL, logaddr \<times> nat \<times> nat) \<phi>"
  where "SlicePtr TY = (\<lambda>(base,i,len).
    if valid_logaddr base \<and> base \<noteq> 0 \<and> (\<exists>N. logaddr_type base = array N TY \<and> len \<le> N)
        \<and> 0 < MemObj_Size TY \<and> i \<le> len
    then { V_pointer.mk (logaddr_to_raw base ||+ of_nat (i * MemObj_Size TY)) }
    else {})"

lemma SlicePtr_expn[\<phi>expns]:
  \<open>v \<in> ((base, i, len) \<Ztypecolon> SlicePtr TY) \<longleftrightarrow>
      valid_logaddr base \<and> base \<noteq> 0
      \<and> (\<exists>N. logaddr_type base = \<tau>Array N TY \<and> len \<le> N)
      \<and> 0 < MemObj_Size TY \<and> i \<le> len
      \<and> v = V_pointer.mk (logaddr_to_raw base ||+ of_nat (i * MemObj_Size TY))\<close>
  unfolding SlicePtr_def \<phi>Type_def by simp blast

lemma SlicePtr_inhabited[\<phi>reason_elim!,elim!]:
  \<open>Inhabited ((base, i, len) \<Ztypecolon> SlicePtr TY)
\<Longrightarrow> (\<And>N. valid_logaddr base \<Longrightarrow> base \<noteq> 0 \<Longrightarrow> logaddr_type base = \<tau>Array N TY \<Longrightarrow> len \<le> N
          \<Longrightarrow> 0 < MemObj_Size TY \<Longrightarrow> i \<le> len \<Longrightarrow> C)
\<Longrightarrow> C\<close>
  unfolding Inhabited_def SlicePtr_expn by simp blast

lemma SlicePtr_eqcmp[\<phi>reason on \<open>\<phi>Equal (SlicePtr ?TY) ?c ?eq\<close>]:
    "\<phi>Equal (SlicePtr TY) (\<lambda>x y. fst x = fst y) (\<lambda>(_,i1,_) (_,i2,_). i1 = i2)"
  unfolding \<phi>Equal_def
  apply (clarsimp simp add: \<phi>expns word_of_nat_eq_iff take_bit_nat_def simp del: of_nat_mult)
  subgoal premises for addr i1 n1 i2 N n2 proof -
    note logaddr_storable_in_mem[OF \<open>valid_logaddr addr\<close> \<open>addr \<noteq> 0\<close>,
            unfolded \<open>logaddr_type addr = \<tau>Array N TY\<close>, unfolded memobj_size_arr]
    then have \<open>i1 * MemObj_Size TY < 2 ^ addrspace_bits\<close>
          and \<open>i2 * MemObj_Size TY < 2 ^ addrspace_bits\<close>
      by (meson \<open>i1 \<le> n1\<close> \<open>n1 \<le> N\<close> \<open>i2 \<le> n2\<close> \<open>n2 \<le> N\<close> dual_order.strict_trans2 mult_le_mono1)+
    then show ?thesis
      using \<open>0 < MemObj_Size TY\<close> by fastforce
  qed
  done

lemma SlicePtr_semty[\<phi>reason on \<open>\<phi>SemType (?x \<Ztypecolon> SlicePtr ?TY) ?ty\<close>]:
  \<open>\<phi>SemType (x \<Ztypecolon> SlicePtr TY) \<tau>Pointer\<close>
  unfolding \<phi>SemType_def subset_iff
  by (cases x, simp add: \<phi>expns valid_logaddr_def)

subsection \<open>Memory Object\<close>

definition Ref :: \<open>('VAL,'a) \<phi> \<Rightarrow> ('FIC_N \<Rightarrow> 'FIC, 'TY logaddr \<Zinj> 'a share) \<phi>\<close>
  where \<open>Ref T x' = (case x' of (seg |: idx) \<Zinj> (n \<Znrres> x) \<Rightarrow>
    if 0 < n \<and> valid_index (segidx.layout seg) idx then
    { FIC_mem.mk (1(seg := Fine (push_map idx (share n (to_share o Mapof_Val v)))))
          |v. v \<in> Well_Type (logaddr_type (seg |: idx)) \<and> v \<in> (x \<Ztypecolon> T) }
    else {})\<close>

lemma (in agmem) Ref_expn[\<phi>expns]:
  \<open>fic \<in> ((seg |: idx) \<Zinj> (n \<Znrres> v) \<Ztypecolon> Ref Identity)
    \<longleftrightarrow> 0 < n \<and> valid_index (segidx.layout seg) idx
        \<and> v \<in> Well_Type (logaddr_type (seg |: idx))
        \<and> fic = FIC_mem.mk (1(seg := Fine (push_map idx (share n (to_share o Mapof_Val v)))))\<close>
  unfolding Ref_def \<phi>Type_def by (simp add: Identity_def) blast

(*
definition Slice :: \<open>('VAL,'a) \<phi> \<Rightarrow> ('FIC_N \<Rightarrow> 'FIC, 'TY logaddr \<Zinj> 'a share option list) \<phi>\<close>
  where \<open>Slice T x' = (case x' of (seg |: i#idx) \<Zinj> l \<Rightarrow>
    if valid_index (segidx.layout seg) idx
     \<and> (\<exists>N TY. index_type idx (segidx.layout seg) = \<tau>Array N TY \<and> i + length l \<le> N)
    then let
    { FIC_mem.mk (1(seg := Fine (push_map idx (share n (to_share o Mapof_Val v)))))
          |v. v \<in> Well_Type (logaddr_type (seg |: idx)) \<and> v \<in> (x \<Ztypecolon> T) }
    else {} | _ \<Rightarrow> {})\<close> *)

section \<open>Instructions & Their Specifications\<close>

subsubsection \<open>Address / Pointer\<close>

definition \<phi>M_get_logptr :: \<open>'TY \<Rightarrow> 'VAL sem_value \<Rightarrow> ('TY logaddr \<Rightarrow> ('ret,'RES_N,'RES) proc) \<Rightarrow> ('ret,'RES_N,'RES) proc\<close>
  where \<open>\<phi>M_get_logptr TY v F = \<phi>M_getV \<tau>Pointer V_pointer.dest v (\<lambda>p. F (rawaddr_to_log TY p))\<close>

lemma (in agmem) \<phi>M_get_logptr[\<phi>reason!]:
  \<open>(valid_logaddr addr \<Longrightarrow>
    addr \<noteq> 0 \<Longrightarrow>
    logaddr_type addr = TY \<Longrightarrow>
    0 < MemObj_Size TY \<Longrightarrow>
    \<^bold>p\<^bold>r\<^bold>o\<^bold>c F addr \<lbrace> X \<longmapsto> Y \<rbrace>) \<Longrightarrow>
   \<^bold>p\<^bold>r\<^bold>o\<^bold>c \<phi>M_get_logptr TY v F \<lbrace> X\<heavy_comma> addr \<Ztypecolon> Val v (Pointer TY) \<longmapsto> Y \<rbrace>\<close>
  unfolding \<phi>M_get_logptr_def
  by (cases v, simp, rule \<phi>M_getV, simp add: \<phi>expns valid_logaddr_def, auto simp add: \<phi>expns)

subsection \<open>Access the Resource\<close>

subsubsection \<open>Memory Operations\<close>

definition \<phi>M_get_mem
    :: "'TY segidx \<Rightarrow> nat list \<Rightarrow> ('VAL \<Rightarrow> ('ret,'RES_N,'RES) proc) \<Rightarrow> ('ret,'RES_N,'RES) proc"
  where "\<phi>M_get_mem seg idx F =
            \<phi>M_get_res_entry R_mem.get seg (\<lambda>val.
            \<phi>M_assert (val \<in> Well_Type (segidx.layout seg)) \<ggreater> F (index_value idx val))"

definition op_load_mem :: "'TY \<Rightarrow> ('VAL, 'VAL,'RES_N,'RES) proc'"
  where "op_load_mem TY v =
    \<phi>M_get_logptr TY v (\<lambda>ptr.
    \<phi>M_get_mem (memaddr.segment ptr) (memaddr.index ptr) (\<lambda>x. Return (sem_value x)))"

definition op_store_mem :: "'TY \<Rightarrow> ('VAL \<times> 'VAL, unit,'RES_N,'RES) proc'"
  where "op_store_mem TY =
    \<phi>M_caseV (\<lambda>va vb.
    \<phi>M_get_logptr TY va (\<lambda>ptr. case ptr of (seg |: idx) \<Rightarrow>
    \<phi>M_getV TY id vb (\<lambda>v.
    \<phi>M_get_mem seg idx (\<lambda>_.
    \<phi>M_set_res R_mem.updt (\<lambda>f. f(seg := map_option (index_mod_value idx (\<lambda>_. v)) (f seg)))))))"

definition op_free_mem :: "('VAL, unit,'RES_N,'RES) proc'"
  where "op_free_mem v =
    \<phi>M_getV \<tau>Pointer V_pointer.dest v (\<lambda>ptr. case ptr of (seg |: ofst) \<Rightarrow>
    \<phi>M_assert (ofst = 0) \<ggreater>
    \<phi>M_set_res R_mem.updt (\<lambda>f. f(seg := None)))"

definition op_alloc_mem :: "'TY \<Rightarrow> ('VAL, unit,'RES_N,'RES) proc'"
  where "op_alloc_mem TY' v =
    \<phi>M_getV (\<tau>Int addrspace_bits) V_int.dest v (\<lambda>(_, n).
    \<phi>M_set_res R_mem.updt (\<lambda>f.
    let TY = \<tau>Array n TY'
      ; addr = (@addr. f addr = None \<and> segidx.layout addr = TY)
     in f(addr := Some (Zero TY))))"

declare (in agmem) fiction_mem_\<I>[simp]

lemma (in agmem) \<phi>M_get_mem[\<phi>reason!]:
  \<open>\<^bold>p\<^bold>r\<^bold>o\<^bold>c F v \<lbrace> (seg |: idx) \<Zinj> n \<Znrres> v \<Ztypecolon> Ref Identity \<longmapsto> Y \<rbrace>
    \<Longrightarrow> \<^bold>p\<^bold>r\<^bold>o\<^bold>c \<phi>M_get_mem seg idx F \<lbrace> (seg |: idx) \<Zinj> n \<Znrres> v \<Ztypecolon> Ref Identity \<longmapsto> Y \<rbrace>\<close>
  unfolding \<phi>Procedure_def
  apply clarify
  apply (subgoal_tac \<open>\<phi>M_get_mem seg idx F comp = F v comp\<close>)
  apply simp
  unfolding \<phi>M_get_mem_def \<phi>M_get_res_entry_def \<phi>M_get_res_def
  apply (auto simp add: \<phi>expns FIC_mem.interp_split' R_mem_valid_split' share_mem_def
                R_mem.mult_in_dom Valid_Mem_def times_fun
                mult_strip_fine_011 times_list_def del: subsetI)
  subgoal premises prems for R fic res mem mem'
  proof -
    note [simp] = mult_strip_fine_011
    from \<open>mem' ## mem\<close> have t1: \<open>mem' seg ## mem seg\<close> by (simp add: sep_disj_fun)
    show ?thesis
      using \<open>\<forall>_. \<exists>_. _ = Fine _ \<and> _ \<in> _\<close>[THEN spec[where x=seg]] t1 \<open>valid_index (segidx.layout seg) idx\<close>
        apply (auto simp add: \<open>0 < n\<close>)
      using \<open>\<forall>_ \<in> dom _. _\<close>[unfolded Ball_def, THEN spec[where x=seg]]
       apply (auto simp add: times_fun)[1]

      subgoal premises prems2 for sh' v' proof -
        have [simp]: \<open>valid_index (segidx.layout seg) idx\<close>
          by (simp add: \<open>valid_index (segidx.layout seg) idx\<close> \<open>v' \<in> Well_Type (segidx.layout seg)\<close>)
        note t2[simp] = this[THEN Mapof_Val_pull]

        have t3[simp]: \<open>pull_map idx sh' ## share n (to_share \<circ> Mapof_Val v)\<close>
          using \<open>sh' ## push_map idx _\<close> by (metis pull_map_sep_disj pull_push_map)
        have t5: \<open>index_value idx v' \<in> Well_Type (index_type idx (segidx.layout seg))\<close>
          using index_value_welltyp \<open>valid_index (segidx.layout seg) idx\<close>
                  \<open>v' \<in> Well_Type (segidx.layout seg)\<close> by blast

        let \<open>?lhs = ?rhs\<close> = \<open>to_share \<circ> Mapof_Val v' = sh' * push_map idx (share n (to_share \<circ> Mapof_Val v))\<close>
        from \<open>?lhs = ?rhs\<close> have \<open>pull_map idx ?lhs = pull_map idx ?rhs\<close> by fastforce
        note this[simplified pull_map_to_share pull_map_homo_mult pull_push_map t2]
        then have \<open>Mapof_Val (index_value idx v') = (strip_share \<circ> pull_map idx sh') ++ (Mapof_Val v)\<close>
          by (metis prems(5) prems2(6) strip_share_fun_mult strip_share_fun_share strip_share_share_funcomp(2) t2 t3)
        then have txx: \<open>index_value idx v' = v\<close>
          using Valof_Map_append Valof_Map t5
          by (metis prems(7))

        show ?thesis by (subst txx) standard
      qed
      done
  qed
  done

lemma (in agmem) op_load_mem:
  \<open>\<^bold>p\<^bold>r\<^bold>e\<^bold>m\<^bold>i\<^bold>s\<^bold>e v \<in> Well_Type TY
    \<Longrightarrow> \<^bold>p\<^bold>r\<^bold>o\<^bold>c op_load_mem TY raw
          \<lbrace> ptr \<Zinj> n \<Znrres> v \<Ztypecolon> Ref Identity\<heavy_comma> ptr \<Ztypecolon> Val raw (Pointer TY) \<longmapsto> ptr \<Zinj> n \<Znrres> v \<Ztypecolon> Ref Identity\<heavy_comma> \<^bold>v\<^bold>a\<^bold>l v \<Ztypecolon> Identity \<rbrace>\<close>
  unfolding Premise_def op_load_mem_def
  apply (cases ptr; simp)
  apply \<phi>reason
  apply simp
  by \<phi>reason

lemma (in agmem) op_store_mem:
   \<open>\<^bold>p\<^bold>r\<^bold>e\<^bold>m\<^bold>i\<^bold>s\<^bold>e v \<in> Well_Type TY
\<Longrightarrow> \<^bold>p\<^bold>r\<^bold>e\<^bold>m\<^bold>i\<^bold>s\<^bold>e u \<in> Well_Type TY
\<Longrightarrow> \<^bold>p\<^bold>r\<^bold>o\<^bold>c op_store_mem TY (\<phi>V_pair raw_ptr raw_u)
          \<lbrace> ptr \<Zinj> 1 \<Znrres> v \<Ztypecolon> Ref Identity\<heavy_comma> u \<Ztypecolon> Val raw_u Identity\<heavy_comma> ptr \<Ztypecolon> Val raw_ptr (Pointer TY)
        \<longmapsto> ptr \<Zinj> 1 \<Znrres> u \<Ztypecolon> Ref Identity\<rbrace>\<close>
  unfolding Premise_def op_store_mem_def
  apply (rule \<phi>M_caseV, rule \<phi>M_get_logptr)
  apply (cases ptr; cases raw_u; simp, \<phi>reason)
  unfolding \<phi>M_set_res_def \<phi>Procedure_def
  apply (auto simp add: \<phi>expns FIC_mem.interp_split' R_mem_valid_split' share_mem_def
                        R_mem.mult_in_dom times_list_def)
  subgoal premises prems for seg idx R fic res mem mem_remain'
  proof -
    show ?thesis
      using \<open>\<forall>_. \<exists>_. _ \<and> mem _ \<in> _\<close>[THEN spec[where x=seg]] \<open>mem_remain' * Fine mem \<in> Valid_Mem\<close>
      apply (auto simp add: mult_strip_fine_011 prems Valid_Mem_def times_fun
                            sep_disj_partial_map_some_none times_fine times_list_def)
      subgoal premises prems2 for fic_mR mem_R val
      proof -
        have [simp]: \<open>seg \<in> dom mem\<close> using \<open>mem seg = Some val\<close> by blast
        have [simp]: \<open>\<And>any. mem_R ## mem(seg := any)\<close> using \<open>mem_R ## _\<close> \<open>mem seg = Some val\<close>
          by (smt (verit, best) fun_upd_apply sep_disj_commuteI sep_disj_fun_def sep_disj_option(3) sep_disj_partial_map_some_none)
      have t1: \<open>dom (push_map idx (to_share \<circ> Mapof_Val u)) = dom (push_map idx (to_share \<circ> Mapof_Val v))\<close>
        by simp (meson Mapof_Val_same_dom \<open>u \<in> Well_Type _\<close> \<open>v \<in> Well_Type _\<close>)
      have t2: \<open>fic_mR ## push_map idx (to_share \<circ> Mapof_Val u)\<close>
        using total_Mapof_disjoint dom1_disjoint_sep_disj dom1_dom t1
        by (metis \<open>fic_mR ## _\<close> \<open>to_share \<circ> Mapof_Val val = _\<close>)

        show ?thesis
          apply (rule exI[where x=\<open>fic * FIC_mem.mk (1(seg := Fine (push_map idx (to_share \<circ> Mapof_Val u))))\<close>])
          apply (auto simp add: prems prems2 inj_image_mem_iff index_mod_value_welltyp
                                FIC_mem.interp_split' R_mem.times_fun_upd sep_disj_partial_map_upd
                                times_set_def times_fine'[symmetric] R_mem.mk_homo_mult)
          apply (fold \<open>mem_remain' = Fine mem_R\<close>,
                 fold \<open>res R_mem.name = R_mem.inject mem_remain'\<close>,
                 fold mult.assoc,
                 fold R_mem.split)
          apply (rule exI[where x=\<open>res\<close>])
          apply (rule exI[where x=\<open>R_mem.mk (Fine (mem(seg \<mapsto> index_mod_value idx (\<lambda>_. u) val)))\<close>])
          apply (simp add: prems share_mem_def )
          apply (auto simp add: mult_strip_fine_011 times_fun inj_image_mem_iff prems2 times_fine t2)
          apply (rule exI[where x =\<open>fic_mR * push_map idx (to_share \<circ> Mapof_Val u)\<close>],
              simp add: Mapof_Val_modify_fiction[of \<open>segidx.layout seg\<close> idx val v u fic_mR]
                        prems2 prems index_mod_value_welltyp)
          subgoal for x
            using \<open>\<forall>_. \<exists>y. _\<close>[THEN spec[where x=x]] apply clarsimp apply (case_tac \<open>y=1\<close>; simp)
          subgoal for y by (rule exI[where x=y], simp)
          done
        done
    qed
    done
  qed
  done

declare (in agmem) fiction_mem_\<I>[simp del]

lemma (in agmem) fiction_mem_\<I>':
  \<open> Rmem \<in> \<I> (fiction_mem (fiction.defined I)) fic
\<longleftrightarrow> (\<exists>mem. Rmem = R_mem.mk (Fine mem) \<and> mem \<in> \<I> I fic)\<close>
  unfolding fiction_mem_\<I> by clarsimp blast

lemma (in agmem) fiction_mem_\<I>'':
  \<open> Rmem R_mem.name = R_mem.inject (Fine mem)
\<Longrightarrow> Rmem \<in> \<I> (fiction_mem (fiction.defined I)) fic
\<longleftrightarrow> Rmem = R_mem.mk (Fine mem) \<and> mem \<in> \<I> I fic\<close>
  unfolding fiction_mem_\<I>' by auto

lemma (in agmem) fiction_mem_\<I>_simp:
  \<open> R_mem.mk (Fine mem) \<in> \<I> (fiction_mem (fiction.defined I)) fic
\<longleftrightarrow> mem \<in> \<I> I fic\<close>
  unfolding fiction_mem_\<I>' by simp

lemma (in agmem) share_mem_in_dom:
  \<open> mem \<in> \<I> share_mem' fic
\<Longrightarrow> seg \<in> dom1 fic
\<Longrightarrow> seg \<in> dom mem\<close>
  unfolding share_mem'_def
  by (simp add: domIff dom1_def one_fine_def)
     (smt (verit, ccfv_SIG) mem_Collect_eq option.distinct(1))

lemma (in agmem) share_mem'_mono:
  \<open> x \<in> \<I> share_mem' fx
\<Longrightarrow> y \<in> \<I> share_mem' fy
\<Longrightarrow> dom1 fx \<inter> dom1 fy = {}
\<Longrightarrow> x * y \<in> \<I> share_mem' (fx * fy)\<close>
  unfolding share_mem'_def set_eq_iff
  apply clarsimp
  subgoal premises prems for k
    using prems[THEN spec[where x=k]]
  apply (clarsimp simp add: times_fun dom1_def one_fine_def)
    subgoal for fx' fy'
      apply (cases \<open>fx' = 1\<close>; cases \<open>fy' = 1\<close>; clarsimp simp add: times_fine)
      using Mapof_not_1 to_share_funcomp_eq_1_iff by blast+
    done
  done

lemma (in agmem) share_mem'_drop_seg:
  \<open> v \<in> Well_Type (segidx.layout seg)
\<Longrightarrow> mem \<in> \<I> share_mem' (fic * 1(seg := Fine (to_share \<circ> Mapof_Val v)))
\<Longrightarrow> seg \<in> dom mem \<and> mem(seg := None) \<in> \<I> share_mem' fic\<close>
  unfolding share_mem'_def
  apply (auto simp add: times_fun)
  subgoal premises prems proof -
    show ?thesis
      using prems(2)[THEN spec[where x=seg]]
      by (clarsimp simp add: mult_strip_fine_011)
  qed
  subgoal premises prems proof -
    show ?thesis
      using prems(2)[THEN spec[where x=seg]]
      apply (clarsimp simp add: mult_strip_fine_011)
      subgoal premises prems2 for r u proof -
        have \<open>dom r \<inter> dom (to_share o Mapof_Val v) = {}\<close>
          using total_Mapof_disjoint[where idx=\<open>[]\<close>, simplified]
                \<open>r ## (to_share \<circ> Mapof_Val v)\<close> \<open>to_share \<circ> Mapof_Val u = r * (to_share \<circ> Mapof_Val v)\<close>
          by fastforce
        moreover have \<open>dom (to_share \<circ> Mapof_Val u) = dom (to_share \<circ> Mapof_Val v)\<close>
          using Mapof_Val_same_dom
          by (metis \<open>u \<in> Well_Type (segidx.layout seg)\<close> dom_map_option_comp prems(1))
        moreover have \<open>dom (to_share \<circ> Mapof_Val u) = dom r \<union> dom (to_share \<circ> Mapof_Val v)\<close>
          using dom_mult by (metis prems2)
        ultimately have \<open>dom r = {}\<close> by (metis inf_sup_absorb)
        then show ?thesis unfolding one_partial_map by blast
      qed
      done
  qed
  subgoal premises prems for x proof -
    thm prems
    show ?thesis using \<open>\<forall>_. _\<close>[THEN spec[where x=x]] \<open>x\<noteq>seg\<close> apply clarsimp
      subgoal for m by (rule exI[where x=m], simp, cases \<open>m = 1\<close>; simp)
      done
  qed
  done

lemma (in agmem) op_alloc_mem:
  \<open>\<^bold>p\<^bold>r\<^bold>o\<^bold>c op_alloc_mem TY raw_n \<lbrace> n \<Ztypecolon> Val raw_n Size \<longmapsto> ((seg |: []) \<Zinj> 1 \<Znrres> (Zero (\<tau>Array n TY)) \<Ztypecolon> Ref Identity \<^bold>s\<^bold>u\<^bold>b\<^bold>j seg. True) \<rbrace>\<close>
  unfolding op_alloc_mem_def
  apply (cases raw_n; simp, rule \<phi>M_tail_left, rule \<phi>M_getV; simp add: \<phi>expns)
  unfolding \<phi>M_set_res_def \<phi>Procedure_def
  apply (auto simp add: \<phi>expns FIC_mem.interp_split' R_mem_valid_split' times_fun dom_mult
                        R_mem.mult_in_dom Valid_Mem_def mult_strip_fine_011 mult_strip_fine_001
                        fiction_mem_\<I>'' share_mem_def' times_list_def)
  subgoal premises prems for R fic res mem' mem
  proof -
    note [simp] = times_fun dom_mult
    have t0: \<open>finite (dom (mem' * mem))\<close> using prems by simp
    note t1 = Mem_freshness[OF t0, of \<open>\<tau>Array n TY\<close>, THEN someI_ex, simplified]
    let ?seg = \<open>(SOME x. mem' x = None \<and> mem x = None \<and> segidx.layout x = \<tau>Array n TY)\<close>
    have t2'[simp]: \<open>mem' ?seg = None \<and> mem ?seg = None\<close> using t1 by blast
    have t2'': \<open>?seg \<notin> dom mem\<close> by force
    have t6: \<open>\<And>any. R_mem.clean res * R_mem.mk (Fine ((mem' * mem)(?seg := any)))
                  = res * (R_mem.mk (Fine (mem * 1(?seg := any))))\<close>
      unfolding fun_upd_def fun_eq_iff
      apply (simp add: prems R_mem.inj_homo_mult[symmetric] times_fine fun_eq_iff sep_disj_fun_def)
      by (simp add: \<open>mem' ## mem\<close> sep_disj_fun)

    show ?thesis
      apply (rule exI[where x = \<open>fic * FIC_mem.mk
                  (1(?seg := Fine (to_share \<circ> Mapof_Val (V_array.mk (TY, replicate n (Zero TY))))))\<close>])
      apply (auto simp add: prems inj_image_mem_iff t1 list_all_length zero_well_typ
                            FIC_mem.interp_split' R_mem.times_fun_upd sep_disj_partial_map_upd
                            times_set_def times_fine'[symmetric] R_mem.mk_homo_mult)
       apply (rule exI[where x=\<open>?seg\<close>], rule exI[where x=fic], simp add: prems t1 list_all_length zero_well_typ)
      apply (unfold t6)
      apply (rule exI[where x=\<open>res\<close>])
      apply (rule exI[where x=\<open>R_mem.mk (Fine (mem * 1(?seg \<mapsto> V_array.mk (TY, replicate n (Zero TY)))))\<close>])
      using \<open>res \<in> \<I> INTERP (FIC_mem.clean fic)\<close>
      apply (clarsimp simp add: prems share_mem_def' fiction_mem_\<I>_simp)
      apply (rule share_mem'_mono, simp add: prems)
      apply (clarsimp simp add: share_mem'_def t1 list_all_length zero_well_typ one_fine_def)
      apply (simp add: set_eq_iff)
      using share_mem_in_dom[OF \<open>mem \<in> \<I> share_mem' (FIC_mem.get fic)\<close>]  t2'' by blast
  qed
  done

lemma (in agmem) op_free_mem:
   \<open>\<^bold>p\<^bold>r\<^bold>o\<^bold>c op_free_mem vptr \<lbrace> (seg |: []) \<Zinj> 1 \<Znrres> v \<Ztypecolon> Ref Identity\<heavy_comma> (seg |: 0) \<Ztypecolon> Val vptr RawPointer \<longmapsto> 1\<rbrace>\<close>
  unfolding op_free_mem_def
  apply (cases vptr; simp, rule \<phi>M_getV; simp add: \<phi>expns)
  unfolding \<phi>M_set_res_def \<phi>Procedure_def
  apply (auto simp add: \<phi>expns FIC_mem.interp_split' R_mem_valid_split' times_fun dom_mult
                        R_mem.mult_in_dom Valid_Mem_def mult_strip_fine_011 mult_strip_fine_001
                        fiction_mem_\<I>'' share_mem_def' times_list_def)
  subgoal premises prems for R fic res memR mem
  proof -
    have t2: \<open>seg \<in> dom mem\<close>
      using share_mem'_drop_seg prems by blast
    have t3: \<open>seg \<notin> dom memR\<close>
      by (meson domD domIff prems sep_disj_partial_map_some_none t2)
    have t1: \<open>(res * R_mem.mk (Fine mem))(R_mem.name := R_mem.inject (Fine ((memR * mem)(seg := None))))
            = res * R_mem.mk (Fine (mem(seg := None)))\<close>
      unfolding fun_eq_iff times_fun
      apply (simp add: prems R_mem.inj_homo_mult[symmetric] times_fine sep_disj_partial_map_del)
      apply (simp add: fun_upd_def fun_eq_iff times_fun)
      using domIff t3 by fastforce
    show ?thesis
      apply (rule exI[where x=fic], simp add: prems FIC_mem.interp_split' sep_disj_partial_map_del t1)
      apply (rule times_set_I, simp add: prems)
      using share_mem'_drop_seg prems
      by (metis fiction_mem_\<I>' share_mem_def')
  qed
  done

end

end


           (*-------------------------------------------*
            |                  DFtick                   |
            |                                           |
            |                   June 2007               |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory DFP_DFtick
imports DFP_Deadlock
begin

(*****************************************************************

         1. The most abstract deadlockfree process DFtick

 *****************************************************************)

declare csp_prefix_ss_def[simp]

(*********************************************************
                         event
 *********************************************************)

typedecl Event   (* any event *)

datatype DFtickName = DFtick

(*** Spc ***)

primrec
  DFtickfun ::  "(DFtickName, Event) pnfun"
where
  "DFtickfun (DFtick) = (! x ->  $(DFtick)) |~| SKIP "
(*
defs (overloaded)
Set_DFtickfun_def [simp]: "PNfun == DFtickfun"
*)

overloading Set_DFtickfun ==
  "PNfun :: (DFtickName, Event) pnfun"
begin
  definition "PNfun == DFtickfun"
end

declare Set_DFtickfun_def [simp]

(*---------------------------------------------------*
 |                  n-replicted spec                 |
 *---------------------------------------------------*)

datatype RDFtickName = RDFtick

(*** Spc ***)

primrec
  NatDFtick ::
     "nat => (RDFtickName, Event) proc
          => (RDFtickName, Event) proc"
where
    "NatDFtick 0 P = P"
  | "NatDFtick (Suc n) P = ((! x -> NatDFtick n P) |~| SKIP) |~| P"

primrec
  RDFtickfun ::
    "RDFtickName
         => (RDFtickName, Event) proc"
where
  "RDFtickfun (RDFtick)
     = (! x -> (!nat n .. NatDFtick n ($(RDFtick))) |~| SKIP)"
(*
defs (overloaded)
Set_RDFtickfun_def [simp]: "PNfun == RDFtickfun"
*)

overloading Set_RDFtickfun ==
  "PNfun :: (RDFtickName, Event) pnfun"
begin
  definition "PNfun == RDFtickfun"
end

declare Set_RDFtickfun_def [simp]

(*********************************************************
              DFtick lemma
 *********************************************************)

lemma guardedfun_DFtick[simp]:
      "guardedfun DFtickfun"
by (simp add: guardedfun_def, rule allI, induct_tac p, simp_all)

lemma guardedfun_RDFtick[simp]:
      "guardedfun RDFtickfun"
apply (simp add: guardedfun_def)
apply (rule allI)
apply (induct_tac p)
apply (simp)
apply (rule allI)
apply (induct_tac n)
apply (simp_all)
done

(* -------------------------------------------------*
 |                                                  |
 |  syntactical approach --> semantical approach    |
 |                                                  |
 * -------------------------------------------------*)

(*** sub ***)

lemma DFtick_is_DeadlockFree:
  "(($DFtick) :: (DFtickName, Event) proc) isDeadlockFree"
apply (simp add: DeadlockFree_def)
apply (rule allI)
apply (induct_tac s rule: induct_trace)

(* base case *)
apply (simp)
apply (subgoal_tac
  "((DFtickfun (DFtick))::(DFtickName, Event) proc) =F
   ($(DFtick)::(DFtickName, Event) proc)")
apply (simp add: cspF_eqF_semantics)
apply (erule conjE)
apply (rotate_tac 1)
apply (drule sym)
apply (simp)
apply (rotate_tac 1)
apply (drule sym)
apply (simp (no_asm) add: in_failures)
apply (simp add: Evset_def)
apply (force)

apply (cspF_unwind)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)

apply (subgoal_tac
  "failures (($DFtick)::(DFtickName, Event) proc) MF =
   failures ((DFtickfun DFtick)::(DFtickName, Event) proc) MF")
apply (simp)
apply (rotate_tac -1)
apply (drule sym)
apply (simp (no_asm) add: in_failures)
apply (intro impI)
apply (simp add: in_failures)

apply (subgoal_tac
  "(($DFtick)::(DFtickName, Event) proc) =F
   ((DFtickfun DFtick)::(DFtickName, Event) proc)")
apply (simp add: cspF_eqF_semantics)
apply (cspF_unwind)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
done

(*** main ***)

lemma DFtick_DeadlockFree:
  "($DFtick :: (DFtickName, Event) proc) <=F P ==> P isDeadlockFree"
apply (insert DFtick_is_DeadlockFree)
apply (simp add: DeadlockFree_def)
apply (simp add: cspF_refF_semantics)
apply (auto)
done

(* -------------------------------------------------*
 |                                                  |
 |  semantical approach --> syntactical approach    |
 |                                                  |
 * -------------------------------------------------*)

lemma traces_included_in_DFtick:
  "t :t traces ((FIX DFtickfun) (DFtick)) (fstF o MF)"
apply (induct_tac t rule: induct_trace)

 (* <> *)
 apply (simp)

 (* <Tick> *)
 apply (simp add: FIX_def)
 apply (simp add: in_traces)
 apply (rule_tac x="Suc 0" in exI)
 apply (simp add: FIXn_def)
 apply (simp add: Subst_procfun_prod_def)
 apply (simp add: in_traces)

 (* <Eva>^^^s *)
 apply (simp add: FIX_def)
 apply (simp add: in_traces)
 apply (erule disjE)

 apply (simp)
 apply (rule_tac x="Suc 0" in exI)
 apply (simp add: FIXn_def)
 apply (simp add: Subst_procfun_prod_def)
 apply (simp add: in_traces)

 apply (erule exE)
 apply (rule_tac x="Suc n" in exI)
 apply (simp add: FIXn_def)
 apply (simp add: Subst_procfun_prod_def)
 apply (simp add: in_traces)
done

lemma failures_included_in_DFtick_lm:
  "(X ~= UNIV | Tick : sett t) -->
   (t,X) :f failures ((FIX DFtickfun) (DFtick)) MF"
apply (induct_tac t rule: induct_trace)

 (* <> *)
apply (simp add: FIX_def)
apply (intro impI)
apply (simp add: in_failures)
apply (rule_tac x="Suc 0" in exI)
apply (simp add: FIXn_def)
apply (simp add: Subst_procfun_prod_def)
apply (simp add: in_failures)

apply (case_tac "EX x. x ~: X")
apply (elim exE)
apply (case_tac "x = Tick")
apply (simp)
apply (simp add: Evset_def)
apply (force)
apply (simp add: not_Tick_to_Ev)
apply (force)
apply (force)

 (* <Tick> *)
 apply (simp add: FIX_def)
apply (simp add: in_failures)
apply (rule_tac x="Suc 0" in exI)
apply (simp add: FIXn_def)
apply (simp add: Subst_procfun_prod_def)
apply (simp add: in_failures)

 (* <Eva>^^^s *)
apply (intro impI)
 apply (simp add: FIX_def)
apply (simp add: in_failures)
apply (erule exE)
apply (rule_tac x="Suc n" in exI)
apply (simp add: FIXn_def)
apply (simp add: Subst_procfun_prod_def)
apply (simp add: in_failures)
done

lemma failures_included_in_DFtick:
  "[| X ~= UNIV | Tick : sett t |] ==>
   (t,X) :f failures ((FIX DFtickfun) (DFtick)) MF"
by (simp add: failures_included_in_DFtick_lm)

lemma DeadlockFree_DFtick:
  "P isDeadlockFree ==> ($DFtick :: (DFtickName, Event) proc) <=F P"
apply (rule cspF_rw_left)
apply (rule cspF_FIX)
prefer 2
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp add: cspF_refF_semantics)

apply (rule conjI)

(* trace *)
apply (simp add: subdomT_iff)
apply (simp add: traces_included_in_DFtick)

(* failures *)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (rule failures_included_in_DFtick)
apply (simp add: DeadlockFree_def)
apply (drule_tac x="s" in spec)
apply (auto)
done

(* -------------------------------------------------*
 |                                                  |
 |  syntactical approach <--> semantical approach   |
 |                                                  |
 * -------------------------------------------------*)

theorem DeadlockFree_DFtick_ref:
  "P isDeadlockFree = (($DFtick:: (DFtickName, Event) proc) <=F P)"
apply (rule)
apply (simp add: DeadlockFree_DFtick)
apply (simp add: DFtick_DeadlockFree)
done

(*================================================================*
 |                                                                |
 |                   n-replicted DF specification                 |
 |                                                                |
 *================================================================*)

(*******************************************************************
        relating function between DFtickName and Rep...
 *******************************************************************)

(*** ref1 ***)

primrec
  RepDF_to_DF :: "RDFtickName =>
                 (DFtickName, Event) proc"
where
  "RepDF_to_DF (RDFtick) = ($DFtick)"

lemma RDFtick_DFtick_ref1_induct_lm:
  "(($DFtick)::(DFtickName, Event) proc)
   <=F (NatDFtick n (($RDFtick)::(RDFtickName,Event)proc)) << RepDF_to_DF"
apply (induct_tac n)
apply (simp_all)
apply (rule cspF_Int_choice_right)
apply (rule cspF_rw_left)
apply (rule cspF_unwind)
apply (simp_all)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)
done

lemma RDFtick_DFtick_ref1:
  "($DFtick :: (DFtickName, Event) proc) <=F $RDFtick"
apply (rule cspF_fp_induct_right[of _ _ "RepDF_to_DF"])
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)

apply (induct_tac p)
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_unwind)
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)
apply (rule cspF_decompo)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_decompo)
apply (simp)

apply (rule cspF_Rep_int_choice_right)
apply (simp add: RDFtick_DFtick_ref1_induct_lm)
apply (simp)
done

(*** ref2 ***)

primrec
  DF_to_RepDF :: "DFtickName =>
                 (RDFtickName, Event) proc"
where
  "DF_to_RepDF (DFtick) = ($RDFtick)"

lemma RDFtick_DFtick_ref2:
  "$RDFtick <=F ($DFtick :: (DFtickName, Event) proc)"
apply (rule cspF_fp_induct_right[of _ _ "DF_to_RepDF"])
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)

apply (induct_tac p)
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_unwind)
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)
apply (rule cspF_decompo)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_decompo)
apply (simp)

apply (rule cspF_Rep_int_choice_left)
apply (rule_tac x="0" in exI)
apply (simp)
apply (simp)
done

(**************************** =F****************************)

lemma RDFtick_DFtick:
  "$RDFtick =F ($DFtick :: (DFtickName, Event) proc)"
apply (simp add: cspF_eq_ref_iff)
apply (simp add: RDFtick_DFtick_ref1)
apply (simp add: RDFtick_DFtick_ref2)
done

(* ---------------------------------------------------*
 |                                                    |
 |  syntactical approach 2 <--> semantical approach   |
 |                                                    |
 * ---------------------------------------------------*)

theorem DeadlockFree_RDFtick_ref:
  "P isDeadlockFree = (($RDFtick :: (RDFtickName, Event) proc) <=F P)"
apply (simp add: DeadlockFree_DFtick_ref)
apply (rule)
apply (rule cspF_rw_left)
apply (rule RDFtick_DFtick)
apply (simp)

apply (rule cspF_rw_left)
apply (rule RDFtick_DFtick[THEN cspF_sym])
apply (simp)
done

(* ------------------------------------------------------------------ *)

declare csp_prefix_ss_def[simp del]

end


(*******************************************************************************

  Project: Development of Security Protocols by Refinement

  Module:  Refinement/Channels.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Channels.thy 132773 2016-12-09 15:30:22Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Channel messages for Level 2 protocols

  Copyright (c) 2009-2016 Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>Channel Messages\<close>

theory Channels imports Atoms
begin

(******************************************************************************)
subsection \<open>Channel messages\<close>
(******************************************************************************)

datatype secprop = auth | confid

type_synonym
  chtyp = "secprop set"

abbreviation
  secure :: chtyp where
  "secure \<equiv> {auth, confid}"

datatype payload = Msg "atom list"

datatype chmsg =
  StatCh "chtyp" "agent" "agent" "payload"
| DynCh "chtyp" "key" "payload"

text \<open>Abbreviations for use in protocol defs\<close>

abbreviation
  Insec :: "[agent, agent, payload] \<Rightarrow> chmsg" where
  "Insec \<equiv> StatCh {}"

abbreviation
  Confid :: "[agent, agent, payload] \<Rightarrow> chmsg" where
  "Confid \<equiv> StatCh {confid}"

abbreviation
  Auth :: "[agent, agent, payload] \<Rightarrow> chmsg" where
  "Auth \<equiv> StatCh {auth}"

abbreviation
  Secure :: "[agent, agent, payload] \<Rightarrow> chmsg" where
  "Secure \<equiv> StatCh {auth, confid}"

abbreviation
  dConfid :: "[key, payload] \<Rightarrow> chmsg" where
  "dConfid \<equiv> DynCh {confid}"

abbreviation
  dAuth :: "[key, payload] \<Rightarrow> chmsg" where
  "dAuth \<equiv> DynCh {auth}"

abbreviation
  dSecure :: "[key, payload] \<Rightarrow> chmsg" where
  "dSecure \<equiv> DynCh {auth, confid}"

(******************************************************************************)
subsection \<open>Keys used in dynamic channel messages\<close>
(******************************************************************************)

definition
  keys_for :: "chmsg set \<Rightarrow> key set" where
  "keys_for H \<equiv> {K. \<exists>c M. DynCh c K M \<in> H}"

lemma keys_forI [dest]: "DynCh c K M \<in> H \<Longrightarrow> K \<in> keys_for H"
by (auto simp add: keys_for_def)

lemma keys_for_empty [simp]: "keys_for {} = {}"
by (simp add: keys_for_def)

lemma keys_for_monotone: "G \<subseteq> H \<Longrightarrow> keys_for G \<subseteq> keys_for H"
by (auto simp add: keys_for_def)

lemmas keys_for_mono [elim] = keys_for_monotone [THEN [2] rev_subsetD]

lemma keys_for_insert_StatCh [simp]:
  "keys_for (insert (StatCh c A B M) H) = keys_for H"
by (auto simp add: keys_for_def)

lemma keys_for_insert_DynCh [simp]:
  "keys_for (insert (DynCh c K M) H) = insert K (keys_for H)"
by (auto simp add: keys_for_def)

(******************************************************************************)
subsection \<open>Atoms in a set of channel messages\<close>
(******************************************************************************)

text \<open>The set of atoms contained in a set of channel messages. We also
include the public atoms, i.e., the agent names, numbers, and corrupted keys.
\<close>

inductive_set
  atoms :: "chmsg set \<Rightarrow> atom set"
  for H :: "chmsg set"
where
  at_StatCh: "\<lbrakk> StatCh c A B (Msg M) \<in> H; At \<in> set M \<rbrakk> \<Longrightarrow> At \<in> atoms H"
| at_DynCh: "\<lbrakk> DynCh c K (Msg M) \<in> H; At \<in> set M \<rbrakk> \<Longrightarrow> At \<in> atoms H"

declare atoms.intros [intro]

lemma atoms_empty [simp]: "atoms {} = {}"
by (auto elim!: atoms.cases)

lemma atoms_monotone: "G \<subseteq> H \<Longrightarrow> atoms G \<subseteq> atoms H"
by (auto elim!: atoms.cases)

lemmas atoms_mono [elim] = atoms_monotone [THEN [2] rev_subsetD]

lemma atoms_insert_StatCh [simp]:
  "atoms (insert (StatCh c A B (Msg M)) H) = set M \<union> atoms H"
by (auto elim!: atoms.cases)

lemma atoms_insert_DynCh [simp]:
  "atoms (insert (DynCh c K (Msg M)) H) = set M \<union> atoms H"
by (auto elim!: atoms.cases)

(******************************************************************************)
subsection \<open>Intruder knowledge (atoms)\<close>
(******************************************************************************)

text \<open>Atoms that the intruder can extract from a set of channel messages.\<close>

inductive_set
  extr :: "atom set \<Rightarrow> chmsg set \<Rightarrow> atom set"
  for T :: "atom set"
  and H :: "chmsg set"
where
  extr_Inj: "At \<in> T \<Longrightarrow> At \<in> extr T H"
| extr_StatCh:
    "\<lbrakk> StatCh c A B (Msg M) \<in> H; At \<in> set M; confid \<notin> c \<or> A \<in> bad \<or> B \<in> bad \<rbrakk>
   \<Longrightarrow> At \<in> extr T H"
| extr_DynCh:
    "\<lbrakk> DynCh c K (Msg M) \<in> H; At \<in> set M; confid \<notin> c \<or> aKey K \<in> extr T H \<rbrakk>
   \<Longrightarrow> At \<in> extr T H"

declare extr.intros [intro]
declare extr.cases [elim]

text\<open>Typical parameter describing initial intruder knowledge.\<close>

definition
  ik0 :: "atom set" where
  "ik0 \<equiv> range aAgt \<union> range aNum \<union> aKey`corrKey"

lemma ik0_aAgt [iff]: "aAgt A \<in> ik0"
by (auto simp add: ik0_def)

lemma ik0_aNum [iff]: "aNum T \<in> ik0"
by (auto simp add: ik0_def)

lemma ik0_aNon [iff]: "aNon N \<notin> ik0"
by (auto simp add: ik0_def)

lemma ik0_aKey_corr [simp]: "(aKey K \<in> ik0) = (K \<in> corrKey)"
by (auto simp add: ik0_def)

subsubsection \<open>Basic lemmas\<close>
(******************************************************************************)

lemma extr_empty [simp]: "extr T {} = T"
by (auto)

lemma extr_monotone [dest]: "G \<subseteq> H \<Longrightarrow> extr T G \<subseteq> extr T H"
by (safe, erule extr.induct, auto)

lemmas extr_mono [elim] = extr_monotone [THEN [2] rev_subsetD]

lemma extr_monotone_param [dest]: "T \<subseteq> U \<Longrightarrow> extr T H \<subseteq> extr U H"
by (safe, erule extr.induct, auto)

lemmas extr_mono_param [elim] = extr_monotone_param [THEN [2] rev_subsetD]

lemma extr_insert [intro]: "At \<in> extr T H \<Longrightarrow> At \<in> extr T (insert C H)"
by (erule extr_mono) (auto)

lemma extr_into_atoms [dest]: "At \<in> extr T H \<Longrightarrow> At \<in> T \<union> atoms H"
by (erule extr.induct, auto)

subsubsection \<open>Insertion lemmas for atom parameters\<close>
(******************************************************************************)

lemma extr_insert_non_key_param [simp]:
  assumes "At \<in> range aNon \<union> range aAgt \<union> range aNum"
  shows "extr (insert At T) H = insert At (extr T H)"
proof -
  { fix Bt
    assume "Bt \<in> extr (insert At T) H"
    hence "Bt \<in> insert At (extr T H)"
      using assms by induct auto
  }
  thus ?thesis by auto
qed

lemma extr_insert_unused_key_param [simp]:
  assumes "K \<notin> keys_for H"
  shows "extr (insert (aKey K) T) H = insert (aKey K) (extr T H)"
proof -
  { fix At
    assume "At \<in> extr (insert (aKey K) T) H"
    hence "At \<in> insert (aKey K) (extr T H)"
      using assms by induct (auto simp add: keys_for_def)
  }
  thus ?thesis by auto
qed

subsubsection \<open>Insertion lemmas for each type of channel message\<close>
(******************************************************************************)

text \<open>Note that the parameter accumulates the extracted atoms. In particular,
these may include keys that may open further dynamically confidential messages.
\<close>

lemma extr_insert_StatCh [simp]:
  "extr T (insert (StatCh c A B (Msg M)) H)
   = (if confid \<notin> c \<or> A \<in> bad \<or> B \<in> bad then extr (set M \<union> T) H else extr T H)"
proof (cases "confid \<notin> c \<or> A \<in> bad \<or> B \<in> bad")
  case True
  moreover
  {
    fix At
    assume "At \<in> extr T (insert (StatCh c A B (Msg M)) H)"
    hence "At \<in> extr (set M \<union> T) H" by induct auto
  }
  moreover
  {
    fix At
    assume "At \<in> extr (set M \<union> T) H"
    and    "confid \<notin> c \<or> A \<in> bad \<or> B \<in> bad"
    hence "At \<in> extr T (insert (StatCh c A B (Msg M)) H)" by induct auto
  }
  ultimately show ?thesis by auto
next
  case False
  moreover
  {
    fix At
    assume "At \<in> extr T (insert (StatCh c A B (Msg M)) H)"
    and "confid \<in> c" "A \<notin> bad" "B \<notin> bad"
    hence "At \<in> extr T H" by induct auto
  }
  ultimately show ?thesis by auto
qed

lemma extr_insert_DynCh [simp]:
  "extr T (insert (DynCh c K (Msg M)) H)
   = (if confid \<notin> c \<or> aKey K \<in> extr T H then extr (set M \<union> T) H else extr T H)"
proof (cases "confid \<notin> c \<or> aKey K \<in> extr T H")
  case True
  moreover
  {
    fix At
    assume "At \<in> extr T (insert (DynCh c K (Msg M)) H)"
    hence "At \<in> extr (set M \<union> T) H" by induct auto
  }
  moreover
  {
    fix At
    assume "At \<in> extr (set M \<union> T) H"
    hence "At \<in> extr T (insert (DynCh c K (Msg M)) H)"
      using True by induct auto
  }
  ultimately show ?thesis by auto
next
  case False
  moreover
  hence "extr T (insert (DynCh c K (Msg M)) H) = extr T H"
    by (intro equalityI subsetI) (erule extr.induct, auto)+
  ultimately show ?thesis by auto
qed

declare extr.cases [rule del, elim]

(******************************************************************************)
subsection \<open>Faking messages\<close>
(******************************************************************************)

text \<open>Channel messages that are fakeable from a given set of channel
messages.  Parameters are a set of atoms and a set of freshness identifiers.

For faking messages on dynamic non-authentic channels, we cannot allow the
intruder to use arbitrary keys. Otherwise, we would lose the possibility to
generate fresh values in our model. Therefore, the chosen keys must correspond
to session keys associated with existing runs (i.e., from set
@{term "rkeys U"}).
\<close>

abbreviation
  rkeys :: "fid_t set \<Rightarrow> key set" where
  "rkeys U \<equiv> sesK`(\<lambda>(x, y). x $ y)`(U \<times> (UNIV::nat set))"

lemma rkeys_sesK [simp, dest]: "sesK (R$i) \<in> rkeys U \<Longrightarrow> R \<in> U"
by (auto simp add: image_def)

inductive_set
  fake :: "atom set \<Rightarrow> fid_t set \<Rightarrow> chmsg set \<Rightarrow> chmsg set"
  for T :: "atom set"
  and U :: "fid_t set"
  and H :: "chmsg set"
where
  fake_Inj:
    "M \<in> H \<Longrightarrow> M \<in> fake T U H"
| fake_StatCh:
    "\<lbrakk> set M \<subseteq> extr T H; auth \<notin> c \<or> A \<in> bad \<or> B \<in> bad  \<rbrakk>
   \<Longrightarrow> StatCh c A B (Msg M) \<in> fake T U H"
| fake_DynCh:
    "\<lbrakk> set M \<subseteq> extr T H; auth \<notin> c \<and> K \<in> rkeys U \<or> aKey K \<in> extr T H \<rbrakk>
   \<Longrightarrow> DynCh c K (Msg M) \<in> fake T U H"

declare fake.cases [elim]
declare fake.intros [intro]

lemmas fake_intros = fake_StatCh fake_DynCh

lemma fake_monotone [intro]: "G \<subseteq> H \<Longrightarrow> fake T U G \<subseteq> fake T U H"
by (safe, erule fake.cases, auto intro!: fake_intros)

lemma fake_monotone_param1 [intro]:
  "T \<subseteq> T' \<Longrightarrow> fake T U H \<subseteq> fake T' U H"
by (safe, erule fake.cases, auto intro!: fake_intros)

lemmas fake_mono [elim] = fake_monotone [THEN [2] rev_subsetD]
lemmas fake_mono_param1 [elim] = fake_monotone_param1 [THEN [2] rev_subsetD]

subsubsection \<open>Atoms and extr together with fake\<close>
(******************************************************************************)

lemma atoms_fake [simp]: "atoms (fake T U H) = T \<union> atoms H"
proof -
  {
    fix At
    assume "At \<in> T"
    hence "At \<in> atoms (fake T U H)"
    proof -
      {
        fix A B
        have "Insec A B (Msg [At]) \<in> fake T U H" using \<open>At \<in> T\<close>
        by (intro fake_StatCh) (auto)
      }
      thus ?thesis by (intro at_StatCh) (auto)
    qed
  }
  moreover
  {
    fix At
    assume "At \<in> atoms (fake T U H) "
    hence "At \<in> T \<union> atoms H" by cases blast+
  }
  ultimately show ?thesis by auto
qed

lemma extr_fake [simp]:
  assumes "T' \<subseteq> T" shows "extr T (fake T' U H) = extr T H"
proof (intro equalityI subsetI)
  fix At
  assume "At \<in> extr T (fake T' U H)"
  with assms have "At \<in> extr T (fake T U H)" by auto
  thus "At \<in> extr T H" by induct auto
qed auto

(*
lemma extr_fake [simp]: "extr T (fake T U H) = extr T H"
proof -
  {
    fix At
    assume "At \<in> extr T (fake T U H)"
    hence "At \<in> extr T H" by induct auto
  }
  thus ?thesis by auto
qed
*)

end