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

theory PackedTypes
imports "Word_Lib.WordSetup" CProof
begin

section \<open>Underlying definitions for the class axioms\<close>

text \<open>field_access / field_update is the identity for packed types\<close>

definition fa_fu_idem :: "'a field_desc \<Rightarrow> nat \<Rightarrow> bool" where
  "fa_fu_idem fd n \<equiv>
     \<forall>bs bs' v. length bs = n \<longrightarrow> length bs' = n \<longrightarrow> field_access fd (field_update fd bs v) bs' = bs"

(* Is it better to do this or to use a fold over td?  This seems easier to use *)
primrec
  td_fafu_idem :: "'a field_desc typ_desc \<Rightarrow> bool" and
  td_fafu_idem_struct :: "'a field_desc typ_struct \<Rightarrow> bool" and
  td_fafu_idem_list :: " ('a field_desc typ_desc, char list) dt_pair list \<Rightarrow> bool" and
  td_fafu_idem_pair :: "('a field_desc typ_desc, char list) dt_pair \<Rightarrow> bool"
where
  fai0: "td_fafu_idem (TypDesc ts n) = td_fafu_idem_struct ts"

| fai1: "td_fafu_idem_struct (TypScalar n algn d) = fa_fu_idem d n"
| fai2: "td_fafu_idem_struct (TypAggregate ts) = td_fafu_idem_list ts"

| fai3: "td_fafu_idem_list [] = True"
| fai4: "td_fafu_idem_list (x#xs) = (td_fafu_idem_pair x \<and> td_fafu_idem_list xs)"

| fai5: "td_fafu_idem_pair (DTPair x n) = td_fafu_idem x"

lemmas td_fafu_idem_simps = fai0 fai1 fai2 fai3 fai4 fai5

text \<open>field_access is independent of the underlying bytes\<close>

definition  fa_heap_indep :: "'a field_desc \<Rightarrow> nat \<Rightarrow> bool" where
  "fa_heap_indep fd n \<equiv>
     \<forall>bs bs' v. length bs = n \<longrightarrow> length bs' = n \<longrightarrow> field_access fd v bs = field_access fd v bs'"

primrec
  td_fa_hi :: "'a field_desc typ_desc \<Rightarrow> bool" and
  td_fa_hi_struct :: "'a field_desc typ_struct \<Rightarrow> bool" and
  td_fa_hi_list :: "('a field_desc typ_desc, char list) dt_pair list \<Rightarrow> bool" and
  td_fa_hi_pair :: "('a field_desc typ_desc, char list) dt_pair \<Rightarrow> bool"
where
  fahi0: "td_fa_hi (TypDesc ts n) = td_fa_hi_struct ts"

| fahi1: "td_fa_hi_struct (TypScalar n algn d) = fa_heap_indep d n"
| fahi2: "td_fa_hi_struct (TypAggregate ts) = td_fa_hi_list ts"

| fahi3: "td_fa_hi_list [] = True"
| fahi4: "td_fa_hi_list (x#xs) = (td_fa_hi_pair x \<and> td_fa_hi_list xs)"

| fahi5: "td_fa_hi_pair (DTPair x n) = td_fa_hi x"

lemmas td_fa_hi_simps = fahi0 fahi1 fahi2 fahi3 fahi4 fahi5

section \<open>Lemmas about td_fafu_idem\<close>

lemma field_lookup_td_fafu_idem:
  shows "\<And>(s :: 'a field_desc typ_desc) f m n.
           \<lbrakk> field_lookup t f m = Some (s, n); td_fafu_idem t \<rbrakk> \<Longrightarrow> td_fafu_idem s"
  and   "\<And>(s :: 'a field_desc typ_desc) f m n.
           \<lbrakk> field_lookup_struct st f m = Some (s, n); td_fafu_idem_struct st \<rbrakk> \<Longrightarrow> td_fafu_idem s"
  and   "\<And>(s :: 'a field_desc typ_desc) f m n.
           \<lbrakk> field_lookup_list ts f m = Some (s, n); td_fafu_idem_list ts \<rbrakk> \<Longrightarrow> td_fafu_idem s"
  and   "\<And>(s :: 'a field_desc typ_desc) f m n.
           \<lbrakk> field_lookup_pair p f m = Some (s, n); td_fafu_idem_pair p \<rbrakk> \<Longrightarrow> td_fafu_idem s"
  by (induct t and st and ts and p) (auto split: if_split_asm option.splits)

lemma field_access_update_same:
  fixes t :: "'a :: mem_type field_desc typ_desc" and st :: "'a field_desc typ_struct"
  shows "\<And>(v :: 'a) bs bs'. \<lbrakk> td_fafu_idem t; wf_fd t; length bs = size_td t; length bs' = size_td t\<rbrakk>
  \<Longrightarrow> access_ti t (update_ti t bs v) bs' = bs"
  and "\<And>(v :: 'a) bs bs'. \<lbrakk> td_fafu_idem_struct st; wf_fd_struct st; length bs = size_td_struct st; length bs' = size_td_struct st \<rbrakk>
  \<Longrightarrow> access_ti_struct st (update_ti_struct st bs v) bs' = bs"
  and "\<And>(v :: 'a) bs bs'. \<lbrakk> td_fafu_idem_list ts; wf_fd_list ts; length bs = size_td_list ts; length bs' = size_td_list ts\<rbrakk>
  \<Longrightarrow> access_ti_list ts (update_ti_list ts bs v) bs' = bs"
  and "\<And>(v :: 'a) bs bs'. \<lbrakk> td_fafu_idem_pair p; wf_fd_pair p; length bs = size_td_pair p; length bs' = size_td_pair p\<rbrakk>
  \<Longrightarrow> access_ti_pair p (update_ti_pair p bs v) bs' = bs"
proof (induct t and st and ts and p)
  case TypScalar thus ?case by (clarsimp simp: fa_fu_idem_def)
next
  case (Cons_typ_desc p' ts' v bs bs')
  hence "fu_commutes (update_ti_pair_t p') (update_ti_list_t ts')" by clarsimp
  moreover
  have "update_ti_pair p' (take (size_td_pair p') bs) = update_ti_pair_t p' (take (size_td_pair p') bs)"
    using Cons_typ_desc.prems by (simp add: update_ti_pair_t_def min_ll)
  moreover
  have "update_ti_list ts' (drop (size_td_pair p') bs) = update_ti_list_t ts' (drop (size_td_pair p') bs)"
    using Cons_typ_desc.prems by (simp add: update_ti_list_t_def)
  ultimately have updeq:
    "(update_ti_pair p' (take (size_td_pair p') bs) (update_ti_list ts' (drop (size_td_pair p') bs) v))
    = (update_ti_list ts' (drop (size_td_pair p') bs) (update_ti_pair p' (take (size_td_pair p') bs) v))"
    unfolding fu_commutes_def by simp

  show ?case using Cons_typ_desc.prems
    by (clarsimp simp add: Cons_typ_desc.hyps) (simp add: updeq  Cons_typ_desc.hyps)
qed simp+

lemma access_ti_pair_dt_fst:
  "access_ti_pair p v bs = access_ti (dt_fst p) v bs"
  by (cases p, simp)

lemma size_td_pair_dt_fst:
  "size_td_pair p = size_td (dt_fst p)"
  by (cases p, simp)

lemma wf_fd_pair_dt_fst:
  "wf_fd_pair p = wf_fd (dt_fst p)"
  by (cases p, simp)

lemma field_lookup_offset2:
  assumes fl: "(field_lookup t f (m + n) = Some (s, q))"
  shows   "field_lookup t f m = Some (s, q - n)"
proof -
  from fl have le: "m + n \<le> q"
    by (rule field_lookup_offset_le)

  hence "q = (m + n) + (q - (m + n))"
    by simp

  hence "field_lookup t f (m + n) = Some (s, (m + n) + (q - (m + n)))" using fl by simp

  hence "field_lookup t f m = Some (s, m + (q - (m + n)))"
    by (rule iffD1 [OF field_lookup_offset'(1)])

  thus ?thesis using le by simp
qed

lemma field_lookup_offset2_list:
  assumes fl: "(field_lookup_list ts f (m + n) = Some (s, q))"
  shows   "field_lookup_list ts f m = Some (s, q - n)"
proof -
  from fl have le: "m + n \<le> q"
    by (rule field_lookup_offset_le)

  hence "q = (m + n) + (q - (m + n))"
    by simp

  hence "field_lookup_list ts f (m + n) = Some (s, (m + n) + (q - (m + n)))" using fl by simp

  hence "field_lookup_list ts f m = Some (s, m + (q - (m + n)))"
    by (rule iffD1 [OF field_lookup_offset'(3)])

  thus ?thesis using le by simp
qed

lemma field_lookup_offset2_pair:
  assumes fl: "(field_lookup_pair p f (m + n) = Some (s, q))"
  shows   "field_lookup_pair p f m = Some (s, q - n)"
proof -
  from fl have le: "m + n \<le> q"
    by (rule field_lookup_offset_le)

  hence "q = (m + n) + (q - (m + n))"
    by simp

  hence "field_lookup_pair p f (m + n) = Some (s, (m + n) + (q - (m + n)))" using fl by simp

  hence "field_lookup_pair p f m = Some (s, m + (q - (m + n)))"
    by (rule iffD1 [OF field_lookup_offset'(4)])

  thus ?thesis using le by simp
qed

lemma field_lookup_offset_size':
  shows "field_lookup t f 0 = Some (t',n) \<Longrightarrow> size_td t' + n \<le> size_td t"
  apply(drule td_set_field_lookupD)
  apply(erule td_set_offset_size)
done

lemma field_access_update_nth_inner:
  shows "\<And>f (s :: 'a :: mem_type field_desc typ_desc) n x v bs bs'.
  \<lbrakk> field_lookup t f 0 = Some (s, n); n \<le> x; x < n + size_td s; td_fafu_idem s; wf_fd s; wf_fd t;
  length bs = size_td s; length bs' = size_td t \<rbrakk>
  \<Longrightarrow> access_ti t (update_ti s bs v) bs' ! x = bs ! (x - n)"

  and "\<And>f (s :: 'a  :: mem_type field_desc typ_desc) n x v bs bs'.
  \<lbrakk>field_lookup_struct st f 0 = Some (s, n); n \<le> x; x < n + size_td s; td_fafu_idem s; wf_fd s; wf_fd_struct st;
  length bs = size_td s; length bs' = size_td_struct st \<rbrakk>
  \<Longrightarrow> access_ti_struct st (update_ti s bs v) bs' ! x = bs ! (x - n)"

  and "\<And>f (s :: 'a  :: mem_type field_desc typ_desc) n x v bs bs'.
  \<lbrakk>field_lookup_list ts f 0 = Some (s, n); n \<le> x; x < n + size_td s; td_fafu_idem s; wf_fd s; wf_fd_list ts;
  length bs = size_td s; length bs' = size_td_list ts\<rbrakk>
  \<Longrightarrow> access_ti_list ts (update_ti s bs v) bs' ! x = bs ! (x - n)"

  and "\<And>f (s :: 'a  :: mem_type field_desc typ_desc) n x v bs bs'.
  \<lbrakk>field_lookup_pair p f 0 = Some (s, n); n \<le> x; x < n + size_td s; td_fafu_idem s; wf_fd s; wf_fd_pair p;
  length bs = size_td s; length bs' = size_td_pair p\<rbrakk>
  \<Longrightarrow> access_ti_pair p (update_ti s bs v) bs' ! x = bs ! (x - n)"
proof (induct t and st and ts and p)
  case (TypDesc typ_struct ls f s n x v bs bs')

  show ?case
  proof (cases "f = []")
    case False thus ?thesis using TypDesc by clarsimp
  next
    case True
    thus ?thesis using TypDesc.prems
      by (simp add: field_access_update_same)
  qed
next
  case (Cons_typ_desc p' ts' f s n x v bs bs')
  have nlex: "n \<le> x" and xln: "x < n + size_td s"
    and lbs: "length bs = size_td s" and lbs': "length bs' = size_td_list (p' # ts')" by fact+
  from Cons_typ_desc have wf: "wf_fd (dt_fst p')" and wfts: "wf_fd_list ts'" by (cases p', auto)

  {
    assume fl: "field_lookup_list ts' f (size_td (dt_fst p')) = Some (s, n)"

    hence mlt: "size_td (dt_fst p') \<le> n"
      by (rule field_lookup_offset_le)

    hence "size_td (dt_fst p') \<le> x"
      by (rule order_trans) fact

    hence ?case using wf lbs lbs'
    proof (simp add: nth_append length_fa_ti access_ti_pair_dt_fst size_td_pair_dt_fst)
      from fl have fl': "field_lookup_list ts' f 0 = Some (s, n - size_td (dt_fst p'))"
        by (rule field_lookup_offset2_list [where m = 0, simplified])

      show "access_ti_list ts' (update_ti s bs v) (drop (size_td (dt_fst p')) bs') ! (x - size_td (dt_fst p')) = bs ! (x - n)"
        using mlt nlex xln lbs lbs' wf wfts \<open>td_fafu_idem s\<close> \<open>wf_fd s\<close>
        by (simp add: Cons_typ_desc.hyps(2) [OF fl'] size_td_pair_dt_fst)
    qed
  }
  moreover
  {
    note ih = Cons_typ_desc.hyps(1)[simplified access_ti_pair_dt_fst wf_fd_pair_dt_fst]

    assume fl: "field_lookup_pair p' f 0 = Some (s, n)"

    hence "x < size_td (dt_fst p')"
      apply (cases p')
      apply (simp split: if_split_asm)
      apply (drule field_lookup_offset_size')
      apply (rule order_less_le_trans [OF xln])
      apply simp
      done

    hence ?case using wf lbs lbs' nlex xln wf wfts \<open>td_fafu_idem s\<close> \<open>wf_fd s\<close>
      by (simp add: nth_append length_fa_ti access_ti_pair_dt_fst size_td_pair_dt_fst ih[OF fl])
  }
  ultimately show ?case using \<open>field_lookup_list (p' # ts') f 0 = Some (s, n)\<close> by (simp split: option.splits)
qed (clarsimp split: if_split_asm)+

subsection \<open>td_fa_hi\<close>

(* \<lbrakk> size_of TYPE('a::mem_type) \<le> length h; size_of TYPE('a) \<le> length h' \<rbrakk> \<Longrightarrow> *)

lemma fa_heap_indepD:
  "\<lbrakk> fa_heap_indep fd n; length bs = n; length bs' = n \<rbrakk> \<Longrightarrow>
  field_access fd v bs = field_access fd v bs'"
  unfolding fa_heap_indep_def
  apply (drule spec, drule spec, drule spec)
  apply (drule (1) mp)
  apply (erule (1) mp)
  done

(* The simplifier spins on the IHs here, hence the proofs for each case *)
lemma td_fa_hi_heap_independence:
  shows "\<And>(v :: 'a :: mem_type) h h'. \<lbrakk> td_fa_hi t; length h = size_td t; length h' = size_td t \<rbrakk>
  \<Longrightarrow> access_ti t v h = access_ti t v h'"
  and   "\<And>(v :: 'a :: mem_type) h h'. \<lbrakk> td_fa_hi_struct st; length h = size_td_struct st; length h' = size_td_struct st\<rbrakk>
  \<Longrightarrow> access_ti_struct st v h = access_ti_struct st v h'"
  and   "\<And>(v :: 'a :: mem_type) h h'. \<lbrakk> td_fa_hi_list ts;  length h = size_td_list ts; length h' = size_td_list ts \<rbrakk>
  \<Longrightarrow> access_ti_list ts v h = access_ti_list ts v h'"
  and   "\<And>(v :: 'a :: mem_type) h h'. \<lbrakk> td_fa_hi_pair p;  length h = size_td_pair p; length h' = size_td_pair p \<rbrakk>
  \<Longrightarrow> access_ti_pair p v h = access_ti_pair p v h'"
proof (induct t and st and ts and p)
  case TypDesc
  from TypDesc.prems show ?case
    by (simp) (erule (2) TypDesc.hyps)
next
  case TypScalar
  from TypScalar.prems show ?case
    by simp (erule (2) fa_heap_indepD)
next
  case TypAggregate
  from TypAggregate.prems show ?case
    by (simp) (erule (2) TypAggregate.hyps)
next
  case Nil_typ_desc thus ?case by simp
next
  case Cons_typ_desc
  from Cons_typ_desc.prems show ?case
    apply simp
    apply (erule conjE)
    apply (rule arg_cong2 [where f = "(@)"])
    apply (erule Cons_typ_desc.hyps; simp)
    apply (erule Cons_typ_desc.hyps; simp)
    done
next
  case DTPair_typ_desc
  from DTPair_typ_desc.prems show ?case
    by simp (erule (2) DTPair_typ_desc.hyps)
qed

section \<open>Simp rules for deriving packed props from the type combinators\<close>

subsection \<open>td_fafu_idem\<close>

lemma td_fafu_idem_final_pad:
  "padup (2 ^ align_td t) (size_td t) = 0
  \<Longrightarrow> td_fafu_idem (final_pad t) = td_fafu_idem t"
  unfolding final_pad_def
  by (clarsimp simp add: padup_def Let_def)

lemma td_fafu_idem_ti_typ_pad_combine:
  fixes t :: "'a :: c_type itself" and s :: "'b :: c_type field_desc typ_desc"
  assumes pad: "padup (align_of TYPE('a)) (size_td s) = 0"
  shows "td_fafu_idem (ti_typ_pad_combine t xf xfu nm s) = td_fafu_idem (ti_typ_combine t xf xfu nm s)"
  unfolding ti_typ_pad_combine_def using pad
  by (clarsimp simp: Let_def)

lemma td_fafu_idem_list_append:
  fixes xs :: "'a :: c_type field_desc typ_pair list"
  shows "td_fafu_idem_list (xs @ ys) = (td_fafu_idem_list xs \<and> td_fafu_idem_list ys)"
  by (induct xs) simp+

lemma td_fafu_idem_extend_ti:
  fixes t :: "'a :: c_type field_desc typ_desc"
  assumes as: "td_fafu_idem s"
  and     at: "td_fafu_idem t"
  shows "td_fafu_idem (extend_ti s t nm)" using as at
  by (cases s, rename_tac typ_struct xs)
     (case_tac typ_struct; simp add: td_fafu_idem_list_append)

lemma fd_cons_access_updateD:
  "\<lbrakk> fd_cons_access_update d n; length bs = n; length bs' = n\<rbrakk> \<Longrightarrow>
   field_access d (field_update d bs v) bs' = field_access d (field_update d bs v') bs'"
  unfolding fd_cons_access_update_def by clarsimp

lemma fa_fu_idem_update_desc:
  fixes a :: "'a field_desc"
  assumes fg: "fg_cons xf xfu"
  and     fd: "fd_cons_struct (TypScalar n n' a)"
  shows   "fa_fu_idem (update_desc xf xfu a) n = fa_fu_idem a n"
proof
  assume asm: "fa_fu_idem (update_desc xf xfu a) n"

  let ?fu = "\<lambda>bs. if length bs = n then field_update a bs else id"
  let ?a' = "\<lparr> field_access = field_access a, field_update = ?fu \<rparr>"

  show "fa_fu_idem a n"
    unfolding fa_fu_idem_def
  proof (intro impI conjI allI)
    fix bs :: "byte list" and bs' :: "byte list" and v
    assume l: "length bs = n" and l': "length bs' = n"

    hence "(\<forall>v. field_access a (field_update a bs (xf v)) bs' = bs)
           = (\<forall>v. field_access a (?fu bs (xf v)) bs' = bs)" by simp

    also have "\<dots> = (\<forall>v. field_access a (field_update a bs v) bs' = bs)" using fd
      apply -
      apply (rule iffI)
       apply (rule allI)
       apply (subst (asm) fd_cons_access_updateD [OF _ l l', where d = ?a', simplified])
        apply (simp add: fd_cons_struct_def fd_cons_desc_def)
       apply (fastforce simp: l l')
      apply (fastforce simp: l l')
      done

    finally show "field_access a (field_update a bs v) bs' = bs" using asm fg l l'
      by (clarsimp simp add: update_desc_def fa_fu_idem_def fg_cons_def)
  qed
next
  assume "fa_fu_idem a n"
  thus "fa_fu_idem (update_desc xf xfu a) n"
    unfolding fa_fu_idem_def update_desc_def using fg
    by (clarsimp simp add: update_desc_def fa_fu_idem_def fg_cons_def)
qed

lemma td_fafu_idem_map_td_update_desc:
  assumes fg: "fg_cons xf xfu"
  shows  "wf_fd t \<Longrightarrow> td_fafu_idem (map_td (\<lambda>_ _. update_desc xf xfu) t) = td_fafu_idem t"
  and    "wf_fd_struct st \<Longrightarrow> td_fafu_idem_struct (map_td_struct (\<lambda>_ _. update_desc xf xfu) st) = td_fafu_idem_struct st"
  and    "wf_fd_list ts \<Longrightarrow> td_fafu_idem_list (map_td_list (\<lambda>_ _. update_desc xf xfu) ts) = td_fafu_idem_list ts"
  and    "wf_fd_pair p \<Longrightarrow> td_fafu_idem_pair (map_td_pair (\<lambda>_ _. update_desc xf xfu) p) = td_fafu_idem_pair p"
  by (induct t and st and ts and p) (auto elim!: fa_fu_idem_update_desc [OF fg])

lemmas td_fafu_idem_adjust_ti = td_fafu_idem_map_td_update_desc(1)[folded adjust_ti_def]

lemma td_fafu_idem_ti_typ_combine:
  fixes s :: "'b :: c_type field_desc typ_desc"
  assumes fg: "fg_cons xf xfu"
  and    tda: "td_fafu_idem (typ_info_t TYPE('a :: mem_type))"
  and    tds: "td_fafu_idem s"
  shows "td_fafu_idem (ti_typ_combine TYPE('a :: mem_type) xf xfu nm s)"
  unfolding ti_typ_combine_def using tda tds
  apply (clarsimp simp: Let_def)
  apply (cases s)
  apply (rename_tac typ_struct xs)
  apply (case_tac typ_struct)
   apply simp
   apply (subst td_fafu_idem_adjust_ti [OF fg wf_fd], assumption)
  apply (simp add: td_fafu_idem_list_append)
  apply (subst td_fafu_idem_adjust_ti [OF fg wf_fd], assumption)
  done

lemma td_fafu_idem_ptr:
   "td_fafu_idem (typ_info_t TYPE('a :: c_type ptr))"
  apply (clarsimp simp add: fa_fu_idem_def)
  apply (subst word_rsplit_rcat_size)
   apply (clarsimp simp add: size_of_def word_size)
  apply simp
  done

lemma td_fafu_idem_word:
   "td_fafu_idem (typ_info_t TYPE('a :: len8 word))"
  apply(clarsimp simp: fa_fu_idem_def)
  apply (subst word_rsplit_rcat_size)
   apply (insert len8_dv8)
   apply (clarsimp simp add: size_of_def word_size)
   apply (subst dvd_div_mult_self; simp)
  apply simp
  done

lemma fg_cons_array [simp]:
  "n < card (UNIV :: 'b :: finite set) \<Longrightarrow>
   fg_cons (\<lambda>x. index x n) (\<lambda>x f. Arrays.update (f :: 'a['b]) n x)"
  unfolding fg_cons_def by simp

lemma td_fafu_idem_array_n:
  "\<lbrakk> td_fafu_idem (typ_info_t TYPE('a)); n \<le> card (UNIV :: 'b set) \<rbrakk> \<Longrightarrow>
   td_fafu_idem (array_tag_n n :: ('a :: mem_type ['b :: finite]) field_desc typ_desc)"
  by (induct n; simp add: array_tag_n.simps empty_typ_info_def)
     (simp add: td_fafu_idem_ti_typ_combine)

lemma td_fafu_idem_array:
  "td_fafu_idem (typ_info_t TYPE('a)) \<Longrightarrow> td_fafu_idem (typ_info_t TYPE('a :: mem_type ['b :: finite]))"
  by (clarsimp simp: typ_info_array array_tag_def fa_fu_idem_def td_fafu_idem_array_n)

lemma td_fafu_idem_empty_typ_info:
  "td_fafu_idem (empty_typ_info t)"
  unfolding empty_typ_info_def
  by simp

subsection \<open>td_fa_hi\<close>

(* These are mostly identical to the above --- surely there is something which implies both? *)

lemma td_fa_hi_final_pad:
  "padup (2 ^ align_td t) (size_td t) = 0
  \<Longrightarrow> td_fa_hi (final_pad t) = td_fa_hi t"
  unfolding final_pad_def
  by (clarsimp simp add: padup_def Let_def)

lemma td_fa_hi_ti_typ_pad_combine:
  fixes t :: "'a :: c_type itself" and s :: "'b :: c_type field_desc typ_desc"
  assumes pad: "padup (align_of TYPE('a)) (size_td s) = 0"
  shows "td_fa_hi (ti_typ_pad_combine t xf xfu nm s) = td_fa_hi (ti_typ_combine t xf xfu nm s)"
  unfolding ti_typ_pad_combine_def using pad
  by (clarsimp simp: Let_def)

lemma td_fa_hi_list_append:
  fixes xs :: "'a :: c_type field_desc typ_pair list"
  shows "td_fa_hi_list (xs @ ys) = (td_fa_hi_list xs \<and> td_fa_hi_list ys)"
  by (induct xs) simp+

lemma td_fa_hi_extend_ti:
  fixes t :: "'a :: c_type field_desc typ_desc"
  assumes as: "td_fa_hi s"
  and     at: "td_fa_hi t"
  shows "td_fa_hi (extend_ti s t nm)" using as at
  by (cases s, rename_tac typ_struct xs)
     (case_tac typ_struct; simp add: td_fa_hi_list_append)

lemma fa_heap_indep_update_desc:
  fixes a :: "'a field_desc"
  assumes fg: "fg_cons xf xfu"
  and     fd: "fd_cons_struct (TypScalar n n' a)"
  shows   "fa_heap_indep (update_desc xf xfu a) n = fa_heap_indep a n"
proof
  assume asm: "fa_heap_indep (update_desc xf xfu a) n"

  have xf_xfu: "\<And>v v'. xf (xfu v v') = v" using fg
    unfolding fg_cons_def
    by simp

  show "fa_heap_indep a n"
    unfolding fa_heap_indep_def
  proof (intro impI conjI allI)
    fix bs :: "byte list" and bs' :: "byte list" and v
    assume l: "length bs = n" and l': "length bs' = n"
    with asm
    have "field_access (update_desc xf xfu a) (xfu v undefined) bs =
          field_access (update_desc xf xfu a) (xfu v undefined) bs'"
      by (rule fa_heap_indepD)

    thus "field_access a v bs = field_access a v bs'"
      unfolding update_desc_def
      by (simp add: xf_xfu)
  qed
next
  assume asm: "fa_heap_indep a n"
  show "fa_heap_indep (update_desc xf xfu a) n"
    unfolding fa_heap_indep_def update_desc_def
  proof (simp, intro impI conjI allI)
    fix bs :: "byte list" and bs' :: "byte list" and v
    assume l: "length bs = n" and l': "length bs' = n"

    with asm show "field_access a (xf v) bs = field_access a (xf v) bs'"
      by (rule fa_heap_indepD)
  qed
qed

lemma td_fa_hi_map_td_update_desc:
  assumes fg: "fg_cons xf xfu"
  shows  "wf_fd t \<Longrightarrow> td_fa_hi (map_td (\<lambda>_ _. update_desc xf xfu) t) = td_fa_hi t"
  and    "wf_fd_struct st \<Longrightarrow> td_fa_hi_struct (map_td_struct (\<lambda>_ _. update_desc xf xfu) st) = td_fa_hi_struct st"
  and    "wf_fd_list ts \<Longrightarrow> td_fa_hi_list (map_td_list (\<lambda>_ _. update_desc xf xfu) ts) = td_fa_hi_list ts"
  and    "wf_fd_pair p \<Longrightarrow> td_fa_hi_pair (map_td_pair (\<lambda>_ _. update_desc xf xfu) p) = td_fa_hi_pair p"
  by (induct t and st and ts and p) (auto elim!: fa_heap_indep_update_desc [OF fg])

lemmas td_fa_hi_adjust_ti = td_fa_hi_map_td_update_desc(1)[folded adjust_ti_def]

lemma td_fa_hi_ti_typ_combine:
  fixes s :: "'b :: c_type field_desc typ_desc"
  assumes fg: "fg_cons xf xfu"
  and    tda: "td_fa_hi (typ_info_t TYPE('a :: mem_type))"
  and    tds: "td_fa_hi s"
  shows "td_fa_hi (ti_typ_combine TYPE('a :: mem_type) xf xfu nm s)"
  unfolding ti_typ_combine_def Let_def using tda tds
  by (cases s, rename_tac typ_struct xs)
     (case_tac typ_struct; simp add: td_fa_hi_list_append td_fa_hi_adjust_ti[OF fg wf_fd])

lemma td_fa_hi_ptr:
   "td_fa_hi (typ_info_t TYPE('a :: c_type ptr))"
  by (clarsimp simp add: fa_heap_indep_def)

lemma td_fa_hi_word:
   "td_fa_hi (typ_info_t TYPE('a :: len8 word))"
  by (clarsimp simp add: fa_heap_indep_def)

lemma td_fa_hi_array_n:
  "\<lbrakk>td_fa_hi (typ_info_t TYPE('a)); n \<le> card (UNIV :: 'b set) \<rbrakk> \<Longrightarrow> td_fa_hi (array_tag_n n :: ('a :: mem_type ['b :: finite]) field_desc typ_desc)"
  by (induct n; simp add: array_tag_n.simps empty_typ_info_def td_fa_hi_ti_typ_combine)

lemma td_fa_hi_array:
  "td_fa_hi (typ_info_t TYPE('a)) \<Longrightarrow> td_fa_hi (typ_info_t TYPE('a :: mem_type ['b :: finite]))"
  by (clarsimp simp add: typ_info_array array_tag_def fa_fu_idem_def td_fa_hi_array_n)

lemma td_fa_hi_empty_typ_info:
  "td_fa_hi (empty_typ_info t)"
  unfolding empty_typ_info_def
  by simp

section \<open>The type class and simp sets\<close>

text \<open>Packed types, with no padding, have the defining property that
        access is invariant under substitution of the underlying heap and
        access/update is the identity\<close>

class packed_type = mem_type +
  assumes td_fafu_idem: "td_fafu_idem (typ_info_t TYPE('a::c_type))"
  assumes td_fa_hi:     "td_fa_hi (typ_info_t TYPE('a::c_type))"

lemmas td_fafu_idem_intro_simps =
  \<comment> \<open>Axioms\<close>
  td_fafu_idem
  \<comment> \<open>Combinators\<close>
  td_fafu_idem_final_pad td_fafu_idem_ti_typ_pad_combine td_fafu_idem_ti_typ_combine td_fafu_idem_empty_typ_info
  \<comment> \<open>Constructors\<close>
  td_fafu_idem_ptr td_fafu_idem_word td_fafu_idem_array

lemmas td_fa_hi_intro_simps =
  \<comment> \<open>Axioms\<close>
  td_fa_hi
  \<comment> \<open>Combinators\<close>
  td_fa_hi_final_pad td_fa_hi_ti_typ_pad_combine td_fa_hi_ti_typ_combine td_fa_hi_empty_typ_info
  \<comment> \<open>Constructors\<close>
  td_fa_hi_ptr td_fa_hi_word td_fa_hi_array

lemma align_td_array':
  "align_td (typ_info_t TYPE('a :: c_type['b :: finite])) = align_td (typ_info_t TYPE('a))"
  by (simp add: typ_info_array array_tag_def align_td_array_tag)

lemmas packed_type_intro_simps =
  td_fafu_idem_intro_simps td_fa_hi_intro_simps align_td_array' size_td_simps size_td_array

lemma access_ti_append':
  "\<And>list.
   access_ti_list (xs @ ys) t list =
     access_ti_list xs t (take (size_td_list xs) list) @
     access_ti_list ys t (drop (size_td_list xs) list)"
proof(induct xs)
  case Nil show ?case by simp
next
  case (Cons x xs) thus ?case by (simp add: min_def ac_simps drop_take)
qed

section \<open>Instances\<close>

text \<open>Words (of multiple of 8 size) are packed\<close>

instantiation word :: (len8) packed_type
begin
instance
  by (intro_classes; rule td_fafu_idem_word td_fa_hi_word)
end

text \<open>Pointers are always packed\<close>

instantiation ptr :: (c_type)packed_type
begin
instance
  by (intro_classes; simp add: fa_fu_idem_def word_rsplit_rcat_size word_size fa_heap_indep_def)
end

text \<open>Arrays of packed types are in turn packed\<close>

class array_outer_packed = packed_type + array_outer_max_size
class array_inner_packed = array_outer_packed + array_inner_max_size

instance word :: (len8)array_outer_packed ..
instance word :: (len8)array_inner_packed ..

instance array :: (array_outer_packed, array_max_count) packed_type
  by (intro_classes; simp add: td_fafu_idem_intro_simps td_fa_hi_intro_simps)

instance array :: (array_inner_packed, array_max_count) array_outer_packed ..

section \<open>Theorems about packed types\<close>

subsection \<open>td_fa_hi\<close>

lemma heap_independence:
  "\<lbrakk>length h = size_of TYPE('a :: packed_type); length h' = size_of TYPE('a) \<rbrakk>
  \<Longrightarrow> access_ti (typ_info_t TYPE('a)) v h = access_ti (typ_info_t TYPE('a)) v h'"
  by (rule td_fa_hi_heap_independence(1)[OF td_fa_hi], simp_all add: size_of_def)

theorem packed_heap_update_collapse:
 fixes u::"'a::packed_type"
 fixes v::"'a"
 shows "heap_update p v (heap_update p u h) = heap_update p v h"
  unfolding heap_update_def
  apply(rule ext)
  apply(case_tac "x \<in> {ptr_val p..+size_of TYPE('a)}")
   apply(simp add: heap_update_mem_same_point)
   apply(simp add:to_bytes_def)
   apply(subst heap_independence, simp)
    prefer 2
    apply(rule refl)
   apply(simp)
  apply(simp add: heap_update_nmem_same)
  done

lemma packed_heap_update_collapse_hrs:
  fixes p :: "'a :: packed_type ptr"
  shows "hrs_mem_update (heap_update p v) (hrs_mem_update (heap_update p v') hp) =
         hrs_mem_update (heap_update p v) hp"
  unfolding hrs_mem_update_def
  by (simp add: split_def packed_heap_update_collapse)

subsection \<open>td_fafu_idem\<close>

lemma order_leE:
  fixes x :: "'a :: order"
  shows "\<lbrakk> x \<le> y; x = y \<Longrightarrow> P; x < y \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto simp: order_le_less)

lemma of_nat_mono_maybe_le:
  shows "\<lbrakk>X < 2 ^ len_of TYPE('a); Y \<le> X\<rbrakk> \<Longrightarrow> (of_nat Y :: 'a :: len word) \<le> of_nat X"
  apply (erule order_leE)
   apply simp
  apply (rule order_less_imp_le)
  apply (erule (1) of_nat_mono_maybe)
  done

lemma intvl_le_lower:
  fixes x :: "'a :: len word"
  shows "\<lbrakk> x \<in> {y..+n}; y \<le> y + of_nat (n - 1); n < 2 ^ len_of TYPE('a) \<rbrakk> \<Longrightarrow> y \<le> x"
  apply (drule intvlD)
  apply (elim conjE exE)
  apply (erule ssubst)
  apply (erule word_plus_mono_right2)
  apply (rule of_nat_mono_maybe_le)
   apply simp
  apply simp
  done

lemma intvl_less_upper:
  fixes x :: "'a :: len word"
  shows "\<lbrakk> x \<in> {y..+n}; y \<le> y + of_nat (n - 1); n < 2 ^ len_of TYPE('a) \<rbrakk> \<Longrightarrow> x \<le> y + of_nat (n - 1)"
  apply (drule intvlD)
  apply (elim conjE exE)
  apply (erule ssubst)
  apply (rule word_plus_mono_right; assumption?)
  apply (rule of_nat_mono_maybe_le; simp)
  done

lemma packed_type_access_ti:
  fixes v :: "'a :: packed_type"
  assumes lbs: "length bs = size_of TYPE('a)"
  shows "access_ti (typ_info_t TYPE('a)) v bs = access_ti\<^sub>0 (typ_info_t TYPE('a)) v"
  unfolding access_ti\<^sub>0_def
  by (rule heap_independence; simp add: lbs size_of_def)

lemma update_ti_update_ti_t:
  "length bs = size_td s \<Longrightarrow> update_ti s bs v = update_ti_t s bs v"
  unfolding update_ti_t_def by simp

lemma heap_list_nth:
  "m < n \<Longrightarrow> heap_list hp n p ! m = hp (p + of_nat m)"
proof (induct m arbitrary: n p)
  case (0 n' p')
  thus ?case by (cases n', simp_all)
next
  case (Suc m' n' p')
  show ?case
  proof (cases n')
    case 0 thus ?thesis using \<open>Suc m' < n'\<close> by simp
  next
    case (Suc n'')
    hence "m' < n''" using \<open>Suc m' < n'\<close> by simp
    thus ?thesis using Suc
      by (simp add: Suc.hyps ac_simps)
  qed
qed

lemma c_guard_field_lvalue:
  fixes p :: "'a :: mem_type ptr"
  assumes cg: "c_guard p"
  and     fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (t, n)"
  and     eu: "export_uinfo t = typ_uinfo_t TYPE('b :: mem_type)"
  shows   "c_guard (Ptr &(p\<rightarrow>f) :: 'b :: mem_type ptr)"
  unfolding c_guard_def
proof (rule conjI)
  from cg fl eu show "ptr_aligned (Ptr &(p\<rightarrow>f) :: 'b ptr)"
    by (rule c_guard_ptr_aligned_fl)
next
  from eu have std: "size_td t = size_of TYPE('b)" using fl
    by (simp add: export_size_of)

  from cg have "c_null_guard p" unfolding c_guard_def ..
  thus "c_null_guard (Ptr &(p\<rightarrow>f)  :: 'b ptr)" unfolding c_null_guard_def
    apply (rule contrapos_nn)
    apply (rule subsetD [OF field_tag_sub, OF fl])
    apply (simp add: std)
    done
qed

lemma c_guard_no_wrap:
  fixes p :: "'a :: mem_type ptr"
  assumes cgrd: "c_guard p"
  shows   "ptr_val p \<le> ptr_val p + of_nat (size_of TYPE('a) - 1)"
  using cgrd unfolding c_guard_def c_null_guard_def
  apply -
  apply (erule conjE)
  apply (erule contrapos_np)
  apply (simp add: intvl_def)
  apply (drule word_wrap_of_natD)
  apply (erule exE)
  apply (rule exI)
  apply (simp add: nat_le_Suc_less)
  done

theorem packed_heap_super_field_update:
  fixes v :: "'a :: packed_type" and p :: "'b :: packed_type ptr"
  assumes fl: "field_lookup (typ_info_t TYPE('b)) f 0 = Some (t, n)"
  and   cgrd: "c_guard p"
  and     eu: "export_uinfo t = typ_uinfo_t TYPE('a)"
  shows   "heap_update (Ptr &(p\<rightarrow>f)) v hp = heap_update p (update_ti t (to_bytes_p v) (h_val hp p)) hp"
  unfolding heap_update_def to_bytes_def
proof (simp add: packed_type_access_ti, rule ext)
  fix x
  let ?LHS = "heap_update_list &(p\<rightarrow>f) (to_bytes_p v) hp x"
  let ?RHS = "heap_update_list (ptr_val p) (to_bytes_p (update_ti t (to_bytes_p v) (h_val hp p))) hp x"

  from cgrd have al: "ptr_val p \<le> ptr_val p + of_nat (size_of TYPE('b) - 1)" by (rule c_guard_no_wrap)

  have szb: "size_of TYPE('b) < 2 ^ len_of TYPE(addr_bitsize)"
    apply (fold card_word)
    apply (fold addr_card_def)
    apply (rule max_size)
    done

  have szt: "n + size_td t \<le> size_of TYPE('b)"
    unfolding size_of_def
    by (subst add.commute, rule field_lookup_offset_size [OF fl])
  moreover have t0: "0 < size_td t" using fl wf_size_desc
    by (rule field_lookup_wf_size_desc_gt)
  ultimately have szn: "n < size_of TYPE('b)" by simp
  from szt have szt1: "n + (size_td t - 1) \<le> size_of TYPE('b)"
    by simp

  have b0: "0 < size_of (TYPE ('b))" using wf_size_desc
    unfolding size_of_def
    by (rule wf_size_desc_gt)

  have uofn: "unat (of_nat n :: addr_bitsize word) = n" using szn szb
    by (simp add: nat_less_le unat_of_nat_eq)

  from eu have std: "size_td t = size_of TYPE('a)" using fl
    by (simp add: export_size_of)

  hence "?LHS = (if x \<in> {&(p\<rightarrow>f)..+size_td t} then (to_bytes_p v) ! unat (x - &(p\<rightarrow>f)) else hp x)"
    by (simp add: heap_update_mem_same_point heap_update_nmem_same)
  also have "... = ?RHS"
  proof (simp, intro impI conjI)
    assume xin: "x \<in> {&(p\<rightarrow>f)..+size_td t}"
    have "to_bytes_p v ! unat (x - &(p\<rightarrow>f)) = to_bytes_p (update_ti t (to_bytes_p v) (h_val hp p)) ! unat (x - ptr_val p)"
    proof (simp add: to_bytes_p_def to_bytes_def, subst field_access_update_nth_inner(1)[OF fl, simplified])

      have "c_guard (Ptr &(p\<rightarrow>f) :: 'a ptr)" using cgrd fl eu
        by (rule c_guard_field_lvalue)
      hence pft: "&(p\<rightarrow>f) \<le> &(p\<rightarrow>f) + of_nat (size_td t - 1)"
        apply -
        apply (drule c_guard_no_wrap)
        apply (simp add: std)
        done

      have szt': "size_td t < 2 ^ len_of TYPE(addr_bitsize)"
        apply (subst std)
        apply (fold card_word)
        apply (fold addr_card_def)
        apply (rule max_size)
        done

      have ofn: "of_nat n \<le> x - ptr_val p"
      proof (rule le_minus')
        from xin show "ptr_val p + of_nat n \<le> x" using pft szt'
          unfolding field_lvalue_def field_lookup_offset_eq [OF fl]
          by (rule intvl_le_lower)
      next
        from szb szn have "of_nat n \<le> (of_nat (size_of TYPE('b) - 1) :: addr_bitsize word)"
          apply -
          apply (rule of_nat_mono_maybe_le)
           apply simp_all
          done
        with al show "ptr_val p \<le> ptr_val p + of_nat n"
          by (rule word_plus_mono_right2)
      qed

      thus nlt: "n \<le> unat (x - ptr_val p)"
        by (simp add: word_le_nat_alt uofn)
      have "x \<le> ptr_val p + (of_nat n + of_nat (size_td t - 1))" using xin pft szt' t0
        unfolding field_lvalue_def field_lookup_offset_eq [OF fl]
        apply -
        apply (drule (2) intvl_less_upper)
        apply (simp add: add.assoc)
        done
      moreover have "x \<in> {ptr_val p..+size_of TYPE('b)}" using fl xin
        by (rule subsetD [OF field_tag_sub])
      ultimately have "x - ptr_val p \<le> (of_nat n + of_nat (size_td t - 1))" using al szb
        apply -
        apply (rule word_diff_ls(4)[where xa=x and x=x for x, simplified])
         apply (metis (hide_lams, mono_tags) add.commute of_nat_add)
        apply (erule (2) intvl_le_lower)
        done
      moreover have "unat (of_nat n + of_nat (size_td t - 1) :: addr_bitsize word) = n + size_td t - 1"
        using t0 order_le_less_trans [OF szt1 szb]
        apply (subst Abs_fnat_homs(1))
        apply (subst unat_of_nat)
        apply simp
        done
      ultimately have "unat (x - ptr_val p) \<le> n + size_td t - 1"
        by (simp add: word_le_nat_alt)
      thus "unat (x - ptr_val p) < n + size_td t" using t0
        by simp

      show "td_fafu_idem t"
        by (rule field_lookup_td_fafu_idem(1)[OF fl td_fafu_idem])

      show "wf_fd t"
        by (rule wf_fd_field_lookupD [OF fl wf_fd])

      show "length (access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0)) = size_td t"
        using wf_fd [where 'a = 'a]
        by (simp add: length_fa_ti size_of_def std)

      show "length (replicate (size_of TYPE('b)) 0) = size_td (typ_info_t TYPE('b))"
        by (simp add: size_of_def)

      have "unat (x - &(p\<rightarrow>f)) = unat ((x - ptr_val p) - of_nat n)"
        by (simp add: field_lvalue_def field_lookup_offset_eq [OF fl])
      also have "\<dots> = unat (x - ptr_val p) - n"
        by (simp add: unat_sub [OF ofn] uofn)
      finally have "unat (x - &(p\<rightarrow>f)) = unat (x - ptr_val p) - n" .

      thus "access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0) ! unat (x - &(p\<rightarrow>f)) =
        access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0) ! (unat (x - ptr_val p) - n)"
        by simp
    qed

    thus "to_bytes_p v ! unat (x - &(p\<rightarrow>f)) = ?RHS"
    proof (subst heap_update_mem_same_point, simp_all)
      show "x \<in> {ptr_val p..+size_of TYPE('b)}" using fl xin
        by (rule subsetD [OF field_tag_sub])
    qed
  next
    assume xni: "x \<notin> {&(p\<rightarrow>f)..+size_td t}"
    have "?RHS = (if x \<in> {ptr_val p..+size_of TYPE('b)}
          then (to_bytes_p (update_ti t (to_bytes_p v) (h_val hp p))) ! unat (x - ptr_val p) else hp x)"
      by (simp add: heap_update_mem_same_point heap_update_nmem_same)

    also
    {
      assume xin: "x \<in> {ptr_val p..+size_of TYPE('b)}"

      hence "access_ti (typ_info_t TYPE('b))
        (update_ti_t t (access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0)) (h_val hp p))
        (replicate (size_of TYPE('b)) 0) ! unat (x - ptr_val p) = hp x"
      proof (subst field_access_update_nth_disjD [OF fl])
        have "x - ptr_val p \<le> of_nat (size_of TYPE('b) - 1)"
        proof (rule word_diff_ls(4)[where xa=x and x=x for x, simplified])
          from xin show "x \<le> of_nat (size_of TYPE('b) - 1) + ptr_val p" using al szb
            by (subst add.commute, rule intvl_less_upper)
          show "ptr_val p \<le> x" using xin al szb
            by (rule intvl_le_lower)
        qed
        thus unx: "unat (x - ptr_val p) < size_td (typ_info_t TYPE('b))" using szb b0
          by (simp add: word_le_nat_alt size_of_def unat_of_nat)

        show "unat (x - ptr_val p) < n - 0 \<or> n - 0 + size_td t \<le> unat (x - ptr_val p)" using xin xni
          unfolding field_lvalue_def field_lookup_offset_eq [OF fl]
          apply -
          apply (erule intvl_cut)
           apply simp
          apply (rule max_size)
          done

        show "wf_fd (typ_info_t TYPE('b))" by (rule wf_fd)
            (* clag *)
        show "length (access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0)) = size_td t"
          using wf_fd [where 'a = 'a]
          by (simp add: length_fa_ti size_of_def std)

        show "length (replicate (size_of TYPE('b)) 0) = size_td (typ_info_t TYPE('b))"
          by (simp add: size_of_def)

        have "heap_list hp (size_td (typ_info_t TYPE('b))) (ptr_val p) ! unat (x - ptr_val p) = hp x"
          apply (subst heap_list_nth)
           apply (rule unx)
          apply simp
          done

        thus "access_ti (typ_info_t TYPE('b)) (h_val hp p) (replicate (size_of TYPE('b)) 0) ! unat (x - ptr_val p) = hp x"
          unfolding h_val_def
          by (simp add: from_bytes_def update_ti_t_def size_of_def field_access_update_same(1)[OF td_fafu_idem wf_fd])
      qed
    }
    hence "\<dots> = hp x"
      by (simp add: to_bytes_p_def to_bytes_def update_ti_update_ti_t length_fa_ti [OF wf_fd] std size_of_def)
    finally show "hp x = ?RHS" by simp
  qed
  finally show "?LHS = ?RHS" .
qed

subsection \<open>Proof automation for packed types\<close>

definition td_packed :: "'a field_desc typ_desc \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "td_packed t sz al \<longleftrightarrow>
    td_fafu_idem t \<and> td_fa_hi t \<and> aggregate t \<and> size_td t = sz \<and> align_td t = al"

lemma packed_type_class_intro:
  "td_packed (typ_info_t TYPE('a::mem_type)) s a
    \<Longrightarrow> OFCLASS('a::mem_type, packed_type_class)"
  by standard (simp_all add: td_packed_def)

lemma td_packed_final_pad:
  "\<lbrakk>td_packed t s a; 2 ^ a dvd s\<rbrakk> \<Longrightarrow> td_packed (final_pad t) s a"
  by (simp add: padup_dvd [symmetric] td_packed_def final_pad_def)

lemma td_packed_ti_typ_combine:
  "\<lbrakk> td_packed (td::'a::c_type field_desc typ_desc) s a;
     align_of TYPE('b::packed_type) dvd s; fg_cons xf xfu \<rbrakk>
    \<Longrightarrow> td_packed (ti_typ_combine TYPE('b) xf xfu nm td)
                  (s + size_td (typ_info_t TYPE('b)))
                  (max a (align_td (typ_info_t TYPE('b))))"
  unfolding td_packed_def
  apply safe
      apply (rule td_fafu_idem_ti_typ_combine; assumption?)
      apply (rule td_fafu_idem)
     apply (rule td_fa_hi_ti_typ_combine; assumption?)
     apply (rule td_fa_hi)
    apply simp
   apply (simp only: size_td_lt_ti_typ_combine)
  apply (simp only: align_of_ti_typ_combine)
  done

lemma td_packed_ti_typ_pad_combine:
  "\<lbrakk> td_packed (td::'a::c_type field_desc typ_desc) s a;
     align_of TYPE('b::packed_type) dvd s; fg_cons xf xfu \<rbrakk>
    \<Longrightarrow> td_packed (ti_typ_pad_combine TYPE('b) xf xfu nm td)
                  (s + size_td (typ_info_t TYPE('b)))
                  (max a (align_td (typ_info_t TYPE('b))))"
  apply (subgoal_tac "padup (align_of TYPE('b)) (size_td td) = 0")
   apply (simp add: ti_typ_pad_combine_def Let_def td_packed_ti_typ_combine)
  apply (simp add: align_of_def padup_dvd td_packed_def)
  done

lemma td_packed_ti_typ_combine_array:
  "\<lbrakk>td_packed (td::'a::c_type field_desc typ_desc) s a;
    align_of TYPE('b::packed_type) dvd s; fg_cons xf xfu\<rbrakk>
    \<Longrightarrow> td_packed
      (ti_typ_combine TYPE('b ['n :: finite]) xf xfu nm td)
      (s + size_td (typ_info_t TYPE('b)) * CARD('n))
      (max a (align_td (typ_info_t TYPE('b))))"
  by (clarsimp simp: ti_typ_combine_def td_packed_def
                     packed_type_intro_simps td_fafu_idem_extend_ti
                     td_fa_hi_extend_ti td_fa_hi_adjust_ti
                     size_td_extend_ti size_of_def
                     td_fafu_idem_adjust_ti)

lemma td_packed_ti_typ_pad_combine_array:
  "\<lbrakk> td_packed (td::'a::c_type field_desc typ_desc) s a;
     align_of TYPE('b::packed_type) dvd s; fg_cons xf xfu \<rbrakk>
    \<Longrightarrow> td_packed (ti_typ_pad_combine TYPE('b ['n :: finite]) xf xfu nm td)
                  (s + size_td (typ_info_t TYPE('b)) * CARD('n))
                  (max a (align_td (typ_info_t TYPE('b))))"
  apply (subgoal_tac "padup (align_of TYPE('b['n])) (size_td td) = 0")
   apply (simp add: ti_typ_pad_combine_def Let_def)
   apply (simp add: td_packed_ti_typ_combine_array)
  apply (simp add: align_of_def padup_dvd td_packed_def align_td_array)
  done

lemma td_packed_empty_typ_info:
  "td_packed (empty_typ_info fn) 0 0"
  apply (unfold td_packed_def, safe)
      apply (rule td_fafu_idem_empty_typ_info)
     apply (rule td_fa_hi_empty_typ_info)
    apply (rule aggregate_empty_typ_info)
   apply (rule size_td_empty_typ_info)
  apply (rule align_of_empty_typ_info)
  done

lemmas td_packed_intros =
  td_packed_final_pad
  td_packed_empty_typ_info
  td_packed_ti_typ_combine
  td_packed_ti_typ_pad_combine
  td_packed_ti_typ_combine_array
  td_packed_ti_typ_pad_combine_array

end


section {* \isaheader{Generic Map To Set Converter} *}
theory Gen_Map2Set
imports
  "../Intf/Intf_Map"
  "../Intf/Intf_Set"
  "../Intf/Intf_Comp"
  "../../Iterator/Iterator"
begin

lemma map_fst_unit_distinct_eq[simp]:
  fixes l :: "('k\<times>unit) list"
  shows "distinct (map fst l) \<longleftrightarrow> distinct l"
  by (induct l) auto

definition
  map2set_rel :: "
    (('ki\<times>'k) set \<Rightarrow> (unit\<times>unit) set \<Rightarrow> ('mi\<times>('k\<rightharpoonup>unit))set) \<Rightarrow>
    ('ki\<times>'k) set \<Rightarrow>
    ('mi\<times>('k set)) set"
  where
  map2set_rel_def_internal:
  "map2set_rel R Rk \<equiv> \<langle>Rk,Id::(unit\<times>_) set\<rangle>R O {(m,dom m)| m. True}"

lemma map2set_rel_def: "\<langle>Rk\<rangle>(map2set_rel R)
  = \<langle>Rk,Id::(unit\<times>_) set\<rangle>R O {(m,dom m)| m. True}"
  unfolding map2set_rel_def_internal[abs_def] by (simp add: relAPP_def)

lemma map2set_relI:
  assumes "(s,m')\<in>\<langle>Rk,Id\<rangle>R" and "s'=dom m'"
  shows "(s,s')\<in>\<langle>Rk\<rangle>map2set_rel R"
  using assms unfolding map2set_rel_def by blast

lemma map2set_relE:
  assumes "(s,s')\<in>\<langle>Rk\<rangle>map2set_rel R"
  obtains m' where "(s,m')\<in>\<langle>Rk,Id\<rangle>R" and "s'=dom m'"
  using assms unfolding map2set_rel_def by blast

lemma map2set_rel_sv[relator_props]:
  "single_valued (\<langle>Rk,Id\<rangle>Rm) \<Longrightarrow> single_valued (\<langle>Rk\<rangle>map2set_rel Rm)"
  unfolding map2set_rel_def
  by (auto intro: single_valuedI dest: single_valuedD)

lemma map2set_empty[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP e op_map_empty (\<langle>Rk,Id\<rangle>R)"
  shows "(e,{})\<in>\<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def
  by auto

lemmas [autoref_rel_intf] =
  REL_INTFI[of "map2set_rel R" i_set] for R

definition "map2set_insert i k s \<equiv> i k () s"
lemma map2set_insert[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP i op_map_update (Rk \<rightarrow> Id \<rightarrow> \<langle>Rk,Id\<rangle>R \<rightarrow> \<langle>Rk,Id\<rangle>R)"
  shows
    "(map2set_insert i,Set.insert)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>map2set_rel R \<rightarrow> \<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def map2set_insert_def[abs_def]
  by (force dest: fun_relD)

definition "map2set_memb l k s \<equiv> case l k s of None \<Rightarrow> False | Some _ \<Rightarrow> True"
lemma map2set_memb[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP l op_map_lookup (Rk \<rightarrow> \<langle>Rk,Id\<rangle>R \<rightarrow> \<langle>Id\<rangle>option_rel)"
  shows "(map2set_memb l ,op\<in>)
    \<in> Rk\<rightarrow>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>Id"
  using assms
  unfolding map2set_rel_def map2set_memb_def[abs_def]
  by (force dest: fun_relD split: option.splits)

lemma map2set_delete[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP d op_map_delete (Rk\<rightarrow>\<langle>Rk,Id\<rangle>R\<rightarrow>\<langle>Rk,Id\<rangle>R)"
  shows "(d,op_set_delete)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>\<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def
  by (force dest: fun_relD)

lemma map2set_to_sorted_list[autoref_ga_rules]:
  fixes it :: "'m \<Rightarrow> ('k\<times>unit) list"
  assumes A: "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Id R it)"
  shows "is_set_to_sorted_list ordR Rk (map2set_rel R)
    (it_to_list (map_iterator_dom o (foldli o it)))"
proof -
  {
    fix l::"('k\<times>unit) list"
    have "\<And>l0. foldli l (\<lambda>_. True) (\<lambda>x \<sigma>. \<sigma> @ [fst x]) l0 = l0@map fst l"
      by (induct l) auto
  }
  hence S: "it_to_list (map_iterator_dom o (foldli o it)) = map fst o it"
    unfolding it_to_list_def[abs_def] map_iterator_dom_def[abs_def]
      set_iterator_image_def set_iterator_image_filter_def
    by (auto)
  show ?thesis
    unfolding S
    using assms
    unfolding is_map_to_sorted_list_def is_set_to_sorted_list_def
    apply clarsimp
    apply (erule map2set_relE)
    apply (drule spec, drule spec)
    apply (drule (1) mp)
    apply (elim exE conjE)
    apply (rule_tac x="map fst l'" in exI)
    apply (rule conjI)
    apply parametricity

    unfolding it_to_sorted_list_def
    apply (simp add: map_to_set_dom)
    apply (simp add: sorted_by_rel_map key_rel_def[abs_def])
    done
qed

lemma map2set_to_list[autoref_ga_rules]:
  fixes it :: "'m \<Rightarrow> ('k\<times>unit) list"
  assumes A: "GEN_ALGO_tag (is_map_to_list Rk Id R it)"
  shows "is_set_to_list Rk (map2set_rel R)
    (it_to_list (map_iterator_dom o (foldli o it)))"
  using assms unfolding is_set_to_list_def is_map_to_list_def
  by (rule map2set_to_sorted_list)

(*lemma map2set_it_simp[iterator_simps]:
  "foldli ((map fst o it) x) c f s = foldli (it x) c (\<lambda>(k,v) s. f k s) s"
  by (simp add: foldli_map comp_def fn_fst_conv)
*)

text {* Transfering also non-basic operations results in specializations
  of map-algorithms to also be used for sets *}
lemma map2set_union[autoref_rules_raw]:
  assumes "MINOR_PRIO_TAG (- 9)"
  assumes "GEN_OP u op ++ (\<langle>Rk,Id\<rangle>R\<rightarrow>\<langle>Rk,Id\<rangle>R\<rightarrow>\<langle>Rk,Id\<rangle>R)"
  shows "(u,op \<union>)\<in>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>\<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def
  by (force dest: fun_relD)

lemmas [autoref_ga_rules] = cmp_unit_eq_linorder
lemmas [autoref_rules_raw] = param_cmp_unit

lemma cmp_lex_zip_unit[simp]:
  "cmp_lex (cmp_prod cmp cmp_unit) (map (\<lambda>k. (k, ())) l)
           (map (\<lambda>k. (k, ())) m) =
          cmp_lex cmp l m"
  apply (induct cmp l m rule: cmp_lex.induct)
  apply (auto split: comp_res.split)
  done

lemma cmp_img_zip_unit[simp]:
  "cmp_img (\<lambda>m. map (\<lambda>k. (k,())) (f m)) (cmp_lex (cmp_prod cmp1 cmp_unit))
    = cmp_img f (cmp_lex cmp1)"
  unfolding cmp_img_def[abs_def]
  apply (intro ext)
  apply simp
  done

(* TODO: Move *)

lemma map2set_finite[relator_props]:
  assumes "finite_map_rel (\<langle>Rk,Id\<rangle>R)"
  shows "finite_set_rel (\<langle>Rk\<rangle>map2set_rel R)"
  using assms
  unfolding map2set_rel_def finite_set_rel_def finite_map_rel_def
  by auto

lemma map2set_cmp[autoref_rules_raw]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmpk)"
  assumes MPAR:
    "GEN_OP cmp (cmp_map cmpk cmp_unit) (\<langle>Rk,Id\<rangle>R \<rightarrow> \<langle>Rk,Id\<rangle>R \<rightarrow> Id)"
  assumes FIN: "PREFER finite_map_rel (\<langle>Rk, Id\<rangle>R)"
  shows "(cmp,cmp_set cmpk)\<in>\<langle>Rk\<rangle>map2set_rel R \<rightarrow> \<langle>Rk\<rangle>map2set_rel R \<rightarrow> Id"
proof -
  interpret linorder "comp2le cmpk" "comp2lt cmpk"
    using ELO by (simp add: eq_linorder_class_conv)

  show ?thesis
    using MPAR
    unfolding cmp_map_def cmp_set_def
    apply simp
    apply parametricity
    apply (drule cmp_extend_paramD)
    apply (insert FIN, fastforce simp add: finite_map_rel_def) []
    apply (simp add: sorted_list_of_map_def[abs_def])
    apply (auto simp: map2set_rel_def cmp_img_def[abs_def] dest: fun_relD) []

    apply (insert map2set_finite[OF FIN[unfolded autoref_tag_defs]],
      fastforce simp add: finite_set_rel_def)
    done
qed

end


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

chapter \<open>Memory Models\<close>

theory MM
imports
  "../Common/Heap"
begin

type_synonym addr = nat
type_synonym thread_id = addr

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

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

instantiation nat :: addr begin
definition "hash_addr \<equiv> int"
definition "monitor_finfun_to_list \<equiv> (finfun_to_list :: nat \<Rightarrow>f nat \<Rightarrow> nat list)"
instance
by(intro_classes)(simp add: monitor_finfun_to_list_nat_def)
end

definition new_Addr :: "(addr \<rightharpoonup> 'b) \<Rightarrow> addr option"
where "new_Addr h \<equiv> if \<exists>a. h a = None then Some(LEAST a. h a = None) else None"

lemma new_Addr_SomeD:
  "new_Addr h = Some a \<Longrightarrow> h a = None"
by(auto simp add:new_Addr_def split:if_splits intro: LeastI)

lemma new_Addr_SomeI:
  "finite (dom h) \<Longrightarrow> \<exists>a. new_Addr h = Some a"
by(simp add: new_Addr_def) (metis finite_map_freshness infinite_UNIV_nat)

subsection \<open>Code generation\<close>

definition gen_new_Addr :: "(addr \<rightharpoonup> 'b) \<Rightarrow> addr \<Rightarrow> addr option"
where "gen_new_Addr h n \<equiv> if \<exists>a. a \<ge> n \<and> h a = None then Some(LEAST a. a \<ge> n \<and> h a = None) else None"

lemma new_Addr_code_code [code]:
  "new_Addr h = gen_new_Addr h 0"
by(simp add: new_Addr_def gen_new_Addr_def)

lemma gen_new_Addr_code [code]:
  "gen_new_Addr h n = (if h n = None then Some n else gen_new_Addr h (Suc n))"
apply(simp add: gen_new_Addr_def)
apply(rule impI)
apply(rule conjI)
 apply safe[1]
  apply(auto intro: Least_equality)[2]
 apply(rule arg_cong[where f=Least])
 apply(rule ext)
 apply auto[1]
 apply(case_tac "n = ab")
  apply simp
 apply simp
apply clarify
apply(subgoal_tac "a = n")
 apply simp
 apply(rule Least_equality)
 apply auto[2]
apply(rule ccontr)
apply(erule_tac x="a" in allE)
apply simp
done

end


(*
   Title: Psi-calculi
   Based on the AFP entry by Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weaken_Transition
  imports Weakening
begin

context weak
begin

definition weakenTransition :: "'b \<Rightarrow> ('a, 'b, 'c) psi \<Rightarrow> 'a frame frame option \<Rightarrow> 'a action \<Rightarrow> ('a, 'b, 'c) psi \<Rightarrow> bool" ("_ \<rhd> _ \<Longrightarrow>_ @ _ \<prec> _" [80, 80, 80, 80, 80] 80)
where
  "\<Psi> \<rhd> P \<Longrightarrow>\<pi> @ \<alpha> \<prec> P' \<equiv> (\<exists>P''' P''. \<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P''' \<and> \<Psi> \<rhd> P''' \<longmapsto>\<pi> @ \<alpha> \<prec> P'' \<and> \<Psi> \<rhd> P'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> P') \<or> (P = P' \<and> \<alpha> = \<tau>)"

lemma weakenTransitionCases[consumes 1, case_names cBase cStep]:
  assumes "\<Psi> \<rhd> P \<Longrightarrow>\<pi> @ \<alpha> \<prec> P'"
  and "Prop (\<tau>) \<pi> P"
  and "\<And>P''' P''. \<lbrakk>\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'''; \<Psi> \<rhd> P''' \<longmapsto>\<pi> @ \<alpha> \<prec> P''; \<Psi> \<rhd> P'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'\<rbrakk> \<Longrightarrow> Prop \<alpha> \<pi> P'"

  shows "Prop \<alpha> \<pi> P'"
using assms
by(auto simp add: weakenTransition_def)

lemma statImpTauChainDerivative:
  fixes \<Psi>   :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   P'   :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'"

  shows "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame P') \<Psi>"
using assms
by(induct rule: tau_chain_induct) (auto intro: statImpTauDerivative dest: Frame_stat_imp_trans)

lemma weakenTauChain:
  fixes \<Psi>  :: 'b
  and   P  :: "('a, 'b, 'c) psi"
  and   P' :: "('a, 'b, 'c) psi"
  and   \<Psi>' :: 'b

  assumes "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'"
  shows "\<Psi> \<otimes> \<Psi>' \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'"
using assms
proof(induct rule: tau_chain_induct)
  case(tau_base P)
  thus ?case by simp
next
  case(tau_step P P' P'')
  note `\<Psi> \<otimes> \<Psi>' \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'`
  moreover from `\<Psi> \<rhd> P' \<longmapsto>None @ \<tau> \<prec> P''` have "\<Psi> \<otimes> \<Psi>' \<rhd> P' \<longmapsto>None @ \<tau> \<prec> P''" by(rule weakenTransition)
  ultimately show ?case by(auto dest: tau_act_tau_chain)
qed

end

end


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

header {* \chapter{Memory Models} *}

theory MM
imports
  "../Common/Heap"
begin

type_synonym addr = nat
type_synonym thread_id = addr

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

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

instantiation nat :: addr begin
definition "hash_addr \<equiv> int"
definition "monitor_finfun_to_list \<equiv> (finfun_to_list :: nat \<Rightarrow>f nat \<Rightarrow> nat list)"
instance
by(intro_classes)(simp add: monitor_finfun_to_list_nat_def)
end

definition new_Addr :: "(addr \<rightharpoonup> 'b) \<Rightarrow> addr option"
where "new_Addr h \<equiv> if \<exists>a. h a = None then Some(LEAST a. h a = None) else None"

lemma new_Addr_SomeD:
  "new_Addr h = Some a \<Longrightarrow> h a = None"
by(auto simp add:new_Addr_def split:if_splits intro: LeastI)

lemma new_Addr_SomeI:
  "finite (dom h) \<Longrightarrow> \<exists>a. new_Addr h = Some a"
by(simp add: new_Addr_def) (metis finite_map_freshness infinite_UNIV_nat)

subsection {* Code generation *}

definition gen_new_Addr :: "(addr \<rightharpoonup> 'b) \<Rightarrow> addr \<Rightarrow> addr option"
where "gen_new_Addr h n \<equiv> if \<exists>a. a \<ge> n \<and> h a = None then Some(LEAST a. a \<ge> n \<and> h a = None) else None"

lemma new_Addr_code_code [code]:
  "new_Addr h = gen_new_Addr h 0"
by(simp add: new_Addr_def gen_new_Addr_def)

lemma gen_new_Addr_code [code]:
  "gen_new_Addr h n = (if h n = None then Some n else gen_new_Addr h (Suc n))"
apply(simp add: gen_new_Addr_def)
apply(rule impI)
apply(rule conjI)
 apply safe[1]
  apply(auto intro: Least_equality)[2]
 apply(rule arg_cong[where f=Least])
 apply(rule ext)
 apply auto[1]
 apply(case_tac "n = ab")
  apply simp
 apply simp
apply clarify
apply(subgoal_tac "a = n")
 apply simp
 apply(rule Least_equality)
 apply auto[2]
apply(rule ccontr)
apply(erule_tac x="a" in allE)
apply simp
done

end


section {* Refinement calculus *}

theory utp_refcalc
  imports utp_designs
begin

abbreviation spec_stat :: "('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> hrel_des" where
"spec_stat w pre post \<equiv> (pre \<turnstile>\<^sub>n w:[\<lceil>post\<rceil>\<^sub>>])"

syntax
  "_spec_stat" :: "salpha \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> hrel_des" ("_:[_,_]\<^sub>u" [70,0,0] 70)

translations
  "_spec_stat w pre post" \<rightleftharpoons> "CONST spec_stat w pre post"

lemma rc_strengthen_post:
  assumes "`post' \<Rightarrow> post`"
  shows "w:[pre, post]\<^sub>u \<sqsubseteq> w:[pre, post']\<^sub>u"
  using assms by (rel_auto)

lemma rc_weaken_pre:
  assumes "`pre \<Rightarrow> pre'`"
  shows "w:[pre, post]\<^sub>u \<sqsubseteq> w:[pre', post]\<^sub>u"
  using assms by (rel_auto)

lemma rc_skip:
  assumes "`pre \<Rightarrow> post`"
  shows "w:[pre, post]\<^sub>u \<sqsubseteq> II\<^sub>D"
  using assms by (rel_auto)

lemma rc_seq:
  assumes "vwb_lens w"
  shows "w:[pre, post]\<^sub>u \<sqsubseteq> w:[pre, mid]\<^sub>u ;; w:[mid, post]\<^sub>u"
  using assms
  by (rel_auto, metis vwb_lens.put_eq)
end


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

theory ArraysMemInstance
imports Arrays CompoundCTypes
begin

primrec
  array_tag_n :: "nat \<Rightarrow> ('a::c_type,'b::finite) array typ_info"
where
  atn_base:
  "array_tag_n 0 = ((empty_typ_info (typ_name (typ_uinfo_t TYPE('a)) @ ''_array_'' @
      nat_to_bin_string (CARD('b::finite))))::('a::c_type,'b) array
          typ_info)"
| atn_rec:
  "array_tag_n (Suc n) = ((ti_typ_combine TYPE('a::c_type)
      (\<lambda>x. index x n) (\<lambda>x f. update f n x) (replicate n CHR ''1'')
          (array_tag_n n))::('a,'b::finite) array typ_info)"

definition
  array_tag :: "('a::c_type,'b::finite) array itself \<Rightarrow> ('a,'b) array typ_info" where
  "array_tag t \<equiv> array_tag_n (CARD('b))"

instantiation array :: (c_type,finite) c_type
begin
instance ..
end

defs (overloaded)
  typ_info_array: "typ_info_t (w::('a::c_type,'b::finite) array itself) \<equiv> array_tag w"

lemma field_names_array_tag_length [rule_format]:
  "x \<in> set (field_names_list (array_tag_n n)) \<longrightarrow> length x < n"
apply(induct_tac n)
 apply simp
apply clarsimp
done

lemma replicate_mem_field_names_array_tag [simp]:
  "replicate n x \<notin> set (field_names_list (array_tag_n n))"
apply clarsimp
apply(drule field_names_array_tag_length)
apply simp
done

lemma aggregate_array_tag [simp]:
  "aggregate (array_tag_n n)"
apply(case_tac n)
 apply simp+
done

lemma wf_desc_array_tag [simp]:
  "wf_desc ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info)"
apply(induct_tac n)
 apply simp+
apply(erule wf_desc_ti_typ_combine)
apply simp
done

lemma wf_size_desc_array_tag [simp, rule_format]:
  "0 < n \<longrightarrow> wf_size_desc ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info)"
apply(induct n)
 apply simp+
apply(case_tac "n=0")
 apply simp
apply(rule wf_size_desc_ti_typ_combine)
apply simp
done

lemma g_ind_array_tag_udpate [simp]:
  "n \<le> m \<longrightarrow> n \<le> CARD('b) \<longrightarrow>
      g_ind (lf_set ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info) []) (\<lambda>x f. update f m x)"
apply(induct_tac n)
 apply clarsimp+
apply(erule g_ind_ti_typ_combine)
 apply clarsimp+
done

lemma fc_array_tag_udpate [simp]:
  "n \<le> m \<longrightarrow> n \<le> CARD('b) \<longrightarrow>
      fu_commutes (update_ti_t ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info)) (\<lambda>x f. update f m x)"
apply(induct_tac n)
 apply clarsimp+
apply(erule fc_ti_typ_combine)
  apply(clarsimp simp: fg_cons_def)
 apply clarsimp+
done

lemma f_ind_array_tag_udpate [simp, rule_format]:
  "n \<le> m \<longrightarrow> m < CARD('b) \<longrightarrow>
      f_ind (\<lambda>x. index x m) (lf_fd ` lf_set ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info) [])"
apply(induct_tac n)
 apply clarsimp+
apply(erule f_ind_ti_typ_combine)
 apply clarsimp
apply simp
done

lemma fa_fu_g_array_tag_udpate [simp, rule_format]:
  "n \<le> m \<longrightarrow> m < CARD('b) \<longrightarrow>
      fa_ind (lf_fd ` lf_set ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info) []) (\<lambda>x f. update f m x)"
apply(induct_tac n)
 apply clarsimp+
apply(erule fa_ind_ti_typ_combine)
apply clarsimp+
done

lemma wf_fdp_array_tag [simp, rule_format]:
  "n \<le> CARD('b) \<longrightarrow>
      wf_lf (lf_set ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info) [])"
apply(induct_tac n)
 apply clarsimp+
apply(erule wf_lf_ti_typ_combine)
      apply simp+
done

lemma upd_local_update [simp]:
  "upd_local (\<lambda>x f. update f n x)"
apply(auto simp: upd_local_def)
apply(subst cart_eq)
apply clarsimp
apply(subst (asm) cart_eq)
apply(drule_tac x=i in spec)
apply clarsimp
apply(case_tac "i=n")
 apply simp+
done

lemma fu_eq_mask_array_tag [simp, rule_format]:
  "n \<le> CARD('b) \<longrightarrow> (\<forall>m. (\<forall>k v. k < CARD('b) \<longrightarrow>
      index ((m v)::('a,'b) array) k = (if n \<le> k then
          index (undefined::('a::mem_type,'b::finite) array) k
          else index v k)) \<longrightarrow> fu_eq_mask (array_tag_n n) m)"
apply(induct n)
 apply clarsimp
 apply(rule fu_eq_mask_empty_typ_info)
 apply clarsimp
 apply(subst cart_eq)
 apply simp
apply clarsimp
apply(rule fu_eq_mask_ti_typ_combine)
     apply(drule_tac x="\<lambda>v. update (m v) n (index undefined n)" in spec)
     apply(erule impE)
      apply clarsimp
      apply(drule_tac x=k in spec)
      apply clarsimp
      apply(case_tac "k=n")
       apply simp
      apply clarsimp
     apply(subgoal_tac "\<forall>v bs. m (update v n bs) = update (m v) n bs")
      apply clarsimp+
     apply(subst cart_eq)
     apply clarsimp
     apply(drule_tac x=i in spec)
     apply clarsimp
     apply(case_tac "i=n")
      apply clarsimp+
     apply(frule_tac x="update v n bs" in spec)
     apply(drule_tac x="v" in spec)
     apply clarsimp
     apply(case_tac "Suc n \<le> i")
      apply clarsimp+
    apply(clarsimp simp: fg_cons_def)
   apply(clarsimp)
  apply simp
done

lemma size_td_array_tag [simp]:
  "size_td (((array_tag_n n)::('a,'b::finite) array typ_info)) =
      n * size_of TYPE('a::c_type)"
apply(induct_tac n)
 apply simp
apply simp
apply(simp add: size_td_lt_ti_typ_combine size_of_def)
done

lemma align_td_array_tag [rule_format]:
  "0 < n \<longrightarrow> align_td ((array_tag_n n)::('a,'b::finite) array typ_info) = (align_td (typ_info_t (TYPE('a::c_type))))"
apply(induct_tac n)
 apply simp
apply(clarsimp simp: ti_typ_combine_def Let_def)
apply(case_tac "n = 0")
 apply(clarsimp simp: align_of_def max_def)+
done

lemma align_field_array [simp]:
  "align_field ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info)"
apply(induct_tac n)
 apply simp
apply clarsimp
apply(erule align_field_ti_typ_combine)
apply simp
apply(rule dvd_mult)
apply(subgoal_tac "align_of TYPE('a) dvd size_of TYPE('a)")
 apply(simp add: align_of_def)
apply(rule align_size_of)
done

instantiation array :: (mem_type,finite) mem_type_sans_size
begin

instance
apply intro_classes
     apply(simp_all add: typ_info_array array_tag_def size_of_def
                         norm_bytes_def)

 apply clarsimp
 apply(rule fu_eq_mask)
  apply(simp add: size_of_def)
 apply(rule fu_eq_mask_array_tag)
    apply simp+

apply(clarsimp simp: align_of_def typ_info_array array_tag_def)
apply(subst align_td_array_tag)
 apply simp
apply(rule dvd_trans)
 apply(subgoal_tac "align_of TYPE('a) dvd size_of TYPE('a)")
  apply(simp only: align_of_def)
 apply(rule align_size_of)
apply(simp add: size_of_def)
done

end

declare atn_base [simp del]
declare atn_rec [simp del]

lemma size_of_array [simp]:
  "size_of TYPE(('a,'b::finite) array) = CARD('b) * size_of TYPE('a::c_type)"
  by (simp add: size_of_def typ_info_array array_tag_def)

lemma size_td_array:
  "size_td (typ_info_t TYPE(('a,'b::finite) array)) = CARD('b) * size_of TYPE('a::c_type)"
  by (simp add: size_of_def typ_info_array array_tag_def)

lemma align_td_array:
  "2^align_td (typ_info_t TYPE(('a,'b::finite) array)) = align_of TYPE('a::c_type)"
apply(simp add: align_of_def typ_info_array array_tag_def)
apply(subst align_td_array_tag)
 apply simp+
done

(* Showing arrays are in mem_type requires maximum sizes for objects,
   and maximum counts for elements *)
class oneMB_size = mem_type +
  assumes oneMB_size_ax: "size_of TYPE('a::c_type) < 2 ^ 19"

class fourthousand_count = finite +
  assumes fourthousand_count_ax: "CARD ('a) <= 2 ^ 13"

instantiation array :: (oneMB_size, fourthousand_count) mem_type
begin

instance
apply intro_classes
apply simp
apply (subgoal_tac "addr_card = 2 ^ 13 * 2 ^ 19")
  apply (erule ssubst)
  apply (rule less_le_trans[where y = "card (UNIV::'b set) * 2 ^ 19"])
    apply (rule mult_less_mono2)
      apply (rule oneMB_size_ax)
    apply simp
  apply (rule mult_le_mono1)
    apply (rule fourthousand_count_ax)
  apply simp
apply (simp add: addr_card)
done

end

class twoToSix_size = oneMB_size +
  assumes twoToSix_size_ax: "size_of TYPE('a::c_type) < 2 ^ 6"

instantiation array :: (twoToSix_size, fourthousand_count) oneMB_size
begin

instance
apply intro_classes
apply simp
  apply (rule order_less_le_trans)
   apply (rule mult_le_less_imp_less)
    apply (rule fourthousand_count_ax)
   apply (rule twoToSix_size_ax)
  apply simp
   apply simp
  apply simp
  done

end

instantiation word :: (len8) oneMB_size
begin
instance
apply intro_classes
apply(simp add: size_of_def)
apply(subgoal_tac "len_of TYPE('a) \<le> 128")
 apply simp
apply(rule len8_width)
done
end

instantiation word :: (len8) twoToSix_size
begin
instance
apply intro_classes
apply(simp add: size_of_def)
apply(subgoal_tac "len_of TYPE('a) \<le> 128")
 apply simp
apply(rule len8_width)
done
end

instantiation ptr :: (c_type) oneMB_size
begin
instance
apply intro_classes
apply (simp add: size_of_def)
done
end

instantiation ptr :: (c_type) twoToSix_size
begin
instance
apply intro_classes
apply (simp add: size_of_def)
done
end

class lt12 = finite +
  assumes lt12_ax: "CARD ('a) < 2 ^ 12"
class lt11 = lt12 +
  assumes lt11_ax: "CARD ('a) < 2 ^ 11"
class lt10 = lt11 +
  assumes lt10_ax: "CARD ('a) < 2 ^ 10"
class lt9 = lt10 +
  assumes lt9_ax: "CARD ('a) < 2 ^ 9"
class lt8 = lt9 +
  assumes lt8_ax: "CARD ('a) < 2 ^ 8"
class lt7 = lt8 +
  assumes lt7_ax: "CARD ('a) < 2 ^ 7"
class lt6 = lt7 +
  assumes lt6_ax: "CARD ('a) < 2 ^ 6"
class lt5 = lt6 +
  assumes lt5_ax: "CARD ('a) < 2 ^ 5"
class lt4 = lt5 +
  assumes lt4_ax: "CARD ('a) < 2 ^ 4"
class lt3 = lt4 +
  assumes lt3_ax: "CARD ('a) < 2 ^ 3"
class lt2 = lt3 +
  assumes lt2_ax: "CARD ('a) < 2 ^ 2"
class lt1 = lt2 +
  assumes lt1_ax: "CARD ('a) < 2 ^ 1"

instantiation bit0 :: (lt12) fourthousand_count
begin
instance
  by (intro_classes, insert lt12_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt12) fourthousand_count
begin
instance
  by (intro_classes, insert lt12_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt11) lt12
begin
instance
  by (intro_classes, insert lt11_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt11) lt12
begin
instance
  by (intro_classes, insert lt11_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt10) lt11
begin
instance
  by (intro_classes, insert lt10_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt10) lt11
begin
instance
  by (intro_classes, insert lt10_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt9) lt10
begin
instance
  by (intro_classes, insert lt9_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt9) lt10
begin
instance
  by (intro_classes, insert lt9_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt8) lt9
begin
instance
  by (intro_classes, insert lt8_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt8) lt9
begin
instance
  by (intro_classes, insert lt8_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt7) lt8
begin
instance
  by (intro_classes, insert lt7_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt7) lt8
begin
instance
  by (intro_classes, insert lt7_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt6) lt7
begin
instance
  by (intro_classes, insert lt6_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt6) lt7
begin
instance
  by (intro_classes, insert lt6_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt5) lt6
begin
instance
  by (intro_classes, insert lt5_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt5) lt6
begin
instance
  by (intro_classes, insert lt5_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt4) lt5
begin
instance
  by (intro_classes, insert lt4_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt4) lt5
begin
instance
  by (intro_classes, insert lt4_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt3) lt4
begin
instance
  by (intro_classes, insert lt3_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt3) lt4
begin
instance
  by (intro_classes, insert lt3_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt2) lt3
begin
instance
  by (intro_classes, insert lt2_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt2) lt3
begin
instance
  by (intro_classes, insert lt2_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt1) lt2
begin
instance
  by (intro_classes, insert lt1_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt1) lt2
begin
instance
  by (intro_classes, insert lt1_ax[where 'a = 'a], simp)
end

instantiation num1 :: lt1
begin
instance
  by (intro_classes, simp_all)
end

(* don't understand why this also seems to be necessary *)
instantiation num1 :: fourthousand_count
begin
instance
  by (intro_classes, simp)
end

(* introduce hackish handling of 8192 type by making a copy of the type
   under a constructor, and then manually showing that it is an instance of
   fourthousand_count *)
datatype ty8192 = ty8192 "8192"

lemma univ8192: "(UNIV::ty8192 set) = image ty8192 (UNIV::8192 set)"
apply (simp add: set_eq_iff image_iff)
apply (rule_tac allI)
apply (rule_tac ty8192.induct)
apply simp
done

instance "ty8192" :: finite
apply intro_classes
apply (simp add: univ8192)
done

lemma card8192[simp]: "CARD(ty8192) = CARD(8192)"
apply (simp add: univ8192 card_image inj_on_def)
done

instance "ty8192" :: fourthousand_count
by intro_classes simp

end


theory Channel_Type_Rep
  imports Executable_Universe
begin

text \<open> There follows a class for representing channel types \<close>

class pre_uchantyperep =
  \<comment> \<open> A mapping from channel names to types \<close>
  fixes uchans :: "'a itself \<Rightarrow> (uname \<Zpfun> utyp)"

  assumes finite_chans: "finite (pdom (uchans a))"
  and nonempty_chans: "\<exists> n. n \<in> pdom (uchans a)"
begin

definition unames :: "'a itself \<Rightarrow> uname set" where
"unames a = pdom (uchans a)"

lemma finite_names: "finite (unames a)"
  by (simp add: local.finite_chans unames_def)

lemma names_nonempty: "unames a \<noteq> {}"
  using local.nonempty_chans unames_def by auto

text \<open> The value carried over the channel \<close>

end

typedef (overloaded) 'c::pre_uchantyperep name =
  "{n. n \<in> unames TYPE('c)}"
  by (simp add: nonempty_chans unames_def)

(* The following type should be isomorphic to 'c, but conveys more structure *)

typedef (overloaded) 'c::pre_uchantyperep event =
  "{(n, v). n \<in> unames TYPE('c) \<and> utyp_of v = Some ((uchans TYPE('c))(n)\<^sub>p)}"
  morphisms of_event event_of
  using nonempty_chans unames_def utyp_of_default_uval by blast

setup_lifting type_definition_event

lift_definition ev_name :: "'c::pre_uchantyperep event \<Rightarrow> uname" is fst .
definition ev_type :: "'c::pre_uchantyperep event \<Rightarrow> utyp"
  where "ev_type e = (uchans TYPE('c))(ev_name e)\<^sub>p"
lift_definition ev_val :: "'c::pre_uchantyperep event \<Rightarrow> 'a::uvals" is "from_uval \<circ> snd" .
lift_definition mk_event :: "uname \<Rightarrow> 'a::uvals \<Rightarrow> 'c::pre_uchantyperep event"
  is "\<lambda> n v. if (n \<in> unames TYPE('c) \<and> (uchans TYPE('c))(n)\<^sub>p = UTYPE('a))
             then (n, to_uval v)
             else (let sn = SOME n. n \<in> unames TYPE('c) in (sn, default_uval ((uchans TYPE('c))(sn)\<^sub>p)))"
  apply auto
  apply (metis nonempty_chans old.prod.inject someI unames_def)
  apply (metis fst_conv snd_conv utyp_of_default_uval)
  apply (metis nonempty_chans prod.inject someI unames_def)
  apply (metis fst_conv snd_conv utyp_of_default_uval)
  done

lemma
  assumes "UTYPE('a) = ev_type x"
  shows "mk_event (ev_name x) (ev_val x :: 'a::uvals) = x"
  using assms
  apply (simp add: ev_val_def ev_type_def)
  apply (transfer)
  apply auto
  oops

(*
type_synonym 'c chan = unit

definition mk_chan :: "'c name \<Rightarrow> ('a \<Longrightarrow>\<^sub>\<triangle> 'c) \<Rightarrow> 'c chan" where
"mk_chan = undefined"
*)

(* I want to achieve a type something like "forall 'a\<in>unames. (('a, 'c) name, 'a \<Longrightarrow>\<^sub>\<triangle> 'c) *)

class uchantyperep = pre_uchantyperep +
  fixes uchan_mk :: "'a event \<Rightarrow> 'a"
  and uchan_dest :: "'a \<Rightarrow> 'a event"
  assumes "uchan_dest (uchan_mk x) = x"

chantype chan =
  Input :: unit
  Output :: integer

instantiation chan :: pre_uchantyperep
begin

definition uchans_chan :: "chan itself \<Rightarrow> String.literal \<Zpfun> utyp"
  where "uchans_chan x = {STR ''Input'' \<mapsto> UnitT, STR ''Output'' \<mapsto> IntT}"

instance
  by (intro_classes, auto simp add: uchans_chan_def)

end

(*
instantiation chan :: uchantyperep
begin

definition uchan_mk_chan :: "chan event \<Rightarrow> chan"
  where "uchan_mk_chan e = (if (ev_name e = STR ''Input'') then Input_C (ev_val e)
                            else Output_C (ev_val e))"

fun uchan_dest_chan :: "chan \<Rightarrow> chan event" where
"uchan_dest (Input_C v) = mk_event (STR ''Input'', to_uval v)" |
"uchan_dest (Output_C v) = mk_event (STR ''Output'', to_uval v)"

instance
  apply (intro_classes)
  apply (auto simp add: uchan_mk_chan_def)
*)

datatype ('e, 'b) chf =
  ChanF (chf_chn: "(uname \<times> uval \<times> uval \<Longrightarrow>\<^sub>\<triangle> 'e)") \<comment> \<open> The channel, including a name, output value, and input value \<close>
        (chf_out: "uname \<times> uval") \<comment> \<open> The value output by the process (displayed in the animator) \<close>
        (chf_typ: "utyp") \<comment> \<open> The type of data requested by the animator \<close>
        (chf_cont: "uval \<Rightarrow> 'b") \<comment> \<open> The continuation for each kind of value received \<close>

definition pfun_of_chfun ::
  "('e, 'b) chf \<Rightarrow> 'e \<Zpfun> 'b" where
"pfun_of_chfun chf =
    (\<lambda> e\<in>{build\<^bsub>chf_chn chf\<^esub> (fst (chf_out chf), snd (chf_out chf), v) | v. v \<in> uvals (chf_typ chf)}
    \<bullet> (chf_cont chf) (snd (snd (the (match\<^bsub>chf_chn chf\<^esub> e)))))"

definition
  "map_chfun f chf = ChanF (chf_chn chf) (chf_out chf) (chf_typ chf) (f \<circ> chf_cont chf)"

lemma map_pfun_pfun_of_chfun:
  "map_pfun f (pfun_of_chfun chf) = pfun_of_chfun (map_chfun f chf)"
  by (simp add: map_chfun_def pfun_of_chfun_def pfun_eq_iff)

lemma "pfun_app (pfun_of_chfun chf) e = undefined"
  apply (simp add: pfun_of_chfun_def)
  apply (subst pabs_apply)
    apply simp
  oops

definition pfun_of_chfuns ::
  "('e, 'b) chf list \<Rightarrow> 'e \<Zpfun> 'b" where
"pfun_of_chfuns chfs = foldr (\<lambda> c f. pfun_of_chfun c \<oplus> f) chfs {}\<^sub>p"

lemma map_pfun_pfun_of_chfuns [code]:
  "map_pfun f (pfun_of_chfuns chfs) = pfun_of_chfuns (map (map_chfun f) chfs)"
  by (induct chfs, simp_all add: pfun_of_chfuns_def map_pfun_pfun_of_chfun)

end


section \<open>Machine\<close>
text \<open>
  This theory describes the state of an abstract machine on which binary and assembly programs
  can be executed.
\<close>

theory Machine
  imports Main "HOL-Library.Word" "HOL-Library.Stream"
begin

subsection \<open>Primitive Values\<close>
text \<open>Bits and bytes on which the abstract machine operates\<close>

type_synonym byte  = "8 word"
type_synonym bytes = "byte list"

type_synonym addr = "nat"

subsection \<open>Machine State\<close>

record state =
  state_rip :: "addr"
  state_mem :: "addr \<Rightarrow> byte"

type_synonym trace = "state stream"

subsection \<open>ISA\<close>

type_synonym instr = string

locale isa =
  fixes isa_instructions :: "instr set"
    and isa_encodings    :: "bytes set"
    and isa_encode       :: "instr \<rightharpoonup> bytes"
    and isa_decode       :: "bytes \<rightharpoonup> instr"
    and isa_step_instr   :: "(instr \<times> state \<times> state) set"
  assumes isa_encode_valid: "\<forall> i \<in> isa_instructions. \<exists> bs \<in> isa_encodings. isa_encode i = Some bs \<and> isa_decode bs = Some i"
      and isa_decode_valid: "\<forall> bs \<in> isa_encodings. \<exists> i \<in> isa_instructions. isa_encode i = Some bs \<and> isa_decode bs = Some i"

context isa
begin

definition isa_step_bytes :: "(bytes \<times> state \<times> state) set" where
  "isa_step_bytes = { (bs, \<sigma>\<^sub>1, \<sigma>\<^sub>2). \<exists> i. Some i = isa_decode bs \<and> (i, \<sigma>\<^sub>1, \<sigma>\<^sub>2) \<in> isa_step_instr }"

lemma isa_encode_preserves_instr_semantics:
  assumes "Some bs = isa_encode i"
      and "i \<in> isa_instructions"
      and "(i, \<sigma>\<^sub>1, \<sigma>\<^sub>2)  \<in> isa_step_instr"
    shows "(bs, \<sigma>\<^sub>1, \<sigma>\<^sub>2) \<in> isa_step_bytes"
  using assms(1) assms(2) assms(3) isa_encode_valid isa_step_bytes_def by auto

lemma isa_decode_preserves_instr_semantics:
  assumes "Some i = isa_decode bs"
      and "(i, \<sigma>\<^sub>1, \<sigma>\<^sub>2)  \<in> isa_step_instr"
    shows "(bs, \<sigma>\<^sub>1, \<sigma>\<^sub>2) \<in> isa_step_bytes"
  using assms(1) assms(2) isa_step_bytes_def by auto

lemma isa_encode_preserves_byte_semantics:
  assumes "Some bs = isa_encode i"
      and "i \<in> isa_instructions"
      and "(bs, \<sigma>\<^sub>1, \<sigma>\<^sub>2) \<in> isa_step_bytes"
    shows "(i, \<sigma>\<^sub>1, \<sigma>\<^sub>2)  \<in> isa_step_instr"
  using assms(1) assms(2) assms(3) isa_encode_valid isa_step_bytes_def by auto

lemma isa_decode_preserves_byte_semantics:
  assumes "Some i = isa_decode bs"
      and "(bs, \<sigma>\<^sub>1, \<sigma>\<^sub>2) \<in> isa_step_bytes"
    shows "(i, \<sigma>\<^sub>1, \<sigma>\<^sub>2)  \<in> isa_step_instr"
  by (smt (verit) assms(1) assms(2) curryI curry_case_prod isa_step_bytes_def mem_Collect_eq option.inject)

end

end


theory SINVAR_DomainHierarchyNG_impl
imports SINVAR_DomainHierarchyNG "../TopoS_Interface_impl"
begin

subsubsection {* SecurityInvariant DomainHierarchy List Implementation *}

code_identifier code_module SINVAR_DomainHierarchyNG_impl => (Scala) SINVAR_DomainHierarchyNG

fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (s, r) \<in> set (edgesL G). (nP r) \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t (nP s))"

fun verify_globals :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> domainTree \<Rightarrow> bool" where
  "verify_globals G nP tree = (\<forall> v \<in> set (nodesL G).
    case (nP v) of Unassigned \<Rightarrow> True | DN (level, trust) \<Rightarrow> valid_hierarchy_pos tree level
   )"

definition DomainHierarchyNG_offending_list:: "'v list_graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> ('v \<times> 'v) list list" where
  "DomainHierarchyNG_offending_list G nP = (if sinvar G nP then
    []
   else
    [ [e \<leftarrow> edgesL G. case e of (s,r) \<Rightarrow> \<not> (nP r) \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t (nP s) ] ])"

lemma "DomainHierarchyNG.node_props P =
  (\<lambda>i. case node_properties P i of None \<Rightarrow> SINVAR_DomainHierarchyNG.default_node_properties | Some property \<Rightarrow> property)"
by(fact SecurityInvariant.node_props.simps[OF TopoS_DomainHierarchyNG, of "P"])

definition "NetModel_node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_DomainHierarchyNG.default_node_properties))"
(*

(*TODO does this work?*)
lemma[code_unfold]: "DomainHierarchyNG.node_props P = NetModel_node_props P"
by(simp add: NetModel_node_props_def)

definition "DomainHierarchyNG_eval G P = (valid_list_graph G \<and>
  verify_globals G (SecurityInvariant.node_props SINVAR_DomainHierarchyNG.default_node_properties P) (model_global_properties P) \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_DomainHierarchyNG.default_node_properties P))"

interpretation DomainHierarchyNG_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_DomainHierarchyNG.default_node_properties
  and sinvar_spec=SINVAR_DomainHierarchyNG.sinvar
  and sinvar_impl=sinvar
  and verify_globals_spec=SINVAR_DomainHierarchyNG.verify_globals
  and verify_globals_impl=verify_globals
  and receiver_violation=SINVAR_DomainHierarchyNG.receiver_violation
  and offending_flows_impl=DomainHierarchyNG_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=DomainHierarchyNG_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(simp add: TopoS_DomainHierarchyNG list_graph_to_graph_def)
 apply(rule conjI)
  apply(simp add: list_graph_to_graph_def DomainHierarchyNG_offending_set DomainHierarchyNG_offending_set_def DomainHierarchyNG_offending_list_def)
 apply(rule conjI)
  apply(simp only: NetModel_node_props_def)
  apply(metis DomainHierarchyNG.node_props.simps DomainHierarchyNG.node_props_eq_node_props_formaldef)
 apply(simp only: DomainHierarchyNG_eval_def)
 apply(intro allI)
 apply(rule TopoS_eval_impl_proofrule[OF TopoS_DomainHierarchyNG])
 apply(simp_all add: list_graph_to_graph_def)
done

subsubsection {* DomainHierarchyNG packing *}
  definition SINVAR_LIB_DomainHierarchyNG :: "('v::vertex, domainNameTrust, domainTree) TopoS_packed" where
    "SINVAR_LIB_DomainHierarchyNG \<equiv>
    \<lparr> nm_name = ''DomainHierarchyNG'',
      nm_receiver_violation = SINVAR_DomainHierarchyNG.receiver_violation,
      nm_default = SINVAR_DomainHierarchyNG.default_node_properties,
      nm_sinvar = sinvar,
      nm_verify_globals = verify_globals,
      nm_offending_flows = DomainHierarchyNG_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = DomainHierarchyNG_eval
      \<rparr>"
  interpretation SINVAR_LIB_DomainHierarchyNG_interpretation: TopoS_modelLibrary SINVAR_LIB_DomainHierarchyNG
      SINVAR_DomainHierarchyNG.sinvar SINVAR_DomainHierarchyNG.verify_globals
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_DomainHierarchyNG_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

text {*Examples:*}
definition example_TUM_net :: "vString list_graph" where
  "example_TUM_net \<equiv> \<lparr> nodesL=[TopoS_Vertices.V ''Gateway'', TopoS_Vertices.V ''LowerSVR'', TopoS_Vertices.V ''UpperSRV''],
        edgesL=[
          (TopoS_Vertices.V ''Gateway'',TopoS_Vertices.V ''LowerSVR''), (TopoS_Vertices.V ''Gateway'',TopoS_Vertices.V ''UpperSRV''),
          (TopoS_Vertices.V ''LowerSVR'', TopoS_Vertices.V ''Gateway''),
          (TopoS_Vertices.V ''UpperSRV'', TopoS_Vertices.V ''Gateway'')
        ] \<rparr>"
value "valid_list_graph example_TUM_net"

definition example_TUM_config :: "vString \<Rightarrow> domainNameTrust" where
  "example_TUM_config \<equiv> ((\<lambda> e. default_node_properties)
        (TopoS_Vertices.V ''Gateway'':= DN (''ACD''--''AISD''--Leaf, 1),
         TopoS_Vertices.V ''LowerSVR'':= DN (''ACD''--''AISD''--Leaf, 0),
         TopoS_Vertices.V ''UpperSRV'':= DN (''ACD''--Leaf, 0)
       ))"

definition example_TUM_hierarchy :: "domainTree" where
"example_TUM_hierarchy \<equiv> (Department ''ACD'' [
           Department ''AISD'' []
       ])"

value "verify_globals example_TUM_net example_TUM_config example_TUM_hierarchy"
value "sinvar     example_TUM_net example_TUM_config"

definition example_TUM_net_invalid where
"example_TUM_net_invalid \<equiv> example_TUM_net\<lparr>edgesL :=
    (TopoS_Vertices.V ''LowerSRV'', TopoS_Vertices.V ''UpperSRV'')#(edgesL example_TUM_net)\<rparr>"

value "verify_globals example_TUM_net_invalid example_TUM_config example_TUM_hierarchy"
value "sinvar     example_TUM_net_invalid example_TUM_config"
value "DomainHierarchyNG_offending_list example_TUM_net_invalid example_TUM_config"

hide_const (open) NetModel_node_props

hide_const (open) sinvar verify_globals

end


(* @TAG(OTHER_LGPL) *)

(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      StateSpace.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section {* State Space Template *}
theory StateSpace imports Hoare
begin

record 'g state = "globals"::'g

definition
  upd_globals:: "('g \<Rightarrow> 'g) \<Rightarrow> ('g,'z) state_scheme \<Rightarrow> ('g,'z) state_scheme"
where
  "upd_globals upd s = s\<lparr>globals := upd (globals s)\<rparr>"

record ('g, 'n, 'val) stateSP = "'g state" +
  locals :: "'n \<Rightarrow> 'val"

lemma upd_globals_conv: "upd_globals f = (\<lambda>s. s\<lparr>globals := f (globals s)\<rparr>)"
  by (rule ext) (simp add: upd_globals_def)

end