section \<open>State monad transformer\<close>

theory State_Transformer
imports Monad_Zero_Plus
begin

text \<open>
  This version has non-lifted product, and a non-lifted function space.
\<close>

tycondef 'a\<cdot>('f::"functor", 's) stateT =
  StateT (runStateT :: "'s \<rightarrow> ('a \<times> 's)\<cdot>'f")

lemma coerce_stateT_abs [simp]: "coerce\<cdot>(stateT_abs\<cdot>x) = stateT_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: stateT_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_stateT)
done

lemma coerce_StateT [simp]: "coerce\<cdot>(StateT\<cdot>k) = StateT\<cdot>(coerce\<cdot>k)"
unfolding StateT_def by simp

lemma stateT_cases [case_names StateT]:
  obtains k where "y = StateT\<cdot>k"
proof
  show "y = StateT\<cdot>(runStateT\<cdot>y)"
    by (cases y, simp_all)
qed

lemma stateT_induct [case_names StateT]:
  fixes P :: "'a\<cdot>('f::functor,'s) stateT \<Rightarrow> bool"
  assumes "\<And>k. P (StateT\<cdot>k)"
  shows "P y"
by (cases y rule: stateT_cases, simp add: assms)

lemma stateT_eqI:
  "(\<And>s. runStateT\<cdot>a\<cdot>s = runStateT\<cdot>b\<cdot>s) \<Longrightarrow> a = b"
apply (cases a rule: stateT_cases)
apply (cases b rule: stateT_cases)
apply (simp add: cfun_eq_iff)
done

lemma runStateT_coerce [simp]:
  "runStateT\<cdot>(coerce\<cdot>k)\<cdot>s = coerce\<cdot>(runStateT\<cdot>k\<cdot>s)"
by (induct k rule: stateT_induct, simp)

subsection \<open>Functor class instance\<close>

lemma fmapU_StateT [simp]:
  "fmapU\<cdot>f\<cdot>(StateT\<cdot>k) =
    StateT\<cdot>(\<Lambda> s. fmap\<cdot>(\<Lambda>(x, s'). (f\<cdot>x, s'))\<cdot>(k\<cdot>s))"
unfolding fmapU_stateT_def stateT_map_def StateT_def
by (subst fix_eq, simp add: cfun_map_def csplit_def prod_map_def)

lemma runStateT_fmapU [simp]:
  "runStateT\<cdot>(fmapU\<cdot>f\<cdot>m)\<cdot>s =
    fmap\<cdot>(\<Lambda>(x, s'). (f\<cdot>x, s'))\<cdot>(runStateT\<cdot>m\<cdot>s)"
by (cases m rule: stateT_cases, simp)

instantiation stateT :: ("functor", "domain") "functor"
begin

instance
apply standard
apply (induct_tac xs rule: stateT_induct)
apply (simp_all add: fmap_fmap ID_def csplit_def)
done

end

subsection \<open>Monad class instance\<close>

instantiation stateT :: (monad, "domain") monad
begin

definition returnU_stateT_def:
  "returnU = (\<Lambda> x. StateT\<cdot>(\<Lambda> s. return\<cdot>(x, s)))"

definition bindU_stateT_def:
  "bindU = (\<Lambda> m k. StateT\<cdot>(\<Lambda> s. runStateT\<cdot>m\<cdot>s \<bind> (\<Lambda> (x, s'). runStateT\<cdot>(k\<cdot>x)\<cdot>s')))"

lemma bindU_stateT_StateT [simp]:
  "bindU\<cdot>(StateT\<cdot>f)\<cdot>k =
    StateT\<cdot>(\<Lambda> s. f\<cdot>s \<bind> (\<Lambda> (x, s'). runStateT\<cdot>(k\<cdot>x)\<cdot>s'))"
unfolding bindU_stateT_def by simp

lemma runStateT_bindU [simp]:
  "runStateT\<cdot>(bindU\<cdot>m\<cdot>k)\<cdot>s = runStateT\<cdot>m\<cdot>s \<bind> (\<Lambda> (x, s'). runStateT\<cdot>(k\<cdot>x)\<cdot>s')"
unfolding bindU_stateT_def by simp

instance proof
  fix f :: "udom \<rightarrow> udom" and r :: "udom\<cdot>('a,'b) stateT"
  show "fmapU\<cdot>f\<cdot>r = bindU\<cdot>r\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
    by (rule stateT_eqI)
       (simp add: returnU_stateT_def monad_fmap prod_map_def csplit_def)
next
  fix f :: "udom \<rightarrow> udom\<cdot>('a,'b) stateT" and x :: "udom"
  show "bindU\<cdot>(returnU\<cdot>x)\<cdot>f = f\<cdot>x"
    by (rule stateT_eqI)
       (simp add: returnU_stateT_def eta_cfun)
next
  fix r :: "udom\<cdot>('a,'b) stateT" and f g :: "udom \<rightarrow> udom\<cdot>('a,'b) stateT"
  show "bindU\<cdot>(bindU\<cdot>r\<cdot>f)\<cdot>g = bindU\<cdot>r\<cdot>(\<Lambda> x. bindU\<cdot>(f\<cdot>x)\<cdot>g)"
    by (rule stateT_eqI)
       (simp add: bind_bind csplit_def)
qed

end

subsection \<open>Monad zero instance\<close>

instantiation stateT :: (monad_zero, "domain") monad_zero
begin

definition zeroU_stateT_def:
  "zeroU = StateT\<cdot>(\<Lambda> s. mzero)"

lemma runStateT_zeroU [simp]:
  "runStateT\<cdot>zeroU\<cdot>s = mzero"
unfolding zeroU_stateT_def by simp

instance proof
  fix k :: "udom \<rightarrow> udom\<cdot>('a,'b) stateT"
  show "bindU\<cdot>zeroU\<cdot>k = zeroU"
    by (rule stateT_eqI, simp add: bind_mzero)
qed

end

subsection \<open>Monad plus instance\<close>

instantiation stateT :: (monad_plus, "domain") monad_plus
begin

definition plusU_stateT_def:
  "plusU = (\<Lambda> a b. StateT\<cdot>(\<Lambda> s. mplus\<cdot>(runStateT\<cdot>a\<cdot>s)\<cdot>(runStateT\<cdot>b\<cdot>s)))"

lemma runStateT_plusU [simp]:
  "runStateT\<cdot>(plusU\<cdot>a\<cdot>b)\<cdot>s =
    mplus\<cdot>(runStateT\<cdot>a\<cdot>s)\<cdot>(runStateT\<cdot>b\<cdot>s)"
unfolding plusU_stateT_def by simp

instance proof
  fix a b :: "udom\<cdot>('a, 'b) stateT" and k :: "udom \<rightarrow> udom\<cdot>('a, 'b) stateT"
  show "bindU\<cdot>(plusU\<cdot>a\<cdot>b)\<cdot>k = plusU\<cdot>(bindU\<cdot>a\<cdot>k)\<cdot>(bindU\<cdot>b\<cdot>k)"
    by (rule stateT_eqI, simp add: bind_mplus)
next
  fix a b c :: "udom\<cdot>('a, 'b) stateT"
  show "plusU\<cdot>(plusU\<cdot>a\<cdot>b)\<cdot>c = plusU\<cdot>a\<cdot>(plusU\<cdot>b\<cdot>c)"
    by (rule stateT_eqI, simp add: mplus_assoc)
qed

end

subsection \<open>Monad zero plus instance\<close>

instance stateT :: (monad_zero_plus, "domain") monad_zero_plus
proof
  fix m :: "udom\<cdot>('a, 'b) stateT"
  show "plusU\<cdot>zeroU\<cdot>m = m"
    by (rule stateT_eqI, simp add: mplus_mzero_left)
next
  fix m :: "udom\<cdot>('a, 'b) stateT"
  show "plusU\<cdot>m\<cdot>zeroU = m"
    by (rule stateT_eqI, simp add: mplus_mzero_right)
qed

subsection \<open>Transfer properties to polymorphic versions\<close>

lemma coerce_csplit [coerce_simp]:
  shows "coerce\<cdot>(csplit\<cdot>f\<cdot>p) = csplit\<cdot>(\<Lambda> x y. coerce\<cdot>(f\<cdot>x\<cdot>y))\<cdot>p"
unfolding csplit_def by simp

lemma csplit_coerce [coerce_simp]:
  fixes p :: "'a \<times> 'b"
  shows "csplit\<cdot>f\<cdot>(COERCE('a \<times> 'b, 'c \<times> 'd)\<cdot>p) =
    csplit\<cdot>(\<Lambda> x y. f\<cdot>(COERCE('a, 'c)\<cdot>x)\<cdot>(COERCE('b, 'd)\<cdot>y))\<cdot>p"
unfolding coerce_prod csplit_def prod_map_def by simp

lemma fmap_stateT_simps [simp]:
  "fmap\<cdot>f\<cdot>(StateT\<cdot>m :: 'a\<cdot>('f::functor,'s) stateT) =
    StateT\<cdot>(\<Lambda> s. fmap\<cdot>(\<Lambda> (x, s'). (f\<cdot>x, s'))\<cdot>(m\<cdot>s))"
unfolding fmap_def [where 'f="('f, 's) stateT"]
by (simp add: coerce_simp eta_cfun)

lemma runStateT_fmap [simp]:
  "runStateT\<cdot>(fmap\<cdot>f\<cdot>m)\<cdot>s = fmap\<cdot>(\<Lambda> (x, s'). (f\<cdot>x, s'))\<cdot>(runStateT\<cdot>m\<cdot>s)"
by (induct m rule: stateT_induct, simp)

lemma return_stateT_def:
  "(return :: _ \<rightarrow> 'a\<cdot>('m::monad, 's) stateT) =
    (\<Lambda> x. StateT\<cdot>(\<Lambda> s. return\<cdot>(x, s)))"
unfolding return_def [where 'm="('m, 's) stateT"] returnU_stateT_def
by (simp add: coerce_simp)

lemma bind_stateT_def:
  "bind = (\<Lambda> m k. StateT\<cdot>(\<Lambda> s. runStateT\<cdot>m\<cdot>s \<bind> (\<Lambda> (x, s'). runStateT\<cdot>(k\<cdot>x)\<cdot>s')))"
apply (subst bind_def, subst bindU_stateT_def)
apply (simp add: coerce_simp)
apply (simp add: coerce_idem domain_defl_simps monofun_cfun)
apply (simp add: eta_cfun)
done

text "TODO: add \<open>coerce_idem\<close> to \<open>coerce_simps\<close>, along\010with monotonicity rules for DEFL."

lemma bind_stateT_simps [simp]:
  "bind\<cdot>(StateT\<cdot>m :: 'a\<cdot>('m::monad,'s) stateT)\<cdot>k =
    StateT\<cdot>(\<Lambda> s. m\<cdot>s \<bind> (\<Lambda> (x, s'). runStateT\<cdot>(k\<cdot>x)\<cdot>s'))"
unfolding bind_stateT_def by simp

lemma runStateT_bind [simp]:
  "runStateT\<cdot>(m \<bind> k)\<cdot>s = runStateT\<cdot>m\<cdot>s \<bind> (\<Lambda> (x, s'). runStateT\<cdot>(k\<cdot>x)\<cdot>s')"
unfolding bind_stateT_def by simp

end


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

theory n_mutualEx_lemma_inv__2_on_rules imports n_mutualEx_lemma_on_inv__2
begin
section{*All lemmas on causal relation between inv__2*}
lemma lemma_inv__2_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__2  p__Inv4)"
  shows "invHoldForRule Interp s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule Interp s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__2) done
    }

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

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

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

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

end


theory Deadlock_Checking
  imports Deadlock_Impl Uppaal_Networks.UPPAAL_Model_Checking
begin

paragraph \<open>Standard Deadlock Checker Implementation\<close>
context Reachability_Problem_Impl
begin

definition deadlock_checker where
  "deadlock_checker \<equiv>
    let
      key = return \<circ> fst;
      sub = subsumes_impl;
      copy = state_copy_impl;
      start = a\<^sub>0_impl;
      final = (\<lambda>_. return False);
      succs = succs_impl;
      empty = emptiness_check_impl;
      P = check_deadlock_neg_impl;
      trace = tracei
    in do {
      r1 \<leftarrow> is_start_in_states_impl;
      if r1 then do {
        r2 \<leftarrow> check_passed_impl succs start final sub empty key copy trace P;
        return r2
      }
      else return True
    }
    "

interpretation ta_bisim: Bisimulation_Invariant
  "(\<lambda>(l, u) (l', u'). conv_A A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>)"
  "(\<lambda>(l, u) (l', u'). conv_A A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>)"
  "(\<lambda>(l, u) (l', u'). l' = l \<and> (\<forall> c. c \<in> clk_set (conv_A A) \<longrightarrow> u c = u' c))"
  "(\<lambda>_. True)" "(\<lambda>_. True)"
  by (rule ta_bisimulation[of "conv_A A"])

lemma deadlock_zero_clock_val_iff:
  "(\<exists>u\<^sub>0. (\<forall>c\<in>{1..n}. u\<^sub>0 c = 0) \<and> deadlock (l\<^sub>0, u\<^sub>0)) \<longleftrightarrow> deadlock (l\<^sub>0, \<lambda>_. 0)"
  apply safe
  subgoal for u
    using clocks_I[of "\<lambda>_. 0" u] by (subst ta_bisim.deadlock_iff; simp)
  by auto

context
  assumes F_fun_False: "\<And>x. F_fun x = False" and F_False: "F = (\<lambda>_. False)"
begin
lemma F_impl_is_False:
  "F_impl = (\<lambda>_. return False)"
  unfolding F_impl_def F_fun_False by simp

lemma deadlock_checker_correct:
  "(uncurry0 deadlock_checker, uncurry0 (Refine_Basic.RETURN (deadlock (l\<^sub>0, \<lambda>_. 0))))
  \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  unfolding
    deadlock_checker_def Let_def F_impl_is_False[symmetric]
    check_passed_impl_start_def[symmetric] deadlock_zero_clock_val_iff[symmetric]
  using check_passed_impl_start_hnr[OF F_False] .

lemmas deadlock_checker_hoare = deadlock_checker_correct[to_hnr, unfolded hn_refine_def, simplified]

end

end

context UPPAAL_Reachability_Problem_precompiled'
begin

text \<open>
  \<^item> @{term equiv.defs.states'}
  \<^item> @{term EA} is @{term equiv.state_ta},
    the state automaton constructed from UPPAAL network (\<open>equiv\<close>/\<open>N\<close>)
  \<^item> @{term A} is @{term equiv.defs.prod_ta},
    the product automaton constructed from UPPAAL network (\<open>equiv\<close>/\<open>N\<close>)
\<close>

context
  fixes \<phi>
  assumes formula_is_false: "formula = formula.EX (and \<phi> (not \<phi>))"
begin

lemma F_is_FalseI:
  shows "PR_CONST (\<lambda>(x, y). F x y) = (\<lambda>_. False)"
  unfolding F_def by (subst formula_is_false) auto

lemma final_fun_is_False:
  "final_fun a = False"
  unfolding final_fun_def by (subst formula_is_false) auto

lemmas deadlock_checker_hoare = impl.deadlock_checker_hoare[
    OF final_fun_is_False F_is_FalseI, folded deadlock_start_iff has_deadlock_def]

end

schematic_goal deadlock_checker_alt_def:
  "impl.deadlock_checker \<equiv> ?impl"
  unfolding impl.deadlock_checker_def impl.succs_impl_def
  unfolding impl.E_op''_impl_def impl.abstr_repair_impl_def impl.abstra_repair_impl_def
  unfolding
    impl.start_inv_check_impl_def impl.unbounded_dbm_impl_def
    impl.unbounded_dbm'_def unbounded_dbm_def
  unfolding k_impl_alt_def
  unfolding impl.check_deadlock_neg_impl_def impl.check_deadlock_impl_def
  unfolding impl.is_start_in_states_impl_def
  apply (abstract_let k_i ceiling)
  apply (abstract_let "inv_fun :: (_ \<times> int list \<Rightarrow> _)" inv)
  apply (abstract_let "trans_fun" trans)
  unfolding impl.init_dbm_impl_def impl.a\<^sub>0_impl_def
  unfolding impl.F_impl_def
  unfolding impl.subsumes_impl_def
  unfolding impl.emptiness_check_impl_def
  unfolding impl.state_copy_impl_def
  by (rule Pure.reflexive)

schematic_goal deadlock_checker_alt_def_refined:
  "impl.deadlock_checker \<equiv> ?impl"
  unfolding deadlock_checker_alt_def
  unfolding fw_impl'_int
  unfolding inv_fun_def trans_fun_def trans_s_fun_def trans_i_fun_def
  unfolding trans_i_from_impl
  unfolding runf_impl runt_impl check_g_impl pairs_by_action_impl check_pred_impl
  apply (abstract_let "IArray (map IArray inv)" inv_array)
  apply (abstract_let "IArray (map IArray trans_out_map)" trans_out)
  apply (abstract_let "IArray (map IArray trans_in_map)" trans_in)
  apply (abstract_let "IArray (map IArray trans_i_map)" trans_internal)
  apply (abstract_let "IArray bounds" bounds_array)
  apply (abstract_let PF PF)
  apply (abstract_let PT PT)
  unfolding PF_alt_def PT_alt_def
  apply (abstract_let PROG' PROG')
  unfolding PROG'_def
  apply (abstract_let "length prog" len_prog)
  apply (abstract_let "IArray (map (map_option stripf) prog)" prog_f)
  apply (abstract_let "IArray (map (map_option stript) prog)" prog_t)
  apply (abstract_let "IArray prog" prog_array)
  unfolding all_actions_by_state_impl
  apply (abstract_let "[0..<p]" p_ran)
  apply (abstract_let "[0..<na]" num_actions_ran)
  apply (abstract_let "{0..<p}" num_processes_ran)
  apply (abstract_let "[0..<m+1]" num_clocks_ran)
  by (rule Pure.reflexive)

end

concrete_definition deadlock_checker uses
  UPPAAL_Reachability_Problem_precompiled'.deadlock_checker_alt_def_refined

definition
  "precond_dc
    num_processes num_clocks clock_ceiling max_steps I T prog bounds program s\<^sub>0 num_actions
  \<equiv>
    if UPPAAL_Reachability_Problem_precompiled'
      num_processes num_clocks max_steps I T prog bounds program s\<^sub>0 num_actions clock_ceiling
    then
      deadlock_checker
        num_processes num_clocks max_steps I T prog bounds program s\<^sub>0 num_actions clock_ceiling
      \<bind> (\<lambda>x. return (Some x))
    else return None"

theorem deadlock_check:
  "<emp>
      precond_dc p m k max_steps I T prog bounds P s\<^sub>0 na
   <\<lambda> Some r \<Rightarrow> \<up>(
       UPPAAL_Reachability_Problem_precompiled' p m max_steps I T prog bounds P s\<^sub>0 na k \<and>
       r = has_deadlock (conv (N p I P T prog bounds)) max_steps (repeat 0 p, s\<^sub>0, \<lambda>_ . 0))
    | None \<Rightarrow> \<up>(\<not> UPPAAL_Reachability_Problem_precompiled' p m max_steps I T prog bounds P s\<^sub>0 na k)
   >\<^sub>t"
proof -
  define A where "A \<equiv> conv (N p I P T prog bounds)"
  note [sep_heap_rules] = UPPAAL_Reachability_Problem_precompiled'.deadlock_checker_hoare[
      OF _ HOL.refl,
      of p m max_steps I T prog bounds P s\<^sub>0 na k,
      unfolded UPPAAL_Reachability_Problem_precompiled_defs.init_def,
      folded A_def
      ]
  show ?thesis
    unfolding A_def[symmetric] precond_dc_def
    by (sep_auto simp:
        deadlock_checker.refine[symmetric] UPPAAL_Reachability_Problem_precompiled_defs.init_def
        mod_star_conv has_deadlock_def)
qed

export_code precond_dc checking SML

end


theory VCG_Check

imports Logic

begin

(* theorems for the checking the correctness of vcg *)

lemma  write_consistent_defined_address:
  "\<Turnstile> \<lbrace> \<lambda>s. aval lval s = Some vp \<and> aval rval s = Some v \<and> Addr vp \<notin> incon_set s \<and>
      ptable_lift_m (heap s) (root s) (mode s) (Addr vp) = Some pp \<rbrace>  lval ::= rval \<lbrace>\<lambda>s. heap s pp = Some v \<rbrace>"
   by vcgm

(* successful memory writes to inconsistent address after flushing, in Kernel Mode *)

lemma [simp]:
  "aval e s = Some v \<Longrightarrow> aval e (s\<lparr>incon_set := {}\<rparr>) = Some v "
  by (induct e arbitrary: v; clarsimp split: option.splits; fastforce)

lemma [simp]:
  "aval e s = Some v \<Longrightarrow> aval e (s\<lparr>incon_set := {}, ptable_snapshot := \<lambda>a. ({}, \<lambda>v. Fault) \<rparr>) = Some v "
  by (induct e arbitrary: v; clarsimp split: option.splits; fastforce)

end


theory Diff_Arr_Safe
  imports Diff_Arr
begin

context
begin

qualified definition lookup where
  "lookup arr i = do {
    len \<leftarrow> Diff_Arr.length arr;
    if i < len
    then Diff_Arr.lookup arr i
    else return (undefined(i - len))
  }"

qualified definition update where
  "update arr i v = do {
    len \<leftarrow> Diff_Arr.length arr;
    if i < len
    then Diff_Arr.update arr i v
    else return arr
  }"

qualified definition update_tailrec where
  "update_tailrec arr i v = do {
    len \<leftarrow> Diff_Arr.length arr;
    if i < len
    then Diff_Arr.update_tailrec arr i v
    else return arr
  }"

lemma nth_undefined: "i \<ge> length xs \<Longrightarrow> xs ! i = undefined(i - length xs)"
  unfolding List.nth_def
  by(induction xs arbitrary: i)(auto split: nat.split)

lemma lookup_safe [sep_heap_rules]: "
  <master_assn t * \<up>(t \<turnstile> xs \<sim> a)>
     lookup a i
  <\<lambda>r. master_assn t * \<up>(r = xs!i)>"
  unfolding lookup_def
  apply sep_auto
  using length
  apply sep_auto
  apply sep_auto
  using lookup
  by(sep_auto simp: nth_undefined[of xs i])+

lemma update_safe [sep_heap_rules]: "
  <master_assn t * \<up>(t \<turnstile> xs \<sim> diff_arr)>
     update diff_arr i v
  <\<lambda>diff_arr. \<exists>\<^sub>At'. master_assn t' *
    \<up>((\<forall>xs' diff_arr'. t \<turnstile> xs' \<sim> diff_arr' \<longrightarrow> t' \<turnstile> xs' \<sim> diff_arr')
      \<and> (t' \<turnstile> xs[i := v] \<sim> diff_arr))>"
  unfolding update_def
  apply sep_auto
  apply(rule fi_rule[OF length, where F = emp])
  apply sep_auto+
  apply(rule cons_post_rule)
  apply(rule fi_rule[OF update, where F = emp])
  by sep_auto+

lemma update_tailrec_safe [sep_heap_rules]: "
  <master_assn t * \<up>(t \<turnstile> xs \<sim> diff_arr)>
     update_tailrec diff_arr i v
  <\<lambda>diff_arr. \<exists>\<^sub>At'. master_assn t' *
    \<up>((\<forall>xs' diff_arr'. t \<turnstile> xs' \<sim> diff_arr' \<longrightarrow> t' \<turnstile> xs' \<sim> diff_arr')
      \<and> (t' \<turnstile> xs[i := v] \<sim> diff_arr))>"
  unfolding update_tailrec_def
  apply sep_auto
  apply(rule fi_rule[OF length, where F = emp])
  apply sep_auto+
  apply(rule cons_post_rule)
  apply(rule fi_rule[OF update_tailrec, where F = emp])
  by sep_auto+

end

end


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

theory PackedTypes
imports 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)"
    by (metis len_of_addr_card max_size)

  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 (metis le_unat_uoi nat_less_le unat_of_nat_len)

  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)"
        by (metis c_guard_no_wrap ptr_val.ptr_val_def std)

      have szt': "size_td t < 2 ^ len_of TYPE(addr_bitsize)"
        by (metis len_of_addr_card max_size std)

      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)"
          by (metis One_nat_def of_nat_mono_maybe_le b0 less_imp_diff_less nat_le_Suc_less)
        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 (metis uofn word_le_nat_alt)
      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]
        by (metis (no_types) add.assoc intvl_less_upper)
      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
        by (metis add_diff_cancel_left' intvl_le_lower word_diff_ls(4))
      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]
        by (metis Nat.add_diff_assoc One_nat_def Suc_leI of_nat_add unat_of_nat_len)
      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 (metis ofn unat_sub 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 (metis (no_types) One_nat_def Suc_leI le_m1_iff_lt of_nat_1 of_nat_diff of_nat_mono_maybe
                               semiring_1_class.of_nat_0 size_of_def unat_less_helper)

        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]
          using intvl_cut by auto

        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"
          by (subst heap_list_nth, rule unx) simp

        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