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

(*
  CSpace refinement
*)

theory CSpace1_R
imports
  CSpace_I
begin

context Arch begin global_naming AARCH64_A (*FIXME: arch_split*)

lemmas final_matters_def = final_matters_def[simplified final_matters_arch_def]

declare final_matters_simps[simp del]

lemmas final_matters_simps[simp]
    = final_matters_def[split_simps cap.split arch_cap.split]

end

context begin interpretation Arch . (*FIXME: arch_split*)

lemma isMDBParentOf_CTE1:
  "isMDBParentOf (CTE cap node) cte =
   (\<exists>cap' node'. cte = CTE cap' node' \<and> sameRegionAs cap cap'
      \<and> mdbRevocable node
      \<and> (isEndpointCap cap \<longrightarrow> capEPBadge cap \<noteq> 0 \<longrightarrow>
           capEPBadge cap = capEPBadge cap' \<and> \<not> mdbFirstBadged node')
      \<and> (isNotificationCap cap \<longrightarrow> capNtfnBadge cap \<noteq> 0 \<longrightarrow>
           capNtfnBadge cap = capNtfnBadge cap' \<and> \<not> mdbFirstBadged node'))"
  apply (simp add: isMDBParentOf_def Let_def split: cte.splits split del: if_split)
  apply (clarsimp simp: Let_def)
  apply (fastforce simp: isCap_simps)
  done

lemma isMDBParentOf_CTE:
  "isMDBParentOf (CTE cap node) cte =
   (\<exists>cap' node'. cte = CTE cap' node' \<and> sameRegionAs cap cap'
      \<and> mdbRevocable node
      \<and> (capBadge cap, capBadge cap') \<in> capBadge_ordering (mdbFirstBadged node'))"
  apply (simp add: isMDBParentOf_CTE1)
  apply (intro arg_cong[where f=Ex] ext conj_cong refl)
  apply (cases cap, simp_all add: isCap_simps)
   apply (auto elim!: sameRegionAsE simp: isCap_simps)
  done

lemma isMDBParentOf_trans:
  "\<lbrakk> isMDBParentOf a b; isMDBParentOf b c \<rbrakk> \<Longrightarrow> isMDBParentOf a c"
  apply (cases a)
  apply (clarsimp simp: isMDBParentOf_CTE)
  apply (frule(1) sameRegionAs_trans, simp)
  apply (erule(1) capBadge_ordering_trans)
  done

lemma parentOf_trans:
  "\<lbrakk> s \<turnstile> a parentOf b; s \<turnstile> b parentOf c \<rbrakk> \<Longrightarrow> s \<turnstile> a parentOf c"
  by (auto simp: parentOf_def elim: isMDBParentOf_trans)

lemma subtree_parent:
  "s \<turnstile> a \<rightarrow> b \<Longrightarrow> s \<turnstile> a parentOf b"
  by (erule subtree.induct) auto

lemma leadsto_is_prev:
  "\<lbrakk> m \<turnstile> p \<leadsto> c; m c = Some (CTE cap node);
    valid_dlist m; no_0 m \<rbrakk> \<Longrightarrow>
  p = mdbPrev node"
  by (fastforce simp add: next_unfold' valid_dlist_def Let_def no_0_def)

lemma subtree_target_Some:
  "m \<turnstile> a \<rightarrow> b \<Longrightarrow> m b \<noteq> None"
  by (erule subtree.cases) (auto simp: parentOf_def)

lemma subtree_prev_loop:
  "\<lbrakk> m p = Some (CTE cap node); no_loops m; valid_dlist m; no_0 m \<rbrakk> \<Longrightarrow>
  m \<turnstile> p \<rightarrow> mdbPrev node = False"
  apply clarsimp
  apply (frule subtree_target_Some)
  apply (drule subtree_mdb_next)
  apply (subgoal_tac "m \<turnstile> p \<leadsto>\<^sup>+ p")
   apply (simp add: no_loops_def)
  apply (erule trancl_into_trancl)
  apply (clarsimp simp: mdb_next_unfold)
  apply (fastforce simp: next_unfold' valid_dlist_def no_0_def Let_def)
  done

lemma subtree_trans_lemma:
  assumes "s \<turnstile> b \<rightarrow> c"
  shows "s \<turnstile> a \<rightarrow> b \<Longrightarrow> s \<turnstile> a \<rightarrow> c"
  using assms
proof induct
  case direct_parent
  thus ?case
    by (blast intro: trans_parent parentOf_trans subtree_parent)
next
  case (trans_parent y z)
  have IH: "s \<turnstile> a \<rightarrow> b \<Longrightarrow> s \<turnstile> a \<rightarrow> y" by fact+
  have step: "s \<turnstile> y \<leadsto> z" "z \<noteq> 0" "s \<turnstile> b parentOf z" by fact+

  have "s \<turnstile> a \<rightarrow> b" by fact+
  hence "s \<turnstile> a \<rightarrow> y" and "s \<turnstile> a parentOf b" by (auto intro: IH subtree_parent)
  moreover
  with step
  have "s \<turnstile> a parentOf z" by - (rule parentOf_trans)
  ultimately
  show ?case using step by - (rule subtree.trans_parent)
qed

lemma subtree_trans: "\<lbrakk> s \<turnstile> a \<rightarrow> b; s \<turnstile> b \<rightarrow> c \<rbrakk> \<Longrightarrow> s \<turnstile> a \<rightarrow> c"
  by (rule subtree_trans_lemma)

lemma same_arch_region_as_relation:
  "\<lbrakk>acap_relation c d; acap_relation c' d'\<rbrakk> \<Longrightarrow>
  arch_same_region_as c c' =
  sameRegionAs (ArchObjectCap d) (ArchObjectCap d')"
  by (cases c; cases c')
     (auto simp: AARCH64_H.sameRegionAs_def sameRegionAs_def Let_def isCap_simps mask_def
                 add_diff_eq)

lemma is_phyiscal_relation:
  "cap_relation c c' \<Longrightarrow> is_physical c = isPhysicalCap c'"
  by (auto simp: is_physical_def arch_is_physical_def
           split: cap.splits arch_cap.splits)

lemma obj_ref_of_relation:
  "\<lbrakk> cap_relation c c'; capClass c' = PhysicalClass \<rbrakk> \<Longrightarrow>
  obj_ref_of c = capUntypedPtr c'"
  by (cases c; simp) (rename_tac arch_cap, case_tac arch_cap, auto)

lemma obj_size_relation:
  "\<lbrakk> cap_relation c c'; capClass c' = PhysicalClass \<rbrakk> \<Longrightarrow>
  obj_size c = capUntypedSize c'"
  apply (cases c, simp_all add: objBits_simps' zbits_map_def
                                cte_level_bits_def
                         split: option.splits sum.splits)
  apply (rename_tac arch_cap)
  apply (case_tac arch_cap; simp add: objBits_def AARCH64_H.capUntypedSize_def bit_simps')
  done

lemma same_region_as_relation:
    "\<lbrakk> cap_relation c d; cap_relation c' d' \<rbrakk> \<Longrightarrow>
  same_region_as c c' = sameRegionAs d d'"
  apply (cases c)
             apply clarsimp
            apply (clarsimp simp: sameRegionAs_def isCap_simps Let_def is_phyiscal_relation)
            apply (auto simp: obj_ref_of_relation obj_size_relation cong: conj_cong)[1]
           apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1]
          apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1]
         apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1]
        apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def bits_of_def)[1]
       apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1]
      apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1]
     apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1]
    apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1]
   apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1]
  apply simp
  apply (cases c')
             apply (clarsimp simp: same_arch_region_as_relation|
                    clarsimp simp: sameRegionAs_def isCap_simps Let_def)+
  done

lemma can_be_is:
  "\<lbrakk> cap_relation c (cteCap cte); cap_relation c' (cteCap cte');
     mdbRevocable (cteMDBNode cte) = r;
     mdbFirstBadged (cteMDBNode cte') = r' \<rbrakk> \<Longrightarrow>
  should_be_parent_of c r c' r' = isMDBParentOf cte cte'"
  unfolding should_be_parent_of_def isMDBParentOf_def
  apply (cases cte)
  apply (rename_tac cap mdbnode)
  apply (cases cte')
  apply (rename_tac cap' mdbnode')
  apply (clarsimp split del: if_split)
  apply (case_tac "mdbRevocable mdbnode")
   prefer 2
   apply simp
  apply (clarsimp split del: if_split)
  apply (case_tac "RetypeDecls_H.sameRegionAs cap cap'")
   prefer 2
   apply (simp add: same_region_as_relation)
  apply (simp add: same_region_as_relation split del: if_split)
  apply (cases c, simp_all add: isCap_simps)
    apply (cases c', auto simp: sameRegionAs_def Let_def isCap_simps)[1]
   apply (cases c', auto simp: sameRegionAs_def isCap_simps is_cap_simps)[1]
  apply (auto simp: Let_def)[1]
  done

lemma no_fail_getCTE [wp]:
  "no_fail (cte_at' p) (getCTE p)"
  apply (simp add: getCTE_def getObject_def split_def
                   loadObject_cte alignCheck_def unless_def
                   alignError_def is_aligned_mask[symmetric]
             cong: kernel_object.case_cong)
  apply (rule no_fail_pre, (wp | wpc)+)
  apply (clarsimp simp: cte_wp_at'_def getObject_def
                        loadObject_cte split_def in_monad
                 dest!: in_singleton
             split del: if_split)
  apply (clarsimp simp: in_monad typeError_def objBits_simps
                        magnitudeCheck_def
                 split: kernel_object.split_asm if_split_asm option.split_asm
             split del: if_split)
       apply simp+
  done

lemma tcb_cases_related:
  "tcb_cap_cases ref = Some (getF, setF, restr) \<Longrightarrow>
    \<exists>getF' setF'. (\<forall>x. tcb_cte_cases (cte_map (x, ref) - x) = Some (getF', setF'))
               \<and> (\<forall>tcb tcb'. tcb_relation tcb tcb' \<longrightarrow> cap_relation (getF tcb) (cteCap (getF' tcb')))"
  by (simp add: tcb_cap_cases_def tcb_cnode_index_def to_bl_1
                cte_map_def' tcb_relation_def
         split: if_split_asm)

lemma pspace_relation_cte_wp_at:
  "\<lbrakk> pspace_relation (kheap s) (ksPSpace s');
    cte_wp_at ((=) c) (cref, oref) s; pspace_aligned' s';
     pspace_distinct' s' \<rbrakk>
  \<Longrightarrow> cte_wp_at' (\<lambda>cte. cap_relation c (cteCap cte)) (cte_map (cref, oref)) s'"
  apply (simp add: cte_wp_at_cases)
  apply (erule disjE)
   apply clarsimp
   apply (drule(1) pspace_relation_absD)
   apply (simp add: unpleasant_helper)
   apply (drule spec, drule mp, erule domI)
   apply (clarsimp simp: cte_relation_def)
   apply (drule(2) aligned_distinct_obj_atI'[where 'a=cte])
    apply simp
   apply (drule ko_at_imp_cte_wp_at')
   apply (clarsimp elim!: cte_wp_at_weakenE')
  apply clarsimp
  apply (drule(1) pspace_relation_absD)
  apply (clarsimp simp: other_obj_relation_def)
  apply (simp split: kernel_object.split_asm)
  apply (drule(2) aligned_distinct_obj_atI'[where 'a=tcb])
   apply simp
  apply (drule tcb_cases_related)
  apply (clarsimp simp: obj_at'_def objBits_simps)
  apply (erule(2) cte_wp_at_tcbI')
   apply fastforce
  apply simp
  done

lemma pspace_relation_ctes_ofI:
  "\<lbrakk> pspace_relation (kheap s) (ksPSpace s');
    cte_wp_at ((=) c) slot s; pspace_aligned' s';
     pspace_distinct' s' \<rbrakk>
  \<Longrightarrow> \<exists>cte. ctes_of s' (cte_map slot) = Some cte \<and> cap_relation c (cteCap cte)"
  apply (cases slot, clarsimp)
  apply (drule(3) pspace_relation_cte_wp_at)
  apply (simp add: cte_wp_at_ctes_of)
  done

lemma get_cap_corres_P:
  "corres (\<lambda>x y. cap_relation x (cteCap y) \<and> P x)
          (cte_wp_at P cslot_ptr)
          (pspace_aligned' and pspace_distinct')
          (get_cap cslot_ptr) (getCTE (cte_map cslot_ptr))"
  apply (rule corres_stronger_no_failI)
   apply (rule no_fail_pre, wp)
   apply clarsimp
   apply (drule cte_wp_at_norm)
   apply (clarsimp simp: state_relation_def)
   apply (drule (3) pspace_relation_ctes_ofI)
   apply (clarsimp simp: cte_wp_at_ctes_of)
  apply (cases cslot_ptr)
  apply (rename_tac oref cref)
  apply (clarsimp simp: cte_wp_at_def)
  apply (frule in_inv_by_hoareD[OF getCTE_inv])
  apply (drule use_valid [where P="\<top>", OF _ getCTE_sp TrueI])
  apply (clarsimp simp: state_relation_def)
  apply (drule pspace_relation_ctes_ofI)
     apply (simp add: cte_wp_at_def)
    apply assumption+
  apply (clarsimp simp: cte_wp_at_ctes_of)
  done

lemmas get_cap_corres = get_cap_corres_P[where P="\<top>", simplified]

lemma cap_relation_masks:
  "cap_relation c c' \<Longrightarrow> cap_relation
      (cap_rights_update (cap_rights c \<inter> rmask) c)
      (RetypeDecls_H.maskCapRights (rights_mask_map rmask) c')"
  apply (case_tac c, simp_all add: isCap_defs maskCapRights_def Let_def
                                 rights_mask_map_def maskVMRights_def
                                 AllowSend_def AllowRecv_def
                                 cap_rights_update_def
                          split del: if_split)
  apply (clarsimp simp add: isCap_defs)
  by (rule ArchAcc_R.arch_cap_rights_update
         [simplified, simplified rights_mask_map_def])

lemma getCTE_wp:
  "\<lbrace>\<lambda>s. cte_at' p s \<longrightarrow> (\<exists>cte. cte_wp_at' ((=) cte) p s \<and> Q cte s)\<rbrace> getCTE p \<lbrace>Q\<rbrace>"
  apply (clarsimp simp add: getCTE_def valid_def cte_wp_at'_def)
  apply (drule getObject_cte_det)
  apply clarsimp
  done

lemma getCTE_ctes_of:
  "\<lbrace>\<lambda>s. ctes_of s p \<noteq> None \<longrightarrow> P (the (ctes_of s p)) (ctes_of s)\<rbrace> getCTE p \<lbrace>\<lambda>rv s. P rv (ctes_of s)\<rbrace>"
  apply (wp getCTE_wp)
  apply (clarsimp simp: cte_wp_at_ctes_of)
  done

lemma getCTE_wp':
  "\<lbrace>\<lambda>s. \<forall>cte. cte_wp_at' ((=) cte) p s \<longrightarrow> Q cte s\<rbrace> getCTE p \<lbrace>Q\<rbrace>"
  apply (clarsimp simp add: getCTE_def valid_def cte_wp_at'_def)
  apply (drule getObject_cte_det)
  apply clarsimp
  done

lemma getSlotCap_corres:
  "cte_ptr' = cte_map cte_ptr \<Longrightarrow>
   corres cap_relation
     (cte_at cte_ptr)
     (pspace_distinct' and pspace_aligned')
     (get_cap cte_ptr)
     (getSlotCap cte_ptr')"
  apply (simp add: getSlotCap_def)
  apply (subst bind_return [symmetric])
  apply (rule corres_guard_imp)
    apply (rule corres_split[OF get_cap_corres])
      apply (rule corres_trivial, simp)
     apply (wp | simp)+
  done

lemma maskCapRights [simp]:
  "cap_relation c c' \<Longrightarrow>
  cap_relation (mask_cap msk c) (maskCapRights (rights_mask_map msk) c')"
  by (simp add: mask_cap_def cap_relation_masks)

lemma maskCap_valid [simp]:
  "s \<turnstile>' RetypeDecls_H.maskCapRights R cap = s \<turnstile>' cap"
  by (clarsimp simp: valid_cap'_def maskCapRights_def isCap_simps
                     capAligned_def AARCH64_H.maskCapRights_def
              split: capability.split arch_capability.split)

lemma getSlotCap_valid_cap:
  "\<lbrace>valid_objs'\<rbrace> getSlotCap t \<lbrace>\<lambda>r. valid_cap' r and cte_at' t\<rbrace>"
  apply (simp add: getSlotCap_def)
  apply (wp getCTE_valid_cap | simp)+
  done

lemmas getSlotCap_valid_cap1 [wp] = getSlotCap_valid_cap [THEN hoare_conjD1]
lemmas getSlotCap_valid_cap2 [wp] = getSlotCap_valid_cap [THEN hoare_conjD2]

lemma resolveAddressBits_real_cte_at':
  "\<lbrace> valid_objs' and valid_cap' cap \<rbrace>
  resolveAddressBits cap addr depth
  \<lbrace>\<lambda>rv. real_cte_at' (fst rv)\<rbrace>, -"
proof (induct rule: resolveAddressBits.induct)
  case (1 cap addr depth)
  show ?case
    apply (clarsimp simp: validE_def validE_R_def valid_def split: sum.split)
    apply (subst (asm) resolveAddressBits.simps)
    apply (simp only: Let_def split: if_split_asm)
     prefer 2
     apply (simp add: in_monad)
    apply (simp only: in_bindE_R K_bind_def)
    apply (elim exE conjE)
    apply (simp only: split: if_split_asm)
     apply (clarsimp simp: in_monad locateSlot_conv stateAssert_def)
     apply (cases cap)
       apply (simp_all add: isCap_defs)[12]
     apply (clarsimp simp add: valid_cap'_def objBits_simps' cte_level_bits_def
                        split: option.split_asm)
    apply (simp only: in_bindE_R K_bind_def)
    apply (elim exE conjE)
    apply (simp only: cap_case_CNodeCap split: if_split_asm)
     apply (drule_tac cap=nextCap in isCapDs(4), elim exE)
     apply (simp only: in_bindE_R K_bind_def)
     apply (frule (12) 1 [OF refl], (assumption | rule refl)+)
     apply (clarsimp simp: in_monad locateSlot_conv objBits_simps stateAssert_def)
     apply (cases cap)
       apply (simp_all add: isCap_defs)[12]
     apply (frule in_inv_by_hoareD [OF getSlotCap_inv])
     apply simp
     apply (frule (1) post_by_hoare [OF getSlotCap_valid_cap])
     apply (simp add: valid_def validE_def validE_R_def)
     apply (erule allE, erule impE, blast)
     apply (drule (1) bspec)
     apply simp
    apply (clarsimp simp: in_monad locateSlot_conv objBits_simps stateAssert_def)
    apply (cases cap)
     apply (simp_all add: isCap_defs)[12]
    apply (frule in_inv_by_hoareD [OF getSlotCap_inv])
    apply (clarsimp simp: valid_cap'_def cte_level_bits_def objBits_defs)
    done
qed

lemma resolveAddressBits_cte_at':
  "\<lbrace> valid_objs' and valid_cap' cap \<rbrace>
  resolveAddressBits cap addr depth
  \<lbrace>\<lambda>rv. cte_at' (fst rv)\<rbrace>, \<lbrace>\<lambda>rv s. True\<rbrace>"
  apply (fold validE_R_def)
  apply (rule hoare_post_imp_R)
   apply (rule resolveAddressBits_real_cte_at')
  apply (erule real_cte_at')
  done

declare AllowSend_def[simp]
declare AllowRecv_def[simp]

lemma cap_map_update_data:
  assumes "cap_relation c c'"
  shows   "cap_relation (update_cap_data p x c) (updateCapData p x c')"
proof -
  note simps = update_cap_data_def updateCapData_def word_size
               isCap_defs is_cap_defs Let_def badge_bits_def
               cap_rights_update_def badge_update_def
  { fix x :: machine_word
    define y where "y \<equiv> (x >> 6) && mask 58" (* guard_bits *)
    define z where "z \<equiv> unat (x && mask 6)" (* cnode_guard_size_bits *)
    have "of_bl (to_bl (y && mask z)) = (of_bl (replicate (64-z) False @ drop (64-z) (to_bl y))::machine_word)"
      by (simp add: bl_and_mask)
    then
    have "y && mask z = of_bl (drop (64 - z) (to_bl y))"
      apply simp
      apply (subst test_bit_eq_iff [symmetric])
      apply (rule ext)
      apply (clarsimp simp: test_bit_of_bl nth_append)
      done
  } note x = this
  from assms
  show ?thesis
  apply (cases c)
            apply (simp_all add: simps)[5]
       defer
       apply (simp_all add: simps)[4]
   apply (clarsimp simp: simps the_arch_cap_def)
   apply (rename_tac arch_cap)
   apply (case_tac arch_cap; simp add: simps arch_update_cap_data_def
                             AARCH64_H.updateCapData_def)
  \<comment> \<open>CNodeCap\<close>
  apply (simp add: simps word_bits_def the_cnode_cap_def andCapRights_def
                   rightsFromWord_def data_to_rights_def nth_ucast cteRightsBits_def cteGuardBits_def)
  apply (insert x)
  apply (subgoal_tac "unat (x && mask 6) < unat (2^6::machine_word)")
   prefer 2
   apply (fold word_less_nat_alt)[1]
   apply (rule and_mask_less_size)
   apply (simp add: word_size)
  apply (simp add: word_bw_assocs cnode_padding_bits_def cnode_guard_size_bits_def)
  done
qed


lemma cte_map_shift:
  assumes bl: "to_bl cref' = zs @ cref"
  assumes pre: "guard \<le> cref"
  assumes len: "cbits + length guard \<le> length cref"
  assumes aligned: "is_aligned ptr (5 + cbits)" (* cte_level_bits *)
  assumes cbits: "cbits \<le> word_bits - cte_level_bits"
  shows
  "ptr + 32 * ((cref' >> length cref - (cbits + length guard)) && mask cbits) = \<comment> \<open>2^cte_level_bits\<close>
   cte_map (ptr, take cbits (drop (length guard) cref))"
proof -
  let ?l = "length cref - (cbits + length guard)"
  from pre obtain xs where
    xs: "cref = guard @ xs" by (auto simp: prefix_def less_eq_list_def)
  hence len_c: "length cref = length guard + length xs" by simp
  with len have len_x: "cbits \<le> length xs" by simp

  from bl xs
  have cref': "to_bl cref' = zs @ guard @ xs" by simp
  hence "length (to_bl cref') = length \<dots>" by simp
  hence 64: "64 = length zs + length guard + length xs" by simp

  have len_conv [simp]: "size ptr = word_bits"
    by (simp add: word_size word_bits_def)

  have "to_bl ((cref' >> ?l) && mask cbits) = (replicate (64 - cbits) False) @
        drop (64 - cbits) (to_bl (cref' >> ?l))"
    by (simp add: bl_shiftl word_size bl_and_mask
                  cte_level_bits_def word_bits_def)
  also
  from len_c len_x cref' 64
  have "\<dots> = (replicate (64 - cbits) False) @ take cbits xs"
    by (simp add: bl_shiftr word_size add.commute add.left_commute)
  also
  from len_x len_c 64
  have "\<dots> = to_bl (of_bl (take cbits (drop (length guard) cref)) :: machine_word)"
    by (simp add: xs word_rev_tf takefill_alt rev_take rev_drop)

  finally
    show ?thesis
      by (simp add: cte_map_def')
qed

lemma cte_map_shift':
  "\<lbrakk> to_bl cref' = zs @ cref; guard \<le> cref; length cref = cbits + length guard;
    is_aligned ptr (5 + cbits); cbits \<le> word_bits - cte_level_bits \<rbrakk> \<Longrightarrow>
  ptr + 32 * (cref' && mask cbits) = cte_map (ptr, drop (length guard) cref)"
  by (auto dest: cte_map_shift)

lemma cap_relation_Null2 [simp]:
  "cap_relation c NullCap = (c = cap.NullCap)"
  by (cases c) auto

lemmas cnode_cap_case_if = cap_case_CNodeCap

lemma corres_stateAssert_assume_stronger:
  "\<lbrakk> corres_underlying sr nf nf' r P Q f (g ());
    \<And>s s'. \<lbrakk> (s, s') \<in> sr; P s; Q s' \<rbrakk> \<Longrightarrow> P' s' \<rbrakk> \<Longrightarrow>
   corres_underlying sr nf nf' r P Q f (stateAssert P' [] >>= g)"
  apply (clarsimp simp: bind_assoc stateAssert_def)
  apply (rule corres_symb_exec_r [OF _ get_sp])
    apply (rule_tac F="P' x" in corres_req)
     apply clarsimp
    apply (auto elim: corres_guard_imp)[1]
   apply wp+
  done

lemma cap_table_at_gsCNodes:
  "cap_table_at bits ptr s \<Longrightarrow> (s, s') \<in> state_relation
    \<Longrightarrow> gsCNodes s' ptr = Some bits"
  apply (clarsimp simp: state_relation_def ghost_relation_def
                        obj_at_def is_cap_table)
  apply blast
  done

lemma rab_corres':
  "\<lbrakk> cap_relation (fst a) c'; drop (64-bits) (to_bl cref') = snd a;
     bits = length (snd a) \<rbrakk> \<Longrightarrow>
  corres (lfr \<oplus> (\<lambda>(cte, bits) (cte', bits').
                   cte' = cte_map cte \<and> length bits = bits'))
          (valid_objs and pspace_aligned and valid_cap (fst a))
          (valid_objs' and pspace_distinct' and pspace_aligned' and valid_cap' c')
          (resolve_address_bits a)
          (resolveAddressBits c' cref' bits)"
unfolding resolve_address_bits_def
proof (induct a arbitrary: c' cref' bits rule: resolve_address_bits'.induct)
  case (1 z cap cref)
  show ?case
  proof (cases "isCNodeCap c'")
    case True
    with "1.prems"
    obtain ptr guard cbits where caps:
      "cap = cap.CNodeCap ptr cbits guard"
      "c' = CNodeCap ptr cbits (of_bl guard) (length guard)"
      apply (cases cap, simp_all add: isCap_defs)
       apply auto
      done
    with "1.prems"
    have IH: "\<And>vd vc c' f' cref' bits.
      \<lbrakk> cbits + length guard \<noteq> 0; \<not> length cref < cbits + length guard; guard \<le> cref;
        vc = drop (cbits + length guard) cref; vc \<noteq> []; vd \<noteq> cap.NullCap;
       cap_relation vd c'; bits = length vc; is_cnode_cap vd;
       drop (64 - bits) (to_bl cref') = vc \<rbrakk>
      \<Longrightarrow> corres (lfr \<oplus> (\<lambda>(cte, bits) (cte', bits').
                   cte' = cte_map cte \<and> length bits = bits'))
    (valid_objs and pspace_aligned and (\<lambda>s. s \<turnstile> fst (vd,vc)))
    (valid_objs' and pspace_distinct' and pspace_aligned' and (\<lambda>s. s \<turnstile>' c'))
    (resolve_address_bits' z (vd, vc))
    (CSpace_H.resolveAddressBits c' cref' bits)"
      apply -
      apply (rule "1.hyps" [of _ cbits guard, OF caps(1)])
      prefer 7
        apply (clarsimp simp: in_monad)
        apply (rule get_cap_success)
      apply (auto simp: in_monad intro!: get_cap_success) (* takes time *)
      done
    note if_split [split del]
    { assume "cbits + length guard = 0 \<or> cbits = 0 \<and> guard = []"
      hence ?thesis
        apply (simp add: caps isCap_defs
                         resolveAddressBits.simps resolve_address_bits'.simps)
        apply (rule corres_fail)
        apply (clarsimp simp: valid_cap_def)
        done
    }
    moreover
    { assume "cbits + length guard \<noteq> 0 \<and> \<not>(cbits = 0 \<and> guard = [])"
      hence [simp]: "((cbits + length guard = 0) = False) \<and>
                     ((cbits = 0 \<and> guard = []) = False) \<and>
                    (0 < cbits \<or> guard \<noteq> []) " by simp
      from "1.prems"
      have ?thesis
        apply -
        apply (rule corres_assume_pre)
        apply (subgoal_tac "is_aligned ptr (5 + cbits) \<and> cbits \<le> word_bits - cte_level_bits") (*cte_level_bits *)
         prefer 2
         apply (clarsimp simp: caps)
         apply (erule valid_CNodeCapE)
           apply fastforce
          apply fastforce
         apply (fastforce simp: word_bits_def cte_level_bits_def)
        apply (thin_tac "t \<in> state_relation" for t)
        apply (erule conjE)
        apply (subst resolveAddressBits.simps)
        apply (subst resolve_address_bits'.simps)
        apply (simp add: caps isCap_defs Let_def)
        apply (simp add: linorder_not_less drop_postfix_eq)
        apply (simp add: liftE_bindE[where a="locateSlotCap a b" for a b])
        apply (simp add: locateSlot_conv)
        apply (rule corres_stateAssert_assume_stronger[rotated])
         apply (clarsimp simp: valid_cap_def cap_table_at_gsCNodes isCap_simps)
         apply (rule and_mask_less_size, simp add: word_bits_def word_size cte_level_bits_def)
        apply (erule exE)
        apply (cases "guard \<le> cref")
         prefer 2
         apply (clarsimp simp: guard_mask_shift lookup_failure_map_def unlessE_whenE)
        apply (clarsimp simp: guard_mask_shift unlessE_whenE)
        apply (cases "length cref < cbits + length guard")
         apply (simp add: lookup_failure_map_def)
        apply simp
        apply (cases "length cref = cbits + length guard")
         apply clarsimp
         apply (rule corres_noopE)
          prefer 2
          apply wp
         apply wp
         apply (clarsimp simp: objBits_simps cte_level_bits_def)
         apply (erule (2) valid_CNodeCapE)
         apply (erule (3) cte_map_shift')
         apply simp
        apply simp
        apply (subgoal_tac "cbits + length guard < length cref"; simp)
        apply (rule corres_initial_splitE)
           apply clarsimp
           apply (rule corres_guard_imp)
             apply (rule getSlotCap_corres)
             apply (simp add: objBits_simps cte_level_bits_def)
             apply (erule (1) cte_map_shift)
               apply simp
              apply assumption
             apply (simp add: cte_level_bits_def)
            apply clarsimp
            apply (clarsimp simp: valid_cap_def)
            apply (erule cap_table_at_cte_at)
            apply simp
           apply clarsimp
          apply (case_tac "is_cnode_cap rv")
           prefer 2
           apply (simp add: cnode_cap_case_if)
           apply (rule corres_noopE)
            prefer 2
            apply (rule no_fail_pre, rule no_fail_returnOK)
            apply (rule TrueI)
           prefer 2
           apply (simp add: unlessE_whenE cnode_cap_case_if)
           apply (rule IH, (simp_all)[9])
            apply clarsimp
           apply (drule postfix_dropD)
           apply clarsimp
           apply (subgoal_tac "64 + (cbits + length guard) - length cref = (cbits + length guard) + (64 - length cref)")
            prefer 2
            apply (drule len_drop_lemma)
             apply simp
            apply arith
           apply simp
           apply (subst drop_drop [symmetric])
           apply simp
          apply wp
          apply (clarsimp simp: objBits_simps cte_level_bits_def)
          apply (erule (1) cte_map_shift)
            apply simp
           apply assumption
          apply (simp add: cte_level_bits_def)
         apply (wp get_cap_wp)
         apply clarsimp
         apply (erule (1) cte_wp_valid_cap)
        apply wpsimp
        done
    }
    ultimately
    show ?thesis by fast
  next
    case False
    with "1.prems"
    show ?thesis
      by (cases cap)
         (auto simp: resolve_address_bits'.simps resolveAddressBits.simps
                     isCap_defs lookup_failure_map_def)
  qed
qed

lemma getThreadCSpaceRoot:
  "getThreadCSpaceRoot t = return t"
  by (simp add: getThreadCSpaceRoot_def locateSlot_conv
                tcbCTableSlot_def)

lemma getThreadVSpaceRoot:
  "getThreadVSpaceRoot t = return (t+2^cteSizeBits)" (*2^cte_level_bits*)
  by (simp add: getThreadVSpaceRoot_def locateSlot_conv objBits_simps'
                tcbVTableSlot_def shiftl_t2n cte_level_bits_def)

lemma getSlotCap_tcb_corres:
  "corres (\<lambda>t c. cap_relation (tcb_ctable t) c)
          (tcb_at t and valid_objs and pspace_aligned)
          (pspace_distinct' and pspace_aligned')
          (gets_the (get_tcb t))
          (getSlotCap t)"
  (is "corres ?r ?P ?Q ?f ?g")
  using get_cap_corres [where cslot_ptr = "(t, tcb_cnode_index 0)"]
  apply (simp add: getSlotCap_def liftM_def[symmetric])
  apply (drule corres_guard_imp [where P="?P" and P'="?Q"])
    apply (clarsimp simp: cte_at_cases tcb_at_def
                   dest!: get_tcb_SomeD)
   apply simp
  apply (subst(asm) corres_cong [OF refl refl gets_the_tcb_get_cap[symmetric] refl refl])
   apply simp
  apply (simp add: o_def cte_map_def tcb_cnode_index_def)
  done

lemma lookupSlotForThread_corres:
  "corres (lfr \<oplus> (\<lambda>(cref, bits) cref'. cref' = cte_map cref))
        (valid_objs and pspace_aligned and tcb_at t)
        (valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' t)
        (lookup_slot_for_thread t (to_bl cptr))
        (lookupSlotForThread t cptr)"
  apply (unfold lookup_slot_for_thread_def lookupSlotForThread_def)
  apply (simp add: const_def)
  apply (simp add: getThreadCSpaceRoot)
  apply (fold returnOk_liftE)
  apply simp
  apply (rule corres_initial_splitE)
     apply (subst corres_liftE_rel_sum)
     apply (rule corres_guard_imp)
       apply (rule getSlotCap_tcb_corres)
      apply simp
     apply simp
    apply (subst bindE_returnOk[symmetric])
    apply (rule corres_initial_splitE)
       apply (rule rab_corres')
          apply simp
         apply (simp add: word_size)
        apply simp
       apply (clarsimp simp: word_size)
      prefer 4
      apply wp
      apply clarsimp
      apply (erule (1) objs_valid_tcb_ctable)
     prefer 4
     apply wp
      apply clarsimp
     apply simp
    prefer 2
    apply (rule hoare_vcg_precond_impE)
     apply (rule resolve_address_bits_cte_at [unfolded validE_R_def])
    apply clarsimp
   prefer 2
   apply (rule hoare_vcg_precond_impE)
    apply (rule resolveAddressBits_cte_at')
   apply (simp add: invs'_def valid_state'_def valid_pspace'_def)
  apply (simp add: returnOk_def split_def)
  done

lemmas rab_cte_at' [wp] = resolveAddressBits_cte_at' [folded validE_R_def]

lemma lookupSlot_cte_at_wp[wp]:
  "\<lbrace>valid_objs'\<rbrace> lookupSlotForThread t addr \<lbrace>\<lambda>rv. cte_at' rv\<rbrace>, \<lbrace>\<lambda>r. \<top>\<rbrace>"
  apply (simp add: lookupSlotForThread_def)
  apply (simp add: getThreadCSpaceRoot_def locateSlot_conv tcbCTableSlot_def)
  apply (wp | simp add: split_def)+
  done

lemma lookupSlot_inv[wp]:
  "\<lbrace>P\<rbrace> lookupSlotForThread t addr \<lbrace>\<lambda>_. P\<rbrace>"
  apply (simp add: lookupSlotForThread_def)
  apply (simp add: getThreadCSpaceRoot_def locateSlot_conv tcbCTableSlot_def)
  apply (wp | simp add: split_def)+
  done

lemma lookupCap_corres:
 "corres (lfr \<oplus> cap_relation)
         (valid_objs and pspace_aligned and tcb_at t)
         (valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' t)
         (lookup_cap t (to_bl ref)) (lookupCap t ref)"
  apply (simp add: lookup_cap_def lookupCap_def bindE_assoc
                   lookupCapAndSlot_def liftME_def split_def)
  apply (rule corres_guard_imp)
    apply (rule corres_splitEE[OF lookupSlotForThread_corres])
      apply (simp add: split_def getSlotCap_def liftM_def[symmetric] o_def)
      apply (rule get_cap_corres)
     apply (rule hoare_pre, wp lookup_slot_cte_at_wp|simp)+
  done

lemma setObject_cte_obj_at_tcb':
  assumes x: "\<And>tcb f. P (tcbCTable_update f tcb) = P tcb"
             "\<And>tcb f. P (tcbVTable_update f tcb) = P tcb"
             "\<And>tcb f. P (tcbReply_update f tcb) = P tcb"
             "\<And>tcb f. P (tcbCaller_update f tcb) = P tcb"
             "\<And>tcb f. P (tcbIPCBufferFrame_update f tcb) = P tcb"
  shows
  "\<lbrace>\<lambda>s. P' (obj_at' (P :: tcb \<Rightarrow> bool) p s)\<rbrace>
  setObject c (cte::cte)
  \<lbrace>\<lambda>_ s. P' (obj_at' P p s)\<rbrace>"
  apply (clarsimp simp: setObject_def in_monad split_def
                        valid_def lookupAround2_char1
                        obj_at'_def ps_clear_upd)
  apply (clarsimp elim!: rsubst[where P=P'])
  apply (clarsimp simp: updateObject_cte in_monad objBits_simps
                        tcbCTableSlot_def tcbVTableSlot_def x
                        typeError_def
                 split: if_split_asm
                        Structures_H.kernel_object.split_asm)
  done

lemma setCTE_typ_at':
  "\<lbrace>\<lambda>s. P (typ_at' T p s)\<rbrace> setCTE c cte \<lbrace>\<lambda>_ s. P (typ_at' T p s)\<rbrace>"
  by (clarsimp simp add: setCTE_def) (wp setObject_typ_at')

lemmas setObject_typ_at [wp] = setObject_typ_at' [where P=id, simplified]

lemma setCTE_typ_at [wp]:
  "\<lbrace>typ_at' T p\<rbrace> setCTE c cte \<lbrace>\<lambda>_. typ_at' T p\<rbrace>"
  by (clarsimp simp add: setCTE_def) wp

lemmas setCTE_typ_ats [wp] = typ_at_lifts [OF setCTE_typ_at']

lemma setObject_cte_ksCurDomain[wp]:
  "\<lbrace>\<lambda>s. P (ksCurDomain s)\<rbrace> setObject ptr (cte::cte) \<lbrace>\<lambda>_ s. P (ksCurDomain s)\<rbrace>"
  apply (simp add: setObject_def split_def)
  apply (wp updateObject_cte_inv | simp)+
  done

lemma setCTE_tcb_in_cur_domain':
  "\<lbrace>tcb_in_cur_domain' t\<rbrace>
     setCTE c cte
   \<lbrace>\<lambda>_. tcb_in_cur_domain' t\<rbrace>"
  unfolding tcb_in_cur_domain'_def setCTE_def
  apply (rule_tac f="\<lambda>s. ksCurDomain s" in hoare_lift_Pf)
  apply (wp setObject_cte_obj_at_tcb' | simp)+
  done

lemma setCTE_ctes_of_wp [wp]:
  "\<lbrace>\<lambda>s. P ((ctes_of s) (p \<mapsto> cte))\<rbrace>
  setCTE p cte
  \<lbrace>\<lambda>rv s. P (ctes_of s)\<rbrace>"
  by (simp add: setCTE_def ctes_of_setObject_cte)

lemma setCTE_weak_cte_wp_at:
 "\<lbrace>\<lambda>s. (if p = ptr then P (cteCap cte) else cte_wp_at' (\<lambda>c. P (cteCap c)) p s)\<rbrace>
  setCTE ptr cte
  \<lbrace>\<lambda>uu s. cte_wp_at'(\<lambda>c. P (cteCap c)) p s\<rbrace>"
  apply (simp add: cte_wp_at_ctes_of)
  apply wp
  apply clarsimp
  done

lemma updateMDB_weak_cte_wp_at:
 "\<lbrace>cte_wp_at' (\<lambda>c. P (cteCap c)) p\<rbrace>
  updateMDB m f
  \<lbrace>\<lambda>uu. cte_wp_at'(\<lambda>c. P (cteCap c)) p\<rbrace>"
  unfolding updateMDB_def
  apply simp
  apply safe
  apply (wp setCTE_weak_cte_wp_at getCTE_wp)
  apply (auto simp: cte_wp_at'_def)
  done

lemma cte_wp_at_extract':
  "\<lbrakk> cte_wp_at' (\<lambda>c. c = x) p s; cte_wp_at' P p s \<rbrakk> \<Longrightarrow> P x"
  by (clarsimp simp: cte_wp_at_ctes_of)

lemmas setCTE_valid_objs = setCTE_valid_objs'

lemma capFreeIndex_update_valid_cap':
  "\<lbrakk>fa \<le> fb; fb \<le> 2 ^ bits; is_aligned (of_nat fb :: machine_word) minUntypedSizeBits;
    s \<turnstile>' capability.UntypedCap d v bits fa\<rbrakk>
   \<Longrightarrow> s \<turnstile>' capability.UntypedCap d v bits fb"
  apply (clarsimp simp:valid_cap'_def capAligned_def valid_untyped'_def ko_wp_at'_def)
  apply (intro conjI impI allI)
  apply (elim allE)
    apply (erule(1) impE)+
    apply (erule disjE)
      apply simp_all
    apply (rule disjI1)
    apply clarsimp
   apply (erule disjoint_subset2[rotated])
   apply (clarsimp)
   apply (rule word_plus_mono_right)
    apply (rule of_nat_mono_maybe_le[THEN iffD1])
     apply (subst word_bits_def[symmetric])
     apply (erule less_le_trans[OF _  power_increasing])
      apply simp
     apply simp
   apply (subst word_bits_def[symmetric])
   apply (erule le_less_trans)
   apply (erule less_le_trans[OF _ power_increasing])
      apply simp+
   apply (erule is_aligned_no_wrap')
   apply (rule word_of_nat_less)
   apply simp
  apply (erule allE)+
  apply (erule(1) impE)+
  apply simp
  done

lemma maxFreeIndex_update_valid_cap'[simp]:
  "s \<turnstile>' capability.UntypedCap d v0a v1a fa \<Longrightarrow>
   s \<turnstile>' capability.UntypedCap d v0a v1a (maxFreeIndex v1a)"
  apply (rule capFreeIndex_update_valid_cap'[rotated -1])
   apply assumption
  apply (clarsimp simp: valid_cap'_def capAligned_def ko_wp_at'_def
                        maxFreeIndex_def shiftL_nat)+
  apply (erule is_aligned_weaken[OF is_aligned_triv])
  done

lemma ctes_of_valid_cap'':
  "\<lbrakk> ctes_of s p = Some r; valid_objs' s\<rbrakk> \<Longrightarrow> s \<turnstile>' (cteCap r)"
  apply (rule cte_wp_at_valid_objs_valid_cap'[where P="(=) r", simplified])
   apply (simp add: cte_wp_at_ctes_of)
  apply assumption
  done

lemma cap_insert_objs' [wp]:
  "\<lbrace>valid_objs'
    and valid_cap' cap\<rbrace>
   cteInsert cap src dest \<lbrace>\<lambda>rv. valid_objs'\<rbrace>"
  including no_pre
  apply (simp add: cteInsert_def updateCap_def setUntypedCapAsFull_def bind_assoc split del: if_split)
  apply (wp setCTE_valid_objs)
      apply simp
      apply wp+
      apply (clarsimp simp: updateCap_def)
      apply (wp|simp)+
    apply (rule hoare_drop_imp)+
    apply wp+
  apply (rule hoare_strengthen_post[OF getCTE_sp])
  apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps
                 dest!: ctes_of_valid_cap'')
  done

lemma cteInsert_weak_cte_wp_at:
  "\<lbrace>\<lambda>s. if p = dest then P cap else p \<noteq> src \<and>
        cte_wp_at' (\<lambda>c. P (cteCap c)) p s\<rbrace>
   cteInsert cap src dest
   \<lbrace>\<lambda>uu. cte_wp_at'(\<lambda>c. P (cteCap c)) p\<rbrace>"
  unfolding cteInsert_def error_def updateCap_def setUntypedCapAsFull_def
  apply (simp add: bind_assoc split del: if_split)
  apply (wp setCTE_weak_cte_wp_at updateMDB_weak_cte_wp_at hoare_weak_lift_imp | simp)+
   apply (wp getCTE_ctes_wp)+
   apply (clarsimp simp: isCap_simps split:if_split_asm| rule conjI)+
done

lemma setCTE_valid_cap:
  "\<lbrace>valid_cap' c\<rbrace> setCTE ptr cte \<lbrace>\<lambda>r. valid_cap' c\<rbrace>"
  by (rule typ_at_lifts, rule setCTE_typ_at')

lemma updateMDB_valid_cap:
  "\<lbrace>valid_cap' c\<rbrace> updateMDB ptr f \<lbrace>\<lambda>_. valid_cap' c\<rbrace>"
  unfolding updateMDB_def
  apply simp
  apply rule
  apply (wp setCTE_valid_cap)
  done

lemma set_is_modify:
  "m p = Some cte \<Longrightarrow>
  m (p \<mapsto> cteMDBNode_update (\<lambda>_. (f (cteMDBNode cte))) cte) =
  m (p \<mapsto> cteMDBNode_update f cte)"
  apply (case_tac cte)
  apply (rule ext)
  apply clarsimp
  done

lemma updateMDB_ctes_of_wp:
  "\<lbrace>\<lambda>s. (p \<noteq> 0 \<longrightarrow> P (modify_map (ctes_of s) p (cteMDBNode_update f))) \<and>
        (p = 0 \<longrightarrow> P (ctes_of s))\<rbrace>
  updateMDB p f
  \<lbrace>\<lambda>rv s. P (ctes_of s)\<rbrace>"
  apply (simp add: updateMDB_def)
  apply safe
  apply (wp getCTE_wp)
  apply (clarsimp simp: cte_wp_at_ctes_of simp del: fun_upd_apply)
  apply (simp add: modify_map_def set_is_modify)
  done

lemma updateMDB_ctes_of_no_0 [wp]:
  "\<lbrace>\<lambda>s. no_0 (ctes_of s) \<and>
        P (modify_map (ctes_of s) p (cteMDBNode_update f))\<rbrace>
  updateMDB p f
  \<lbrace>\<lambda>rv s. P (ctes_of s)\<rbrace>"
  by (wp updateMDB_ctes_of_wp) clarsimp

lemma updateMDB_no_0 [wp]:
  "\<lbrace>\<lambda>s. no_0 (ctes_of s)\<rbrace>
  updateMDB p f
  \<lbrace>\<lambda>rv s. no_0 (ctes_of s)\<rbrace>"
  by wp simp

lemma isMDBParentOf_next_update [simp]:
  "isMDBParentOf (cteMDBNode_update (mdbNext_update f) cte) cte' =
   isMDBParentOf cte cte'"
  "isMDBParentOf cte (cteMDBNode_update (mdbNext_update f) cte') =
   isMDBParentOf cte cte'"
   apply (cases cte)
   apply (cases cte')
   apply (simp add: isMDBParentOf_def)
  apply (cases cte)
  apply (cases cte')
  apply (clarsimp simp: isMDBParentOf_def)
  done

lemma isMDBParentOf_next_update_cte [simp]:
  "isMDBParentOf (CTE cap (mdbNext_update f node)) cte' =
   isMDBParentOf (CTE cap node) cte'"
  "isMDBParentOf cte (CTE cap (mdbNext_update f node)) =
   isMDBParentOf cte (CTE cap node)"
   apply (cases cte')
   apply (simp add: isMDBParentOf_def)
  apply (cases cte)
  apply (clarsimp simp: isMDBParentOf_def)
  done

lemma valid_mdbD1':
  "\<lbrakk> ctes_of s p = Some cte; mdbNext (cteMDBNode cte) \<noteq> 0; valid_mdb' s \<rbrakk> \<Longrightarrow>
  \<exists>c. ctes_of s (mdbNext (cteMDBNode cte)) = Some c \<and> mdbPrev (cteMDBNode c) = p"
  by (clarsimp simp add: valid_mdb'_def valid_mdb_ctes_def valid_dlist_def Let_def)

lemma valid_mdbD2':
  "\<lbrakk> ctes_of s p = Some cte; mdbPrev (cteMDBNode cte) \<noteq> 0; valid_mdb' s \<rbrakk> \<Longrightarrow>
  \<exists>c. ctes_of s (mdbPrev (cteMDBNode cte)) = Some c \<and> mdbNext (cteMDBNode c) = p"
  by (clarsimp simp add: valid_mdb'_def valid_mdb_ctes_def valid_dlist_def Let_def)

lemma prev_next_update:
  "cteMDBNode_update (mdbNext_update f) (cteMDBNode_update (mdbPrev_update f') x) =
   cteMDBNode_update (mdbPrev_update f') (cteMDBNode_update (mdbNext_update f) x)"
  apply (cases x)
  apply (rename_tac cap mdbnode)
  apply (case_tac mdbnode)
  apply simp
  done

lemmas modify_map_prev_next_up [simp] =
  modify_map_com [where f="cteMDBNode_update (mdbNext_update f)" and
                        g="cteMDBNode_update (mdbPrev_update f')" for f f',
                  OF prev_next_update]

lemma update_prev_next_trancl:
  assumes nxt: "m \<turnstile> x \<leadsto>\<^sup>+ y"
  shows "(modify_map m ptr (cteMDBNode_update (mdbPrev_update z))) \<turnstile> x \<leadsto>\<^sup>+ y"
proof (cases "m ptr")
  case None
  thus ?thesis using nxt
    by (simp add: modify_map_def)
next
  case (Some cte)
  let ?m = "m(ptr \<mapsto> cteMDBNode_update (mdbPrev_update z) cte)"

  from nxt have "?m \<turnstile> x \<leadsto>\<^sup>+ y"
  proof induct
    case (base y)
    thus ?case using Some
      by - (rule r_into_trancl, clarsimp simp: next_unfold')
  next
    case (step q r)
    show ?case
    proof (rule trancl_into_trancl)
      show "?m \<turnstile> q \<leadsto> r" using step(2) Some
        by (simp only: mdb_next_update, clarsimp simp: next_unfold')
    qed fact+
  qed
  thus ?thesis using Some
    by (simp add: modify_map_def)
qed

lemma update_prev_next_trancl2:
  assumes nxt: "(modify_map m ptr (cteMDBNode_update (mdbPrev_update z))) \<turnstile> x \<leadsto>\<^sup>+ y"
  shows   "m \<turnstile> x \<leadsto>\<^sup>+ y"
proof (cases "m ptr")
  case None
  thus ?thesis using nxt
    by (simp add: modify_map_def)
next
  case (Some cte)
  let ?m = "m(ptr \<mapsto> cteMDBNode_update (mdbPrev_update z) cte)"

  from nxt have "m \<turnstile> x \<leadsto>\<^sup>+ y"
  proof induct
    case (base y)
    thus ?case using Some
      by (fastforce simp: modify_map_def mdb_next_update next_unfold' split: if_split_asm)
  next
    case (step q r)
    show ?case
    proof
      show "m \<turnstile> q \<leadsto> r" using step(2) Some
      by (auto simp: modify_map_def mdb_next_update next_unfold' split: if_split_asm)
    qed fact+
  qed
  thus ?thesis using Some
    by (simp add: modify_map_def)
qed

lemma next_update_lhs:
  "(m(p \<mapsto> cte) \<turnstile> p \<leadsto> x) = (x = mdbNext (cteMDBNode cte))"
  by (auto simp: mdb_next_update)

lemma next_update_lhs_trancl:
  assumes np: "\<not> m \<turnstile> mdbNext (cteMDBNode cte) \<leadsto>\<^sup>* p"
  shows   "(m(p \<mapsto> cte) \<turnstile> p \<leadsto>\<^sup>+ x) = (m \<turnstile> mdbNext (cteMDBNode cte) \<leadsto>\<^sup>* x)"
proof
  assume "m(p \<mapsto> cte) \<turnstile> p \<leadsto>\<^sup>+ x"
  thus "m \<turnstile> mdbNext (cteMDBNode cte) \<leadsto>\<^sup>* x"
  proof (cases rule: tranclE2')
    case base
    thus ?thesis
      by (simp add: next_update_lhs)
  next
    case (trancl q)
    hence "m(p \<mapsto> cte) \<turnstile> mdbNext (cteMDBNode cte) \<leadsto>\<^sup>+ x"
      by (simp add: next_update_lhs)
    thus ?thesis
      by (rule trancl_into_rtrancl [OF mdb_trancl_update_other]) fact+
  qed
next
  assume "m \<turnstile> mdbNext (cteMDBNode cte) \<leadsto>\<^sup>* x"
  hence "m(p \<mapsto> cte) \<turnstile> mdbNext (cteMDBNode cte) \<leadsto>\<^sup>* x"
    by (rule mdb_rtrancl_other_update) fact+
  moreover
  have "m(p \<mapsto> cte) \<turnstile> p \<leadsto> mdbNext (cteMDBNode cte)" by (simp add:  next_update_lhs)
  ultimately show "m(p \<mapsto> cte) \<turnstile> p \<leadsto>\<^sup>+ x" by simp
qed

lemma next_update_lhs_rtrancl:
  assumes np: "\<not> m \<turnstile> mdbNext (cteMDBNode cte) \<leadsto>\<^sup>* p"
  shows   "(m(p \<mapsto> cte) \<turnstile> p \<leadsto>\<^sup>* x) = (p = x \<or> m \<turnstile> mdbNext (cteMDBNode cte) \<leadsto>\<^sup>* x)"
  apply rule
   apply (erule next_rtrancl_tranclE)
  apply (auto simp add: next_update_lhs_trancl [OF np, symmetric])
  done

definition
  cte_mdb_prop :: "(machine_word \<rightharpoonup> cte) \<Rightarrow> machine_word \<Rightarrow> (mdbnode \<Rightarrow> bool) \<Rightarrow> bool"
where
  "cte_mdb_prop m p P \<equiv> (\<exists>cte. m p = Some cte \<and> P (cteMDBNode cte))"

lemma cte_mdb_prop_no_0:
  "\<lbrakk> no_0 m; cte_mdb_prop m p P \<rbrakk> \<Longrightarrow> p \<noteq> 0"
  unfolding cte_mdb_prop_def no_0_def
  by auto

lemma mdb_chain_0_modify_map_prev:
  "mdb_chain_0 m \<Longrightarrow> mdb_chain_0 (modify_map m ptr (cteMDBNode_update (mdbPrev_update f)))"
  unfolding mdb_chain_0_def
  apply rule
  apply (rule update_prev_next_trancl)
   apply (clarsimp simp: modify_map_def dom_def split: option.splits if_split_asm)
   done

lemma mdb_chain_0_modify_map_next:
  assumes chain: "mdb_chain_0 m"
  and      no0:  "no_0 m"
  and     dom:   "target \<in> dom m"
  and   npath:   "\<not> m \<turnstile> target \<leadsto>\<^sup>* ptr"
  shows
  "mdb_chain_0 (modify_map m ptr (cteMDBNode_update (mdbNext_update (\<lambda>_. target))))"
  (is "mdb_chain_0 ?M")
  unfolding mdb_chain_0_def
proof
  fix x
  assume "x \<in> dom ?M"
  hence xd: "x \<in> dom m"
    by (clarsimp simp: modify_map_def dom_def split: if_split_asm)
  hence x0: "m \<turnstile> x \<leadsto>\<^sup>+ 0" using chain unfolding mdb_chain_0_def by simp

  from dom have t0: "m \<turnstile> target \<leadsto>\<^sup>+ 0"
    using chain unfolding mdb_chain_0_def by simp

  show "?M \<turnstile> x \<leadsto>\<^sup>+ 0"
  proof (cases "m ptr")
    case None
    thus ?thesis
      by (simp add: modify_map_def) (rule x0)
  next
    case (Some cte)
    show ?thesis
    proof (cases "m \<turnstile> x \<leadsto>\<^sup>* ptr")
      case False
      thus ?thesis
        apply (subst next_update_is_modify [symmetric, OF _ refl])
        apply (rule Some)
        apply (erule mdb_trancl_other_update [OF x0])
        done
    next
      case True
      hence "?M \<turnstile> x \<leadsto>\<^sup>* ptr"
        apply (subst next_update_is_modify [symmetric, OF _ refl])
        apply (rule Some)
        apply (erule next_rtrancl_tranclE)
        apply simp
        apply (rule trancl_into_rtrancl)
        apply (erule no_loops_upd_last [OF mdb_chain_0_no_loops [OF chain no0]])
        done
      moreover have "?M \<turnstile> ptr \<leadsto> target"
        apply (subst next_update_is_modify [symmetric, OF _ refl])
        apply (rule Some)
        apply (simp add: mdb_next_update)
        done
      moreover have "?M \<turnstile> target \<leadsto>\<^sup>+ 0" using t0
        apply (subst next_update_is_modify [symmetric, OF _ refl])
        apply (rule Some)
        apply (erule mdb_trancl_other_update [OF _ npath])
        done
      ultimately show ?thesis by simp
    qed
  qed
qed

lemma mdb_chain_0D:
  "\<lbrakk> mdb_chain_0 m; p \<in> dom m \<rbrakk> \<Longrightarrow> m \<turnstile> p \<leadsto>\<^sup>+ 0"
  unfolding mdb_chain_0_def by auto

lemma mdb_chain_0_nextD:
  "\<lbrakk> mdb_chain_0 m; m p = Some cte \<rbrakk> \<Longrightarrow> m \<turnstile> mdbNext (cteMDBNode cte) \<leadsto>\<^sup>* 0"
  apply (drule mdb_chain_0D)
   apply (erule domI)
  apply (erule tranclE2)
   apply (simp add: next_unfold')
  apply (simp add: next_unfold')
  done

lemma null_mdb_no_next:
  "\<lbrakk> valid_dlist m; no_0 m;
  cte_mdb_prop m target (\<lambda>m. mdbPrev m = nullPointer \<and> mdbNext m = nullPointer) \<rbrakk>
  \<Longrightarrow> \<not> m \<turnstile> x \<leadsto> target"
  unfolding cte_mdb_prop_def
  by (auto elim: valid_dlistE elim!: valid_mdb_ctesE
    simp: nullPointer_def no_0_def next_unfold')

lemma null_mdb_no_trancl:
  "\<lbrakk> valid_dlist m; no_0 m;
  cte_mdb_prop m target (\<lambda>m. mdbPrev m = nullPointer \<and> mdbNext m = nullPointer) \<rbrakk>
  \<Longrightarrow> \<not> m \<turnstile> x \<leadsto>\<^sup>+ target"
  by (auto dest: null_mdb_no_next elim: tranclE)

lemma null_mdb_no_next2:
  "\<lbrakk> no_0 m; x \<noteq> 0;
  cte_mdb_prop m target (\<lambda>m. mdbPrev m = nullPointer \<and> mdbNext m = nullPointer) \<rbrakk>
  \<Longrightarrow> \<not> m \<turnstile> target \<leadsto> x"
  unfolding cte_mdb_prop_def
  by (auto elim!: valid_mdb_ctesE simp: nullPointer_def no_0_def next_unfold')

definition
  "capASID cap \<equiv> case cap of
    ArchObjectCap (FrameCap _ _ _ _ (Some (asid, _))) \<Rightarrow> Some asid
  | ArchObjectCap (PageTableCap _ _ (Some (asid, _))) \<Rightarrow> Some asid
  | _ \<Rightarrow> None"

lemmas capASID_simps [simp] =
  capASID_def [split_simps capability.split arch_capability.split option.split prod.split]

definition
  "cap_asid_base' cap \<equiv> case cap of
    ArchObjectCap (ASIDPoolCap _ asid) \<Rightarrow> Some asid
  | _ \<Rightarrow> None"

lemmas cap_asid_base'_simps [simp] =
  cap_asid_base'_def [split_simps capability.split arch_capability.split option.split prod.split]

definition
  "cap_vptr' cap \<equiv> case cap of
    ArchObjectCap (FrameCap _ _ _ _ (Some (_, vptr))) \<Rightarrow> Some vptr
  | ArchObjectCap (PageTableCap _ _ (Some (_, vptr))) \<Rightarrow> Some vptr
  | _ \<Rightarrow> None"

lemmas cap_vptr'_simps [simp] =
  cap_vptr'_def [split_simps capability.split arch_capability.split option.split prod.split]

definition
  "weak_derived' cap cap' \<equiv>
  capMasterCap cap = capMasterCap cap' \<and>
  capBadge cap = capBadge cap' \<and>
  capASID cap = capASID cap' \<and>
  cap_asid_base' cap = cap_asid_base' cap' \<and>
  cap_vptr' cap = cap_vptr' cap' \<and>
  \<comment> \<open>check all fields of ReplyCap except capReplyCanGrant\<close>
  (isReplyCap cap \<longrightarrow> capTCBPtr cap = capTCBPtr cap' \<and>
                     capReplyMaster cap = capReplyMaster cap')"

lemma capASID_update [simp]:
  "capASID (RetypeDecls_H.updateCapData P x c) = capASID c"
  unfolding capASID_def
  apply (cases c, simp_all add: updateCapData_def isCap_simps Let_def)
  apply (rename_tac arch_capability)
  apply (case_tac arch_capability,
         simp_all add: updateCapData_def
                       AARCH64_H.updateCapData_def
                       isCap_simps Let_def)
  done

lemma cap_vptr_update' [simp]:
  "cap_vptr' (RetypeDecls_H.updateCapData P x c) = cap_vptr' c"
  unfolding capASID_def
  apply (cases c, simp_all add: updateCapData_def isCap_simps Let_def)
  apply (rename_tac arch_capability)
  apply (case_tac arch_capability,
         simp_all add: updateCapData_def
                       AARCH64_H.updateCapData_def
                       isCap_simps Let_def)
  done

lemma cap_asid_base_update' [simp]:
  "cap_asid_base' (RetypeDecls_H.updateCapData P x c) = cap_asid_base' c"
  unfolding cap_asid_base'_def
  apply (cases c, simp_all add: updateCapData_def isCap_simps Let_def)
  apply (rename_tac arch_capability)
  apply (case_tac arch_capability,
         simp_all add: updateCapData_def
                       AARCH64_H.updateCapData_def
                       isCap_simps Let_def)
  done

lemma updateCapData_Master:
  "updateCapData P d cap \<noteq> NullCap \<Longrightarrow>
   capMasterCap (updateCapData P d cap) = capMasterCap cap"
  apply (cases cap, simp_all add: updateCapData_def isCap_simps Let_def
                           split: if_split_asm)
  apply (rename_tac arch_capability)
  apply (case_tac arch_capability, simp_all add: AARCH64_H.updateCapData_def)
  done

lemma updateCapData_Reply:
  "isReplyCap (updateCapData P x c) = isReplyCap c"
  apply (cases "updateCapData P x c = NullCap")
   apply (clarsimp simp: isCap_simps)
   apply (simp add: updateCapData_def isCap_simps Let_def)
  apply (drule updateCapData_Master)
  apply (rule master_eqI, rule isCap_Master)
  apply simp
  done

lemma weak_derived_updateCapData:
  "\<lbrakk> (updateCapData P x c) \<noteq> NullCap; weak_derived' c c';
      capBadge (updateCapData P x c) = capBadge c' \<rbrakk>
  \<Longrightarrow> weak_derived' (updateCapData P x c) c'"
  apply (clarsimp simp add: weak_derived'_def updateCapData_Master)
  apply (clarsimp elim: impE dest!: iffD1[OF updateCapData_Reply])
  apply (clarsimp simp: isCap_simps)
  apply (clarsimp simp: Let_def isCap_simps updateCapData_def)
  done

lemma maskCapRights_Reply[simp]:
  "isReplyCap (maskCapRights r c) = isReplyCap c"
  apply (insert capMasterCap_maskCapRights)
  apply (rule master_eqI, rule isCap_Master)
  apply simp
  done

lemma capASID_mask [simp]:
  "capASID (maskCapRights x c) = capASID c"
  unfolding capASID_def
  apply (cases c, simp_all add: maskCapRights_def isCap_simps Let_def)
  apply (rename_tac arch_capability)
  apply (case_tac arch_capability,
         simp_all add: maskCapRights_def AARCH64_H.maskCapRights_def isCap_simps Let_def)
  done

lemma cap_vptr_mask' [simp]:
  "cap_vptr' (maskCapRights x c) = cap_vptr' c"
  unfolding cap_vptr'_def
  apply (cases c, simp_all add: maskCapRights_def isCap_simps Let_def)
  apply (rename_tac arch_capability)
  apply (case_tac arch_capability,
         simp_all add: maskCapRights_def AARCH64_H.maskCapRights_def isCap_simps Let_def)
  done

lemma cap_asid_base_mask' [simp]:
  "cap_asid_base' (maskCapRights x c) = cap_asid_base' c"
  unfolding cap_vptr'_def
  apply (cases c, simp_all add: maskCapRights_def isCap_simps Let_def)
  apply (rename_tac arch_capability)
  apply (case_tac arch_capability,
         simp_all add: maskCapRights_def AARCH64_H.maskCapRights_def isCap_simps Let_def)
  done

lemmas cteInsert_valid_objs = cap_insert_objs'

lemma subtree_not_Null:
  assumes null: "m p = Some (CTE capability.NullCap node)"
  assumes sub: "m \<turnstile> c \<rightarrow> p"
  shows "False" using sub null
  by induct (auto simp: parentOf_def)

lemma Null_not_subtree:
  assumes null: "m c = Some (CTE capability.NullCap node)"
  assumes sub: "m \<turnstile> c \<rightarrow> p"
  shows "False" using sub null
  by induct (auto simp: parentOf_def)

lemma subtree_Null_update:
  assumes "no_0 m" "valid_dlist m"
  assumes null: "m p = Some (CTE NullCap node)"
  assumes node: "mdbPrev node = 0"
  assumes init: "mdbNext (cteMDBNode cte) = 0"
  shows "m \<turnstile> c \<rightarrow> c' = m (p \<mapsto> cte) \<turnstile> c \<rightarrow> c'"
proof
  assume "m \<turnstile> c \<rightarrow> c'"
  thus "m (p \<mapsto> cte) \<turnstile> c \<rightarrow> c'" using null init
  proof induct
    case direct_parent
    thus ?case
      apply -
      apply (rule subtree.direct_parent)
        apply (clarsimp simp add: mdb_next_unfold parentOf_def)
       apply assumption
      apply (simp add: parentOf_def)
      apply (rule conjI)
       apply clarsimp
      apply clarsimp
      done
  next
    case (trans_parent y z)
    have "m \<turnstile> c \<rightarrow> y" "m \<turnstile> y \<leadsto> z" "z \<noteq> 0" "m \<turnstile> c parentOf z" by fact+
    with trans_parent.prems
    show ?case
      apply -
      apply (rule subtree.trans_parent)
         apply (erule (1) trans_parent.hyps)
        apply (clarsimp simp: mdb_next_unfold parentOf_def)
        apply (drule (1) subtree_not_Null)
        apply simp
       apply assumption
      apply (fastforce simp: parentOf_def)
      done
  qed
next
  assume m: "m (p \<mapsto> cte) \<turnstile> c \<rightarrow> c'"
  thus "m \<turnstile> c \<rightarrow> c'" using assms m
  proof induct
    case (direct_parent x)
    thus ?case
      apply -
      apply (cases "c=p")
       apply (clarsimp simp: mdb_next_unfold)
      apply (rule subtree.direct_parent)
        apply (clarsimp simp: mdb_next_unfold)
       apply assumption
      apply (cases "p\<noteq>x")
       apply (clarsimp simp: parentOf_def  split: if_split_asm)
      apply clarsimp
      apply (clarsimp simp: mdb_next_unfold)
      apply (case_tac z)
      apply clarsimp
      apply (clarsimp simp: no_0_def valid_dlist_def Let_def)
      apply (erule_tac x=c in allE)
      apply clarsimp
      done
  next
    case (trans_parent x y)
    have "m(p \<mapsto> cte) \<turnstile> c \<rightarrow> x" "m(p \<mapsto> cte) \<turnstile> x \<leadsto> y"
         "y \<noteq> 0" "m(p \<mapsto> cte) \<turnstile> c parentOf y" by fact+
    with trans_parent.prems
    show ?case
      apply -
      apply (cases "p=x")
       apply clarsimp
       apply (clarsimp simp: mdb_next_unfold)
      apply (frule (5) trans_parent.hyps)
      apply (rule subtree.trans_parent)
         apply assumption
        apply (clarsimp simp: mdb_next_unfold)
       apply assumption
      apply (clarsimp simp: parentOf_def simp del: fun_upd_apply)
      apply (cases "p=y")
       apply clarsimp
       apply (clarsimp simp: mdb_next_unfold)
       apply (clarsimp simp: valid_dlist_def Let_def)
       apply (erule_tac x=x in allE)
       apply (clarsimp simp: no_0_def)
      apply (case_tac "p\<noteq>c")
       apply clarsimp
      apply clarsimp
      apply (erule (1) Null_not_subtree)
      done
  qed
qed


corollary descendants_of_Null_update':
  assumes "no_0 m" "valid_dlist m"
  assumes "m p = Some (CTE NullCap node)"
  assumes "mdbPrev node = 0"
  assumes "mdbNext (cteMDBNode cte) = 0"
  shows "descendants_of' c (m (p \<mapsto> cte)) = descendants_of' c m" using assms
  by (simp add: descendants_of'_def subtree_Null_update [symmetric])

lemma ps_clear_32:
  "\<lbrakk> ps_clear p tcbBlockSizeBits s; is_aligned p tcbBlockSizeBits \<rbrakk>
    \<Longrightarrow> ksPSpace s (p + 2^cteSizeBits) = None"
  apply (simp add: ps_clear_def)
  apply (drule equals0D[where a="p + 2^cteSizeBits"])
  apply (simp add: dom_def field_simps objBits_defs)
  apply (erule impE)
   apply (rule word_plus_mono_right)
    apply (simp add: mask_def)
   apply (erule is_aligned_no_wrap')
   apply (simp add: mask_def)
  apply (erule mp)
  apply (erule is_aligned_no_wrap')
  apply simp
  done

lemma cte_at_cte_map_in_obj_bits:
  "\<lbrakk> cte_at p s; pspace_aligned s; valid_objs s \<rbrakk>
     \<Longrightarrow> cte_map p \<in> {fst p .. fst p + 2 ^ (obj_bits (the (kheap s (fst p)))) - 1}
           \<and> kheap s (fst p) \<noteq> None"
  apply (simp add: cte_at_cases)
  apply (elim disjE conjE exE)
   apply (clarsimp simp: well_formed_cnode_n_def)
   apply (drule(1) pspace_alignedD[rotated])
   apply (erule(1) valid_objsE)
   apply (frule arg_cong[where f="\<lambda>S. snd p \<in> S"])
   apply (simp(no_asm_use) add: domIff)
   apply (clarsimp simp: cte_map_def split_def
                         well_formed_cnode_n_def length_set_helper ex_with_length
                         valid_obj_def valid_cs_size_def valid_cs_def)
   apply (subgoal_tac "of_bl (snd p) * 2^cte_level_bits < 2 ^ (cte_level_bits + length (snd p))")
    apply (rule conjI)
     apply (erule is_aligned_no_wrap')
     apply (simp add: shiftl_t2n mult_ac)
    apply (subst add_diff_eq[symmetric])
    apply (rule word_plus_mono_right)
     apply (simp add: shiftl_t2n mult_ac)
    apply (erule is_aligned_no_wrap')
    apply (rule word_power_less_1)
    apply (simp add: cte_level_bits_def word_bits_def)
   apply (simp add: power_add)
   apply (subst mult.commute, rule word_mult_less_mono1)
     apply (rule of_bl_length)
     apply (simp add: word_bits_def)
    apply (simp add: cte_level_bits_def)
   apply (simp add: cte_level_bits_def word_bits_def)
   apply (drule power_strict_increasing [where a="2 :: nat"])
    apply simp
   apply simp
  apply (clarsimp simp: cte_map_def split_def field_simps)
  apply (subgoal_tac "of_bl (snd p) * 2^cte_level_bits < (2^tcb_bits :: machine_word)")
   apply (drule(1) pspace_alignedD[rotated])
   apply (rule conjI)
    apply (erule is_aligned_no_wrap')
     apply (simp add: word_bits_conv shiftl_t2n mult_ac)
    apply simp
   apply (rule word_plus_mono_right)
    apply (simp add: shiftl_t2n mult_ac)
    apply (drule word_le_minus_one_leq)
    apply simp
   apply (erule is_aligned_no_wrap')
   apply simp
  apply (simp add: tcb_cap_cases_def tcb_cnode_index_def to_bl_1 cte_level_bits_def
              split: if_split_asm)
  done

lemma cte_map_inj:
  assumes neq: "p \<noteq> p'"
  assumes c1: "cte_at p s"
  assumes c2: "cte_at p' s"
  assumes vo: "valid_objs s"
  assumes al: "pspace_aligned s"
  assumes pd: "pspace_distinct s"
  shows "cte_map p \<noteq> cte_map p'"
  using cte_at_cte_map_in_obj_bits [OF c1 al vo]
        cte_at_cte_map_in_obj_bits [OF c2 al vo]
        pd
  apply (clarsimp simp: pspace_distinct_def
              simp del: atLeastAtMost_iff Int_atLeastAtMost)
  apply (elim allE, drule mp)
   apply (erule conjI)+
   defer
   apply (simp add: field_simps
               del: atLeastAtMost_iff Int_atLeastAtMost)
   apply blast
  apply (clarsimp simp: cte_map_def split_def)
  apply (thin_tac "b \<le> a" for b a)+
  apply (rule notE[OF neq])
  apply (insert cte_at_length_limit [OF c1 vo])
  apply (simp add: shiftl_t2n[where n=5, simplified, simplified mult.commute, symmetric]
                   word_bits_def cte_level_bits_def prod_eq_iff)
  apply (insert cte_at_cref_len[where p="fst p" and c="snd p" and c'="snd p'", simplified, OF c1])
  apply (simp add: c2 prod_eqI)
  apply (subst rev_is_rev_conv[symmetric])
  apply (rule nth_equalityI)
   apply simp
  apply clarsimp
  apply (drule_tac x="i + 5" in word_eqD)
  apply (simp add: nth_shiftl test_bit_of_bl nth_rev)
  done

lemma cte_map_inj_ps:
  assumes "p \<noteq> p'"
  assumes "cte_at p s"
  assumes "cte_at p' s"
  assumes "valid_pspace s"
  shows "cte_map p \<noteq> cte_map p'" using assms
  apply -
  apply (rule cte_map_inj)
  apply (auto simp: valid_pspace_def)
  done

lemma cte_map_inj_eq:
  "\<lbrakk>cte_map p = cte_map p';
   cte_at p s; cte_at p' s;
   valid_objs s; pspace_aligned s; pspace_distinct s\<rbrakk>
  \<Longrightarrow> p = p'"
  apply (rule classical)
  apply (drule (5) cte_map_inj)
  apply simp
  done

lemma tcb_cases_related2:
  "tcb_cte_cases (v - x) = Some (getF, setF) \<Longrightarrow>
   \<exists>getF' setF' restr. tcb_cap_cases (tcb_cnode_index (unat ((v - x) >> cte_level_bits))) = Some (getF', setF', restr)
          \<and> cte_map (x, tcb_cnode_index (unat ((v - x) >> cte_level_bits))) = v
          \<and> (\<forall>tcb tcb'. tcb_relation tcb tcb' \<longrightarrow> cap_relation (getF' tcb) (cteCap (getF tcb')))
          \<and> (\<forall>tcb tcb' cap cte. tcb_relation tcb tcb' \<longrightarrow> cap_relation cap (cteCap cte)
                        \<longrightarrow> tcb_relation (setF' (\<lambda>x. cap) tcb) (setF (\<lambda>x. cte) tcb'))"
  apply (clarsimp simp: tcb_cte_cases_def tcb_relation_def cte_level_bits_def cteSizeBits_def
                        tcb_cap_cases_simps[simplified]
                 split: if_split_asm)
  apply (simp_all add: tcb_cnode_index_def cte_level_bits_def cte_map_def field_simps to_bl_1)
  done

lemma other_obj_relation_KOCTE[simp]:
  "\<not> other_obj_relation ko (KOCTE cte)"
  by (simp add: other_obj_relation_def
         split: Structures_A.kernel_object.splits
                AARCH64_A.arch_kernel_obj.splits)

lemma cte_map_pulls_tcb_to_abstract:
  "\<lbrakk> y = cte_map z; pspace_relation (kheap s) (ksPSpace s');
     ksPSpace s' x = Some (KOTCB tcb);
     pspace_aligned s; pspace_distinct s; valid_objs s;
     cte_at z s; (y - x) \<in> dom tcb_cte_cases \<rbrakk>
     \<Longrightarrow> \<exists>tcb'. kheap s x = Some (TCB tcb') \<and> tcb_relation tcb' tcb
                  \<and> (z = (x, tcb_cnode_index (unat ((y - x) >> cte_level_bits))))"
  apply (rule pspace_dom_relatedE, assumption+)
  apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm)
  apply (clarsimp simp: other_obj_relation_def
                 split: Structures_A.kernel_object.split_asm
                        AARCH64_A.arch_kernel_obj.split_asm)
  apply (drule tcb_cases_related2)
  apply clarsimp
  apply (frule(1) cte_wp_at_tcbI [OF _ _ TrueI, where t="(a, b)" for a b, simplified])
  apply (erule(5) cte_map_inj_eq [OF sym])
  done

lemma pspace_relation_update_tcbs:
  "\<lbrakk> pspace_relation s s'; s x = Some (TCB otcb); s' x = Some (KOTCB otcb');
        tcb_relation tcb tcb' \<rbrakk>
       \<Longrightarrow> pspace_relation (s(x \<mapsto> TCB tcb)) (s'(x \<mapsto> KOTCB tcb'))"
  apply (simp add: pspace_relation_def pspace_dom_update
                   dom_fun_upd2
              del: dom_fun_upd)
  apply (erule conjE)
  apply (rule ballI, drule(1) bspec)
  apply (rule conjI, simp add: other_obj_relation_def)
  apply (clarsimp split: Structures_A.kernel_object.split_asm)
  apply (drule bspec, fastforce)
  apply clarsimp
  apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm)
  done

lemma cte_map_pulls_cte_to_abstract:
  "\<lbrakk> y = cte_map z; pspace_relation (kheap s) (ksPSpace s');
     ksPSpace s' y = Some (KOCTE cte);
     valid_objs s; pspace_aligned s; pspace_distinct s; cte_at z s \<rbrakk>
     \<Longrightarrow> \<exists>sz cs cap. kheap s (fst z) = Some (CNode sz cs) \<and> cs (snd z) = Some cap
                  \<and> cap_relation cap (cteCap cte)"
  apply (rule pspace_dom_relatedE, assumption+)
  apply (erule(1) obj_relation_cutsE, simp_all)
  apply clarsimp
  apply (frule(1) cte_map_inj_eq[OF sym], simp_all)
  apply (rule cte_wp_at_cteI, (fastforce split: if_split_asm)+)
  done

lemma pspace_relation_update_ctes:
  assumes ps: "pspace_relation s s'"
    and octe: "s' z = Some (KOCTE octe)"
    and  s'': "\<And>x. s'' x = (case (s x) of None \<Rightarrow> None | Some ko \<Rightarrow>
                    (case ko of CNode sz cs \<Rightarrow>
                          Some (CNode sz (\<lambda>y. if y \<in> dom cs \<and> cte_map (x, y) = z
                                              then Some cap else cs y))
                                    | _ \<Rightarrow> Some ko))"
     and rel: "cap_relation cap (cteCap cte')"
       shows  "pspace_relation s'' (s'(z \<mapsto> KOCTE cte'))"
proof -
  have funny_update_no_dom:
    "\<And>fun P v. dom (\<lambda>y. if y \<in> dom fun \<and> P y then Some v else fun y)
      = dom fun"
    by (rule set_eqI, simp add: domIff)

  have funny_update_well_formed_cnode:
    "\<And>sz fun P v.
      well_formed_cnode_n sz (\<lambda>y. if y \<in> dom fun \<and> P y then Some v else fun y)
      = well_formed_cnode_n sz fun"
    by (simp add: well_formed_cnode_n_def funny_update_no_dom)

  have obj_relation_cuts1:
  "\<And>ko x. obj_relation_cuts (the (case ko of CNode sz cs \<Rightarrow>
                                       Some (CNode sz (\<lambda>y. if y \<in> dom cs \<and> cte_map (x, y) = z
                                                           then Some cap else cs y))
                                    | _ \<Rightarrow> Some ko)) x
             = obj_relation_cuts ko x"
    by (simp split: Structures_A.kernel_object.split
               add: funny_update_well_formed_cnode funny_update_no_dom)

  have domEq[simp]:
    "dom s'' = dom s"
    using s''
    apply (intro set_eqI)
    apply (simp add: domIff split: option.split Structures_A.kernel_object.split)
    done

  have obj_relation_cuts2:
  "\<And>x. x \<in> dom s'' \<Longrightarrow> obj_relation_cuts (the (s'' x)) x = obj_relation_cuts (the (s x)) x"
    using s''
    by (clarsimp simp add: obj_relation_cuts1 dest!: domD)

  show ?thesis using ps octe
    apply (clarsimp simp add: pspace_relation_def dom_fun_upd2
                    simp del: dom_fun_upd split del: if_split)
    apply (rule conjI)
     apply (erule subst[where t="dom s'"])
     apply (simp add: pspace_dom_def obj_relation_cuts2)
    apply (simp add: obj_relation_cuts2)
    apply (rule ballI, drule(1) bspec)+
    apply clarsimp
    apply (intro conjI impI)
     apply (simp add: s'')
     apply (rule obj_relation_cutsE, assumption+, simp_all split: if_split_asm)[1]
     apply (clarsimp simp: cte_relation_def rel)
    apply (rule obj_relation_cutsE, assumption+, simp_all add: s'')
     apply (clarsimp simp: cte_relation_def)
    apply (clarsimp simp: is_other_obj_relation_type other_obj_relation_def
                   split: Structures_A.kernel_object.split_asm)
    done
qed

definition pspace_relations where
  "pspace_relations ekh kh kh' \<equiv> pspace_relation kh kh' \<and> ekheap_relation ekh kh'"

lemma set_cap_not_quite_corres_prequel:
  assumes cr:
  "pspace_relations (ekheap s) (kheap s) (ksPSpace s')"
  "(x,t') \<in> fst (setCTE p' c' s')"
  "valid_objs s" "pspace_aligned s" "pspace_distinct s" "cte_at p s"
  "pspace_aligned' s'" "pspace_distinct' s'"
  assumes c: "cap_relation c (cteCap c')"
  assumes p: "p' = cte_map p"
  shows "\<exists>t. ((),t) \<in> fst (set_cap c p s) \<and>
             pspace_relations (ekheap t) (kheap t) (ksPSpace t')"
  using cr
  apply (clarsimp simp: setCTE_def setObject_def in_monad split_def)
  apply (drule(1) updateObject_cte_is_tcb_or_cte[OF _ refl, rotated])
  apply (elim disjE exE conjE)
   apply (clarsimp simp: lookupAround2_char1 pspace_relations_def)
   apply (frule(5) cte_map_pulls_tcb_to_abstract[OF p])
    apply (simp add: domI)
   apply (frule tcb_cases_related2)
   apply (clarsimp simp: set_cap_def2 split_def bind_def get_object_def
                         simpler_gets_def assert_def fail_def return_def
                         set_object_def get_def put_def)
   apply (rule conjI)
    apply (erule(2) pspace_relation_update_tcbs)
    apply (simp add: c)
   apply (clarsimp simp: ekheap_relation_def pspace_relation_def)
   apply (drule bspec, erule domI)
   apply (clarsimp simp: etcb_relation_def tcb_cte_cases_def split: if_split_asm)
  apply (clarsimp simp: pspace_relations_def)
  apply (frule(5) cte_map_pulls_cte_to_abstract[OF p])
  apply (clarsimp simp: set_cap_def split_def bind_def get_object_def
                        simpler_gets_def assert_def a_type_def fail_def return_def
                        set_object_def get_def put_def domI)
  apply (erule(1) valid_objsE)
  apply (clarsimp simp: valid_obj_def valid_cs_def valid_cs_size_def exI)
  apply (rule conjI, clarsimp)
   apply (rule conjI)
    apply (erule(1) pspace_relation_update_ctes[where cap=c])
     apply clarsimp
     apply (intro conjI impI)
      apply (rule ext, clarsimp simp add: domI p)
      apply (drule cte_map_inj_eq [OF _ _ cr(6) cr(3-5)])
       apply (simp add: cte_at_cases domI)
      apply (simp add: prod_eq_iff)
     apply (insert p)[1]
     apply (clarsimp split: option.split Structures_A.kernel_object.split
                    intro!: ext)
     apply (drule cte_map_inj_eq [OF _ _ cr(6) cr(3-5)])
      apply (simp add: cte_at_cases domI well_formed_cnode_invsI[OF cr(3)])
     apply clarsimp
    apply (simp add: c)
   apply (clarsimp simp: ekheap_relation_def pspace_relation_def)
   apply (drule bspec, erule domI)
   apply (clarsimp simp: etcb_relation_def tcb_cte_cases_def split: if_split_asm)
  apply (simp add: wf_cs_insert)
  done

lemma setCTE_pspace_only:
  "(rv, s') \<in> fst (setCTE p v s) \<Longrightarrow> \<exists>ps'. s' = ksPSpace_update (\<lambda>s. ps') s"
  apply (clarsimp simp: setCTE_def setObject_def in_monad split_def
                 dest!: in_inv_by_hoareD [OF updateObject_cte_inv])
  apply (rule exI, rule refl)
  done

lemma set_cap_not_quite_corres:
  assumes cr:
  "pspace_relations (ekheap s) (kheap s) (ksPSpace s')"
  "cur_thread s = ksCurThread s'"
  "idle_thread s = ksIdleThread s'"
  "machine_state s = ksMachineState s'"
  "work_units_completed s = ksWorkUnitsCompleted s'"
  "domain_index s = ksDomScheduleIdx s'"
  "domain_list s = ksDomSchedule s'"
  "cur_domain s = ksCurDomain s'"
  "domain_time s = ksDomainTime s'"
  "(x,t') \<in> fst (updateCap p' c' s')"
  "valid_objs s" "pspace_aligned s" "pspace_distinct s" "cte_at p s"
  "pspace_aligned' s'" "pspace_distinct' s'"
  "interrupt_state_relation (interrupt_irq_node s) (interrupt_states s) (ksInterruptState s')"
  "(arch_state s, ksArchState s') \<in> arch_state_relation"
  assumes c: "cap_relation c c'"
  assumes p: "p' = cte_map p"
  shows "\<exists>t. ((),t) \<in> fst (set_cap c p s) \<and>
             pspace_relations (ekheap t) (kheap t) (ksPSpace t') \<and>
             cdt t = cdt s \<and>
             cdt_list t = cdt_list s \<and>
             ekheap t = ekheap s \<and>
             scheduler_action t = scheduler_action s \<and>
             ready_queues t = ready_queues s \<and>
             is_original_cap t = is_original_cap s \<and>
             interrupt_state_relation (interrupt_irq_node t) (interrupt_states t)
                              (ksInterruptState t') \<and>
             (arch_state t, ksArchState t') \<in> arch_state_relation \<and>
             cur_thread t = ksCurThread t' \<and>
             idle_thread t = ksIdleThread t' \<and>
             machine_state t = ksMachineState t' \<and>
             work_units_completed t = ksWorkUnitsCompleted t' \<and>
             domain_index t = ksDomScheduleIdx t' \<and>
             domain_list t = ksDomSchedule t' \<and>
             cur_domain t = ksCurDomain t' \<and>
             domain_time t = ksDomainTime t'"
  using cr
  apply (clarsimp simp: updateCap_def in_monad)
  apply (drule use_valid [OF _ getCTE_sp[where P="\<lambda>s. s2 = s" for s2], OF _ refl])
  apply clarsimp
  apply (drule(7) set_cap_not_quite_corres_prequel)
    apply simp
    apply (rule c)
   apply (rule p)
  apply (erule exEI)
  apply clarsimp
  apply (frule setCTE_pspace_only)
  apply (clarsimp simp: set_cap_def split_def in_monad set_object_def
                        get_object_def
                 split: Structures_A.kernel_object.split_asm if_split_asm)
  done

lemma descendants_of_eq':
  assumes "cte_at p s"
  assumes "cte_at src s"
  assumes "cdt_relation (swp cte_at s) (cdt s) m'"
  assumes "valid_mdb s"
  assumes "valid_objs s" "pspace_aligned s" "pspace_distinct s"
  shows "(cte_map src \<in> descendants_of' (cte_map p) m') = (src \<in> descendants_of p (cdt s))"
  using assms
  apply (simp add: cdt_relation_def del: split_paired_All)
  apply (rule iffI)
   prefer 2
   apply (auto simp del: split_paired_All)[1]
  apply (erule_tac x=p in allE)
  apply simp
  apply (drule sym)
  apply clarsimp
  apply (frule (1) descendants_of_cte_at)
  apply (drule (5) cte_map_inj_eq)
  apply simp
  done

lemma updateCap_stuff:
  assumes "(x, s'') \<in> fst (updateCap p cap s')"
  shows "(ctes_of s'' = modify_map (ctes_of s') p (cteCap_update (K cap))) \<and>
         gsUserPages s'' = gsUserPages s' \<and>
         gsCNodes s'' = gsCNodes s' \<and>
         ksMachineState s'' = ksMachineState s' \<and>
         ksWorkUnitsCompleted s'' = ksWorkUnitsCompleted s' \<and>
         ksCurThread s'' = ksCurThread s' \<and>
         ksIdleThread s'' = ksIdleThread s' \<and>
         ksReadyQueues s'' = ksReadyQueues s' \<and>
         ksSchedulerAction s'' = ksSchedulerAction s' \<and>
         (ksArchState s'' = ksArchState s') \<and>
         (pspace_aligned' s' \<longrightarrow> pspace_aligned' s'') \<and>
         (pspace_distinct' s' \<longrightarrow> pspace_distinct' s'')" using assms
  apply (clarsimp simp: updateCap_def in_monad)
  apply (drule use_valid [where P="\<lambda>s. s2 = s" for s2, OF _ getCTE_sp refl])
  apply (rule conjI)
   apply (erule use_valid [OF _ setCTE_ctes_of_wp])
   apply (clarsimp simp: cte_wp_at_ctes_of modify_map_apply)
  apply (frule setCTE_pspace_only)
  apply (clarsimp simp: setCTE_def)
  apply (intro conjI impI)
   apply (erule(1) use_valid [OF _ setObject_aligned])
  apply (erule(1) use_valid [OF _ setObject_distinct])
  done

(* FIXME: move *)
lemma pspace_relation_cte_wp_atI':
  "\<lbrakk> pspace_relation (kheap s) (ksPSpace s');
     cte_wp_at' ((=) cte) x s'; valid_objs s \<rbrakk>
  \<Longrightarrow> \<exists>c slot. cte_wp_at ((=) c) slot s \<and> cap_relation c (cteCap cte) \<and> x = cte_map slot"
  apply (simp add: cte_wp_at_cases')
  apply (elim disjE conjE exE)
   apply (erule(1) pspace_dom_relatedE)
   apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm)[1]
   apply (intro exI, rule conjI[OF _ conjI [OF _ refl]])
    apply (simp add: cte_wp_at_cases domI well_formed_cnode_invsI)
   apply (simp split: if_split_asm)
  apply (erule(1) pspace_dom_relatedE)
  apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm)
  apply (simp add: other_obj_relation_def
            split: Structures_A.kernel_object.split_asm
                   AARCH64_A.arch_kernel_obj.split_asm)
  apply (subgoal_tac "n = x - y", clarsimp)
   apply (drule tcb_cases_related2, clarsimp)
   apply (intro exI, rule conjI)
    apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified])
    apply fastforce
   apply simp
  apply clarsimp
  done

lemma pspace_relation_cte_wp_atI:
  "\<lbrakk> pspace_relation (kheap s) (ksPSpace s');
     ctes_of (s' :: kernel_state) x = Some cte; valid_objs s \<rbrakk>
  \<Longrightarrow> \<exists>c slot. cte_wp_at ((=) c) slot s \<and> cap_relation c (cteCap cte) \<and> x = cte_map slot"
  apply (erule pspace_relation_cte_wp_atI'[where x=x])
   apply (simp add: cte_wp_at_ctes_of)
  apply assumption
  done

lemma sameRegion_corres:
  "\<lbrakk> sameRegionAs c' d'; cap_relation c c'; cap_relation d d' \<rbrakk>
  \<Longrightarrow> same_region_as c d"
  by (simp add: same_region_as_relation)

lemma is_final_cap_unique:
  assumes cte: "ctes_of s' (cte_map slot) = Some cte"
  assumes fin: "cte_wp_at (\<lambda>c. final_matters c \<and> is_final_cap' c s) slot s"
  assumes psr: "pspace_relation (kheap s) (ksPSpace s')"
  assumes cte': "ctes_of s' x = Some cte'"
  assumes neq: "x \<noteq> cte_map slot"
  assumes region: "sameRegionAs (cteCap cte) (cteCap cte')"
  assumes valid: "pspace_aligned s" "valid_objs s" "pspace_aligned' s'" "pspace_distinct' s'"
  shows "False"
proof -
  from fin obtain c where
    c: "cte_wp_at ((=) c) slot s" and
    final: "is_final_cap' c s" and
    fm: "final_matters c"
    by (auto simp add: cte_wp_at_cases)
  with valid psr cte
  have cr: "cap_relation c (cteCap cte)"
    by (auto dest!: pspace_relation_ctes_ofI)
  from cte' psr valid
  obtain slot' c' where
    c': "cte_wp_at ((=) c') slot' s" and
    cr': "cap_relation c' (cteCap cte')" and
    x: "x = cte_map slot'"
    by (auto dest!: pspace_relation_cte_wp_atI)
  with neq
  have s: "slot \<noteq> slot'" by clarsimp
  from region cr cr'
  have reg: "same_region_as c c'" by (rule sameRegion_corres)
  hence fm': "final_matters c'" using fm
    apply -
    apply (rule ccontr)
    apply (simp add: final_matters_def split: cap.split_asm arch_cap.split_asm)
    done
  hence ref: "obj_refs c = obj_refs c'" using fm reg
    apply (simp add: final_matters_def split: cap.split_asm arch_cap.split_asm)
    done
  have irq: "cap_irqs c = cap_irqs c'" using reg fm fm'
    by (simp add: final_matters_def split: cap.split_asm)
  have arch_ref: "arch_gen_refs c = arch_gen_refs c'" using fm reg
    by (clarsimp simp: final_matters_def is_cap_simps
                   split: cap.split_asm arch_cap.split_asm)

  from final have refs_non_empty: "obj_refs c \<noteq> {} \<or> cap_irqs c \<noteq> {} \<or> arch_gen_refs c \<noteq> {}"
    by (clarsimp simp add: is_final_cap'_def gen_obj_refs_def)

  define S where "S \<equiv> {cref. \<exists>cap'. fst (get_cap cref s) = {(cap', s)} \<and>
                                    (gen_obj_refs c \<inter> gen_obj_refs cap' \<noteq> {})}"

  have "is_final_cap' c s = (\<exists>cref. S = {cref})"
    by (simp add: is_final_cap'_def S_def)
  moreover
  from c refs_non_empty
  have "slot \<in> S" by (simp add: S_def cte_wp_at_def gen_obj_refs_def)
  moreover
  from c' refs_non_empty ref irq arch_ref
  have "slot' \<in> S" by (simp add: S_def cte_wp_at_def gen_obj_refs_def)
  ultimately
  show False using s final by auto
qed

lemma obj_refs_relation_Master:
  "cap_relation cap cap' \<Longrightarrow>
   obj_refs cap = (if isUntypedCap (capMasterCap cap') then {}
                    else if capClass (capMasterCap cap') = PhysicalClass
                    then {capUntypedPtr (capMasterCap cap')}
                    else {})"
  by (simp add: isCap_simps
         split: cap_relation_split_asm arch_cap.split_asm)

lemma cap_irqs_relation_Master:
  "cap_relation cap cap' \<Longrightarrow>
   cap_irqs cap = (case capMasterCap cap' of IRQHandlerCap irq \<Rightarrow> {irq} | _ \<Rightarrow> {})"
  by (simp split: cap_relation_split_asm arch_cap.split_asm)

lemma arch_gen_refs_relation_Master:
  "cap_relation cap cap' \<Longrightarrow> arch_gen_refs cap = {}"
  by (simp split: cap_relation_split_asm arch_cap.split_asm)

lemma is_final_cap_unique_sym:
  assumes cte: "ctes_of s' (cte_map slot) = Some cte"
  assumes fin: "cte_wp_at (\<lambda>c. is_final_cap' c s) slot s"
  assumes psr: "pspace_relation (kheap s) (ksPSpace s')"
  assumes cte': "ctes_of s' x = Some cte'"
  assumes neq: "x \<noteq> cte_map slot"
  assumes master: "capMasterCap (cteCap cte') = capMasterCap (cteCap cte)"
  assumes valid: "pspace_aligned s" "valid_objs s" "pspace_aligned' s'" "pspace_distinct' s'"
  shows "False"
proof -
  from fin obtain c where
    c: "cte_wp_at ((=) c) slot s" and
    final: "is_final_cap' c s"
    by (auto simp add: cte_wp_at_cases)
  with valid psr cte
  have cr: "cap_relation c (cteCap cte)"
    by (auto dest!: pspace_relation_ctes_ofI)
  from cte' psr valid
  obtain slot' c' where
    c': "cte_wp_at ((=) c') slot' s" and
    cr': "cap_relation c' (cteCap cte')" and
    x: "x = cte_map slot'"
    by (auto dest!: pspace_relation_cte_wp_atI)
  with neq
  have s: "slot \<noteq> slot'" by clarsimp
  have irq: "cap_irqs c = cap_irqs c'"
  using master cr cr'
  by (simp add: cap_irqs_relation_Master)
  have ref: "obj_refs c = obj_refs c'"
  using master cr cr'
  by (simp add: obj_refs_relation_Master)
  have arch_ref: "arch_gen_refs c = arch_gen_refs c'"
  using master cr cr'
  by (clarsimp simp: arch_gen_refs_relation_Master)

  from final have refs_non_empty: "obj_refs c \<noteq> {} \<or> cap_irqs c \<noteq> {} \<or> arch_gen_refs c \<noteq> {}"
    by (clarsimp simp add: is_final_cap'_def gen_obj_refs_def)

  define S where "S \<equiv> {cref. \<exists>cap'. fst (get_cap cref s) = {(cap', s)} \<and>
                                    (gen_obj_refs c \<inter> gen_obj_refs cap' \<noteq> {})}"

  have "is_final_cap' c s = (\<exists>cref. S = {cref})"
    by (simp add: is_final_cap'_def S_def)
  moreover
  from c refs_non_empty
  have "slot \<in> S" by (simp add: S_def cte_wp_at_def gen_obj_refs_def)
  moreover
  from c' refs_non_empty ref irq arch_ref
  have "slot' \<in> S" by (simp add: S_def cte_wp_at_def gen_obj_refs_def)
  ultimately
  show False using s final by auto
qed

lemma isMDBParent_sameRegion:
  "isMDBParentOf cte cte' \<Longrightarrow> sameRegionAs (cteCap cte) (cteCap cte')"
  by (simp add: isMDBParentOf_def split: cte.split_asm if_split_asm)

lemma no_loops_no_subtree:
  "no_loops m \<Longrightarrow> m \<turnstile> x \<rightarrow> x = False"
  apply clarsimp
  apply (drule subtree_mdb_next)
  apply (simp add: no_loops_def)
  done

definition
  "caps_contained2 m \<equiv>
  \<forall>c c' cap n cap' n'.
  m c = Some (CTE cap n) \<longrightarrow> m c' = Some (CTE cap' n') \<longrightarrow>
  (isCNodeCap cap' \<or> isThreadCap cap') \<longrightarrow>
  capUntypedPtr cap' \<in> untypedRange cap \<longrightarrow>
  capUntypedPtr cap' + capUntypedSize cap' - 1 \<in> untypedRange cap"

lemma capUntypedPtr_capRange:
  "\<lbrakk> ctes_of s p = Some (CTE cap node);
     capClass cap = PhysicalClass;
     valid_objs' s \<rbrakk> \<Longrightarrow>
  capUntypedPtr cap \<in> capRange cap"
  apply (erule capAligned_capUntypedPtr[rotated])
  apply (drule (1) ctes_of_valid_cap')
  apply (erule valid_capAligned)
  done

lemma descendants_of_update_ztc:
  assumes c: "\<And>x. \<lbrakk> m \<turnstile> x \<rightarrow> slot; \<not> P \<rbrakk> \<Longrightarrow>
                  \<exists>cte'. m x = Some cte'
                    \<and> capMasterCap (cteCap cte') \<noteq> capMasterCap (cteCap cte)
                    \<and> sameRegionAs (cteCap cte') (cteCap cte)"
  assumes m: "m slot = Some cte"
  assumes z: "isZombie cap \<or> isCNodeCap cap \<or> isThreadCap cap"
  defines "cap' \<equiv> cteCap cte"
  assumes F: "\<And>x cte'. \<lbrakk> m x = Some cte'; x \<noteq> slot; P \<rbrakk>
               \<Longrightarrow> isUntypedCap (cteCap cte') \<or> capClass (cteCap cte') \<noteq> PhysicalClass
                    \<or> capUntypedPtr (cteCap cte') \<noteq> capUntypedPtr cap'"
  assumes pu: "capRange cap' = capRange cap \<and> capUntypedPtr cap' = capUntypedPtr cap"
  assumes a: "capAligned cap'"
  assumes t: "isZombie cap' \<or> isCNodeCap cap' \<or> isThreadCap cap'"
  assumes n: "no_loops m"
  defines "m' \<equiv> m(slot \<mapsto> cteCap_update (\<lambda>_. cap) cte)"
  shows "((c \<noteq> slot \<or> P) \<longrightarrow> descendants_of' c m \<subseteq> descendants_of' c m')
           \<and> (P \<longrightarrow> descendants_of' c m' \<subseteq> descendants_of' c m)"
proof (simp add: descendants_of'_def subset_iff,
       simp only: all_simps(6)[symmetric], intro conjI allI)
  note isMDBParentOf_CTE[simp]

  have utp: "capUntypedPtr cap' \<in> capRange cap'"
    using t a
    by (auto elim!: capAligned_capUntypedPtr simp: isCap_simps)

  have ztc_parent: "\<And>cap cap'. isZombie cap \<or> isCNodeCap cap \<or> isThreadCap cap
                            \<Longrightarrow> sameRegionAs cap cap'
                            \<Longrightarrow> capUntypedPtr cap = capUntypedPtr cap'
                                 \<and> capClass cap' = PhysicalClass \<and> \<not> isUntypedCap cap'"
    by (auto simp: isCap_simps sameRegionAs_def3)

  have ztc_child: "\<And>cap cap'. isZombie cap \<or> isCNodeCap cap \<or> isThreadCap cap
                            \<Longrightarrow> sameRegionAs cap' cap
                            \<Longrightarrow> capClass cap' = PhysicalClass \<and>
                                  (isUntypedCap cap' \<or> capUntypedPtr cap' = capUntypedPtr cap)"
    by (auto simp: isCap_simps sameRegionAs_def3)

  have notparent: "\<And>x cte'. \<lbrakk> m x = Some cte'; x \<noteq> slot; P \<rbrakk>
                               \<Longrightarrow> \<not> isMDBParentOf cte cte'"
    using t utp
    apply clarsimp
    apply (drule_tac cte'=cte' in F, simp+)
    apply (simp add: cap'_def)
    apply (cases cte, case_tac cte', clarsimp)
    apply (frule(1) ztc_parent, clarsimp)
    done

  have notparent2: "\<And>x cte'. \<lbrakk> m x = Some cte'; x \<noteq> slot; P \<rbrakk>
                               \<Longrightarrow> \<not> isMDBParentOf (cteCap_update (\<lambda>_. cap) cte) cte'"
    using z utp
    apply clarsimp
    apply (drule_tac cte'=cte' in F, simp+)
    apply (cases cte, case_tac cte', clarsimp)
    apply (frule(1) ztc_parent)
    apply (clarsimp simp: pu)
    done

  fix x
  { assume cx: "m \<turnstile> c \<rightarrow> x" and cP: "c \<noteq> slot \<or> P"
    hence c_neq_x [simp]: "c \<noteq> x"
      by (clarsimp simp: n no_loops_no_subtree)
    from cx c_neq_x cP m
    have s_neq_c [simp]: "c \<noteq> slot"
      apply (clarsimp simp del: c_neq_x)
      apply (drule subtree_parent)
      apply (clarsimp simp: parentOf_def notparent)
      done

    have parent: "\<And>x cte'. \<lbrakk> m x = Some cte'; isMDBParentOf cte' cte; m \<turnstile> x \<rightarrow> slot; x \<noteq> slot \<rbrakk>
                                \<Longrightarrow> isMDBParentOf cte' (cteCap_update (\<lambda>_. cap) cte)"
      using t z pu
      apply -
      apply (cases P)
       apply (frule(2) F)
       apply (clarsimp simp: cap'_def)
       apply (case_tac cte')
       apply (rename_tac capability mdbnode)
       apply (case_tac cte)
       apply clarsimp
       apply (frule(1) ztc_child)
       apply (case_tac "isUntypedCap capability")
        apply (simp add: isCap_simps)
        apply (clarsimp simp: sameRegionAs_def3 isCap_simps)
       apply simp
      apply (frule(1) c, clarsimp)
      apply (clarsimp simp: cap'_def)
      apply (case_tac cte')
      apply (case_tac cte)
      apply clarsimp
      apply (erule sameRegionAsE)
         apply (clarsimp simp: sameRegionAs_def3 isCap_simps)+
      done

    from cx
    have "m' \<turnstile> c \<rightarrow> x"
    proof induct
      case (direct_parent c')
      hence "m \<turnstile> c \<rightarrow> c'" by (rule subtree.direct_parent)
      with direct_parent m
      show ?case
        apply -
        apply (rule subtree.direct_parent)
          apply (clarsimp simp add: mdb_next_unfold m'_def m)
         apply assumption
        apply (clarsimp simp: parentOf_def)
        apply (clarsimp simp add: m'_def)
        apply (erule(2) parent)
        apply simp
        done
    next
      case (trans_parent c' c'')
      moreover
      from trans_parent
      have "m \<turnstile> c \<rightarrow> c''" by - (rule subtree.trans_parent)
      ultimately
      show ?case using  z m pu t
        apply -
        apply (erule subtree.trans_parent)
          apply (clarsimp simp: mdb_next_unfold m'_def m)
         apply assumption
        apply (clarsimp simp: parentOf_def m'_def)
        apply (erule(2) parent)
        apply simp
        done
    qed
  }
    thus "(c = slot \<longrightarrow> P) \<longrightarrow> m \<turnstile> c \<rightarrow> x \<longrightarrow> m' \<turnstile> c \<rightarrow> x"
      by blast

  { assume subcx: "m' \<turnstile> c \<rightarrow> x" and P: "P"

    have mdb_next_eq: "\<And>x y. m' \<turnstile> x \<leadsto> y = m \<turnstile> x \<leadsto> y"
      by (simp add: mdb_next_unfold m'_def m)
    have mdb_next_eq_trans: "\<And>x y. m' \<turnstile> x \<leadsto>\<^sup>+ y = m \<turnstile> x \<leadsto>\<^sup>+ y"
      apply (rule arg_cong[where f="\<lambda>S. v \<in> S\<^sup>+" for v])
      apply (simp add: set_eq_iff mdb_next_eq)
      done

    have subtree_neq: "\<And>x y. m' \<turnstile> x \<rightarrow> y \<Longrightarrow> x \<noteq> y"
      apply clarsimp
      apply (drule subtree_mdb_next)
      apply (clarsimp simp: mdb_next_eq_trans n no_loops_trancl_simp)
      done

    have parent2: "\<And>x cte'. \<lbrakk> m x = Some cte'; isMDBParentOf cte' (cteCap_update (\<lambda>_. cap) cte);
                                         x \<noteq> slot \<rbrakk>
                                \<Longrightarrow> isMDBParentOf cte' cte"
      using t z pu P
      apply (drule_tac cte'=cte' in F, simp, simp)
      apply (simp add: cap'_def)
      apply (cases cte)
      apply (case_tac cte')
      apply (rename_tac cap' node')
      apply (clarsimp)
      apply (frule(1) ztc_child)
      apply (case_tac "isUntypedCap cap'")
       apply (simp add:isCap_simps)
       apply (clarsimp simp: isCap_simps sameRegionAs_def3)
      apply clarsimp
      done

    from subcx have "m \<turnstile> c \<rightarrow> x"
    proof induct
      case (direct_parent c')
      thus ?case
        using subtree_neq [OF subtree.direct_parent [OF direct_parent(1-3)]]
        apply -
        apply (rule subtree.direct_parent)
          apply (clarsimp simp: mdb_next_unfold m'_def m split: if_split_asm)
         apply assumption
        apply (insert z m t pu)
        apply (simp add: cap'_def)
        apply (simp add: m'_def parentOf_def split: if_split_asm)
         apply (clarsimp simp: parent2)
        apply (clarsimp simp add: notparent2 [OF _ _ P])
        done
    next
      case (trans_parent c' c'')
      thus ?case
        using subtree_neq [OF subtree.trans_parent [OF trans_parent(1, 3-5)]]
        apply -
        apply (erule subtree.trans_parent)
          apply (clarsimp simp: mdb_next_unfold m'_def m split: if_split_asm)
         apply assumption
        apply (insert z m t pu)
        apply (simp add: cap'_def)
        apply (simp add: m'_def parentOf_def split: if_split_asm)
         apply (clarsimp simp: parent2)
        apply (clarsimp simp: notparent2 [OF _ _ P])
        done
    qed
  }
    thus "P \<longrightarrow> m' \<turnstile> c \<rightarrow> x \<longrightarrow> m \<turnstile> c \<rightarrow> x"
      by simp
qed

lemma use_update_ztc_one:
  "((c \<noteq> slot \<or> True) \<longrightarrow> descendants_of' c m \<subseteq> descendants_of' c m')
           \<and> (True \<longrightarrow> descendants_of' c m' \<subseteq> descendants_of' c m)
      \<Longrightarrow> descendants_of' c m = descendants_of' c m'"
  by clarsimp

lemma use_update_ztc_two:
  "((c \<noteq> slot \<or> False) \<longrightarrow> descendants_of' c m \<subseteq> descendants_of' c m')
           \<and> (False \<longrightarrow> descendants_of' c m' \<subseteq> descendants_of' c m)
       \<Longrightarrow> descendants_of' slot m = {}
       \<Longrightarrow> descendants_of' c m \<subseteq> descendants_of' c m'"
  by auto

lemmas cte_wp_at'_obj_at' = cte_wp_at_obj_cases'

lemma cte_at'_obj_at':
  "cte_at' addr s = (obj_at' (\<lambda>_ :: cte. True) addr s
                      \<or> (\<exists>n \<in> dom tcb_cte_cases. tcb_at' (addr - n) s))"
  by (simp add: cte_wp_at'_obj_at')

lemma ctes_of_valid:
  "\<lbrakk> cte_wp_at' ((=) cte) p s; valid_objs' s \<rbrakk>
  \<Longrightarrow> s \<turnstile>' cteCap cte"
  apply (simp add: cte_wp_at'_obj_at')
  apply (erule disjE)
   apply (subgoal_tac "ko_at' cte p s")
    apply (drule (1) ko_at_valid_objs')
     apply simp
    apply (simp add: valid_obj'_def valid_cte'_def)
   apply (simp add: obj_at'_def cte_level_bits_def objBits_simps)
  apply clarsimp
  apply (drule obj_at_ko_at')
  apply clarsimp
  apply (drule (1) ko_at_valid_objs')
   apply simp
  apply (simp add: valid_obj'_def valid_tcb'_def)
  apply (fastforce)
  done

lemma no_fail_setCTE [wp]:
  "no_fail (cte_at' p) (setCTE p c)"
  apply (clarsimp simp: setCTE_def setObject_def split_def unless_def
                        updateObject_cte alignCheck_def alignError_def
                        typeError_def is_aligned_mask[symmetric]
                  cong: kernel_object.case_cong)
  apply (wp|wpc)+
  apply (clarsimp simp: cte_wp_at'_def getObject_def split_def
                        in_monad loadObject_cte
                 dest!: in_singleton
             split del: if_split)
  apply (clarsimp simp: typeError_def alignCheck_def alignError_def
                        in_monad is_aligned_mask[symmetric] objBits_simps
                        magnitudeCheck_def
                 split: kernel_object.split_asm if_split_asm option.splits
             split del: if_split)
    apply simp_all
  done

lemma no_fail_updateCap [wp]:
  "no_fail (cte_at' p) (updateCap p cap')"
  apply (simp add: updateCap_def)
  apply (rule no_fail_pre, wp)
  apply simp
  done

lemma capRange_cap_relation:
  "\<lbrakk> cap_relation cap cap'; cap_relation cap cap' \<Longrightarrow> capClass cap' = PhysicalClass \<rbrakk>
    \<Longrightarrow> capRange cap' = {obj_ref_of cap .. obj_ref_of cap + obj_size cap - 1}"
  by (simp add: capRange_def objBits_simps' cte_level_bits_def
                asid_low_bits_def zbits_map_def bit_simps
         split: cap_relation_split_asm arch_cap.split_asm
                option.split sum.split)

lemma cap_relation_untyped_ptr_obj_refs:
  "cap_relation cap cap' \<Longrightarrow> capClass cap' = PhysicalClass \<Longrightarrow> \<not> isUntypedCap cap'
        \<Longrightarrow> capUntypedPtr cap' \<in> obj_refs cap"
  by (clarsimp simp add: isCap_simps
               simp del: not_ex
                  split: cap_relation_split_asm arch_cap.split_asm)

lemma obj_refs_cap_relation_untyped_ptr:
  "\<lbrakk> cap_relation cap cap'; obj_refs cap \<noteq> {} \<rbrakk> \<Longrightarrow> capUntypedPtr cap' \<in> obj_refs cap"
  by (clarsimp split: cap_relation_split_asm arch_cap.split_asm)

lemma is_final_untyped_ptrs:
  "\<lbrakk> ctes_of (s' :: kernel_state) (cte_map slot) = Some cte; ctes_of s' y = Some cte'; cte_map slot \<noteq> y;
     pspace_relation (kheap s) (ksPSpace s'); valid_objs s; pspace_aligned s; pspace_distinct s;
     cte_wp_at (\<lambda>cap. is_final_cap' cap s \<and> obj_refs cap \<noteq> {}) slot s \<rbrakk>
         \<Longrightarrow> capClass (cteCap cte') \<noteq> PhysicalClass
           \<or> isUntypedCap (cteCap cte')
           \<or> capUntypedPtr (cteCap cte) \<noteq> capUntypedPtr (cteCap cte')"
  apply clarsimp
  apply (drule(2) pspace_relation_cte_wp_atI[rotated])+
  apply clarsimp
  apply (drule_tac s=s in cte_map_inj_eq,
          (clarsimp elim!: cte_wp_at_weakenE[OF _ TrueI])+)
  apply (clarsimp simp: cte_wp_at_def)
  apply (erule(3) final_cap_duplicate [where r="ObjRef (capUntypedPtr (cteCap cte))",
                                       OF _ _ distinct_lemma[where f=cte_map]])
    apply (rule obj_ref_is_gen_obj_ref)
    apply (erule(1) obj_refs_cap_relation_untyped_ptr)
   apply (rule obj_ref_is_gen_obj_ref)
   apply (erule(1) obj_refs_cap_relation_untyped_ptr)
  apply (rule obj_ref_is_gen_obj_ref)
  apply (drule(2) cap_relation_untyped_ptr_obj_refs)+
  apply simp
  done

lemma capClass_ztc_relation:
  "\<lbrakk> is_zombie c \<or> is_cnode_cap c \<or> is_thread_cap c;
       cap_relation c c' \<rbrakk> \<Longrightarrow> capClass c' = PhysicalClass"
  by (auto simp: is_cap_simps)

lemma pspace_relationsD:
  "\<lbrakk>pspace_relation kh kh'; ekheap_relation ekh kh'\<rbrakk> \<Longrightarrow> pspace_relations ekh kh kh'"
  by (simp add: pspace_relations_def)

lemma updateCap_corres:
  "\<lbrakk>cap_relation cap cap';
    is_zombie cap \<or> is_cnode_cap cap \<or> is_thread_cap cap \<rbrakk>
   \<Longrightarrow> corres dc (\<lambda>s. invs s \<and>
                      cte_wp_at (\<lambda>c. (is_zombie c \<or> is_cnode_cap c \<or>
                                      is_thread_cap c) \<and>
                                     is_final_cap' c s \<and>
                                     obj_ref_of c = obj_ref_of cap \<and>
                                     obj_size c = obj_size cap) slot s)
                 invs'
                 (set_cap cap slot) (updateCap (cte_map slot) cap')"
  apply (rule corres_stronger_no_failI)
   apply (rule no_fail_pre, wp)
   apply clarsimp
   apply (drule cte_wp_at_norm)
   apply (clarsimp simp: state_relation_def)
   apply (drule (1) pspace_relation_ctes_ofI)
     apply fastforce
    apply fastforce
   apply (clarsimp simp: cte_wp_at_ctes_of)
  apply (clarsimp simp add: state_relation_def)
  apply (drule(1) pspace_relationsD)
  apply (frule (3) set_cap_not_quite_corres; fastforce?)
   apply (erule cte_wp_at_weakenE, rule TrueI)
  apply clarsimp
  apply (rule bexI)
   prefer 2
   apply simp
  apply (clarsimp simp: in_set_cap_cte_at_swp pspace_relations_def)
  apply (drule updateCap_stuff)
  apply simp
  apply (rule conjI)
   apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def)
  apply (rule conjI)
   prefer 2
   apply (rule conjI)
    apply (unfold cdt_list_relation_def)[1]
    apply (intro allI impI)
    apply (erule_tac x=c in allE)
    apply (auto elim!: modify_map_casesE)[1]
   apply (unfold revokable_relation_def)[1]
   apply (drule set_cap_caps_of_state_monad)
   apply (simp add: cte_wp_at_caps_of_state del: split_paired_All)
   apply (intro allI impI)
   apply (erule_tac x=c in allE)
   apply (erule impE[where P="\<exists>y. v = Some y" for v])
    apply (clarsimp simp: null_filter_def is_zombie_def split: if_split_asm)
   apply (auto elim!: modify_map_casesE del: disjE)[1] (* slow *)
  apply (case_tac "ctes_of b (cte_map slot)")
   apply (simp add: modify_map_None)
  apply (simp add: modify_map_apply)
  apply (simp add: cdt_relation_def del: split_paired_All)
  apply (intro allI impI)
  apply (rule use_update_ztc_one [OF descendants_of_update_ztc])
         apply simp
        apply assumption
       apply (auto simp: is_cap_simps isCap_simps)[1]
      apply (frule(3) is_final_untyped_ptrs [OF _ _ not_sym], clarsimp+)
       apply (clarsimp simp: cte_wp_at_caps_of_state)
       apply (simp add: is_cap_simps, elim disjE exE, simp_all)[1]
      apply (simp add: eq_commute)
     apply (drule cte_wp_at_norm, clarsimp)
     apply (drule(1) pspace_relation_ctes_ofI, clarsimp+)
     apply (drule(1) capClass_ztc_relation)+
     apply (simp add: capRange_cap_relation obj_ref_of_relation[symmetric])
    apply (rule valid_capAligned, rule ctes_of_valid)
     apply (simp add: cte_wp_at_ctes_of)
    apply clarsimp
   apply (drule cte_wp_at_norm, clarsimp)
   apply (drule(1) pspace_relation_ctes_ofI, clarsimp+)
   apply (simp add: is_cap_simps, elim disjE exE, simp_all add: isCap_simps)[1]
  apply clarsimp
  done

lemma exst_set_cap:
  "(x,s') \<in> fst (set_cap p c s) \<Longrightarrow> exst s' = exst s"
  by (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def
               split: if_split_asm Structures_A.kernel_object.splits)

lemma updateMDB_eqs:
  assumes "(x, s'') \<in> fst (updateMDB p f s')"
  shows "ksMachineState s'' = ksMachineState s' \<and>
         ksWorkUnitsCompleted s'' = ksWorkUnitsCompleted s' \<and>
         ksCurThread s'' = ksCurThread s' \<and>
         ksIdleThread s'' = ksIdleThread s' \<and>
         ksReadyQueues s'' = ksReadyQueues s' \<and>
         ksInterruptState s'' = ksInterruptState s' \<and>
         ksArchState s'' = ksArchState s' \<and>
         ksSchedulerAction s'' = ksSchedulerAction s' \<and>
         gsUserPages s'' = gsUserPages s' \<and>
         gsCNodes s'' = gsCNodes s' \<and>
         ksDomScheduleIdx s'' = ksDomScheduleIdx s' \<and>
         ksDomSchedule s''    = ksDomSchedule s' \<and>
         ksCurDomain s''      = ksCurDomain s' \<and>
         ksDomainTime s''     = ksDomainTime s'" using assms
  apply (clarsimp simp: updateMDB_def Let_def in_monad split: if_split_asm)
  apply (drule in_inv_by_hoareD [OF getCTE_inv])
  apply (clarsimp simp: setCTE_def setObject_def in_monad split_def)
  apply (drule in_inv_by_hoareD [OF updateObject_cte_inv])
  apply simp
  done

lemma updateMDB_pspace_relation:
  assumes "(x, s'') \<in> fst (updateMDB p f s')"
  assumes "pspace_relation (kheap s) (ksPSpace s')"
  assumes "pspace_aligned' s'" "pspace_distinct' s'"
  shows "pspace_relation (kheap s) (ksPSpace s'')" using assms
  apply (clarsimp simp: updateMDB_def Let_def in_monad split: if_split_asm)
  apply (drule_tac P="(=) s'" in use_valid [OF _ getCTE_sp], rule refl)
  apply clarsimp
  apply (clarsimp simp: setCTE_def setObject_def in_monad
                        split_def)
  apply (drule(1) updateObject_cte_is_tcb_or_cte[OF _ refl, rotated])
  apply (elim disjE conjE exE)
   apply (clarsimp simp: cte_wp_at_cases' lookupAround2_char1)
   apply (erule disjE)
    apply (clarsimp simp: tcb_ctes_clear cte_level_bits_def objBits_defs)
   apply clarsimp
   apply (rule pspace_dom_relatedE, assumption+)
   apply (rule obj_relation_cutsE, assumption+, simp_all split: if_split_asm)[1]
   apply (clarsimp split: Structures_A.kernel_object.split_asm
                          AARCH64_A.arch_kernel_obj.split_asm
                    simp: other_obj_relation_def)
   apply (frule(1) tcb_cte_cases_aligned_helpers(1))
   apply (frule(1) tcb_cte_cases_aligned_helpers(2))
   apply (clarsimp simp del: diff_neg_mask)
   apply (subst map_upd_triv[symmetric, where t="kheap s"], assumption)
   apply (erule(2) pspace_relation_update_tcbs)
   apply (case_tac tcba)
   apply (simp add: tcb_cte_cases_def tcb_relation_def del: diff_neg_mask
             split: if_split_asm)
  apply (clarsimp simp: cte_wp_at_cases')
  apply (erule disjE)
   apply (rule pspace_dom_relatedE, assumption+)
   apply (rule obj_relation_cutsE, assumption+, simp_all split: if_split_asm)[1]
   apply (clarsimp simp: cte_relation_def)
   apply (simp add: pspace_relation_def dom_fun_upd2
               del: dom_fun_upd)
   apply (erule conjE)
   apply (rule ballI, drule(1) bspec)
   apply (rule ballI, drule(1) bspec)
   apply clarsimp
   apply (rule obj_relation_cutsE, assumption+, simp_all split: if_split_asm)[1]
   apply (clarsimp simp: cte_relation_def)
  apply clarsimp
  apply (drule_tac y=p in tcb_ctes_clear[rotated], assumption+)
   apply fastforce
  apply fastforce
  done

lemma updateMDB_ekheap_relation:
  assumes "(x, s'') \<in> fst (updateMDB p f s')"
  assumes "ekheap_relation (ekheap s) (ksPSpace s')"
  shows "ekheap_relation (ekheap s) (ksPSpace s'')" using assms
  apply (clarsimp simp: updateMDB_def Let_def setCTE_def setObject_def in_monad ekheap_relation_def etcb_relation_def split_def split: if_split_asm)
  apply (drule(1) updateObject_cte_is_tcb_or_cte[OF _ refl, rotated])
  apply (drule_tac P="(=) s'" in use_valid [OF _ getCTE_sp], rule refl)
  apply (drule bspec, erule domI)
  apply (clarsimp simp: tcb_cte_cases_def lookupAround2_char1 split: if_split_asm)
  done

lemma updateMDB_pspace_relations:
  assumes "(x, s'') \<in> fst (updateMDB p f s')"
  assumes "pspace_relations (ekheap s) (kheap s) (ksPSpace s')"
  assumes "pspace_aligned' s'" "pspace_distinct' s'"
  shows "pspace_relations (ekheap s) (kheap s) (ksPSpace s'')" using assms
  by (simp add: pspace_relations_def updateMDB_pspace_relation updateMDB_ekheap_relation)

lemma updateMDB_ctes_of:
  assumes "(x, s') \<in> fst (updateMDB p f s)"
  assumes "no_0 (ctes_of s)"
  shows "ctes_of s' = modify_map (ctes_of s) p (cteMDBNode_update f)"
  using assms
  apply (clarsimp simp: valid_def)
  apply (drule use_valid)
    apply (rule updateMDB_ctes_of_no_0)
   prefer 2
   apply assumption
  apply simp
  done

crunch aligned[wp]: updateMDB "pspace_aligned'"
crunch pdistinct[wp]: updateMDB "pspace_distinct'"

lemma updateMDB_the_lot:
  assumes "(x, s'') \<in> fst (updateMDB p f s')"
  assumes "pspace_relations (ekheap s) (kheap s) (ksPSpace s')"
  assumes "pspace_aligned' s'" "pspace_distinct' s'" "no_0 (ctes_of s')"
  shows "ctes_of s'' = modify_map (ctes_of s') p (cteMDBNode_update f) \<and>
         ksMachineState s'' = ksMachineState s' \<and>
         ksWorkUnitsCompleted s'' = ksWorkUnitsCompleted s' \<and>
         ksCurThread s'' = ksCurThread s' \<and>
         ksIdleThread s'' = ksIdleThread s' \<and>
         ksReadyQueues s'' = ksReadyQueues s' \<and>
         ksSchedulerAction s'' = ksSchedulerAction s' \<and>
         ksInterruptState s'' = ksInterruptState s' \<and>
         ksArchState s'' = ksArchState s' \<and>
         gsUserPages s'' = gsUserPages s' \<and>
         gsCNodes s'' = gsCNodes s' \<and>
         pspace_relations (ekheap s) (kheap s) (ksPSpace s'') \<and>
         pspace_aligned' s'' \<and> pspace_distinct' s'' \<and>
         no_0 (ctes_of s'') \<and>
         ksDomScheduleIdx s'' = ksDomScheduleIdx s' \<and>
         ksDomSchedule s''    = ksDomSchedule s' \<and>
         ksCurDomain s''      = ksCurDomain s' \<and>
         ksDomainTime s''     = ksDomainTime s'"
using assms
  apply (simp add: updateMDB_eqs updateMDB_pspace_relations split del: if_split)
  apply (frule (1) updateMDB_ctes_of)
  apply clarsimp
  apply (rule conjI)
   apply (erule use_valid)
    apply wp
   apply simp
  apply (erule use_valid)
   apply wp
  apply simp
  done

lemma is_cap_revocable_eq:
  "\<lbrakk> cap_relation c c'; cap_relation src_cap src_cap'; sameRegionAs src_cap' c';
     is_untyped_cap src_cap \<longrightarrow> \<not> is_ep_cap c \<and> \<not> is_ntfn_cap c\<rbrakk>
  \<Longrightarrow> is_cap_revocable c src_cap = isCapRevocable c' src_cap'"
  apply (clarsimp simp: isCap_simps objBits_simps bit_simps arch_is_cap_revocable_def
                        bits_of_def is_cap_revocable_def Retype_H.isCapRevocable_def
                        sameRegionAs_def3 isCapRevocable_def
                 split: cap_relation_split_asm arch_cap.split_asm)
  done

lemma isMDBParentOf_prev_update [simp]:
  "isMDBParentOf (cteMDBNode_update (mdbPrev_update f) cte) cte' =
   isMDBParentOf cte cte'"
  "isMDBParentOf cte (cteMDBNode_update (mdbPrev_update f) cte') =
   isMDBParentOf cte cte'"
   apply (cases cte)
   apply (cases cte')
   apply (simp add: isMDBParentOf_def)
  apply (cases cte)
  apply (cases cte')
  apply (clarsimp simp: isMDBParentOf_def)
  done

lemma prev_update_subtree [simp]:
  "modify_map m' x (cteMDBNode_update (mdbPrev_update f)) \<turnstile> a \<rightarrow> b = m' \<turnstile> a \<rightarrow> b"
  (is "?m' = ?m")
proof
  assume "?m"
  thus ?m'
  proof induct
    case (direct_parent c)
    thus ?case
      apply -
      apply (rule subtree.direct_parent)
        apply (clarsimp simp add: mdb_next_unfold modify_map_def)
       apply assumption
      apply (clarsimp simp add: parentOf_def modify_map_def)
      apply fastforce
      done
  next
    case (trans_parent c c')
    thus ?case
      apply -
      apply (rule subtree.trans_parent)
         apply (rule trans_parent.hyps)
        apply (clarsimp simp add: mdb_next_unfold modify_map_def)
       apply assumption
      apply (clarsimp simp add: parentOf_def modify_map_def)
      apply fastforce
      done
  qed
next
  assume "?m'"
  thus ?m
  proof induct
    case (direct_parent c)
    thus ?case
      apply -
      apply (rule subtree.direct_parent)
        apply (clarsimp simp add: mdb_next_unfold modify_map_def split: if_split_asm)
       apply assumption
      apply (clarsimp simp add: parentOf_def modify_map_def split: if_split_asm)
      done
  next
    case (trans_parent c c')
    thus ?case
      apply -
      apply (rule subtree.trans_parent)
         apply (rule trans_parent.hyps)
        apply (clarsimp simp add: mdb_next_unfold modify_map_def split: if_split_asm)
       apply assumption
      apply (clarsimp simp add: parentOf_def modify_map_def split: if_split_asm)
      done
  qed
qed

lemma prev_update_modify_mdb_relation:
  "cdt_relation c m (modify_map m' x (cteMDBNode_update (mdbPrev_update f)))
  = cdt_relation c m m'"
  by (fastforce simp: cdt_relation_def descendants_of'_def)

lemma subtree_prev_0:
  assumes s: "m \<turnstile> a \<rightarrow> b"
  assumes n: "m b = Some cte" "mdbPrev (cteMDBNode cte) = 0"
  assumes d: "valid_dlist m"
  assumes 0: "no_0 m"
  shows "False" using s n
proof induct
  case (direct_parent c)
  have "m \<turnstile> a \<leadsto> c" by fact+
  then obtain cte' where a: "m a = Some cte'" and "mdbNext (cteMDBNode cte') = c"
    by (auto simp add: mdb_next_unfold)
  moreover
  have "m c = Some cte" by fact+
  moreover
  have "c \<noteq> 0" by fact+
  ultimately
  have "mdbPrev (cteMDBNode cte) = a" using d
    by (fastforce simp add: valid_dlist_def Let_def)
  moreover
  have "mdbPrev (cteMDBNode cte) = 0" by fact+
  moreover
  from a have "a \<noteq> 0" using assms by auto
  ultimately
  show False by simp
next
  case (trans_parent c' c)
  have "m \<turnstile> c' \<leadsto> c" by fact+
  then obtain cte' where c': "m c' = Some cte'" and "mdbNext (cteMDBNode cte') = c"
    by (auto simp add: mdb_next_unfold)
  moreover
  have "m c = Some cte" by fact+
  moreover
  have "c \<noteq> 0" by fact+
  ultimately
  have "mdbPrev (cteMDBNode cte) = c'" using d
    by (fastforce simp add: valid_dlist_def Let_def)
  moreover
  have "mdbPrev (cteMDBNode cte) = 0" by fact+
  moreover
  from c' have "c' \<noteq> 0" using assms by auto
  ultimately
  show False by simp
qed

lemma subtree_next_0:
  assumes s: "m \<turnstile> a \<rightarrow> b"
  assumes n: "m a = Some cte" "mdbNext (cteMDBNode cte) = 0"
  shows "False" using s n
  by induct (auto simp: mdb_next_unfold)

definition
  "isArchCap P cap \<equiv> case cap of ArchObjectCap acap \<Rightarrow> P acap | _ \<Rightarrow> False"

lemma isArchCap_simps[simp]:
  "isArchCap P (capability.ThreadCap xc) = False"
  "isArchCap P capability.NullCap = False"
  "isArchCap P capability.DomainCap = False"
  "isArchCap P (capability.NotificationCap xca xba xaa xd) = False"
  "isArchCap P (capability.EndpointCap xda xcb xbb xab xe xi) = False"
  "isArchCap P (capability.IRQHandlerCap xf) = False"
  "isArchCap P (capability.Zombie xbc xac xg) = False"
  "isArchCap P (capability.ArchObjectCap xh) = P xh"
  "isArchCap P (capability.ReplyCap xad xi xia) = False"
  "isArchCap P (capability.UntypedCap d xae xj f) = False"
  "isArchCap P (capability.CNodeCap xfa xea xdb xcc) = False"
  "isArchCap P capability.IRQControlCap = False"
  by (simp add: isArchCap_def)+

definition
  "badge_derived' cap' cap \<equiv>
    capMasterCap cap = capMasterCap cap' \<and>
    (capBadge cap, capBadge cap') \<in> capBadge_ordering False"

definition vs_cap_ref_arch' :: "arch_capability \<Rightarrow> (asid \<times> vspace_ref) option" where
  "vs_cap_ref_arch' acap \<equiv>
     case acap of
       ASIDPoolCap _ asid \<Rightarrow> Some (asid, 0)
     | ASIDControlCap \<Rightarrow> None
     | FrameCap _ _ _ _ m \<Rightarrow> m
     | PageTableCap _ _ m \<Rightarrow> m"

lemmas vs_cap_ref_arch'_simps[simp] = vs_cap_ref_arch'_def[split_simps arch_capability.split]

definition
  "vs_cap_ref' = arch_cap'_fun_lift vs_cap_ref_arch' None"

lemmas vs_cap_ref'_simps[simp] =
  vs_cap_ref'_def[THEN fun_cong, unfolded arch_cap'_fun_lift_def, split_simps capability.split]

definition
  "is_derived' m p cap' cap \<equiv>
  cap' \<noteq> NullCap \<and>
  \<not> isZombie cap \<and>
  \<not> isIRQControlCap cap' \<and>
  badge_derived' cap' cap \<and>
  (isUntypedCap cap \<longrightarrow> descendants_of' p m = {}) \<and>
  (isReplyCap cap = isReplyCap cap') \<and>
  (isReplyCap cap \<longrightarrow> capReplyMaster cap) \<and>
  (isReplyCap cap' \<longrightarrow> \<not> capReplyMaster cap') \<and>
  (vs_cap_ref' cap = vs_cap_ref' cap' \<or> isArchFrameCap cap) \<and>
  (isArchCap isPageTableCap cap \<longrightarrow> capASID cap = capASID cap' \<and> capASID cap \<noteq> None)"

lemma zbits_map_eq[simp]:
  "(zbits_map zbits = zbits_map zbits') = (zbits = zbits')"
  by (simp add: zbits_map_def split: option.split sum.split)

lemma master_cap_relation:
  "\<lbrakk> cap_relation c c'; cap_relation d d' \<rbrakk> \<Longrightarrow>
  (capMasterCap c' = capMasterCap d') =
  (cap_master_cap c = cap_master_cap d)"
  by (auto simp add: cap_master_cap_def capMasterCap_def split: cap.splits arch_cap.splits)

lemma cap_badge_relation:
  "\<lbrakk> cap_relation c c'; cap_relation d d' \<rbrakk> \<Longrightarrow>
  (capBadge c' = capBadge d') =
  (cap_badge c = cap_badge d)"
  by (auto simp add: cap_badge_def split: cap.splits arch_cap.splits)

lemma capBadge_ordering_relation:
  "\<lbrakk> cap_relation c c'; cap_relation d d' \<rbrakk> \<Longrightarrow>
  ((capBadge c', capBadge d') \<in> capBadge_ordering f) =
  ((cap_badge c, cap_badge d) \<in> capBadge_ordering f)"
  apply (cases c)
   by (auto simp add: cap_badge_def capBadge_ordering_def split: cap.splits)

lemma is_reply_cap_relation:
  "cap_relation c c' \<Longrightarrow> is_reply_cap c = (isReplyCap c' \<and> \<not> capReplyMaster c')"
  by (cases c, auto simp: is_cap_simps isCap_simps)

lemma is_reply_master_relation:
  "cap_relation c c' \<Longrightarrow>
   is_master_reply_cap c = (isReplyCap c' \<and> capReplyMaster c')"
  by (cases c, auto simp add: is_cap_simps isCap_simps)

lemma cap_asid_cap_relation:
  "cap_relation c c' \<Longrightarrow> capASID c' = map_option ucast (cap_asid c)"
  by (auto simp: capASID_def cap_asid_def split: cap.splits arch_cap.splits option.splits)

lemma isArchCapE[elim!]:
  "\<lbrakk> isArchCap P cap; \<And>arch_cap. cap = ArchObjectCap arch_cap \<Longrightarrow> P arch_cap \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by (cases cap, simp_all)

lemma is_derived_eq:
  "\<lbrakk> cap_relation c c'; cap_relation d d';
     cdt_relation (swp cte_at s) (cdt s) (ctes_of s'); cte_at p s \<rbrakk> \<Longrightarrow>
  is_derived (cdt s) p c d = is_derived' (ctes_of s') (cte_map p) c' d'"
  unfolding cdt_relation_def
  apply (erule allE, erule impE, simp)
  apply (clarsimp simp: is_derived_def is_derived'_def badge_derived'_def)
  apply (rule conjI)
   apply (clarsimp simp: is_cap_simps isCap_simps)
   apply (cases c, auto simp: isCap_simps cap_master_cap_def capMasterCap_def)[1]
  apply (case_tac "isIRQControlCap d'")
   apply (frule(1) master_cap_relation)
   apply (clarsimp simp: isCap_simps cap_master_cap_def
                         is_zombie_def is_reply_cap_def is_master_reply_cap_def
                  split: cap_relation_split_asm arch_cap.split_asm)[1]
  apply (frule(1) master_cap_relation)
  apply (frule(1) cap_badge_relation)
  apply (frule cap_asid_cap_relation)
  apply (frule(1) capBadge_ordering_relation)
  apply (case_tac d)
             apply (simp_all add: isCap_simps is_cap_simps cap_master_cap_def
                                  capMasterCap_def
                           split: cap_relation_split_asm arch_cap.split_asm)
      apply fastforce
     apply (auto simp: up_ucast_inj_eq split:arch_cap.splits arch_capability.splits option.splits)
  done
end

locale masterCap =
  fixes cap cap'
  assumes master: "capMasterCap cap = capMasterCap cap'"
begin
interpretation Arch . (*FIXME: arch_split*)

lemma isZombie [simp]:
  "isZombie cap' = isZombie cap" using master
  by (simp add: capMasterCap_def isZombie_def split: capability.splits)

lemma isUntypedCap [simp]:
  "isUntypedCap cap' = isUntypedCap cap" using master
  by (simp add: capMasterCap_def isUntypedCap_def split: capability.splits)

lemma isArchFrameCap [simp]:
  "isArchFrameCap cap' = isArchFrameCap cap" using master
  by (simp add: capMasterCap_def isArchFrameCap_def
           split: capability.splits arch_capability.splits)

lemma isIRQHandlerCap [simp]:
  "isIRQHandlerCap cap' = isIRQHandlerCap cap" using master
  by (simp add: capMasterCap_def isIRQHandlerCap_def split: capability.splits)

lemma isEndpointCap [simp]:
  "isEndpointCap cap' = isEndpointCap cap" using master
  by (simp add: capMasterCap_def isEndpointCap_def split: capability.splits)

lemma isNotificationCap [simp]:
  "isNotificationCap cap' = isNotificationCap cap" using master
  by (simp add: capMasterCap_def isNotificationCap_def split: capability.splits)

lemma isIRQControlCap [simp]:
  "isIRQControlCap cap' = isIRQControlCap cap" using master
  by (simp add: capMasterCap_def isIRQControlCap_def split: capability.splits)

lemma isReplyCap [simp]:
  "isReplyCap cap' = isReplyCap cap" using master
  by (simp add: capMasterCap_def isReplyCap_def split: capability.splits)

lemma capRange [simp]:
  "capRange cap' = capRange cap" using master
  by (simp add: capRange_def capMasterCap_def split: capability.splits arch_capability.splits)

lemma isDomain1:
  "(cap' = DomainCap) = (cap = DomainCap)" using master
  by (simp add: capMasterCap_def split: capability.splits)

lemma isDomain2:
  "(DomainCap = cap') = (DomainCap = cap)" using master
  by (simp add: capMasterCap_def split: capability.splits)

lemma isNull1:
  "(cap' = NullCap) = (cap = NullCap)" using master
  by (simp add: capMasterCap_def split: capability.splits)

lemma isNull2:
  "(NullCap = cap') = (NullCap = cap)" using master
  by (simp add: capMasterCap_def split: capability.splits)

lemmas isNull [simp] = isNull1 isNull2

lemmas isDomain [simp] = isDomain1 isDomain2

lemma sameRegionAs1:
  "sameRegionAs c cap' = sameRegionAs c cap" using master
  by (simp add: sameRegionAs_def3)

lemma sameRegionAs2:
  "sameRegionAs cap' c = sameRegionAs cap c" using master
  by (simp add: sameRegionAs_def3)

lemmas sameRegionAs [simp] = sameRegionAs1 sameRegionAs2

lemma isMDBParentOf1:
  assumes "\<not>isReplyCap cap"
  assumes "\<not>isEndpointCap cap"
  assumes "\<not>isNotificationCap cap"
  shows "isMDBParentOf c (CTE cap' m) = isMDBParentOf c (CTE cap m)"
proof -
  from assms
  have c':
    "\<not>isReplyCap cap'" "\<not>isEndpointCap cap'"
    "\<not>isNotificationCap cap'" by auto
  note isReplyCap [simp del] isEndpointCap [simp del] isNotificationCap [simp del]
  from c' assms
  show ?thesis
  apply (cases c, clarsimp)
  apply (simp add: isMDBParentOf_CTE)
  apply (rule iffI)
   apply clarsimp
   apply (clarsimp simp: capBadge_ordering_def capBadge_def isCap_simps sameRegionAs_def3
                   split: if_split_asm)
  apply clarsimp
  apply (clarsimp simp: capBadge_ordering_def capBadge_def isCap_simps sameRegionAs_def3
                  split: if_split_asm)
  done
qed

lemma isMDBParentOf2:
  assumes "\<not>isReplyCap cap"
  assumes "\<not>isEndpointCap cap"
  assumes "\<not>isNotificationCap cap"
  shows "isMDBParentOf (CTE cap' m) c = isMDBParentOf (CTE cap m) c"
proof -
  from assms
  have c':
    "\<not>isReplyCap cap'" "\<not>isEndpointCap cap'"
    "\<not>isNotificationCap cap'" by auto
  note isReplyCap [simp del] isEndpointCap [simp del] isNotificationCap [simp del]
  from c' assms
  show ?thesis
  apply (cases c, clarsimp)
  apply (simp add: isMDBParentOf_CTE)
  apply (auto simp: capBadge_ordering_def capBadge_def isCap_simps sameRegionAs_def3
                  split: if_split_asm)[1]
  done
qed

lemmas isMDBParentOf = isMDBParentOf1 isMDBParentOf2

end


lemma same_master_descendants:
  assumes slot: "m slot = Some cte"
  assumes master: "capMasterCap (cteCap cte) = capMasterCap cap'"
  assumes c': "\<not>isReplyCap cap'" "\<not>isEndpointCap cap'" "\<not>isNotificationCap cap'"
  defines "m' \<equiv> m(slot \<mapsto> cteCap_update (\<lambda>_. cap') cte)"
  shows "descendants_of' p m' = descendants_of' p m"
proof (rule set_eqI, simp add: descendants_of'_def)
  obtain cap n where cte: "cte = CTE cap n" by (cases cte)
  then
  interpret masterCap cap cap'
    using master by (simp add: masterCap_def)

  from c'
  have c: "\<not>isReplyCap cap"
          "\<not>isEndpointCap cap"
          "\<not>isNotificationCap cap" by auto

  note parent [simp] = isMDBParentOf [OF c]

  { fix a b
    from slot
    have "m' \<turnstile> a \<leadsto> b = m \<turnstile> a \<leadsto> b"
      by (simp add: m'_def mdb_next_unfold)
  } note this [simp]

  { fix a b
    from slot cte
    have "m' \<turnstile> a parentOf b = m \<turnstile> a parentOf b"
      by (simp add: m'_def parentOf_def)
  } note this [simp]

  fix x
  { assume "m \<turnstile> p \<rightarrow> x"
    hence "m' \<turnstile> p \<rightarrow> x"
    proof induct
      case (direct_parent c')
      thus ?case
        by (auto intro: subtree.direct_parent)
    next
      case trans_parent
      thus ?case
        by (auto elim: subtree.trans_parent)
    qed
  }
  moreover {
    assume "m' \<turnstile> p \<rightarrow> x"
    hence "m \<turnstile> p \<rightarrow> x"
    proof induct
      case (direct_parent c')
      thus ?case
        by (auto intro: subtree.direct_parent)
    next
      case trans_parent
      thus ?case
        by (auto elim: subtree.trans_parent)
    qed
  }
  ultimately
  show "m' \<turnstile> p \<rightarrow> x = m \<turnstile> p \<rightarrow> x" by blast
qed

lemma is_ep_cap_relation:
  "cap_relation c c' \<Longrightarrow> isEndpointCap c' = is_ep_cap c"
  apply (simp add: isCap_simps is_cap_simps)
  apply (cases c, auto)
  done

lemma is_ntfn_cap_relation:
  "cap_relation c c' \<Longrightarrow> isNotificationCap c' = is_ntfn_cap c"
  apply (simp add: isCap_simps is_cap_simps)
  apply (cases c, auto)
  done

(* Just for convenience like free_index_update *)
definition freeIndex_update where
  "freeIndex_update c' g \<equiv> case c' of capability.UntypedCap d ref sz f \<Rightarrow> capability.UntypedCap d ref sz (g f) | _ \<Rightarrow> c'"

lemma freeIndex_update_not_untyped[simp]: "\<not>isUntypedCap c \<Longrightarrow> freeIndex_update c g = c"
   by (case_tac c,simp_all add:freeIndex_update_def isCap_simps)

locale mdb_insert =
  mdb_ptr_src?: mdb_ptr m _ _ src src_cap src_node +
  mdb_ptr_dest?: mdb_ptr m _ _ dest dest_cap dest_node
  for m src src_cap src_node dest dest_cap dest_node +

  fixes c' :: capability

  assumes dest_cap: "dest_cap = NullCap"
  assumes dest_prev: "mdbPrev dest_node = 0"
  assumes dest_next: "mdbNext dest_node = 0"

  assumes valid_badges: "valid_badges m"
  assumes ut_rev: "ut_revocable' m"

  fixes n

  defines "n \<equiv>
           modify_map
             (modify_map
               (modify_map m dest (cteCap_update (\<lambda>_. c')))
               dest
               (cteMDBNode_update
                 (\<lambda>m. mdbFirstBadged_update (\<lambda>a. isCapRevocable c' src_cap)
                     (mdbRevocable_update (\<lambda>a. isCapRevocable c' src_cap)
                     (mdbPrev_update (\<lambda>a. src) src_node)))))
             src
             (cteMDBNode_update (mdbNext_update (\<lambda>a. dest)))"

  assumes neq: "src \<noteq> dest"

locale mdb_insert_der = mdb_insert +
    assumes partial_is_derived': "is_derived' m src c' src_cap"


context mdb_insert
begin

lemmas src = mdb_ptr_src.m_p
lemmas dest = mdb_ptr_dest.m_p


lemma no_0_n [intro!]: "no_0 n" by (auto simp: n_def)
lemmas n_0_simps [iff] = no_0_simps [OF no_0_n]

lemmas neqs [simp] = neq neq [symmetric]

definition
  "new_dest \<equiv> CTE c' (mdbFirstBadged_update (\<lambda>a. isCapRevocable c' src_cap)
                     (mdbRevocable_update (\<lambda>a. isCapRevocable c' src_cap)
                     (mdbPrev_update (\<lambda>a. src) src_node)))"

definition
  "new_src \<equiv> CTE src_cap (mdbNext_update (\<lambda>a. dest) src_node)"

lemma n: "n = m (dest \<mapsto> new_dest, src \<mapsto> new_src)"
  using src dest
  by (simp add: n_def modify_map_apply new_dest_def new_src_def)

lemma dest_no_parent [iff]:
  "m \<turnstile> dest \<rightarrow> x = False" using dest dest_next
  by (auto dest: subtree_next_0)

lemma dest_no_child [iff]:
  "m \<turnstile> x \<rightarrow> dest = False" using dest dest_prev
  by (auto dest: subtree_prev_0)

lemma dest_no_descendants: "descendants_of' dest m = {}"
  by (simp add: descendants_of'_def)

lemma descendants_not_dest: "dest \<in> descendants_of' p m \<Longrightarrow> False"
  by (simp add: descendants_of'_def)

lemma src_next: "m \<turnstile> src \<leadsto> mdbNext src_node"
  by (simp add: src mdb_next_unfold)

lemma src_next_rtrancl_conv [simp]:
  "m \<turnstile> mdbNext src_node \<leadsto>\<^sup>* dest = m \<turnstile> src \<leadsto>\<^sup>+ dest"
  apply (rule iffI)
   apply (insert src_next)
   apply (erule (1) rtrancl_into_trancl2)
  apply (drule tranclD)
  apply (clarsimp simp: mdb_next_unfold)
  done

lemma dest_no_next [iff]:
  "m \<turnstile> x \<leadsto> dest = False" using dest dest_prev dlist
  apply clarsimp
  apply (simp add: mdb_next_unfold)
  apply (elim exE conjE)
  apply (case_tac z)
  apply simp
  apply (rule dlistEn [where p=x], assumption)
   apply clarsimp
  apply clarsimp
  done

lemma dest_no_next_trans [iff]:
  "m \<turnstile> x \<leadsto>\<^sup>+ dest = False"
  by (clarsimp dest!: tranclD2)

lemma dest_no_prev [iff]:
  "m \<turnstile> dest \<leadsto> p = (p = 0)" using dest dest_next
  by (simp add: mdb_next_unfold)

lemma dest_no_prev_trancl [iff]:
  "m \<turnstile> dest \<leadsto>\<^sup>+ p = (p = 0)"
  apply (rule iffI)
   apply (drule tranclD)
   apply (clarsimp simp: dest_next)
  apply simp
  apply (insert chain dest)
  apply (simp add: mdb_chain_0_def)
  apply auto
  done

lemma chain_n:
  "mdb_chain_0 n"
proof -
  from chain
  have "m \<turnstile> mdbNext src_node \<leadsto>\<^sup>* 0" using dlist src
    apply (cases "mdbNext src_node = 0")
     apply simp
    apply (erule dlistEn, simp)
    apply (auto simp: mdb_chain_0_def)
    done
  moreover
  have "\<not>m \<turnstile> mdbNext src_node \<leadsto>\<^sup>* src"
    using src_next
    apply clarsimp
    apply (drule (1) rtrancl_into_trancl2)
    apply simp
    done
  moreover
  have "\<not> m \<turnstile> 0 \<leadsto>\<^sup>* dest" using no_0 dest
    by (auto elim!: next_rtrancl_tranclE dest!: no_0_lhs_trancl)
  moreover
  have "\<not> m \<turnstile> 0 \<leadsto>\<^sup>* src" using no_0 src
    by (auto elim!: next_rtrancl_tranclE dest!: no_0_lhs_trancl)
  moreover
  note chain
  ultimately
  show "mdb_chain_0 n" using no_0 src dest
    apply (simp add: n new_src_def new_dest_def)
    apply (auto intro!: mdb_chain_0_update no_0_update simp: next_update_lhs_rtrancl)
    done
qed

lemma no_loops_n: "no_loops n" using chain_n no_0_n
  by (rule mdb_chain_0_no_loops)

lemma irrefl_trancl_simp [iff]:
  "n \<turnstile> x \<leadsto>\<^sup>+ x = False"
  using no_loops_n by (rule no_loops_trancl_simp)

lemma n_direct_eq:
  "n \<turnstile> p \<leadsto> p' = (if p = src then p' = dest else
                 if p = dest then m \<turnstile> src \<leadsto> p'
                 else m \<turnstile> p \<leadsto> p')"
  using src dest dest_prev
  by (auto simp: mdb_next_update n new_src_def new_dest_def
                 src_next mdb_next_unfold)

lemma n_dest:
  "n dest = Some new_dest"
  by (simp add: n)

end

lemma revokable_plus_orderD:
  "\<lbrakk> isCapRevocable new old; (capBadge old, capBadge new) \<in> capBadge_ordering P;
       capMasterCap old = capMasterCap new \<rbrakk>
      \<Longrightarrow> (isUntypedCap new \<or> (\<exists>x. capBadge old = Some 0 \<and> capBadge new = Some x \<and> x \<noteq> 0))"
  by (clarsimp simp: Retype_H.isCapRevocable_def AARCH64_H.isCapRevocable_def isCap_simps
                        AARCH64_H.arch_capability.simps
              split: if_split_asm capability.split_asm AARCH64_H.arch_capability.split_asm)

lemma valid_badges_def2:
  "valid_badges m =
  (\<forall>p p' cap node cap' node'.
   m p = Some (CTE cap node) \<longrightarrow>
   m p' = Some (CTE cap' node') \<longrightarrow>
   m \<turnstile> p \<leadsto> p' \<longrightarrow>
   capMasterCap cap = capMasterCap cap' \<longrightarrow>
   capBadge cap \<noteq> None \<longrightarrow>
   capBadge cap \<noteq> capBadge cap' \<longrightarrow>
   capBadge cap' \<noteq> Some 0 \<longrightarrow>
   mdbFirstBadged node')"
  apply (simp add: valid_badges_def)
  apply (intro arg_cong[where f=All] ext imp_cong [OF refl])
  apply (case_tac cap, simp_all add: isCap_simps cong: weak_imp_cong)
   apply (fastforce simp: sameRegionAs_def3 isCap_simps)+
  done

lemma sameRegionAs_update_untyped:
  "RetypeDecls_H.sameRegionAs (capability.UntypedCap d a b c) =
   RetypeDecls_H.sameRegionAs (capability.UntypedCap d a b c')"
  apply (rule ext)
  apply (case_tac x)
    apply (clarsimp simp:sameRegionAs_def isCap_simps)+
  done

lemma sameRegionAs_update_untyped':
  "RetypeDecls_H.sameRegionAs cap (capability.UntypedCap d a b f) =
   RetypeDecls_H.sameRegionAs cap (capability.UntypedCap d a b f')"
  apply (case_tac cap)
    apply (clarsimp simp:sameRegionAs_def isCap_simps)+
  done

(*The newly inserted cap should never have children.*)
lemma (in mdb_insert_der) dest_no_parent_n:
  "n \<turnstile> dest \<rightarrow> p = False"
  using src partial_is_derived' valid_badges ut_rev
  apply clarsimp
  apply (erule subtree.induct)
   prefer 2
   apply simp
  apply (clarsimp simp: parentOf_def mdb_next_unfold n_dest new_dest_def n)
  apply (cases "mdbNext src_node = dest")
   apply (subgoal_tac "m \<turnstile> src \<leadsto> dest")
    apply simp
   apply (subst mdb_next_unfold)
   apply (simp add: src)
  apply (case_tac "isUntypedCap src_cap")
  apply (clarsimp simp: isCap_simps isMDBParentOf_CTE is_derived'_def
                        badge_derived'_def freeIndex_update_def capMasterCap_def
                 split: capability.splits)
   apply (simp add: ut_revocable'_def)
   apply (drule spec[where x=src], simp add: isCap_simps)
   apply (simp add: descendants_of'_def)
   apply (drule spec[where x="mdbNext src_node"])
   apply (erule notE, rule direct_parent)
     apply (simp add: mdb_next_unfold)
    apply simp
   apply (simp add: parentOf_def src isMDBParentOf_CTE isCap_simps
              cong: sameRegionAs_update_untyped)
  apply (clarsimp simp: isMDBParentOf_CTE is_derived'_def badge_derived'_def)
  apply (drule(2) revokable_plus_orderD)
  apply (erule sameRegionAsE, simp_all)
     apply (simp add: valid_badges_def2)
     apply (erule_tac x=src in allE)
     apply (erule_tac x="mdbNext src_node" in allE)
     apply (clarsimp simp: src mdb_next_unfold)
     apply (case_tac "capBadge cap'", simp_all)
    apply (clarsimp simp add: isCap_simps capMasterCap_def
                    simp del: not_ex
                       split: capability.splits)
   apply (clarsimp simp: isCap_simps)+
  done

locale mdb_insert_child = mdb_insert_der +
  assumes child:
  "isMDBParentOf
   (CTE src_cap src_node)
   (CTE c' (mdbFirstBadged_update (\<lambda>a. isCapRevocable c' src_cap)
           (mdbRevocable_update (\<lambda>a. isCapRevocable c' src_cap)
           (mdbPrev_update (\<lambda>a. src) src_node))))"

context mdb_insert_child
begin

lemma new_child [simp]:
  "isMDBParentOf new_src new_dest"
  by (simp add: new_src_def new_dest_def) (rule child)

lemma n_dest_child:
  "n \<turnstile> src \<rightarrow> dest"
  apply (rule subtree.direct_parent)
    apply (simp add: n_direct_eq)
   apply simp
  apply (clarsimp simp: parentOf_def src dest n)
  done

lemma parent_m_n:
  assumes "m \<turnstile> p \<rightarrow> p'"
  shows "if p' = src then n \<turnstile> p \<rightarrow> dest \<and> n \<turnstile> p \<rightarrow> p' else n \<turnstile> p \<rightarrow> p'" using assms
proof induct
  case (direct_parent c)
  thus ?case
    apply (cases "p = src")
     apply simp
     apply (rule conjI, clarsimp)
     apply clarsimp
     apply (rule subtree.trans_parent [where c'=dest])
        apply (rule n_dest_child)
       apply (simp add: n_direct_eq)
      apply simp
     apply (clarsimp simp: parentOf_def n)
     apply (clarsimp simp: new_src_def src)
    apply simp
    apply (subgoal_tac "n \<turnstile> p \<rightarrow> c")
     prefer 2
     apply (rule subtree.direct_parent)
       apply (clarsimp simp add: n_direct_eq)
      apply simp
     apply (clarsimp simp: parentOf_def n)
     apply (fastforce simp: new_src_def src)
    apply clarsimp
    apply (erule subtree_trans)
    apply (rule n_dest_child)
    done
next
  case (trans_parent c d)
  thus ?case
    apply -
    apply (cases "c = dest", simp)
    apply (cases "d = dest", simp)
    apply (cases "c = src")
     apply clarsimp
     apply (erule subtree.trans_parent [where c'=dest])
       apply (clarsimp simp add: n_direct_eq)
      apply simp
     apply (clarsimp simp: parentOf_def n)
     apply (rule conjI, clarsimp)
     apply (clarsimp simp: new_src_def src)
    apply clarsimp
    apply (subgoal_tac "n \<turnstile> p \<rightarrow> d")
     apply clarsimp
     apply (erule subtree_trans, rule n_dest_child)
    apply (erule subtree.trans_parent)
      apply (simp add: n_direct_eq)
     apply simp
    apply (clarsimp simp: parentOf_def n)
    apply (fastforce simp: src new_src_def)
    done
qed

lemma n_to_dest [simp]:
  "n \<turnstile> p \<leadsto> dest = (p = src)"
  by (simp add: n_direct_eq)

lemma parent_n_m:
  assumes "n \<turnstile> p \<rightarrow> p'"
  shows "if p' = dest then p \<noteq> src \<longrightarrow> m \<turnstile> p \<rightarrow> src else m \<turnstile> p \<rightarrow> p'"
proof -
  from assms have [simp]: "p \<noteq> dest" by (clarsimp simp: dest_no_parent_n)
  from assms
  show ?thesis
  proof induct
    case (direct_parent c)
    thus ?case
      apply simp
      apply (rule conjI)
       apply clarsimp
      apply clarsimp
      apply (rule subtree.direct_parent)
        apply (simp add: n_direct_eq split: if_split_asm)
       apply simp
      apply (clarsimp simp: parentOf_def n src new_src_def split: if_split_asm)
      done
  next
    case (trans_parent c d)
    thus ?case
      apply clarsimp
      apply (rule conjI, clarsimp)
      apply (clarsimp split: if_split_asm)
      apply (simp add: n_direct_eq)
      apply (cases "p=src")
       apply simp
       apply (rule subtree.direct_parent, assumption, assumption)
       apply (clarsimp simp: parentOf_def n src new_src_def split: if_split_asm)
      apply clarsimp
      apply (erule subtree.trans_parent, assumption, assumption)
      apply (clarsimp simp: parentOf_def n src new_src_def split: if_split_asm)
     apply (erule subtree.trans_parent)
       apply (simp add: n_direct_eq split: if_split_asm)
      apply assumption
     apply (clarsimp simp: parentOf_def n src new_src_def split: if_split_asm)
     done
 qed
qed

lemma descendants:
  "descendants_of' p n =
   (if src \<in> descendants_of' p m \<or> p = src
   then descendants_of' p m \<union> {dest} else descendants_of' p m)"
  apply (rule set_eqI)
  apply (simp add: descendants_of'_def)
  apply (fastforce dest!: parent_n_m dest: parent_m_n simp: n_dest_child split: if_split_asm)
  done

end

locale mdb_insert_sib = mdb_insert_der +
  assumes no_child:
  "\<not>isMDBParentOf
   (CTE src_cap src_node)
   (CTE c' (mdbFirstBadged_update (\<lambda>a. isCapRevocable c' src_cap)
           (mdbRevocable_update (\<lambda>a. isCapRevocable c' src_cap)
           (mdbPrev_update (\<lambda>a. src) src_node))))"
begin
interpretation Arch . (*FIXME: arch_split*)

(* If dest is inserted as sibling, src can not have had children.
   If it had had children, then dest_node which is just a derived copy
   of src_node would be a child as well. *)
lemma src_no_mdb_parent:
  "isMDBParentOf (CTE src_cap src_node) cte = False"
  using no_child partial_is_derived'
  apply clarsimp
  apply (case_tac cte)
  apply (clarsimp simp: isMDBParentOf_CTE is_derived'_def badge_derived'_def)
  apply (erule sameRegionAsE)
     apply (clarsimp simp add: sameRegionAs_def3)
     subgoal by (cases src_cap; auto simp: capMasterCap_def Retype_H.isCapRevocable_def AARCH64_H.isCapRevocable_def
                                           freeIndex_update_def isCap_simps
                                       split: capability.split_asm arch_capability.split_asm) (* long *)
    apply (clarsimp simp: isCap_simps sameRegionAs_def3 capMasterCap_def freeIndex_update_def
       split:capability.splits arch_capability.splits)
   apply (clarsimp simp: isCap_simps sameRegionAs_def3 freeIndex_update_def
                         capRange_def split:capability.splits
               simp del: Int_atLeastAtMost atLeastAtMost_iff)
   apply auto[1]
  apply (clarsimp simp: isCap_simps sameRegionAs_def3)+
  done

lemma src_no_parent:
  "m \<turnstile> src \<rightarrow> p = False"
  by (clarsimp dest!: subtree_parent simp: src_no_mdb_parent parentOf_def src)

lemma parent_preserved:
  "isMDBParentOf cte (CTE src_cap src_node) \<Longrightarrow> isMDBParentOf cte new_dest"
  using partial_is_derived'
  apply (cases cte)
  apply (case_tac "isUntypedCap src_cap")
   apply (clarsimp simp:isCap_simps isMDBParentOf_CTE freeIndex_update_def new_dest_def)
   apply (clarsimp simp:is_derived'_def isCap_simps badge_derived'_def capMasterCap_def split:capability.splits)
   apply (clarsimp simp:sameRegionAs_def2 capMasterCap_def isCap_simps split:capability.splits)
  apply (clarsimp simp: isMDBParentOf_CTE)
  apply (clarsimp simp: new_dest_def)
  apply (rename_tac cap node)
  apply (clarsimp simp: is_derived'_def badge_derived'_def)
  apply (rule conjI)
   apply (simp add: sameRegionAs_def2)
  apply (cases "isCapRevocable c' src_cap")
   apply simp
   apply (drule(2) revokable_plus_orderD)
   apply (erule disjE)
     apply (clarsimp simp: isCap_simps)
     by ((fastforce elim: capBadge_ordering_trans simp: isCap_simps)+)

lemma src_no_parent_n [simp]:
  "n \<turnstile> src \<rightarrow> p = False"
  apply clarsimp
  apply (erule subtree.induct)
   apply (simp add: n_direct_eq)
   apply (clarsimp simp: parentOf_def n src dest new_src_def
                         new_dest_def no_child)
  apply simp
  done

lemma parent_n:
  "n \<turnstile> p \<rightarrow> p' \<Longrightarrow> if p' = dest then m \<turnstile> p \<rightarrow> src else m \<turnstile> p \<rightarrow> p'"
  apply (cases "p=dest", simp add: dest_no_parent_n)
  apply (cases "p=src", simp)
  apply (erule subtree.induct)
   apply simp
   apply (rule conjI)
    apply (clarsimp simp: n_direct_eq)
   apply clarsimp
   apply (rule direct_parent)
     apply (simp add: n_direct_eq)
    apply assumption
   apply (clarsimp simp: parentOf_def n src new_src_def split: if_split_asm)
  apply simp
  apply (rule conjI)
   apply (clarsimp simp: n_direct_eq split: if_split_asm)
  apply (clarsimp simp: n_direct_eq split: if_split_asm)
   apply (erule trans_parent, assumption, assumption)
   apply (clarsimp simp: parentOf_def n src new_src_def split: if_split_asm)
  apply (erule trans_parent, assumption, assumption)
  apply (clarsimp simp: parentOf_def n src new_src_def split: if_split_asm)
  done

lemma parent_m:
  "m \<turnstile> p \<rightarrow> p' \<Longrightarrow> n \<turnstile> p \<rightarrow> p' \<and> (p' = src \<longrightarrow> n \<turnstile> p \<rightarrow> dest)"
  apply (cases "p=src", simp add: src_no_parent)
  apply (erule subtree.induct)
   apply (rule conjI)
    apply (rule direct_parent)
      apply (clarsimp simp: n_direct_eq)
     apply assumption
    apply (fastforce simp add: parentOf_def n src new_src_def)
   apply clarsimp
   apply (rule trans_parent [where c'=src])
      apply (rule direct_parent)
        apply (simp add: n_direct_eq)
        apply (rule notI, simp)
       apply simp
      apply (simp add: parentOf_def n src new_src_def)
      apply (clarsimp simp: dest dest_cap)
     apply (simp add: n_direct_eq)
    apply simp
   apply (clarsimp simp: parentOf_def dest src n)
   apply (rule conjI, clarsimp simp: dest dest_cap)
   apply (clarsimp intro!: parent_preserved)
  apply clarsimp
  apply (case_tac "c'=src")
   apply simp
   apply (erule trans_parent [where c'=dest])
     apply (clarsimp simp: n_direct_eq)
    apply clarsimp
   apply (fastforce simp: parentOf_def dest src n)
  apply clarsimp
  apply (rule conjI)
   apply (erule trans_parent)
     apply (simp add: n_direct_eq)
     apply clarsimp
    apply assumption
   apply (fastforce simp: parentOf_def dest src n new_src_def)
  apply clarsimp
  apply (rule trans_parent [where c'=src])
     apply (erule trans_parent)
       apply (simp add: n_direct_eq)
       apply clarsimp
      apply simp
     apply (fastforce simp: parentOf_def dest src n new_src_def)
    apply (simp add: n_direct_eq)
   apply simp
  apply (fastforce simp: parentOf_def dest src n new_src_def
                  intro!: parent_preserved)
  done

lemma parent_n_eq:
  "n \<turnstile> p \<rightarrow> p' = (if p' = dest then m \<turnstile> p \<rightarrow> src else m \<turnstile> p \<rightarrow> p')"
  apply (rule iffI)
   apply (erule parent_n)
  apply (simp split: if_split_asm)
   apply (drule parent_m, simp)
  apply (drule parent_m, clarsimp)
  done

lemma descendants:
  "descendants_of' p n =
   descendants_of' p m \<union> (if src \<in> descendants_of' p m then {dest} else {})"
  by (rule set_eqI) (simp add: descendants_of'_def parent_n_eq)

end
context begin interpretation Arch . (*FIXME: arch_split*)
lemma mdb_None:
  assumes F: "\<And>p'. cte_map p \<in> descendants_of' p' m' \<Longrightarrow> False"
  assumes R: "cdt_relation (swp cte_at s) (cdt s) m'"
  assumes "valid_mdb s"
  shows "cdt s p = None"
  apply (simp add: descendants_of_None [symmetric])
  apply clarsimp
  apply (frule descendants_of_cte_at2, rule assms)
  apply (insert R)
  apply (simp add: cdt_relation_def)
  apply (erule allE, erule allE, erule (1) impE)
  apply (rule_tac p'="cte_map (a,b)" in F)
  apply (drule sym)
  apply simp
  done

declare if_split [split del]

lemma derived_sameRegionAs:
  "\<lbrakk> is_derived' m p cap' cap; s \<turnstile>' cap' \<rbrakk>
       \<Longrightarrow> sameRegionAs cap cap'"
  unfolding is_derived'_def badge_derived'_def
  apply (simp add: sameRegionAs_def3)
  apply (cases "isUntypedCap cap \<or> isArchFrameCap cap")
   apply (rule disjI2, rule disjI1)
   apply (erule disjE)
    apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def
                          is_aligned_no_overflow capRange_def
                   split: capability.splits arch_capability.splits option.splits)
   apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def
                         is_aligned_no_overflow capRange_def
                  split: capability.splits arch_capability.splits option.splits)
  apply (clarsimp simp: isCap_simps valid_cap'_def
                        is_aligned_no_overflow capRange_def vs_cap_ref_arch'_def
                 split: capability.splits arch_capability.splits option.splits)
  done

lemma no_fail_updateMDB [wp]:
  "no_fail (\<lambda>s. p \<noteq> 0 \<longrightarrow> cte_at' p s) (updateMDB p f)"
  apply (simp add: updateMDB_def)
  apply (rule no_fail_pre, wp)
  apply (simp split: if_split)
  done

lemma updateMDB_cte_at' [wp]:
 "\<lbrace>cte_at' p\<rbrace>
  updateMDB x y
  \<lbrace>\<lambda>_. cte_at' p\<rbrace>"
  by (wpsimp wp: updateMDB_weak_cte_wp_at)

lemma updateCap_cte_at' [wp]:
 "\<lbrace>cte_at' p\<rbrace> updateCap c p' \<lbrace>\<lambda>_. cte_at' p\<rbrace>"
  unfolding updateCap_def by wp

lemma nullMDBNode_pointers[simp]:
  "mdbPrev nullMDBNode = nullPointer"
  "mdbNext nullMDBNode = nullPointer"
  by (simp add: nullMDBNode_def)+

lemma maxFreeIndex_eq[simp]: "maxFreeIndex nat1 = max_free_index nat1"
  by (clarsimp simp:maxFreeIndex_def max_free_index_def shiftL_nat)

definition maskedAsFull :: "capability \<Rightarrow> capability \<Rightarrow> capability"
where "maskedAsFull srcCap newCap \<equiv>
  if isUntypedCap srcCap \<and> isUntypedCap newCap \<and>
     capPtr srcCap = capPtr newCap \<and> capBlockSize srcCap = capBlockSize newCap
  then capFreeIndex_update (\<lambda>_. maxFreeIndex (capBlockSize srcCap)) srcCap
  else srcCap"

lemma is_derived_maskedAsFull[simp]:
  "is_derived' m slot c (maskedAsFull src_cap' a) =
   is_derived' m slot c src_cap'"
  apply (clarsimp simp: maskedAsFull_def isCap_simps split:if_splits)
  apply (case_tac c)
             apply (clarsimp simp:is_derived'_def isCap_simps badge_derived'_def)+
  done


lemma maskedAsFull_revokable:
  "is_derived' x y c' src_cap' \<Longrightarrow>
   isCapRevocable c' (maskedAsFull src_cap' a) = isCapRevocable c' src_cap'"
  apply (case_tac src_cap')
             apply (simp_all add:maskedAsFull_def isCap_simps)
  apply (case_tac c')
             apply (simp_all add:maskedAsFull_def is_derived'_def isCap_simps)
          apply (simp_all add:badge_derived'_def capMasterCap_simps split:arch_capability.splits)
   apply (clarsimp split:if_splits simp:Retype_H.isCapRevocable_def AARCH64_H.isCapRevocable_def isCap_simps)+
  done

lemma parentOf_preserve_oneway:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
    sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
  isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte')
  \<and> isNotificationCap (cteCap cte)  = isNotificationCap (cteCap cte')
  \<and> (isNotificationCap (cteCap cte) \<longrightarrow> (capNtfnBadge (cteCap cte) = capNtfnBadge (cteCap cte')))
  \<and> (isEndpointCap (cteCap cte) = isEndpointCap (cteCap cte'))
  \<and> (isEndpointCap (cteCap cte) \<longrightarrow> (capEPBadge (cteCap cte) = capEPBadge (cteCap cte')))
  \<and> cteMDBNode cte = cteMDBNode cte'"
  assumes node:"\<And>p. mdb_next m p = mdb_next m' p"
  shows "(m  \<turnstile> p parentOf x) \<Longrightarrow> (m'  \<turnstile> p parentOf x)"
  apply (clarsimp simp:parentOf_def)
    apply (frule iffD1[OF dom,OF domI])
    apply (frule iffD1[OF dom[where x = p],OF domI])
    apply clarsimp
    apply (frule_tac x1 = p in conjunct1[OF sameRegion])
      apply assumption
    apply (frule_tac x1 = x in conjunct2[OF sameRegion])
      apply assumption
    apply (drule_tac x = "cteCap y" in fun_cong)
    apply (drule_tac x = "cteCap cte'" in fun_cong)
    apply (drule_tac x = p in misc)
      apply assumption
    apply (drule_tac x = x in misc)
      apply assumption
    apply ((simp only: isMDBParentOf_def split_def split: cte.splits if_split_asm); clarsimp)
    by (clarsimp simp: sameRegionAs_def isCap_simps Let_def split: if_split_asm)+ (* long *)

lemma parentOf_preserve:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
    sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
  isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte')
  \<and> isNotificationCap (cteCap cte)  = isNotificationCap (cteCap cte')
  \<and> (isNotificationCap (cteCap cte) \<longrightarrow> (capNtfnBadge (cteCap cte) = capNtfnBadge (cteCap cte')))
  \<and> (isEndpointCap (cteCap cte) = isEndpointCap (cteCap cte'))
  \<and> (isEndpointCap (cteCap cte) \<longrightarrow> (capEPBadge (cteCap cte) = capEPBadge (cteCap cte')))
  \<and> cteMDBNode cte = cteMDBNode cte'"
  assumes node:"\<And>p. mdb_next m p = mdb_next m' p"
  shows "(m  \<turnstile> p parentOf x) = (m'  \<turnstile> p parentOf x)"
  apply (rule iffI)
    apply (rule parentOf_preserve_oneway[OF dom sameRegion misc node])
      apply (assumption)+
  apply (rule parentOf_preserve_oneway)
  apply (auto simp:dom sameRegion misc node)
done

lemma updateUntypedCap_descendants_of:
  "\<lbrakk>m src = Some cte; isUntypedCap (cteCap cte)\<rbrakk>
   \<Longrightarrow> descendants_of' slot (m(src \<mapsto> cteCap_update
           (\<lambda>_. (capFreeIndex_update (\<lambda>_. idx) (cteCap cte))) cte)) =
       descendants_of' slot m"
  apply (rule set_eqI)

  apply (clarsimp simp:descendants_of'_def subtree_def)
   apply (rule_tac x = x in fun_cong)
   apply (rule_tac f = lfp in arg_cong)
   apply (rule ext)+
  apply (cut_tac x  = xa in parentOf_preserve
  [where m = "m(src \<mapsto> cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. idx) (cteCap cte)) cte)"
   and  m' = m and p = slot])
    apply (clarsimp,rule iffI,fastforce+)
    apply (clarsimp simp:isCap_simps split:if_splits)
    apply (clarsimp simp:sameRegionAs_def isCap_simps split:if_splits)
    apply (rule ext)
    apply (clarsimp simp:sameRegionAs_def isCap_simps split:if_splits)+
   apply (simp add:mdb_next_def split:if_splits)
  apply (simp del:fun_upd_apply)
  apply (subgoal_tac "\<And>p. m(src \<mapsto> cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. idx) (cteCap cte)) cte) \<turnstile> p \<leadsto> xa
     = m \<turnstile> p \<leadsto> xa")
  apply simp
  apply (clarsimp simp:mdb_next_rel_def mdb_next_def split:if_splits)
  done

lemma setCTE_UntypedCap_corres:
  "\<lbrakk>cap_relation cap (cteCap cte); is_untyped_cap cap; idx' = idx\<rbrakk>
   \<Longrightarrow> corres dc (cte_wp_at ((=) cap) src and valid_objs and
                  pspace_aligned and pspace_distinct)
                 (cte_wp_at' ((=) cte) (cte_map src) and
                  pspace_distinct' and pspace_aligned')
                 (set_cap (free_index_update (\<lambda>_. idx) cap) src)
                 (setCTE (cte_map src) (cteCap_update
                    (\<lambda>cap. (capFreeIndex_update (\<lambda>_. idx') (cteCap cte))) cte))"
  apply (case_tac cte)
  apply (clarsimp simp:is_cap_simps)
  apply (rule corres_stronger_no_failI)
   apply (rule no_fail_pre, wp)
   apply (clarsimp simp: cte_wp_at_ctes_of)
  apply clarsimp
  apply (clarsimp simp add: state_relation_def split_def)
  apply (drule (1) pspace_relationsD)
  apply (frule_tac c = "cap.UntypedCap dev r bits idx"
                in set_cap_not_quite_corres_prequel)
         apply assumption+
       apply (erule cte_wp_at_weakenE, rule TrueI)
      apply assumption+
    apply simp+
  apply clarsimp
  apply (rule bexI)
   prefer 2
   apply assumption
  apply (clarsimp simp: pspace_relations_def)
  apply (subst conj_assoc[symmetric])
  apply (rule conjI)
   apply (frule setCTE_pspace_only)
   apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def
                    split: if_split_asm Structures_A.kernel_object.splits)
  apply (rule conjI)
   apply (frule setCTE_pspace_only)
   apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def)
  apply (rule conjI)
   prefer 2
   apply (rule conjI)
    apply (frule mdb_set_cap, frule exst_set_cap)
    apply (erule use_valid [OF _ setCTE_ctes_of_wp])
    apply (clarsimp simp: cdt_list_relation_def cte_wp_at_ctes_of split: if_split_asm)
   apply (rule conjI)
    prefer 2
    apply (frule setCTE_pspace_only)
    apply clarsimp
    apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def
                    split: if_split_asm Structures_A.kernel_object.splits)
   apply (frule set_cap_caps_of_state_monad)
   apply (drule is_original_cap_set_cap)
   apply clarsimp
   apply (erule use_valid [OF _ setCTE_ctes_of_wp])
   apply (clarsimp simp: revokable_relation_def simp del: fun_upd_apply)
   apply (clarsimp split: if_split_asm)
    apply (frule cte_map_inj_eq)
         prefer 2
         apply (erule cte_wp_at_weakenE, rule TrueI)
        apply (simp add: null_filter_def split: if_split_asm)
         apply (erule cte_wp_at_weakenE, rule TrueI)
        apply (erule caps_of_state_cte_at)
       apply fastforce
      apply fastforce
     apply fastforce
    apply clarsimp
    apply (simp add: null_filter_def split: if_split_asm)
    apply (erule_tac x=aa in allE, erule_tac x=bb in allE)
    apply (case_tac cte)
    apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps isCap_simps cte_wp_at_ctes_of)
   apply (simp add: null_filter_def cte_wp_at_caps_of_state split: if_split_asm)
   apply (erule_tac x=aa in allE, erule_tac x=bb in allE)
   apply (clarsimp)
  apply (clarsimp simp: cdt_relation_def)
  apply (frule set_cap_caps_of_state_monad)
  apply (frule mdb_set_cap)
  apply clarsimp
  apply (erule use_valid [OF _ setCTE_ctes_of_wp])
  apply (frule cte_wp_at_norm)
  apply (clarsimp simp:cte_wp_at_ctes_of simp del: fun_upd_apply)
  apply (drule_tac slot = "cte_map (aa,bb)" in updateUntypedCap_descendants_of)
   apply (clarsimp simp:isCap_simps)
  apply (drule_tac x = aa in spec)
  apply (drule_tac x = bb in spec)
  apply (erule impE)
   apply (clarsimp simp: cte_wp_at_caps_of_state split:if_splits)
  apply auto
  done

lemma getCTE_get:
  "\<lbrace>cte_wp_at' P src\<rbrace> getCTE src \<lbrace>\<lambda>rv s. P rv\<rbrace>"
  apply (wp getCTE_wp)
  apply (clarsimp simp:cte_wp_at_ctes_of)
  done

lemma setUntypedCapAsFull_corres:
  "\<lbrakk>cap_relation c c'; cap_relation src_cap (cteCap srcCTE)\<rbrakk>
   \<Longrightarrow> corres dc (cte_wp_at ((=) src_cap) src and valid_objs and
                  pspace_aligned and pspace_distinct)
                 (cte_wp_at' ((=) srcCTE) (cte_map src) and
                  pspace_aligned' and pspace_distinct')
                 (set_untyped_cap_as_full src_cap c src)
                 (setUntypedCapAsFull (cteCap srcCTE) c' (cte_map src))"
  apply (clarsimp simp:set_untyped_cap_as_full_def setUntypedCapAsFull_def
    split:if_splits)
  apply (intro conjI impI)
    apply (clarsimp simp del:capFreeIndex_update.simps simp:updateCap_def)
      apply (rule corres_guard_imp)
        apply (rule corres_symb_exec_r)
           apply (rule_tac F="cte = srcCTE" in corres_gen_asm2)
           apply (simp)
           apply (rule setCTE_UntypedCap_corres)
             apply simp+
           apply (clarsimp simp:free_index_update_def isCap_simps is_cap_simps)
           apply (subst identity_eq)
        apply (wp getCTE_sp getCTE_get)+
       apply (clarsimp simp:cte_wp_at_ctes_of)+
   apply (clarsimp simp:is_cap_simps isCap_simps)+
  apply (case_tac c,simp_all)
  apply (case_tac src_cap,simp_all)
  done

(* FIXME: SELFOUR-421 move *)
lemma isUntypedCap_simps[simp]:
  "isUntypedCap (capability.UntypedCap uu uv uw ux) = True"
  "isUntypedCap (capability.NullCap) = False"
  "isUntypedCap (capability.EndpointCap v va vb vc vd ve) = False"
  "isUntypedCap (capability.NotificationCap v va vb vc) = False"
  "isUntypedCap (capability.ReplyCap v1 v2 v3) = False"
  "isUntypedCap (capability.CNodeCap x1 x2 x3 x4) = False"
  "isUntypedCap (capability.ThreadCap v) = False"
  "isUntypedCap (capability.DomainCap) = False"
  "isUntypedCap (capability.IRQControlCap) = False"
  "isUntypedCap (capability.IRQHandlerCap y1) = False"
  "isUntypedCap (capability.Zombie v va1 vb1) = False"
  "isUntypedCap (capability.ArchObjectCap z) = False"
  by (simp_all add: isUntypedCap_def split: capability.splits)

lemma cap_relation_masked_as_full:
  "\<lbrakk>cap_relation src_cap src_cap';cap_relation c c'\<rbrakk> \<Longrightarrow>
    cap_relation (masked_as_full src_cap c) (maskedAsFull src_cap' c')"
  apply (clarsimp simp: masked_as_full_def maskedAsFull_def
                 split: if_splits)
  apply (case_tac src_cap; clarsimp)
  by (case_tac c; clarsimp)

lemma setUntypedCapAsFull_pspace_distinct[wp]:
  "\<lbrace>pspace_distinct' and cte_wp_at' ((=) srcCTE) slot\<rbrace>
   setUntypedCapAsFull (cteCap srcCTE) c slot \<lbrace>\<lambda>r. pspace_distinct'\<rbrace>"
  apply (clarsimp simp: setUntypedCapAsFull_def split:if_splits)
  apply (intro conjI impI)
    apply (clarsimp simp:valid_def)
    apply (drule updateCap_stuff)
    apply simp
  apply (wp|clarsimp)+
done

lemma setUntypedCapAsFull_pspace_aligned[wp]:
  "\<lbrace>pspace_aligned' and cte_wp_at' ((=) srcCTE) slot\<rbrace>
   setUntypedCapAsFull (cteCap srcCTE) c slot
   \<lbrace>\<lambda>r. pspace_aligned'\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits)
  apply (intro conjI impI)
    apply (clarsimp simp:valid_def)
    apply (drule updateCap_stuff)
    apply simp
  apply (wp|clarsimp)+
done

(* wp rules about setFreeIndex and setUntypedCapAsFull *)
lemma setUntypedCapAsFull_ctes_of:
  "\<lbrace>\<lambda>s. src \<noteq> dest \<and> P (ctes_of s dest) \<or>
        src = dest \<and> P (Some (CTE (maskedAsFull (cteCap srcCTE) cap)
                                  (cteMDBNode srcCTE))) \<and>
        cte_wp_at' ((=) srcCTE) src s\<rbrace>
  setUntypedCapAsFull (cteCap srcCTE) cap src
  \<lbrace>\<lambda>r s. P (ctes_of s dest)\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits)
  apply (intro conjI impI)
    apply (simp add:updateCap_def)
    apply (wp getCTE_wp)
    apply (clarsimp split:if_splits simp:cte_wp_at_ctes_of if_distrib)
    apply (case_tac "src = dest")
      apply (case_tac srcCTE)
      apply (clarsimp simp:maskedAsFull_def)
    apply clarsimp
  apply wp
  apply (case_tac srcCTE)
  apply (fastforce simp:maskedAsFull_def cte_wp_at_ctes_of split: if_splits)
  done

lemma setUntypedCapAsFull_ctes_of_no_0:
  "\<lbrace>\<lambda>s. no_0 ((ctes_of s)(a:=b)) \<and> cte_wp_at' ((=) srcCTE) src s\<rbrace>
   setUntypedCapAsFull (cteCap srcCTE) cap src
   \<lbrace>\<lambda>r s. no_0 ((ctes_of s)(a:=b)) \<rbrace>"
  apply (clarsimp simp:no_0_def split:if_splits)
  apply (wp hoare_vcg_imp_lift setUntypedCapAsFull_ctes_of[where dest = 0])
    apply (auto simp:cte_wp_at_ctes_of)
  done

lemma valid_dlist_preserve_oneway:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'"
  shows  "valid_dlist m \<Longrightarrow> valid_dlist m'"
  apply (clarsimp simp:valid_dlist_def Let_def)
  apply (frule domI[where m = m'],drule iffD2[OF dom],erule domE)
    apply (elim allE impE)
    apply assumption
  apply (intro conjI impI)
    apply clarsimp
    apply (frule(1) misc)
    apply (clarsimp)
    apply (frule_tac b = cte' in domI[where m = m])
    apply (drule iffD1[OF dom])
    apply clarsimp
    apply (drule(1) misc)+
    apply simp
  apply clarsimp
  apply (frule(1) misc)
  apply (clarsimp)
  apply (frule_tac b = cte' in domI[where m = m])
  apply (drule iffD1[OF dom])
  apply clarsimp
  apply (drule(1) misc)+
  apply simp
done

lemma valid_dlist_preserve:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'"
  shows  "valid_dlist m = valid_dlist m'"
  apply (rule iffI)
   apply (rule valid_dlist_preserve_oneway[OF dom misc])
     apply simp+
  apply (rule valid_dlist_preserve_oneway)
    apply (simp add:dom misc)+
done

lemma ut_revocable_preserve_oneway:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'
  \<and> isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte')"
  shows  "ut_revocable' m \<Longrightarrow> ut_revocable' m'"
  apply (clarsimp simp:ut_revocable'_def Let_def)
  apply (drule_tac x = p in spec)
  apply (frule domI[where m = m'],drule iffD2[OF dom],erule domE)
    apply (case_tac r)
    apply clarsimp
    apply (elim allE impE)
    apply (frule(1) misc)
    apply (clarsimp)
    apply (drule(1) misc)+
    apply simp
done

lemma ut_revocable_preserve:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'
  \<and> isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte')"
  shows  "ut_revocable' m = ut_revocable' m'"
  apply (rule iffI)
    apply (rule ut_revocable_preserve_oneway[OF dom misc])
    apply (assumption)+
  apply (rule ut_revocable_preserve_oneway[OF dom[symmetric]])
  apply (simp add:misc)+
done

lemma class_links_preserve_oneway:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> capClass (cteCap cte) = capClass (cteCap cte')"
  assumes node:"\<And>p. mdb_next m p = mdb_next m' p"
  shows  "class_links m \<Longrightarrow> class_links m'"
  apply (clarsimp simp:class_links_def Let_def)
  apply (drule_tac x = p in spec)
  apply (drule_tac x = p' in spec)
  apply (frule domI[where m = m'],drule iffD2[OF dom],erule domE)
    apply (case_tac r)
    apply clarsimp
    apply (frule_tac b = cte' in domI[where m = m'],drule iffD2[OF dom],erule domE)
    apply (elim allE impE)
      apply simp
    apply (frule(1) misc)
    apply (clarsimp simp:mdb_next_rel_def node)
  apply (drule(1) misc)+
    apply simp
done

lemma class_links_preserve:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> capClass (cteCap cte) = capClass (cteCap cte')"
  assumes node:"\<And>p. mdb_next m p = mdb_next m' p"
  shows  "class_links m = class_links m'"
  apply (rule iffI)
    apply (rule class_links_preserve_oneway[OF dom misc])
    apply (simp add:node)+
  apply (rule class_links_preserve_oneway)
  apply (simp add:dom misc node)+
done

lemma distinct_zombies_preserve_oneway:
  assumes dom: "\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:
  "\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
      isZombie (cteCap cte) = isZombie (cteCap cte') \<and>
      isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte') \<and>
      isArchFrameCap (cteCap cte) = isArchFrameCap (cteCap cte') \<and>
      capBits (cteCap cte) = capBits (cteCap cte') \<and>
      capUntypedPtr (cteCap cte) = capUntypedPtr (cteCap cte') \<and>
      capClass (cteCap cte) = capClass (cteCap cte')"
  assumes node: "\<And>p. mdb_next m p = mdb_next m' p"
  shows  "distinct_zombies m \<Longrightarrow> distinct_zombies m'"
  apply (clarsimp simp:distinct_zombies_def distinct_zombie_caps_def Let_def)
  apply (drule_tac x = ptr in spec)
  apply (drule_tac x = ptr' in spec)
  apply (frule domI[where m = m'],drule iffD2[OF dom],erule domE)
    apply (case_tac r)
    apply clarsimp
    apply (frule_tac a=ptr' in domI[where m = m'],drule iffD2[OF dom],erule domE)
    apply clarsimp
    apply (drule(1) misc)+
    apply clarsimp
  done

lemma distinct_zombies_preserve:
  assumes dom: "\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:
  "\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
      isZombie (cteCap cte) = isZombie (cteCap cte') \<and>
      isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte') \<and>
      isArchFrameCap (cteCap cte) = isArchFrameCap (cteCap cte') \<and>
      capBits (cteCap cte) = capBits (cteCap cte') \<and>
      capUntypedPtr (cteCap cte) = capUntypedPtr (cteCap cte') \<and>
      capClass (cteCap cte) = capClass (cteCap cte')"
  assumes node: "\<And>p. mdb_next m p = mdb_next m' p"
  shows  "distinct_zombies m = distinct_zombies m'"
  apply (rule iffI)
    apply (rule distinct_zombies_preserve_oneway[OF dom misc node])
     apply (assumption)+
  apply (rule distinct_zombies_preserve_oneway)
    apply (simp add:dom misc node)+
  done

lemma caps_contained'_preserve_oneway:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
  isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte')
  \<and> untypedRange (cteCap cte) = untypedRange (cteCap cte')
  \<and> capRange (cteCap cte) = capRange (cteCap cte')
  \<and> cteMDBNode cte = cteMDBNode cte'"
  shows "caps_contained' m \<Longrightarrow> caps_contained' m'"
  apply (clarsimp simp:caps_contained'_def)
    apply (frule iffD2[OF dom,OF domI])
    apply (frule_tac x1 = p' in iffD2[OF dom,OF domI])
    apply clarsimp
    apply (case_tac y,case_tac ya)
    apply (drule_tac x= p in spec)
    apply (drule_tac x= p' in spec)
    apply (frule_tac x = p in misc)
      apply assumption
    apply (frule_tac x = p' in misc)
      apply assumption
    apply (elim allE impE)
      apply fastforce+
  done

lemma caps_contained'_preserve:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
  isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte')
  \<and> untypedRange (cteCap cte) = untypedRange (cteCap cte')
  \<and> capRange (cteCap cte) = capRange (cteCap cte')
  \<and> cteMDBNode cte = cteMDBNode cte'"
  shows "caps_contained' m = caps_contained' m'"
  apply (rule iffI)
    apply (rule caps_contained'_preserve_oneway[OF dom misc])
      apply (assumption)+
  apply (rule caps_contained'_preserve_oneway)
  apply (auto simp:dom misc)
  done

lemma is_chunk_preserve_oneway:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'
  \<and> sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes node:"\<And>p. mdb_next m p = mdb_next m' p"
  shows " \<lbrakk>m x =Some (CTE a b);m' x = Some (CTE c d)\<rbrakk> \<Longrightarrow> is_chunk m a p p' \<Longrightarrow> is_chunk m' c p p'"
  apply (clarsimp simp:is_chunk_def)
   apply (drule_tac x= p'' in spec)
    apply (subgoal_tac "m \<turnstile> p \<leadsto>\<^sup>+ p'' = m' \<turnstile> p \<leadsto>\<^sup>+ p''")
     apply (subgoal_tac "m \<turnstile> p'' \<leadsto>\<^sup>* p' = m' \<turnstile> p'' \<leadsto>\<^sup>* p'")
     apply (frule iffD1[OF dom,OF domI])
     apply (clarsimp)
     apply (frule_tac x1 = p'' in iffD1[OF dom,OF domI])
     apply clarsimp
     apply (frule_tac x = p'' in sameRegion,assumption)
     apply clarsimp
     apply (frule_tac x = x in sameRegion,assumption)
     apply clarsimp
     apply (case_tac y)
     apply (drule_tac fun_cong)+
     apply fastforce
    apply simp
   apply (erule iffD1[OF connect_eqv_singleE',rotated -1])
   apply (clarsimp simp: mdb_next_rel_def node)
  apply (rule connect_eqv_singleE)
  apply (clarsimp simp: mdb_next_rel_def node)
  done

lemma is_chunk_preserve:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'
  \<and> sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes node:"\<And>p. mdb_next m p = mdb_next m' p"
  shows " \<lbrakk>m x =Some (CTE a b);m' x = Some (CTE c d)\<rbrakk> \<Longrightarrow> is_chunk m a p p' = is_chunk m' c p p'"
  apply (rule iffI)
    apply (rule is_chunk_preserve_oneway[OF dom sameRegion node],assumption+)
  apply (rule is_chunk_preserve_oneway)
  apply (auto simp:dom sameRegion node)
  done

lemma mdb_chunked_preserve_oneway:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'
  \<and> sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes node:"\<And>p. mdb_next m p = mdb_next m' p"
  shows
  "mdb_chunked m \<Longrightarrow> mdb_chunked m'"
  apply (clarsimp simp:mdb_chunked_def)
  apply (drule_tac x=p in spec)
  apply (drule_tac x=p' in spec)
  apply (frule iffD2[OF dom,OF domI],rotate_tac)
  apply (frule iffD2[OF dom,OF domI],rotate_tac)
  apply clarsimp
  apply (case_tac ya)
  apply (case_tac y)
  apply (frule_tac x = p in sameRegion,assumption)
  apply (frule_tac x = p' in sameRegion,assumption)
  apply clarsimp
  apply (erule impE)
   apply (drule fun_cong)+
   apply fastforce
   apply (subgoal_tac "m \<turnstile> p \<leadsto>\<^sup>+ p' = m' \<turnstile> p \<leadsto>\<^sup>+ p'")
     apply (subgoal_tac "m \<turnstile> p' \<leadsto>\<^sup>+ p = m' \<turnstile> p' \<leadsto>\<^sup>+ p")
       apply (frule_tac m = m and
              x = p and c = cap and p = p and p'=p' in is_chunk_preserve[rotated -1])
              apply (simp add:dom)
              apply (rule sameRegion)
          apply simp+
        apply (rule node)
      apply assumption
     apply (frule_tac x = p' and c = cap' and p = p' and p'=p in is_chunk_preserve[rotated -1])
              apply (rule dom)
              apply (rule sameRegion)
            apply assumption+
         apply (rule node)
      apply assumption
    apply clarsimp
    apply (rule connect_eqv_singleE)
  apply (clarsimp simp:mdb_next_rel_def node)
  apply (rule connect_eqv_singleE)
  apply (clarsimp simp:mdb_next_rel_def node)
  done

lemma mdb_chunked_preserve:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'
  \<and> sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes node:"\<And>p. mdb_next m p = mdb_next m' p"
  shows
  "mdb_chunked m = mdb_chunked m'"
   apply (rule iffI)
     apply (erule mdb_chunked_preserve_oneway[rotated -1])
       apply (simp add:dom sameRegion node)+
   apply (erule mdb_chunked_preserve_oneway[rotated -1])
   apply (simp add:dom[symmetric])
   apply (frule sameRegion)
     apply assumption
     apply simp
   apply (simp add:node)
  done

lemma valid_badges_preserve_oneway:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
    isNotificationCap (cteCap cte)  = isNotificationCap (cteCap cte')
  \<and> (isNotificationCap (cteCap cte) \<longrightarrow> (capNtfnBadge (cteCap cte) = capNtfnBadge (cteCap cte')))
  \<and> (isEndpointCap (cteCap cte) = isEndpointCap (cteCap cte'))
  \<and> (isEndpointCap (cteCap cte) \<longrightarrow> (capEPBadge (cteCap cte) = capEPBadge (cteCap cte')))
  \<and> cteMDBNode cte = cteMDBNode cte'"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
    sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes mdb_next:"\<And>p. mdb_next m p = mdb_next m' p"
  shows "valid_badges m \<Longrightarrow> valid_badges m'"
  apply (clarsimp simp:valid_badges_def)
  apply (drule_tac x = p in spec)
  apply (drule_tac x = p' in spec)
  apply (frule iffD2[OF dom,OF domI],rotate_tac)
  apply (frule iffD2[OF dom,OF domI],rotate_tac)
  apply clarsimp
  apply (case_tac y,case_tac ya)
  apply clarsimp
  apply (erule impE)
   apply (simp add: mdb_next mdb_next_rel_def)
  apply (erule impE)
   apply (drule(1) sameRegion)+
   apply clarsimp
   apply (drule fun_cong)+
   apply fastforce
  apply (drule(1) misc)+
  apply (clarsimp simp:isCap_simps sameRegionAs_def split:if_splits)
  done

lemma valid_badges_preserve:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
    isNotificationCap (cteCap cte)  = isNotificationCap (cteCap cte')
  \<and> (isNotificationCap (cteCap cte) \<longrightarrow> (capNtfnBadge (cteCap cte) = capNtfnBadge (cteCap cte')))
  \<and> (isEndpointCap (cteCap cte) = isEndpointCap (cteCap cte'))
  \<and> (isEndpointCap (cteCap cte) \<longrightarrow> (capEPBadge (cteCap cte) = capEPBadge (cteCap cte')))
  \<and> cteMDBNode cte = cteMDBNode cte'"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
    sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes mdb_next:"\<And>p. mdb_next m p = mdb_next m' p"
  shows "valid_badges m = valid_badges m'"
  apply (rule iffI)
    apply (rule valid_badges_preserve_oneway[OF dom misc sameRegion mdb_next])
    apply assumption+
  apply (rule valid_badges_preserve_oneway)
  apply (simp add:dom misc sameRegion mdb_next)+
  done

lemma mdb_untyped'_preserve_oneway:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
  isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte')
  \<and> untypedRange (cteCap cte) = untypedRange (cteCap cte')
  \<and> isNotificationCap (cteCap cte)  = isNotificationCap (cteCap cte')
  \<and> (isNotificationCap (cteCap cte) \<longrightarrow> (capNtfnBadge (cteCap cte) = capNtfnBadge (cteCap cte')))
  \<and> (isEndpointCap (cteCap cte) = isEndpointCap (cteCap cte'))
  \<and> (isEndpointCap (cteCap cte) \<longrightarrow> (capEPBadge (cteCap cte) = capEPBadge (cteCap cte')))
  \<and> capRange (cteCap cte) = capRange (cteCap cte')
  \<and> cteMDBNode cte = cteMDBNode cte'"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'
  \<and> sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes mdb_next:"\<And>p. mdb_next m p = mdb_next m' p"
  shows
  "untyped_mdb' m \<Longrightarrow> untyped_mdb' m'"
  apply (clarsimp simp:untyped_mdb'_def)
  apply (drule_tac x = p in spec)
  apply (drule_tac x = p' in spec)
  apply (frule iffD2[OF dom,OF domI],rotate_tac)
  apply (frule iffD2[OF dom,OF domI],rotate_tac)
  apply clarsimp
  apply (case_tac y,case_tac ya)
  apply (frule misc)
    apply fastforce
  apply clarsimp
  apply (frule_tac x = p' in misc)
    apply fastforce
  apply (frule_tac x = p in misc)
    apply assumption
  apply clarsimp
  apply (clarsimp simp: descendants_of'_def Invariants_H.subtree_def)
  apply (erule_tac f1 = "\<lambda>x. lfp x y" for y in iffD1[OF arg_cong,rotated])
    apply (rule ext)+
      apply (subgoal_tac "\<And>p p'. (m \<turnstile> p \<leadsto> p') = (m' \<turnstile> p \<leadsto> p')")
        apply (thin_tac "P" for P)+
        apply (subgoal_tac "(m \<turnstile> p parentOf x) = (m' \<turnstile> p parentOf x)")
        apply fastforce
      apply (rule parentOf_preserve[OF dom])
  apply (simp add:misc sameRegion mdb_next mdb_next_rel_def)+
  done


lemma untyped_mdb'_preserve:
  assumes dom:"\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
  isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte')
  \<and> untypedRange (cteCap cte) = untypedRange (cteCap cte')
  \<and> isNotificationCap (cteCap cte)  = isNotificationCap (cteCap cte')
  \<and> (isNotificationCap (cteCap cte) \<longrightarrow> (capNtfnBadge (cteCap cte) = capNtfnBadge (cteCap cte')))
  \<and> (isEndpointCap (cteCap cte) = isEndpointCap (cteCap cte'))
  \<and> (isEndpointCap (cteCap cte) \<longrightarrow> (capEPBadge (cteCap cte) = capEPBadge (cteCap cte')))
  \<and> capRange (cteCap cte) = capRange (cteCap cte')
  \<and> cteMDBNode cte = cteMDBNode cte'"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow> cteMDBNode cte = cteMDBNode cte'
  \<and> sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes mdb_next:"\<And>p. mdb_next m p = mdb_next m' p"
  shows
  "untyped_mdb' m = untyped_mdb' m'"
  apply (rule iffI)
    apply (erule mdb_untyped'_preserve_oneway[rotated -1])
      apply (simp add:dom misc sameRegion range mdb_next)+
   apply (erule mdb_untyped'_preserve_oneway[rotated -1])
   apply (simp add:dom[symmetric])
     apply (frule(1) misc,simp)
     apply (frule(1) sameRegion,simp)
   apply (simp add:mdb_next[symmetric])+
done

lemma irq_control_preserve_oneway:
  assumes dom: "\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:
  "\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
      isIRQControlCap (cteCap cte) = isIRQControlCap (cteCap cte') \<and>
      cteMDBNode cte = cteMDBNode cte'"
  shows "irq_control m \<Longrightarrow> irq_control m'"
  apply (clarsimp simp:irq_control_def)
    apply (frule iffD2[OF dom,OF domI])
    apply clarsimp
    apply (frule(1) misc)
    apply (clarsimp simp:isCap_simps)
    apply (case_tac y)
    apply (elim allE impE)
      apply fastforce
    apply clarsimp
    apply (drule_tac x = p' in spec)
    apply (erule impE)
    apply (frule_tac x1 = p' in iffD2[OF dom,OF domI])
    apply clarsimp
    apply (drule(1) misc)+
    apply (case_tac y)
    apply (simp add:isCap_simps)+
  done

lemma irq_control_preserve:
  assumes dom: "\<And>x. (x \<in> dom m) = (x \<in> dom m')"
  assumes misc:
  "\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
      isIRQControlCap (cteCap cte) = isIRQControlCap (cteCap cte') \<and>
      cteMDBNode cte = cteMDBNode cte'"
  shows "irq_control m = irq_control m'"
  apply (rule iffI[OF irq_control_preserve_oneway[OF dom misc]])
    apply (assumption)+
  apply (rule irq_control_preserve_oneway)
  apply (simp add:dom misc)+
  done

end

locale mdb_inv_preserve =
  fixes m m'
  assumes dom: "\<And>x. (x\<in> dom m)  = (x\<in> dom m')"
  assumes misc:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
  isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte')
  \<and> isNullCap (cteCap cte) = isNullCap (cteCap cte')
  \<and> isReplyCap (cteCap cte) = isReplyCap (cteCap cte')
  \<and> (isReplyCap (cteCap cte) \<longrightarrow> capReplyMaster (cteCap cte) = capReplyMaster (cteCap cte'))
  \<and> isNotificationCap (cteCap cte)  = isNotificationCap (cteCap cte')
  \<and> (isNotificationCap (cteCap cte) \<longrightarrow> (capNtfnBadge (cteCap cte) = capNtfnBadge (cteCap cte')))
  \<and> (isEndpointCap (cteCap cte) = isEndpointCap (cteCap cte'))
  \<and> (isEndpointCap (cteCap cte) \<longrightarrow> (capEPBadge (cteCap cte) = capEPBadge (cteCap cte')))
  \<and> untypedRange (cteCap cte) = untypedRange (cteCap cte')
  \<and> capClass (cteCap cte) = capClass (cteCap cte')
  \<and> isZombie (cteCap cte) = isZombie (cteCap cte')
  \<and> isArchFrameCap (cteCap cte) = isArchFrameCap (cteCap cte')
  \<and> capBits (cteCap cte) = capBits (cteCap cte')
  \<and> RetypeDecls_H.capUntypedPtr (cteCap cte) = RetypeDecls_H.capUntypedPtr (cteCap cte')
  \<and> capRange (cteCap cte) = capRange (cteCap cte')
  \<and> isIRQControlCap (cteCap cte) = isIRQControlCap (cteCap cte')
  \<and> cteMDBNode cte = cteMDBNode cte'"
  assumes sameRegion:"\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte'\<rbrakk> \<Longrightarrow>
     sameRegionAs (cteCap cte) = sameRegionAs (cteCap cte')
  \<and> (\<lambda>x. sameRegionAs x (cteCap cte)) = (\<lambda>x. sameRegionAs x (cteCap cte'))"
  assumes mdb_next:"\<And>p. mdb_next m p = mdb_next m' p"
begin
interpretation Arch . (*FIXME: arch_split*)
lemma preserve_stuff:
  "valid_dlist m = valid_dlist m'
 \<and> ut_revocable' m = ut_revocable' m'
 \<and> class_links m = class_links m'
 \<and> distinct_zombies m = distinct_zombies m'
 \<and> caps_contained' m = caps_contained' m'
 \<and> mdb_chunked m = mdb_chunked m'
 \<and> valid_badges m = valid_badges m'
 \<and> untyped_mdb' m = untyped_mdb' m'
 \<and> irq_control m = irq_control m'"
  apply (intro conjI)
    apply (rule valid_dlist_preserve)
      apply (simp add:mdb_inv_preserve_def dom misc sameRegion mdb_next)+
    apply (rule ut_revocable_preserve)
      apply (simp add:mdb_inv_preserve_def dom misc sameRegion mdb_next)+
    apply (rule class_links_preserve)
      apply (simp add:mdb_inv_preserve_def dom misc sameRegion mdb_next)+
    apply (rule distinct_zombies_preserve)
      apply (simp add:mdb_inv_preserve_def dom misc sameRegion mdb_next)+
    apply (rule caps_contained'_preserve)
      apply (simp add:mdb_inv_preserve_def dom misc sameRegion mdb_next)+
    apply (rule mdb_chunked_preserve)
      apply (simp add:mdb_inv_preserve_def dom misc sameRegion mdb_next)+
    apply (rule valid_badges_preserve)
      apply (simp add:mdb_inv_preserve_def dom misc sameRegion mdb_next)+
    apply (rule untyped_mdb'_preserve)
      apply (simp add:mdb_inv_preserve_def dom misc sameRegion mdb_next)+
    apply (rule irq_control_preserve)
      apply (simp add:mdb_inv_preserve_def dom misc sameRegion mdb_next)+
  done

lemma untyped_inc':
  assumes subeq: "\<And>x cte cte'. \<lbrakk>m x =Some cte;m' x = Some cte';isUntypedCap (cteCap cte)\<rbrakk> \<Longrightarrow>
  usableUntypedRange (cteCap cte') \<subseteq> usableUntypedRange (cteCap cte)"
  shows "untyped_inc' m \<Longrightarrow> untyped_inc' m'"
  apply (clarsimp simp:untyped_inc'_def)
  apply (drule_tac x = p in spec)
  apply (drule_tac x = p' in spec)
  apply (frule iffD2[OF dom,OF domI],rotate_tac)
  apply (frule iffD2[OF dom,OF domI],rotate_tac)
  apply clarsimp
  apply (rename_tac cte cte')
  apply (case_tac cte)
  apply (rename_tac cap node)
  apply (case_tac cte')
  apply (drule_tac x = cap in spec)
  apply clarsimp
  apply (frule_tac x = p' in misc)
    apply assumption
  apply (frule_tac x = p in misc)
    apply assumption
  apply clarsimp
  apply (drule(1) subeq,simp)+
  apply (subgoal_tac  "\<And>p p'. (p' \<in>descendants_of' p m) = (p' \<in> descendants_of' p m')")
  apply clarsimp
  apply (intro conjI impI)
    apply clarsimp
    apply (drule(1) disjoint_subset2[rotated],clarsimp+)+
   apply (erule disjE)
   apply clarsimp+
  apply (thin_tac "P" for P)+
    apply (clarsimp simp: descendants_of'_def Invariants_H.subtree_def)
    apply (rule_tac f = "\<lambda>x. lfp x c" for c in arg_cong)
      apply (subgoal_tac "\<And>p p'. (m \<turnstile> p \<leadsto> p') = (m' \<turnstile> p \<leadsto> p')")
        apply (rule ext)+
        apply clarsimp
        apply (subgoal_tac "(m \<turnstile> pa parentOf x) = (m' \<turnstile> pa parentOf x)")
        apply fastforce
      apply (rule parentOf_preserve[OF dom])
  apply (simp add:misc sameRegion mdb_next mdb_next_rel_def)+
  done

lemma descendants_of:
  "descendants_of' p m = descendants_of' p m'"
  apply (rule set_eqI)
  apply (clarsimp simp:descendants_of'_def Invariants_H.subtree_def)
   apply (rule_tac f = "\<lambda>x. lfp x c" for c in arg_cong)
   apply (rule ext)+
    apply (subgoal_tac "\<And>p p'. (m \<turnstile> p \<leadsto> p') = (m' \<turnstile> p \<leadsto> p')")
    apply clarsimp
     apply (subgoal_tac "(m \<turnstile> p parentOf xa) = (m' \<turnstile> p parentOf xa)")
        apply fastforce
      apply (rule parentOf_preserve[OF dom])
  apply (simp add:misc sameRegion mdb_next mdb_next_rel_def)+
  done

lemma by_products:
  "reply_masters_rvk_fb m = reply_masters_rvk_fb m'
 \<and> no_0 m = no_0 m' \<and> mdb_chain_0 m = mdb_chain_0 m'
 \<and> valid_nullcaps m = valid_nullcaps m'"
apply (intro conjI)
  apply (simp add:ran_dom reply_masters_rvk_fb_def mdb_inv_preserve_def dom misc sameRegion mdb_next)
    apply (rule iffI)
    apply clarsimp
    apply (drule_tac x = y in bspec)
     apply (rule iffD2[OF dom])
     apply clarsimp
    apply (frule iffD2[OF dom,OF domI],rotate_tac)
    apply (clarsimp simp:misc)+
    apply (drule_tac x = y in bspec)
     apply (rule iffD1[OF dom])
     apply clarsimp
    apply (frule iffD1[OF dom,OF domI],rotate_tac)
   apply (clarsimp simp:misc)+
   apply (clarsimp simp:no_0_def)
   apply (rule ccontr)
   apply (simp add:dom_in)
   apply (subst (asm) dom[symmetric])
   apply fastforce
   apply (rule iffI)
   apply (clarsimp simp:mdb_chain_0_def)
      apply (drule_tac x =x in bspec)
      apply (rule iffD2[OF dom],clarsimp)
      apply (erule_tac iffD1[OF connect_eqv_singleE,rotated])
      apply (cut_tac p = p in mdb_next)
      apply (clarsimp simp: mdb_next_rel_def)
    apply (clarsimp simp:mdb_chain_0_def)
      apply (drule_tac x =x in bspec)
      apply (rule iffD1[OF dom],clarsimp)
      apply (erule_tac iffD1[OF connect_eqv_singleE,rotated])
      apply (cut_tac p = p in mdb_next)
      apply (clarsimp simp: mdb_next_rel_def)
   apply (simp add:valid_nullcaps_def)
   apply (rule forall_eq,clarsimp)+
     apply (rule iffI)
      apply clarsimp
      apply (frule iffD2[OF dom,OF domI])
      apply (clarsimp)
      apply (case_tac y)
      apply (drule misc)
        apply assumption
        apply (clarsimp simp:isCap_simps)
     apply clarsimp
     apply (frule iffD1[OF dom,OF domI])
     apply (clarsimp)
     apply (case_tac y)
     apply (drule misc)
       apply assumption
       apply (clarsimp simp:isCap_simps)
done

end

lemma mdb_inv_preserve_modify_map:
  "mdb_inv_preserve m m' \<Longrightarrow>
   mdb_inv_preserve (modify_map m slot (cteMDBNode_update f))
                    (modify_map m' slot (cteMDBNode_update f))"
  apply (clarsimp simp:mdb_inv_preserve_def split:if_splits)
  apply (intro conjI)
     apply (clarsimp simp:modify_map_dom)
    apply (clarsimp simp:modify_map_def split:if_splits)+
  apply (clarsimp simp:option_map_def o_def split:option.splits if_splits)
  apply (drule_tac x = p in spec)+
  apply (intro allI conjI impI)
     apply (clarsimp simp:mdb_next_def split:if_splits)+
  done

lemma mdb_inv_preserve_updateCap:
  "\<lbrakk>m slot = Some cte;isUntypedCap (cteCap cte)\<rbrakk> \<Longrightarrow>
   mdb_inv_preserve m (modify_map m slot
     (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap cte))))"
  apply (clarsimp simp:mdb_inv_preserve_def modify_map_dom isCap_simps modify_map_def split:if_splits)
  apply (intro conjI impI allI)
    apply fastforce
    apply (simp add:sameRegionAs_update_untyped)
    apply (rule ext,simp add:sameRegionAs_update_untyped')
    apply (simp add:mdb_next_def split:if_splits)
  done

lemma mdb_inv_preserve_fun_upd:
  "mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (m(a \<mapsto> b)) (m'(a \<mapsto> b))"
  by (clarsimp simp:mdb_inv_preserve_def mdb_next_def split:if_splits)

lemma updateCap_ctes_of_wp:
  "\<lbrace>\<lambda>s.  P (modify_map (ctes_of s) ptr (cteCap_update (\<lambda>_. cap)))\<rbrace>
  updateCap ptr cap
  \<lbrace>\<lambda>r s.  P (ctes_of s)\<rbrace>"
  by (rule validI, simp add: updateCap_stuff)

lemma updateCap_cte_wp_at':
  "\<lbrace>\<lambda>s. cte_at' ptr s \<longrightarrow> Q (cte_wp_at' (\<lambda>cte. if p = ptr then P' (CTE cap (cteMDBNode cte)) else P' cte) p s)\<rbrace>
        updateCap ptr cap \<lbrace>\<lambda>rv s. Q (cte_wp_at' P' p s)\<rbrace>"
  apply (simp add:updateCap_def cte_wp_at_ctes_of)
  apply (wp setCTE_ctes_of_wp getCTE_wp)
  apply (clarsimp simp: cte_wp_at_ctes_of)
  apply (case_tac cte, auto split: if_split)
  done

lemma updateCapFreeIndex_mdb_chain_0:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (mdb_chain_0 (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (mdb_chain_0 (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.by_products)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_valid_badges:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (valid_badges (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (valid_badges (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.preserve_stuff)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_caps_contained:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (caps_contained' (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (caps_contained' (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.preserve_stuff)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_valid_nullcaps:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (valid_nullcaps (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (valid_nullcaps (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.by_products)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_ut_revocable:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (ut_revocable'(Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (ut_revocable' (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.preserve_stuff)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_class_links:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (class_links (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (class_links (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.preserve_stuff)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_reply_masters_rvk_fb:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (reply_masters_rvk_fb (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (reply_masters_rvk_fb (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.by_products)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_distinct_zombies:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (distinct_zombies (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (distinct_zombies (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.preserve_stuff)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_mdb_chunked:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (mdb_chunked (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (mdb_chunked (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.preserve_stuff)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_untyped_mdb':
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (untyped_mdb' (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (untyped_mdb' (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.preserve_stuff)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma updateCapFreeIndex_irq_control:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (irq_control (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
  updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
 \<lbrace>\<lambda>r s. P (irq_control (Q (ctes_of s)))\<rbrace>"
  apply (wp updateCap_ctes_of_wp)
  apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
              (cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
    apply (drule mdb_inv_preserve.preserve_stuff)
    apply simp
  apply (rule preserve)
  apply (rule mdb_inv_preserve_updateCap)
    apply (clarsimp simp:cte_wp_at_ctes_of)+
done

lemma setUntypedCapAsFull_mdb_chunked:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (mdb_chunked (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (mdb_chunked (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
   apply (wp updateCapFreeIndex_mdb_chunked)
   apply (clarsimp simp:preserve cte_wp_at_ctes_of)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_untyped_mdb':
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (untyped_mdb' (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (untyped_mdb' (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
    apply (wp updateCapFreeIndex_untyped_mdb')
    apply (clarsimp simp:cte_wp_at_ctes_of preserve)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_mdb_chain_0:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (mdb_chain_0 (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (mdb_chain_0 (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
   apply (wp updateCapFreeIndex_mdb_chain_0)
   apply (clarsimp simp:preserve cte_wp_at_ctes_of)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_irq_control:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (irq_control (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (irq_control (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
    apply (wp updateCapFreeIndex_irq_control)
    apply (clarsimp simp:cte_wp_at_ctes_of preserve)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_valid_badges:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (valid_badges (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (valid_badges (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
    apply (wp updateCapFreeIndex_valid_badges)
    apply (clarsimp simp:cte_wp_at_ctes_of preserve)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_caps_contained:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (caps_contained' (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (caps_contained' (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
    apply (wp updateCapFreeIndex_caps_contained)
    apply (clarsimp simp:cte_wp_at_ctes_of preserve)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_valid_nullcaps:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (valid_nullcaps (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (valid_nullcaps (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
    apply (wp updateCapFreeIndex_valid_nullcaps)
    apply (clarsimp simp:cte_wp_at_ctes_of preserve)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_ut_revocable:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (ut_revocable' (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (ut_revocable' (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
    apply (wp updateCapFreeIndex_ut_revocable)
    apply (clarsimp simp:cte_wp_at_ctes_of preserve)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_class_links:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (class_links(Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (class_links (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
    apply (wp updateCapFreeIndex_class_links)
    apply (clarsimp simp:cte_wp_at_ctes_of preserve)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_distinct_zombies:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (distinct_zombies (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (distinct_zombies (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
    apply (wp updateCapFreeIndex_distinct_zombies)
    apply (clarsimp simp:cte_wp_at_ctes_of preserve)+
  apply wp
  apply clarsimp
done

lemma setUntypedCapAsFull_reply_masters_rvk_fb:
  assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
  shows
 "\<lbrace>\<lambda>s. P (reply_masters_rvk_fb (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (reply_masters_rvk_fb (Q (ctes_of s)))\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
    apply (wp updateCapFreeIndex_reply_masters_rvk_fb)
    apply (clarsimp simp:cte_wp_at_ctes_of preserve)+
  apply wp
  apply clarsimp
done

lemma modify_map_eq[simp]:
  "\<lbrakk>m slot = Some srcCTE; cap = cteCap srcCTE\<rbrakk>
   \<Longrightarrow>(modify_map m slot (cteCap_update (\<lambda>_. cap))) = m"
  apply (rule ext)
  apply (case_tac srcCTE)
  apply (auto simp:modify_map_def split:if_splits)
  done

lemma setUntypedCapAsFull_ctes:
 "\<lbrace>\<lambda>s. cte_wp_at' (\<lambda>c. c = srcCTE) src s \<and>
   P (modify_map (ctes_of s) src (cteCap_update (\<lambda>_. maskedAsFull (cteCap srcCTE) cap)))
  \<rbrace>
 setUntypedCapAsFull (cteCap srcCTE) cap src
 \<lbrace>\<lambda>r s. P (ctes_of s)\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
   apply (wp updateCap_ctes_of_wp)
   apply (clarsimp simp:isCap_simps max_free_index_def maskedAsFull_def)
  apply wp
  apply (clarsimp simp:isCap_simps cte_wp_at_ctes_of
    max_free_index_def maskedAsFull_def split:if_splits)
  done

lemma setUntypedCapAsFull_valid_cap:
  "\<lbrace>valid_cap' cap and cte_wp_at' ((=) srcCTE) slot\<rbrace>
   setUntypedCapAsFull (cteCap srcCTE) c slot
   \<lbrace>\<lambda>r. valid_cap' cap\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits)
  apply (intro conjI impI)
    apply (clarsimp simp:updateCap_def)
  apply (wp|clarsimp)+
done

lemma cteCap_update_simps:
  "cteCap_update f srcCTE = CTE (f (cteCap srcCTE)) (cteMDBNode srcCTE)"
  apply (case_tac srcCTE)
  apply auto
done

lemma setUntypedCapAsFull_cte_wp_at:
  "\<lbrace>cte_wp_at' ((=) srcCTE) slot and
    (\<lambda>s. cte_wp_at' (\<lambda>c. P c) dest s \<and> dest \<noteq> slot \<or>
         dest = slot \<and> cte_wp_at' (\<lambda>c. P (CTE (maskedAsFull (cteCap c) c')
                                              (cteMDBNode c))) slot s) \<rbrace>
   setUntypedCapAsFull (cteCap srcCTE) c' slot
   \<lbrace>\<lambda>r s. cte_wp_at' (\<lambda>c. P c) dest s\<rbrace>"
  apply (clarsimp simp:setUntypedCapAsFull_def cte_wp_at_ctes_of split:if_splits)
   apply (case_tac "dest = slot")
    apply (intro conjI impI)
      apply (clarsimp simp:updateCap_def)
      apply (wp getCTE_wp)
      apply (clarsimp simp:maskedAsFull_def cte_wp_at_ctes_of cteCap_update_simps)
    apply wp
    apply (case_tac srcCTE)
    apply (fastforce simp:maskedAsFull_def cte_wp_at_ctes_of)
  apply (intro conjI impI)
    apply (clarsimp simp:updateCap_def | wp setCTE_weak_cte_wp_at getCTE_wp)+
    apply (simp add:cte_wp_at'_def)
  apply (clarsimp simp:updateCap_def | wp setCTE_weak_cte_wp_at getCTE_wp)+
  done

lemma mdb_inv_preserve_sym:"mdb_inv_preserve a b \<Longrightarrow> mdb_inv_preserve b a"
 by (simp add:mdb_inv_preserve_def)


lemma mdb_inv_preserve_refl[simp]:
  "mdb_inv_preserve m m"
   by (simp add:mdb_inv_preserve_def)

lemma setUntypedCapAsFull_mdb[wp]:
  "\<lbrace>\<lambda>s. valid_mdb' s \<and> cte_wp_at' (\<lambda>c. c = srcCTE) slot s \<rbrace>
   setUntypedCapAsFull (cteCap srcCTE) cap slot
   \<lbrace>\<lambda>rv s. valid_mdb' s\<rbrace>"
  apply (clarsimp simp:valid_mdb'_def)
  apply (wp setUntypedCapAsFull_ctes)
  apply (subgoal_tac "mdb_inv_preserve (ctes_of s) (modify_map (ctes_of s) slot
              (cteCap_update (\<lambda>_.  maskedAsFull (cteCap srcCTE) cap)))")
    apply (frule mdb_inv_preserve.untyped_inc')
      apply (clarsimp simp:modify_map_def max_free_index_def
        maskedAsFull_def isCap_simps cte_wp_at_ctes_of
        split:if_splits)
   apply (clarsimp simp:valid_mdb_ctes_def mdb_inv_preserve.preserve_stuff)+
   apply (clarsimp simp:mdb_inv_preserve.by_products[OF mdb_inv_preserve_sym])
  apply (clarsimp simp:maskedAsFull_def cte_wp_at_ctes_of split:if_splits)
  apply (erule(1) mdb_inv_preserve_updateCap)
  done

lemma (in mdb_insert_abs_sib) next_slot_no_parent':
  "\<lbrakk>valid_list_2 t m; finite_depth m; no_mloop m; m src = None\<rbrakk>
    \<Longrightarrow> next_slot p t (m(dest := None)) = next_slot p t m"
  by (insert next_slot_no_parent, simp add: n_def)

lemma no_parent_next_not_child_None:
  "\<lbrakk>m p = None; finite_depth m\<rbrakk> \<Longrightarrow> next_not_child p t m = None"
  apply(rule next_not_child_NoneI)
    apply(fastforce simp: descendants_of_def cdt_parent_defs dest: tranclD2)
   apply(simp add: next_sib_def)
  apply(simp)
  done

lemma (in mdb_insert_abs_sib) next_slot':
  "\<lbrakk>valid_list_2 t m; finite_depth m; no_mloop m; m src = Some src_p; t src = []\<rbrakk>
    \<Longrightarrow> next_slot p (t(src_p := list_insert_after (t src_p) src dest))
        (m(dest := Some src_p)) =
       (if p = src then Some dest
        else if p = dest then next_slot src t m else next_slot p t m)"
  by (insert next_slot, simp add: n_def)

lemmas valid_list_def = valid_list_2_def

crunch valid_list[wp]: set_untyped_cap_as_full valid_list

lemma updateMDB_the_lot':
  assumes "(x, s'') \<in> fst (updateMDB p f s')"
  assumes "pspace_relations (ekheap sa) (kheap s) (ksPSpace s')"
  assumes "pspace_aligned' s'" "pspace_distinct' s'" "no_0 (ctes_of s')" "ekheap s = ekheap sa"
  shows "ctes_of s'' = modify_map (ctes_of s') p (cteMDBNode_update f) \<and>
         ksMachineState s'' = ksMachineState s' \<and>
         ksWorkUnitsCompleted s'' = ksWorkUnitsCompleted s' \<and>
         ksCurThread s'' = ksCurThread s' \<and>
         ksIdleThread s'' = ksIdleThread s' \<and>
         ksReadyQueues s'' = ksReadyQueues s' \<and>
         ksSchedulerAction s'' = ksSchedulerAction s' \<and>
         ksInterruptState s'' = ksInterruptState s' \<and>
         ksArchState s'' = ksArchState s' \<and>
         gsUserPages s'' = gsUserPages s' \<and>
         gsCNodes s'' = gsCNodes s' \<and>
         pspace_relations (ekheap s) (kheap s) (ksPSpace s'') \<and>
         pspace_aligned' s'' \<and> pspace_distinct' s'' \<and>
         no_0 (ctes_of s'') \<and>
         ksDomScheduleIdx s'' = ksDomScheduleIdx s' \<and>
         ksDomSchedule s''    = ksDomSchedule s' \<and>
         ksCurDomain s''      = ksCurDomain s' \<and>
         ksDomainTime s''     = ksDomainTime s'"
  apply (rule updateMDB_the_lot)
      using assms
      apply (fastforce simp: pspace_relations_def)+
      done

lemma cte_map_inj_eq':
  "\<lbrakk>(cte_map p = cte_map p');
   cte_at p s \<and> cte_at p' s \<and>
   valid_objs s \<and> pspace_aligned s \<and> pspace_distinct s\<rbrakk>
  \<Longrightarrow> p = p'"
  apply (rule cte_map_inj_eq; fastforce)
  done

context begin interpretation Arch . (*FIXME: arch_split*)
lemma cteInsert_corres:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
        trans_state_update'[symmetric,simp]
  assumes "cap_relation c c'" "src' = cte_map src" "dest' = cte_map dest"
  shows "corres dc
        (valid_objs and pspace_distinct and pspace_aligned and
         valid_mdb and valid_list and K (src\<noteq>dest) and
         cte_wp_at (\<lambda>c. c=Structures_A.NullCap) dest and
         (\<lambda>s. cte_wp_at (is_derived (cdt s) src c) src s))
        (pspace_distinct' and pspace_aligned' and valid_mdb' and valid_cap' c' and
         cte_wp_at' (\<lambda>c. cteCap c=NullCap) dest')
        (cap_insert c src dest)
        (cteInsert c' src' dest')"
  (is "corres _ (?P and (\<lambda>s. cte_wp_at _ _ s)) (?P' and cte_wp_at' _ _) _ _")
  using assms
  unfolding cap_insert_def cteInsert_def
  apply simp
  apply (rule corres_guard_imp)
    apply (rule corres_split[OF get_cap_corres])
      apply (rule corres_split[OF get_cap_corres])
        apply (rule_tac F="cteCap rv' = NullCap" in corres_gen_asm2)
        apply simp
        apply (rule_tac P="?P and cte_at dest and
                            (\<lambda>s. cte_wp_at (is_derived (cdt s) src c) src s) and
                            cte_wp_at ((=) src_cap) src" and
                        Q="?P' and
                           cte_wp_at' ((=) rv') (cte_map dest) and
                           cte_wp_at' ((=) srcCTE) (cte_map src)"
                        in corres_assert_assume)
         prefer 2
         apply (clarsimp simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def valid_nullcaps_def)
         apply (case_tac rv')
         apply (simp add: initMDBNode_def)
         apply (erule allE)+
         apply (erule (1) impE)
         apply (simp add: nullPointer_def)
        apply (rule corres_guard_imp)
          apply (rule_tac R="\<lambda>r. ?P and cte_at dest and
                            (\<lambda>s. (is_derived (cdt s) src c) src_cap) and
                            cte_wp_at ((=) (masked_as_full src_cap c)) src" and
                        R'="\<lambda>r. ?P' and cte_wp_at' ((=) rv') (cte_map dest) and
                           cte_wp_at' ((=) (CTE (maskedAsFull (cteCap srcCTE) c') (cteMDBNode srcCTE)))
                           (cte_map src)"
                        in corres_split[where r'=dc])
             apply (rule setUntypedCapAsFull_corres; simp)
            apply (rule corres_stronger_no_failI)
             apply (rule no_fail_pre)
              apply (wp hoare_weak_lift_imp)
             apply (clarsimp simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def)
             apply (erule_tac valid_dlistEn[where p = "cte_map src"])
               apply (simp+)[3]
            apply (clarsimp simp: corres_underlying_def state_relation_def
                                  in_monad valid_mdb'_def valid_mdb_ctes_def)
            apply (drule (1) pspace_relationsD)
            apply (drule (18) set_cap_not_quite_corres)
             apply (rule refl)
            apply (elim conjE exE)
            apply (rule bind_execI, assumption)
            apply (subgoal_tac "mdb_insert_abs (cdt a) src dest")
             prefer 2
             apply (erule mdb_insert_abs.intro)
              apply (rule mdb_Null_None)
               apply (simp add: op_equal)
              apply simp
             apply (rule mdb_Null_descendants)
              apply (simp add: op_equal)
             apply simp
            apply (subgoal_tac "no_mloop (cdt a)")
             prefer 2
             apply (simp add: valid_mdb_def)
            apply (clarsimp simp: exec_gets update_cdt_def bind_assoc set_cdt_def
                                  exec_get exec_put set_original_def modify_def
                        simp del: fun_upd_apply
                   | (rule bind_execI[where f="cap_insert_ext x y z i p" for x y z i p], clarsimp simp: exec_gets exec_get put_def mdb_insert_abs.cap_insert_ext_det_def2 update_cdt_list_def set_cdt_list_def, rule refl))+
            apply (clarsimp simp: put_def state_relation_def)
            apply (drule updateCap_stuff)
            apply clarsimp
            apply (drule (3) updateMDB_the_lot', simp, simp, elim conjE)
            apply (drule (3) updateMDB_the_lot', simp, simp, elim conjE)
            apply (drule (3) updateMDB_the_lot', simp, simp,  elim conjE)
            apply (clarsimp simp: cte_wp_at_ctes_of nullPointer_def
                             prev_update_modify_mdb_relation)
            apply (subgoal_tac "cte_map dest \<noteq> 0")
             prefer 2
             apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def no_0_def)
            apply (subgoal_tac "cte_map src \<noteq> 0")
             prefer 2
             apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def no_0_def)
            apply (thin_tac "ksMachineState t = p" for p t)+
            apply (thin_tac "ksCurThread t = p" for p t)+
            apply (thin_tac "ksIdleThread t = p" for p t)+
            apply (thin_tac "ksReadyQueues t = p" for p t)+
            apply (thin_tac "ksSchedulerAction t = p" for p t)+
            apply (clarsimp simp: pspace_relations_def)

            apply (rule conjI)
             apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def)
            apply (rule conjI)
             defer
             apply(rule conjI)
              apply (thin_tac "ctes_of s = t" for s t)+
              apply (thin_tac "pspace_relation s t" for s t)+
              apply (thin_tac "machine_state t = s" for s t)+
              apply (case_tac "srcCTE")
              apply (rename_tac src_cap' src_node)
              apply (case_tac "rv'")
              apply (rename_tac dest_node)
              apply (clarsimp simp: in_set_cap_cte_at_swp)
              apply (subgoal_tac "cte_at src a \<and> is_derived (cdt a) src c src_cap")
               prefer 2
               apply (fastforce simp: cte_wp_at_def)
              apply (erule conjE)
              apply (subgoal_tac "mdb_insert (ctes_of b) (cte_map src) (maskedAsFull src_cap' c') src_node
                                 (cte_map dest) NullCap dest_node")
               prefer 2
               apply (rule mdb_insert.intro)
                 apply (rule mdb_ptr.intro)
                  apply (rule vmdb.intro, simp add: valid_mdb_ctes_def)
                 apply (erule mdb_ptr_axioms.intro)
                apply (rule mdb_ptr.intro)
                 apply (rule vmdb.intro, simp add: valid_mdb_ctes_def)
                apply (erule mdb_ptr_axioms.intro)
               apply (rule mdb_insert_axioms.intro)
                    apply (rule refl)
                   apply assumption
                  apply assumption
                 apply assumption
                apply assumption
               apply (erule (5) cte_map_inj)
              apply (frule mdb_insert_der.intro)
               apply (rule mdb_insert_der_axioms.intro)
               apply (simp add: is_derived_eq)
              apply (simp (no_asm_simp) add: cdt_relation_def split: if_split)
              apply (subgoal_tac "descendants_of dest (cdt a) = {}")
               prefer 2
               apply (drule mdb_insert.dest_no_descendants)
               apply (fastforce simp add: cdt_relation_def)
              apply (subgoal_tac "mdb_insert_abs (cdt a) src dest")
               prefer 2
               apply (erule mdb_insert_abs.intro)
                apply (rule mdb_None)
                  apply (erule(1) mdb_insert.descendants_not_dest)
                 apply assumption
                apply assumption
               apply assumption
              apply(simp add: cdt_list_relation_def)
              apply(subgoal_tac "no_mloop (cdt a) \<and> finite_depth (cdt a)")
               prefer 2
               apply(simp add: finite_depth valid_mdb_def)
              apply(intro conjI impI allI)
               apply(simp cong: option.case_cong)
               apply(simp split: option.split)
               apply(subgoal_tac "\<forall>aa. cdt a src = Some aa \<longrightarrow> src \<noteq> aa")
                prefer 2
                apply(fastforce simp: no_mloop_weaken)
               apply(simp add: fun_upd_twist)
               apply(rule allI)
               apply(case_tac "next_child src (cdt_list (a))")
                apply(frule next_child_NoneD)
                apply(subst mdb_insert_abs.next_slot)
                    apply(simp_all)[5]
                apply(case_tac "ca=src")
                 apply(simp)
                 apply(clarsimp simp: modify_map_def)
                 apply(fastforce split: if_split_asm)
                apply(case_tac "ca = dest")
                 apply(simp)
                 apply(rule impI)
                 apply(clarsimp simp: modify_map_def const_def)
                 apply(simp split: if_split_asm)
                   apply(drule_tac p="cte_map src" in valid_mdbD1')
                     subgoal by(simp)
                    subgoal by(simp add: valid_mdb'_def valid_mdb_ctes_def)
                   subgoal by(clarsimp)
                  apply(drule cte_map_inj_eq')
                   apply(simp_all)[2]
                 apply(erule_tac x=src in allE)+
                 subgoal by(fastforce)
                apply(simp)
                apply(rule impI)
                apply(subgoal_tac "cte_at ca a")
                 prefer 2
                 apply(rule cte_at_next_slot)
                    apply(simp_all)[4]
                apply(clarsimp simp: modify_map_def const_def)
                apply(simp split: if_split_asm)
                      apply(drule cte_map_inj_eq')
                           apply(simp_all)[2]
                     apply(drule_tac p="cte_map src" in valid_mdbD1')
                       subgoal by(simp)
                      subgoal by(simp add: valid_mdb'_def valid_mdb_ctes_def)
                     subgoal by(clarsimp)
                    apply(clarsimp)
                    apply(case_tac z)
                    apply(erule_tac x="(aa, bb)" in allE)+
                    subgoal by(fastforce)
                   apply(drule cte_map_inj_eq')
                        apply(simp_all)[2]
                  apply(drule cte_map_inj_eq')
                       apply(simp_all)[2]
                 apply(drule cte_map_inj_eq')
                      apply(simp_all)[2]
                apply(erule_tac x="(aa, bb)" in allE)+
                subgoal by(fastforce)

               apply(frule(1) next_childD)
               apply(simp add: mdb_insert_abs.next_slot)
               apply(case_tac "ca=src")
                apply(simp)
                apply(clarsimp simp: modify_map_def)
                subgoal by(fastforce split: if_split_asm)
               apply(case_tac "ca = dest")
                apply(simp)
                apply(rule impI)
                apply(clarsimp simp: modify_map_def const_def)
                apply(simp split: if_split_asm)
                  apply(drule_tac p="cte_map src" in valid_mdbD1')
                    subgoal by(simp)
                   apply(simp add: valid_mdb'_def valid_mdb_ctes_def)
                  subgoal by(clarsimp)
                 apply(drule cte_map_inj_eq')
                  apply(simp_all)[2]
                apply(erule_tac x=src in allE)+
                subgoal by(fastforce)
               apply(simp)
               apply(rule impI)
               apply(subgoal_tac "cte_at ca a")
                prefer 2
                apply(rule cte_at_next_slot)
                   apply(simp_all)[4]
               apply(clarsimp simp: modify_map_def const_def)
               apply(simp split: if_split_asm)
                     apply(drule cte_map_inj_eq')
                      apply(simp_all)[2]
                    apply(drule_tac p="cte_map src" in valid_mdbD1')
                      subgoal by(simp)
                     subgoal by(simp add: valid_mdb'_def valid_mdb_ctes_def)
                    subgoal by(clarsimp)
                   apply(clarsimp)
                   apply(case_tac z)
                   apply(erule_tac x="(aa, bb)" in allE)+
                   subgoal by(fastforce)
                  apply(drule cte_map_inj_eq')
                   apply(simp_all)[2]
                 apply(drule cte_map_inj_eq')
                  apply(simp_all)[2]
                apply(drule cte_map_inj_eq')
                 apply(simp_all)[2]
               apply(erule_tac x="(aa, bb)" in allE)+
               subgoal by(fastforce)

              apply(subgoal_tac "mdb_insert_sib (ctes_of b) (cte_map src) (maskedAsFull src_cap' c')
                                   src_node (cte_map dest) capability.NullCap dest_node c'")
               prefer 2
               apply(simp add: mdb_insert_sib_def)
               apply(rule mdb_insert_sib_axioms.intro)
               apply (subst can_be_is [symmetric])
                   apply simp
                   apply (rule cap_relation_masked_as_full)
                    apply (simp+)[3]
                 apply simp
                apply simp
               apply simp
                apply (subst (asm) is_cap_revocable_eq, assumption, assumption)
                 apply (rule derived_sameRegionAs)
                  apply (subst is_derived_eq[symmetric]; assumption)
                 apply assumption
                subgoal by (clarsimp simp: cte_wp_at_def is_derived_def is_cap_simps cap_master_cap_simps
                                    dest!:cap_master_cap_eqDs)
               apply (subgoal_tac "is_original_cap a src = mdbRevocable src_node")
                apply (frule(4) iffD1[OF is_derived_eq])
                apply (drule_tac src_cap' = src_cap' in
                  maskedAsFull_revokable[where a = c',symmetric])
                subgoal by(simp)
               apply (simp add: revokable_relation_def)
               apply (erule_tac x=src in allE)+
               apply simp
               apply (erule impE)
                apply (clarsimp simp: null_filter_def cte_wp_at_caps_of_state split: if_splits)
                subgoal by (clarsimp simp: masked_as_full_def is_cap_simps free_index_update_def split: if_splits)
               apply(simp)

              apply(subgoal_tac "cdt_list (a) src = []")
               prefer 2
               apply(rule ccontr)
               apply(simp add: empty_list_empty_desc)
               apply(simp add: no_children_empty_desc[symmetric])
               apply(erule exE)
               apply(drule_tac p="cte_map caa" in mdb_insert_sib.src_no_parent)
               apply(subgoal_tac "cte_map caa\<in>descendants_of' (cte_map src) (ctes_of b)")
                subgoal by(simp add: descendants_of'_def)
               apply(simp add: cdt_relation_def)
               apply(erule_tac x=src in allE)
               apply(drule child_descendant)+
               apply(drule_tac x=caa and f=cte_map in imageI)
               subgoal by(simp)

              apply(case_tac "cdt a src")
               apply(simp)
               apply(subst mdb_insert_abs_sib.next_slot_no_parent')
                    apply(simp add: mdb_insert_abs_sib_def)
                   apply(simp_all add: fun_upd_idem)[5]

               apply(case_tac "ca=src")
                subgoal by(simp add: next_slot_def no_parent_next_not_child_None)
               apply(case_tac "ca = dest")
                subgoal by(simp add: next_slot_def no_parent_next_not_child_None
                                     mdb_insert_abs.dest empty_list_empty_desc)
               apply(case_tac "next_slot ca (cdt_list (a)) (cdt a)")
                subgoal by(simp)
               apply(simp)
               apply(subgoal_tac "cte_at ca a")
                prefer 2
                apply(rule cte_at_next_slot)
                   apply(simp_all)[4]
               apply(clarsimp simp: modify_map_def const_def)
               apply(simp split: if_split_asm)
                     apply(drule cte_map_inj_eq')
                          apply(simp_all)[2]
                    apply(drule_tac p="cte_map src" in valid_mdbD1')
                      subgoal by(simp)
                     subgoal by(simp add: valid_mdb'_def valid_mdb_ctes_def)
                    subgoal by(clarsimp)
                   apply(clarsimp)
                   apply(case_tac z)
                   apply(erule_tac x="(aa, bb)" in allE)+
                   subgoal by(fastforce)
                  apply(drule cte_map_inj_eq')
                       apply(simp_all)[2]
                 apply(drule cte_map_inj_eq')
                      apply(simp_all)[2]
                apply(drule cte_map_inj_eq')
                     apply(simp_all)[2]
               apply(erule_tac x="(aa, bb)" in allE)+
               subgoal by(fastforce)

              apply(simp add: fun_upd_idem)
              apply(subst mdb_insert_abs_sib.next_slot')
                    subgoal by(simp add: mdb_insert_abs_sib_def)
                   apply(simp_all)[5]
              apply(case_tac "ca=src")
               apply(clarsimp simp: modify_map_def)
               subgoal by(fastforce split: if_split_asm)
              apply(case_tac "ca = dest")
               apply(simp)
               apply(case_tac "next_slot src (cdt_list (a)) (cdt a)")
                subgoal by(simp)
               apply(simp)
               apply(clarsimp simp: modify_map_def const_def)
               apply(simp split: if_split_asm)
                 apply(drule_tac p="cte_map src" in valid_mdbD1')
                   subgoal by(simp)
                  apply(simp add: valid_mdb'_def valid_mdb_ctes_def)
                 subgoal by(clarsimp)
                apply(drule cte_map_inj_eq')
                     apply(simp_all)[2]
               apply(erule_tac x=src in allE)+
               subgoal by(fastforce)
              apply(simp)
              apply(case_tac "next_slot ca (cdt_list (a)) (cdt a)")
               subgoal by(simp)
              apply(simp)
              apply(subgoal_tac "cte_at ca a")
               prefer 2
               apply(rule cte_at_next_slot)
                  apply(simp_all)[4]
              apply(clarsimp simp: modify_map_def const_def)
              apply(simp split: if_split_asm)
                    apply(drule cte_map_inj_eq')
                         apply(simp_all)[2]
                   apply(drule_tac p="cte_map src" in valid_mdbD1')
                     subgoal by(simp)
                    subgoal by(simp add: valid_mdb'_def valid_mdb_ctes_def)
                   subgoal by(clarsimp)
                  apply(clarsimp)
                  apply(case_tac z)
                  apply(erule_tac x="(aa, bb)" in allE)+
                  subgoal by(fastforce)
                 apply(drule cte_map_inj_eq')
                      apply(simp_all)[2]
                apply(drule cte_map_inj_eq')
                     apply(simp_all)[2]
               apply(drule cte_map_inj_eq')
                    apply(simp_all)[2]
              apply(erule_tac x="(aa, bb)" in allE)+
              subgoal by(fastforce)
             apply (thin_tac "ctes_of t = t'" for t t')+
             apply (clarsimp simp: modify_map_apply)
             apply (clarsimp simp: revokable_relation_def  split: if_split)
             apply (rule conjI)
             apply clarsimp
              apply (subgoal_tac "mdbRevocable node = isCapRevocable c' (cteCap srcCTE)")
               prefer 2
               apply (case_tac rv')
               subgoal by (clarsimp simp add: const_def modify_map_def split: if_split_asm)
              apply simp
              apply (rule is_cap_revocable_eq, assumption, assumption)
               apply (rule derived_sameRegionAs)
                apply (drule(3) is_derived_eq[THEN iffD1,rotated -1])
                 subgoal by (simp add: cte_wp_at_def)
                apply assumption
               apply assumption
              subgoal by (clarsimp simp: cap_master_cap_simps cte_wp_at_def is_derived_def is_cap_simps
                                  split:if_splits dest!:cap_master_cap_eqDs)
             apply clarsimp
             apply (case_tac srcCTE)
             apply (case_tac rv')
             apply clarsimp
             apply (subgoal_tac "\<exists>cap' node'. ctes_of b (cte_map (aa,bb)) = Some (CTE cap' node')")
              prefer 2
              apply (clarsimp simp: modify_map_def split: if_split_asm)
              apply (case_tac z)
              subgoal by clarsimp
             apply clarsimp
             apply (drule set_cap_caps_of_state_monad)+
             apply (subgoal_tac "null_filter (caps_of_state a) (aa,bb) \<noteq> None")
              prefer 2
              subgoal by (clarsimp simp: cte_wp_at_caps_of_state null_filter_def split: if_splits)

              apply clarsimp
              apply (subgoal_tac "cte_at (aa,bb) a")
               prefer 2
               apply (drule null_filter_caps_of_stateD)
               apply (erule cte_wp_at_weakenE, rule TrueI)
              apply (subgoal_tac "mdbRevocable node = mdbRevocable node'")
               subgoal by clarsimp
              apply (subgoal_tac "cte_map (aa,bb) \<noteq> cte_map dest")
               subgoal by (clarsimp simp: modify_map_def split: if_split_asm)
              apply (erule (5) cte_map_inj)
            apply (wp set_untyped_cap_full_valid_objs set_untyped_cap_as_full_valid_mdb
               set_untyped_cap_as_full_cte_wp_at setUntypedCapAsFull_valid_cap
               setUntypedCapAsFull_cte_wp_at | clarsimp simp: cte_wp_at_caps_of_state| wps)+
         apply (case_tac rv',clarsimp simp:cte_wp_at_ctes_of maskedAsFull_def)
        apply (wp getCTE_wp' get_cap_wp)+
    apply clarsimp
    subgoal by (fastforce elim: cte_wp_at_weakenE)
   apply (clarsimp simp: cte_wp_at'_def)
  apply (thin_tac "ctes_of s = t" for s t)+
  apply (thin_tac "pspace_relation s t" for s t)+
  apply (thin_tac "machine_state t = s" for s t)+
  apply (case_tac "srcCTE")
  apply (rename_tac src_cap' src_node)
  apply (case_tac "rv'")
  apply (rename_tac dest_node)
  apply (clarsimp simp: in_set_cap_cte_at_swp)
  apply (subgoal_tac "cte_at src a \<and> is_derived (cdt a) src c src_cap")
   prefer 2
   subgoal by (fastforce simp: cte_wp_at_def)
  apply (erule conjE)
  apply (subgoal_tac "mdb_insert (ctes_of b) (cte_map src) (maskedAsFull src_cap' c') src_node
                                 (cte_map dest) NullCap dest_node")
   prefer 2
   apply (rule mdb_insert.intro)
     apply (rule mdb_ptr.intro)
      subgoal by (rule vmdb.intro, simp add: valid_mdb_ctes_def)
     apply (erule mdb_ptr_axioms.intro)
    apply (rule mdb_ptr.intro)
     subgoal by (rule vmdb.intro, simp add: valid_mdb_ctes_def)
    apply (erule mdb_ptr_axioms.intro)
   apply (rule mdb_insert_axioms.intro)
        apply (rule refl)
       apply assumption
      apply assumption
     apply assumption
    apply assumption
   apply (erule (5) cte_map_inj)
  apply (frule mdb_insert_der.intro)
   apply (rule mdb_insert_der_axioms.intro)
   apply (simp add: is_derived_eq)
  apply (simp (no_asm_simp) add: cdt_relation_def split: if_split)
  apply (subgoal_tac "descendants_of dest (cdt a) = {}")
   prefer 2
   apply (drule mdb_insert.dest_no_descendants)
   subgoal by (fastforce simp add: cdt_relation_def simp del: split_paired_All)
  apply (subgoal_tac "mdb_insert_abs (cdt a) src dest")
   prefer 2
   apply (erule mdb_insert_abs.intro)
    apply (rule mdb_None)
      apply (erule(1) mdb_insert.descendants_not_dest)
     apply assumption
    apply assumption
   apply assumption
  apply (rule conjI)
   apply (intro impI allI)
   apply (unfold const_def)
   apply (frule(4) iffD1[OF is_derived_eq])
   apply (drule_tac src_cap' = src_cap' in
     maskedAsFull_revokable[where a = c',symmetric])
   apply simp
   apply (subst mdb_insert_child.descendants)
    apply (rule mdb_insert_child.intro)
     apply simp
    apply (rule mdb_insert_child_axioms.intro)
    apply (subst can_be_is [symmetric])
        apply simp
        apply (rule cap_relation_masked_as_full)
         apply (simp+)[3]
      apply simp
     apply simp
    apply (subst (asm) is_cap_revocable_eq, assumption, assumption)
      apply (rule derived_sameRegionAs)
       apply (subst is_derived_eq[symmetric], assumption, assumption,
                    assumption, assumption, assumption)
      apply assumption
     subgoal by (clarsimp simp: cte_wp_at_def is_derived_def is_cap_simps cap_master_cap_simps
                          dest!:cap_master_cap_eqDs)
    apply (subgoal_tac "is_original_cap a src = mdbRevocable src_node")
     prefer 2
     apply (simp add: revokable_relation_def del: split_paired_All)
     apply (erule_tac x=src in allE)
     apply (erule impE)
      apply (clarsimp simp: null_filter_def cte_wp_at_caps_of_state cap_master_cap_simps
       split: if_splits dest!:cap_master_cap_eqDs)
      subgoal by (clarsimp simp: masked_as_full_def is_cap_simps free_index_update_def split: if_splits)
     subgoal by simp
    subgoal by clarsimp
   apply (subst mdb_insert_abs.descendants_child, assumption)
   apply (frule_tac p=ca in in_set_cap_cte_at)
   apply (subst descendants_of_eq')
          prefer 2
          apply assumption
         apply (simp_all)[6]
   apply (simp add: cdt_relation_def split: if_split del: split_paired_All)
   apply clarsimp
   apply (drule (5) cte_map_inj)+
   apply simp
  apply clarsimp
  apply (subst mdb_insert_abs_sib.descendants, erule mdb_insert_abs_sib.intro)
  apply (frule(4) iffD1[OF is_derived_eq])
  apply (drule_tac src_cap' = src_cap' in maskedAsFull_revokable[where a = c',symmetric])
  apply simp
  apply (subst mdb_insert_sib.descendants)
   apply (rule mdb_insert_sib.intro, assumption)
   apply (rule mdb_insert_sib_axioms.intro)
   apply (subst can_be_is [symmetric])
       apply simp
       apply (rule cap_relation_masked_as_full)
        apply (simp+)[3]
     apply simp
    apply simp
   apply simp
   apply (subst (asm) is_cap_revocable_eq, assumption, assumption)
     apply (rule derived_sameRegionAs)
      apply (subst is_derived_eq[symmetric], assumption, assumption,
                   assumption, assumption, assumption)
     apply assumption
    subgoal by (clarsimp simp: cte_wp_at_def is_derived_def is_cap_simps cap_master_cap_simps
                        dest!:cap_master_cap_eqDs)
   apply (subgoal_tac "is_original_cap a src = mdbRevocable src_node")
    subgoal by simp
   apply (simp add: revokable_relation_def del: split_paired_All)
   apply (erule_tac x=src in allE)
   apply (erule impE)
    apply (clarsimp simp: null_filter_def cte_wp_at_caps_of_state split: if_splits)
    subgoal by (clarsimp simp: masked_as_full_def is_cap_simps free_index_update_def split: if_splits)
   subgoal by simp
  apply (simp split: if_split)
  apply (frule_tac p="(aa, bb)" in in_set_cap_cte_at)
  apply (rule conjI)
   apply (clarsimp simp: descendants_of_eq')
   subgoal by (simp add: cdt_relation_def del: split_paired_All)
  apply (clarsimp simp: descendants_of_eq')
  subgoal by (simp add: cdt_relation_def del: split_paired_All)
  done


declare if_split [split]

lemma updateCap_no_0:
  "\<lbrace>\<lambda>s. no_0 (ctes_of s)\<rbrace> updateCap cap ptr \<lbrace>\<lambda>_ s. no_0 (ctes_of s)\<rbrace>"
  apply (simp add: updateCap_def)
  apply (wp getCTE_wp')
  apply (clarsimp simp: cte_wp_at_ctes_of no_0_def)
  done

lemma revokable_relation_prev [simp]:
  "revokable_relation revo cs (modify_map m p (cteMDBNode_update (mdbPrev_update f))) =
  revokable_relation revo cs m"
  apply (rule iffI)
   apply (clarsimp simp add: revokable_relation_def)
   apply (erule allE, erule allE, erule impE, erule exI)
   apply (clarsimp simp: modify_map_def split: if_split_asm)
  apply (clarsimp simp add: revokable_relation_def modify_map_def)
  apply (erule allE, erule allE, erule impE, erule exI)
  apply (case_tac z)
  apply auto
  done

lemma revokable_relation_next [simp]:
  "revokable_relation revo cs (modify_map m p (cteMDBNode_update (mdbNext_update f))) =
  revokable_relation revo cs m"
  apply (rule iffI)
   apply (clarsimp simp add: revokable_relation_def)
   apply (erule allE, erule allE, erule impE, erule exI)
   apply (clarsimp simp: modify_map_def split: if_split_asm)
  apply (clarsimp simp add: revokable_relation_def modify_map_def)
  apply (erule allE, erule allE, erule impE, erule exI)
  apply (case_tac z)
  apply auto
  done

lemma revokable_relation_cap [simp]:
  "revokable_relation revo cs (modify_map m p (cteCap_update f)) =
  revokable_relation revo cs m"
  apply (rule iffI)
   apply (clarsimp simp add: revokable_relation_def)
   apply (erule allE, erule allE, erule impE, erule exI)
   apply (clarsimp simp: modify_map_def split: if_split_asm)
  apply (clarsimp simp add: revokable_relation_def modify_map_def)
  apply (erule allE, erule allE, erule impE, erule exI)
  apply (case_tac z)
  apply auto
  done

lemma mdb_cap_update:
  "cteMDBNode_update f (cteCap_update f' x) =
   cteCap_update f' (cteMDBNode_update f x)"
  by (cases x) simp

lemmas modify_map_mdb_cap =
  modify_map_com [where f="cteMDBNode_update f" and
                        g="cteCap_update f'" for f f',
                  OF mdb_cap_update]

lemma prev_leadstoD:
  "\<lbrakk> m \<turnstile> mdbPrev node \<leadsto> c; m p = Some (CTE cap node);
    valid_dlist m; no_0 m \<rbrakk> \<Longrightarrow>
  c = p"
  by (fastforce simp add: next_unfold' valid_dlist_def Let_def no_0_def)

lemma prev_leadstoI:
  "\<lbrakk> m p = Some (CTE cap node); mdbPrev node \<noteq> 0; valid_dlist m\<rbrakk>
  \<Longrightarrow> m \<turnstile> mdbPrev node \<leadsto> p"
  by (fastforce simp add: valid_dlist_def Let_def next_unfold')

lemma mdb_next_modify_prev:
  "modify_map m x (cteMDBNode_update (mdbPrev_update f)) \<turnstile> a \<leadsto> b = m \<turnstile> a \<leadsto> b"
  by (auto simp add: next_unfold' modify_map_def)

lemma mdb_next_modify_revocable:
  "modify_map m x (cteMDBNode_update (mdbRevocable_update f)) \<turnstile> a \<leadsto> b = m \<turnstile> a \<leadsto> b"
  by (auto simp add: next_unfold' modify_map_def)

lemma mdb_next_modify_cap:
  "modify_map m x (cteCap_update f) \<turnstile> a \<leadsto> b = m \<turnstile> a \<leadsto> b"
  by (auto simp add: next_unfold' modify_map_def)

lemmas mdb_next_modify [simp] =
  mdb_next_modify_prev
  mdb_next_modify_revocable
  mdb_next_modify_cap

lemma in_getCTE:
  "(cte, s') \<in> fst (getCTE p s) \<Longrightarrow> s' = s \<and> cte_wp_at' ((=) cte) p s"
  apply (frule in_inv_by_hoareD [OF getCTE_inv])
  apply (drule use_valid [OF _ getCTE_cte_wp_at], rule TrueI)
  apply (simp add: cte_wp_at'_def)
  done

lemma isMDBParentOf_eq_parent:
  "\<lbrakk> isMDBParentOf c cte;
     weak_derived' (cteCap c) (cteCap c');
     mdbRevocable (cteMDBNode c') = mdbRevocable (cteMDBNode c) \<rbrakk>
  \<Longrightarrow> isMDBParentOf c' cte"
  apply (cases c)
  apply (cases c')
  apply (cases cte)
  apply clarsimp
  apply (clarsimp simp: weak_derived'_def isMDBParentOf_CTE)
  apply (clarsimp simp: sameRegionAs_def2 isCap_simps)
  done

lemma isMDBParentOf_eq_child:
  "\<lbrakk> isMDBParentOf cte c;
     weak_derived' (cteCap c) (cteCap c');
     mdbFirstBadged (cteMDBNode c') = mdbFirstBadged (cteMDBNode c) \<rbrakk>
  \<Longrightarrow> isMDBParentOf cte c'"
  apply (cases c)
  apply (cases c')
  apply (cases cte)
  apply clarsimp
  apply (clarsimp simp: weak_derived'_def isMDBParentOf_CTE)
  apply (clarsimp simp: sameRegionAs_def2 isCap_simps)
  done

lemma isMDBParentOf_eq:
  "\<lbrakk> isMDBParentOf c d;
     weak_derived' (cteCap c) (cteCap c');
     mdbRevocable (cteMDBNode c') = mdbRevocable (cteMDBNode c);
     weak_derived' (cteCap d) (cteCap d');
     mdbFirstBadged (cteMDBNode d') = mdbFirstBadged (cteMDBNode d) \<rbrakk>
  \<Longrightarrow> isMDBParentOf c' d'"
  apply (drule (2) isMDBParentOf_eq_parent)
  apply (erule (2) isMDBParentOf_eq_child)
  done

lemma weak_derived_refl' [intro!, simp]:
  "weak_derived' c c"
  by (simp add: weak_derived'_def)

lemma weak_derived_sym':
  "weak_derived' c d \<Longrightarrow> weak_derived' d c"
  by (clarsimp simp: weak_derived'_def isCap_simps)
end
locale mdb_swap =
  mdb_ptr_src?: mdb_ptr m _ _ src src_cap src_node +
  mdb_ptr_dest?: mdb_ptr m _ _ dest dest_cap dest_node
  for m src src_cap src_node dest dest_cap dest_node +

  assumes neq: "src \<noteq> dest"

  fixes scap dcap

  assumes src_derived: "weak_derived' src_cap scap"
  assumes dest_derived: "weak_derived' dest_cap dcap"

  fixes n'
  defines "n' \<equiv>
    modify_map
      (modify_map
        (modify_map
          (modify_map m src (cteCap_update (\<lambda>_. dcap)))
          dest
          (cteCap_update (\<lambda>_. scap)))
        (mdbPrev src_node)
        (cteMDBNode_update (mdbNext_update (\<lambda>_. dest))))
      (mdbNext src_node)
      (cteMDBNode_update (mdbPrev_update (\<lambda>_. dest)))"

  fixes dest2
  assumes dest2: "n' dest = Some dest2"

  fixes n
  defines "n \<equiv>
             (modify_map
               (modify_map
                 (modify_map
                   (modify_map n'
                    src (cteMDBNode_update (const (cteMDBNode dest2))))
                 dest (cteMDBNode_update (const src_node)))
               (mdbPrev (cteMDBNode dest2)) (cteMDBNode_update (mdbNext_update (\<lambda>_. src))))
             (mdbNext (cteMDBNode dest2)) (cteMDBNode_update (mdbPrev_update (\<lambda>_. src))))"

begin

lemma no_0_n' [intro!]: "no_0 n'" by (auto simp: n'_def)
lemma no_0_n [intro!]: "no_0 n" by (auto simp: n_def)

lemmas n_0_simps [iff] = no_0_simps [OF no_0_n]
lemmas n'_0_simps [iff] = no_0_simps [OF no_0_n']

lemmas neqs [simp] = neq neq [symmetric]

lemma src: "m src = Some (CTE src_cap src_node)" ..
lemma dest: "m dest = Some (CTE dest_cap dest_node)" ..

lemma src_prev:
  "\<lbrakk> mdbPrev src_node = p; p \<noteq> 0\<rbrakk> \<Longrightarrow> \<exists>cap node. m p = Some (CTE cap node) \<and> mdbNext node = src"
  using src
  apply -
  apply (erule dlistEp, simp)
  apply (case_tac cte')
  apply simp
  done

lemma src_next:
  "\<lbrakk> mdbNext src_node = p; p \<noteq> 0\<rbrakk> \<Longrightarrow> \<exists>cap node. m p = Some (CTE cap node) \<and> mdbPrev node = src"
  using src
  apply -
  apply (erule dlistEn, simp)
  apply (case_tac cte')
  apply simp
  done

lemma dest_prev:
  "\<lbrakk> mdbPrev dest_node = p; p \<noteq> 0\<rbrakk> \<Longrightarrow> \<exists>cap node. m p = Some (CTE cap node) \<and> mdbNext node = dest"
  using dest
  apply -
  apply (erule dlistEp, simp)
  apply (case_tac cte')
  apply simp
  done

lemma dest_next:
  "\<lbrakk> mdbNext dest_node = p; p \<noteq> 0\<rbrakk> \<Longrightarrow> \<exists>cap node. m p = Some (CTE cap node) \<and> mdbPrev node = dest"
  using dest
  apply -
  apply (erule dlistEn, simp)
  apply (case_tac cte')
  apply simp
  done

lemma next_dest_prev_src [simp]:
  "(mdbNext dest_node = src) = (mdbPrev src_node = dest)"
  apply (rule iffI)
   apply (drule dest_next, simp)
   apply (clarsimp simp: src)
  apply (drule src_prev, simp)
  apply (clarsimp simp: dest)
  done

lemmas next_dest_prev_src_sym [simp] = next_dest_prev_src [THEN x_sym]

lemma prev_dest_next_src [simp]:
  "(mdbPrev dest_node = src) = (mdbNext src_node = dest)"
  apply (rule iffI)
   apply (drule dest_prev, simp)
   apply (clarsimp simp: src)
  apply (drule src_next, simp)
  apply (clarsimp simp: dest)
  done

lemmas prev_dest_next_src_sym [simp] = prev_dest_next_src [THEN x_sym]

lemma revokable_n':
  "\<lbrakk> n' p = Some (CTE cap node) \<rbrakk> \<Longrightarrow>
   \<exists>cap' node'. m p = Some (CTE cap' node') \<and> mdbRevocable node = mdbRevocable node'"
  by (fastforce simp add: n'_def elim!: modify_map_casesE)

lemma badge_n':
  "\<lbrakk> n' p = Some (CTE cap node) \<rbrakk> \<Longrightarrow>
   \<exists>cap' node'. m p = Some (CTE cap' node') \<and> mdbFirstBadged node = mdbFirstBadged node'"
  by (fastforce simp add: n'_def elim!: modify_map_casesE)

lemma cteMDBNode_update_split_asm:
  "P (cteMDBNode_update f cte) = (\<not> (\<exists>cap mdb. cte = CTE cap mdb \<and> \<not> P (CTE cap (f mdb))))"
  by (cases cte, simp)

lemma revokable:
  "n p = Some (CTE cap node) \<Longrightarrow>
  if p = src then mdbRevocable node = mdbRevocable dest_node
  else if p = dest then mdbRevocable node = mdbRevocable src_node
  else \<exists>cap' node'. m p = Some (CTE cap' node') \<and>
                    mdbRevocable node = mdbRevocable node'"
  apply (drule sym)
  apply (insert src dest dest2 [symmetric])[1]
  apply clarsimp
  apply (rule conjI, clarsimp)
   apply (simp add: n_def n'_def modify_map_apply)
   apply (simp add: modify_map_def const_def split: if_split_asm)
  apply clarsimp
  apply (rule conjI, clarsimp)
   apply (simp add: n_def n'_def modify_map_apply)
   apply (simp add: modify_map_def const_def split: if_split_asm)
  apply (clarsimp simp: n_def)
  apply (clarsimp simp add: modify_map_def map_option_case split: if_split_asm option.splits)
     apply (auto split: cteMDBNode_update_split_asm elim: revokable_n' revokable_n'[OF sym])
  done

lemma badge_n:
  "n p = Some (CTE cap node) \<Longrightarrow>
  if p = src then mdbFirstBadged node = mdbFirstBadged dest_node
  else if p = dest then mdbFirstBadged node = mdbFirstBadged src_node
  else \<exists>cap' node'. m p = Some (CTE cap' node') \<and>
                    mdbFirstBadged node = mdbFirstBadged node'"
  apply (drule sym)
  apply (insert src dest dest2 [symmetric])[1]
  apply clarsimp
  apply (rule conjI, clarsimp)
   apply (simp add: n_def n'_def modify_map_apply)
   apply (simp add: modify_map_def const_def split: if_split_asm)
  apply clarsimp
  apply (rule conjI, clarsimp)
   apply (simp add: n_def n'_def modify_map_apply)
   apply (simp add: modify_map_def const_def split: if_split_asm)
  apply (clarsimp simp: n_def)
  apply (clarsimp simp add: modify_map_def map_option_case split: if_split_asm option.splits)
     apply (auto split: cteMDBNode_update_split_asm elim: badge_n' badge_n'[OF sym])
  done

lemma n'_cap:
  "n' p = Some (CTE cap node) \<Longrightarrow>
  if p = src then cap = dcap
  else if p = dest then cap = scap
  else \<exists>node'. m p = Some (CTE cap node')"
  apply clarsimp
  apply (rule conjI)
   apply (fastforce simp add: n'_def modify_map_cases)
  apply clarsimp
  apply (rule conjI)
   apply (fastforce simp add: n'_def modify_map_cases)
  apply clarsimp
  apply (simp add: n'_def modify_map_cases)
  apply fastforce
  done

lemma n_cap:
  "n p = Some (CTE cap node) \<Longrightarrow>
  if p = src then cap = dcap
  else if p = dest then cap = scap
  else \<exists>node'. m p = Some (CTE cap node')"
  apply clarsimp
  apply (rule conjI, clarsimp)
   apply (drule sym)
   apply (insert src dest dest2 [symmetric])[1]
   apply (simp add: n_def n'_def modify_map_apply)
   apply (simp add: modify_map_def split: if_split_asm)
  apply clarsimp
  apply (rule conjI, clarsimp)
   apply (drule sym)
   apply (insert src dest dest2 [symmetric])[1]
   apply (simp add: n_def n'_def modify_map_apply)
   apply (simp add: modify_map_def split: if_split_asm)
  apply clarsimp
  apply (insert src dest dest2)
  apply (clarsimp simp: n_def modify_map_cases)
  apply (auto dest: n'_cap)
  done

lemma dest2_cap [simp]:
  "cteCap dest2 = scap"
  using dest2 by (cases dest2) (simp add: n'_cap)

lemma n'_next:
  "n' p = Some (CTE cap node) \<Longrightarrow>
  if p = mdbPrev src_node then mdbNext node = dest
  else \<exists>cap' node'. m p = Some (CTE cap' node') \<and> mdbNext node = mdbNext node'"
  apply (simp add: n'_def)
  apply (rule conjI)
   apply clarsimp
   apply (simp add: modify_map_cases)
   apply clarsimp
  apply clarsimp
  apply (auto simp add: modify_map_cases)
  done

lemma dest2_next:
  "mdbNext (cteMDBNode dest2) =
  (if dest = mdbPrev src_node then dest else mdbNext dest_node)"
  using dest2 dest by (cases dest2) (clarsimp dest!: n'_next)

lemma n'_prev:
  "n' p = Some (CTE cap node) \<Longrightarrow>
  if p = mdbNext src_node then mdbPrev node = dest
  else \<exists>cap' node'. m p = Some (CTE cap' node') \<and> mdbPrev node = mdbPrev node'"
  apply (simp add: n'_def)
  apply (rule conjI)
   apply clarsimp
   apply (simp add: modify_map_cases)
   apply clarsimp
  apply clarsimp
  by (auto simp add: modify_map_cases)

lemma dest2_prev:
  "mdbPrev (cteMDBNode dest2) =
  (if dest = mdbNext src_node then dest else mdbPrev dest_node)"
  using dest2 dest by (cases dest2) (clarsimp dest!: n'_prev)

lemma dest2_rev [simp]:
  "mdbRevocable (cteMDBNode dest2) = mdbRevocable dest_node"
  using dest2 dest by (cases dest2) (clarsimp dest!: revokable_n')

lemma dest2_bdg [simp]:
  "mdbFirstBadged (cteMDBNode dest2) = mdbFirstBadged dest_node"
  using dest2 dest by (cases dest2) (clarsimp dest!: badge_n')

definition
  "dest2_node \<equiv> MDB (if dest = mdbPrev src_node then dest else mdbNext dest_node)
                    (if dest = mdbNext src_node then dest else mdbPrev dest_node)
                    (mdbRevocable dest_node)
                    (mdbFirstBadged dest_node)"

lemma dest2_parts [simp]:
  "dest2 = CTE scap dest2_node"
  unfolding dest2_node_def
  apply (subst dest2_prev [symmetric])
  apply (subst dest2_next [symmetric])
  apply (subst dest2_rev [symmetric])
  apply (subst dest2_bdg [symmetric])
  apply (subst dest2_cap [symmetric])
  apply (cases dest2)
  apply (rename_tac mdbnode)
  apply (case_tac mdbnode)
  apply (simp del: dest2_cap)
  done

lemma prev_dest_src [simp]:
  "(mdbPrev dest_node = mdbPrev src_node) = (mdbPrev dest_node = 0 \<and> mdbPrev src_node = 0)"
  apply (subst mdb_ptr.p_prev_eq)
    apply (rule mdb_ptr_axioms)
   apply rule
  apply simp
  done

lemmas prev_dest_src_sym [simp] = prev_dest_src [THEN x_sym]

lemma next_dest_src [simp]:
  "(mdbNext dest_node = mdbNext src_node) = (mdbNext dest_node = 0 \<and> mdbNext src_node = 0)"
  apply (subst mdb_ptr.p_next_eq)
    apply (rule mdb_ptr_axioms)
   apply rule
  apply simp
  done

lemmas next_dest_src_sym [simp] = next_dest_src [THEN x_sym]

definition
  s_d_swp :: "machine_word \<Rightarrow> machine_word"
where
  "s_d_swp p \<equiv> s_d_swap p src dest"

declare s_d_swp_def [simp]


lemma n_exists:
  "m p = Some (CTE cap node) \<Longrightarrow> \<exists>cap' node'. n p = Some (CTE cap' node')"
  apply (simp add: n_def n'_def)
  apply (intro modify_map_exists)
  apply simp
  done

lemma m_exists:
  "n p = Some (CTE cap node) \<Longrightarrow> \<exists>cap' node'. m p = Some (CTE cap' node')"
  apply (simp add: n_def n'_def)
  apply (drule modify_map_exists_rev, clarsimp)+
  done

lemma next_src_node [simp]:
  "(m (mdbNext src_node) = Some (CTE cap src_node)) = False"
  apply clarsimp
  apply (subgoal_tac "m \<turnstile> mdbNext src_node \<leadsto> mdbNext src_node")
   apply simp
  apply (simp add: mdb_next_unfold)
  done

lemma mdbNext_update_self [simp]:
  "(mdbNext_update (\<lambda>_. x) node = node) = (mdbNext node = x)"
  by (cases node) auto

lemmas p_next_eq_src = mdb_ptr_src.p_next_eq

lemma next_m_n:
  shows "m \<turnstile> p \<leadsto> p' = n \<turnstile> s_d_swp p \<leadsto> s_d_swp p'"
  using src dest
  apply (simp add: n_def n'_def modify_map_mdb_cap const_def)
  apply (simp add: s_d_swap_def)
  apply (rule conjI, clarsimp)
   apply (rule conjI, clarsimp)
    apply (clarsimp simp: mdb_next_unfold modify_map_cases dest2_node_def
                    split: if_split_asm)
   apply clarsimp
   apply (rule conjI, clarsimp)
    apply (clarsimp simp: mdb_next_unfold modify_map_cases)
    apply (auto simp add: dest2_node_def split: if_split_asm)[1]
   apply clarsimp
   apply (simp add: mdb_next_unfold modify_map_cases)
   apply (simp add: dest2_node_def const_def)
   apply (intro impI)
   apply (rule conjI, clarsimp)
   apply (rule iffI)
    apply clarsimp
   apply clarsimp
  apply clarsimp
  apply (rule conjI, clarsimp)
   apply (rule conjI, clarsimp)
    apply (clarsimp simp: mdb_next_unfold modify_map_cases dest2_node_def)
    apply (rule conjI)
     apply clarsimp
     apply (rule_tac x="CTE dest_cap (mdbNext_update (\<lambda>_. src) src_node)"
                     in exI)
     apply simp
     apply (rule_tac x=dest_node in exI)
     apply clarsimp
    apply clarsimp
   apply clarsimp
   apply (rule conjI, clarsimp)
    apply (clarsimp simp: mdb_next_unfold modify_map_cases dest2_node_def
                    split: if_split_asm)
   apply clarsimp
   apply (clarsimp simp: mdb_next_unfold modify_map_cases dest2_node_def)
   apply (rule conjI, clarsimp)
   apply clarsimp
   apply (rule iffI)
    apply clarsimp
    apply (rule_tac x="CTE dest_cap src_node" in exI)
    apply simp
    apply (case_tac "mdbPrev src_node = dest")
     apply clarsimp
    apply clarsimp
   apply clarsimp
  apply clarsimp
  apply (rule conjI, clarsimp)
   apply (simp add: mdb_next_unfold modify_map_cases dest2_node_def)
   apply (rule conjI, clarsimp)
    apply (case_tac "m p", simp)
    apply (case_tac a)
    apply (rename_tac cap node)
    apply clarsimp
    apply (frule p_next_eq_src [where p'=p])
    apply simp
    apply (case_tac "mdbNext src_node = 0", simp)
    apply simp
    apply (rule allI)
    apply (rule disjCI2)
    apply simp
    apply (erule disjE)
     apply clarsimp
    apply (rule disjCI2)
    apply (clarsimp del: notI)
    apply (rule notI)
    apply (erule dlistEn [where p=p])
     apply clarsimp
    apply clarsimp
   apply clarsimp
   apply (case_tac "m p", simp)
   apply (case_tac a)
   apply (rename_tac cap node)
   apply clarsimp
   apply (case_tac "mdbPrev dest_node = p")
    apply simp
    apply (frule dest_prev, clarsimp)
    apply (elim exE conjE)
    apply simp
    apply (case_tac "mdbNext src_node = p")
     apply fastforce
    apply fastforce
   apply (subgoal_tac "dest \<noteq> mdbNext node")
    prefer 2
    apply (rule notI)
    apply (erule dlistEn [where p=p])
     apply clarsimp
    apply clarsimp
   apply simp
   apply (rule allI)
   apply (cases "mdbNext src_node = p")
    apply simp
    apply (subgoal_tac "mdbPrev src_node \<noteq> p")
     prefer 2
     apply clarsimp
    apply simp
    apply (subgoal_tac "src \<noteq> mdbNext node")
     apply clarsimp
    apply (rule notI)
    apply (erule dlistEn [where p=p])
     apply clarsimp
    apply clarsimp
   apply simp
   apply (subgoal_tac "src \<noteq> mdbPrev node")
    prefer 2
    apply (rule notI)
    apply (erule dlistEp [where p=p])
     apply clarsimp
    apply clarsimp
   apply (rule disjCI2)
   apply simp
   apply (erule disjE)
    apply clarsimp
   apply simp
   apply (rule disjCI)
   apply simp
   apply (erule dlistEn [where p=p])
    apply clarsimp
   apply clarsimp
  apply clarsimp
  apply (rule conjI, clarsimp)
   apply (simp add: mdb_next_unfold modify_map_cases dest2_node_def)
   apply (case_tac "m p", simp)
   apply (case_tac a)
   apply (rename_tac cap node)
   apply simp
   apply (rule conjI)
    apply (rule impI)
    apply simp
    apply (rule iffI)
     apply simp
     apply (rule dlistEn [where p=p], assumption, clarsimp)
     apply clarsimp
    apply (elim exE conjE)
    apply (case_tac "mdbPrev src_node = p")
     apply simp
     apply (drule src_prev, clarsimp)
     apply clarsimp
    apply clarsimp
    apply (drule p_next_eq_src [where p'=p])
    apply simp
   apply clarsimp
   apply (rule iffI)
    apply simp
    apply (subgoal_tac "mdbPrev src_node = p")
     prefer 2
     apply (erule dlistEn [where p=p], clarsimp)
     apply clarsimp
    apply fastforce
   apply (elim exE conjE)
   apply simp
   apply (case_tac "mdbPrev dest_node = p")
    apply (frule dest_prev)
     apply clarsimp
    apply hypsubst_thin
    apply clarsimp
   apply simp
   apply (case_tac "mdbNext src_node = p")
    apply simp
    apply (elim exE conjE)
    apply (frule src_next, clarsimp)
    apply simp
    apply (case_tac "mdbPrev src_node = p")
     apply clarsimp
    apply (subgoal_tac "mdbNext (cteMDBNode z) = mdbNext node")
     prefer 2
     apply (case_tac nodea)
     apply (case_tac z)
     apply (rename_tac capability mdbnode)
     apply (case_tac mdbnode)
     apply clarsimp
    apply simp
    apply (rule dlistEn [where p=p], assumption, clarsimp)
    apply clarsimp
   apply simp
   apply (case_tac "mdbPrev src_node = p")
    apply simp
    apply (frule src_prev, clarsimp)
    apply simp
   apply simp
   apply (rule dlistEn [where p=p], assumption, clarsimp)
   apply clarsimp
  apply clarsimp
  apply (simp add: mdb_next_unfold modify_map_cases dest2_node_def)
  apply (rule conjI)
   apply (rule impI)
   apply simp
   apply (case_tac "m p", simp)
   apply (case_tac a)
   apply (rename_tac cap node)
   apply simp
   apply (case_tac "mdbPrev src_node \<noteq> p")
    apply simp
   apply simp
   apply (frule src_prev, clarsimp)
   apply simp
  apply clarsimp
  apply (case_tac "m p", simp)
  apply (case_tac a)
  apply (rename_tac cap node)
  apply simp
  apply (case_tac "mdbPrev dest_node = p")
   apply simp
   apply (frule dest_prev, clarsimp)
   apply clarsimp
  apply simp
  apply (case_tac "mdbPrev src_node = p")
   apply simp
   apply (frule src_prev, clarsimp)
   apply fastforce
  apply simp
  apply (case_tac "mdbNext src_node = p")
   apply simp
  apply simp
  done

lemma n_next:
  "n p = Some (CTE cap node) \<Longrightarrow>
  if p = dest then
    (if mdbNext src_node = dest then mdbNext node = src
    else mdbNext node = mdbNext src_node)
  else if p = src then
    (if mdbNext dest_node = src then mdbNext node = dest
    else mdbNext node = mdbNext dest_node)
  else if p = mdbPrev src_node then mdbNext node = dest
  else if p = mdbPrev dest_node then mdbNext node = src
  else \<exists>cap' node'. m p = Some (CTE cap' node') \<and> mdbNext node = mdbNext node'"
  apply (simp add: n_def del: dest2_parts split del: if_split)
  apply (simp only: dest2_next dest2_prev split del: if_split)
  apply (simp add: dest2_node_def split del: if_split)
  apply (simp add: n'_def const_def cong: if_cong split del: if_split)
  apply(case_tac "p=dest")
   apply(clarsimp simp: modify_map_cases const_def split: if_split_asm)
  apply(case_tac "p=src")
   apply(simp split del: if_split)
   apply(clarsimp simp: modify_map_cases const_def split: if_split_asm)
  apply(case_tac "p=mdbPrev src_node")
   apply(simp split del: if_split)
   apply(clarsimp simp: modify_map_cases const_def split: if_split_asm)
    apply(fastforce)
   apply(fastforce)
  apply(case_tac "p=mdbPrev dest_node")
   apply(simp split del: if_split)
   apply(clarsimp simp: modify_map_cases const_def split: if_split_asm)
   apply(fastforce)
  apply(simp split del: if_split)
  apply (clarsimp simp: modify_map_cases const_def split: if_split_asm)
    apply(fastforce)+
  done

lemma parent_of_m_n:
  "m \<turnstile> p parentOf c =
   n \<turnstile> s_d_swp p parentOf s_d_swp c"
  apply (clarsimp simp add: parentOf_def)
  apply (rule iffI)
   apply clarsimp
   apply (case_tac cte, case_tac cte')
   apply (rename_tac cap0 node0 cap1 node1)
   apply clarsimp
   apply (subgoal_tac "\<exists>cap0' node0'. n (s_d_swap c src dest) = Some (CTE cap0' node0')")
    prefer 2
    apply (simp add: s_d_swap_def)
    apply (fastforce intro: n_exists)
   apply (subgoal_tac "\<exists>cap1' node1'. n (s_d_swap p src dest) = Some (CTE cap1' node1')")
    prefer 2
    apply (simp add: s_d_swap_def)
    apply (fastforce intro: n_exists)
   apply clarsimp
   apply (insert src_derived dest_derived)[1]
   apply (erule isMDBParentOf_eq)
      apply simp
      apply (drule n_cap)+
      subgoal by (simp add: s_d_swap_def src dest split: if_split_asm)
     apply simp
     apply (drule revokable)+
     subgoal by (simp add: s_d_swap_def src dest split: if_split_asm)
    apply simp
    apply (drule n_cap)+
    subgoal by (simp add: s_d_swap_def src dest split: if_split_asm)
   apply simp
   apply (drule badge_n)+
   subgoal by (simp add: s_d_swap_def src dest split: if_split_asm)
  apply clarsimp
  apply (case_tac cte, case_tac cte')
  apply (rename_tac cap0 node0 cap1 node1)
  apply clarsimp
  apply (subgoal_tac "\<exists>cap0' node0' cap1' node1'.
                      m c = Some (CTE cap0' node0') \<and>
                      m p = Some (CTE cap1' node1')")
   prefer 2
   apply (drule m_exists)+
   apply clarsimp
   apply (simp add: s_d_swap_def src dest split: if_split_asm)
  apply clarsimp
  apply (insert src_derived dest_derived)[1]
  apply (erule isMDBParentOf_eq)
     apply simp
     apply (rule weak_derived_sym')
     apply (drule n_cap)+
     apply (simp add: s_d_swap_def src dest split: if_split_asm)
    apply simp
    apply (drule revokable)+
    subgoal by (simp add: s_d_swap_def src dest split: if_split_asm)
   apply simp
   apply (rule weak_derived_sym')
   apply (drule n_cap)+
   subgoal by (simp add: s_d_swap_def src dest split: if_split_asm)
  apply simp
  apply (drule badge_n)+
  subgoal by (simp add: s_d_swap_def src dest split: if_split_asm)
  done

lemma parency_m_n:
  assumes "m \<turnstile> p \<rightarrow> p'"
  shows "n \<turnstile> s_d_swp p \<rightarrow> s_d_swp p'" using assms
proof induct
  case (direct_parent c)
  thus ?case
    apply -
    apply (rule subtree.direct_parent)
      apply (subst (asm) next_m_n, assumption)
     apply simp
    apply (subst (asm) parent_of_m_n, assumption)
    done
next
  case (trans_parent c c')
  thus ?case
    apply -
    apply (erule subtree.trans_parent)
      apply (subst (asm) next_m_n, assumption)
     apply simp
    apply (subst (asm) parent_of_m_n, assumption)
    done
qed

lemma parency_n_m:
  assumes "n \<turnstile> p \<rightarrow> p'"
  shows "m \<turnstile> s_d_swp p \<rightarrow> s_d_swp p'" using assms
proof induct
  case (direct_parent c)
  thus ?case
    apply -
    apply (rule subtree.direct_parent)
      apply (subst next_m_n, simp)
     apply simp
    apply (subst parent_of_m_n, simp)
    done
next
  case (trans_parent c c')
  thus ?case
    apply -
    apply (erule subtree.trans_parent)
      apply (subst next_m_n, simp)
     apply simp
    apply (subst parent_of_m_n, simp)
    done
qed

lemma parency:
  "n \<turnstile> p \<rightarrow> p' = m \<turnstile> s_d_swp p \<rightarrow> s_d_swp p'"
  apply (rule iffI)
   apply (erule parency_n_m)
  apply (drule parency_m_n)
  apply simp
  done

lemma descendants:
  "descendants_of' p n =
  (let swap = \<lambda>S. S - {src,dest} \<union>
                (if src \<in> S then {dest} else {}) \<union>
                (if dest \<in> S then {src} else {}) in
  swap (descendants_of' (s_d_swp p) m))"
  apply (simp add: Let_def parency descendants_of'_def s_d_swap_def)
  apply auto
  done

end

lemma inj_on_descendants_cte_map:
  "\<lbrakk> valid_mdb s;
     valid_objs s; pspace_distinct s; pspace_aligned s \<rbrakk> \<Longrightarrow>
  inj_on cte_map (descendants_of p (cdt s))"
  apply (clarsimp simp add: inj_on_def)
  apply (drule (1) descendants_of_cte_at)+
  apply (drule (5) cte_map_inj_eq)
  apply simp
  done

lemmas revokable_relation_simps [simp del] =
  revokable_relation_cap revokable_relation_next revokable_relation_prev

declare if_split [split del]

(*
lemma corres_bind_ext:
"corres_underlying srel nf rrel G G' g (g') \<Longrightarrow>
corres_underlying srel nf rrel G G' (do do_extended_op (return ()); g od) (g')"
  apply (simp add: corres_underlying_def do_extended_op_def return_def gets_def get_def put_def bind_def select_f_def modify_def mk_ef_def wrap_ext_op_det_ext_ext_def wrap_ext_op_unit_def)
  done
*)

(* consider putting in AINVS or up above cteInsert_corres *)
lemma next_slot_eq:
  "\<lbrakk>next_slot p t' m' = x; t' = t; m' = m\<rbrakk> \<Longrightarrow> next_slot p t m = x"
  by simp

lemma inj_on_image_set_diff15 : (* for compatibility of assumptions *)
  "\<lbrakk>inj_on f C; A \<subseteq> C; B \<subseteq> C\<rbrakk> \<Longrightarrow> f ` (A - B) = f ` A - f ` B"
by (rule inj_on_image_set_diff; auto)

lemma cteSwap_corres:
  assumes srcdst: "src' = cte_map src" "dest' = cte_map dest"
  assumes scr: "cap_relation scap scap'"
  assumes dcr: "cap_relation dcap dcap'"
  assumes wf_caps: "wellformed_cap scap" "wellformed_cap dcap"
  notes trans_state_update'[symmetric,simp]
  shows "corres dc
         (valid_objs and pspace_aligned and pspace_distinct and
          valid_mdb and valid_list and
          (\<lambda>s. cte_wp_at (weak_derived scap) src s \<and>
               cte_wp_at (weak_derived dcap) dest s \<and>
               src \<noteq> dest \<and> (\<forall>cap. tcb_cap_valid cap src s)
                  \<and> (\<forall>cap. tcb_cap_valid cap dest s)))
         (valid_mdb' and pspace_aligned' and pspace_distinct' and
          (\<lambda>s. cte_wp_at' (weak_derived' scap' o cteCap) src' s \<and>
               cte_wp_at' (weak_derived' dcap' o cteCap) dest' s))
         (cap_swap scap src dcap dest) (cteSwap scap' src' dcap' dest')"
  (is "corres _ ?P ?P' _ _") using assms including no_pre
  supply None_upd_eq[simp del]
  apply (unfold cap_swap_def cteSwap_def)
  apply (cases "src=dest")
   apply (rule corres_assume_pre)
   apply simp
  apply (rule corres_assume_pre)
  apply (subgoal_tac "cte_map src \<noteq> cte_map dest")
   prefer 2
   apply (erule cte_map_inj)
       apply (fastforce simp: cte_wp_at_def)
      apply (fastforce simp: cte_wp_at_def)
     apply simp
    apply simp
   apply simp
  apply (thin_tac "t : state_relation" for t)
  apply (thin_tac "(P and (\<lambda>s. Q s)) s" for Q P)
  apply (thin_tac "(P and (\<lambda>s. Q s)) s'" for Q P)
  apply clarsimp
  apply (rule corres_symb_exec_r)
     prefer 2
     apply (rule getCTE_sp)
    defer
    apply wp
   apply (rule no_fail_pre, wp)
   apply (clarsimp simp: cte_wp_at'_def)
  apply (rule corres_no_failI)
   apply (rule no_fail_pre)
    apply (wp hoare_weak_lift_imp getCTE_wp' updateCap_no_0 updateCap_ctes_of_wp|
           simp add: cte_wp_at_ctes_of)+
   apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def modify_map_exists_eq)
   apply (rule conjI)
    apply clarsimp
    apply (erule (2) valid_dlistEp)
    apply simp
   apply (rule conjI)
    apply clarsimp
    apply (erule (2) valid_dlistEn)
    apply simp
   apply clarsimp
   apply (case_tac cte)
   apply (rename_tac cap node)
   apply (case_tac cte1)
   apply (rename_tac src_cap src_node)
   apply (case_tac ctea)
   apply (rename_tac dest_cap dest_node)
   apply clarsimp
   apply (rule conjI, clarsimp)
    apply (subgoal_tac "mdbPrev node = mdbNext src_node \<or>
                        mdbPrev node = mdbPrev dest_node")
     apply (erule disjE)
      apply simp
      apply (erule (1) valid_dlistEn, simp)
      apply simp
     apply (erule_tac p="cte_map dest" in valid_dlistEp, assumption, simp)
     apply simp
    apply (auto simp: modify_map_if split: if_split_asm)[1]
   apply clarsimp
   apply (subgoal_tac "mdbNext node = mdbPrev src_node \<or>
                       mdbNext node = mdbNext dest_node")
    apply (erule disjE)
     apply simp
     apply (erule (1) valid_dlistEp, simp)
     apply simp
    apply (erule_tac p="cte_map dest" in valid_dlistEn, assumption, simp)
    apply simp
   apply (auto simp: modify_map_if split: if_split_asm)[1]
  apply (clarsimp simp: corres_underlying_def in_monad
                        state_relation_def)
  apply (clarsimp simp: valid_mdb'_def)
  apply (drule(1) pspace_relationsD)
  apply (drule (12) set_cap_not_quite_corres)
      apply (erule cte_wp_at_weakenE, rule TrueI)
     apply assumption+
   apply (rule refl)
  apply (elim exE conjE)
  apply (rule bind_execI, assumption)
  apply (drule updateCap_stuff, elim conjE, erule(1) impE)
  apply (subgoal_tac "valid_objs t \<and> pspace_distinct t \<and> pspace_aligned t \<and> cte_at dest t")
   prefer 2
   apply (rule conjI)
    apply (erule use_valid, rule set_cap_valid_objs)
    apply simp
    apply (drule_tac p=dest in cte_wp_at_norm, clarsimp)
    apply (drule (1) cte_wp_valid_cap)
    apply (erule (2) weak_derived_valid_cap)
   apply (fastforce elim: use_valid [OF _ set_cap_aligned]
                         use_valid [OF _ set_cap_cte_at]
                         use_valid [OF _ set_cap_distinct]
                         cte_wp_at_weakenE)
  apply (elim conjE)
  apply (drule (14) set_cap_not_quite_corres)
       apply simp
      apply assumption+
   apply (rule refl)
  apply (elim exE conjE)
  apply (rule bind_execI, assumption)
  apply (clarsimp simp: exec_gets)
  apply (clarsimp simp: set_cdt_def bind_assoc)

  apply (clarsimp simp: set_original_def bind_assoc exec_get exec_put exec_gets modify_def cap_swap_ext_def
         update_cdt_list_def set_cdt_list_def simp del: fun_upd_apply
        | rule refl | clarsimp simp: put_def simp del: fun_upd_apply )+
  apply (simp cong: option.case_cong)
  apply (drule updateCap_stuff, elim conjE, erule(1) impE)
  apply (drule (2) updateMDB_the_lot')
     apply (erule (1) impE, assumption)
    apply (fastforce simp only: no_0_modify_map)
   apply assumption
  apply (elim conjE TrueE, simp only:)
  apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption)
  apply (drule in_getCTE, elim conjE, simp only:)
  apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption)
  apply (elim conjE TrueE, simp only:)
  apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption)
  apply (elim conjE TrueE, simp only:)
  apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption)
  apply (elim conjE TrueE, simp only:)
  apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption)
  apply (simp only: pspace_relations_def refl)
  apply (rule conjI, rule TrueI)+
  apply (thin_tac "ksMachineState t = p" for t p)+
  apply (thin_tac "ksCurThread t = p" for t p)+
  apply (thin_tac "ksReadyQueues t = p" for t p)+
  apply (thin_tac "ksSchedulerAction t = p" for t p)+
  apply (thin_tac "machine_state t = p" for t p)+
  apply (thin_tac "cur_thread t = p" for t p)+
  apply (thin_tac "ksDomScheduleIdx t = p" for t p)+
  apply (thin_tac "ksDomSchedule t = p" for t p)+
  apply (thin_tac "ksCurDomain t = p" for t p)+
  apply (thin_tac "ksDomainTime t = p" for t p)+
  apply (simp only: simp_thms no_0_modify_map)
  apply (clarsimp simp: cte_wp_at_ctes_of cong: if_cong)
  apply (thin_tac "ctes_of x = y" for x y)+
  apply (case_tac cte1)
  apply (rename_tac src_cap src_node)
  apply (case_tac cte)
  apply (rename_tac dest_cap dest_node)
  apply clarsimp
  apply (subgoal_tac "mdb_swap (ctes_of b) (cte_map src) src_cap src_node
                               (cte_map dest)  dest_cap dest_node scap' dcap' cte2")
   prefer 2
   apply (rule mdb_swap.intro)
     apply (rule mdb_ptr.intro)
      apply (erule vmdb.intro)
     apply (erule mdb_ptr_axioms.intro)
    apply (rule mdb_ptr.intro)
     apply (erule vmdb.intro)
    apply (erule mdb_ptr_axioms.intro)
   apply (erule mdb_swap_axioms.intro)
     apply (erule weak_derived_sym')
    apply (erule weak_derived_sym')
   apply assumption
  apply (thin_tac "ksMachineState t = p" for t p)+
  apply (thin_tac "ksCurThread t = p" for t p)+
  apply (thin_tac "ksReadyQueues t = p" for t p)+
  apply (thin_tac "ksSchedulerAction t = p" for t p)+
  apply (thin_tac "ready_queues t = p" for t p)+
  apply (thin_tac "cur_domain t = p" for t p)+
  apply (thin_tac "ksDomScheduleIdx t = p" for t p)+
  apply (thin_tac "ksDomSchedule t = p" for t p)+
  apply (thin_tac "ksCurDomain t = p" for t p)+
  apply (thin_tac "ksDomainTime t = p" for t p)+
  apply (thin_tac "idle_thread t = p" for t p)+
  apply (thin_tac "work_units_completed t = p" for t p)+
  apply (thin_tac "domain_index t = p" for t p)+
  apply (thin_tac "domain_list t = p" for t p)+
  apply (thin_tac "domain_time t = p" for t p)+
  apply (thin_tac "ekheap t = p" for t p)+
  apply (thin_tac "scheduler_action t = p" for t p)+
  apply (thin_tac "ksArchState t = p" for t p)+
  apply (thin_tac "gsCNodes t = p" for t p)+
  apply (thin_tac "ksWorkUnitsCompleted t = p" for t p)+
  apply (thin_tac "ksInterruptState t = p" for t p)+
  apply (thin_tac "ksIdleThread t = p" for t p)+
  apply (thin_tac "gsUserPages t = p" for t p)+
  apply (thin_tac "pspace_relation s s'" for s s')+
  apply (thin_tac "ekheap_relation e p" for e p)+
  apply (thin_tac "interrupt_state_relation n s s'" for n s s')+
  apply (thin_tac "(s,s') \<in> arch_state_relation" for s s')+
  apply (rule conjI)
   subgoal by (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv AARCH64.data_at_def)
  apply(subst conj_assoc[symmetric])
  apply (rule conjI)
   prefer 2
   apply (clarsimp simp add: revokable_relation_def in_set_cap_cte_at
                   simp del: split_paired_All)
   apply (drule set_cap_caps_of_state_monad)+
   apply (simp del: split_paired_All split: if_split)
   apply (rule conjI)
    apply (clarsimp simp: cte_wp_at_caps_of_state simp del: split_paired_All)
    apply (drule(1) mdb_swap.revokable)
    apply (erule_tac x="dest" in allE)
    apply (erule impE)
     subgoal by (clarsimp simp: null_filter_def weak_derived_Null split: if_splits)
    apply simp
   apply (clarsimp simp del: split_paired_All)
   apply (rule conjI)
    apply (clarsimp simp: cte_wp_at_caps_of_state simp del: split_paired_All)
    apply (drule (1) mdb_swap.revokable)
    apply (subgoal_tac "cte_map (aa,bb) \<noteq> cte_map src")
     apply (simp del: split_paired_All)
     apply (erule_tac x="src" in allE)
     apply (erule impE)
      subgoal by (clarsimp simp: null_filter_def weak_derived_Null split: if_splits)
     subgoal by simp
    apply (drule caps_of_state_cte_at)+
    apply (erule (5) cte_map_inj)
   apply (clarsimp simp: cte_wp_at_caps_of_state simp del: split_paired_All)
   apply (drule (1) mdb_swap.revokable)
   apply (subgoal_tac "null_filter (caps_of_state a) (aa,bb) \<noteq> None")
    prefer 2
    subgoal by (clarsimp simp: null_filter_def split: if_splits)
   apply clarsimp
   apply (subgoal_tac "cte_map (aa,bb) \<noteq> cte_map src")
    apply (subgoal_tac "cte_map (aa,bb) \<noteq> cte_map dest")
     subgoal by (clarsimp simp del: split_paired_All)
    apply (drule caps_of_state_cte_at)+
    apply (drule null_filter_caps_of_stateD)+
    apply (erule cte_map_inj, erule cte_wp_cte_at, assumption+)
   apply (drule caps_of_state_cte_at)+
   apply (drule null_filter_caps_of_stateD)+
   apply (erule cte_map_inj, erule cte_wp_cte_at, assumption+)
  apply (subgoal_tac "no_loops (ctes_of b)")
   prefer 2
   subgoal by (simp add: valid_mdb_ctes_def mdb_chain_0_no_loops)
  apply (subgoal_tac "mdb_swap_abs (cdt a) src dest a")
   prefer 2
   apply (erule mdb_swap_abs.intro)
      apply (erule cte_wp_at_weakenE, rule TrueI)
     apply (erule cte_wp_at_weakenE, rule TrueI)
    apply (rule refl)
   apply assumption
  apply (frule mdb_swap_abs''.intro)
  apply (drule_tac t="cdt_list (a)" in mdb_swap_abs'.intro)
   subgoal by (simp add: mdb_swap_abs'_axioms_def)
  apply (thin_tac "modify_map m f p p' = t" for m f p p' t)
  apply(rule conjI)
   apply (simp add: cdt_relation_def del: split_paired_All)
   apply (intro allI impI)
   apply (subst mdb_swap.descendants, assumption)
   apply (subst mdb_swap_abs.descendants, assumption)
   apply (simp add: mdb_swap_abs.s_d_swp_def mdb_swap.s_d_swp_def
              del: split_paired_All)
   apply (subst image_Un)+
   apply (subgoal_tac "cte_at (s_d_swap c src dest) a")
    prefer 2
    apply (simp add: s_d_swap_def split: if_split)
    apply (rule conjI, clarsimp simp: cte_wp_at_caps_of_state)
    apply (rule impI, rule conjI, clarsimp simp: cte_wp_at_caps_of_state)
    apply (fastforce dest: in_set_cap_cte_at)
   apply (subgoal_tac "s_d_swap (cte_map c) (cte_map src) (cte_map dest) =
                       cte_map (s_d_swap c src dest)")
    prefer 2
    apply (simp add: s_d_swap_def split: if_splits)
    apply (drule cte_map_inj,
           erule cte_wp_at_weakenE, rule TrueI,
           erule cte_wp_at_weakenE, rule TrueI,
           assumption+)+
    apply simp
   apply (subgoal_tac "descendants_of' (cte_map (s_d_swap c src dest)) (ctes_of b) =
                       cte_map ` descendants_of (s_d_swap c src dest) (cdt a)")
    prefer 2
    apply (simp del: split_paired_All)
   apply simp
   apply (simp split: if_split)
   apply (frule_tac p="s_d_swap c src dest" in inj_on_descendants_cte_map, assumption+)
   apply (rule conjI, clarsimp)
    apply (rule conjI, clarsimp)
     apply (subst inj_on_image_set_diff15, assumption)
       apply (rule subset_refl)
      apply simp
     apply simp
    apply clarsimp
    apply (rule conjI, clarsimp)
     apply (drule cte_map_inj_eq)
          apply (erule cte_wp_at_weakenE, rule TrueI)
         apply (erule (1) descendants_of_cte_at)
        apply assumption+
     apply simp
    apply (subst insert_minus_eq, assumption)
    apply clarsimp
    apply (subst insert_minus_eq [where x="cte_map dest"], assumption)
    apply (subst inj_on_image_set_diff15)
       apply (erule (3) inj_on_descendants_cte_map)
      apply (rule subset_refl)
     apply clarsimp
    subgoal by auto
   apply clarsimp
   apply (rule conjI, clarsimp)
    apply (rule conjI, clarsimp)
     apply (drule cte_map_inj_eq)
          apply (erule cte_wp_at_weakenE, rule TrueI)
         apply (erule (1) descendants_of_cte_at)
        apply assumption+
     apply simp
    apply clarsimp
    apply (subst inj_on_image_set_diff15)
       apply (erule (3) inj_on_descendants_cte_map)
      apply (rule subset_refl)
     apply clarsimp
    apply simp
   apply clarsimp
   apply (rule conjI, clarsimp)
    apply (drule cte_map_inj_eq)
         apply (erule cte_wp_at_weakenE, rule TrueI)
        apply (erule (1) descendants_of_cte_at)
       apply assumption+
    apply simp
   apply clarsimp
   apply (drule cte_map_inj_eq)
        apply (erule cte_wp_at_weakenE, rule TrueI)
       apply (erule (1) descendants_of_cte_at)
      apply assumption+
   apply simp
  apply(clarsimp simp: cdt_list_relation_def)
  apply(subst next_slot_eq[OF mdb_swap_abs'.next_slot])
     apply(assumption)
    apply(fastforce split: option.split)
   apply(simp)
  apply(frule finite_depth)
  apply(frule mdb_swap.n_next)
   apply(simp)
  apply(case_tac "(aa, bb)=src")
   apply(case_tac "next_slot dest (cdt_list (a)) (cdt a) = Some src")
    apply(simp)
    apply(erule_tac x="fst dest" in allE, erule_tac x="snd dest" in allE)
    apply(simp)
   apply(simp)
   apply(case_tac "next_slot dest (cdt_list (a)) (cdt a)")
    apply(simp)
   apply(simp)
   apply(erule_tac x="fst dest" in allE, erule_tac x="snd dest" in allE)
   apply(simp)
   apply(subgoal_tac "mdbNext dest_node \<noteq> cte_map src")
    apply(simp)
   apply(simp)
   apply(rule_tac s=a in cte_map_inj)
        apply(simp)
       apply(rule cte_at_next_slot')
          apply(simp)
         apply(simp)
        apply(simp)
       apply(simp)
      apply(erule cte_wp_at_weakenE, rule TrueI)
     apply(simp_all)[3]
  apply(case_tac "(aa, bb)=dest")
   apply(case_tac "next_slot src (cdt_list (a)) (cdt a) = Some dest")
    apply(simp)
    apply(erule_tac x="fst src" in allE, erule_tac x="snd src" in allE)
    apply(simp)
   apply(simp)
   apply(case_tac "next_slot src (cdt_list (a)) (cdt a)")
    apply(simp)
   apply(simp)
   apply(erule_tac x="fst src" in allE, erule_tac x="snd src" in allE)
   apply(simp)
   apply(subgoal_tac "mdbNext src_node \<noteq> cte_map dest")
    apply(simp)
   apply(simp)
   apply(rule_tac s=a in cte_map_inj)
        apply(simp)
       apply(rule cte_at_next_slot')
          apply(simp)
         apply(simp)
        apply(simp)
       apply(simp)
      apply(erule cte_wp_at_weakenE, rule TrueI)
     apply(simp_all)[3]
  apply(case_tac "next_slot (aa, bb) (cdt_list (a)) (cdt a) = Some src")
   apply(simp)
   apply(erule_tac x=aa in allE, erule_tac x=bb in allE)
   apply(simp)
   apply(subgoal_tac "cte_at (aa, bb) a")
    apply(subgoal_tac "cte_map (aa, bb) \<noteq> cte_map dest \<and>
                        cte_map (aa, bb) \<noteq> cte_map src \<and>
                        cte_map (aa, bb) = mdbPrev src_node")
     apply(clarsimp)
    apply(rule conjI)
     apply(rule cte_map_inj)
          apply(simp_all)[6]
     apply(erule cte_wp_at_weakenE, simp)
    apply(rule conjI)
     apply(rule cte_map_inj)
          apply(simp_all)[6]
     apply(erule cte_wp_at_weakenE, simp)
    apply(frule mdb_swap.m_exists)
     apply(simp)
    apply(clarsimp)
    apply(frule_tac cte="CTE cap' node'" in valid_mdbD1')
      apply(clarsimp)
     apply(simp add: valid_mdb'_def)
    apply(clarsimp)
   apply(rule cte_at_next_slot)
      apply(simp_all)[4]
  apply(case_tac "next_slot (aa, bb) (cdt_list (a)) (cdt a) = Some dest")
   apply(simp)
   apply(erule_tac x=aa in allE, erule_tac x=bb in allE)
   apply(simp)
   apply(subgoal_tac "cte_at (aa, bb) a")
    apply(subgoal_tac "cte_map (aa, bb) \<noteq> cte_map dest \<and>
                        cte_map (aa, bb) \<noteq> cte_map src \<and>
                        cte_map (aa, bb) = mdbPrev dest_node")
     apply(subgoal_tac "cte_map (aa, bb) \<noteq> mdbPrev src_node")
      apply(clarsimp)
     apply(clarsimp simp: mdb_swap.prev_dest_src)
    apply(rule conjI)
     apply(rule cte_map_inj)
          apply(simp_all)[6]
     apply(erule cte_wp_at_weakenE, simp)
    apply(rule conjI)
     apply(rule cte_map_inj)
          apply(simp_all)[6]
     apply(erule cte_wp_at_weakenE, simp)
    apply(frule mdb_swap.m_exists)
     apply(simp)
    apply(clarsimp)
    apply(frule_tac cte="CTE cap' node'" in valid_mdbD1')
      apply(clarsimp)
     apply(simp add: valid_mdb'_def)
    apply(clarsimp)
   apply(rule cte_at_next_slot)
      apply(simp_all)[4]
  apply(simp)
  apply(case_tac "next_slot (aa, bb) (cdt_list (a)) (cdt a)")
   apply(simp)
  apply(clarsimp)
  apply(erule_tac x=aa in allE, erule_tac x=bb in allE)
  apply(simp)
  apply(subgoal_tac "cte_at (aa, bb) a")
   apply(subgoal_tac "cte_map (aa, bb) \<noteq> cte_map dest \<and>
                      cte_map (aa, bb) \<noteq> cte_map src \<and>
                      cte_map (aa, bb) \<noteq> mdbPrev src_node \<and>
                      cte_map (aa, bb) \<noteq> mdbPrev dest_node")
    apply(clarsimp)
   apply(rule conjI)
    apply(rule cte_map_inj)
         apply(simp_all)[6]
    apply(erule cte_wp_at_weakenE, simp)
   apply(rule conjI)
    apply(rule cte_map_inj)
         apply simp_all[6]
    apply(erule cte_wp_at_weakenE, simp)
   apply(rule conjI)
    apply(frule mdb_swap.m_exists)
     apply(simp)
    apply(clarsimp)
     apply(frule_tac cte="CTE src_cap src_node" in valid_mdbD2')
      subgoal by (clarsimp)
     apply(simp add: valid_mdb'_def)
    apply(clarsimp)
    apply(drule cte_map_inj_eq)
         apply(rule cte_at_next_slot')
            apply(simp_all)[9]
    apply(erule cte_wp_at_weakenE, simp)
   apply(frule mdb_swap.m_exists)
    apply(simp)
   apply(clarsimp)
   apply(frule_tac cte="CTE dest_cap dest_node" in valid_mdbD2')
     apply(clarsimp)
    apply(simp add: valid_mdb'_def)
   apply(clarsimp)
   apply(drule cte_map_inj_eq)
         apply(rule cte_at_next_slot')
           apply(simp_all)[9]
    apply(erule cte_wp_at_weakenE, simp)
  by (rule cte_at_next_slot; simp)


lemma capSwapForDelete_corres:
  assumes "src' = cte_map src" "dest' = cte_map dest"
  shows "corres dc
         (valid_objs and pspace_aligned and pspace_distinct and
          valid_mdb and valid_list and cte_at src and cte_at dest
          and (\<lambda>s. \<forall>cap. tcb_cap_valid cap src s)
          and (\<lambda>s. \<forall>cap. tcb_cap_valid cap dest s))
         (valid_mdb' and pspace_distinct' and pspace_aligned')
         (cap_swap_for_delete src dest) (capSwapForDelete src' dest')"
  using assms
  apply (simp add: cap_swap_for_delete_def capSwapForDelete_def)
  apply (cases "src = dest")
   apply (clarsimp simp: when_def)
  apply (rule corres_assume_pre)
  apply clarsimp
  apply (frule_tac s=s in cte_map_inj)
       apply (simp add: caps_of_state_cte_at)+
  apply (simp add: when_def liftM_def)
  apply (rule corres_guard_imp)
    apply (rule_tac P1=wellformed_cap in corres_split[OF get_cap_corres_P])
      apply (rule_tac P1=wellformed_cap in corres_split[OF get_cap_corres_P])
        apply (rule cteSwap_corres, rule refl, rule refl, clarsimp+)
       apply (wp get_cap_wp getCTE_wp')+
   apply (clarsimp simp: cte_wp_at_caps_of_state)
   apply (drule (1) caps_of_state_valid_cap)+
   apply (simp add: valid_cap_def2)
  apply (clarsimp simp: cte_wp_at_ctes_of)
done

declare if_split [split]
declare revokable_relation_simps [simp]

definition
  "no_child' s cte \<equiv>
  let next = mdbNext (cteMDBNode cte) in
  (next \<noteq> 0 \<longrightarrow> cte_at' next s \<longrightarrow> cte_wp_at' (\<lambda>cte'. \<not>isMDBParentOf cte cte') next s)"

definition
  "child_save' s cte' cte \<equiv>
  let cap = cteCap cte; cap' = cteCap cte' in
  sameRegionAs cap cap' \<and>
  (isEndpointCap cap \<longrightarrow> (capEPBadge cap = capEPBadge cap' \<or> no_child' s cte)) \<and>
  (isNotificationCap cap \<longrightarrow> (capNtfnBadge cap = capNtfnBadge cap' \<or> no_child' s cte))"

lemma subtree_no_parent:
  assumes "m \<turnstile> p \<rightarrow> x"
  assumes "mdbNext (cteMDBNode cte) \<noteq> 0"
  assumes "\<not> isMDBParentOf cte next"
  assumes "m p = Some cte"
  assumes "m (mdbNext (cteMDBNode cte)) = Some next"
  shows "False" using assms
  by induct (auto simp: parentOf_def mdb_next_unfold)

context begin interpretation Arch . (*FIXME: arch_split*)

lemma ensureNoChildren_corres:
  "p' = cte_map p \<Longrightarrow>
  corres (ser \<oplus> dc) (cte_at p) (pspace_aligned' and pspace_distinct' and cte_at' p' and valid_mdb')
         (ensure_no_children p) (ensureNoChildren p')"
  apply (simp add: ensureNoChildren_def ensure_no_children_descendants
                   liftE_bindE nullPointer_def)
  apply (rule corres_symb_exec_r)
     defer
     apply (rule getCTE_sp)
    apply wp
   apply (rule no_fail_pre, wp)
   apply simp
  apply (case_tac "mdbNext (cteMDBNode cte) = 0")
   apply (simp add: whenE_def)
   apply (clarsimp simp: returnOk_def corres_underlying_def return_def)
   apply (erule notE)
   apply (clarsimp simp: state_relation_def cdt_relation_def
                   simp del: split_paired_All)
   apply (erule allE, erule (1) impE)
   apply (subgoal_tac "descendants_of' (cte_map p) (ctes_of b) = {}")
    apply simp
   apply (clarsimp simp: descendants_of'_def)
   apply (subst (asm) cte_wp_at_ctes_of)
   apply clarsimp
   apply (erule (2) subtree_next_0)
  apply (simp add: whenE_def)
  apply (rule corres_symb_exec_r)
     defer
     apply (rule getCTE_sp)
    apply wp
   apply (rule no_fail_pre, wp)
   apply (clarsimp simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def)
   apply (erule (2) valid_dlistEn)
   apply simp
  apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp: corres_underlying_def
                         throwError_def returnOk_def return_def)
   apply (subgoal_tac "pspace_aligned' b \<and> pspace_distinct' b")
    prefer 2
    apply fastforce
   apply (clarsimp simp: cte_wp_at_ctes_of)
   apply (clarsimp simp: state_relation_def cdt_relation_def
                   simp del: split_paired_All)
   apply (erule allE, erule (1) impE)
   apply (clarsimp simp: descendants_of'_def)
   apply (subgoal_tac "ctes_of b \<turnstile> cte_map p \<rightarrow> mdbNext (cteMDBNode cte)")
    apply simp
   apply (rule direct_parent)
     apply (simp add: mdb_next_unfold)
    apply assumption
   apply (simp add: parentOf_def)
  apply clarsimp
  apply (clarsimp simp: corres_underlying_def
                        throwError_def returnOk_def return_def)
  apply (subgoal_tac "pspace_aligned' b \<and> pspace_distinct' b")
   prefer 2
   apply fastforce
  apply (clarsimp simp: cte_wp_at_ctes_of)
  apply (clarsimp simp: state_relation_def cdt_relation_def
                  simp del: split_paired_All)
  apply (erule allE, erule (1) impE)
  apply (subgoal_tac "descendants_of' (cte_map p) (ctes_of b) = {}")
   apply simp
  apply (clarsimp simp: descendants_of'_def)
  apply (erule (4) subtree_no_parent)
  done

end
end