(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(*
   The refinement relation between abstract and concrete states
*)

theory StateRelation
imports InvariantUpdates_H
begin

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

definition
  cte_map :: "cslot_ptr \<Rightarrow> machine_word"
where
 "cte_map \<equiv> \<lambda>(oref, cref). oref + (of_bl cref * 2 ^ cte_level_bits)"

lemmas cte_map_def' = cte_map_def[simplified cte_level_bits_def, simplified]

definition
  lookup_failure_map :: "ExceptionTypes_A.lookup_failure \<Rightarrow> Fault_H.lookup_failure"
where
 "lookup_failure_map \<equiv> \<lambda>lf. case lf of
    ExceptionTypes_A.InvalidRoot            \<Rightarrow> Fault_H.InvalidRoot
  | ExceptionTypes_A.MissingCapability n    \<Rightarrow> Fault_H.MissingCapability n
  | ExceptionTypes_A.DepthMismatch n m      \<Rightarrow> Fault_H.DepthMismatch n m
  | ExceptionTypes_A.GuardMismatch n g      \<Rightarrow> Fault_H.GuardMismatch n (of_bl g) (length g)"

primrec
  arch_fault_map :: "Machine_A.X64_A.arch_fault \<Rightarrow> ArchFault_H.X64_H.arch_fault"
where
 "arch_fault_map (Machine_A.X64_A.VMFault ptr msg) = ArchFault_H.X64_H.VMFault ptr msg"

primrec
  fault_map :: "ExceptionTypes_A.fault \<Rightarrow> Fault_H.fault"
where
  "fault_map (ExceptionTypes_A.CapFault ref bool failure) =
   Fault_H.CapFault ref bool (lookup_failure_map failure)"
| "fault_map (ExceptionTypes_A.ArchFault  arch_fault) =
   Fault_H.ArchFault  (arch_fault_map arch_fault)"
| "fault_map (ExceptionTypes_A.UnknownSyscallException n) =
   Fault_H.UnknownSyscallException n"
| "fault_map (ExceptionTypes_A.UserException x y) =
   Fault_H.UserException x y"

text \<open>
  A pspace and a tree are related if every object in the pspace
  corresponds to an object in the tree. Some abstract objects
  like CapTables correspond to multiple concrete ones, thus we
  have to make cuts.
\<close>

type_synonym obj_relation_cut = "Structures_A.kernel_object \<Rightarrow> Structures_H.kernel_object \<Rightarrow> bool"
type_synonym obj_relation_cuts = "(machine_word \<times> obj_relation_cut) set"

definition
  vmrights_map :: "rights set \<Rightarrow> vmrights"
where
 "vmrights_map S \<equiv> if AllowRead \<in> S
                   then (if AllowWrite \<in> S then VMReadWrite else VMReadOnly)
                   else VMKernelOnly"

definition
  zbits_map :: "nat option \<Rightarrow> zombie_type"
where
 "zbits_map N \<equiv> case N of Some n \<Rightarrow> ZombieCNode n
                        | None \<Rightarrow> ZombieTCB"

primrec
  acap_relation :: "arch_cap \<Rightarrow> arch_capability \<Rightarrow> bool"
where
  "acap_relation (arch_cap.ASIDPoolCap x y) c             = (c =
        arch_capability.ASIDPoolCap x y)"
| "acap_relation (arch_cap.ASIDControlCap) c              = (c =
        arch_capability.ASIDControlCap)"
| "acap_relation (arch_cap.PageCap dev word rghts typ sz data) c  = (c =
        arch_capability.PageCap word (vmrights_map rghts) typ sz dev data)"
| "acap_relation (arch_cap.PageTableCap word data) c      = (c =
        arch_capability.PageTableCap word data)"
| "acap_relation (arch_cap.PageDirectoryCap word data) c  = (c =
        arch_capability.PageDirectoryCap word data)"
| "acap_relation (arch_cap.PDPointerTableCap word data) c = (c =
        arch_capability.PDPointerTableCap word data)"
| "acap_relation (arch_cap.PML4Cap word data) c = (c =
        arch_capability.PML4Cap word data)"
| "acap_relation (arch_cap.IOPortCap f l) c = (c =
        arch_capability.IOPortCap f l)"
| "acap_relation (arch_cap.IOPortControlCap) c = (c = arch_capability.IOPortControlCap)"

primrec
  cap_relation :: "cap \<Rightarrow> capability \<Rightarrow> bool"
where
  "cap_relation Structures_A.NullCap c                    = (c =
           Structures_H.NullCap)"
| "cap_relation Structures_A.DomainCap c                  = (c =
           Structures_H.DomainCap)"
| "cap_relation (Structures_A.UntypedCap dev ref n f) c   = (c =
           Structures_H.UntypedCap dev ref n f)"
| "cap_relation (Structures_A.EndpointCap ref b r) c      = (c =
           Structures_H.EndpointCap ref b (AllowSend \<in> r)
             (AllowRecv \<in> r) (AllowGrant \<in> r) (AllowGrantReply \<in> r))"
| "cap_relation (Structures_A.NotificationCap ref b r) c  = (c =
           Structures_H.NotificationCap ref b (AllowSend \<in> r) (AllowRecv \<in> r))"
| "cap_relation (Structures_A.CNodeCap ref n L) c         = (c =
           Structures_H.CNodeCap ref n (of_bl L) (length L))"
| "cap_relation (Structures_A.ThreadCap ref) c            = (c =
           Structures_H.ThreadCap ref)"
| "cap_relation (Structures_A.ReplyCap ref master r) c    = (c =
           Structures_H.ReplyCap ref master (AllowGrant \<in> r))"
| "cap_relation (Structures_A.IRQControlCap) c            = (c =
           Structures_H.IRQControlCap)"
| "cap_relation (Structures_A.IRQHandlerCap irq) c        = (c =
           Structures_H.IRQHandlerCap irq)"
| "cap_relation (Structures_A.ArchObjectCap a) c          = (\<exists>a'.
           acap_relation a a' \<and> c = Structures_H.ArchObjectCap a')"
| "cap_relation (Structures_A.Zombie p b n) c             = (c =
           Structures_H.Zombie p (zbits_map b) n)"

definition
  cte_relation :: "cap_ref \<Rightarrow> obj_relation_cut"
where
 "cte_relation y \<equiv> \<lambda>ko ko'. \<exists>sz cs cte cap. ko = CNode sz cs \<and> ko' = KOCTE cte
                               \<and> cs y = Some cap \<and> cap_relation cap (cteCap cte)"

definition
  asid_pool_relation :: "(9 word \<rightharpoonup> machine_word) \<Rightarrow> asidpool \<Rightarrow> bool"
where
  "asid_pool_relation \<equiv> \<lambda>p p'. p = inv ASIDPool p' o ucast"

definition
  ntfn_relation :: "Structures_A.notification \<Rightarrow> Structures_H.notification \<Rightarrow> bool"
where
 "ntfn_relation \<equiv> \<lambda>ntfn ntfn'.
    (case ntfn_obj ntfn of
      Structures_A.IdleNtfn       \<Rightarrow> ntfnObj ntfn' = Structures_H.IdleNtfn
    | Structures_A.WaitingNtfn q  \<Rightarrow> ntfnObj ntfn' = Structures_H.WaitingNtfn q
    | Structures_A.ActiveNtfn b \<Rightarrow> ntfnObj ntfn' = Structures_H.ActiveNtfn b)
  \<and> ntfn_bound_tcb ntfn = ntfnBoundTCB ntfn'"

definition
  ep_relation :: "Structures_A.endpoint \<Rightarrow> Structures_H.endpoint \<Rightarrow> bool"
where
 "ep_relation \<equiv> \<lambda>ep ep'. case ep of
    Structures_A.IdleEP   \<Rightarrow> ep' = Structures_H.IdleEP
  | Structures_A.RecvEP q \<Rightarrow> ep' = Structures_H.RecvEP q
  | Structures_A.SendEP q \<Rightarrow> ep' = Structures_H.SendEP q"

definition
  fault_rel_optionation :: "ExceptionTypes_A.fault option \<Rightarrow> Fault_H.fault option \<Rightarrow> bool"
where
 "fault_rel_optionation \<equiv> \<lambda>f f'. f' = option_map fault_map f"

primrec
  thread_state_relation :: "Structures_A.thread_state \<Rightarrow> Structures_H.thread_state \<Rightarrow> bool"
where
  "thread_state_relation (Structures_A.Running) ts'
     = (ts' = Structures_H.Running)"
| "thread_state_relation (Structures_A.Restart) ts'
     = (ts' = Structures_H.Restart)"
| "thread_state_relation (Structures_A.Inactive) ts'
     = (ts' = Structures_H.Inactive)"
| "thread_state_relation (Structures_A.IdleThreadState) ts'
     = (ts' = Structures_H.IdleThreadState)"
| "thread_state_relation (Structures_A.BlockedOnReply) ts'
     = (ts' = Structures_H.BlockedOnReply)"
| "thread_state_relation (Structures_A.BlockedOnReceive oref sp) ts'
     = (ts' = Structures_H.BlockedOnReceive oref (receiver_can_grant sp))"
| "thread_state_relation (Structures_A.BlockedOnSend oref sp) ts'
     = (ts' = Structures_H.BlockedOnSend oref (sender_badge sp)
                   (sender_can_grant sp) (sender_can_grant_reply sp) (sender_is_call sp))"
| "thread_state_relation (Structures_A.BlockedOnNotification oref) ts'
     = (ts' = Structures_H.BlockedOnNotification oref)"

definition
  arch_tcb_relation :: "Structures_A.arch_tcb \<Rightarrow> Structures_H.arch_tcb \<Rightarrow> bool"
where
 "arch_tcb_relation \<equiv> \<lambda>atcb atcb'.
   tcb_context atcb = atcbContext atcb'"

definition
  tcb_relation :: "Structures_A.tcb \<Rightarrow> Structures_H.tcb \<Rightarrow> bool"
where
 "tcb_relation \<equiv> \<lambda>tcb tcb'.
    tcb_fault_handler tcb = to_bl (tcbFaultHandler tcb')
  \<and> tcb_ipc_buffer tcb = tcbIPCBuffer tcb'
  \<and> arch_tcb_relation (tcb_arch tcb) (tcbArch tcb')
  \<and> thread_state_relation (tcb_state tcb) (tcbState tcb')
  \<and> fault_rel_optionation (tcb_fault tcb) (tcbFault tcb')
  \<and> cap_relation (tcb_ctable tcb) (cteCap (tcbCTable tcb'))
  \<and> cap_relation (tcb_vtable tcb) (cteCap (tcbVTable tcb'))
  \<and> cap_relation (tcb_reply tcb) (cteCap (tcbReply tcb'))
  \<and> cap_relation (tcb_caller tcb) (cteCap (tcbCaller tcb'))
  \<and> cap_relation (tcb_ipcframe tcb) (cteCap (tcbIPCBufferFrame tcb'))
  \<and> tcb_bound_notification tcb = tcbBoundNotification tcb'
  \<and> tcb_mcpriority tcb = tcbMCP tcb'"

definition
  other_obj_relation :: "Structures_A.kernel_object \<Rightarrow> Structures_H.kernel_object \<Rightarrow> bool"
where
  "other_obj_relation obj obj' \<equiv>
  (case (obj, obj') of
        (TCB tcb, KOTCB tcb') \<Rightarrow> tcb_relation tcb tcb'
      | (Endpoint ep, KOEndpoint ep') \<Rightarrow> ep_relation ep ep'
      | (Notification ntfn, KONotification ntfn') \<Rightarrow> ntfn_relation ntfn ntfn'
      | (ArchObj (X64_A.ASIDPool pool), KOArch (KOASIDPool pool'))
             \<Rightarrow> asid_pool_relation pool pool'
      | _ \<Rightarrow> False)"

primrec
   pml4e_relation' :: "X64_A.pml4e \<Rightarrow> X64_H.pml4e \<Rightarrow> bool"
where
  "pml4e_relation'  X64_A.InvalidPML4E x = (x = X64_H.InvalidPML4E)"
| "pml4e_relation' (X64_A.PDPointerTablePML4E ptr atts rights) x
      = (x = X64_H.PDPointerTablePML4E ptr (Accessed \<in> atts) (CacheDisabled \<in> atts) (WriteThrough \<in> atts)
                                    (ExecuteDisable \<in> atts) (vmrights_map rights))"

primrec
   pdpte_relation' :: "X64_A.pdpte \<Rightarrow> X64_H.pdpte \<Rightarrow> bool"
where
  "pdpte_relation'  X64_A.InvalidPDPTE x = (x = X64_H.InvalidPDPTE)"
| "pdpte_relation' (X64_A.PageDirectoryPDPTE ptr atts rights) x
      = (x = X64_H.PageDirectoryPDPTE ptr (Accessed \<in> atts) (CacheDisabled \<in> atts) (WriteThrough \<in> atts)
                                    (ExecuteDisable \<in> atts) (vmrights_map rights))"
| "pdpte_relation' (X64_A.HugePagePDPTE ptr atts rghts) x
      = (x = X64_H.HugePagePDPTE ptr (Global \<in> atts) (PAT \<in> atts) (Dirty \<in> atts)
                                    (PTAttr Accessed \<in> atts) (PTAttr CacheDisabled \<in> atts)
                                    (PTAttr WriteThrough \<in> atts) (PTAttr ExecuteDisable \<in> atts)
                                    (vmrights_map rghts))"

primrec
   pde_relation' :: "X64_A.pde \<Rightarrow> X64_H.pde \<Rightarrow> bool"
where
  "pde_relation'  X64_A.InvalidPDE x = (x = X64_H.InvalidPDE)"
| "pde_relation' (X64_A.PageTablePDE ptr atts rights) x
      = (x = X64_H.PageTablePDE ptr (Accessed \<in> atts) (CacheDisabled \<in> atts) (WriteThrough \<in> atts)
                                    (ExecuteDisable \<in> atts) (vmrights_map rights))"
| "pde_relation' (X64_A.LargePagePDE ptr atts rghts) x
      = (x = X64_H.LargePagePDE ptr (Global \<in> atts) (PAT \<in> atts) (Dirty \<in> atts)
                                    (PTAttr Accessed \<in> atts) (PTAttr CacheDisabled \<in> atts)
                                    (PTAttr WriteThrough \<in> atts) (PTAttr ExecuteDisable \<in> atts)
                                    (vmrights_map rghts))"

primrec
   pte_relation' :: "X64_A.pte \<Rightarrow> X64_H.pte \<Rightarrow> bool"
where
  "pte_relation'  X64_A.InvalidPTE x = (x = X64_H.InvalidPTE)"
| "pte_relation' (X64_A.SmallPagePTE ptr atts rghts) x
      = (x = X64_H.SmallPagePTE ptr (Global \<in> atts) (PAT \<in> atts) (Dirty \<in> atts)
                                    (PTAttr Accessed \<in> atts) (PTAttr CacheDisabled \<in> atts)
                                    (PTAttr WriteThrough \<in> atts) (PTAttr ExecuteDisable \<in> atts)
                                    (vmrights_map rghts))"

definition
 "pte_relation y \<equiv> \<lambda>ko ko'. \<exists>pt pte. ko = ArchObj (PageTable pt) \<and> ko' = KOArch (KOPTE pte)
                              \<and> pte_relation' (pt y) pte"

definition
 "pde_relation y \<equiv> \<lambda>ko ko'. \<exists>pd pde. ko = ArchObj (PageDirectory pd) \<and> ko' = KOArch (KOPDE pde)
                              \<and> pde_relation' (pd y) pde"

definition
 "pdpte_relation y \<equiv> \<lambda>ko ko'. \<exists>pd pdpte. ko = ArchObj (PDPointerTable pd) \<and> ko' = KOArch (KOPDPTE pdpte)
                              \<and> pdpte_relation' (pd y) pdpte"

definition
 "pml4e_relation y \<equiv> \<lambda>ko ko'. \<exists>pd pml4e. ko = ArchObj (PageMapL4 pd) \<and> ko' = KOArch (KOPML4E pml4e)
                              \<and> pml4e_relation' (pd y) pml4e"

primrec
 aobj_relation_cuts :: "X64_A.arch_kernel_obj \<Rightarrow> machine_word \<Rightarrow> obj_relation_cuts"
where
  "aobj_relation_cuts (DataPage dev sz) x =
      {(x + n * 2 ^ pageBits, \<lambda>_ obj. obj = (if dev then KOUserDataDevice else KOUserData) ) | n . n < 2 ^ (pageBitsForSize sz - pageBits) }"
| "aobj_relation_cuts (X64_A.ASIDPool pool) x =
     {(x, other_obj_relation)}"
| "aobj_relation_cuts (PageTable pt) x =
     (\<lambda>y. (x + (ucast y << word_size_bits), pte_relation y)) ` UNIV"
| "aobj_relation_cuts (PageDirectory pd) x =
     (\<lambda>y. (x + (ucast y << word_size_bits), pde_relation y)) ` UNIV"
| "aobj_relation_cuts (PDPointerTable pdpt) x =
     (\<lambda>y. (x + (ucast y << word_size_bits), pdpte_relation y)) ` UNIV"
| "aobj_relation_cuts (PageMapL4 pm) x =
     (\<lambda>y. (x + (ucast y << word_size_bits), pml4e_relation y)) ` UNIV"

primrec
  obj_relation_cuts :: "Structures_A.kernel_object \<Rightarrow> machine_word \<Rightarrow> obj_relation_cuts"
where
  "obj_relation_cuts (CNode sz cs) x =
     (if well_formed_cnode_n sz cs
      then {(cte_map (x, y), cte_relation y) | y. y \<in> dom cs}
      else {(x, \<bottom>\<bottom>)})"
| "obj_relation_cuts (TCB tcb) x = {(x, other_obj_relation)}"
| "obj_relation_cuts (Endpoint ep) x = {(x, other_obj_relation)}"
| "obj_relation_cuts (Notification ntfn) x = {(x, other_obj_relation)}"
| "obj_relation_cuts (ArchObj ao) x = aobj_relation_cuts ao x"

lemma obj_relation_cuts_def2:
  "obj_relation_cuts ko x =
   (case ko of CNode sz cs \<Rightarrow> if well_formed_cnode_n sz cs
                             then {(cte_map (x, y), cte_relation y) | y. y \<in> dom cs}
                             else {(x, \<bottom>\<bottom>)}
             | ArchObj (PageTable pt) \<Rightarrow> (\<lambda>y. (x + (ucast y << word_size_bits), pte_relation y))
                                           ` (UNIV :: 9 word set)
             | ArchObj (PageDirectory pd) \<Rightarrow> (\<lambda>y. (x + (ucast y << word_size_bits), pde_relation y))
                                           ` (UNIV :: 9 word set)
             | ArchObj (PDPointerTable pdpt) \<Rightarrow> (\<lambda>y. (x + (ucast y << word_size_bits), pdpte_relation y))
                                           ` (UNIV :: 9 word set)
             | ArchObj (PageMapL4 pm) \<Rightarrow> (\<lambda>y. (x + (ucast y << word_size_bits), pml4e_relation y))
                                           ` (UNIV :: 9 word set)
             | ArchObj (DataPage dev sz)      \<Rightarrow>
                 {(x + n * 2 ^ pageBits,  \<lambda>_ obj. obj =(if dev then KOUserDataDevice else KOUserData)) | n . n < 2 ^ (pageBitsForSize sz - pageBits) }
             | _ \<Rightarrow> {(x, other_obj_relation)})"
  by (simp split: Structures_A.kernel_object.split
                  X64_A.arch_kernel_obj.split)

lemma obj_relation_cuts_def3:
  "obj_relation_cuts ko x =
  (case (a_type ko) of
     ACapTable n \<Rightarrow> {(cte_map (x, y), cte_relation y) | y. length y = n}
   | AArch APageTable \<Rightarrow> (\<lambda>y. (x + (ucast y << word_size_bits), pte_relation y))
                            ` (UNIV :: 9 word set)
   | AArch APageDirectory \<Rightarrow> (\<lambda>y. (x + (ucast y << word_size_bits), pde_relation y))
                            ` (UNIV :: 9 word set)
   | AArch APDPointerTable \<Rightarrow> (\<lambda>y. (x + (ucast y << word_size_bits), pdpte_relation y))
                            ` (UNIV :: 9 word set)
   | AArch APageMapL4 \<Rightarrow> (\<lambda>y. (x + (ucast y << word_size_bits), pml4e_relation y))
                            ` (UNIV :: 9 word set)
   | AArch (AUserData sz)  \<Rightarrow> {(x + n * 2 ^ pageBits, \<lambda>_ obj. obj = KOUserData) | n . n < 2 ^ (pageBitsForSize sz - pageBits) }
   | AArch (ADeviceData sz)  \<Rightarrow> {(x + n * 2 ^ pageBits, \<lambda>_ obj. obj = KOUserDataDevice ) | n . n < 2 ^ (pageBitsForSize sz - pageBits) }
   | AGarbage _ \<Rightarrow> {(x, \<bottom>\<bottom>)}
   | _ \<Rightarrow> {(x, other_obj_relation)})"
  apply (simp add: obj_relation_cuts_def2 a_type_def
            split: Structures_A.kernel_object.split
                  X64_A.arch_kernel_obj.split)
  apply (clarsimp simp: well_formed_cnode_n_def length_set_helper)
  done

definition
 "is_other_obj_relation_type tp \<equiv>
  case tp of
     ACapTable n \<Rightarrow> False
   | AArch APageTable \<Rightarrow> False
   | AArch APageDirectory \<Rightarrow> False
   | AArch APDPointerTable \<Rightarrow> False
   | AArch APageMapL4 \<Rightarrow> False
   | AArch (AUserData _)   \<Rightarrow> False
   | AArch (ADeviceData _)   \<Rightarrow> False
   | AGarbage _ \<Rightarrow> False
   | _ \<Rightarrow> True"

lemma is_other_obj_relation_type_CapTable:
  "\<not> is_other_obj_relation_type (ACapTable n)"
  by (simp add: is_other_obj_relation_type_def)

lemma is_other_obj_relation_type_UserData:
  "\<not> is_other_obj_relation_type (AArch (AUserData sz))"
  unfolding is_other_obj_relation_type_def by simp

lemma is_other_obj_relation_type_DeviceData:
  "\<not> is_other_obj_relation_type (AArch (ADeviceData sz))"
  unfolding is_other_obj_relation_type_def by simp

lemma is_other_obj_relation_type:
  "is_other_obj_relation_type (a_type ko) \<Longrightarrow>
   obj_relation_cuts ko x = {(x, other_obj_relation)}"
  by (simp add: obj_relation_cuts_def3 is_other_obj_relation_type_def
         split: a_type.splits aa_type.splits)

definition
  pspace_dom :: "Structures_A.kheap \<Rightarrow> machine_word set"
where
  "pspace_dom ps \<equiv> \<Union>x\<in>dom ps. fst ` (obj_relation_cuts (the (ps x)) x)"

definition
  pspace_relation :: "Structures_A.kheap \<Rightarrow> (machine_word \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> bool"
where
 "pspace_relation ab con \<equiv>
  (pspace_dom ab = dom con) \<and>
  (\<forall>x \<in> dom ab. \<forall>(y, P) \<in> obj_relation_cuts (the (ab x)) x.
       P (the (ab x)) (the (con y)))"

definition etcb_relation :: "etcb \<Rightarrow> Structures_H.tcb \<Rightarrow> bool"
where
 "etcb_relation \<equiv> \<lambda>etcb tcb'.
    tcb_priority etcb = tcbPriority tcb'
  \<and> tcb_time_slice etcb = tcbTimeSlice tcb'
  \<and> tcb_domain etcb = tcbDomain tcb'"

definition
 ekheap_relation :: "(obj_ref \<Rightarrow> etcb option) \<Rightarrow> (machine_word \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> bool"
where
 "ekheap_relation ab con \<equiv>
    \<forall>x \<in> dom ab. \<exists>tcb'. con x = Some (KOTCB tcb') \<and> etcb_relation (the (ab x)) tcb'"

primrec
  sched_act_relation :: "Deterministic_A.scheduler_action \<Rightarrow> Structures_H.scheduler_action \<Rightarrow> bool"
where
  "sched_act_relation resume_cur_thread a' = (a' = ResumeCurrentThread)" |
  "sched_act_relation choose_new_thread a' = (a' = ChooseNewThread)" |
  "sched_act_relation (switch_thread x) a' = (a' = SwitchToThread x)"

definition
  ready_queues_relation :: "(Deterministic_A.domain \<Rightarrow> Structures_A.priority \<Rightarrow> Deterministic_A.ready_queue)
                         \<Rightarrow> (domain \<times> priority \<Rightarrow> KernelStateData_H.ready_queue) \<Rightarrow> bool"
where
  "ready_queues_relation qs qs' \<equiv> \<forall>d p. (qs d p = qs' (d, p))"

definition
  ghost_relation :: "Structures_A.kheap \<Rightarrow> (machine_word \<rightharpoonup> vmpage_size) \<Rightarrow> (machine_word \<rightharpoonup> nat) \<Rightarrow> bool"
where
  "ghost_relation h ups cns \<equiv>
   (\<forall>a sz. (\<exists>dev. h a = Some (ArchObj (DataPage dev sz))) \<longleftrightarrow> ups a = Some sz) \<and>
   (\<forall>a n. (\<exists>cs. h a = Some (CNode n cs) \<and> well_formed_cnode_n n cs) \<longleftrightarrow>
          cns a = Some n)"

definition
  cdt_relation :: "(cslot_ptr \<Rightarrow> bool) \<Rightarrow> cdt \<Rightarrow> cte_heap \<Rightarrow> bool"
where
  "cdt_relation \<equiv> \<lambda>cte_at m m'.
  \<forall>c. cte_at c \<longrightarrow> cte_map ` descendants_of c m = descendants_of' (cte_map c) m'"

definition
  cdt_list_relation :: "cdt_list \<Rightarrow> cdt \<Rightarrow> cte_heap \<Rightarrow> bool"
where
 "cdt_list_relation \<equiv> \<lambda>t m m'.
    \<forall>c cap node. m' (cte_map c) = Some (CTE cap node)
        \<longrightarrow> (case next_slot c t m of None \<Rightarrow> True
            | Some next \<Rightarrow> mdbNext node = cte_map next)"

definition
  revokable_relation :: "(cslot_ptr \<Rightarrow> bool) \<Rightarrow> (cslot_ptr \<Rightarrow> cap option) \<Rightarrow> cte_heap \<Rightarrow> bool"
where
  "revokable_relation revo cs m' \<equiv>
  \<forall>c cap node. cs c \<noteq> None \<longrightarrow>
               m' (cte_map c) = Some (CTE cap node) \<longrightarrow>
               revo c = mdbRevocable node"

definition
  irq_state_relation :: "irq_state \<Rightarrow> irqstate \<Rightarrow> bool"
where
  "irq_state_relation irq irq' \<equiv> case (irq, irq') of
     (irq_state.IRQInactive, irqstate.IRQInactive) \<Rightarrow> True
   | (irq_state.IRQSignal, irqstate.IRQSignal) \<Rightarrow> True
   | (irq_state.IRQTimer, irqstate.IRQTimer) \<Rightarrow> True
   | _ \<Rightarrow> False"

definition
  interrupt_state_relation :: "(irq \<Rightarrow> obj_ref) \<Rightarrow> (irq \<Rightarrow> irq_state) \<Rightarrow> interrupt_state \<Rightarrow> bool"
where
  "interrupt_state_relation node_map irqs is \<equiv>
    (\<exists>node irqs'. is = InterruptState node irqs'
              \<and> (\<forall>irq. node_map irq = node + (ucast irq << cte_level_bits))
              \<and> (\<forall>irq. irq_state_relation (irqs irq) (irqs' irq)))"

definition
  cr3_relation :: "X64_A.cr3 \<Rightarrow> cr3 \<Rightarrow> bool"
where
  "cr3_relation c c' \<equiv> cr3_base_address c = cr3BaseAddress c' \<and> cr3_pcid c = cr3pcid c'"

fun
  x64irqstate_to_abstract :: "x64irqstate \<Rightarrow> X64IRQState"
where
  "x64irqstate_to_abstract X64IRQFree = IRQFree"
| "x64irqstate_to_abstract X64IRQReserved = IRQReserved"
| "x64irqstate_to_abstract (X64IRQMSI bus dev func handle) = (IRQMSI bus dev func handle)"
| "x64irqstate_to_abstract (X64IRQIOAPIC ioapic pin level polarity masked) =
     (IRQIOAPIC ioapic pin level polarity masked)"

definition
  x64_irq_relation :: "(8 word \<Rightarrow> X64IRQState) \<Rightarrow> (8 word \<Rightarrow> x64irqstate) \<Rightarrow> bool"
where
  "x64_irq_relation irq_states irq_states' \<equiv> irq_states = x64irqstate_to_abstract o irq_states'"

definition
  arch_state_relation :: "(arch_state \<times> X64_H.kernel_state) set"
where
  "arch_state_relation \<equiv> {(s, s') .
         x64_asid_table s = x64KSASIDTable s' o ucast
       \<and> x64_global_pml4 s = x64KSSKIMPML4 s'
       \<and> x64_global_pdpts s = x64KSSKIMPDPTs s'
       \<and> x64_global_pds s = x64KSSKIMPDs s'
       \<and> x64_global_pts s = x64KSSKIMPTs s'
       \<and> cr3_relation (x64_current_cr3 s) (x64KSCurrentUserCR3 s')
       \<and> x64_kernel_vspace s = x64KSKernelVSpace s'
       \<and> x64_allocated_io_ports s = x64KSAllocatedIOPorts s'
       \<and> x64_num_ioapics s = x64KSNumIOAPICs s'
       \<and> x64_irq_relation (x64_irq_state s) (x64KSIRQState s')}"

definition
  rights_mask_map :: "rights set \<Rightarrow> Types_H.cap_rights"
where
 "rights_mask_map \<equiv> \<lambda>rs. CapRights (AllowWrite \<in> rs) (AllowRead \<in> rs) (AllowGrant \<in> rs)
                                   (AllowGrantReply \<in> rs)"

lemma obj_relation_cutsE:
  "\<lbrakk> (y, P) \<in> obj_relation_cuts ko x; P ko ko';
     \<And>sz cs z cap cte. \<lbrakk> ko = CNode sz cs; well_formed_cnode_n sz cs; y = cte_map (x, z);
                      ko' = KOCTE cte; cs z = Some cap; cap_relation cap (cteCap cte) \<rbrakk>
              \<Longrightarrow> R;
     \<And>pt (z :: 9 word) pte'. \<lbrakk> ko = ArchObj (PageTable pt); y = x + (ucast z << word_size_bits);
                              ko' = KOArch (KOPTE pte'); pte_relation' (pt z) pte' \<rbrakk>
              \<Longrightarrow> R;
     \<And>pd (z :: 9 word) pde'. \<lbrakk> ko = ArchObj (PageDirectory pd); y = x + (ucast z << word_size_bits);
                              ko' = KOArch (KOPDE pde'); pde_relation' (pd z) pde' \<rbrakk>
              \<Longrightarrow> R;
     \<And>pdpt (z :: 9 word) pdpte'. \<lbrakk> ko = ArchObj (PDPointerTable pdpt); y = x + (ucast z << word_size_bits);
                              ko' = KOArch (KOPDPTE pdpte'); pdpte_relation' (pdpt z) pdpte' \<rbrakk>
              \<Longrightarrow> R;
     \<And>pml4 (z :: 9 word) pml4e'. \<lbrakk> ko = ArchObj (PageMapL4 pml4); y = x + (ucast z << word_size_bits);
                              ko' = KOArch (KOPML4E pml4e'); pml4e_relation' (pml4 z) pml4e' \<rbrakk>
              \<Longrightarrow> R;
     \<And>sz dev n. \<lbrakk> ko = ArchObj (DataPage dev sz); ko' = (if dev then KOUserDataDevice else KOUserData);
              y = x + n * 2 ^ pageBits; n < 2 ^ (pageBitsForSize sz - pageBits) \<rbrakk> \<Longrightarrow> R;
            \<lbrakk> y = x; other_obj_relation ko ko'; is_other_obj_relation_type (a_type ko) \<rbrakk> \<Longrightarrow> R
    \<rbrakk> \<Longrightarrow> R"
  apply (simp add: obj_relation_cuts_def2 is_other_obj_relation_type_def
                   a_type_def
            split: Structures_A.kernel_object.split_asm if_split_asm
                   X64_A.arch_kernel_obj.split_asm)
    apply ((clarsimp split: if_splits,
                force simp: cte_relation_def pte_relation_def pde_relation_def
                            pdpte_relation_def pml4e_relation_def)+)
  done

lemma eq_trans_helper:
  "\<lbrakk> x = y; P y = Q \<rbrakk> \<Longrightarrow> P x = Q"
  by simp

lemma cap_relation_case':
  "cap_relation cap cap'
     = (case cap of cap.ArchObjectCap arch_cap.ASIDControlCap \<Rightarrow> cap_relation cap cap'
            | _ \<Rightarrow> cap_relation cap cap')"
  by (simp split: cap.split arch_cap.split)

schematic_goal cap_relation_case:
  "cap_relation cap cap' = ?P"
  apply (subst cap_relation_case')
  apply (clarsimp cong: cap.case_cong arch_cap.case_cong)
  apply (rule refl)
  done

lemmas cap_relation_split =
  eq_trans_helper [where P=P, OF cap_relation_case cap.split[where P=P]] for P
lemmas cap_relation_split_asm =
  eq_trans_helper [where P=P, OF cap_relation_case cap.split_asm[where P=P]] for P

text \<open>Relations on other data types that aren't stored but
        used as intermediate values in the specs.\<close>

primrec
  message_info_map :: "Structures_A.message_info \<Rightarrow> Types_H.message_info"
where
 "message_info_map (Structures_A.MI a b c d) = (Types_H.MI a b c d)"

lemma mi_map_label[simp]: "msgLabel (message_info_map mi) = mi_label mi"
  by (cases mi, simp)

primrec
  syscall_error_map :: "ExceptionTypes_A.syscall_error \<Rightarrow> Fault_H.syscall_error"
where
  "syscall_error_map (ExceptionTypes_A.InvalidArgument n)     = Fault_H.InvalidArgument n"
| "syscall_error_map (ExceptionTypes_A.InvalidCapability n)   = (Fault_H.InvalidCapability n)"
| "syscall_error_map ExceptionTypes_A.IllegalOperation        = Fault_H.IllegalOperation"
| "syscall_error_map (ExceptionTypes_A.RangeError n m)        = Fault_H.RangeError n m"
| "syscall_error_map ExceptionTypes_A.AlignmentError          = Fault_H.AlignmentError"
| "syscall_error_map (ExceptionTypes_A.FailedLookup b lf)     = Fault_H.FailedLookup b (lookup_failure_map lf)"
| "syscall_error_map ExceptionTypes_A.TruncatedMessage        = Fault_H.TruncatedMessage"
| "syscall_error_map ExceptionTypes_A.DeleteFirst             = Fault_H.DeleteFirst"
| "syscall_error_map ExceptionTypes_A.RevokeFirst             = Fault_H.RevokeFirst"
| "syscall_error_map (ExceptionTypes_A.NotEnoughMemory n)       = Fault_H.syscall_error.NotEnoughMemory n"

definition
  APIType_map :: "Structures_A.apiobject_type \<Rightarrow> X64_H.object_type"
where
  "APIType_map ty \<equiv> case ty of
                    Structures_A.Untyped \<Rightarrow> APIObjectType ArchTypes_H.Untyped
                  | Structures_A.TCBObject \<Rightarrow> APIObjectType ArchTypes_H.TCBObject
                  | Structures_A.EndpointObject \<Rightarrow> APIObjectType ArchTypes_H.EndpointObject
                  | Structures_A.NotificationObject \<Rightarrow> APIObjectType ArchTypes_H.NotificationObject
                  | Structures_A.CapTableObject \<Rightarrow> APIObjectType ArchTypes_H.CapTableObject
                  | ArchObject ao \<Rightarrow> (case ao of
         SmallPageObj     \<Rightarrow> SmallPageObject
       | LargePageObj     \<Rightarrow> LargePageObject
       | HugePageObj       \<Rightarrow> HugePageObject
       | PageTableObj     \<Rightarrow> PageTableObject
       | PageDirectoryObj \<Rightarrow> PageDirectoryObject
       | PDPTObj \<Rightarrow> PDPointerTableObject
       | PML4Obj \<Rightarrow> PML4Object)"

definition
  state_relation :: "(det_state \<times> kernel_state) set"
where
 "state_relation \<equiv> {(s, s').
         pspace_relation (kheap s) (ksPSpace s')
       \<and> ekheap_relation (ekheap s) (ksPSpace s')
       \<and> sched_act_relation (scheduler_action s) (ksSchedulerAction s')
       \<and> ready_queues_relation (ready_queues s) (ksReadyQueues s')
       \<and> ghost_relation (kheap s) (gsUserPages s') (gsCNodes s')
       \<and> cdt_relation (swp cte_at s) (cdt s) (ctes_of s')
       \<and> cdt_list_relation (cdt_list s) (cdt s) (ctes_of s')
       \<and> revokable_relation (is_original_cap s) (null_filter (caps_of_state s)) (ctes_of s')
       \<and> (arch_state s, ksArchState s') \<in> arch_state_relation
       \<and> interrupt_state_relation (interrupt_irq_node s) (interrupt_states s) (ksInterruptState s')
       \<and> (cur_thread s = ksCurThread s')
       \<and> (idle_thread s = ksIdleThread s')
       \<and> (machine_state s = ksMachineState s')
       \<and> (work_units_completed s = ksWorkUnitsCompleted s')
       \<and> (domain_index s = ksDomScheduleIdx s')
       \<and> (domain_list s = ksDomSchedule s')
       \<and> (cur_domain s = ksCurDomain s')
       \<and> (domain_time s = ksDomainTime s')}"

text \<open>Rules for using states in the relation.\<close>

lemma curthread_relation:
  "(a, b) \<in> state_relation \<Longrightarrow> ksCurThread b = cur_thread a"
  by (simp add: state_relation_def)

lemma state_relation_pspace_relation[elim!]:
  "(s,s') \<in> state_relation \<Longrightarrow> pspace_relation (kheap s) (ksPSpace s')"
  by (simp add: state_relation_def)

lemma state_relation_ekheap_relation[elim!]:
  "(s,s') \<in> state_relation \<Longrightarrow> ekheap_relation (ekheap s) (ksPSpace s')"
  by (simp add: state_relation_def)

lemma state_relationD:
  assumes sr:  "(s, s') \<in> state_relation"
  shows "pspace_relation (kheap s) (ksPSpace s') \<and>
  ekheap_relation (ekheap s) (ksPSpace s') \<and>
  sched_act_relation (scheduler_action s) (ksSchedulerAction s') \<and>
  ready_queues_relation (ready_queues s) (ksReadyQueues s') \<and>
  ghost_relation (kheap s) (gsUserPages s') (gsCNodes s') \<and>
  cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \<and>
  cdt_list_relation (cdt_list s) (cdt s) (ctes_of s') \<and>
  revokable_relation (is_original_cap s) (null_filter (caps_of_state s)) (ctes_of s') \<and>
  (arch_state s, ksArchState s') \<in> arch_state_relation \<and>
  interrupt_state_relation (interrupt_irq_node s) (interrupt_states s) (ksInterruptState s') \<and>
  cur_thread s = ksCurThread s' \<and>
  idle_thread s = ksIdleThread s' \<and>
  machine_state s = ksMachineState s' \<and>
  work_units_completed s = ksWorkUnitsCompleted s' \<and>
  domain_index s = ksDomScheduleIdx s' \<and>
  domain_list s = ksDomSchedule s' \<and>
  cur_domain s = ksCurDomain s' \<and>
  domain_time s = ksDomainTime s'"
  using sr unfolding state_relation_def by simp

lemma state_relationE [elim?]:
  assumes sr:  "(s, s') \<in> state_relation"
  and rl: "\<lbrakk>pspace_relation (kheap s) (ksPSpace s');
  ekheap_relation (ekheap s) (ksPSpace s');
  sched_act_relation (scheduler_action s) (ksSchedulerAction s');
  ready_queues_relation (ready_queues s) (ksReadyQueues s');
  ghost_relation (kheap s) (gsUserPages s') (gsCNodes s');
  cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \<and>
  revokable_relation (is_original_cap s) (null_filter (caps_of_state s)) (ctes_of s');
  cdt_list_relation (cdt_list s) (cdt s) (ctes_of s');
  (arch_state s, ksArchState s') \<in> arch_state_relation;
  interrupt_state_relation (interrupt_irq_node s) (interrupt_states s) (ksInterruptState s');
  cur_thread s = ksCurThread s';
  idle_thread s = ksIdleThread s';
  machine_state s = ksMachineState s';
  work_units_completed s = ksWorkUnitsCompleted s';
  domain_index s = ksDomScheduleIdx s';
  domain_list s = ksDomSchedule s';
  cur_domain s = ksCurDomain s';
  domain_time s = ksDomainTime s' \<rbrakk> \<Longrightarrow> R"
  shows "R"
  using sr by (blast intro!: rl dest: state_relationD)

text \<open>This isn't defined for arch objects\<close>

lemmas isCap_defs =
  isZombie_def isArchObjectCap_def
  isThreadCap_def isCNodeCap_def isNotificationCap_def
  isEndpointCap_def isUntypedCap_def isNullCap_def
  isIRQHandlerCap_def isIRQControlCap_def isReplyCap_def
  isPageCap_def isPageTableCap_def isPageDirectoryCap_def
  isPDPointerTableCap_def isPML4Cap_def isIOPortCap_def
  isASIDControlCap_def isASIDPoolCap_def isArchPageCap_def
  isDomainCap_def isArchIOPortCap_def isIOPortControlCap_def
  isIOPortControlCap'_def

lemma isCNodeCap_cap_map [simp]:
  "cap_relation c c' \<Longrightarrow> isCNodeCap c' = is_cnode_cap c"
  apply (cases c, simp_all add: isCap_defs split: sum.splits)
   apply clarsimp+
  done

lemma sts_rel_idle :
  "thread_state_relation st IdleThreadState = (st = Structures_A.IdleThreadState)"
  by (cases st, auto)

lemma pspace_relation_absD:
  "\<lbrakk> ab x = Some y; pspace_relation ab con \<rbrakk>
      \<Longrightarrow> \<forall>(x', P) \<in> obj_relation_cuts y x. \<exists>z. con x' = Some z \<and> P y z"
  apply (clarsimp simp add: pspace_relation_def)
  apply (drule bspec, erule domI)
  apply simp
  apply (drule(1) bspec)
  apply (subgoal_tac "a \<in> pspace_dom ab")
   apply clarsimp
  apply (simp(no_asm) add: pspace_dom_def)
  apply (rule rev_bexI, erule domI)
  apply (simp add: image_def rev_bexI)
  done

lemma ekheap_relation_absD:
  "\<lbrakk> ab x = Some y; ekheap_relation ab con \<rbrakk>
      \<Longrightarrow> \<exists>tcb'. con x = Some (KOTCB tcb') \<and> etcb_relation y tcb'"
  by (force simp add: ekheap_relation_def)

lemma in_related_pspace_dom:
  "\<lbrakk> s' x = Some y; pspace_relation s s' \<rbrakk> \<Longrightarrow> x \<in> pspace_dom s"
  by (clarsimp simp add: pspace_relation_def)

lemma pspace_dom_revE:
  "\<lbrakk> x \<in> pspace_dom ps; \<And>ko y P. \<lbrakk> ps y = Some ko; (x, P) \<in> obj_relation_cuts ko y \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (clarsimp simp add: pspace_dom_def)

lemma pspace_dom_relatedE:
  "\<lbrakk> s' x = Some ko'; pspace_relation s s';
     \<And>y ko P. \<lbrakk> s y = Some ko; (x, P) \<in> obj_relation_cuts ko y; P ko ko' \<rbrakk> \<Longrightarrow> R
        \<rbrakk> \<Longrightarrow> R"
  apply (rule pspace_dom_revE [OF in_related_pspace_dom],
         assumption+)
  apply (frule(1) pspace_relation_absD)
  apply fastforce
  done

lemma ghost_relation_typ_at:
  "ghost_relation (kheap s) ups cns \<equiv>
   (\<forall>a sz. data_at sz a s = (ups a = Some sz)) \<and>
   (\<forall>a n. typ_at (ACapTable n) a s = (cns a = Some n))"
   apply (rule eq_reflection)
   apply (clarsimp simp: ghost_relation_def typ_at_eq_kheap_obj data_at_def)
   apply (intro conjI impI iffI allI; force)
   done

end
end


theory Eg1Eg2
imports Eg1
        Eg2
        "../CompositionalRefinement"
begin

locale sifum_refinement_eg1_eg2 =
  A: sifum_example +
  C: sifum_example2

primrec Eg2_var\<^sub>C_of_Eg1 :: "Eg1.var \<Rightarrow> Eg2.var\<^sub>C"
where
  "Eg2_var\<^sub>C_of_Eg1 control_var = control_var\<^sub>C" |
  "Eg2_var\<^sub>C_of_Eg1 buffer = buffer\<^sub>C" |
  "Eg2_var\<^sub>C_of_Eg1 high_var = high_var\<^sub>C" |
  "Eg2_var\<^sub>C_of_Eg1 low_var = low_var\<^sub>C" |
  "Eg2_var\<^sub>C_of_Eg1 temp = temp\<^sub>C"

sublocale sifum_refinement_eg1_eg2 \<subseteq> sifum_refinement dma dma\<^sub>C \<C>_vars \<C>_vars\<^sub>C \<C> \<C>\<^sub>C A.eval\<^sub>w C.eval\<^sub>w undefined Eg2_var\<^sub>C_of_Eg1
  supply image_cong_simp [cong del] INF_cong_simp [cong] SUP_cong_simp [cong]
  apply(unfold_locales)
           apply(erule C.eval_det, simp)
          apply(rule C.Var_finite)
         apply(simp add:\<C>_vars\<^sub>C_def split:if_splits)
        apply(simp add:\<C>_vars\<^sub>C_def dma\<^sub>C_def)
       apply(simp add:\<C>_vars\<^sub>C_def dma\<^sub>C_def)
      apply(rule inj_onI, simp)
      apply(case_tac x)
          apply(case_tac y, simp+)
         apply(case_tac y, simp+)
        apply(case_tac y, simp+)
       apply(case_tac y, simp+)
      apply(case_tac y, simp+)
     apply(case_tac x\<^sub>A)
         apply(clarsimp simp:dma\<^sub>C_def dma_def dma_control_var_def dma_control_var\<^sub>C_def)+
    apply(case_tac x\<^sub>A)
        apply(clarsimp simp:\<C>_vars\<^sub>C_def \<C>_vars_def)+
   apply(rule set_eqI, clarsimp)
   apply(case_tac x, clarsimp)
        apply(rule_tac x=control_var in rev_image_eqI, clarsimp+)
       apply(case_tac xa, clarsimp+)
          apply(case_tac xb, clarsimp+)
      apply(case_tac xa, clarsimp+)
         apply(case_tac xb, clarsimp+)
     apply(case_tac xa, clarsimp+)
        apply(case_tac xb, clarsimp+)
    apply(case_tac xa, clarsimp+)
       apply(case_tac xb, clarsimp+)
   apply(case_tac xa, clarsimp+)
  apply(simp add:\<C>\<^sub>C_def)
  done

context sifum_refinement_eg1_eg2
begin

lemma bisim_simple_\<R>:
  "bisim_simple (A.\<R> \<Gamma> \<S> P)"
  unfolding bisim_simple_def
  apply clarsimp
  apply(drule_tac lc="\<langle>c\<^sub>1\<^sub>A, mds, mem\<^sub>1\<^sub>A\<rangle>\<^sub>A" and lc'="\<langle>c\<^sub>2\<^sub>A, mds, mem\<^sub>2\<^sub>A\<rangle>\<^sub>A" in A.bisim_simple_\<R>\<^sub>u)
  by simp

(* Don't know to what extent these helpers can be made generic enough to go into any parent theories.
   Again, mightn't be able to (or bother to) make some generic considering the aexp evaluator
   is going to be specific to each language. *)

lemma conc_only_vars_not_visible_abs:
  "(\<forall>v\<^sub>C. v\<^sub>C \<in> range Eg2_var\<^sub>C_of_Eg1 \<longrightarrow> mem\<^sub>C v\<^sub>C = mem\<^sub>C' v\<^sub>C) \<Longrightarrow> mem\<^sub>A_of mem\<^sub>C = mem\<^sub>A_of mem\<^sub>C'"
  by (simp add: mem\<^sub>A_of_def)

lemma conc_only_var_assign_not_visible_abs:
  "\<forall>v\<^sub>C e. v\<^sub>C \<notin> range Eg2_var\<^sub>C_of_Eg1 \<longrightarrow> mem\<^sub>A_of mem\<^sub>C = mem\<^sub>A_of (mem\<^sub>C(v\<^sub>C := e))"
  using conc_only_vars_not_visible_abs
  by simp

lemma reg\<^sub>C_is_not_the_var\<^sub>C_of_anything:
  "reg\<^sub>C = Eg2_var\<^sub>C_of_Eg1 x \<Longrightarrow> False"
  by (induct x, clarsimp+)

lemma reg\<^sub>C_not_visible_abs:
  "reg\<^sub>C \<notin> range Eg2_var\<^sub>C_of_Eg1"
  using reg\<^sub>C_is_not_the_var\<^sub>C_of_anything
  by blast

(* This one's pretty specific to this refinement... *)
lemma reg\<^sub>C_the_only_concrete_only_var:
  "v\<^sub>C \<notin> range Eg2_var\<^sub>C_of_Eg1 \<Longrightarrow> v\<^sub>C = reg\<^sub>C"
  apply(case_tac v\<^sub>C)
       apply(erule rev_notE, clarsimp, rule_tac x=control_var in range_eqI, clarsimp)
      apply(erule rev_notE, clarsimp, rule_tac x=buffer in range_eqI, clarsimp)
     apply(erule rev_notE, clarsimp, rule_tac x=high_var in range_eqI, clarsimp)
    apply(erule rev_notE, clarsimp, rule_tac x=low_var in range_eqI, clarsimp)
   apply(erule rev_notE, clarsimp, rule_tac x=temp in range_eqI, clarsimp)
  apply clarsimp
  done

lemma NoRW\<^sub>A_implies_NoRW\<^sub>C:
  "x \<in> mds\<^sub>A_of mds\<^sub>C AsmNoReadOrWrite \<Longrightarrow>
   Eg2_var\<^sub>C_of_Eg1 x \<in> mds\<^sub>C AsmNoReadOrWrite"
  unfolding mds\<^sub>A_of_def
  apply clarsimp
  apply (simp only: Eg2_var\<^sub>C_of_Eg1_def)
  apply clarsimp
  apply (simp add: f_inv_into_f)
  done

lemma NoWrite\<^sub>A_implies_NoWrite\<^sub>C:
  "x \<in> mds\<^sub>A_of mds\<^sub>C AsmNoWrite \<Longrightarrow>
   Eg2_var\<^sub>C_of_Eg1 x \<in> mds\<^sub>C AsmNoWrite"
  unfolding mds\<^sub>A_of_def
  apply clarsimp
  apply (simp only: Eg2_var\<^sub>C_of_Eg1_def)
  apply clarsimp
  apply (simp add: f_inv_into_f)
  done

lemma assign_eval\<^sub>w_load\<^sub>A:
  shows "(\<langle>x \<leftarrow> Eg1.Load y, mds, mem\<rangle>\<^sub>A, \<langle>Stop, mds, mem (x := mem y)\<rangle>\<^sub>A) \<in> A.eval\<^sub>w"
  by (metis A.assign_eval\<^sub>w ev\<^sub>A.simps(2))

lemma assign_eval\<^sub>w_load\<^sub>C:
  shows "(\<langle>x \<leftarrow> Load y, mds, mem\<rangle>\<^sub>C, \<langle>Stop, mds, mem (x := mem y)\<rangle>\<^sub>C) \<in> C.eval\<^sub>w"
  using C.unannotated[OF C.assign, where E="[]", simplified]
  apply(drule_tac x=x in meta_spec)
  apply(drule_tac x="Load y" in meta_spec)
  apply(drule_tac x=mds in meta_spec)
  apply(drule_tac x=mem in meta_spec)
  apply clarsimp
  done

lemma assign_eval\<^sub>w_const\<^sub>A:
  shows "(\<langle>x \<leftarrow> Eg1.Const c, mds, mem\<rangle>, \<langle>Stop, mds, mem (x := c)\<rangle>) \<in> A.eval\<^sub>w"
  by (metis A.assign_eval\<^sub>w ev\<^sub>A.simps(1))

lemma assign_eval\<^sub>w_const\<^sub>C:
  shows "(\<langle>x \<leftarrow> Const c, mds, mem\<rangle>, \<langle>Stop, mds, mem (x := c)\<rangle>) \<in> C.eval\<^sub>w"
  using C.unannotated[OF C.assign, where E="[]", simplified]
  apply(drule_tac x=x in meta_spec)
  apply(drule_tac x="Const c" in meta_spec)
  apply(drule_tac x=mds in meta_spec)
  apply(drule_tac x=mem in meta_spec)
  apply clarsimp
  done

lemma if_seq_eval\<^sub>w_helper\<^sub>A:
  "(\<langle>If B T E, mds, mem\<rangle>,
    \<langle>if ev\<^sub>B mem B then T else E, mds, mem\<rangle>\<^sub>A) \<in> A.eval\<^sub>w
    \<Longrightarrow>
   (\<langle>If B T E ;; TAIL, mds, mem\<rangle>,
    \<langle>if ev\<^sub>B mem B then T ;; TAIL else E ;; TAIL, mds, mem\<rangle>\<^sub>A) \<in> A.eval\<^sub>w"
  using A.eval\<^sub>w.seq
  by auto

lemma if_seq_eval\<^sub>w_helper\<^sub>C:
  "(\<langle>If B T E, mds, mem\<rangle>,
    \<langle>if ev\<^sub>B\<^sub>C mem B then T else E, mds, mem\<rangle>\<^sub>C) \<in> C.eval\<^sub>w
    \<Longrightarrow>
   (\<langle>If B T E ;; TAIL, mds, mem\<rangle>,
    \<langle>if ev\<^sub>B\<^sub>C mem B then T ;; TAIL else E ;; TAIL, mds, mem\<rangle>\<^sub>C) \<in> C.eval\<^sub>w"
  using C.eval\<^sub>w.seq
  by auto

lemma mem_assign_refinement_helper_var:
  "mem\<^sub>A_of (mem\<^sub>C (Eg2_var\<^sub>C_of_Eg1 x := mem\<^sub>C (Eg2_var\<^sub>C_of_Eg1 y)))
       = (mem\<^sub>A_of mem\<^sub>C) (x := (mem\<^sub>A_of mem\<^sub>C) y)"
  apply(clarsimp simp: mem\<^sub>A_of_def)
  apply(rule ext, clarsimp)
  apply(cases x)
      apply(case_tac x\<^sub>A, clarsimp+)+
  done

lemma mem_assign_refinement_helper_const:
  "mem\<^sub>A_of (mem\<^sub>C (Eg2_var\<^sub>C_of_Eg1 x := c))
       = (mem\<^sub>A_of mem\<^sub>C) (x := c)"
  apply(clarsimp simp: mem\<^sub>A_of_def)
  apply(rule ext, clarsimp)
  apply(cases x)
      apply(case_tac x\<^sub>A, clarsimp+)+
  done

lemma if_true_eval\<^sub>w\<^sub>C:
  shows "mem\<^sub>C x = 0 \<longrightarrow>
     (\<langle>(If (Eq x 0) c\<^sub>C_then c\<^sub>C_else) ;; c\<^sub>C_tail, mds\<^sub>C, mem\<^sub>C\<rangle>\<^sub>C,
      \<langle>(c\<^sub>C_then ;; c\<^sub>C_tail), mds\<^sub>C, mem\<^sub>C\<rangle>\<^sub>C) \<in> C.eval\<^sub>w"
  using C.if_eval\<^sub>w C.eval\<^sub>w.seq ev\<^sub>B\<^sub>C.simps by presburger

lemma if_false_eval\<^sub>w\<^sub>C:
  shows "mem\<^sub>C x \<noteq> 0 \<longrightarrow>
     (\<langle>(If (Eq x 0) c\<^sub>C_then c\<^sub>C_else) ;; c\<^sub>C_tail, mds\<^sub>C, mem\<^sub>C\<rangle>\<^sub>C,
      \<langle>(c\<^sub>C_else ;; c\<^sub>C_tail), mds\<^sub>C, mem\<^sub>C\<rangle>\<^sub>C) \<in> C.eval\<^sub>w"
  using C.if_eval\<^sub>w C.eval\<^sub>w.seq ev\<^sub>B\<^sub>C.simps by presburger

end

end


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

(*
 * This file contains an example spec, and shows it obeys the well_formed constraints
 *
 * This file contains the invariants of the user-space initialiser,
 * the well-formed conditions of the input capDL specification,
 * and the predicates describing the initial state.
 *)

theory ExampleSpecIRQ_SI
imports WellFormed_SI
begin

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

(****************************************************
 * Definitions of all the objects and capabilities. *
 ***************************************************)

definition small_section_size :: nat
where
  "small_section_size = 20"

definition "guard = 0"
definition "guard_size = 1"
definition "cnode_a1_size = 7"
definition "cnode_a2_size = 7"
definition "cnode_b_size = 8"
definition "cnode_extra_size = 2"
lemmas constants [simp] = guard_def guard_size_def cnode_a1_size_def cnode_a2_size_def
                          cnode_b_size_def cnode_extra_size_def

definition "tcb_a_id = 9"
definition "tcb_b_id = 10"
definition "cnode_a1_id = 6"
definition "cnode_a2_id = 7"
definition "cnode_b_id = 5"
definition "cnode_extra_id = 11"
definition "ep_id = 12"
definition "ntfn_id = 13"
definition "pd_a_id = 1"
definition "pt_a_id = 8"
definition "pd_b_id = 2"
definition "frame_a1_id = 3"
definition "frame_a2_id = 4"
definition "frame_b_id = 0"
lemmas ids [simp] = tcb_a_id_def tcb_b_id_def cnode_a1_id_def
                    cnode_a2_id_def cnode_b_id_def cnode_extra_id_def
                    ep_id_def ntfn_id_def pd_a_id_def pt_a_id_def pd_b_id_def
                    frame_a1_id_def frame_a2_id_def frame_b_id_def

definition
  "tcb_a =
  \<lparr>cdl_tcb_caps = [tcb_cspace_slot \<mapsto> CNodeCap cnode_a1_id guard guard_size cnode_a1_size,
                   tcb_vspace_slot \<mapsto> PageDirectoryCap pd_a_id Real None,
                   tcb_replycap_slot \<mapsto> NullCap,
                   tcb_caller_slot \<mapsto> NullCap,
                   tcb_ipcbuffer_slot \<mapsto> FrameCap False frame_a1_id {AllowRead, AllowWrite} small_frame_size Real None,
                   tcb_pending_op_slot \<mapsto> NullCap,
                   tcb_boundntfn_slot \<mapsto> NullCap],
   cdl_tcb_fault_endpoint = 0,
   cdl_tcb_intent = \<lparr>cdl_intent_op = None, cdl_intent_error = False, cdl_intent_cap = 0,
                     cdl_intent_extras = [], cdl_intent_recv_slot = None\<rparr>,
   cdl_tcb_has_fault = False,
   cdl_tcb_domain = minBound\<rparr>"

definition
  "tcb_b =
  \<lparr>cdl_tcb_caps = [tcb_cspace_slot \<mapsto> CNodeCap cnode_b_id guard guard_size cnode_b_size,
                   tcb_vspace_slot \<mapsto> PageDirectoryCap pd_b_id Real None,
                   tcb_replycap_slot \<mapsto> NullCap,
                   tcb_caller_slot \<mapsto> NullCap,
                   tcb_ipcbuffer_slot \<mapsto> FrameCap False frame_b_id {AllowRead, AllowWrite} small_section_size Real None,
                   tcb_pending_op_slot \<mapsto> NullCap,
                   tcb_boundntfn_slot \<mapsto> NullCap],
   cdl_tcb_fault_endpoint = 0,
   cdl_tcb_intent = \<lparr>cdl_intent_op = None, cdl_intent_error = False, cdl_intent_cap = 0,
                     cdl_intent_extras = [], cdl_intent_recv_slot = None\<rparr>,
   cdl_tcb_has_fault = False,
   cdl_tcb_domain = minBound\<rparr>"

definition
  "new_cap_map sz caps \<equiv> empty_cap_map sz ++ caps"

definition
  "new_cnode sz caps \<equiv> \<lparr>cdl_cnode_caps = new_cap_map sz caps,
                        cdl_cnode_size_bits = sz\<rparr>"

definition
  "cnode_a1 \<equiv>
   new_cnode cnode_a1_size
             [0 \<mapsto> TcbCap tcb_a_id,
              1 \<mapsto> CNodeCap cnode_a2_id guard guard_size cnode_a2_size]"

definition
  "cnode_a2 \<equiv>
   new_cnode cnode_a2_size
             [0 \<mapsto> EndpointCap ep_id 0 {Write},
              2 \<mapsto> CNodeCap cnode_a1_id guard guard_size cnode_a1_size,
              3 \<mapsto> PageDirectoryCap pd_a_id Real None,
              4 \<mapsto> PageTableCap pt_a_id Real None,
              8 \<mapsto> FrameCap False frame_a1_id {AllowRead, AllowWrite} small_frame_size Real None,
              10 \<mapsto> NotificationCap ntfn_id 0 {Read},
              11 \<mapsto> FrameCap False frame_a2_id {AllowRead, AllowWrite} small_frame_size Real None,
              12 \<mapsto> IrqHandlerCap 4]"

definition
  "cnode_b \<equiv>
   new_cnode cnode_b_size
             [0 \<mapsto> TcbCap tcb_b_id,
              2 \<mapsto> CNodeCap cnode_b_id guard guard_size cnode_b_size,
              4 \<mapsto> EndpointCap ep_id 0 {Read},
              7 \<mapsto> PageDirectoryCap pd_b_id Real None,
              8 \<mapsto> FrameCap False frame_b_id {AllowRead, AllowWrite} small_section_size Real None,
              254 \<mapsto> IrqHandlerCap 254]"

definition
  "cnode_extra \<equiv>
   new_cnode cnode_extra_size
             [0 \<mapsto> CNodeCap cnode_extra_id guard guard_size cnode_extra_size,
              1 \<mapsto> EndpointCap ep_id 0 UNIV,
              2 \<mapsto> NotificationCap ntfn_id 0 {Read, Write}]"

definition
  "pd_a \<equiv> \<lparr>cdl_page_directory_caps = new_cap_map pd_size [0 \<mapsto> PageTableCap pt_a_id Fake None]\<rparr>"

definition
  "pd_b \<equiv> \<lparr>cdl_page_directory_caps = new_cap_map pd_size
           [2 \<mapsto> FrameCap False frame_b_id {AllowRead, AllowWrite} small_section_size Fake None]\<rparr>"

definition
  "pt_a \<equiv> \<lparr>cdl_page_table_caps = new_cap_map pt_size
           [0 \<mapsto> FrameCap False frame_a1_id {AllowRead, AllowWrite} small_frame_size Fake None,
            255 \<mapsto> FrameCap False frame_a2_id {AllowRead, AllowWrite} small_frame_size Fake None]\<rparr>"

definition
  "empty_frame \<equiv> \<lparr>cdl_frame_size_bits = small_frame_size\<rparr>"
definition
  "empty_section \<equiv> \<lparr>cdl_frame_size_bits = small_section_size\<rparr>"

definition
  example_irq_node :: "cdl_irq \<Rightarrow> cdl_object_id"
where
  "example_irq_node = (\<lambda>irq. ucast irq + 0x100)"

definition
  "new_irq_node obj_id \<equiv>
    \<lparr> cdl_irq_node_caps = (\<lambda>slot. if slot = 0
                                    then Some (NotificationCap obj_id 0 {Read, Write})
                                    else None)\<rparr>"

definition
  irq_objects :: cdl_heap
where
  "irq_objects \<equiv>
  \<lambda>obj_id. if obj_id = 0x104 then Some (IRQNode (new_irq_node ntfn_id))
           else if 0x100 \<le> obj_id \<and> obj_id < 0x200 then (Some (IRQNode empty_irq_node))
           else None"

lemma
  "irq_objects =
  (\<lambda>obj_id. if 0x100 \<le> obj_id \<and> obj_id < 0x200
            then (Some (IRQNode empty_irq_node))
            else None) ++
  (\<lambda>obj_id. if obj_id = 0x104 then Some (IRQNode (new_irq_node ntfn_id))
           else None)"
  apply (rule ext)
  apply (clarsimp simp: irq_objects_def map_add_def)
  done

definition
  "example_spec =
  \<lparr>cdl_arch = ARM11,
   cdl_objects = [tcb_a_id    \<mapsto> Tcb tcb_a,
                  tcb_b_id    \<mapsto> Tcb tcb_b,
                  pd_a_id     \<mapsto> PageDirectory pd_a,
                  pt_a_id     \<mapsto> PageTable pt_a,
                  pd_b_id     \<mapsto> PageDirectory pd_b,
                  cnode_a1_id \<mapsto> CNode cnode_a1,
                  cnode_a2_id \<mapsto> CNode cnode_a2,
                  cnode_b_id  \<mapsto> CNode cnode_b,
                  cnode_extra_id \<mapsto> CNode cnode_extra,
                  frame_a1_id \<mapsto> Frame empty_frame,
                  frame_a2_id \<mapsto> Frame empty_frame,
                  frame_b_id  \<mapsto> Frame empty_section,
                  ep_id       \<mapsto> Endpoint,
                  ntfn_id      \<mapsto> Notification,
                  0x104       \<mapsto> IRQNode (new_irq_node ntfn_id),
                  0x1FE       \<mapsto> IRQNode empty_irq_node],
   cdl_cdt = [(cnode_a2_id, 0)  \<mapsto> (cnode_extra_id, 1),
              (cnode_b_id,  4)  \<mapsto> (cnode_extra_id, 1),
              (cnode_a2_id, 10) \<mapsto> (cnode_extra_id, 2)], \<comment> \<open>All caps are orig caps,
                                                            except endpoints and notifications.\<close>
   cdl_current_thread = undefined,
   cdl_irq_node = example_irq_node,
   cdl_asid_table = undefined,
   cdl_current_domain = minBound\<rparr>"

declare cap_object_simps [simp]

lemmas cnode_defs = cnode_a1_def cnode_a2_def cnode_b_def cnode_extra_def
lemmas obj_defs   = cnode_defs tcb_a_def tcb_b_def pd_a_def pd_b_def pt_a_def

lemmas example_spec_def_expanded = example_spec_def
  [unfolded obj_defs tcb_slot_defs tcb_pending_op_slot_def
             new_cnode_def new_cap_map_def empty_cap_map_def]

(*************************
 *     Helper lemmas.    *
 *************************)
lemma cap_has_object_IrqHandlerCap [simp]:
  "\<not>cap_has_object (IrqHandlerCap irq)"
  by (clarsimp simp: cap_has_object_def)+

lemma badge_bits_2p [simp]:
  "(0::word32) < 2 ^ badge_bits"
  by (clarsimp simp: p2_gt_0 badge_bits_def)

lemma cdl_cnode_size_bits_new_cnode [simp]:
  "cdl_cnode_size_bits (new_cnode sz caps) = sz"
  by (clarsimp simp: new_cnode_def)

lemma cnode_cap_size_simps [simp]:
  "cnode_cap_size (CNodeCap a b c sz) = sz"
  by (clarsimp simp: cnode_cap_size_def)

lemma object_size_bits_new_cnode [simp]:
  "object_size_bits (CNode (new_cnode sz caps)) = sz"
  by (clarsimp simp: object_size_bits_def)

lemma object_slots_Endpoint [simp]:
  "object_slots Endpoint = Map.empty"
  by (simp add: object_slots_def)

lemma cdl_frame_size_bits_empty_frame [simp]:
  "cdl_frame_size_bits empty_frame = small_frame_size"
  by (simp add: empty_frame_def)

lemma cdl_frame_size_bits_empty_section [simp]:
  "cdl_frame_size_bits empty_section = small_section_size"
  by (simp add: empty_section_def)

lemma object_slots_empty_objects [simp]:
  "object_slots (Frame f) slot = None"
  by (clarsimp simp: object_slots_def)+

lemma is_fake_pt_cap_simps:
  "\<not> is_fake_pt_cap (PageTableCap obj_id Real asid)"
  "is_fake_pt_cap (PageTableCap obj_id Fake asid)"
  by (clarsimp simp: is_fake_pt_cap_def)+

lemma frame_cap_not_cnode:
  "\<not>is_cnode_cap (FrameCap dev a b c d e)"
  by (clarsimp simp: cap_type_def)

lemma empty_cap_map_NullCap [simp]:
  "empty_cap_map sz slot = Some cap \<Longrightarrow> cap = NullCap"
  by (clarsimp simp: empty_cap_map_def split: if_split_asm)

lemma new_cap_map_empty_NullCap [simp]:
  "new_cap_map sz Map.empty slot = Some cap \<Longrightarrow> cap = NullCap"
  by (clarsimp simp: new_cap_map_def)

lemma new_cap_map_slot:
  "\<lbrakk>new_cap_map sz caps slot = Some cap; cap \<noteq> NullCap\<rbrakk> \<Longrightarrow> caps slot = Some cap"
  by (clarsimp simp: new_cap_map_def empty_cap_map_def split: option.splits if_split_asm)

lemma cdl_cnode_caps_new_cnode:
  "\<lbrakk>cdl_cnode_caps (new_cnode sz caps) slot = Some cap; cap \<noteq> NullCap\<rbrakk> \<Longrightarrow> caps slot = Some cap"
  by (clarsimp simp: new_cnode_def, erule (1) new_cap_map_slot)

lemma new_cap_map_caps_D:
  "new_cap_map sz caps slot = Some cap \<Longrightarrow> caps slot = Some cap \<or> cap = NullCap"
  by (clarsimp simp: new_cap_map_def)

lemma cdl_cnode_caps_new_cnode_D:
  "\<lbrakk>cdl_cnode_caps (new_cnode sz caps) slot = Some cap\<rbrakk>
  \<Longrightarrow> caps slot = Some cap \<or> cap = NullCap"
  by (clarsimp simp: new_cnode_def, erule (1) new_cap_map_slot)

lemma cdl_irq_node_caps_empty_irq_node_D:
  "\<lbrakk>cdl_irq_node_caps (empty_irq_node) slot = Some cap\<rbrakk>
  \<Longrightarrow> cap = NullCap"
  by (clarsimp simp: empty_irq_node_def)

lemma object_slots_new_cnode_D:
  "object_slots (CNode (new_cnode sz caps)) slot = Some cap
  \<Longrightarrow> caps slot = Some cap \<or> cap = NullCap"
  by (clarsimp simp: object_slots_def dest!: cdl_cnode_caps_new_cnode_D)

lemma object_slots_new_cnode_cap_has_object [dest!]:
  "\<lbrakk>object_slots (CNode (new_cnode sz caps)) slot = Some cap; cap_has_object cap\<rbrakk>
  \<Longrightarrow> caps slot = Some cap"
  by (clarsimp simp: object_slots_def dest!: cdl_cnode_caps_new_cnode_D)

lemma cdl_cnode_caps_empty_cnode [dest!]:
  "cdl_cnode_caps (empty_cnode sz) slot = Some cap \<Longrightarrow> cap = NullCap"
  by (clarsimp simp: empty_cnode_def)

lemma cdl_cnode_caps_new_cnode_cnode_cap:
  "\<lbrakk>cdl_cnode_caps (new_cnode sz caps) slot = Some cap; is_cnode_cap cap\<rbrakk>
  \<Longrightarrow> caps slot = Some cap"
  by (erule cdl_cnode_caps_new_cnode, clarsimp)

lemma object_slots_new_cnode_cnode_cap:
  "\<lbrakk>object_slots (CNode (new_cnode sz caps)) slot = Some cap; is_cnode_cap cap\<rbrakk>
  \<Longrightarrow> caps slot = Some cap"
  by (clarsimp simp: object_slots_def, erule cdl_cnode_caps_new_cnode, clarsimp)

lemma object_slots_empty_irq_node [simp, dest!]:
  "object_slots (IRQNode empty_irq_node) slot = Some cap \<Longrightarrow> cap = NullCap"
  by (clarsimp simp: object_slots_def empty_irq_node_def)

lemma tcb_domain_simp [simp]:
  "tcb_domain (Tcb \<lparr>cdl_tcb_caps = caps,
                    cdl_tcb_fault_endpoint = 0,
                    cdl_tcb_intent = intent,
                    cdl_tcb_has_fault = fault,
                    cdl_tcb_domain = domain\<rparr>) = domain"
  by (simp add: tcb_domain_def)

lemma cdl_irq_node_example_spec [simp]:
  "cdl_irq_node example_spec = example_irq_node"
  by (clarsimp simp: example_spec_def)

lemma range_example_irq_node_helper:
  "range example_irq_node = (\<lambda>irq. irq + 0x100) ` range (ucast :: 10 word \<Rightarrow> 32 word)"
  by (auto simp: example_irq_node_def image_def)

lemma range_example_irq_node:
  "range example_irq_node =  {x. 0x100 \<le> x \<and> x < 0x500}"
  apply (clarsimp simp: range_example_irq_node_helper ucast_range_less)
  apply (clarsimp simp: image_def)
  apply rule
   apply (clarsimp simp:  word_le_nat_alt  word_less_nat_alt unat_plus_if')
  apply clarsimp
  apply (rule_tac x="x - 0x100" in exI)
  apply unat_arith
  done

lemma irq_nodes_example_spec:
  "irq_nodes example_spec = {obj_id. obj_id = 0x104 \<or> obj_id = 0x1FE}"
  by (auto simp: irq_nodes_def example_spec_def object_at_def is_irq_node_def)

(*************************
 * End of helper lemmas. *
 *************************)

(************************
Helpers on the specific state.

***************************)

lemma onehundred_not_le_one:
  "\<not>(0x100 \<le> (1::32 word))"
  by unat_arith

lemma object_type_simps [simp]:
  "object_type (Tcb t) = TcbType"
  "object_type (CNode c) = CNodeType"
  "object_type (Endpoint) = EndpointType"
  "object_type (Notification) = NotificationType"
  "object_type (PageDirectory pd) = PageDirectoryType"
  "object_type (PageTable pt) = PageTableType"
  "object_type (Frame f) = FrameType (cdl_frame_size_bits f)"
  "object_type (IRQNode empty_irq_node) = IRQNodeType"
  by (clarsimp simp: object_type_def)+

lemma cap_irq_simp [simp]:
  "cap_irq (IrqHandlerCap irq) = irq"
  by (simp add: cap_irq_def)

lemma example_irq_node_simps [simp]:
  "example_irq_node 4 = 0x104"
  "example_irq_node 0xFE = 0x1FE"
  by (simp add: example_irq_node_def)+

lemma irq_objects_simps [simp]:
  "irq_objects 0 = None"
  "irq_objects 1 = None"
  "irq_objects 2 = None"
  "irq_objects 3 = None"
  "irq_objects 4 = None"
  "irq_objects 5 = None"
  "irq_objects 6 = None"
  "irq_objects 7 = None"
  "irq_objects 8 = None"
  "irq_objects 9 = None"
  "irq_objects 0xA = None"
  "irq_objects 0xB = None"
  "irq_objects 0xC = None"
  "irq_objects 0xD = None"
  by (clarsimp simp: irq_objects_def onehundred_not_le_one)+

lemma opt_cap_example_spec [simp]:
  "opt_cap (4, slot) example_spec = object_slots (Frame empty_frame) slot"
  "opt_cap (5, slot) example_spec = object_slots (CNode cnode_b) slot"
  "opt_cap (6, slot) example_spec = object_slots (CNode cnode_a1) slot"
  "opt_cap (7, slot) example_spec = object_slots (CNode cnode_a2) slot"
  "opt_cap (0xB, slot) example_spec = object_slots (CNode cnode_extra) slot"
  by (auto simp: example_spec_def opt_cap_def slots_of_def
                 map_add_def  irq_objects_def
          split: if_split_asm)

lemma irq_objects_some_object:
  "irq_objects obj_id = Some obj \<Longrightarrow>
  (obj_id = 0x104 \<and> obj = IRQNode (new_irq_node ntfn_id)) \<or> obj = IRQNode empty_irq_node"
  by (clarsimp simp: irq_objects_def split: if_split_asm)

(*
lemma real_cnode_at_example_spec:
  "real_cnode_at obj_id example_spec
  \<Longrightarrow> obj_id = cnode_a1_id \<or> obj_id = cnode_a2_id \<or> obj_id = cnode_b_id \<or> obj_id = cnode_extra_id"
  apply (clarsimp simp: real_cnode_at_def object_at_def is_cnode_def irq_cnodes_example_spec)
  by (auto simp: example_spec_def object_at_def is_cnode_def irq_objects_def
          split: if_split_asm cdl_object.splits)
*)

lemma cnode_at_example_spec:
  "cnode_at obj_id example_spec =
  (obj_id = cnode_a1_id \<or> obj_id = cnode_a2_id \<or> obj_id = cnode_b_id \<or> obj_id = cnode_extra_id)"
  apply (clarsimp simp: object_at_def is_cnode_def)
  apply (auto simp: example_spec_def irq_objects_def map_add_def
             split: if_split_asm cdl_object.splits)
  done

lemma pt_at_example_spec:
  "pt_at obj_id example_spec = (obj_id = pt_a_id)"
  apply (clarsimp simp: object_at_def is_cnode_def)
  apply (auto simp: example_spec_def object_at_def is_pt_def irq_objects_def
                    new_irq_node_def empty_irq_node_def
             split: if_split_asm cdl_object.splits)
  done

lemma pd_at_example_spec:
  "pd_at obj_id example_spec = (obj_id = pd_a_id \<or> obj_id = pd_b_id)"
  apply (clarsimp simp: object_at_def is_cnode_def)
  apply (auto simp: example_spec_def object_at_def is_pd_def irq_objects_def
                    new_irq_node_def empty_irq_node_def
             split: if_split_asm cdl_object.splits)
  done

lemma slots_of_example_spec_obj_ids:
  "\<lbrakk>slots_of obj_id example_spec 0 = Some cap; cap \<noteq> NullCap\<rbrakk>\<Longrightarrow>
  ((obj_id = tcb_a_id) \<or>
  (obj_id = tcb_b_id) \<or>
  (obj_id = cnode_a1_id) \<or>
  (obj_id = cnode_a2_id) \<or>
  (obj_id = cnode_b_id) \<or>
  (obj_id = cnode_extra_id) \<or>
  (obj_id = pd_a_id) \<or>
  (obj_id = pt_a_id) \<or>
  (obj_id = pd_b_id) \<or>
  (obj_id = 0x104))"
  by (clarsimp simp: example_spec_def slots_of_def object_slots_def
              split: if_split_asm)

lemma irq_handler_cap_example_spec:
  "\<lbrakk>is_irqhandler_cap cap; opt_cap (obj_id, slot) example_spec = Some cap\<rbrakk>
  \<Longrightarrow> (obj_id = cnode_a2_id \<and> slot = 12) \<or>
      (obj_id = cnode_b_id \<and> slot = 254)"
  by (clarsimp simp: example_spec_def opt_cap_def slots_of_def
                     object_slots_def empty_irq_node_def new_irq_node_def new_cnode_def
                     obj_defs new_cap_map_def empty_cap_map_def
              split: if_split_asm)

lemma irqhandler_cap_at_example_spec:
  "irqhandler_cap_at (obj_id, slot) example_spec
  = ((obj_id = cnode_a2_id \<and> slot = 12) \<or>
     (obj_id = cnode_b_id \<and> slot = 254))"
  apply (clarsimp simp: cap_at_def)
  apply (rule iffI)
   apply clarsimp
   apply (drule (1) irq_handler_cap_example_spec)
   apply clarsimp
  apply (erule disjE)
   apply (clarsimp simp: cnode_a2_def object_slots_def new_cnode_def new_cap_map_def)
  apply (clarsimp simp: cnode_b_def object_slots_def new_cnode_def new_cap_map_def)
  done

lemma cap_at_has_no_parents_in_cdt_example_spec:
  "cap_at_has_no_parents_in_cdt (obj_id, slot) example_spec
  = ((obj_id \<noteq> cnode_a2_id \<or> slot \<noteq> 0) \<and>
     (obj_id \<noteq> cnode_a2_id \<or> slot \<noteq> 10) \<and>
     (obj_id \<noteq> cnode_b_id \<or> slot \<noteq> 4))"
  by (auto simp: cap_at_has_no_parents_in_cdt_def opt_parent_def example_spec_def)

lemma is_orig_cap_example_spec:
  "original_cap_at (obj_id, slot) example_spec
  = ((obj_id \<noteq> cnode_a2_id \<or> slot \<noteq> 0) \<and>
     (obj_id \<noteq> cnode_a2_id \<or> slot \<noteq> 10) \<and>
     (obj_id \<noteq> cnode_b_id \<or> slot \<noteq> 4))"
  by (fastforce simp: original_cap_at_def cap_at_has_no_parents_in_cdt_example_spec irqhandler_cap_at_example_spec)

(****************************************
 * Proof that the state is well formed. *
 ****************************************)

lemma well_formed_tcb_a:
  "well_formed_tcb example_spec obj_id (Tcb tcb_a)"
  by (auto simp: well_formed_tcb_def object_slots_def tcb_a_def tcb_slot_defs tcb_has_fault_def
                 is_default_cap_def default_cap_def cap_type_def irq_nodes_example_spec)

lemma well_formed_tcb_b:
  "well_formed_tcb example_spec obj_id (Tcb tcb_b)"
  by (auto simp: well_formed_tcb_def object_slots_def tcb_b_def tcb_slot_defs tcb_has_fault_def
                 is_default_cap_def default_cap_def cap_type_def irq_nodes_example_spec)

lemma well_formed_orig_caps_unique_example:
  "well_formed_orig_caps_unique example_spec"
  apply (clarsimp simp: well_formed_orig_caps_unique_def)
  apply (clarsimp simp: cnode_at_example_spec is_orig_cap_example_spec)
  by (elim disjE, (clarsimp simp: cnode_defs split: if_split_asm)+)

lemma well_formed_fake_pt_caps_unique_example:
  "well_formed_fake_pt_caps_unique example_spec"
   apply (clarsimp simp: well_formed_fake_pt_caps_unique_def
                         pd_at_example_spec)
   apply (fastforce simp: example_spec_def opt_cap_def slots_of_def
                          object_slots_def is_fake_pt_cap_simps
                          pd_a_def pd_b_def new_cap_map_def irq_objects_def
                   split: if_split_asm option.splits)
  done

lemma well_formed_orig_cap_tcb [simp]:
  "well_formed_orig_cap (TcbCap obj_id)"
  by (clarsimp simp: well_formed_orig_cap_def default_cap_def cap_type_def
                     cap_rights_def ep_related_cap_def)

lemma well_formed_cap_ex [simp]:
  "well_formed_cap (CNodeCap a 0 0 2)"
  "well_formed_cap (TcbCap 0)"
  by (clarsimp simp: well_formed_cap_def guard_bits_def)+

lemma well_formed_cap_example [simp]:
  "\<lbrakk>cdl_objects example_spec obj_id = Some obj;
    object_slots obj slot = Some cap; cap \<noteq> NullCap\<rbrakk>
  \<Longrightarrow> well_formed_cap cap"
  apply (clarsimp simp: well_formed_cap_def)
  by (clarsimp simp: well_formed_cap_def example_spec_def
                     obj_defs new_cap_map_def new_irq_node_def new_cnode_def
                     object_slots_def empty_cap_map_def guard_bits_def
                     tcb_slot_defs vm_read_write_def
              split: cdl_cap.splits if_split_asm)

lemma well_formed_cdt_example [simp]:
  "\<lbrakk>cdl_objects example_spec obj_id = Some obj;
    object_slots obj slot = Some cap; cap \<noteq> NullCap\<rbrakk>
  \<Longrightarrow> well_formed_cdt example_spec (obj_id, slot) cap"
  apply (clarsimp simp: well_formed_cdt_def)
  apply (clarsimp simp: cnode_at_example_spec)
  apply (case_tac "(obj_id = cnode_a2_id \<and> slot = 0) \<or>
                   (obj_id = cnode_b_id \<and> slot = 4)")
   apply (rule_tac x=cnode_extra_id in exI, clarsimp, rule conjI)
    subgoal by (fastforce simp: example_spec_def cnode_defs
                    split: if_split_asm)
   apply (rule_tac x=1 in exI)
   apply (clarsimp simp: is_orig_cap_example_spec)
   apply (clarsimp simp: example_spec_def opt_cap_def slots_of_def
                         cnode_defs object_slots_def new_cnode_def new_cap_map_def
                         irq_objects_def map_add_def empty_irq_node_def
                  split: if_split_asm)
  apply (case_tac "(obj_id = cnode_a2_id \<and> slot = 10)")
   apply (rule_tac x=cnode_extra_id in exI, clarsimp, rule conjI)
    apply (fastforce simp: example_spec_def cnode_defs
                    split: if_split_asm)
   apply (rule_tac x=2 in exI)
   apply (clarsimp simp: is_orig_cap_example_spec)
   apply (clarsimp simp: example_spec_def opt_cap_def slots_of_def
                         cnode_defs object_slots_def new_cnode_def new_cap_map_def
                         irq_objects_def map_add_def empty_irq_node_def
                  split: if_split_asm)
  apply clarsimp
  apply (rule_tac x=obj_id in exI, clarsimp, rule conjI)
   apply (clarsimp simp: example_spec_def cnode_defs
                  dest!: object_slots_new_cnode_D
                  split: if_split_asm)
  apply (fastforce simp: is_orig_cap_example_spec opt_cap_def slots_of_def)
  done

lemma well_formed_orig_cap_example [simp]:
  "\<lbrakk>cdl_objects example_spec obj_id = Some obj;
    object_slots obj slot = Some cap; cap \<noteq> NullCap;
    original_cap_at (obj_id, slot) example_spec \<rbrakk>
   \<Longrightarrow> well_formed_orig_cap cap"
  apply (clarsimp simp: is_orig_cap_example_spec well_formed_orig_cap_def)
  by (clarsimp simp: example_spec_def object_slots_def obj_defs new_cnode_def new_cap_map_def
                        new_irq_node_def ep_related_cap_def cap_type_def default_cap_def cap_rights_def
                split: if_split_asm)

lemma well_formed_caps_example:
  "cdl_objects example_spec obj_id = Some obj \<Longrightarrow>
   well_formed_caps example_spec obj_id obj"
   apply (clarsimp simp: well_formed_caps_def, rule conjI)
   apply (clarsimp simp: is_orig_cap_example_spec)
   apply (clarsimp simp: example_spec_def obj_defs object_type_def cap_type_def object_slots_def
                         is_copyable_cap_def
                  dest!: cdl_cnode_caps_new_cnode_D new_cap_map_caps_D
                  split: if_split_asm)
   apply (rule conjI)
    apply (clarsimp simp: well_formed_cap_to_real_object_def real_object_at_def irq_nodes_example_spec)
    apply (clarsimp simp: example_spec_def obj_defs object_slots_def onehundred_not_le_one
                   dest!: cdl_cnode_caps_new_cnode_D new_cap_map_caps_D
                          irq_objects_some_object cdl_irq_node_caps_empty_irq_node_D
                   split: if_split_asm)
    apply (fastforce simp: new_irq_node_def empty_irq_node_def split: if_split_asm)
   apply (rule conjI)
    apply (clarsimp simp: well_formed_cap_types_match_def)
    apply (rule conjI)
     apply (clarsimp simp: example_spec_def object_slots_def obj_defs
                           irq_objects_def map_add_def new_irq_node_def
                           onehundred_not_le_one
                    dest!: cdl_cnode_caps_new_cnode_D new_cap_map_caps_D
                           cdl_irq_node_caps_empty_irq_node_D
                    split: if_split_asm)
   apply (clarsimp simp: example_spec_def object_slots_def obj_defs
                         irq_objects_def map_add_def new_irq_node_def
                         onehundred_not_le_one object_type_def
                  dest!: cdl_cnode_caps_new_cnode_D new_cap_map_caps_D cdl_irq_node_caps_empty_irq_node_D
                  split: if_split_asm)
   by (clarsimp simp: example_spec_def obj_defs is_cnode_def is_tcb_def is_fake_vm_cap_def
                         object_slots_def object_type_def cap_type_def new_irq_node_def
                         empty_irq_node_def empty_cnode_def
                  dest!: cdl_cnode_caps_new_cnode_D irq_objects_some_object cdl_irq_node_caps_empty_irq_node_D
                  split: if_split_asm cdl_object.splits)

lemma real_object_at_example_spec:
  "real_object_at obj_id example_spec =
  ((obj_id = tcb_a_id) \<or>
  (obj_id = tcb_b_id) \<or>
  (obj_id = cnode_a1_id) \<or>
  (obj_id = cnode_a2_id) \<or>
  (obj_id = cnode_b_id) \<or>
  (obj_id = cnode_extra_id) \<or>
  (obj_id = ep_id) \<or>
  (obj_id = ntfn_id) \<or>
  (obj_id = pd_a_id) \<or>
  (obj_id = pt_a_id) \<or>
  (obj_id = pd_b_id) \<or>
  (obj_id = frame_a1_id) \<or>
  (obj_id = frame_a2_id) \<or>
  (obj_id = frame_b_id))"
  apply (clarsimp simp: real_object_at_def irq_nodes_example_spec)
  apply (clarsimp simp: example_spec_def irq_objects_def dom_def onehundred_not_le_one
                 split: if_split_asm)
  done

lemma real_object_at_example_spec_simp [simp]:
  "real_object_at 0 example_spec"
  "real_object_at 1 example_spec = True"
  "real_object_at 2 example_spec"
  "real_object_at 3 example_spec"
  "real_object_at 4 example_spec"
  "real_object_at 5 example_spec"
  "real_object_at 6 example_spec"
  "real_object_at 7 example_spec"
  "real_object_at 8 example_spec"
  "real_object_at 9 example_spec"
  "real_object_at 0xA example_spec"
  "real_object_at 0xB example_spec"
  "real_object_at 0xC example_spec"
  "real_object_at 0xD example_spec"
  "\<not>real_object_at 0x104 example_spec"
  "\<not>real_object_at 0x1FE example_spec"
  by (clarsimp simp: real_object_at_example_spec)+

lemma cdl_objects_example_spec_simps [simp]:
  "cdl_objects example_spec 4 = Some (Frame empty_frame)"
  "cdl_objects example_spec 0xD = Some Notification"
  "cdl_objects example_spec 0x1FE = Some (IRQNode empty_irq_node)"
  by (clarsimp simp: example_spec_def map_add_def)+

lemma well_formed_cap_to_object_example:
  "cdl_objects example_spec obj_id = Some obj
   \<Longrightarrow> well_formed_cap_to_object example_spec obj_id obj"
  apply (clarsimp simp: well_formed_cap_to_object_def is_orig_cap_example_spec)
  apply (intro conjI)
   apply (case_tac "obj_id = ep_id \<or>
                    obj_id = ntfn_id \<or>
                    obj_id = cnode_extra_id")
    apply (rule_tac x=cnode_extra_id in exI)
    apply (fastforce simp: cnode_at_example_spec cnode_extra_def
                           object_slots_def new_cnode_def new_cap_map_def)
   apply (case_tac "obj_id = tcb_b_id \<or>
                    obj_id = cnode_b_id \<or>
                    obj_id = pd_b_id \<or>
                    obj_id = frame_b_id")
    apply (rule_tac x=cnode_b_id in exI)
    apply (fastforce simp: cnode_at_example_spec cnode_b_def
                          object_slots_def new_cnode_def new_cap_map_def)
   apply (case_tac "obj_id = tcb_a_id \<or>
                    obj_id = cnode_a2_id")
    apply (rule_tac x=cnode_a1_id in exI)
    apply (fastforce simp: cnode_at_example_spec cnode_a1_def
                          object_slots_def new_cnode_def new_cap_map_def)
   apply (case_tac "obj_id = cnode_a1_id \<or>
                    obj_id = pd_a_id \<or>
                    obj_id = pt_a_id \<or>
                    obj_id = frame_a1_id \<or>
                    obj_id = ep_id")
    apply (rule_tac x=cnode_a2_id in exI)
    apply (fastforce simp: cnode_at_example_spec cnode_a2_def
                           object_slots_def new_cnode_def new_cap_map_def)
   apply (case_tac "obj_id = frame_a2_id")
    apply (rule_tac x=cnode_a2_id in exI)
    apply (rule_tac x=11 in exI) (* Not sure why fastforce gives up here. *)
    apply (fastforce simp: cnode_at_example_spec cnode_a2_def
                           object_slots_def new_cnode_def new_cap_map_def)
   apply (case_tac "obj_id = 0x104")
    apply (rule_tac x=cnode_a2_id in exI)
    apply (rule_tac x=12 in exI) (* Not sure why fastforce gives up here. *)
    apply (fastforce simp: cnode_at_example_spec cnode_a2_def
                           object_slots_def new_cnode_def new_cap_map_def)
   apply (case_tac "obj_id = 0x1FE")
    apply (rule_tac x=cnode_b_id in exI)
    apply (fastforce simp: cnode_at_example_spec cnode_b_def
                           object_slots_def new_cnode_def new_cap_map_def)
   apply (clarsimp simp: example_spec_def)
  apply clarsimp
  apply (clarsimp simp: example_spec_def)
  by (clarsimp simp: opt_cap_def slots_of_def obj_defs
                        object_slots_def object_size_bits_def
                        new_cap_map_def empty_cap_map_def frame_cap_not_cnode
                        empty_irq_node_def new_irq_node_def
                 split: if_split_asm
       | drule (1) cdl_cnode_caps_new_cnode_cnode_cap)+ (* Takes 20 seconds. *)

lemma well_formed_cap_to_non_empty_pt_example:
  "cdl_objects example_spec obj_id = Some obj \<Longrightarrow>
    well_formed_cap_to_non_empty_pt example_spec obj_id obj"
  apply (clarsimp simp: well_formed_cap_to_non_empty_pt_def pt_at_example_spec)
  apply (rule exI [where x=pd_a_id])
  apply (clarsimp simp: well_formed_cap_to_non_empty_pt_def example_spec_def is_pt_def
                        object_at_def opt_cap_def slots_of_def object_slots_def
                        obj_defs new_cap_map_def is_pd_def empty_cap_map_def
              split: if_split_asm)
  done

lemma well_formed_vspace_example:
  "cdl_objects example_spec obj_id = Some obj
  \<Longrightarrow> well_formed_vspace example_spec obj_id obj"
  apply (clarsimp simp: well_formed_vspace_def well_formed_cap_to_non_empty_pt_example)
  apply (clarsimp simp: example_spec_def is_pt_def is_pd_def object_slots_def empty_cap_map_def
                        new_irq_node_def
                 split: if_split_asm)
    apply (fastforce simp: cap_type_def is_fake_vm_cap_def obj_defs new_cap_map_def small_section_size_def
                    split: if_split_asm)
   apply (clarsimp simp: obj_defs new_cap_map_def cap_type_def small_frame_size_def
                         is_fake_vm_cap_def is_fake_pt_cap_simps small_section_size_def
                  split: if_split_asm)
  apply (clarsimp simp: obj_defs new_cap_map_def cap_type_def small_frame_size_def
                        is_fake_vm_cap_def is_fake_pt_cap_simps small_section_size_def
                 split: if_split_asm)
  done

lemma well_formed_irqhandler_caps_unique_example_spec:
  "well_formed_irqhandler_caps_unique example_spec"
  apply (clarsimp simp: well_formed_irqhandler_caps_unique_def)
  apply (drule (1) irq_handler_cap_example_spec)+
  by (clarsimp simp: example_spec_def opt_cap_def slots_of_def
                        object_slots_def obj_defs
                        new_cnode_def new_cap_map_def
                 split: if_split_asm)

lemma ucast_0xFE:
  "(ucast :: 8 word \<Rightarrow> 32 word) irq = 0xFE \<Longrightarrow> irq = 0xFE"
  by (rule ucast_up_inj, simp+)

lemma ucast_4:
  "(ucast :: 10 word \<Rightarrow> 32 word) irq = 4 \<Longrightarrow> irq = 4"
  by (rule ucast_up_inj, simp+)

lemma rangeD:
  "\<lbrakk>range f = A; f x = y\<rbrakk> \<Longrightarrow> y \<in> A"
  by (fastforce simp: image_def)

lemma slots_of_example_irq_node:
  "\<lbrakk>slots_of (example_irq_node irq) example_spec 0 = Some cap;
    cap \<noteq> NullCap\<rbrakk>
  \<Longrightarrow> (irq = 4)"
  apply (frule (1) slots_of_example_spec_obj_ids)
  apply (insert range_example_irq_node)
  apply (erule disjE, drule (1) rangeD, simp add: onehundred_not_le_one)+
  apply (clarsimp simp: example_irq_node_def ucast_4)
  done

lemma bound_irqs_example_spec [simp]:
  "bound_irqs example_spec = {4}"
  apply (clarsimp simp: bound_irqs_def)
  apply rule
   apply clarsimp
   apply (erule (1) slots_of_example_irq_node)
  apply (clarsimp simp: example_spec_def slots_of_def
                        object_slots_def new_irq_node_def)
  done

lemma well_formed_irqhandler_caps_example_spec:
  "well_formed_irqhandler_caps example_spec"
  apply (clarsimp simp: well_formed_irqhandler_caps_def)
  apply (rule exI [where x=cnode_a2_id])
  apply (rule exI [where x=12])
  apply (rule exI [where x="IrqHandlerCap 4"])
  apply (clarsimp simp: object_slots_def cnode_a2_def new_cnode_def new_cap_map_def)
  done

lemma rangeI:
  "f x = a \<Longrightarrow> a \<in> range f"
  by auto

lemma well_formed_irq_table_example_spec:
  "well_formed_irq_table example_spec"
  apply (clarsimp simp: well_formed_irq_table_def)
  apply (rule conjI)
   apply (clarsimp simp: example_irq_node_def)
   apply (clarsimp simp: inj_on_def ucast_up_inj)
  apply (clarsimp simp: irq_nodes_example_spec)
  apply (rule subset_antisym)
   apply (clarsimp simp: example_spec_def)
   apply (metis example_irq_node_simps)
  apply clarsimp
  apply (clarsimp simp: example_spec_def split: if_split_asm,
         (drule rangeI [where f=example_irq_node],
          simp add: range_example_irq_node onehundred_not_le_one)+)
  done

lemma well_formed_tcb_example_spec:
  "cdl_objects example_spec obj_id = Some obj \<Longrightarrow>
   well_formed_tcb example_spec obj_id obj"
   apply (case_tac "obj_id = tcb_a_id")
    apply (cut_tac obj_id = tcb_a_id in well_formed_tcb_a)
    apply (clarsimp simp: example_spec_def split: if_split_asm)
   apply (case_tac "obj_id = tcb_b_id")
    apply (cut_tac obj_id = tcb_b_id in well_formed_tcb_b)
    apply (clarsimp simp: example_spec_def split: if_split_asm)
   by (clarsimp simp: example_spec_def well_formed_tcb_def is_tcb_def
                         empty_irq_node_def new_irq_node_def
                  split: if_split_asm)

lemma well_formed_irq_node_example_spec:
  "cdl_objects example_spec obj_id = Some obj \<Longrightarrow>
   well_formed_irq_node example_spec obj_id obj"
  apply (clarsimp simp: well_formed_irq_node_def irq_nodes_example_spec)
  apply (clarsimp simp: example_spec_def object_slots_def empty_irq_node_def new_irq_node_def
                        empty_cnode_def empty_cap_map_def dom_def
                        is_default_cap_def default_cap_def onehundred_not_le_one
                        split: if_split_asm)
  done

lemma well_formed_example:
  "well_formed example_spec"
  apply (clarsimp simp: well_formed_def)
  apply (intro conjI)
       apply (rule well_formed_orig_caps_unique_example)
      apply (rule well_formed_irqhandler_caps_unique_example_spec)
     apply (rule well_formed_fake_pt_caps_unique_example)
    apply (rule well_formed_irqhandler_caps_example_spec)
   apply (rule well_formed_irq_table_example_spec)
  apply (clarsimp split: option.splits, rename_tac obj)
  apply (clarsimp simp: well_formed_caps_example well_formed_cap_to_object_example
                        well_formed_orig_caps_unique_example)
  apply (rule conjI)
   apply (fact well_formed_tcb_example_spec)
  apply (rule conjI)
   apply (fact well_formed_vspace_example)
  apply (rule conjI)
   apply (fact well_formed_irq_node_example_spec)
  apply (clarsimp simp: cnode_at_example_spec)
  by (auto simp: example_spec_def object_size_bits_def object_default_state_def2
                    pd_size_def word_bits_def empty_cnode_def is_cnode_def
                    object_slots_def empty_cap_map_def tcb_slot_defs slots_of_def
                    default_tcb_def obj_defs cap_at_def opt_cap_def
                    small_frame_size_def small_section_size_def pt_size_def
                    new_cnode_def new_cap_map_def empty_irq_node_def
                    new_irq_node_def
             split: if_split_asm)

end

end


(*  Title:      HOL/Auth/n_german_lemma_inv__28_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__28_on_rules imports n_german_lemma_on_inv__28
begin
section{*All lemmas on causal relation between inv__28*}
lemma lemma_inv__28_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__28  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  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)"
  apply (cut_tac b1, auto) 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__28) done
    }

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

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

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

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

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

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

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__28) 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__28) 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__28) 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__28) 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__28) 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__28) 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__28) done
    }

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

end


(*  Title:      HOL/Auth/n_g2kAbsAfter_lemma_inv__77_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_g2kAbsAfter Protocol Case Study*}

theory n_g2kAbsAfter_lemma_inv__77_on_rules imports n_g2kAbsAfter_lemma_on_inv__77
begin
section{*All lemmas on causal relation between inv__77*}
lemma lemma_inv__77_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__77  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__77) done
    }

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

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__77) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__77) done
    }

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

end