(*
    Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

header {* \isaheader{Correctness of the LBV} *}

theory LBVCorrect
imports LBVSpec Typing_Framework
begin

locale lbvs = lbv +
  fixes s\<^sub>0  :: 'a
  fixes c   :: "'a list"
  fixes ins :: "'b list"
  fixes \<tau>s  :: "'a list"
  defines phi_def:
  "\<tau>s \<equiv> map (\<lambda>pc. if c!pc = \<bottom> then wtl (take pc ins) c 0 s\<^sub>0 else c!pc)
       [0..<size ins]"

  assumes bounded: "bounded step (size ins)"
  assumes cert: "cert_ok c (size ins) \<top> \<bottom> A"
  assumes pres: "pres_type step (size ins) A"

lemma (in lbvs) phi_None [intro?]:
  "\<lbrakk> pc < size ins; c!pc = \<bottom> \<rbrakk> \<Longrightarrow> \<tau>s!pc = wtl (take pc ins) c 0 s\<^sub>0"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) phi_Some [intro?]:
  "\<lbrakk> pc < size ins; c!pc \<noteq> \<bottom> \<rbrakk> \<Longrightarrow> \<tau>s!pc = c!pc"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) phi_len [simp]: "size \<tau>s = size ins"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) wtl_suc_pc:
  assumes all: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>"
  assumes pc:  "pc+1 < size ins"
  shows "wtl (take (pc+1) ins) c 0 s\<^sub>0 \<sqsubseteq>\<^sub>r \<tau>s!(pc+1)"
(*<*)
proof -
  from all pc
  have "wtc c (pc+1) (wtl (take (pc+1) ins) c 0 s\<^sub>0) \<noteq> T" by (rule wtl_all)
  with pc show ?thesis by (simp add: phi_def wtc split: split_if_asm)
qed
(*>*)

lemma (in lbvs) wtl_stable:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>"
  assumes s\<^sub>0:  "s\<^sub>0 \<in> A" and  pc:  "pc < size ins"
  shows "stable r step \<tau>s pc"
(*<*)
proof (unfold stable_def, clarify)
  fix pc' s' assume step: "(pc',s') \<in> set (step pc (\<tau>s ! pc))"
                      (is "(pc',s') \<in> set (?step pc)")

  from bounded pc step have pc': "pc' < size ins" by (rule boundedD)

  have tkpc: "wtl (take pc ins) c 0 s\<^sub>0 \<noteq> \<top>" (is "?s\<^sub>1 \<noteq> _") using wtl by (rule wtl_take)
  have s\<^sub>2: "wtl (take (pc+1) ins) c 0 s\<^sub>0 \<noteq> \<top>" (is "?s\<^sub>2 \<noteq> _") using wtl by (rule wtl_take)

  from wtl pc have wt_s\<^sub>1: "wtc c pc ?s\<^sub>1 \<noteq> \<top>" by (rule wtl_all)

  have c_Some: "\<forall>pc t. pc < size ins \<longrightarrow> c!pc \<noteq> \<bottom> \<longrightarrow> \<tau>s!pc = c!pc"
    by (simp add: phi_def)
  have c_None: "c!pc = \<bottom> \<Longrightarrow> \<tau>s!pc = ?s\<^sub>1" using pc ..

  from wt_s\<^sub>1 pc c_None c_Some
  have inst: "wtc c pc ?s\<^sub>1  = wti c pc (\<tau>s!pc)"
    by (simp add: wtc split: split_if_asm)

  have "?s\<^sub>1 \<in> A" using pres cert s\<^sub>0 wtl pc by (rule wtl_pres)
  with pc c_Some cert c_None
  have "\<tau>s!pc \<in> A" by (cases "c!pc = \<bottom>") (auto dest: cert_okD1)
  with pc pres
  have step_in_A: "snd`set (?step pc) \<subseteq> A" by (auto dest: pres_typeD2)

  show "s' \<sqsubseteq>\<^sub>r \<tau>s!pc'"
  proof (cases "pc' = pc+1")
    case True
    with pc' cert
    have cert_in_A: "c!(pc+1) \<in> A" by (auto dest: cert_okD1)
    from True pc' have pc1: "pc+1 < size ins" by simp
    with tkpc have "?s\<^sub>2 = wtc c pc ?s\<^sub>1" by - (rule wtl_Suc)
    with inst
    have merge: "?s\<^sub>2 = merge c pc (?step pc) (c!(pc+1))" by (simp add: wti)
    also from s\<^sub>2 merge have "\<dots> \<noteq> \<top>" (is "?merge \<noteq> _") by simp
    with cert_in_A step_in_A
    have "?merge = (map snd [(p',t') \<leftarrow> ?step pc. p'=pc+1] \<Squnion>\<^bsub>f\<^esub> c!(pc+1))"
      by (rule merge_not_top_s)
    finally have "s' \<sqsubseteq>\<^sub>r ?s\<^sub>2" using step_in_A cert_in_A True step
      by (auto intro: pp_ub1')
    also from wtl pc1 have "?s\<^sub>2 \<sqsubseteq>\<^sub>r \<tau>s!(pc+1)" by (rule wtl_suc_pc)
    also note True [symmetric]
    finally show ?thesis by simp
  next
    case False
    from wt_s\<^sub>1 inst
    have "merge c pc (?step pc) (c!(pc+1)) \<noteq> \<top>" by (simp add: wti)
    with step_in_A have "\<forall>(pc', s')\<in>set (?step pc). pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'"
      by - (rule merge_not_top)
    with step False  have ok: "s' \<sqsubseteq>\<^sub>r c!pc'" by blast
    moreover from ok have "c!pc' = \<bottom> \<Longrightarrow> s' = \<bottom>" by simp
    moreover from c_Some pc'  have "c!pc' \<noteq> \<bottom> \<Longrightarrow> \<tau>s!pc' = c!pc'" by auto
    ultimately show ?thesis by (cases "c!pc' = \<bottom>") auto
  qed
qed
(*>*)

lemma (in lbvs) phi_not_top:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>" and pc:  "pc < size ins"
  shows "\<tau>s!pc \<noteq> \<top>"
(*<*)
proof (cases "c!pc = \<bottom>")
  case False with pc
  have "\<tau>s!pc = c!pc" ..
  also from cert pc have "\<dots> \<noteq> \<top>" by (rule cert_okD4)
  finally show ?thesis .
next
  case True with pc
  have "\<tau>s!pc = wtl (take pc ins) c 0 s\<^sub>0" ..
  also from wtl have "\<dots> \<noteq> \<top>" by (rule wtl_take)
  finally show ?thesis .
qed
(*>*)

lemma (in lbvs) phi_in_A:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>" and s\<^sub>0: "s\<^sub>0 \<in> A"
  shows "\<tau>s \<in> list (size ins) A"
(*<*)
proof -
  { fix x assume "x \<in> set \<tau>s"
    then obtain xs ys where "\<tau>s = xs @ x # ys"
      by (auto simp add: in_set_conv_decomp)
    then obtain pc where pc: "pc < size \<tau>s" and x: "\<tau>s!pc = x"
      by (simp add: that [of "size xs"] nth_append)

    from pres cert wtl s\<^sub>0 pc
    have "wtl (take pc ins) c 0 s\<^sub>0 \<in> A" by (auto intro!: wtl_pres)
    moreover
    from pc have "pc < size ins" by simp
    with cert have "c!pc \<in> A" ..
    ultimately
    have "\<tau>s!pc \<in> A" using pc by (simp add: phi_def)
    hence "x \<in> A" using x by simp
  }
  hence "set \<tau>s \<subseteq> A" ..
  thus ?thesis by (unfold list_def) simp
qed
(*>*)

lemma (in lbvs) phi0:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>" and 0: "0 < size ins"
  shows "s\<^sub>0 \<sqsubseteq>\<^sub>r \<tau>s!0"
(*<*)
proof (cases "c!0 = \<bottom>")
  case True
  with 0 have "\<tau>s!0 = wtl (take 0 ins) c 0 s\<^sub>0" ..
  moreover have "wtl (take 0 ins) c 0 s\<^sub>0 = s\<^sub>0" by simp
  ultimately have "\<tau>s!0 = s\<^sub>0" by simp
  thus ?thesis by simp
next
  case False
  with 0 have "\<tau>s!0 = c!0" ..
  moreover
  have "wtl (take 1 ins) c 0 s\<^sub>0 \<noteq> \<top>" using wtl by (rule wtl_take)
  with 0 False
  have "s\<^sub>0 \<sqsubseteq>\<^sub>r c!0" by (auto simp add: neq_Nil_conv wtc split: split_if_asm)
  ultimately
  show ?thesis by simp
qed
(*>*)

theorem (in lbvs) wtl_sound_strong:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>"
  assumes s\<^sub>0: "s\<^sub>0 \<in> A" and ins: "0 < size ins"
  shows "\<exists>\<tau>s \<in> list (size ins) A. wt_step r \<top> step \<tau>s \<and> s\<^sub>0 \<sqsubseteq>\<^sub>r \<tau>s!0"
(*<*)
proof -
  have "\<tau>s \<in> list (size ins) A" using wtl s\<^sub>0 by (rule phi_in_A)
  moreover
  have "wt_step r \<top> step \<tau>s"
  proof (unfold wt_step_def, intro strip conjI)
    fix pc assume "pc < size \<tau>s"
    then obtain pc: "pc < size ins" by simp
    with wtl show "\<tau>s!pc \<noteq> \<top>" by (rule phi_not_top)
    from wtl s\<^sub>0 and pc show "stable r step \<tau>s pc" by (rule wtl_stable)
  qed
  moreover from wtl ins have "s\<^sub>0 \<sqsubseteq>\<^sub>r \<tau>s!0" by (rule phi0)
  ultimately show ?thesis by fast
qed
(*>*)

end


section \<open>List Comprehension\<close>

theory List_Comprehension
  imports Data_List
begin

no_notation
  disj (infixr "|" 30)

nonterminal llc_qual and llc_quals

syntax
  "_llc" :: "'a \<Rightarrow> llc_qual \<Rightarrow> llc_quals \<Rightarrow> ['a]" ("[_ | __")
  "_llc_gen" :: "'a \<Rightarrow> ['a] \<Rightarrow> llc_qual" ("_ <- _")
  "_llc_guard" :: "tr \<Rightarrow> llc_qual" ("_")
  "_llc_let" :: "letbinds \<Rightarrow> llc_qual" ("let _")
  "_llc_quals" :: "llc_qual \<Rightarrow> llc_quals \<Rightarrow> llc_quals" (", __")
  "_llc_end" :: "llc_quals" ("]")
  "_llc_abs" :: "'a \<Rightarrow> ['a] \<Rightarrow> ['a]"

translations
  "[e | p <- xs]" => "CONST concatMap\<cdot>(_llc_abs p [e])\<cdot>xs"
  "_llc e (_llc_gen p xs) (_llc_quals q qs)"
    => "CONST concatMap\<cdot>(_llc_abs p (_llc e q qs))\<cdot>xs"
  "[e | b]" => "If b then [e] else []"
  "_llc e (_llc_guard b) (_llc_quals q qs)"
    => "If b then (_llc e q qs) else []"
  "_llc e (_llc_let b) (_llc_quals q qs)"
    => "_Let b (_llc e q qs)"

parse_translation \<open>
let open HOLCF_Library in
  let
    val NilC = Syntax.const @{const_syntax "Nil"};

    fun Lam x = Syntax.const @{const_syntax "Abs_cfun"} $ x;

    fun fresh_var ts ctxt =
      let
        val ctxt' = fold Variable.declare_term ts ctxt
      in
        singleton (Variable.variant_frees ctxt' []) ("x", dummyT)
      end

    fun pat_tr ctxt p e = (* %x. case x of p => e | _ => [] *)
      let
        val x = Free (fresh_var [p, e] ctxt);
        val case1 = Syntax.const @{syntax_const "_case1"} $ p $ e;
        val case2 =
          Syntax.const @{syntax_const "_case1"} $
            Syntax.const @{const_syntax Pure.dummy_pattern} $ NilC;
        val cs = Syntax.const @{syntax_const "_case2"} $ case1 $ case2;
      in
        (* FIXME: handle HOLCF patterns correctly *)
        Syntax_Trans.abs_tr [x, Case_Translation.case_tr false ctxt [x, cs]]
        |> Lam
      end

    fun abs_tr ctxt [p, e] =
      (case Term_Position.strip_positions p of
        Free (s, T) => Lam (Syntax_Trans.abs_tr [p, e])
      | _ => pat_tr ctxt p e)

  in [(@{syntax_const "_llc_abs"}, abs_tr)] end
end
\<close>

lemma concatMap_singleton [simp]:
  "concatMap\<cdot>(\<Lambda> x. [f\<cdot>x])\<cdot>xs = map\<cdot>f\<cdot>xs"
  by (induct xs) simp_all

lemma listcompr_filter [simp]:
  "[x | x <- xs, P\<cdot>x] = filter\<cdot>P\<cdot>xs"
proof (induct xs)
  case (Cons a xs)
  then show ?case by (cases "P\<cdot>a"; simp)
qed simp_all

lemma "[y | let y = x*2; z = y, x <- xs] = A"
  apply simp
  oops

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 PackedTypes
imports "../lib/$L4V_ARCH/WordSetup" CProof
begin

section {* Underlying definitions for the class axioms *}

text {* field_access / field_update is the identity for packed types *}

definition
  "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 {* field_access is independent of the underlying bytes *}

definition
  "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 {* Lemmas about td_fafu_idem *}

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 `td_fafu_idem s` `wf_fd s`
        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 -
      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 `td_fafu_idem s` `wf_fd s`
      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 `field_lookup_list (p' # ts') f 0 = Some (s, n)` by (simp split: option.splits)
qed (clarsimp split: if_split_asm)+

subsection {* td_fa_hi *}

(* \<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 = "op @"])
    apply (erule Cons_typ_desc.hyps, simp, simp)
    apply (erule Cons_typ_desc.hyps, simp, simp)
    done
next
  case DTPair_typ_desc
  from DTPair_typ_desc.prems show ?case
    by simp (erule (2) DTPair_typ_desc.hyps)
qed

section {* Simp rules for deriving packed props from the type combinators *}

subsection {* td_fafu_idem *}

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
  apply (cases s)
  apply (rename_tac typ_struct xs)
  apply (case_tac typ_struct)
   apply simp
  apply (simp add: td_fafu_idem_list_append)
  done

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

(* Beer crime? *)
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
      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 add: 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)
    apply simp
   apply 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)"
  apply (induct n)
   apply (simp add: array_tag_n.simps empty_typ_info_def)
  apply (simp add: array_tag_n.simps)
  apply (rule td_fafu_idem_ti_typ_combine)
    apply simp
   apply simp
  apply simp
  done

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]))"
  apply (clarsimp simp add: typ_info_array array_tag_def fa_fu_idem_def)
  apply (erule td_fafu_idem_array_n)
  apply simp
  done

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

subsection {* td_fa_hi *}

(* 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
  apply (cases s)
  apply (rename_tac typ_struct xs)
  apply (case_tac typ_struct)
   apply simp
  apply (simp add: td_fa_hi_list_append)
  done

(* Beer crime? *)
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 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_fa_hi_adjust_ti [OF fg wf_fd], assumption)
  apply (simp add: td_fa_hi_list_append)
  apply (subst td_fa_hi_adjust_ti [OF fg wf_fd], assumption)
  done

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)"
  apply (induct n)
   apply (simp add: array_tag_n.simps empty_typ_info_def)
  apply (simp add: array_tag_n.simps)
  apply (rule td_fa_hi_ti_typ_combine)
    apply simp
   apply simp
  apply simp
  done

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]))"
  apply (clarsimp simp add: typ_info_array array_tag_def fa_fu_idem_def)
  apply (erule td_fa_hi_array_n)
  apply simp
  done

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

section {* The type class and simp sets *}

text {* 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 *}

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 =
  -- "Axioms"
  td_fafu_idem
  -- "Combinators"
  td_fafu_idem_final_pad td_fafu_idem_ti_typ_pad_combine td_fafu_idem_ti_typ_combine td_fafu_idem_empty_typ_info
  -- "Constructors"
  td_fafu_idem_ptr td_fafu_idem_word td_fafu_idem_array

lemmas td_fa_hi_intro_simps =
  -- "Axioms"
  td_fa_hi
  -- "Combinators"
  td_fa_hi_final_pad td_fa_hi_ti_typ_pad_combine td_fa_hi_ti_typ_combine td_fa_hi_empty_typ_info
  -- "Constructors"
  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 {* Instances *}

text {* Words (of multiple of 8 size) are packed *}

instantiation word :: (len8) packed_type
begin
instance
 apply(intro_classes)
   apply (rule td_fafu_idem_word)
  apply (rule td_fa_hi_word)
  done
end

text {* Pointers are always packed *}

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

text {* Arrays of packed types are in turn packed *}

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
  apply(intro_classes)
   apply (simp add: td_fafu_idem_intro_simps)
  apply (simp add: td_fa_hi_intro_simps)
  done

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

section {* Theorems about packed types *}

subsection {* td_fa_hi *}

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"
 apply(simp add:heap_update_def)
 apply(rule ext)
 apply(case_tac "x \<in> {ptr_val p..+size_of TYPE('a)}")
  apply((subst heap_update_mem_same_point, simp, simp)+)
  apply(simp add:to_bytes_def)
  apply(subst heap_independence)
    apply(simp)
   prefer 2
   apply(force)
  apply(simp)
 apply((subst heap_update_nmem_same, simp)+)
 apply(rule refl)
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 {* td_fafu_idem *}

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)
   apply (rule of_nat_mono_maybe_le)
    apply simp
   apply simp
  apply assumption
  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 using lbs
  apply -
  apply (rule heap_independence)
   apply simp
  apply (simp add: size_of_def)
  done

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 `Suc m' < n'` by simp
  next
    case (Suc n'')
    hence "m' < n''" using `Suc m' < n'` 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

(* Similar in TypHeap, but for w32 *)
lemma unat_minus':
  fixes x :: "'a :: len word"
  shows "x \<noteq> 0 \<Longrightarrow> unat (-x) = 2 ^ len_of TYPE('a) - unat x"
  apply (simp add: unat_def word_minus_def)
  apply (simp add: int_word_uint zmod_zminus1_eq_if uint_0_iff)
  apply (subst nat_diff_distrib)
    apply simp
   apply (rule order_less_imp_le [OF uint_lt2p])
   apply (clarsimp simp: nat_power_eq)
   done

lemma word_wrap_of_natD:
  fixes x :: "'a :: len word"
  assumes wraps: "\<not> x \<le> x + of_nat n"
  shows   "\<exists>k. x + of_nat k = 0 \<and> k \<le> n"
proof -
  show ?thesis
  proof (rule exI [where x = "unat (- x)"], intro conjI)
    show "x + of_nat (unat (-x)) = 0"
      by simp
  next
    show "unat (-x) \<le> n"
    proof (subst unat_minus')
      from wraps show "x \<noteq> 0"
        by (rule contrapos_pn, simp add: not_le)
    next
      show "2 ^ len_of TYPE('a) - unat x \<le> n" using wraps
        apply (simp add: no_olen_add_nat le_diff_conv not_less)
        apply (erule order_trans)
        apply (simp add: unat_of_nat)
        done
    qed
  qed
qed

lemma nat_le_Suc_less:
  "0 < y \<Longrightarrow> (x \<le> y - Suc 0) = (x < y)"
  by arith

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: unat_simps)

  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

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory ArchVSpaceLookup_AI
imports "../SubMonad_AI"
 "Lib.Crunch_Instances_NonDet"
begin

definition
  "lookup_walk cs m ref p \<equiv> {(r, q). \<exists>h. ref = h @ r \<and> (r, q) \<in> cs\<^sup>* `` m \<and> (([], q),h, p) \<in> cs\<^sup>*}"

definition
  "trans_depends kh cs f \<equiv> \<forall>q h p. (([],q),h,p) \<in> cs = (\<exists>obj. obj = kh q \<and> f obj p h)"

definition
  "lookup_leaf ptr cs =  {(ref,p). (([],ptr),ref, p) \<in> cs^*}"

definition
lookup_refs ::"'c \<Rightarrow> ('c \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> ('a list \<times> 'b) set"
where "lookup_refs obj f \<equiv> {(h,p). f obj p h}"

definition
lookupable_refs :: "(('a list \<times> 'b) \<times> 'a list \<times> 'b) set \<Rightarrow> 'a list set \<Rightarrow> ('a list \<times> 'b) set \<Rightarrow> ('a list \<times> 'b) set"
where  "lookupable_refs cs refs m \<equiv> {(ref, p). \<exists>tref href. href\<in>refs \<and> ref=tref@href \<and> (tref,p)\<in>cs^* `` m}"

definition
  "reachable vset \<equiv> (\<lambda>(ref, p). p) ` vset"

locale wellformed_lookup =
  fixes cs :: "(('c list \<times> 'a) \<times> 'c list \<times> 'a) set" and kh and f
  assumes trans_depends: "trans_depends kh cs f"
  assumes lookup1_is_append:
      "((r , q), rs, p) \<in> cs \<Longrightarrow> \<exists>ref. rs = ref # r"
  assumes lookup1_append:
      "((ra @ b, q), r @ b, p) \<in> cs \<Longrightarrow> ((ra, q), r, p) \<in> cs"
  assumes lookup1_cut:
      "((ra, q), r, p) \<in> cs \<Longrightarrow> ((ra @ b, q), r @ b, p) \<in> cs"
  assumes graph_inject:
      "\<And>p q obj ref. \<lbrakk>f obj p ref; f obj q ref\<rbrakk> \<Longrightarrow> p = q"
  assumes graph_single_step:
      "\<And>p obj ref. \<lbrakk>f obj p ref\<rbrakk> \<Longrightarrow> \<exists>r. ref = [r]"

context wellformed_lookup
begin

lemma lookup_refs_lookup1:
  "lookup_refs (kh ptr) f = {(h,p). (([],ptr),h,p) \<in> cs}"
  apply (insert  trans_depends)
  apply (clarsimp simp: trans_depends_def lookup_refs_def)
  done

lemma lookupable_refs_reach_self:
  "(rs, ptr) \<in> lookupable_refs cs {ref. (ref, ptr) \<in> cs\<^sup>* `` rset} refs
  \<Longrightarrow> \<exists>rs'. (rs', ptr) \<in> cs^* `` rset"
  apply (clarsimp simp: lookupable_refs_def Image_def)
  apply fastforce
  done

lemma lookup1_append_singleton:
  "((a, b), ref # a, q) \<in> cs \<Longrightarrow> (([], b), [ref], q) \<in> cs"
  apply (rule lookup1_append)
  apply fastforce
  done

lemma lookup1_cut_singleton:
  "(([], b), [ref], q) \<in> cs \<Longrightarrow> ((a, b), ref # a, q) \<in> cs "
  apply (drule lookup1_cut)
  apply fastforce
  done

lemma trans_dependsD:
  "(([],p), ref, q ) \<in> cs \<Longrightarrow> f (kh p) q ref"
  apply (insert trans_depends)
  apply (simp add: trans_depends_def)
  done

lemma trans_depends_eq:
  "(([],q),h,p) \<in> cs = f (kh q) p h"
  apply (insert trans_depends)
  apply (clarsimp simp: trans_depends_def)
  done

lemma lookup_empty_refl:
  "((a, p), [], q) \<in> cs\<^sup>* \<Longrightarrow> a = [] \<and> p = q"
  apply (erule rtranclE)
   apply simp
  apply (case_tac y)
  apply (clarsimp dest!: lookup1_is_append)
  done

lemma lookup_empty_refl_eq[simp]:
  "((a, p), [], q) \<in> cs\<^sup>* \<longleftrightarrow> a = [] \<and> p = q"
  using lookup_empty_refl by auto

lemma lookup1_same_leaf:
  "\<lbrakk>(a, refs, p) \<in> cs; (a, refs, q) \<in> cs\<rbrakk> \<Longrightarrow> p = q"
  apply (case_tac a)
  apply clarsimp
  apply (frule lookup1_is_append)
  apply clarsimp
  apply (drule lookup1_append_singleton)
  apply (drule lookup1_append_singleton)
  apply (clarsimp dest!: trans_dependsD)
  apply (drule graph_inject)
  apply simp+
  done

lemma lookup_ref_step:
  "((ref, ptr), ref', p) \<in> cs\<^sup>* \<Longrightarrow> \<exists>r. ref' = r @ ref"
  proof (induct "length ref'" arbitrary: ref' ref ptr p)
  case 0
    assume xs: "0 = length ref'"
      and  "((ref, ptr), ref', p) \<in> cs\<^sup>*"
  thus ?case
    apply simp
    done
  next
  case Suc
  show ?case
    apply (cut_tac Suc.prems Suc.hyps(2))
    apply (erule rtranclE)
     apply fastforce
    apply (case_tac y)
    apply (case_tac ref')
     apply clarsimp
    apply simp
    apply (drule Suc.hyps(1)[rotated])
     apply (clarsimp dest!: lookup1_is_append )+
    done
  qed

lemma lookup_trancl_append_1: (* This is true because the lengh of the lookup is always increased by 1 *)
  "((ra @ [b], q), r @ [b], p) \<in> cs\<^sup>*
  \<Longrightarrow> ((ra, q), r, p) \<in> cs\<^sup>*"
  proof (induct "length r - length ra" arbitrary: ra r q p)
  case 0
    assume "0 = length r - length ra"
    and "((ra @ [b], q), r @ [b], p) \<in> cs\<^sup>*"
  thus ?case
    apply simp
    apply (erule rtranclE)
     apply simp
    apply (case_tac y)
    apply simp
    apply (frule lookup_ref_step)
    apply (clarsimp dest!: lookup1_is_append)
    done
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (erule rtranclE)
     apply simp
    apply (case_tac y)
    apply clarsimp
    apply (frule lookup_ref_step)
    apply clarsimp
    apply (drule Suc.hyps(1)[where r = "a @ b" for a b, rotated,simplified])
     apply (clarsimp dest!: lookup1_is_append)
    apply (drule lookup1_append[where ra = "a @ b" for a b, simplified])
    apply (erule rtrancl.intros)
    apply simp
    done
  qed

lemma lookup_trancl_append:
  "((ra @ ref, b), r @ ref, p) \<in> cs^* \<Longrightarrow> ((ra, b), r, p) \<in> cs^*"
  proof (induct "length ref" arbitrary: ref ra r b p)
  case 0
  assume "((ra @ ref, b), r @ ref, p) \<in> cs ^*"
     and " 0 = length ref"
  thus ?case
    by simp
  next
  case Suc
  have t: "\<And>a b c. a @ b # c = (a @ [b]) @ c"
    by auto
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (case_tac ref)
     apply clarsimp+
    apply (subst(asm) t)
    apply (subst(asm) t[where a = r])
    apply (frule(1) Suc.hyps(1)[rotated])
    apply (drule lookup_trancl_append_1)
    apply fastforce
    done
  qed

lemma lookup_leaf_from_lookup:
  assumes neq: "ref' \<noteq> ref"
  shows "\<lbrakk>((ref, p), ref', q) \<in> cs\<^sup>* \<rbrakk>
  \<Longrightarrow> \<exists>r ptr. ref' = r @ ref \<and> (([],p),[last r],ptr) \<in> cs \<and> (r,q) \<in> lookup_leaf p cs"
  apply (frule lookup_ref_step)
  apply clarsimp
  apply (erule converse_rtranclE)
   apply (insert neq)
   apply clarsimp
  apply (case_tac y)
  apply (rule conjI)
   apply clarsimp
   apply (rename_tac r mref ptr)
   apply (rule_tac x = ptr in exI)
   subgoal ex
    apply (clarsimp dest!: lookup_ref_step)
    apply (rule_tac ra = "[]" and b = ref in lookup1_append)
    apply (frule lookup1_is_append)
    apply clarsimp
    done
  apply (clarsimp simp: lookup_leaf_def)
  apply (rule converse_rtrancl_into_rtrancl)
  apply (rule ex)
      apply simp+
  apply (rule_tac ref = ref in lookup_trancl_append)
  apply (frule lookup_ref_step)
  apply (clarsimp dest!: lookup1_is_append)
  done

lemma lookupE:
  assumes rcl: "((ref, p), ref', q) \<in> cs\<^sup>*"
  assumes eq: "\<lbrakk>ref' = ref; p = q\<rbrakk> \<Longrightarrow> P ref' ref p q cs"
  and neq: "\<And>r ptr. \<lbrakk>ref' \<noteq> ref; ref' = r @ ref;  (([],p),[last r],ptr) \<in> cs; (r,q) \<in> lookup_leaf p cs\<rbrakk> \<Longrightarrow> P ref' ref p q cs"
  shows "P ref' ref p q cs"
  apply (insert rcl)
  apply (case_tac "ref' = ref")
   apply (rule eq)
    apply simp
   apply (erule rtranclE)
    apply simp
   apply (clarsimp dest!: lookup1_is_append lookup_ref_step)
  apply (frule(1) lookup_leaf_from_lookup)
  apply (elim disjE conjE exE)
  apply (rule neq)
   apply simp+
  done

lemma lookup_forwardE:
  assumes rcl: "(([], p), ref, q) \<in> cs\<^sup>*"
  assumes eq: "\<lbrakk>ref = []; p = q\<rbrakk> \<Longrightarrow> P ref p q cs"
  and neq1: "\<And>r. \<lbrakk>ref = [r]; (([], p), [r], q) \<in> cs\<rbrakk> \<Longrightarrow> P ref p q cs"
  and neq: "\<And>r ptr ref'. \<lbrakk>ref \<noteq> []; ref = r @ [ref'];  (([],p),[ref'],ptr) \<in> cs; (([], ptr), r, q) \<in> cs\<^sup>*\<rbrakk> \<Longrightarrow> P ref p q cs"
  shows "P ref p q cs"
  apply (insert rcl)
  apply (erule converse_rtranclE)
   apply (rule eq)
    apply (simp add: eq)
   apply simp
  apply clarsimp
  apply (frule lookup_ref_step)
  apply (frule lookup1_is_append)
  apply (elim exE)+
  apply (case_tac r)
   apply (rule neq1)
    apply simp
   apply clarsimp
   apply (erule rtranclE, simp)
   apply (clarsimp dest!: lookup1_is_append)
  apply clarsimp
  apply (drule lookup_trancl_append[where ra = "[]" and r = "h # g" for h g,simplified])
  apply (drule neq[rotated 2])
    apply simp+
  done

lemma lookup_rtrancl_stepD:
  "(([],p), [r], q) \<in> cs^* \<Longrightarrow> (([],p),[r],q) \<in> cs"
  apply (erule rtranclE)
  apply simp
  apply clarsimp
  apply (frule lookup_ref_step)
  apply clarsimp
  apply (erule rtranclE)
   apply simp
  apply (clarsimp dest!: lookup_ref_step lookup1_is_append)
  done

lemma lookup_rtrancl_stepsD:
  "(([], p), r @ [ref'], q) \<in> cs\<^sup>* \<Longrightarrow> \<exists>ptr. (([],p),[ref'],ptr) \<in> cs \<and> (([], ptr), r, q) \<in> cs\<^sup>*"
  apply (erule lookup_forwardE)
  apply clarsimp+
  apply force+
  done

lemma lookup_trancl_cut_1:
  (* This is true because the lengh of the lookup is always increased by 1 *)
  "((ra, q), r, p) \<in> cs\<^sup>* \<Longrightarrow> ((ra @ [b], q), r @ [b], p) \<in> cs\<^sup>*"
    proof (induct "length r - length ra" arbitrary: ra r q p)
  case 0
    assume " 0 = length r - length ra"
    and "((ra , q), r , p) \<in> cs\<^sup>*"
  thus ?case
    apply simp
    apply (frule lookup_ref_step)
    apply clarsimp
    apply (erule rtranclE)
     apply simp
    apply (case_tac y)
    apply simp
    apply (frule lookup_ref_step)
    apply (clarsimp dest!: lookup1_is_append)
    done
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (erule rtranclE)
     apply simp
    apply (case_tac y)
    apply clarsimp
    apply (frule lookup_ref_step)
    apply clarsimp
    apply (drule Suc.hyps(1)[where r = "a @ b" for a b, rotated,simplified])
     apply (clarsimp dest!: lookup1_is_append)
    apply (erule rtrancl.intros)
    apply (frule lookup1_cut)
    apply simp
    done
  qed

lemma lookup_trancl_cut:
  "((ra, b), r, p) \<in> cs\<^sup>* \<Longrightarrow> ((ra @ ref, b), r @ ref, p) \<in> cs\<^sup>*"
  proof (induct "length ref" arbitrary: ref ra r b p)
  case 0
  assume "((ra, b), r, p) \<in> cs\<^sup>*"
     and " 0 = length ref"
  thus ?case
    by simp
  next
  case Suc
  have t: "\<And>a b c. a @ b # c = (a @ [b]) @ c"
    by auto
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (case_tac ref rule: rev_cases)
     apply clarsimp+
    apply (frule(1) Suc.hyps(1)[rotated])
    apply (drule lookup_trancl_cut_1)
        apply (drule lookup_trancl_cut_1)
    apply fastforce
    done
  qed

lemma empty_lookup_walk:
  "lookup_walk cs m [] p = {ptr. ptr \<in> m \<and> fst ptr = [] \<and> snd ptr = p }"
  by (fastforce simp: lookup_walk_def)

lemma lookup_walk_stepI1:
  "\<lbrakk>p \<in> lookup_walk cs m ref ptr; (([], ptr), [q], ptr') \<in> cs\<rbrakk> \<Longrightarrow> p \<in> lookup_walk cs m (q # ref) ptr'"
  apply (clarsimp simp: lookup_walk_def)
  apply (rule conjI, fastforce)
  apply (erule rtrancl_into_rtrancl)
  apply (erule lookup1_cut[where ra = "[]" and r = "[q]", simplified])
  done

lemma lookup_walk_stepsI1:
  "\<lbrakk>p \<in> lookup_walk cs m ref ptr; (([], ptr), refs, ptr') \<in> cs^*\<rbrakk> \<Longrightarrow> p \<in> lookup_walk cs m (refs @ ref) ptr'"
  apply (clarsimp simp: lookup_walk_def)
  apply (rule conjI, fastforce)
  apply (erule rtrancl_trans)
  apply (erule lookup_trancl_cut[where ra = "[]" and r = "refs", simplified])
  done

lemma lookup_walk_stepI2:
  "\<lbrakk>(ref, ptr) \<in> lookup_walk cs m ref ptr; (([], ptr), [q], ptr') \<in> cs\<rbrakk>
  \<Longrightarrow> (q#ref,ptr') \<in> lookup_walk cs m (q # ref) ptr'"
  apply (clarsimp simp: lookup_walk_def Image_def)
  apply (erule bexI[rotated])
  apply (erule rtrancl_into_rtrancl)
  apply (drule lookup1_cut)
  apply fastforce
  done

lemma lookup_walk_step_hdD:
  "(refs, p) \<in> lookup_walk cs m refs p \<Longrightarrow> (refs, p)\<in> m \<or> (\<exists>y. (tl refs,y) \<in> lookup_walk cs m (tl refs) y \<and> (([],y), [hd refs], p) \<in> cs)"
  apply (clarsimp simp: lookup_walk_def del: disjCI)
  apply (erule rtranclE)
   apply simp
  apply (rule disjI2)
  apply (case_tac y, clarsimp)
  apply (frule lookup1_is_append)
  apply clarsimp
  apply (intro conjI exI)
   apply fastforce
  apply (erule lookup1_append_singleton)
  done

lemma lookup_walk_stepD:
  "p \<in> lookup_walk cs m (ref # refs) q
  \<Longrightarrow> p = (ref # refs, q)
      \<or> (\<exists>ptr r. r @ (fst p) = refs \<and> p \<in> lookup_walk cs m refs ptr \<and> (([],ptr),[ref], q) \<in> cs)"
  apply (clarsimp simp: lookup_walk_def del: disjCI)
  apply (erule rtranclE)
   apply clarsimp
  apply (case_tac ya, clarsimp del: disjCI)
  apply (frule lookup1_is_append)
  apply (clarsimp del: disjCI)
  apply (rule conjI)
   apply force
  apply (intro exI conjI)
   apply force
  apply (erule lookup1_append_singleton)
  done

lemma reachable_walk:
  "(ref, p) \<in> (cs^* `` m) \<Longrightarrow> (ref, p) \<in> lookup_walk cs m ref p"
  by (clarsimp simp: lookup_walk_def)

lemma lookup_trans_eq:
  "((refs, b), refs, p) \<in> cs\<^sup>* \<Longrightarrow> b = p"
  by (erule lookup_trancl_append[where ra = "[]" and r = "[]" , simplified])

lemma lookup1_same_parent:
  "\<lbrakk>(a, refs, p) \<in> cs; (b, refs, q) \<in> cs\<rbrakk> \<Longrightarrow> fst a = fst b"
  apply (insert trans_depends)
  apply (case_tac a,case_tac b)
  apply (clarsimp dest!: lookup1_is_append)
  done

lemma lookupable_is_unique:
 "\<lbrakk>(sref, refs, p) \<in> cs^*; (sref, refs, q) \<in> cs^* \<rbrakk>
 \<Longrightarrow> p = q"
  proof (induct "length refs - length (fst sref)" arbitrary: p q sref refs)
  case 0
  thus ?case
    apply (insert "local.0.prems" "local.0.hyps")
    apply (cases sref, simp)
    apply (case_tac "fst sref = refs")
     apply (clarsimp dest!: lookup_trans_eq)
    apply clarsimp
    apply (drule lookup_leaf_from_lookup[rotated])
     apply simp
    apply clarsimp
    done
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (erule rtranclE, simp)
    apply (erule rtranclE, simp)
    apply (frule_tac a = y and b = ya in lookup1_same_parent)
     apply simp
    apply (case_tac y, clarsimp)
    apply (drule(1) Suc.hyps(1)[rotated])
     apply (fastforce dest!: lookup1_is_append)
   apply clarsimp
   apply (erule(1) lookup1_same_leaf)
   done
  qed

lemma lookup_walk_reduce:
  "(ref, ptr) \<in> lookup_walk cs m refs q
  \<Longrightarrow> (ref, ptr) \<in> lookup_walk cs m ref ptr"
  by (clarsimp simp: lookup_walk_def)

lemma lookup_walk_trivial:
  "a \<in> lookup_walk cs m ref ptr
  \<Longrightarrow> (ref, ptr) \<in> lookup_walk cs m ref ptr"
  apply (clarsimp simp: lookup_walk_def Image_def)
  apply (erule bexI[rotated])
  apply (erule rtrancl_trans)
  apply clarsimp
  apply (drule_tac ref = x in lookup_trancl_cut)
  apply clarsimp
  done

lemma lookup_walk_imp_reachable:
  "p \<in> lookup_walk cs m r ptr \<Longrightarrow> (r, ptr) \<in> cs^* `` m"
  apply (clarsimp simp: lookup_walk_def Image_def)
  apply (erule bexI[rotated])
  apply (erule rtrancl_trans)
  apply (erule lookup_trancl_cut[where ra = "[]", simplified])
  done

lemma lookup_trancl_walk:
  "(([], pa), ref, rptr) \<in> cs\<^sup>* \<Longrightarrow> (ref, rptr) \<in> lookup_walk cs {([],pa)} ref rptr"
  by (clarsimp simp: lookup_walk_def)

lemma lookup1_eq_ref:
  "(ref, ptr) \<in> lookup_walk cs m ref p \<Longrightarrow> p = ptr"
  by (clarsimp simp: lookup_walk_def)

lemma lookup_walk_decomp:
  "(a, ptr) \<in> lookup_walk cs rset r rptr \<Longrightarrow>
  \<exists>h. r = h @ a \<and> (h,rptr) \<in> lookup_walk cs ({([], ptr)}) h rptr"
  apply (clarsimp simp: lookup_walk_def)
  done

lemma lookup_walk_decomp_more:
  "(h @ [b],rptr) \<in> lookup_walk cs ({([], ptr)}) (h @ [b]) rptr \<Longrightarrow>
    \<exists>p. (([], ptr), [b], p) \<in> cs \<and> (([], p), h, rptr) \<in> cs\<^sup>*"
  apply (clarsimp simp: lookup_walk_def)
  apply (erule converse_rtranclE)
   apply clarsimp
  apply clarsimp
  apply (frule lookup1_is_append)
  apply clarsimp
  apply (frule lookup_ref_step)
  apply (intro exI conjI)
   apply force
  apply (rule lookup_trancl_append)
  apply force
  done

lemma lookupable_refs_set:
  shows "lookupable_refs cs refs (lookup_refs a f)
    \<subseteq> lookupable_refs cs refs (lookup_refs a f - lookup_refs b f) \<union> lookupable_refs cs refs (lookup_refs b f)"
  apply (fastforce simp: lookupable_refs_def Image_def)
  done

lemma in_lookupable_refsI:
  "\<lbrakk>(ref, ptr) \<in> cs\<^sup>* `` rset; f obj b a ; ((a, b), refs, rptr) \<in> cs\<^sup>*\<rbrakk> \<Longrightarrow>
  (refs @ ref, rptr) \<in> lookupable_refs cs {ref. (ref, ptr) \<in> cs\<^sup>* `` rset} (lookup_refs obj f)"
  apply (clarsimp simp: lookupable_refs_def Image_def)
  apply (intro exI conjI)
    apply fastforce
   apply fastforce
  apply (clarsimp simp: lookup_refs_def)
  apply fastforce
  done

(* The main result for this locale *)
theorem khupd_graph_subset:
  assumes wlcs: "wellformed_lookup cs' (kh(ptr := obj)) f"
  shows "(refs, p) \<in> cs'^* `` rset \<Longrightarrow> \<exists>sref. (sref, p) \<in> cs^* `` rset \<union> lookupable_refs cs
      {ref. (ref, ptr) \<in> cs^* `` rset} (lookup_refs obj f)"
  proof (induct "length refs" arbitrary: refs p)
   case 0
   note "0.prems" "0.hyps"
   thus ?case
    apply clarsimp
    apply (erule rtranclE, fastforce)
    apply (clarsimp dest!: wellformed_lookup.lookup1_is_append[OF wlcs])
    done
   next
   case Suc
   thus ?case
    apply (insert Suc.hyps(2) Suc.prems)
    apply (clarsimp del: disjCI)
    apply (erule rtranclE)
     apply fastforce
    apply (case_tac y, clarsimp del: disjCI)
    apply (rename_tac ref mptr)
    apply (frule  wellformed_lookup.lookup1_is_append[OF wlcs])
    apply (clarsimp del: disjCI)
    apply (drule Suc.hyps(1))
     apply (fastforce simp: Image_def)
    apply clarsimp
    apply (case_tac "mptr = ptr")
     apply (elim disjE)
      apply (rule_tac x = "refa # sref" in exI)
      apply (rule disjI2)
      apply (clarsimp simp: lookupable_refs_def lookup_refs_def)
      apply (drule wellformed_lookup.lookup1_append_singleton[OF wlcs])
      apply (clarsimp dest!:wellformed_lookup.trans_dependsD[OF wlcs])
      apply ((rule exI | rule conjI | force)+)[1]
     apply clarsimp
     apply (clarsimp simp: lookupable_refs_def)
     apply (intro disjI2 exI conjI | force)+
      apply (drule wellformed_lookup.lookup1_append_singleton[OF wlcs])
      apply (clarsimp dest!:wellformed_lookup.trans_dependsD[OF wlcs])
      apply (fastforce simp: Image_def lookup_refs_def)
    apply (clarsimp simp: Image_def)
    apply (drule wellformed_lookup.lookup1_append_singleton[OF wlcs])
    apply (clarsimp dest!:wellformed_lookup.trans_dependsD[OF wlcs])
    apply (rule exI)
    apply (elim disjE)
     apply (rule disjI1)
     apply (clarsimp simp: Image_def trans_depends_eq[symmetric])
     apply ((intro conjI bexI
              | simp add: obj_at_def
              | erule lookup1_cut_singleton
              | erule rtrancl_into_rtrancl)+)[1]
    apply (rule disjI2)
    apply (clarsimp simp: lookupable_refs_def Image_def trans_depends_eq[symmetric])
    apply (intro conjI exI)
      apply (rule_tac x = "(aa,ba)" in bexI)
       apply simp+
    apply (clarsimp simp: lookup_refs_def)
    apply ((intro conjI exI bexI
              | simp add: obj_at_def
              | erule lookup1_cut_singleton
              | erule rtrancl_into_rtrancl)+)[1]
    done
   qed
end

lemma lookup_bound_estimate:
  assumes wlcs: "wellformed_lookup cs kh f"
  and   wlcs': "wellformed_lookup cs' kh' f"
  and bound: "\<And>p. lookup_refs (kh' p) f \<subseteq> lookup_refs (kh p) f"
  shows "(refs, p) \<in> cs'^* `` rset \<Longrightarrow> (refs, p) \<in> cs^* `` rset"
  apply (clarsimp simp: Image_def)
  apply (erule_tac x = "(a,b)" in bexI[rotated])
  apply (induct refs arbitrary: p)
   apply (erule rtranclE)
   apply (clarsimp dest!: wellformed_lookup.lookup1_is_append[OF wlcs'])+
  apply (erule rtranclE)
   apply simp
  apply (rule_tac b = y in rtrancl_into_rtrancl)
   apply (clarsimp dest!: wellformed_lookup.lookup1_is_append[OF wlcs'])
  apply (case_tac y,clarsimp)
  apply (frule wellformed_lookup.lookup_ref_step[OF wlcs'])
  apply clarsimp
  apply (frule wellformed_lookup.lookup1_is_append[OF wlcs'])
  apply clarsimp
  apply (rule  wellformed_lookup.lookup1_cut[OF wlcs,where ra = "[]" and r = "[a]" for a,simplified])
  apply (drule wellformed_lookup.lookup1_append[OF wlcs', where ra = "[]" and r = "[a]" for a, simplified])
  apply (simp add: wellformed_lookup.trans_depends_eq[OF wlcs] wellformed_lookup.trans_depends_eq[OF wlcs'])
  apply (insert bound)
  apply (clarsimp simp: lookup_refs_def)
  apply fastforce
  done

lemma trans_depends_vs_walk:
  assumes wlcs: "wellformed_lookup cs kh f"
    and   wlcs': "wellformed_lookup cs' kh' f"
    and stick: "\<And>r q. (r, q) \<in> lookup_walk cs m ref p \<Longrightarrow> kh' q = kh q"
  shows "lookup_walk cs m ref p \<subseteq> lookup_walk cs' m ref p"
  apply (subgoal_tac "\<forall>r q. (r, q) \<in> lookup_walk cs m ref p \<longrightarrow> kh' q = kh q")
  prefer 2
    apply (clarsimp simp: stick)
  proof (induct ref arbitrary: p)
  case Nil
  show ?case
    by (simp add: wellformed_lookup.empty_lookup_walk[OF wlcs]
                  wellformed_lookup.empty_lookup_walk[OF wlcs'])
  next
  case Cons
  show ?case
    apply clarsimp
    apply (frule wellformed_lookup.lookup_walk_stepD[OF wlcs])
    apply (elim disjE)
     apply clarsimp
     apply (drule wellformed_lookup.lookup_walk_step_hdD[OF wlcs])
     apply (erule disjE)
      apply (fastforce simp: lookup_walk_def Image_def)
     apply clarsimp
     apply (rule wellformed_lookup.lookup_walk_stepI2[OF wlcs'])
      apply (erule subsetD[OF Cons.hyps, rotated])
      apply clarsimp
      apply (drule(1) wellformed_lookup.lookup_walk_stepI1[OF wlcs])
      apply (insert Cons.prems, fastforce)
     apply (drule(1) wellformed_lookup.lookup_walk_stepI1[OF wlcs])
     apply (clarsimp simp: wellformed_lookup.trans_depends_eq[OF wlcs] wellformed_lookup.trans_depends_eq[OF wlcs'])
    apply (elim exE conjE)
    apply (rule wellformed_lookup.lookup_walk_stepI1[OF wlcs'])
     apply (erule subsetD[OF Cons.hyps,rotated])
     apply clarsimp
      apply (drule(1) wellformed_lookup.lookup_walk_stepI1[OF wlcs])
      apply (insert Cons.prems, fastforce)
    apply clarsimp
    apply (drule_tac ptr = ptr in wellformed_lookup.lookup_walk_trivial[OF wlcs])
    apply (drule(1) wellformed_lookup.lookup_walk_stepI1[OF wlcs])
    apply (clarsimp simp: wellformed_lookup.trans_depends_eq[OF wlcs] wellformed_lookup.trans_depends_eq[OF wlcs'])
    done
  qed

locale wellformed_order_lookup = wellformed_lookup +
  fixes ev :: "'b\<Rightarrow>nat" and rset
  assumes lookup1_increase: "\<And>p q r ref. \<lbrakk>(ref,p) \<in> cs^* `` rset; (([],p),[r],q) \<in> cs \<rbrakk> \<Longrightarrow> ev (kh p) < ev (kh q)"

context wellformed_order_lookup
begin
lemma lookup1_increaseD:
  "\<lbrakk>(ref,p) \<in> cs^* `` rset; (([],p),[r],q) \<in> cs\<rbrakk> \<Longrightarrow> ev (kh p) < ev (kh q)"
  apply (insert lookup1_increase)
  apply (fastforce)
  done

lemma lookup_walk_distinct_strong:
  "(ref, ptr) \<in> lookup_walk cs rset (r @ ref) q \<Longrightarrow> (ev (kh ptr)) < (ev (kh q)) \<or> r = []"
  proof (induct "length r" arbitrary: ref ptr q r)
  case 0
  show ?case
    apply (insert "local.0")
    by clarsimp
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (case_tac r, simp)
    apply clarsimp
    apply (drule lookup_walk_stepD)
    apply (elim disjE, clarsimp)
    apply clarsimp
    apply (frule Suc.hyps(1)[rotated])
     apply fastforce
    apply (elim disjE)
     apply (frule lookup_walk_imp_reachable)
     apply (drule(1) lookup1_increaseD)
     apply clarsimp
    apply (frule lookup_walk_imp_reachable)
    apply (drule(1) lookup1_increaseD)
    apply (clarsimp dest!:lookup1_eq_ref)
    done
  qed

lemma lookup1_trans_increase:
  "\<lbrakk>(ref,p) \<in> cs^* `` rset; ((a,p),b,q) \<in> cs^+ \<rbrakk> \<Longrightarrow> ev (kh p) < ev (kh q)"
  apply (drule reachable_walk)
  apply (frule lookup_ref_step[OF trancl_into_rtrancl])
  apply clarsimp
  apply (drule lookup_walk_stepsI1)
   apply (rule lookup_trancl_append)
   apply force
  apply (drule lookup_walk_distinct_strong)
  apply clarsimp
  apply (erule tranclE)
   apply (clarsimp dest!: lookup1_is_append lookup_ref_step trancl_into_rtrancl)+
  done

lemma lookup_walk_unique:
  "(ref', ptr) \<in> lookup_walk cs rset ref ptr \<Longrightarrow> ref = ref'"
  proof (induct "length ref" arbitrary: ref ptr ref')
  case 0
  show ?case
    apply (insert "local.0")
    by (clarsimp simp:empty_lookup_walk)
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (case_tac ref)
     apply simp
    apply clarsimp
    apply (drule lookup_walk_stepD)
    apply (elim disjE, clarsimp)
    apply clarsimp
    apply (frule lookup_walk_distinct_strong)
    apply (frule lookup_walk_imp_reachable)
    apply (drule(1) lookup1_increaseD)
    apply (clarsimp dest!: lookup1_eq_ref)
    done
  qed

lemma lookup_walk_unique_from_root:
  "\<lbrakk>(([], ptr), b, ptr) \<in> cs^*; (ref,ptr) \<in> cs^* `` rset\<rbrakk> \<Longrightarrow> b = []"
  apply (subgoal_tac "b @ ref = ref")
   apply simp
  apply (rule lookup_walk_unique)
  apply (simp add: lookup_walk_def)
  done

lemma  lookup_walk_kh_upd:
  "\<lbrakk>wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset; (q, ptr) \<in> lookup_walk cs rset q ptr \<rbrakk>
    \<Longrightarrow> (q, ptr) \<in> lookup_walk cs' rset q ptr"
  apply (case_tac q)
   apply (clarsimp simp: empty_lookup_walk)
   apply (fastforce simp: lookup_walk_def Image_def)
  apply clarsimp
  apply (frule lookup_walk_step_hdD)
   apply (elim disjE)
   apply (fastforce simp: lookup_walk_def Image_def)
  apply (clarsimp simp: Image_def)
  apply (cut_tac m = rset and ref = list and p = y
          in trans_depends_vs_walk[OF local.wellformed_lookup_axioms])
    apply (erule wellformed_order_lookup.axioms)
   apply clarsimp
   apply (drule_tac p = "(r, ptr)" in lookup_walk_stepI1[rotated])
    apply simp
   apply (clarsimp dest!: lookup_walk_unique)
   apply (drule lookup_walk_decomp)
   apply simp
  apply (rule wellformed_lookup.lookup_walk_stepI2)
    apply (erule wellformed_order_lookup.axioms)
   apply fastforce
  apply (subst wellformed_lookup.trans_depends_eq)
   apply (erule wellformed_order_lookup.axioms)
  apply (subgoal_tac "y \<noteq> ptr")
   apply (simp add: trans_depends_eq)
  apply clarsimp
   apply (drule_tac p = "(list, ptr)" in lookup_walk_stepI1[rotated])
   apply simp
  apply (clarsimp dest!: lookup_walk_unique)
  done

lemma lookup_walk_path_distinct:
  "h \<noteq> [] \<Longrightarrow> (q, ptr) \<in> lookup_walk cs rset (h @ q) rptr \<Longrightarrow> ptr \<noteq> rptr"
  apply (rule ccontr)
  apply clarsimp
  apply (drule lookup_walk_unique)
  apply simp
  done

(*
   This lemma should not be used out side of this locale.
   Please use kpupd_wellformed_order_lookup instead.
*)
lemma khupd_wellform_order_lookup_pref:
  assumes wlos: "wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset"
  shows "cs'^* `` rset \<subseteq> cs^* `` rset \<union> lookupable_refs cs
      {ref. (ref, ptr) \<in> cs^* `` rset} (lookup_refs obj f)"
  proof -
  have wlcs: "wellformed_lookup cs' (kh(ptr := obj)) f"
   by (intro wellformed_order_lookup.axioms[OF wlos])
  have kh_upd_dummy[simp]:
     "(kh(ptr := obj, ptr := kh ptr)) = kh"
  by auto
  have l: "\<And>ys y q.  ys @ y # q = (ys @ [y]) @ q"
  by auto
  show ?thesis
  apply (rule subsetI)
  apply (clarsimp del: disjCI)
  apply (rename_tac r rptr ref p)
  apply (erule rtranclE)
   apply (fastforce simp: wellformed_lookup.empty_lookup_walk[OF wlcs] Image_def)
  apply (insert wlcs)
  apply (drule wellformed_lookup.reachable_walk)
   apply (simp add: Image_def)
   apply fastforce
  apply (case_tac "\<exists>q. (q, ptr) \<in> lookup_walk cs' rset r rptr")
   apply (clarsimp del: disjCI)
   apply (frule_tac ptr = ptr in wellformed_lookup.lookup_walk_reduce[OF wlcs])
   apply (drule_tac obj = "kh ptr" and ptr = ptr and cs' = cs in wellformed_order_lookup.lookup_walk_kh_upd[rotated -1,OF _ wlos])
    apply simp
    apply (rule wellformed_order_lookup_axioms)
   apply (frule_tac rptr = rptr in wellformed_lookup.lookup_walk_decomp[OF wlcs])
   apply (clarsimp del: disjCI)
   apply (rule_tac xs = h in rev_cases)
    apply (clarsimp simp: wellformed_lookup.empty_lookup_walk[OF wlcs])
    apply (simp add: lookup_walk_def)
   apply (rule disjI2)
   apply clarsimp
   apply (drule wellformed_lookup.lookup_walk_decomp_more[OF wlcs])
   apply clarsimp
   apply (drule wellformed_lookup.lookup_trancl_walk[OF wlcs])
   apply (drule_tac ref = q in wellformed_lookup.lookup_walk_reduce[OF wlcs])
   apply (drule_tac c="(ys, rptr)" in subsetD[OF trans_depends_vs_walk,rotated -1])
      apply (rule wlcs)
     apply (rule local.wellformed_lookup_axioms)
    apply clarsimp
    apply (drule_tac ref = r in wellformed_lookup.lookup_walk_reduce[OF wlcs])
    apply (frule_tac ptr = ptr in wellformed_order_lookup.lookup_walk_unique_from_root
                 [OF wlos _ wellformed_lookup.lookup_walk_imp_reachable[OF wlcs],rotated])
     apply (erule converse_rtrancl_into_rtrancl)
     apply (drule wellformed_lookup.lookup_walk_imp_reachable[OF wlcs])+
     apply (clarsimp simp: Image_def)
     apply (rule wellformed_lookup.lookup_trancl_cut[OF wlcs, where ra = "[]",simplified])
     apply simp
    apply simp
   apply (subst l)
   apply (rule in_lookupable_refsI)
     apply (clarsimp dest!: lookup_walk_imp_reachable)
    apply (drule wellformed_lookup.trans_dependsD[OF wlcs])
    apply simp
   apply (rule lookup_trancl_cut[where ra ="[]",simplified])
   apply (clarsimp dest!: lookup_walk_imp_reachable)
   apply simp
  apply (cut_tac m = rset and ref=r and p = rptr
          in trans_depends_vs_walk[OF wlcs local.wellformed_lookup_axioms])
   apply clarsimp
  apply (drule subsetD)
   apply (rule wellformed_lookup.reachable_walk[OF wlcs])
   apply (clarsimp simp: Image_def)
   apply (erule bexI[rotated])
   apply (erule(1) rtrancl_into_rtrancl)
  apply (simp add: lookup_walk_imp_reachable)
  done
  qed

lemma lookupable_refs_reachable:
  "lookupable_refs cs {ref. (ref, ptr) \<in> cs\<^sup>* `` rset} (lookup_refs (kh ptr) f)
   \<subseteq> cs\<^sup>* `` rset"
   apply (clarsimp simp: lookupable_refs_def Image_def lookup_refs_lookup1)
   apply (erule bexI[rotated])
   apply (erule rtrancl_trans)
   apply (frule lookup1_is_append)
   apply clarsimp
   apply (erule converse_rtrancl_into_rtrancl[OF lookup1_cut_singleton])
   apply (drule lookup_trancl_cut)
   apply force
   done

lemma khupd_wellformed_order_lookup_private:
  assumes well_order:
    "\<And>nref np stepref nq sref. \<lbrakk>(nref,np) \<in> cs^* `` (lookup_refs obj f); (([],np),[stepref],nq) \<in> cs; (sref, ptr)\<in> cs^* `` rset\<rbrakk>
    \<Longrightarrow> ev (kh np) < ev (kh nq)"
  and well_order_as_parent:
    "\<And>nref np sref. \<lbrakk>(nref,np) \<in> lookup_refs obj f; (sref, ptr)\<in> cs^* `` rset\<rbrakk> \<Longrightarrow> ev (obj) < ev (kh np)"
  and well_order_as_leaf:
    "\<And>p r sref. \<lbrakk>((r, p), sref, ptr) \<in> cs^+ ;(r, p) \<in> cs^* `` rset\<rbrakk> \<Longrightarrow> ev (kh p) < ev (obj)"
  and wlcs: "wellformed_lookup cs' (kh(ptr := obj)) f"
  shows "ev (kh ptr) \<le> ev obj \<Longrightarrow> wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset"
  apply (intro wellformed_order_lookup.intro[OF wlcs])
  apply (intro wellformed_order_lookup_axioms.intro)
  apply (drule khupd_graph_subset[OF wlcs])
  apply (clarsimp simp: wellformed_lookup.trans_depends_eq[OF wlcs])
  apply (elim disjE)
   apply (clarsimp split: if_splits)
    apply (cut_tac nref = "[r]" and np = q in well_order_as_parent)
      apply (clarsimp simp: Image_def lookup_refs_def)
     apply (fastforce simp: Image_def)
    apply clarsimp
   apply (clarsimp simp: trans_depends_eq[symmetric])
   apply (intro conjI impI)
    apply (rule well_order_as_leaf[rotated])
     apply (fastforce simp: Image_def)
    apply (rule r_into_trancl')
    apply (rule lookup1_cut_singleton)
    apply force
   apply (rule lookup1_increase)
    apply (clarsimp simp: Image_def)
    apply (erule bexI[rotated])
    apply simp
   apply simp
  apply (clarsimp simp: lookupable_refs_def split: if_splits)
   apply (cut_tac nref = "[r]" and np = q in well_order_as_parent)
     apply (clarsimp simp: Image_def lookup_refs_def)
    apply (fastforce simp: Image_def)
   apply clarsimp
  apply (clarsimp simp: trans_depends_eq[symmetric])
  apply (intro conjI impI)
   apply clarsimp
   apply (frule well_order_as_parent)
    apply fastforce
   apply (drule well_order[rotated])
     apply fastforce+
  apply (frule well_order[rotated])
    apply (fastforce)+
  done

lemma khupd_wellformed_order_lookup:
  assumes well_order:
    "\<And>nref np stepref nq sref. \<lbrakk>(nref,np) \<in> cs^* `` (lookup_refs obj f - lookup_refs (kh ptr) f); (([],np),[stepref],nq) \<in> cs; (sref, ptr)\<in> cs^* `` rset\<rbrakk>
    \<Longrightarrow> ev (kh np) < ev (kh nq)"
  and well_order_as_parent:
    "\<And>nref np sref. \<lbrakk>(nref,np) \<in> (lookup_refs obj f - lookup_refs (kh ptr) f); (sref, ptr)\<in> cs^* `` rset\<rbrakk> \<Longrightarrow> ev (obj) < ev (kh np)"
  and well_order_as_leaf:
    "\<And>p r sref. \<lbrakk>((r, p), sref, ptr) \<in> cs^+ ;(r, p) \<in> cs^* `` rset\<rbrakk> \<Longrightarrow> ev (kh p) < ev (obj)"
  and wlcs: "wellformed_lookup cs' (kh(ptr := obj)) f"
  shows "ev (kh ptr) = ev obj \<Longrightarrow> wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset"
  apply (rule khupd_wellformed_order_lookup_private[OF _ _ well_order_as_leaf wlcs])
       apply clarsimp
       apply (case_tac "(a,b) \<in> lookup_refs (kh ptr) f")
        apply (rule lookup1_increaseD)
         apply (clarsimp simp: Image_def)
         apply (erule bexI[rotated])
         apply (erule rtrancl_trans)
         apply (rule converse_rtrancl_into_rtrancl)
          apply (simp add: lookup_refs_lookup1)
          apply (drule_tac b = sref in lookup1_cut[where q = ptr])
          apply fastforce
         apply (erule lookup_trancl_cut)
        apply simp
       apply (rule well_order, fastforce+)
     apply clarsimp
     apply (case_tac "(nref,np) \<in> lookup_refs (kh ptr) f")
      apply (clarsimp simp: Image_def lookup_refs_lookup1)
      apply (frule lookup1_is_append)
      apply clarsimp
      apply (erule subst)
       apply (rule lookup1_trans_increase)
       apply (clarsimp simp: Image_def)
       apply (erule bexI[rotated])
        apply (simp add: lookup_refs_lookup1)+
       apply fastforce
      apply (rule well_order_as_parent,fastforce+)
   done

(* The main result for this locale *)
theorem khupd_graph_subset:
  assumes wlos: "wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset"
  shows "cs'^* `` rset \<subseteq> cs^* `` rset \<union> lookupable_refs cs
      {ref. (ref, ptr) \<in> cs^* `` rset} (lookup_refs obj f - lookup_refs (kh ptr) f)"
  proof -
  have set_plus_mono: "\<And>a b c d. \<lbrakk>a \<subseteq> b \<union> c; c \<subseteq> d\<rbrakk> \<Longrightarrow> a \<subseteq> b \<union> d"
    by auto
  show ?thesis
    apply (insert khupd_wellform_order_lookup_pref[OF wlos])
    apply (drule set_plus_mono)
     apply (rule_tac b = "kh ptr" in lookupable_refs_set)
    apply (cut_tac ptr = ptr in lookupable_refs_reachable)
    apply fastforce
    done
  qed
end

context Arch begin global_naming X64

locale_abbrev "vs_lookup_leaf ptr s \<equiv> lookup_leaf ptr (vs_lookup1 s)"

primrec vsref_of :: "vs_ref \<Rightarrow> word64"
where
  "vsref_of (VSRef x _ ) = x"

definition
  vs_ref_lvl_arch :: "arch_kernel_obj \<Rightarrow> nat"
where
  "vs_ref_lvl_arch atype \<equiv> case aa_type atype of
      AASIDPool \<Rightarrow> 1
    | APageMapL4 \<Rightarrow> 2
    | APDPointerTable \<Rightarrow> 3
    | APageDirectory \<Rightarrow> 4
    | APageTable \<Rightarrow> 5
    | _ \<Rightarrow> 6"

definition
  "vs_ref_lvl obj_opt \<equiv> case_option 7 (arch_obj_fun_lift vs_ref_lvl_arch 7) obj_opt"

lemma vs_ref_lvl_arch_obj [simp]:
  "vs_ref_lvl (Some (ArchObj aobj)) = vs_ref_lvl_arch aobj"
  by (simp add: vs_ref_lvl_def)

lemma vs_ref_lvl_arch_simps [simp]:
  "vs_ref_lvl_arch (ASIDPool ap) = 1"
  "vs_ref_lvl_arch (PageMapL4 pm) = 2"
  "vs_ref_lvl_arch (PDPointerTable pdpt) = 3"
  "vs_ref_lvl_arch (PageDirectory pd) = 4"
  "vs_ref_lvl_arch (PageTable pt) = 5"
  "vs_ref_lvl_arch (DataPage dev sz) = 6"
  by (auto simp: vs_ref_lvl_arch_def aa_type_def)

definition
  "vs_lookup1_on_heap_obj \<equiv> \<lambda>obj q h. (\<exists>ko. obj = Some ko \<and> (\<exists>r. h = [r] \<and> (r, q) \<in> vs_refs ko))"

definition
  "vs_lookup_pages1_on_heap_obj \<equiv> \<lambda>obj q h. (\<exists>ko. obj = Some ko \<and> (\<exists>r. h = [r] \<and> (r, q) \<in> vs_refs_pages ko))"

sublocale vs_lookup1_wellformed:
  wellformed_lookup "vs_lookup1 s" "kheap s" vs_lookup1_on_heap_obj
  apply unfold_locales
       apply (clarsimp simp: trans_depends_def vs_lookup1_def obj_at_def vs_lookup1_on_heap_obj_def)+
   apply (clarsimp simp: vs_refs_def up_ucast_inj_eq graph_of_def
                  split: kernel_object.splits arch_kernel_obj.splits)
  apply (clarsimp simp: vs_lookup1_on_heap_obj_def)
  done

lemmas vs_lookup1_is_wellformed_lookup
  = vs_lookup1_wellformed.wellformed_lookup_axioms

sublocale vs_lookup_pages1_wellformed:
  wellformed_lookup "vs_lookup_pages1 s" "kheap s" vs_lookup_pages1_on_heap_obj
  apply unfold_locales
       apply (clarsimp simp: trans_depends_def vs_lookup_pages1_def obj_at_def vs_lookup_pages1_on_heap_obj_def)+
   apply (clarsimp simp: vs_refs_pages_def up_ucast_inj_eq graph_of_def
                  split: kernel_object.splits arch_kernel_obj.splits)
  apply (clarsimp simp: vs_lookup_pages1_on_heap_obj_def)
  done

lemmas vs_lookup_pages1_is_wellformed_lookup
  = vs_lookup_pages1_wellformed.wellformed_lookup_axioms

lemma vs_refs_pages_vs_ref_lvl:
  "\<lbrakk> ko_at (ArchObj aobj) p s; (r, q) \<in> vs_refs_pages (ArchObj aobj); valid_vspace_obj aobj s \<rbrakk>
     \<Longrightarrow> vs_ref_lvl (kheap s p) < vs_ref_lvl (kheap s q)"
  apply (cases aobj;
         clarsimp simp: vs_refs_pages_def graph_of_def ball_ran_eq obj_at_def
                        pte_ref_pages_def pde_ref_pages_def pdpte_ref_pages_def pml4e_ref_pages_def
                 split: if_splits pte.splits pde.splits pdpte.splits pml4e.splits;
         match premises in H [thin]: "\<forall>i. P (t i)" and J: "t i = v" for P t i v \<Rightarrow>
                              \<open>insert spec[where x=i, OF H]\<close>
                         \<bar> H [thin]: "\<forall>i \<in> S. P (t i)" and J: "t i = v" for P S t i v \<Rightarrow>
                              \<open>insert bspec[where x=i, OF H]\<close>)
  by (auto simp: obj_at_def data_at_def)

lemmas vs_refs_vs_ref_lvl = vs_refs_pages_vs_ref_lvl[OF _ vs_refs_vs_refs_pages]

lemma vs_lookup1_wellformed_order:
  "valid_vspace_objs s
    \<Longrightarrow> wellformed_order_lookup (vs_lookup1 s) (kheap s) vs_lookup1_on_heap_obj
                                vs_ref_lvl (vs_asid_refs (x64_asid_table (arch_state s)))"
  apply (intro wellformed_order_lookup.intro vs_lookup1_wellformed.wellformed_lookup_axioms
               wellformed_order_lookup_axioms.intro)
  apply (simp only: vs_lookup_def2[symmetric])
  apply (clarsimp simp add: vs_lookup1_def)
  apply (case_tac ko; (clarsimp simp: vs_refs_def; fail)?; rename_tac ako; clarsimp)
  apply (frule (2) valid_vspace_objsD)
  apply (case_tac ako; clarsimp simp: vs_refs_def)
     apply (drule (1) graph_of_in_ranD; clarsimp simp: obj_at_def)
    apply (match premises in "(i,_) \<in> graph_of _" for i \<Rightarrow>
            \<open>match premises in H[thin]: "\<forall>i. P i" for P \<Rightarrow> \<open>insert spec[where x=i, OF H]\<close>
                             \<bar> H[thin]: "\<forall>i\<in>_. P i" for P \<Rightarrow> \<open>insert bspec[where x=i, OF H]\<close>\<close>;
           fastforce simp: graph_of_def obj_at_def
                           pde_ref_def pdpte_ref_def pml4e_ref_def
                    split: pde.splits pdpte.splits pml4e.splits if_splits)+
  done

lemma vs_lookup_pages1_wellformed_order:
  "\<lbrakk> valid_vspace_objs s; valid_asid_table (x64_asid_table (arch_state s)) s \<rbrakk>
    \<Longrightarrow> wellformed_order_lookup (vs_lookup_pages1 s) (kheap s) vs_lookup_pages1_on_heap_obj
                                vs_ref_lvl (vs_asid_refs (x64_asid_table (arch_state s)))"
  apply (intro wellformed_order_lookup.intro vs_lookup_pages1_wellformed.wellformed_lookup_axioms
               wellformed_order_lookup_axioms.intro)
  apply (simp only: vs_lookup_pages_def2[symmetric])
  apply (clarsimp simp add: vs_lookup_pages1_def)
  apply (case_tac ko; (clarsimp simp: vs_refs_pages_def; fail)?; rename_tac ako; clarsimp)
  apply (frule (3) valid_vspace_objsD')
  apply (case_tac ako; clarsimp simp: vs_refs_pages_def)
      apply (drule (1) graph_of_in_ranD; clarsimp simp: obj_at_def)
     apply (match premises in "(x,y) \<in> graph_of f" for f x y \<Rightarrow>
             \<open>match premises in H[thin]: "\<forall>i. P i" for P \<Rightarrow> \<open>insert spec[where x=x, OF H]\<close>
                              \<bar> H[thin]: "\<forall>i\<in>_. P i" for P \<Rightarrow> \<open>insert bspec[where x=x, OF H]\<close>\<close>;
            fastforce simp: graph_of_def obj_at_def data_at_def
                            pte_ref_pages_def pde_ref_pages_def pdpte_ref_pages_def pml4e_ref_pages_def
                     split: pte.splits pde.splits pdpte.splits pml4e.splits if_splits)+
  done

definition
  refs_diff :: "(kernel_object option \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> bool)
                  \<Rightarrow> arch_kernel_obj \<Rightarrow> 64 word \<Rightarrow> 'c abstract_state_scheme \<Rightarrow> ('a list \<times> 'b) set"
where
  "refs_diff lf obj ptr s = (lookup_refs (Some (ArchObj obj)) lf - lookup_refs (kheap s ptr) lf)"

end

end


(*  Title:      HOL/Proofs/ex/XML_Data.thy
    Author:     Makarius
    Author:     Stefan Berghofer

XML data representation of proof terms.
*)

theory XML_Data
imports "~~/src/HOL/Isar_Examples/Drinker"
begin

subsection \<open>Export and re-import of global proof terms\<close>

ML \<open>
  fun export_proof ctxt thm =
    let
      val thy = Proof_Context.theory_of ctxt;
      val (_, prop) =
        Logic.unconstrainT (Thm.shyps_of thm)
          (Logic.list_implies (Thm.hyps_of thm, Thm.prop_of thm));
      val prf =
        Proofterm.proof_of (Proofterm.strip_thm (Thm.proof_body_of thm)) |>
        Reconstruct.reconstruct_proof ctxt prop |>
        Reconstruct.expand_proof ctxt [("", NONE)] |>
        Proofterm.rew_proof thy |>
        Proofterm.no_thm_proofs;
    in Proofterm.encode prf end;

  fun import_proof thy xml =
    let
      val prf = Proofterm.decode xml;
      val (prf', _) = Proofterm.freeze_thaw_prf prf;
    in Drule.export_without_context (Proof_Checker.thm_of_proof thy prf') end;
\<close>

subsection \<open>Examples\<close>

ML \<open>val thy1 = @{theory}\<close>

lemma ex: "A \<longrightarrow> A" ..

ML_val \<open>
  val xml = export_proof @{context} @{thm ex};
  val thm = import_proof thy1 xml;
\<close>

ML_val \<open>
  val xml = export_proof @{context} @{thm de_Morgan};
  val thm = import_proof thy1 xml;
\<close>

ML_val \<open>
  val xml = export_proof @{context} @{thm Drinker's_Principle};
  val thm = import_proof thy1 xml;
\<close>

text \<open>Some fairly large proof:\<close>

ML_val \<open>
  val xml = export_proof @{context} @{thm abs_less_iff};
  val thm = import_proof thy1 xml;
  @{assert} (size (YXML.string_of_body xml) > 1000000);
\<close>

end