(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(GD_GPL)
 *)

chapter {* Abstract datatype for the executable specification *}

theory ADT_H
imports
  "../../invariant-abstract/ADT_AI"
  Syscall_R
begin

text {*
  The general refinement calculus (see theory Simulation) requires
  the definition of a so-called ``abstract datatype'' for each refinement layer.
  This theory defines this datatype for the executable specification.
  It is based on the abstract specification because we chose
  to base the refinement's observable state on the abstract state.
*}

consts
  initEntry :: word32
  initFrames :: "word32 list"
  initOffset :: word32
  initKernelFrames :: "word32 list"
  initBootFrames :: "word32 list"
  initDataStart :: word32

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

text {*
  The construction of the abstract data type
  for the executable specification largely follows
  the one for the abstract specification.
*}
definition
  Init_H :: "kernel_state global_state set"
  where
  "Init_H \<equiv>
   ({empty_context} \<times> snd `
      fst (initKernel (VPtr initEntry) (PPtr initOffset) (map PPtr initFrames)
                      (map PPtr initKernelFrames) initBootFrames
                      (newKernelState initDataStart))) \<times>
    {UserMode} \<times> {None}"

definition
  "user_mem' s \<equiv> \<lambda>p.
  if (pointerInUserData p s)
  then Some (underlying_memory (ksMachineState s) p)
  else None"

definition
  "device_mem' s \<equiv> \<lambda>p.
  if (pointerInDeviceData p s)
  then Some p
  else None"

definition
  vm_rights_of :: "vmrights \<Rightarrow> rights set"
  where
  "vm_rights_of x \<equiv> case x of VMKernelOnly \<Rightarrow> vm_kernel_only
                    | VMReadOnly \<Rightarrow> vm_read_only
                    | VMReadWrite \<Rightarrow> vm_read_write"

lemma vm_rights_of_vmrights_map_id[simp]:
  "rs \<in> valid_vm_rights \<Longrightarrow> vm_rights_of (vmrights_map rs)= rs"
  by (auto simp: vm_rights_of_def vmrights_map_def valid_vm_rights_def
                 vm_read_write_def vm_read_only_def vm_kernel_only_def)

definition
  absPageTable :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> obj_ref \<Rightarrow>
                  word8 \<Rightarrow> ARM_A.pte"
  where
  "absPageTable h a \<equiv> %offs.
   case (h (a + (ucast offs << 2))) of
     Some (KOArch (KOPTE (ARM_H.InvalidPTE))) \<Rightarrow> ARM_A.InvalidPTE
   | Some (KOArch (KOPTE (ARM_H.LargePagePTE p c g xn rights))) \<Rightarrow>
       if is_aligned offs 4 then
         ARM_A.LargePagePTE p
           {x. c & x=PageCacheable | g & x=Global | xn & x=XNever}
           (vm_rights_of rights)
       else ARM_A.InvalidPTE
   | Some (KOArch (KOPTE (ARM_H.SmallPagePTE p c g xn rights))) \<Rightarrow>
       ARM_A.SmallPagePTE p {x. c & x=PageCacheable |
                                        g & x=Global |
                                        xn & x=XNever} (vm_rights_of rights)"

definition
  absPageDirectory :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> obj_ref \<Rightarrow>
                      12 word \<Rightarrow>  ARM_A.pde"
  where
  "absPageDirectory h a \<equiv> %offs.
   case (h (a + (ucast offs << 2))) of
     Some (KOArch (KOPDE (ARM_H.InvalidPDE))) \<Rightarrow> ARM_A.InvalidPDE
   | Some (KOArch (KOPDE (ARM_H.PageTablePDE p e mw))) \<Rightarrow>
       ARM_A.PageTablePDE p {x. e & x=ParityEnabled} mw
   | Some (KOArch (KOPDE (ARM_H.SectionPDE p e mw c g xn rights))) \<Rightarrow>
       ARM_A.SectionPDE p {x. e & x=ParityEnabled |
                                      c & x=PageCacheable |
                                      g & x=Global |
                                      xn & x=XNever} mw (vm_rights_of rights)
   | Some (KOArch (KOPDE (ARM_H.SuperSectionPDE p e c g xn rights))) \<Rightarrow>
       if is_aligned offs 4 then
         ARM_A.SuperSectionPDE p
           {x. e & x=ParityEnabled | c & x=PageCacheable
             | g & x=Global | xn & x=XNever}
           (vm_rights_of rights)
       else ARM_A.InvalidPDE"

(* Can't pull the whole heap off at once, start with arch specific stuff.*)
definition
  absHeapArch :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32
                 \<Rightarrow> arch_kernel_object \<rightharpoonup> arch_kernel_obj"
  where
  "absHeapArch h a \<equiv> %ako.
   (case ako of
     KOASIDPool (ARM_H.ASIDPool ap) \<Rightarrow>
       Some (ARM_A.ASIDPool (\<lambda>w. ap (ucast w)))
   | KOPTE _ \<Rightarrow>
       if is_aligned a pt_bits then Some (PageTable (absPageTable h a))
       else None
   | KOPDE _ \<Rightarrow>
       if is_aligned a pd_bits then Some (PageDirectory (absPageDirectory h a))
       else None)"

lemma
  assumes ptes:
    "\<forall>x. (\<exists>pte. ksPSpace \<sigma> x = Some (KOArch (KOPTE pte))) \<longrightarrow>
         is_aligned x pt_bits \<longrightarrow>
         (\<forall>y::word8. \<exists>pte'. ksPSpace \<sigma> (x + (ucast y << 2)) =
                           Some (KOArch (KOPTE pte')))"
  and pte_rights:
    "\<forall>x. case ksPSpace \<sigma> x of
           Some (KOArch (KOPTE (ARM_H.LargePagePTE _ _ _ _ r))) \<Rightarrow>
             r \<noteq> VMNoAccess"
    "\<forall>x. case ksPSpace \<sigma> x of
           Some (KOArch (KOPTE (ARM_H.SmallPagePTE _ _ _ _ r))) \<Rightarrow>
             r \<noteq> VMNoAccess"

  assumes pdes:
    "\<forall>x. (\<exists>pde. ksPSpace \<sigma> x = Some (KOArch (KOPDE pde))) \<longrightarrow>
         is_aligned x pd_bits \<longrightarrow>
         (\<forall>y::12 word. \<exists>pde'. ksPSpace \<sigma> (x + (ucast y << 2)) =
                             Some (KOArch (KOPDE pde')))"
  and pde_rights:
    "\<forall>x. case ksPSpace \<sigma> x of
           Some (KOArch (KOPDE (ARM_H.SectionPDE _ _ _ _ _ _ r))) \<Rightarrow>
             r \<noteq> VMNoAccess"
    "\<forall>x. case ksPSpace \<sigma> x of
           Some (KOArch (KOPDE (ARM_H.SuperSectionPDE _ _ _ _ _ r))) \<Rightarrow>
             r \<noteq> VMNoAccess"

  assumes fst_pte:
    "\<forall>x. (\<exists>pte. ksPSpace \<sigma> x = Some (KOArch (KOPTE pte))) \<longrightarrow>
          (\<exists>pte'. ksPSpace \<sigma> (x && ~~ mask pt_bits) =
                  Some (KOArch (KOPTE pte')))"
  assumes fst_pde:
    "\<forall>x. (\<exists>pde. ksPSpace \<sigma> x = Some (KOArch (KOPDE pde))) \<longrightarrow>
          (\<exists>pde'. ksPSpace \<sigma> (x && ~~ mask pd_bits) =
                  Some (KOArch (KOPDE pde')))"
  assumes pspace_aligned': "pspace_aligned' \<sigma>"

  shows
    "pspace_relation
     (%x. case ksPSpace \<sigma> x of
            Some (KOArch ako) \<Rightarrow>
              map_option ArchObj (absHeapArch (ksPSpace \<sigma>) x ako)
          | _ \<Rightarrow> None)
     (%x. case ksPSpace \<sigma> x of Some (KOArch _) \<Rightarrow> ksPSpace \<sigma> x | _ \<Rightarrow> None)"
  apply (clarsimp simp add: pspace_relation_def dom_def)
  apply (rule conjI)
   apply (clarsimp simp add: pspace_dom_def dom_def UNION_eq)
   apply (rule Collect_cong)
   apply (rule iffI)
    apply (erule exE)
    apply (case_tac "ksPSpace \<sigma> x", simp+)
    apply (clarsimp split: option.splits Structures_H.kernel_object.splits)
    apply (rename_tac arch_kernel_object aa b z)
    apply (simp add: absHeapArch_def)
    apply (case_tac arch_kernel_object)
      apply (clarsimp split: asidpool.splits)
     apply (clarsimp split: if_split_asm)
     using  ptes
     apply (erule_tac x=x in allE)
     apply simp
     apply (erule_tac x=y in allE)
     apply clarsimp
    apply (clarsimp split: if_split_asm)
    using pdes
    apply (erule_tac x=x in allE)
    apply simp
    apply (erule_tac x=y in allE)
    apply clarsimp
   apply (clarsimp split: option.splits Structures_H.kernel_object.splits)
   apply (clarsimp simp add: absHeapArch_def)
   apply (rename_tac arch_kernel_object)
   apply (case_tac arch_kernel_object)
     apply (rule_tac x=y in exI)
     apply (clarsimp split: asidpool.splits)
    using fst_pte
    apply (erule_tac x=y in allE)
    apply (clarsimp split: if_split_asm)
    apply (rule_tac x="(y && ~~ mask pt_bits)" in exI, simp)
    apply (simp add: is_aligned_mask mask_AND_NOT_mask)
    apply (simp add: range_composition[symmetric])
    apply (rule_tac x="ucast (y >> 2)" in range_eqI)
    apply (simp add: pt_bits_def pageBits_def)
    apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm)
    using pspace_aligned'
    apply (simp add: pspace_aligned'_def dom_def)
    apply (erule_tac x=y in allE)
    apply (simp add: objBitsKO_def archObjSize_def is_aligned_neg_mask_eq
                     and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq)
   using fst_pde
   apply (erule_tac x=y in allE)
   apply clarsimp
   apply (rule_tac x="(y && ~~ mask pd_bits)" in exI, simp)
   apply (simp add: is_aligned_mask mask_AND_NOT_mask)
   apply (simp add: range_composition[symmetric])
   apply (rule_tac x="ucast (y >> 2)" in range_eqI)
   apply (simp add: pd_bits_def pageBits_def)
   apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm)
   using pspace_aligned'
   apply (simp add: pspace_aligned'_def dom_def)
   apply (erule_tac x=y in allE)
   apply (simp add: objBitsKO_def archObjSize_def is_aligned_neg_mask_eq
                    and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq)
  apply (simp split: option.splits Structures_H.kernel_object.splits)
  apply (intro allI)
  apply (intro impI)
  apply (elim exE)
  apply (clarsimp split: option.splits Structures_H.kernel_object.splits)
  apply (simp add: absHeapArch_def)
  apply (rename_tac arch_kernel_object z a b)
  apply (case_tac arch_kernel_object)
    apply (clarsimp split: asidpool.splits)
    apply (simp add: other_obj_relation_def asid_pool_relation_def o_def inv_def)
   apply simp
   apply (clarsimp simp: pte_relation_def pte_relation_aligned_def
                  split: if_split_asm)
   using ptes
   apply (erule_tac x=x in allE)
   apply simp
   apply (erule_tac x=y in allE)
   apply clarsimp
   apply (rule_tac x=pte' in exI)
   apply (simp add: absPageTable_def  split: option.splits ARM_H.pte.splits)
   apply (clarsimp simp add:  vmrights_map_def vm_rights_of_def
              vm_kernel_only_def vm_read_only_def vm_read_write_def
            split: vmrights.splits)
   using pte_rights
   apply -[1]
   apply (erule_tac x="x + (ucast y << 2)" in allE)+
   subgoal by fastforce
  apply (clarsimp split: if_split_asm)
  using pdes
  apply (erule_tac x=x in allE)
  apply simp
  apply (erule_tac x=y in allE)
  apply clarsimp
  apply (simp add: pde_relation_def pde_relation_aligned_def)
  apply (simp add: absPageDirectory_def
              split: option.splits ARM_H.pde.splits)
  apply (clarsimp simp add:  vmrights_map_def vm_rights_of_def
             vm_kernel_only_def vm_read_only_def vm_read_write_def
           split: vmrights.splits)
  using pde_rights
  apply -[1]
  apply (erule_tac x="x + (ucast y << 2)" in allE)+
  apply fastforce
  done

definition
  "EndpointMap ep \<equiv> case ep of
                     Structures_H.IdleEP \<Rightarrow> Structures_A.IdleEP
                   | Structures_H.SendEP q \<Rightarrow> Structures_A.SendEP q
                   | Structures_H.RecvEP q \<Rightarrow> Structures_A.RecvEP q"

definition
  "AEndpointMap ntfn \<equiv>
      \<lparr> ntfn_obj = case ntfnObj ntfn of
                       Structures_H.IdleNtfn \<Rightarrow> Structures_A.IdleNtfn
                     | Structures_H.WaitingNtfn q \<Rightarrow> Structures_A.WaitingNtfn q
                     | Structures_H.ActiveNtfn b \<Rightarrow> Structures_A.ActiveNtfn b
      , ntfn_bound_tcb = ntfnBoundTCB ntfn \<rparr>"

fun
  CapabilityMap :: "capability \<Rightarrow> cap"
 where
  "CapabilityMap capability.NullCap = cap.NullCap"
| "CapabilityMap (capability.UntypedCap d ref n idx) = cap.UntypedCap d ref n idx"
| "CapabilityMap (capability.EndpointCap ref b sr rr gr) =
   cap.EndpointCap ref b {x. sr \<and> x = AllowSend \<or> rr \<and> x = AllowRecv \<or>
                             gr \<and> x = AllowGrant}"
| "CapabilityMap (capability.NotificationCap ref b sr rr) =
   cap.NotificationCap ref b {x. sr \<and> x = AllowSend \<or> rr \<and> x = AllowRecv}"
| "CapabilityMap (capability.CNodeCap ref n L l) =
   cap.CNodeCap ref n (bin_to_bl l (uint L))"
| "CapabilityMap (capability.ThreadCap ref) = cap.ThreadCap ref"
| "CapabilityMap capability.DomainCap = cap.DomainCap"
| "CapabilityMap (capability.ReplyCap ref master) = cap.ReplyCap ref master"
| "CapabilityMap capability.IRQControlCap = cap.IRQControlCap"
| "CapabilityMap (capability.IRQHandlerCap irq) = cap.IRQHandlerCap irq"
| "CapabilityMap (capability.Zombie p b n) =
   cap.Zombie p (case b of ZombieTCB \<Rightarrow> None | ZombieCNode n \<Rightarrow> Some n) n"
| "CapabilityMap (capability.ArchObjectCap (arch_capability.ASIDPoolCap x y)) =
   cap.ArchObjectCap (arch_cap.ASIDPoolCap x y)"
| "CapabilityMap (capability.ArchObjectCap (arch_capability.ASIDControlCap)) =
   cap.ArchObjectCap (arch_cap.ASIDControlCap)"
| "CapabilityMap (capability.ArchObjectCap
                    (arch_capability.PageCap d word rghts sz data)) =
   cap.ArchObjectCap (arch_cap.PageCap d word (vm_rights_of rghts) sz data)"
| "CapabilityMap (capability.ArchObjectCap
                    (arch_capability.PageTableCap word data)) =
  cap.ArchObjectCap (arch_cap.PageTableCap word data)"
| "CapabilityMap (capability.ArchObjectCap
                    (arch_capability.PageDirectoryCap word data)) =
  cap.ArchObjectCap (arch_cap.PageDirectoryCap word data)"

lemma cap_relation_CapabilityMap:
  "\<lbrakk>\<forall>dev w r s d. c = capability.ArchObjectCap (arch_capability.PageCap dev w r s d) \<longrightarrow>
              r \<noteq> VMNoAccess;
    \<forall>ref n L l. c = capability.CNodeCap ref n L l \<longrightarrow>
                of_bl (bin_to_bl l (uint L)) = L\<rbrakk>
   \<Longrightarrow> cap_relation (CapabilityMap c) c"
apply (case_tac c; simp del: bin_to_bl_def)
 apply (clarsimp simp: zbits_map_def split: zombie_type.splits)
apply (rename_tac arch_capability)
apply (case_tac arch_capability,
       simp_all add: vmrights_map_def vm_rights_of_def vm_kernel_only_def
                     vm_read_only_def vm_read_write_def
              split: vmrights.splits)
done

(* FIXME: wellformed_cap_simps has lots of duplicates. *)
lemma cap_relation_imp_CapabilityMap:
  "\<lbrakk>wellformed_cap c; cap_relation c c'\<rbrakk> \<Longrightarrow> CapabilityMap c' = c"
  apply (case_tac c; simp add: wellformed_cap_simps)
      apply (rule set_eqI, clarsimp)
      apply (case_tac "x", simp_all)
     apply (rule set_eqI, clarsimp)
     apply (case_tac "x", simp_all add: word_bits_def)
    apply (simp add: uint_of_bl_is_bl_to_bin bl_bin_bl[simplified])
   apply (simp add: zbits_map_def split: option.splits)
  apply (rename_tac arch_cap)
  apply clarsimp
  apply (case_tac arch_cap, simp_all add: wellformed_cap_simps)
  done

primrec
  ThStateMap :: "Structures_H.thread_state \<Rightarrow> Structures_A.thread_state"
where
  "ThStateMap Structures_H.thread_state.Running =
              Structures_A.thread_state.Running"
| "ThStateMap Structures_H.thread_state.Restart =
              Structures_A.thread_state.Restart"
| "ThStateMap Structures_H.thread_state.Inactive =
              Structures_A.thread_state.Inactive"
| "ThStateMap Structures_H.thread_state.IdleThreadState =
              Structures_A.thread_state.IdleThreadState"
| "ThStateMap Structures_H.thread_state.BlockedOnReply =
              Structures_A.thread_state.BlockedOnReply"
| "ThStateMap (Structures_H.thread_state.BlockedOnReceive oref) =
              Structures_A.thread_state.BlockedOnReceive oref"
| "ThStateMap (Structures_H.thread_state.BlockedOnSend oref badge grant call) =
              Structures_A.thread_state.BlockedOnSend oref
                \<lparr> sender_badge = badge,
                  sender_can_grant = grant,
                  sender_is_call = call \<rparr>"
| "ThStateMap (Structures_H.thread_state.BlockedOnNotification oref) =
              Structures_A.thread_state.BlockedOnNotification oref"

lemma thread_state_relation_ThStateMap:
  "thread_state_relation (ThStateMap ts) ts"
by (cases ts) simp_all

lemma thread_state_relation_imp_ThStateMap:
  "thread_state_relation ts ts' \<Longrightarrow> ThStateMap ts' = ts"
by (cases ts) simp_all

definition
  "LookupFailureMap \<equiv> \<lambda>lf. case lf of
     Fault_H.lookup_failure.InvalidRoot \<Rightarrow>
         ExceptionTypes_A.lookup_failure.InvalidRoot
     | Fault_H.lookup_failure.MissingCapability n \<Rightarrow>
         ExceptionTypes_A.lookup_failure.MissingCapability n
     | Fault_H.lookup_failure.DepthMismatch n m \<Rightarrow>
         ExceptionTypes_A.lookup_failure.DepthMismatch n m
     | Fault_H.lookup_failure.GuardMismatch n g l \<Rightarrow>
         ExceptionTypes_A.lookup_failure.GuardMismatch n (bin_to_bl l (uint g))"

lemma lookup_failure_map_LookupFailureMap:
  "(\<forall>n g l. lf = Fault_H.lookup_failure.GuardMismatch n g l \<longrightarrow>
                of_bl (bin_to_bl l (uint g)) = g)
   \<Longrightarrow> lookup_failure_map (LookupFailureMap lf) = lf"
by (clarsimp simp add: LookupFailureMap_def lookup_failure_map_def
             simp del: bin_to_bl_def
        split: lookup_failure.splits)

lemma LookupFailureMap_lookup_failure_map:
  "(\<forall>n g. lf = ExceptionTypes_A.GuardMismatch n g \<longrightarrow> length g \<le> 32)
   \<Longrightarrow> LookupFailureMap (lookup_failure_map lf) = lf"
  by (clarsimp simp add: LookupFailureMap_def lookup_failure_map_def
                         uint_of_bl_is_bl_to_bin
               simp del: bin_to_bl_def
               split: ExceptionTypes_A.lookup_failure.splits)

primrec
  ArchFaultMap :: "Fault_H.arch_fault \<Rightarrow> ExceptionTypes_A.arch_fault"
where
  "ArchFaultMap (ArchFault_H.ARM_H.arch_fault.VMFault p m) = Machine_A.ARM_A.arch_fault.VMFault p m"

primrec
  FaultMap :: "Fault_H.fault \<Rightarrow> ExceptionTypes_A.fault"
where
  "FaultMap (Fault_H.fault.CapFault ref b failure) =
     ExceptionTypes_A.fault.CapFault ref b (LookupFailureMap failure)"
| "FaultMap (Fault_H.fault.ArchFault fault) =
     ExceptionTypes_A.fault.ArchFault (ArchFaultMap fault)"
| "FaultMap (Fault_H.fault.UnknownSyscallException n) =
     ExceptionTypes_A.fault.UnknownSyscallException n"
| "FaultMap (Fault_H.fault.UserException x y) =
     ExceptionTypes_A.fault.UserException x y"

lemma ArchFaultMap_arch_fault_map: "ArchFaultMap (arch_fault_map f) = f"
  by (cases f, simp add: ArchFaultMap_def arch_fault_map_def)

lemma FaultMap_fault_map[simp]:
  "valid_fault ft \<Longrightarrow> FaultMap (fault_map ft) = ft"
  apply (case_tac ft, simp_all)
   apply (simp add: valid_fault_def LookupFailureMap_lookup_failure_map)
  apply (rule ArchFaultMap_arch_fault_map)
  done

definition
  "ArchTcbMap atcb \<equiv>
    \<lparr> tcb_context =  atcbContext atcb \<rparr>"

lemma arch_tcb_relation_imp_ArchTcnMap:
  "\<lbrakk> arch_tcb_relation atcb atcb'\<rbrakk> \<Longrightarrow> ArchTcbMap atcb' = atcb"
  by (clarsimp simp: arch_tcb_relation_def ArchTcbMap_def)

definition
  "TcbMap tcb \<equiv>
     \<lparr>tcb_ctable = CapabilityMap (cteCap (tcbCTable tcb)),
      tcb_vtable = CapabilityMap (cteCap (tcbVTable tcb)),
      tcb_reply = CapabilityMap (cteCap (tcbReply tcb)),
      tcb_caller = CapabilityMap (cteCap (tcbCaller tcb)),
      tcb_ipcframe = CapabilityMap (cteCap (tcbIPCBufferFrame tcb)),
      tcb_state = ThStateMap (tcbState tcb),
      tcb_fault_handler = to_bl (tcbFaultHandler tcb),
      tcb_ipc_buffer = tcbIPCBuffer tcb,
      tcb_fault = map_option FaultMap (tcbFault tcb),
      tcb_bound_notification = tcbBoundNotification tcb,
      tcb_mcpriority = tcbMCP tcb,
      tcb_arch = ArchTcbMap (tcbArch tcb)\<rparr>"

definition
 "absCNode sz h a \<equiv> CNode sz (%bl.
  if length bl = sz
    then Some (CapabilityMap (case (h (a + of_bl bl * 16)) of
                                Some (KOCTE cte) \<Rightarrow> cteCap cte))
  else None)"

definition
  absHeap :: "(word32 \<rightharpoonup> vmpage_size) \<Rightarrow> (word32 \<rightharpoonup> nat) \<Rightarrow>
              (word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> Structures_A.kheap"
  where
  "absHeap ups cns h \<equiv> \<lambda>x.
     case h x of
       Some (KOEndpoint ep) \<Rightarrow> Some (Endpoint (EndpointMap ep))
     | Some (KONotification ntfn) \<Rightarrow> Some (Notification (AEndpointMap ntfn))
     | Some KOKernelData \<Rightarrow> undefined (* forbidden by pspace_relation *)
     | Some KOUserData \<Rightarrow> map_option (ArchObj \<circ> DataPage False) (ups x)
     | Some KOUserDataDevice \<Rightarrow> map_option (ArchObj \<circ> DataPage True) (ups x)
     | Some (KOTCB tcb) \<Rightarrow> Some (TCB (TcbMap tcb))
     | Some (KOCTE cte) \<Rightarrow> map_option (%sz. absCNode sz h x) (cns x)
     | Some (KOArch ako) \<Rightarrow> map_option ArchObj (absHeapArch h x ako)
     | None \<Rightarrow> None"

lemma unaligned_page_offsets_helper:
  "\<lbrakk>is_aligned y (pageBitsForSize vmpage_size); n\<noteq>0;
    n < 2 ^ (pageBitsForSize vmpage_size - pageBits)\<rbrakk>
   \<Longrightarrow> \<not> is_aligned (y + n * 2 ^ pageBits :: word32) (pageBitsForSize vmpage_size)"
  apply (simp (no_asm_simp) add: is_aligned_mask)
  apply (simp add: mask_add_aligned)
  apply (cut_tac mask_eq_iff_w2p [of "pageBitsForSize vmpage_size" "n * 2 ^ pageBits"])
   prefer 2
   apply (case_tac vmpage_size, simp_all add: pageBits_def word_size)
  apply (cut_tac word_power_nonzero_32[of n pageBits];
         simp add: word_bits_conv pageBits_def)
   prefer 2
   apply (case_tac vmpage_size, simp_all add: pageBits_def word_size)
     apply (frule less_trans[of n _ "0x100000"], simp+)+
  apply clarsimp
  apply (case_tac vmpage_size, simp_all add: pageBits_def)
    apply (frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+
  done

(* FIXME: move *)
lemma unaligned_helper:
  "\<lbrakk>is_aligned x n; y\<noteq>0; y < 2 ^ n\<rbrakk> \<Longrightarrow> \<not> is_aligned (x + y) n"
  apply (simp (no_asm_simp) add: is_aligned_mask)
  apply (simp add: mask_add_aligned)
  apply (cut_tac mask_eq_iff_w2p[of n y], simp_all add: word_size)
  apply (rule ccontr)
  apply (simp add: not_less power_overflow word_bits_conv)
  done

lemma pspace_aligned_distinct_None:
  (* NOTE: life would be easier if pspace_aligned and pspace_distinct were defined on PSpace instead of the whole kernel state. *)
assumes pspace_aligned:
  "\<forall>x\<in>dom ha. is_aligned (x :: word32) (obj_bits (the (ha x)))"
assumes pspace_distinct:
  "\<forall>x y ko ko'.
   ha x = Some ko \<and> ha y = Some ko' \<and> x \<noteq> y \<longrightarrow>
   {x..x + (2 ^ obj_bits ko - 1)} \<inter> {y..y + (2 ^ obj_bits ko' - 1)} = {}"
shows
  "\<lbrakk>ha x = Some ko; y \<in> {0<..<2^(obj_bits ko)}\<rbrakk> \<Longrightarrow> ha (x+y) = None"
  using pspace_aligned[simplified dom_def, simplified]
  apply (erule_tac x=x in allE)
  apply (rule ccontr)
  apply clarsimp
  apply (rename_tac ko')
  using pspace_distinct pspace_aligned[simplified dom_def, simplified]
  apply (erule_tac x=x in allE)
  apply (erule_tac x="x+y" in allE)+
  apply (clarsimp simp add: word_gt_0)
  apply (clarsimp simp add: ucast_of_nat_small is_aligned_mask mask_2pm1[symmetric])
  apply (frule (1) is_aligned_AND_less_0)
  apply (clarsimp simp add: word_plus_and_or_coroll le_word_or2)
  apply (simp add: word_bool_alg.disj_assoc le_word_or2)
  apply (simp add: word_plus_and_or_coroll[symmetric])
  apply (subgoal_tac "x + y \<le> x + mask (obj_bits ko)", simp)
  apply (rule word_add_le_mono2)
   apply (simp add: mask_def plus_one_helper)
  apply (thin_tac "~ P" for P)+
  apply (thin_tac "(x::'a::len word) < y" for x y)+
  apply (thin_tac "x = Some y" for x y)+
  apply (thin_tac "x && mask (obj_bits ko') = 0" for x)
  apply (thin_tac "x && y = 0")
  apply (clarsimp simp add: dvd_def word_bits_len_of word_bits_conv
                            and_mask_dvd_nat[symmetric])
  apply (cut_tac x=x in unat_lt2p)
  apply (cut_tac x="mask (obj_bits ko)::word32" in unat_lt2p)
  apply (simp add: mult.commute
                   add.commute[of "unat (mask (obj_bits ko))"])
  apply (case_tac "k=0", simp+)
  apply (subgoal_tac "obj_bits ko\<le>32")
   prefer 2
   apply (rule ccontr)
   apply (simp add: not_le)
   apply (frule_tac a="2::nat" and n=32 in power_strict_increasing, simp+)
   apply (case_tac "k=1", simp)
   apply (cut_tac m=k and n="2 ^ obj_bits ko" in n_less_n_mult_m,
          (simp(no_asm_simp))+)
   apply (simp only: mult.commute)
  apply (thin_tac "x = y" for x y)+
  apply (clarsimp simp add: le_less)
  apply (erule disjE)
   prefer 2
   apply (simp add: mask_def)
  apply (subgoal_tac "obj_bits ko <= (31::nat)", simp_all)
  apply (simp add: mask_def unat_minus_one word_bits_conv)
  apply (cut_tac w=k and c="2 ^ obj_bits ko" and b="2^(32-obj_bits ko)"
              in less_le_mult_nat)
   apply (simp_all add: power_add[symmetric])
  apply (rule ccontr)
  apply (simp add: not_less)
  apply (simp add: le_less[of "2 ^ (32 - obj_bits ko)"])
  apply (erule disjE)
   prefer 2
   apply (clarsimp simp add: power_add[symmetric])
  apply clarsimp
  apply (drule mult_less_mono1[of "2 ^ (32 - obj_bits ko)" _ "2 ^ obj_bits ko"])
   apply (simp add: power_add[symmetric])+
  done

lemma pspace_aligned_distinct_None':
  assumes pspace_aligned: "pspace_aligned s"
  assumes pspace_distinct: "pspace_distinct s"
  shows
  "\<lbrakk>kheap s x = Some ko; y \<in> {0<..<2^(obj_bits ko)}\<rbrakk> \<Longrightarrow> kheap s (x+y) = None"
  apply (rule pspace_aligned_distinct_None)
     apply (rule pspace_aligned[simplified pspace_aligned_def])
    apply (rule pspace_distinct[simplified pspace_distinct_def])
   apply assumption+
  done

lemma absHeap_correct:
  assumes pspace_aligned:  "pspace_aligned s"
  assumes pspace_distinct: "pspace_distinct s"
  assumes valid_objs:      "valid_objs s"
  assumes pspace_relation: "pspace_relation (kheap s) (ksPSpace s')"
  assumes ghost_relation:  "ghost_relation (kheap s) (gsUserPages s') (gsCNodes s')"
shows
  "absHeap (gsUserPages s') (gsCNodes s') (ksPSpace s') = kheap s"
proof -
  from ghost_relation
  have gsUserPages:
    "\<And>a sz. (\<exists>dev. kheap s a = Some (ArchObj (DataPage dev sz))) \<longleftrightarrow>
             gsUserPages s' a = Some sz"
   and gsCNodes:
    "\<And>a n. (\<exists>cs. kheap s a = Some (CNode n cs) \<and> well_formed_cnode_n n cs) \<longleftrightarrow>
            gsCNodes s' a = Some n"
    by (fastforce simp add: ghost_relation_def)+

  show "?thesis"
    apply (rule ext)
    apply (simp add: absHeap_def split: option.splits)
    apply (rule conjI)
     using pspace_relation
     apply (clarsimp simp add: pspace_relation_def pspace_dom_def UNION_eq
                               dom_def Collect_eq)
     apply (erule_tac x=x in allE)
     apply clarsimp
     apply (case_tac "kheap s x", simp)
     apply (erule_tac x=x in allE, clarsimp)
     apply (erule_tac x=x in allE, simp add: Ball_def)
     apply (erule_tac x=x in allE, clarsimp)

     apply (case_tac a)
         apply (simp_all add: other_obj_relation_def
                       split: if_split_asm Structures_H.kernel_object.splits)
      apply (rename_tac sz cs)
      apply (clarsimp simp add: image_def cte_map_def
                 well_formed_cnode_n_def Collect_eq dom_def)
      apply (erule_tac x="replicate sz False" in allE)+
      apply simp
     apply (rename_tac arch_kernel_obj)
     apply (case_tac arch_kernel_obj, simp_all add: image_def)
       apply (erule_tac x=0 in allE, simp)
      apply (erule_tac x=0 in allE, simp)
     apply clarsimp
     apply (erule_tac x=0 in allE, simp add: pageBits_def)
     apply (rename_tac vmpage_size)
     apply (case_tac vmpage_size, simp_all)

    apply clarsimp
    apply (intro conjI impI allI)
           apply (erule pspace_dom_relatedE[OF _ pspace_relation])
           apply clarsimp
           apply (case_tac ko, simp_all add: other_obj_relation_def)
             apply (clarsimp simp add: cte_relation_def split: if_split_asm)
            apply (clarsimp simp add: ep_relation_def EndpointMap_def
                     split: Structures_A.endpoint.splits)
           apply (clarsimp simp add: EndpointMap_def
                    split: Structures_A.endpoint.splits)
           apply (rename_tac arch_kernel_obj)
           apply (case_tac arch_kernel_obj,
                  simp_all add: other_obj_relation_def)
             apply (clarsimp simp add: pte_relation_def)
            apply (clarsimp simp add: pde_relation_def)
           apply (clarsimp split: if_split_asm)+

          apply (erule pspace_dom_relatedE[OF _ pspace_relation])
          apply (case_tac ko, simp_all add: other_obj_relation_def)
            apply (clarsimp simp add: cte_relation_def split: if_split_asm)
           apply (clarsimp simp add: ntfn_relation_def AEndpointMap_def
                    split: Structures_A.ntfn.splits)
          apply (clarsimp simp add: AEndpointMap_def
                   split: Structures_A.ntfn.splits)
          apply (rename_tac arch_kernel_obj)
          apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
            apply (clarsimp simp add: pte_relation_def)
           apply (clarsimp simp add: pde_relation_def)
          apply (clarsimp split: if_split_asm)+

         apply (erule pspace_dom_relatedE[OF _ pspace_relation])
         apply (case_tac ko, simp_all add: other_obj_relation_def)
           apply (clarsimp simp add: cte_relation_def split: if_split_asm)
         apply (rename_tac arch_kernel_obj)
         apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
           apply (clarsimp simp add: pte_relation_def)
          apply (clarsimp simp add: pde_relation_def)
         apply (clarsimp split: if_split_asm)+

        apply (erule pspace_dom_relatedE[OF _ pspace_relation])
        apply (case_tac ko, simp_all add: other_obj_relation_def)
          apply (clarsimp simp add: cte_relation_def split: if_split_asm)
        apply (rename_tac arch_kernel_obj)
        apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
          apply (clarsimp simp add: pte_relation_def)
         apply (clarsimp simp add: pde_relation_def)
        apply (rename_tac vmpage_size)
        apply (cut_tac a=y and sz=vmpage_size in gsUserPages, clarsimp split: if_split_asm)
        apply (case_tac "n=0", simp)
        apply (case_tac "kheap s (y + n * 2 ^ pageBits)")
         apply (rule ccontr)
         apply (clarsimp dest!: gsUserPages[symmetric, THEN iffD1] )
        using pspace_aligned
        apply (simp add: pspace_aligned_def dom_def)
        apply (erule_tac x=y in allE)
        apply (case_tac "n=0",(simp split: if_split_asm)+)
        apply (frule (2) unaligned_page_offsets_helper)
        apply (frule_tac y="n*2^pageBits" in pspace_aligned_distinct_None'
                                          [OF pspace_aligned pspace_distinct])
         apply simp
         apply (rule conjI, clarsimp simp add: word_gt_0)
         apply (simp add: is_aligned_mask)
         apply (clarsimp simp add: pageBits_def mask_def)
        apply (case_tac vmpage_size; simp)
          apply ((frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+)[4]
        apply (erule pspace_dom_relatedE[OF _ pspace_relation])
        apply (case_tac ko, simp_all add: other_obj_relation_def)
          apply (clarsimp simp add: cte_relation_def split: if_split_asm)
        apply (rename_tac arch_kernel_obj)
        apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
          apply (clarsimp simp add: pte_relation_def)
         apply (clarsimp simp add: pde_relation_def)
        apply (rename_tac vmpage_size)
        apply (cut_tac a=y and sz=vmpage_size in gsUserPages, clarsimp split: if_split_asm)
        apply (case_tac "n=0", simp)
        apply (case_tac "kheap s (y + n * 2 ^ pageBits)")
         apply (rule ccontr)
         apply (clarsimp dest!: gsUserPages[symmetric, THEN iffD1])
        using pspace_aligned
        apply (simp add: pspace_aligned_def dom_def)
        apply (erule_tac x=y in allE)
        apply (case_tac "n=0",simp+)
        apply (frule (2) unaligned_page_offsets_helper)
        apply (frule_tac y="n*2^pageBits" in pspace_aligned_distinct_None'
                                          [OF pspace_aligned pspace_distinct])
         apply simp
         apply (rule conjI, clarsimp simp add: word_gt_0)
         apply (simp add: is_aligned_mask)
         apply (clarsimp simp add: pageBits_def mask_def)
        apply (case_tac vmpage_size; simp)
          apply ((frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+)[4]
       apply (erule pspace_dom_relatedE[OF _ pspace_relation])
       apply (case_tac ko, simp_all add: other_obj_relation_def)
         apply (clarsimp simp add: cte_relation_def split: if_split_asm)
        prefer 2
        apply (rename_tac arch_kernel_obj)
        apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
          apply (clarsimp simp add: pte_relation_def)
         apply (clarsimp simp add: pde_relation_def)
        apply (clarsimp split: if_split_asm)
       apply (clarsimp simp add: TcbMap_def tcb_relation_def valid_obj_def)
       apply (rename_tac tcb y tcb')
       apply (case_tac tcb)
       apply (case_tac tcb')
       apply (simp add: thread_state_relation_imp_ThStateMap)
       apply (subgoal_tac "map_option FaultMap (tcbFault tcb) = tcb_fault")
        prefer 2
        apply (simp add: fault_rel_optionation_def)
        using valid_objs[simplified valid_objs_def dom_def fun_app_def,
                         simplified]
        apply (erule_tac x=y in allE)
        apply (clarsimp simp: valid_obj_def valid_tcb_def
                        split: option.splits)
       using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def]
       apply (erule_tac x=y in allE)
       apply (clarsimp simp add: cap_relation_imp_CapabilityMap valid_obj_def
                                 valid_tcb_def ran_tcb_cap_cases valid_cap_def2
                                 arch_tcb_relation_imp_ArchTcnMap)
      apply (simp add: absCNode_def cte_map_def)
      apply (erule pspace_dom_relatedE[OF _ pspace_relation])
      apply (case_tac ko, simp_all add: other_obj_relation_def
                                 split: if_split_asm)
       prefer 2
       apply (rename_tac arch_kernel_obj)
       apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
         apply (clarsimp simp add: pte_relation_def)
        apply (clarsimp simp add: pde_relation_def)
       apply (clarsimp split: if_split_asm)
      apply (simp add: cte_map_def)
      apply (clarsimp simp add: cte_relation_def)
      apply (cut_tac a=y and n=sz in gsCNodes, clarsimp)
      using pspace_aligned[simplified pspace_aligned_def]
      apply (drule_tac x=y in bspec, clarsimp)
      apply (clarsimp simp: cte_level_bits_def)
      apply (case_tac "(of_bl ya::word32) * 0x10 = 0", simp)
       apply (rule ext)
       apply simp
       apply (rule conjI)
        prefer 2
        using valid_objs[simplified valid_objs_def Ball_def dom_def
                                    fun_app_def]
        apply (erule_tac x=y in allE)
        apply (clarsimp simp add: valid_obj_def valid_cs_def valid_cs_size_def
                    well_formed_cnode_n_def dom_def Collect_eq)
        apply (frule_tac x=ya in spec, simp)
        apply (erule_tac x=bl in allE)
        apply clarsimp+
       apply (frule pspace_relation_absD[OF _ pspace_relation])
       apply (simp add: cte_map_def)
       apply (drule_tac x="y + of_bl bl * 0x10" in spec)
       apply clarsimp
       apply (erule_tac x="cte_relation bl" in allE)
       apply (erule impE)
        apply (fastforce simp add: well_formed_cnode_n_def)
       apply clarsimp
       apply (clarsimp simp add: cte_relation_def)
       apply (rule cap_relation_imp_CapabilityMap)
        using valid_objs[simplified valid_objs_def Ball_def dom_def
                                    fun_app_def]
        apply (erule_tac x=y in allE)
        apply (clarsimp simp: valid_obj_def valid_cs_def valid_cap_def2 ran_def)
        apply fastforce+
      apply (subgoal_tac "kheap s (y + of_bl ya * 0x10) = None")
       prefer 2
       using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def]
       apply (erule_tac x=y in allE)
       apply (clarsimp simp add: valid_obj_def valid_cs_def valid_cs_size_def)
       apply (rule pspace_aligned_distinct_None'[OF
                   pspace_aligned pspace_distinct], assumption)
       apply (clarsimp simp: cte_level_bits_def dom_def word_neq_0_conv
                             power_add mult.commute[of 16])
       apply (simp add: well_formed_cnode_n_def dom_def Collect_eq)
       apply (erule_tac x=ya in allE)+
       apply (rule word_mult_less_mono1)
         apply (subgoal_tac "sz = length ya")
          apply simp
          apply (rule of_bl_length, (simp add: word_bits_def)+)[1]
         apply fastforce
        apply simp
       apply (simp add: word_bits_conv cte_level_bits_def)
       apply (drule_tac a="2::nat" in power_strict_increasing, simp+)
      apply (rule ccontr, clarsimp)
      apply (cut_tac a="y + of_bl ya * 0x10" and n=yc in gsCNodes)
      apply clarsimp

    (* mapping architecture-specific objects *)
    apply clarsimp
    apply (erule pspace_dom_relatedE[OF _ pspace_relation])
    apply (case_tac ko, simp_all add: other_obj_relation_def)
     apply (clarsimp simp add: cte_relation_def split: if_split_asm)
    apply (rename_tac arch_kernel_object y ko P arch_kernel_obj)
    apply (case_tac arch_kernel_object, simp_all add: absHeapArch_def
                                            split: asidpool.splits)

      apply clarsimp
      apply (case_tac arch_kernel_obj)
         apply (simp add: other_obj_relation_def asid_pool_relation_def
                          inv_def o_def)
        apply (clarsimp simp add:  pte_relation_def)
       apply (clarsimp simp add:  pde_relation_def)
      apply (clarsimp split: if_split_asm)+

     apply (case_tac arch_kernel_obj)
        apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def
                         o_def)
       using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def]
       apply (erule_tac x=y in allE)
       apply (clarsimp simp add: pte_relation_def absPageTable_def
                                 pt_bits_def pageBits_def)
       apply (rule conjI)
        prefer 2
        apply clarsimp
        apply (rule sym)
        apply (rule pspace_aligned_distinct_None'
                    [OF pspace_aligned pspace_distinct], simp+)
        apply (cut_tac x=ya and n="2^10" in
               ucast_less_shiftl_helper[where 'a=32,simplified word_bits_conv], simp+)
        apply (clarsimp simp add: word_gt_0)
       apply clarsimp
       apply (subgoal_tac "ucast ya << 2 = 0")
        prefer 2
        apply (rule ccontr)
        apply (frule_tac x=y in unaligned_helper, assumption)
         apply (rule ucast_less_shiftl_helper, simp_all)
       apply (rule ext)
       apply (frule pspace_relation_absD[OF _ pspace_relation])
       apply simp
       apply (erule_tac x=offs in allE)
       apply (clarsimp simp add: pte_relation_def)
       using valid_objs[simplified valid_objs_def fun_app_def dom_def,
                        simplified]
       apply (erule_tac x=y in allE)
       apply (clarsimp simp add: valid_obj_def wellformed_pte_def)
       apply (erule_tac x=offs in allE)
       apply (rename_tac pte')
       apply (case_tac pte', simp_all add: pte_relation_aligned_def)[1]
        apply (clarsimp split: ARM_A.pte.splits)
        apply (rule set_eqI, clarsimp)
        apply (case_tac x, simp_all)[1]
       apply (clarsimp split: ARM_A.pte.splits)
       apply (rule set_eqI, clarsimp)
       apply (case_tac x, simp_all)[1]
      apply (clarsimp simp add: pde_relation_def)
     apply (clarsimp split: if_split_asm)+

    apply (case_tac arch_kernel_obj)
       apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def
                        o_def)
      apply (clarsimp simp add:  pte_relation_def)
     using pspace_aligned
     apply (simp add: pspace_aligned_def dom_def)
     apply (erule_tac x=y in allE)
     apply (clarsimp simp add: pde_relation_def absPageDirectory_def
                               pd_bits_def pageBits_def)
     apply (rule conjI)
      prefer 2
      apply clarsimp
      apply (rule sym)
      apply (rule pspace_aligned_distinct_None'
                  [OF pspace_aligned pspace_distinct], simp+)
      apply (cut_tac x=ya and n="2^14" in
             ucast_less_shiftl_helper[where 'a=32, simplified word_bits_conv], simp+)
      apply (clarsimp simp add: word_gt_0)
     apply clarsimp
     apply (subgoal_tac "ucast ya << 2 = 0")
      prefer 2
      apply (rule ccontr)
      apply (frule_tac x=y in unaligned_helper, assumption)
       apply (rule ucast_less_shiftl_helper, simp_all)
     apply (rule ext)
     apply (frule pspace_relation_absD[OF _ pspace_relation])
     apply simp
     apply (erule_tac x=offs in allE)
     apply (clarsimp simp add: pde_relation_def)

     using valid_objs[simplified valid_objs_def fun_app_def dom_def,simplified]
     apply (erule_tac x=y in allE)
     apply (clarsimp simp add: valid_obj_def wellformed_pde_def)
     apply (erule_tac x=offs in allE)
     apply (rename_tac pde')
     apply (case_tac pde', simp_all add: pde_relation_aligned_def)[1]
        apply (clarsimp split: ARM_A.pde.splits)+
       apply (fastforce simp add: subset_eq)
      apply (clarsimp split: ARM_A.pde.splits)
      apply (rule set_eqI, clarsimp)
      apply (case_tac x, simp_all)[1]
     apply (clarsimp split: ARM_A.pde.splits)
     apply (rule set_eqI, clarsimp)
     apply (case_tac x, simp_all)[1]
    apply (clarsimp simp add: pde_relation_def split: if_split_asm)
    done
qed

definition
  "EtcbMap tcb \<equiv>
     \<lparr>tcb_priority = tcbPriority tcb,
      time_slice = tcbTimeSlice tcb,
      tcb_domain = tcbDomain tcb\<rparr>"

definition
  absEkheap :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> obj_ref \<Rightarrow> etcb option"
  where
  "absEkheap h \<equiv> \<lambda>x.
     case h x of
       Some (KOTCB tcb) \<Rightarrow> Some (EtcbMap tcb)
     | _ \<Rightarrow> None"

lemma absEkheap_correct:
assumes pspace_relation: "pspace_relation (kheap s) (ksPSpace s')"
assumes ekheap_relation: "ekheap_relation (ekheap s) (ksPSpace s')"
assumes vetcbs: "valid_etcbs s"
shows
  "absEkheap (ksPSpace s') = ekheap s"
  apply (rule ext)
  apply (clarsimp simp: absEkheap_def split: option.splits Structures_H.kernel_object.splits)
  apply (subgoal_tac "\<forall>x. (\<exists>tcb. kheap s x = Some (TCB tcb)) =
                          (\<exists>tcb'. ksPSpace s' x = Some (KOTCB tcb'))")
   using vetcbs ekheap_relation
   apply (clarsimp simp: valid_etcbs_def is_etcb_at_def dom_def ekheap_relation_def st_tcb_at_def obj_at_def)
   apply (erule_tac x=x in allE)+
   apply (rule conjI, force)
   apply clarsimp
   apply (rule conjI, clarsimp simp: EtcbMap_def etcb_relation_def)+
   apply clarsimp
  using pspace_relation
  apply (clarsimp simp add: pspace_relation_def pspace_dom_def UNION_eq
                              dom_def Collect_eq)
  apply (rule iffI)
   apply (erule_tac x=x in allE)+
   apply (case_tac "ksPSpace s' x", clarsimp)
    apply (erule_tac x=x in allE, clarsimp)
   apply clarsimp
   apply (case_tac a, simp_all add: other_obj_relation_def)
  apply (insert pspace_relation)
  apply (clarsimp simp: obj_at'_def projectKOs)
  apply (erule(1) pspace_dom_relatedE)
  apply (erule(1) obj_relation_cutsE)
  apply (clarsimp simp: other_obj_relation_def
                 split: Structures_A.kernel_object.split_asm  if_split_asm
                        ARM_A.arch_kernel_obj.split_asm)+
  done

text {* The following function can be used to reverse cte_map. *}
definition
  "cteMap cns \<equiv> \<lambda>p.
   let P = (%(a,bl). cte_map (a,bl) = p \<and> cns a = Some (length bl))
   in if \<exists>x. P x then (SOME x. P x)
      else (p && ~~ mask 9, bin_to_bl 3 (uint (p>>4)))"

lemma wf_unique':
   "P (THE x. \<forall>y\<in>dom fun. length y = x) \<Longrightarrow>
    well_formed_cnode_n n fun \<Longrightarrow> P n"
apply (subgoal_tac "(THE x. \<forall>y\<in>dom fun. length y = x) = n")
apply simp
apply (rule the_equality)
apply (clarsimp simp add: well_formed_cnode_n_def dom_def Collect_eq)+
apply (erule impE)
apply (rule_tac x="replicate n False" in exI, simp)
apply simp
done

lemma tcb_cap_cases_length:
  "tcb_cap_cases b = Some x \<Longrightarrow> length b = 3"
by (simp add: tcb_cap_cases_def tcb_cnode_index_def split: if_split_asm)

lemma of_bl_mult_and_not_mask_eq:
  "\<lbrakk>is_aligned (a :: word32) n; length b + m \<le> n\<rbrakk>
   \<Longrightarrow> a + of_bl b * (2^m) && ~~ mask n = a"
  apply (simp add: shiftl_t2n[simplified mult.commute, symmetric])
  apply (simp add: mask_out_add_aligned[where q="of_bl b << m", symmetric])
  apply (case_tac "n<32")
   prefer 2
   apply (simp add: not_less power_overflow mask_def)
  apply (simp add: mask_eq_x_eq_0[symmetric])
  apply (rule less_mask_eq)
  apply (rule shiftl_less_t2n, simp_all)
  apply (cut_tac 'a=32 and xs=b in of_bl_length, simp)
  apply (drule nat_move_sub_le)
  apply (drule two_power_increasing[where 'a=32], simp)
  apply (drule (2) less_le_trans)
done

lemma bin_to_bl_of_bl_eq:
  "\<lbrakk>is_aligned (a :: word32) n; length b + 4 \<le> n; length b + 4 < 32\<rbrakk>
  \<Longrightarrow> bin_to_bl (length b) (uint ((a + of_bl b * 0x10) >> 4)) = b"
apply (subst word_plus_and_or_coroll)
 apply (erule is_aligned_get_word_bits)
  apply (rule is_aligned_AND_less_0)
   apply (simp add: is_aligned_mask)
  apply (rule order_less_le_trans)
   apply (rule of_bl_length2)
   apply (simp add: word_bits_conv cte_level_bits_def)
  apply (simp add: two_power_increasing)
 apply simp
apply (rule nth_equalityI)
 apply (simp only: len_bin_to_bl)
apply (clarsimp simp only: len_bin_to_bl nth_bin_to_bl
                           word_test_bit_def[symmetric])
apply (simp add: nth_shiftr nth_shiftl
                 shiftl_t2n[where n=4, simplified mult.commute,
                            simplified, symmetric])
apply (simp add: is_aligned_nth[THEN iffD1, rule_format]
                 test_bit_of_bl nth_rev)
apply (case_tac "b ! i", simp_all)
apply arith
done

lemma CNode_implies_KOCTE:
  "\<lbrakk>pspace_relation (kheap s) (ksPSpace s');
    kheap s a = Some (CNode sz cs); well_formed_cnode_n sz cs; cs b = Some cap\<rbrakk>
   \<Longrightarrow> \<exists>cte. ksPSpace s' (cte_map (a, b)) = Some (KOCTE cte) \<and>
             cap_relation cap (cteCap cte)"
  apply (clarsimp simp add: pspace_relation_def pspace_dom_def
                            dom_def UNION_eq Collect_eq)
  apply (erule_tac x="cte_map (a, b)" in allE)
  apply (erule_tac x=a in allE)
  apply clarsimp
  apply (erule_tac x="cte_map (a, b)" in allE)
  apply (erule_tac x="cte_relation b" in allE)
  apply (erule impE, fastforce simp add: dom_def)
  apply (clarsimp simp add: cte_relation_def)
  apply (drule iffD1)
   apply (fastforce simp add: dom_def image_def)
  apply clarsimp
  done

lemma TCB_implies_KOTCB:
  "\<lbrakk>pspace_relation (kheap s) (ksPSpace s'); kheap s a = Some (TCB tcb)\<rbrakk>
   \<Longrightarrow> \<exists>tcb'. ksPSpace s' a = Some (KOTCB tcb') \<and> tcb_relation tcb tcb'"
  apply (clarsimp simp add: pspace_relation_def pspace_dom_def
                            dom_def UNION_eq Collect_eq)
  apply (erule_tac x=a in allE)+
  apply (clarsimp simp add: other_obj_relation_def
                  split: Structures_H.kernel_object.splits)
  apply (drule iffD1)
   apply (fastforce simp add: dom_def image_def)
  apply clarsimp
  done

lemma cte_at_CNodeI:
  "\<lbrakk>kheap s a = Some (CNode (length b) cs); well_formed_cnode_n (length b) cs\<rbrakk>
   \<Longrightarrow> cte_at (a,b) s"
apply (subgoal_tac "\<exists>y. cs b = Some y")
 apply clarsimp
 apply (rule_tac cte=y in cte_wp_at_cteI[of s _ "length b" cs],
        simp_all)
apply (simp add: well_formed_cnode_n_def dom_def Collect_eq)
done

lemma cteMap_correct:
assumes rel:              "(s,s') \<in> state_relation"
assumes valid_objs:       "valid_objs s"
assumes pspace_aligned:   "pspace_aligned s"
assumes pspace_distinct:  "pspace_distinct s"
assumes pspace_aligned':  "pspace_aligned' s'"
assumes pspace_distinct': "pspace_distinct' s'"
shows
  "p \<in> dom (caps_of_state s) \<longrightarrow> cteMap (gsCNodes s') (cte_map p) = p"
proof -
  from rel have gsCNodes:
    "\<forall>a n. (\<exists>cs. kheap s a = Some (CNode n cs) \<and> well_formed_cnode_n n cs) \<longleftrightarrow>
           gsCNodes s' a = Some n"
    by (simp add: state_relation_def ghost_relation_def)

  show ?thesis
  apply (simp add: dom_def cteMap_def  split: if_split_asm)
  apply (clarsimp simp: caps_of_state_cte_wp_at split: if_split_asm)
  apply (drule cte_wp_cte_at)
  apply (intro conjI impI)
   apply (rule some_equality)
    apply (clarsimp simp add: split_def)
    apply (frule gsCNodes[rule_format,THEN iffD2])
    apply clarsimp
    apply (frule (1) cte_at_CNodeI)
    apply (frule (2) cte_map_inj_eq[OF _ _ _
                        valid_objs pspace_aligned pspace_distinct])
    apply clarsimp
   apply (clarsimp simp add: split_def)
   apply (frule gsCNodes[rule_format,THEN iffD2])
   apply clarsimp
   apply (frule (1) cte_at_CNodeI)
   apply (frule (2) cte_map_inj_eq[OF _ _ _
                       valid_objs pspace_aligned pspace_distinct])
   apply clarsimp

  apply (case_tac p)
  apply (clarsimp simp add: cte_wp_at_cases)
  apply (erule disjE)
   apply clarsimp
   apply (drule_tac x=a in spec, drule_tac x=b in spec, simp)
   apply (cut_tac a=a and n=sz in gsCNodes[rule_format])
   apply clarsimp
   apply (simp add: well_formed_cnode_n_def dom_def Collect_eq)
   apply (erule_tac x=b in allE)
   apply simp
  apply (thin_tac "ALL x. P x" for P)
  apply clarsimp

  apply (frule TCB_implies_KOTCB[OF state_relation_pspace_relation[OF rel]])
  apply clarsimp
  using pspace_aligned'[simplified pspace_aligned'_def]
  apply (drule_tac x=a in bspec, simp add: dom_def)
  apply (simp add: objBitsKO_def cte_map_def)
  apply (rule conjI[rotated])
  apply (drule tcb_cap_cases_length)
  apply (frule_tac b=b in bin_to_bl_of_bl_eq, simp+)
  apply (case_tac "b = [False, False, False]")
   apply (simp add: is_aligned_neg_mask_eq)
  apply (frule_tac b=b in bin_to_bl_of_bl_eq, (simp add: tcb_cap_cases_length)+)
  apply (subgoal_tac "ksPSpace s' (cte_map (a, b)) = None")
   prefer 2
   apply (rule ccontr)
   apply clarsimp
   using pspace_distinct'[simplified pspace_distinct'_def]
   apply (drule_tac x=a in bspec, simp add: dom_def)
   apply (simp add: ps_clear_def dom_def mask_2pm1[symmetric] x_power_minus_1)
   apply (simp add: objBitsKO_def)
   apply (drule_tac a="cte_map (a, b)" in equals0D)
   apply (clarsimp simp add: cte_map_def)
   apply (drule tcb_cap_cases_length)
   apply (erule impE)
    apply (rule word_plus_mono_right)
     apply (cut_tac 'a=32 and xs=b in of_bl_length, simp add: word_bits_conv)
     apply (drule_tac k=16 in word_mult_less_mono1, simp+)
     apply (simp add: mask_def)
     apply (rule ccontr)
     apply (simp add: not_le)
     apply (drule (1) less_trans, simp)
    apply (drule is_aligned_no_overflow'[simplified mask_2pm1[symmetric]])
    apply (simp add: word_bits_conv)
   apply simp
   apply (erule impE)
    apply (drule is_aligned_no_overflow'[simplified mask_2pm1[symmetric]])
    apply (cut_tac 'a=32 and xs=b in of_bl_length, simp add: word_bits_conv)
    apply (drule_tac k=16 in word_mult_less_mono1, simp+)
    apply (subgoal_tac "(0x80::word32) < mask 9")
     prefer 2
     apply (simp add: mask_def)
    apply (rule_tac word_random, simp+)
   apply (simp add: mult.commute[of _ 16]
                    shiftl_t2n[of _ 4, simplified,symmetric])
   apply word_bitwise
   apply simp
   apply (case_tac b, simp)
   apply (rename_tac b, case_tac b, simp)
   apply (rename_tac b, case_tac b, simp)
   apply (clarsimp simp add: test_bit_of_bl eval_nat_numeral)
  apply (simp add: cte_map_def split: option.splits)
  apply (drule tcb_cap_cases_length)
  apply (rule of_bl_mult_and_not_mask_eq[where m=4, simplified], simp+)
  done
qed

definition (* NOTE: cnp maps addresses to CNode, offset pairs *)
  "absIsOriginalCap cnp h \<equiv>
   %(oref,cref).
   cnp (cte_map (oref, cref)) = (oref, cref) \<and>
   cte_map (oref,cref) : dom (map_to_ctes h) \<and>
   (\<exists>cte. map_to_ctes h (cte_map (oref,cref)) = Some cte \<and>
          (cteCap cte \<noteq> capability.NullCap) \<and> mdbRevocable (cteMDBNode cte))"

lemma absIsOriginalCap_correct:
assumes valid_ioc: "valid_ioc s"
assumes valid_objs: "valid_objs s"
assumes rel: "(s,s') \<in> state_relation"
assumes pspace_aligned: "pspace_aligned s"
assumes pspace_distinct: "pspace_distinct s"
assumes pspace_aligned': "pspace_aligned' s'"
assumes pspace_distinct': "pspace_distinct' s'"
shows
  "absIsOriginalCap (cteMap (gsCNodes s')) (ksPSpace s') = is_original_cap s"
proof -
  from valid_ioc
  have no_cap_not_orig:
    "\<forall>p. caps_of_state s p = None \<longrightarrow> is_original_cap s p = False"
  and null_cap_not_orig:
    "\<forall>p. caps_of_state s p = Some cap.NullCap \<longrightarrow> is_original_cap s p = False"
    by (fastforce simp: valid_ioc_def2 null_filter_def)+

  have cnp:
  "\<forall>a b. caps_of_state s (a, b) \<noteq> None \<longrightarrow>
         (cteMap (gsCNodes s')) (cte_map (a, b)) = (a, b)"
    using cteMap_correct[OF rel valid_objs pspace_aligned pspace_distinct
                            pspace_aligned' pspace_distinct']
    by (clarsimp simp: dom_def)

  show ?thesis
    apply (subgoal_tac "revokable_relation (is_original_cap s)
                          (null_filter (caps_of_state s)) (ctes_of s') \<and>
                        pspace_relation (kheap s) (ksPSpace s')")
     prefer 2
     using rel
     apply (clarsimp simp add: state_relation_def)
    apply (rule ext)
    apply (clarsimp simp add: revokable_relation_def
                              null_filter_def absIsOriginalCap_def
                       split: if_split_asm)
    apply (erule_tac x=a in allE)
    apply (erule_tac x=b in allE)
    apply (case_tac "caps_of_state s (a, b)")
     apply (clarsimp simp: no_cap_not_orig)
     apply (frule (1) pspace_relation_cte_wp_atI[OF _ _ valid_objs])
     apply (clarsimp simp: cte_wp_at_caps_of_state)
     apply (subgoal_tac "(a,b) = (aa,ba)", simp)
     apply (cut_tac a=aa and b=ba in cnp[rule_format], simp)
     apply (simp add: cte_map_def)
    apply simp
    apply (case_tac "aa = cap.NullCap")
     apply (clarsimp simp add: null_cap_not_orig)
     apply (frule (1) pspace_relation_ctes_ofI
              [OF _ caps_of_state_cteD pspace_aligned' pspace_distinct'])
     apply clarsimp
    apply (frule (1) pspace_relation_ctes_ofI
             [OF _ caps_of_state_cteD pspace_aligned' pspace_distinct'])
    apply (clarsimp simp add: dom_def)
    apply (cut_tac a=a and b=b in cnp[rule_format], simp+)
    apply (case_tac cte, clarsimp)
    apply (case_tac aa, simp_all)
    apply (rename_tac arch_cap)
    apply (case_tac arch_cap, simp_all)
    done
qed

text {*
  In the executable specification,
  a linked list connects all children of a certain node.
  More specifically, the predicate @{term "subtree h c c'"} holds iff
  the map @{term h} from addresses to CTEs contains capabilities
  at the addresses @{term c} and @{term c'} and
  the latter is a child of the former.

  In the abstract specification, the capability-derivation tree @{term "cdt s"}
  maps the address of each capability to the address of its immediate parent.

  The definition below takes a binary predicate @{term ds} as parameter,
  which represents a childhood relation like @{term "subtree h"},
  and converts this into an optional function to the immediate parent
  in the same format as @{term "cdt s"}.
*}
definition
  "parent_of' ds \<equiv> %x.
   if \<forall>p. \<not> ds p x then None
   else Some (THE p. ds p x \<and> (\<forall>q. ds p q \<and> ds q x \<longrightarrow> p = q))"

definition
  "absCDT cnp h \<equiv>
   \<lambda>(oref,cref).
   if cnp (cte_map (oref, cref)) = (oref, cref)
     then map_option cnp (parent_of' (subtree h) (cte_map (oref, cref)))
   else None"

lemma valid_mdb_mdb_cte_at:
  "valid_mdb s
   \<Longrightarrow> mdb_cte_at (\<lambda>p. \<exists>c. caps_of_state s p = Some c \<and> cap.NullCap \<noteq> c)
      (cdt s)"
  by (simp add: valid_mdb_def2)

lemma cte_map_inj_through_cnp:
  "\<lbrakk> cte_map p = cte_map p'; cnp (cte_map p) = p; cnp (cte_map p') = p' \<rbrakk>
    \<Longrightarrow> p = p'"
  by (drule arg_cong[where f=cnp]) metis

lemma ctes_of_cte_wp_atD:
  "ctes_of s p = Some cte \<Longrightarrow> cte_wp_at' (op = cte) p s"
by (simp add: KHeap_R.cte_wp_at_ctes_of)

lemma absCDT_correct':
assumes pspace_aligned: "pspace_aligned s"
assumes pspace_distinct: "pspace_distinct s"
assumes pspace_aligned': "pspace_aligned' s'"
assumes pspace_distinct': "pspace_distinct' s'"
assumes valid_objs: "valid_objs s"
assumes valid_mdb:  "valid_mdb s"
assumes rel:  "(s,s') \<in> state_relation"
shows
  "absCDT (cteMap (gsCNodes s')) (ctes_of s') = cdt s" (is ?P)
  "(case (cdt s x) of None \<Rightarrow> caps_of_state s x \<noteq> None \<longrightarrow> (\<forall>q. \<not>(ctes_of s' \<turnstile> q \<rightarrow> cte_map x)) |
             Some p \<Rightarrow>
             ctes_of s' \<turnstile> cte_map p \<rightarrow> cte_map x \<and>
                   (\<forall>q. ctes_of s' \<turnstile> cte_map p \<rightarrow> q \<and>
                        ctes_of s' \<turnstile> q \<rightarrow> cte_map x \<longrightarrow>
                        cte_map p = q))" (is ?Q)
proof -

  have cnp:
  "\<forall>a b. caps_of_state s (a, b) \<noteq> None \<longrightarrow>
         (cteMap (gsCNodes s')) (cte_map (a, b)) = (a, b)"
    using cteMap_correct[OF rel valid_objs pspace_aligned pspace_distinct
                            pspace_aligned' pspace_distinct']
    by (clarsimp simp: dom_def)

  from rel
  have descs_eq:
    "\<forall>a b. cte_wp_at (\<lambda>_. True) (a, b) s \<longrightarrow>
           {y. \<exists>x\<in>descendants_of (a, b) (cdt s). y = cte_map x} =
               descendants_of' (cte_map (a, b)) (ctes_of s')"
    apply (clarsimp simp add: state_relation_def)
    apply (clarsimp simp add: swp_def cdt_relation_def image_def)
    done

  from rel
  have pspace_relation: "pspace_relation (kheap s) (ksPSpace s')"
    by (clarsimp simp add: state_relation_def)

  note cdt_has_caps = mdb_cte_atD[OF _ valid_mdb_mdb_cte_at[OF valid_mdb]]
  note descendants_of_simps =
    descendants_of_def cdt_parent_rel_def is_cdt_parent_def

  have descendants_implies:
    "\<And>p p'. p' \<in> descendants_of p (cdt s) \<Longrightarrow>
            \<exists>cap cap'. caps_of_state s p = Some cap \<and>
                       caps_of_state s p' = Some cap'"
    apply (clarsimp simp: descendants_of_simps)
    apply (frule tranclD2, drule tranclD)
    apply (auto dest: cdt_has_caps)
    done

  let ?cnp = "cteMap (gsCNodes s')"
  have subtree_implies:
  "\<And>p p'. subtree (ctes_of s') p p' \<Longrightarrow>
           \<exists>cap cap'. ?cnp p' \<in> descendants_of (?cnp p) (cdt s) \<and>
                      caps_of_state s (?cnp p) = Some cap \<and>
                      caps_of_state s (?cnp p') = Some cap' \<and>
           (\<exists>cte cte'. ctes_of s' p = Some cte \<and> ctes_of s' p' = Some cte')"
    apply (subgoal_tac "(ctes_of s') \<turnstile> p parentOf p'")
     prefer 2
     apply (erule subtree.cases, simp+)
    apply (clarsimp simp add: parentOf_def)
    apply (frule_tac x=p in
      pspace_relation_cte_wp_atI[OF pspace_relation _ valid_objs])
    apply clarsimp
    apply (frule descs_eq[rule_format, OF cte_wp_at_weakenE], simp)
    apply (simp add: descendants_of'_def Collect_eq)
    apply (drule spec, drule(1) iffD2)
    apply (clarsimp simp: cnp cte_wp_at_caps_of_state)
    apply (frule descendants_implies)
    apply (clarsimp simp: cnp)
    done
  have is_parent:
  "\<And>a b p cap cap' a' b' c.
       \<lbrakk>cdt s (a, b) = Some (a', b')\<rbrakk>
       \<Longrightarrow> ctes_of s' \<turnstile> cte_map (a', b') \<rightarrow> cte_map (a, b) \<and>
          (\<forall>q. ctes_of s' \<turnstile> cte_map (a', b') \<rightarrow> q \<and>
               ctes_of s' \<turnstile> q \<rightarrow> cte_map (a, b) \<longrightarrow>
               cte_map (a', b') = q)"
    apply (frule cdt_has_caps)
    using descs_eq pspace_relation
    apply (frule_tac x=a' in spec, erule_tac x=b' in allE)
     apply (simp add: cte_wp_at_caps_of_state Collect_eq descendants_of_simps
                      descendants_of'_def)
     apply (rule conjI)
      apply fastforce
     apply clarsimp
     apply (drule subtree_implies)+
     apply (clarsimp simp: cnp)
     using valid_mdb
     apply (clarsimp simp: cnp descendants_of_simps valid_mdb_def no_mloop_def)
     apply (drule_tac x="?cnp q" and y="(a, b)" in tranclD2)
     apply clarsimp
     apply (fastforce intro: trancl_rtrancl_trancl)
     done

  show ?P
    apply (rule ext)
    using descs_eq pspace_relation
    apply (simp add: absCDT_def)
    apply (rule conjI[rotated])
     apply clarsimp
     apply (rule sym, rule ccontr, clarsimp)
     apply (frule cdt_has_caps)
     using cnp
     apply fastforce
    apply clarsimp

    apply (clarsimp simp: parent_of'_def)
    apply (rule conjI)
     apply clarsimp
     apply (rule sym, rule ccontr, clarsimp)
     apply (simp add: descendants_of_simps descendants_of'_def)
     apply (rename_tac a' b')
     apply (erule_tac x=a' in allE, erule_tac x=b' in allE)
     apply (erule_tac x="cte_map (a', b')" in allE, erule notE)
     apply (frule cdt_has_caps)
     apply (clarsimp simp: cte_wp_at_caps_of_state Collect_eq)
     apply fastforce
    apply clarsimp
    apply (drule subtree_implies)
    apply clarsimp
    apply (case_tac "cdt s (a, b)")
     apply (simp add: descendants_of_simps descendants_of'_def)
     apply (drule tranclD2)
     apply clarsimp
    apply clarsimp
    apply (rename_tac a' b')
    apply (frule cdt_has_caps)
    apply clarsimp
    apply (rule trans[rotated])
     apply (rule cnp[rule_format], simp)
    apply (rule arg_cong[where f="?cnp"])
    apply (rule the_equality)
    apply (rule is_parent,assumption)
    apply clarsimp
    apply (rule ccontr)
    apply (drule_tac x="cte_map (a', b')" in spec, drule mp)
     apply simp_all
    apply (drule subtree_implies)
    apply clarsimp
    apply (drule_tac p=pa in ctes_of_cte_wp_atD)
    apply (drule pspace_relation_cte_wp_atI'[OF pspace_relation _ valid_objs])
    apply (clarsimp simp add: cte_wp_at_caps_of_state cnp)
    apply (thin_tac "(a, b) \<in> descendants_of (?cnp p) (cdt s)",
           thin_tac "caps_of_state s (?cnp p) = Some cap")
    apply (unfold descendants_of'_def)
    apply (erule_tac x=a' in allE)
    apply (erule_tac x=b' in allE)
    apply (simp add: Collect_eq)
    apply (erule_tac x="cte_map (a, b)" in allE)
    apply (drule iffD1)
     apply (rule_tac x="(a, b)" in bexI, simp)
     apply (clarsimp simp: cnp descendants_of_simps)
     apply (rule trancl.intros(1))
     apply simp_all
    apply (rule descs_eq[simplified descendants_of'_def Collect_eq,
                         rule_format, THEN iffD1])
     apply (clarsimp simp add: cte_wp_at_caps_of_state)
    apply (rule_tac x="(a', b')" in bexI, simp)
    apply (clarsimp simp: descendants_of_simps)
    apply (drule_tac x="(aa,ba)" and y="(a, b)" in tranclD2)
    apply clarsimp
    apply (drule rtranclD, erule disjE, simp_all)[1]
     done
  thus ?Q
    apply (case_tac x)
    apply (case_tac "cdt s (a, b)")
     apply (drule sym)
     apply (simp add: mdb_cte_at_def)
     apply (simp add: absCDT_def split_def)
     apply (simp add: parent_of'_def split: if_split_asm)
     apply (intro impI)
     apply (frule_tac a=a and b=b in cnp[simplified,rule_format])
     apply simp
    apply simp
    apply (clarsimp simp: is_parent)
    done
qed

lemmas absCDT_correct = absCDT_correct'(1)
lemmas cdt_simple_rel =  absCDT_correct'(2)

lemma has_parent_cte_at:"valid_mdb s \<Longrightarrow> (cdt s) c = Some p \<Longrightarrow> cte_at c s"
  apply (rule cte_wp_cte_at)
  apply (simp add: valid_mdb_def mdb_cte_at_def del: split_paired_All)
  apply blast
  done

lemma has_child_cte_at:"valid_mdb s \<Longrightarrow> (cdt s) c = Some p \<Longrightarrow> cte_at p s"
  apply (rule cte_wp_cte_at)
  apply (simp add: valid_mdb_def mdb_cte_at_def del: split_paired_All)
  apply blast
  done

(* Produce a cdt_list from a cdt by sorting the children
   sets by reachability via mdbNext. We then demonstrate
   that a list satisfying the state relation must
   already be sorted in the same way and therefore is
   equivalent. *)

definition sort_cdt_list where
"sort_cdt_list cd m = (\<lambda>p. (THE xs. set xs = {c. cd c = Some p} \<and> partial_sort.psorted (\<lambda>x y. m \<turnstile> cte_map x \<leadsto>\<^sup>* cte_map y) xs \<and> distinct xs))"

end

locale partial_sort_cdt = partial_sort "\<lambda> x y.  m' \<turnstile> cte_map x \<leadsto>\<^sup>* cte_map y"
                                       "\<lambda> x y. cte_at x (s::det_state) \<and> cte_at y s \<and> (\<exists>p. m' \<turnstile> p \<rightarrow> cte_map x \<and> m' \<turnstile> p \<rightarrow> cte_map y)" for m' s +
  fixes s'::"kernel_state"
  fixes m t
  defines "m \<equiv> (cdt s)"
  defines "t \<equiv> (cdt_list s)"
  assumes m'_def : "m' = (ctes_of s')"
  assumes rel:"(s,s') \<in> state_relation"
  assumes valid_mdb: "valid_mdb s"
  assumes assms' : "pspace_aligned s" "pspace_distinct s" "pspace_aligned' s'"
                   "pspace_distinct' s'" "valid_objs s" "valid_mdb s" "valid_list s"

begin

interpretation Arch . (*FIXME: arch_split*)

lemma valid_list_2 : "valid_list_2 t m"
    apply (insert assms')
    apply (simp add: t_def m_def)
    done

lemma has_next_not_child_is_descendant:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows
  "next_not_child slot t m = Some slot2 \<Longrightarrow> (\<exists>p. slot \<in> descendants_of p m)"
  apply (drule next_not_childD)
  apply (simp add: m_def finite_depth assms')+
   using assms'
   apply (simp add: valid_mdb_def)
  apply (elim disjE)
   apply (drule next_sib_same_parent[OF valid_list_2])
   apply (elim exE)
   apply (rule_tac x=p in exI)
   apply (rule child_descendant)
   apply simp
  apply (elim conjE exE)
  apply force
  done

lemma has_next_slot_is_descendant :
    notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows
    "next_slot slot t m = Some slot2 \<Longrightarrow> m slot2 = Some slot \<or> (\<exists>p. slot \<in> descendants_of p m)"
    apply (insert valid_list_2)
    apply (simp add: next_slot_def next_child_def split: if_split_asm)
     apply (case_tac "t slot",simp+)
     apply (simp add: valid_list_2_def)
     apply (rule disjI1)
     apply force
    apply (rule disjI2)
    apply (erule has_next_not_child_is_descendant)
    done

lemma descendant_has_parent:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
    shows
  "slot \<in> descendants_of p m \<Longrightarrow> \<exists>q. m slot = Some q"
  apply (simp add: descendants_of_def)
  apply (drule tranclD2)
  apply (simp add: cdt_parent_of_def)
  apply force
  done

lemma next_slot_cte_at:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows
  "next_slot slot t m = Some slot2 \<Longrightarrow> cte_at slot s"
   apply (cut_tac valid_mdb_mdb_cte_at)
   prefer 2
   apply (cut_tac assms')
   apply simp
  apply (fold m_def)
  apply (simp add: mdb_cte_at_def)
  apply (simp add: cte_wp_at_caps_of_state)
  apply (drule has_next_slot_is_descendant)
  apply (elim disjE)
   apply force
  apply (elim exE)
  apply (drule descendant_has_parent)
  apply force
  done

lemma cte_at_has_cap: "cte_at slot s \<Longrightarrow> \<exists>c. cte_wp_at (op = c) slot s"
  apply (drule cte_at_get_cap_wp)
  apply force
  done

  lemma next_slot_mdb_next:
  notes split_paired_All[simp del]
  shows
 "next_slot slot t m = Some slot2 \<Longrightarrow> m' \<turnstile> (cte_map slot) \<leadsto> (cte_map slot2)"
    apply (frule cte_at_has_cap[OF next_slot_cte_at])
    apply (elim exE)
    apply (cut_tac s=s and s'=s' in pspace_relation_ctes_ofI)
        apply (fold m'_def)
        using rel
        apply (simp add: state_relation_def)
       apply simp
      using assms'
      apply simp
     using assms'
     apply simp
    apply (subgoal_tac "cdt_list_relation t m m'")
     apply (simp add: cdt_list_relation_def)
     apply (elim exE)
     apply (case_tac cte)
     apply (simp add: mdb_next_rel_def mdb_next_def)
     apply force
    using rel
    apply (simp add: state_relation_def m_def t_def m'_def)
    done

  lemma next_sib_2_reachable: "next_sib_2 slot p s = Some slot2  \<Longrightarrow> m' \<turnstile> (cte_map slot) \<leadsto>\<^sup>* (cte_map slot2)"
    apply (induct slot rule: next_sib_2_pinduct[where s=s and p=p])
    apply (cut_tac slot=slot and s=s and p=p in next_sib_2.psimps[OF next_sib_2_termination], (simp add: assms')+)
    apply (fold m_def t_def)
      apply (simp split: if_split_asm)
      apply (case_tac "next_slot slot t m")
       apply simp
      apply (simp split: if_split_asm)
       apply (rule r_into_rtrancl)
       apply (erule next_slot_mdb_next)
      apply (drule_tac x="a" in meta_spec)
      apply simp
      apply (rule trans)
       apply (rule r_into_rtrancl)
       apply (rule next_slot_mdb_next)
       apply (simp add: assms' valid_list_2)+
    done

lemma next_sib_reachable: "next_sib slot t m = Some slot2 \<Longrightarrow> m slot = Some p \<Longrightarrow>
                             m' \<turnstile> (cte_map slot) \<leadsto>\<^sup>* (cte_map slot2)"
    apply (rule next_sib_2_reachable)
    apply (insert assms')
    apply (simp add: t_def m_def)
    apply (subst next_sib_def2,simp+)
    done

lemma after_in_list_next_reachable:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows
  "after_in_list (t p) slot = Some slot2 \<Longrightarrow> m' \<turnstile> (cte_map slot) \<leadsto>\<^sup>* (cte_map slot2)"
    apply (subgoal_tac "m slot = Some p")
   apply (rule next_sib_reachable)
    apply (simp add: next_sib_def)+
  apply (drule after_in_list_in_list')
  apply (insert valid_list_2)
  apply (simp add: valid_list_2_def)
    done

lemma sorted_lists:
   "psorted (t p)"
    apply (rule after_order_sorted)
     apply (rule after_in_list_next_reachable)
     apply simp
    apply (insert assms')
    apply (simp add: valid_list_def t_def del: split_paired_All)
    done

lemma finite_children:
notes split_paired_All[simp del]
shows
"finite {c. m c = Some p}"
  apply (insert assms')
  apply(subgoal_tac "{x. x \<in> descendants_of p (cdt s)} \<subseteq> {x. cte_wp_at (\<lambda>_. True) x s}")
   prefer 2
   apply(fastforce simp: descendants_of_cte_at)
  apply(drule finite_subset)
   apply(simp add: cte_wp_at_set_finite)
  apply(subgoal_tac "{c. m c = Some p} \<subseteq> {c. c \<in> descendants_of p (cdt s)}")
   apply (drule finite_subset)
    apply simp
   apply simp
  apply clarsimp
  apply (simp add: m_def child_descendant)
  done

lemma ex1_sorted_cdt: "\<exists>!xs. set xs = {c. m c = Some p} \<and>
           psorted xs \<and>
           distinct xs"
  apply (rule psorted_set[OF finite_children])
  apply (simp add: R_set_def)
  apply (intro impI conjI allI)
    apply (simp add: has_parent_cte_at[OF valid_mdb] m_def)
   apply (simp add: has_parent_cte_at[OF valid_mdb] m_def)

  apply (cut_tac s=s and s'=s' and x="(a,b)" in cdt_simple_rel, simp_all add: assms' rel)
  apply (simp add: m_def)
  apply (cut_tac s=s and s'=s' and x="(aa,ba)" in cdt_simple_rel, simp_all add: assms' rel)
  apply (rule_tac x="cte_map p" in exI)
  apply (simp add: m'_def)
  done

lemma sort_cdt_list_correct:
  "sort_cdt_list m m' = t"
  apply (rule ext)
  apply (simp add: sort_cdt_list_def)
  apply (rule the1_equality)
   apply (rule ex1_sorted_cdt)
  apply (simp add: sorted_lists)
  apply (insert assms')
  apply (simp add: valid_list_def t_def m_def del: split_paired_All)
  done

end

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

definition absCDTList where
"absCDTList cnp h \<equiv> sort_cdt_list (absCDT cnp h) h"

lemma no_loops_sym_eq: "no_loops m \<Longrightarrow> m \<turnstile> a \<leadsto>\<^sup>* b \<Longrightarrow> m \<turnstile> b \<leadsto>\<^sup>* a \<Longrightarrow> a = b"
  apply (rule ccontr)
  apply (subgoal_tac "m \<turnstile> a \<leadsto>\<^sup>+ a")
   apply (simp add: no_loops_def)
  apply (simp add: rtrancl_eq_or_trancl)
  done

lemma mdb_next_single_valued: "single_valued (mdb_next_rel m)"
  apply (simp add: single_valued_def mdb_next_rel_def)
  done

lemma substring_next: "m \<turnstile> a \<leadsto>\<^sup>* b \<Longrightarrow> m \<turnstile> a \<leadsto>\<^sup>* c \<Longrightarrow> m \<turnstile> b \<leadsto>\<^sup>* c \<or> m \<turnstile> c \<leadsto>\<^sup>* b"
  apply (rule single_valued_confluent)
  apply (rule mdb_next_single_valued)
  apply simp+
  done

lemma ancestor_comparable: "\<lbrakk>m \<turnstile> a \<rightarrow> x; m \<turnstile> a \<rightarrow> y\<rbrakk> \<Longrightarrow> m \<turnstile> x \<leadsto>\<^sup>* y \<or> m \<turnstile> y \<leadsto>\<^sup>* x"
  apply (rule substring_next)
  apply (erule subtree_mdb_next[THEN trancl_into_rtrancl])+
  done

lemma valid_mdb'_no_loops: "valid_mdb' s \<Longrightarrow> no_loops (ctes_of s)"
  apply (rule mdb_chain_0_no_loops)
  apply (simp add: valid_mdb'_def valid_mdb_ctes_def)+
  done

lemma absCDTList_correct:
notes split_paired_All[simp del] split_paired_Ex[simp del]
assumes valid_mdb:  "valid_mdb s"
assumes valid_mdb': "valid_mdb' s'"
assumes valid_list: "valid_list s"
assumes valid_objs: "valid_objs s"
assumes pspace_aligned: "pspace_aligned s"
assumes pspace_aligned': "pspace_aligned' s'"
assumes pspace_distinct: "pspace_distinct s"
assumes pspace_distinct': "pspace_distinct' s'"
assumes rel:  "(s,s') \<in> state_relation"
shows
  "absCDTList (cteMap (gsCNodes s')) (ctes_of s') = cdt_list s"
  apply (simp add: absCDTList_def)
  apply (subst absCDT_correct[where s=s])
         apply (simp add: assms)+
  apply (rule partial_sort_cdt.sort_cdt_list_correct[where s'=s'])
  apply (simp add: partial_sort_cdt_def)
  apply (rule context_conjI')
   apply unfold_locales
             apply (simp add: assms)+
    apply (simp add: partial_sort_cdt_axioms_def)
    apply (elim conjE exE)
    apply (rule ancestor_comparable,assumption+)
   apply (elim conjE)
   apply (rule cte_map_inj_eq)
        apply (rule no_loops_sym_eq[where m="ctes_of s'"])
          apply (rule valid_mdb'_no_loops[OF valid_mdb'])
         apply (simp add: assms)+
  done

definition
  "absInterruptIRQNode is' \<equiv> \<lambda>irq.
   case is' of InterruptState node irqs' \<Rightarrow>
   node + (ucast irq << cte_level_bits)"

definition
  "irq_state_map s \<equiv> case s of
     irq_state.IRQInactive \<Rightarrow> irqstate.IRQInactive
   | irq_state.IRQSignal \<Rightarrow> irqstate.IRQSignal
   | irq_state.IRQTimer \<Rightarrow> irqstate.IRQTimer
   | irq_state.IRQReserved \<Rightarrow> irqstate.IRQReserved"

definition
  "IRQStateMap s \<equiv> case s of
     irqstate.IRQInactive \<Rightarrow> irq_state.IRQInactive
   | irqstate.IRQSignal \<Rightarrow> irq_state.IRQSignal
   | irqstate.IRQTimer \<Rightarrow> irq_state.IRQTimer
   | irqstate.IRQReserved \<Rightarrow> irq_state.IRQReserved"

lemma irq_state_map_inv:
  "irq_state_map (IRQStateMap s) = s"
  by (cases s) (simp_all add: irq_state_map_def IRQStateMap_def)

lemma IRQStateMap_inv:
  "IRQStateMap (irq_state_map s) = s"
  by (cases s) (simp_all add: irq_state_map_def IRQStateMap_def)

definition
  "absInterruptStates is' \<equiv>
   case is' of InterruptState node m \<Rightarrow>
 IRQStateMap \<circ> m"

lemma absInterruptIRQNode_correct:
  "interrupt_state_relation (interrupt_irq_node s) (interrupt_states s)
      (ksInterruptState s') \<Longrightarrow>
   absInterruptIRQNode (ksInterruptState s') = interrupt_irq_node s"
   by (rule ext) (clarsimp simp add: absInterruptIRQNode_def
                                     interrupt_state_relation_def)

lemma absInterruptStates_correct:
  "interrupt_state_relation (interrupt_irq_node s) (interrupt_states s)
      (ksInterruptState s') \<Longrightarrow>
   absInterruptStates (ksInterruptState s') = interrupt_states s"
apply (rule ext)
apply (clarsimp simp add: absInterruptStates_def IRQStateMap_def
         interrupt_state_relation_def irq_state_relation_def)
apply (erule_tac x=x in allE)+
apply (clarsimp split: irq_state.splits irqstate.splits)
done

definition
  "absArchState s' \<equiv>
   case s' of ARMKernelState asid_tbl hwat anext am gpd gpts kvspace \<Rightarrow>
     \<lparr>arm_asid_table = asid_tbl \<circ> ucast,
      arm_hwasid_table = hwat, arm_next_asid = anext,
      arm_asid_map = am, arm_global_pd = gpd, arm_global_pts = gpts,
      arm_kernel_vspace = kvspace\<rparr>"

lemma absArchState_correct:
assumes rel:
  "(s,s') \<in> state_relation"
shows
  "absArchState (ksArchState s') = arch_state s"
apply (subgoal_tac "(arch_state s, ksArchState s') \<in> arch_state_relation")
 prefer 2
 using rel
 apply (simp add: state_relation_def)
apply (clarsimp simp add: arch_state_relation_def)
by (clarsimp simp add: absArchState_def
             split: ARM_H.kernel_state.splits)

definition absSchedulerAction where
  "absSchedulerAction action \<equiv>
    case action of ResumeCurrentThread \<Rightarrow> resume_cur_thread
                 | SwitchToThread t \<Rightarrow> switch_thread t
                 | ChooseNewThread \<Rightarrow> choose_new_thread"

lemma absSchedulerAction_correct:
  assumes act_rel: "sched_act_relation action action'"
  shows " absSchedulerAction action' = action"
  using act_rel
  by (cases action, simp_all add: absSchedulerAction_def)

definition
  "absExst s \<equiv>
     \<lparr>work_units_completed_internal = ksWorkUnitsCompleted s,
      scheduler_action_internal = absSchedulerAction (ksSchedulerAction s),
      ekheap_internal = absEkheap (ksPSpace s),
      domain_list_internal = ksDomSchedule s,
      domain_index_internal = ksDomScheduleIdx s,
      cur_domain_internal = ksCurDomain s,
      domain_time_internal = ksDomainTime s,
      ready_queues_internal = curry (ksReadyQueues s),
      cdt_list_internal = absCDTList (cteMap (gsCNodes s)) (ctes_of s)\<rparr>"

lemma absExst_correct:
  assumes invs: "einvs s" and invs': "invs' s'"
  assumes rel: "(s, s') \<in> state_relation"
  shows "absExst s' = exst s"
  apply (rule det_ext.equality)
      using rel invs invs'
      apply (simp_all add: absExst_def absSchedulerAction_correct absEkheap_correct
                           absCDTList_correct[THEN fun_cong] state_relation_def invs_def valid_state_def
                           ready_queues_relation_def invs'_def valid_state'_def
                           valid_pspace_def valid_sched_def valid_pspace'_def curry_def fun_eq_iff)
      apply (fastforce simp: absEkheap_correct)
  done

definition
  "absKState s \<equiv>
   \<lparr>kheap = absHeap (gsUserPages s) (gsCNodes s) (ksPSpace s),
    cdt = absCDT (cteMap (gsCNodes s)) (ctes_of s),
    is_original_cap = absIsOriginalCap (cteMap (gsCNodes s)) (ksPSpace s),
    cur_thread = ksCurThread s, idle_thread = ksIdleThread s,
    machine_state = observable_memory (ksMachineState s) (user_mem' s),
    interrupt_irq_node = absInterruptIRQNode (ksInterruptState s),
    interrupt_states = absInterruptStates (ksInterruptState s),
    arch_state = absArchState (ksArchState s),
    exst = absExst s\<rparr>"

(* TODO: move *)
lemma invs_valid_ioc[elim!]: "invs s \<Longrightarrow> valid_ioc s"
  by (clarsimp simp add: invs_def valid_state_def)

definition
  checkActiveIRQ :: "(kernel_state, bool) nondet_monad"
  where
  "checkActiveIRQ \<equiv>
   do irq \<leftarrow> doMachineOp getActiveIRQ;
      return (irq \<noteq> None)
   od"

definition
  check_active_irq_H :: "((user_context \<times> kernel_state) \<times> bool \<times> (user_context \<times> kernel_state)) set"
  where
  "check_active_irq_H \<equiv> {((tc, s), irq, (tc, s')). (irq, s') \<in> fst (checkActiveIRQ s)}"

definition
  doUserOp :: "user_transition \<Rightarrow> user_context \<Rightarrow>
               (kernel_state, event option \<times> user_context) nondet_monad"
  where
  "doUserOp uop tc \<equiv>
   do t \<leftarrow> getCurThread;
      trans \<leftarrow> gets (ptable_lift t \<circ> absKState);
      perms \<leftarrow> gets (ptable_rights t \<circ> absKState);

      um \<leftarrow> gets (\<lambda>s. user_mem' s \<circ> ptrFromPAddr);
      dm \<leftarrow> gets (\<lambda>s. device_mem' s \<circ> ptrFromPAddr);

      ds \<leftarrow> gets (device_state \<circ> ksMachineState);
      assert (dom (um \<circ> addrFromPPtr) \<subseteq> - dom ds);
      assert (dom (dm \<circ> addrFromPPtr) \<subseteq> dom ds);

      (e, tc',um',ds') \<leftarrow> select (fst (uop t (restrict_map trans {pa. perms pa \<noteq> {}}) perms
                   (tc, restrict_map um
                        {pa. \<exists>va. trans va = Some pa \<and> AllowRead \<in> perms va}
                       ,(ds \<circ> ptrFromPAddr) |`  {pa. \<exists>va. trans va = Some pa \<and> AllowRead \<in> perms va} )
                       ));
      doMachineOp (user_memory_update
                       ((um' |` {pa. \<exists>va. trans va = Some pa \<and> AllowWrite \<in> perms va}
                      \<circ> addrFromPPtr) |` (- dom ds)));
      doMachineOp (device_memory_update
                       ((ds' |` {pa. \<exists>va. trans va = Some pa \<and> AllowWrite \<in> perms va}
                      \<circ> addrFromPPtr )|` (dom ds)));
      return (e, tc')
   od"

definition
  do_user_op_H
    :: "user_transition \<Rightarrow>
        ((user_context \<times> kernel_state) \<times> (event option \<times> user_context \<times> kernel_state)) set"
  where
  "do_user_op_H uop \<equiv> monad_to_transition (doUserOp uop)"

definition
  "kernelEntry e tc \<equiv> do
    t \<leftarrow> getCurThread;
    threadSet (\<lambda>tcb. tcb \<lparr> tcbArch := atcbContextSet tc (tcbArch tcb) \<rparr>) t;
    callKernel e;
    t' \<leftarrow> getCurThread;
    threadGet (atcbContextGet o tcbArch) t'
  od"

definition
  kernel_call_H
    :: "event \<Rightarrow> ((user_context \<times> kernel_state) \<times> mode \<times>
                  (user_context \<times> kernel_state)) set"
  where
  "kernel_call_H e \<equiv>
      {(s, m, s'). s' \<in> fst (split (kernelEntry e) s) \<and>
                   m = (if ct_running' (snd s') then UserMode else IdleMode)}"

definition
  ADT_H :: "user_transition \<Rightarrow>
            (kernel_state global_state, det_ext observable, unit) data_type"

  where
  "ADT_H uop \<equiv>
   \<lparr>Init = \<lambda>s. Init_H,
    Fin = \<lambda>((tc,s),m,e). ((tc, absKState s),m,e),
    Step = (\<lambda>u. global_automaton check_active_irq_H (do_user_op_H uop) kernel_call_H)\<rparr>"

end

end


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

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__51_on_rules imports n_german_lemma_on_inv__51
begin
section{*All lemmas on causal relation between inv__51*}
lemma lemma_inv__51_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__51  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__51) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

end


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

header{*The n_german Protocol Case Study*}

theory n_german_lemma_on_inv__28 imports n_german_base
begin
section{*All lemmas on causal relation between inv__28 and some rule r*}
lemma n_RecvReqSVsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqS N i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvReqEVsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqE N i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__0Vsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__0  i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__1Vsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__1  i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvAckVsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Ident ''CurCmd'')) (Const Empty)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const Inv))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvInvAckVsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvInvAck  i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P2 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Ident ''ExGntd'')) (Const true)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const GntS))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__28:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__28  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendReqE__part__1Vsinv__28:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i" and
  a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_StoreVsinv__28:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqE__part__0Vsinv__28:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i" and
  a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqSVsinv__28:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqS  i" and
  a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end