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

theory Helpers_SD
imports
  "Lookups_D"
  "../../lib/SimpStrategy"
  "../../lib/LemmaBucket"
  "../../lib/sep_algebra/Map_Extra"
begin

(* Functions we need from capDL, but can't have yet (until we change capDL).
 * Maybe they aren't actually needed for the proof.
 * (If capDL doesn't have them, then we might not need them to prove conformance.)
 *)

consts tcb_priority :: "cdl_tcb \<Rightarrow> word8 \<times> word8"
consts tcb_ip :: "cdl_tcb \<Rightarrow> word32"
consts tcb_sp :: "cdl_tcb \<Rightarrow> word32"
consts opt_vmattribs :: "cdl_object \<Rightarrow> cdl_raw_vmattrs option"

(* We don't need to know anything about this except that it isn't 0. *)
definition tcb_ipc_buffer_address :: "cdl_tcb \<Rightarrow> word32"
where "tcb_ipc_buffer_address tcb = 1"

lemma tcb_ipc_buffer_address_non_zero:
  "tcb_ipc_buffer_address tcb \<noteq> 0"
  by (clarsimp simp: tcb_ipc_buffer_address_def)

(* Helper funtions. These possibly should be moved somewhere else. *)

(***************************************************
 * Generic Isabelle lemmas. Could be moved to lib. *
 ***************************************************)
lemma map_upd_nonempty' [simp]: "empty \<noteq> t(k\<mapsto>x)"
  by (rule not_sym, simp)

lemma insert_unit_set [simp]:
  "insert () A = UNIV"
  by auto

lemma restrict_map_not_empty [simp]:
  "f p = Some v \<Longrightarrow> f |` {p} \<noteq> empty"
  "f p = Some v \<Longrightarrow> empty \<noteq> f |` {p}"
  by (clarsimp simp: restrict_map_def fun_eq_iff split: if_split_asm)+

(* This lets us compose a total and a partial function in the obvious manner. *)
definition
  map_comp' :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'a \<rightharpoonup> 'c"  (infixl "o'_M" 55) where
  "f o_M g = (\<lambda>k. case g k of None \<Rightarrow> None | Some v \<Rightarrow> Some (f v))"

notation (xsymbols)
  map_comp'  (infixl "\<circ>\<^sub>M" 55)

lemma map_comp'_apply [simp]: "(f \<circ>\<^sub>M g) x = case_option None (\<lambda>x. Some (f x)) (g x)"
  by (clarsimp simp: map_comp'_def)

lemma map_comp'_empty [simp]:
  "m \<circ>\<^sub>M empty = empty"
  by auto

lemma dom_map_comp' [simp]:
  "dom (f \<circ>\<^sub>M m) = dom m"
  by (clarsimp simp: dom_def split: option.splits)

lemma restrict_map_comp' [simp]:
  "f \<circ>\<^sub>M g |` S = (f \<circ>\<^sub>M g) |` S"
  by (rule ext, clarsimp simp: map_comp'_def restrict_map_def)

(**************************
 * Rules about intervals. *
 **************************)

lemma nat_list_not_UNIV [simp]:
  "set (xs::nat list) \<noteq> UNIV"
  by (metis finite'_code(1) Cardinality.finite'_def infinite_UNIV_nat)

(***********************************
 * End of generic Isabelle lemmas. *
 ***********************************)

(*************************************
 * Rules that should go in MapExtra. *
 *************************************)

lemma map_add_self:
  "m ++ m = m"
  by (auto simp add:map_add_def split:option.splits)

(* This lemma is strictly weaker than restrict_map_disj. *)
lemma restrict_map_disj':
  "S \<inter> T = {} \<Longrightarrow> h |` S \<bottom> h' |` T"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_add_restrict_comm:
  "S \<inter> T = {} \<Longrightarrow> h |` S ++ h' |` T = h' |` T ++ h |` S"
  apply (drule restrict_map_disj')
  apply (erule map_add_com)
  done

lemma restrict_map_not_self_UNIV [simp]:
  "h |` (UNIV - dom h) = empty"
  by (rule ext, clarsimp simp: restrict_map_def)

lemma map_add_emptyE [elim!]:
  "\<lbrakk>a ++ b = empty; \<lbrakk>a = empty; b = empty\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (metis map_add_None)

lemma restrict_map_sub_singleton [simp]:
  "s \<noteq> t \<Longrightarrow> h `- {t} |` {s} = h |` {s}"
  by (rule ext)(clarsimp simp: restrict_map_def sub_restrict_map_def)

lemma restrict_map_sub_add': "h `- S ++ h |` S = h"
  by (fastforce simp: sub_restrict_map_def map_add_def
               split: option.splits)

lemma map_add_restrict_singleton:
  "s \<noteq> t \<Longrightarrow> (m |` {s} ++ m' |` {t}) |` {s} = m |` {s}"
  apply (rule ext)
  apply (clarsimp simp: map_add_def restrict_map_def split: option.splits)
  done

lemma map_add_restrict_singleton':
  "s \<noteq> t \<Longrightarrow> (m |` {s} ++ m' |` {t}) |` {t} = m' |` {t}"
  apply (rule ext)
  apply (clarsimp simp: map_add_def restrict_map_def split: option.splits)
  done

(********************************************
 * End of rules that should go in MapExtra. *
 ********************************************)

(**********************************************************
 * CapDL specific lemmas, that could be moved into capDL. *
 * These have nothing to do with the separation logic.    *
 **********************************************************)

definition
  all_caps :: "cdl_state \<Rightarrow> cdl_cap set"
where
"all_caps spec = {cap. \<exists>obj_id slot. opt_cap (obj_id,slot) spec = Some cap \<and> cap \<noteq> NullCap}"

lemma all_capsE [elim!]:
  "\<lbrakk>opt_cap (obj_id, slot) spec = Some cap; cap \<noteq> NullCap\<rbrakk> \<Longrightarrow> cap \<in> all_caps spec"
  "\<lbrakk>opt_cap cap_ref spec = Some cap; cap \<noteq> NullCap\<rbrakk> \<Longrightarrow> cap \<in> all_caps spec"
  apply (clarsimp simp: all_caps_def|fast)+
  by (metis surj_pair)

lemma default_tcb_slots:
 "[0 ..< tcb_pending_op_slot] = [0,1,2,3,4]"
 "[0 ..< 5] = [0,1,2,3,4]"
 "[0 .e. tcb_pending_op_slot] = [0,1,2,3,4,5]"
 "[0 .e. (5::nat)] = [0,1,2,3,4,5]"
 "[0..< 6] = [0,1,2,3,4,5]"
 "[0..< 7] = [0,1,2,3,4,5,6]"
  by (clarsimp simp: tcb_pending_op_slot_def upt_rec)+

definition "update_tcb_fault_endpoint fault_ep = cdl_tcb_fault_endpoint_update (\<lambda>_. fault_ep)"

lemma update_tcb_fault_endpoint_id [simp]:
  "cdl_tcb_fault_endpoint tcb = fault_ep
  \<Longrightarrow> update_tcb_fault_endpoint fault_ep tcb = tcb"
  by (clarsimp simp: update_tcb_fault_endpoint_def)

definition tcb_has_fault :: "cdl_object \<Rightarrow> bool"
where
  "tcb_has_fault obj \<equiv> case obj of Tcb tcb \<Rightarrow> cdl_tcb_has_fault tcb | _ \<Rightarrow> False"

definition tcb_domain :: "cdl_object \<Rightarrow> word8"
where
  "tcb_domain obj \<equiv> case obj of Tcb tcb \<Rightarrow> cdl_tcb_domain tcb | _ \<Rightarrow> 0"

definition update_cap_object :: "cdl_object_id \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
  "update_cap_object obj_id cap \<equiv> case cap of
    IOPageTableCap _ \<Rightarrow> IOPageTableCap obj_id
  | IOSpaceCap _ \<Rightarrow> IOSpaceCap obj_id
  | IOPortsCap _ f2 \<Rightarrow> IOPortsCap obj_id f2
  | AsidPoolCap _ f2 \<Rightarrow> AsidPoolCap obj_id f2
  | PageDirectoryCap _ f2 f3 \<Rightarrow> PageDirectoryCap obj_id f2 f3
  | PageTableCap _ f2 f3 \<Rightarrow> PageTableCap obj_id f2 f3
  | FrameCap dev _ f2 f3 f4 f5 \<Rightarrow> FrameCap dev obj_id f2 f3 f4 f5
  | TcbCap _ \<Rightarrow> TcbCap obj_id
  | CNodeCap _ f2 f3 f4 \<Rightarrow> CNodeCap obj_id f2 f3 f4
  | MasterReplyCap _ \<Rightarrow> MasterReplyCap obj_id
  | ReplyCap _ \<Rightarrow> ReplyCap obj_id
  | NotificationCap _ f2 f3 \<Rightarrow> NotificationCap obj_id f2 f3
  | EndpointCap _ f2 f3 \<Rightarrow> EndpointCap obj_id f2 f3
  | ZombieCap _ \<Rightarrow> ZombieCap obj_id
  | PendingSyncSendCap _ f2 f3 f4 f5 \<Rightarrow> PendingSyncSendCap obj_id f2 f3 f4 f5
  | PendingSyncRecvCap _ f2 \<Rightarrow> PendingSyncRecvCap obj_id f2
  | PendingNtfnRecvCap _ \<Rightarrow> PendingNtfnRecvCap obj_id
  | BoundNotificationCap _ \<Rightarrow> BoundNotificationCap obj_id
  | _ \<Rightarrow> cap"

definition update_cap_objects :: "cdl_object_id set \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
    "update_cap_objects obj_ids cap \<equiv> case cap of
    UntypedCap d _ a \<Rightarrow> UntypedCap d obj_ids a
  | _ \<Rightarrow> cap"

lemma slots_of_cdl_objects:
  "slots_of obj_id s slot = Some cap \<Longrightarrow> \<exists>obj. cdl_objects s obj_id = Some obj"
  by (clarsimp simp: slots_of_def opt_object_def split: option.splits)

lemma opt_cap_cdl_objects:
  "opt_cap (obj_id, slot) s = Some cap \<Longrightarrow> \<exists>obj. cdl_objects s obj_id = Some obj"
  by (clarsimp simp: opt_cap_def slots_of_cdl_objects)

lemma object_slots_slots_of:
  "\<lbrakk>slots_of obj_id spec slot = Some cap; cdl_objects spec obj_id = Some obj\<rbrakk>
  \<Longrightarrow> object_slots obj slot = Some cap"
  by (clarsimp simp: slots_of_def opt_object_def)

lemma object_slots_opt_cap:
  "\<lbrakk>opt_cap cap_ref spec = Some cap; cdl_objects spec obj_id = Some obj; cap_ref = (obj_id, slot)\<rbrakk>
  \<Longrightarrow> object_slots obj slot = Some cap"
  by (clarsimp simp: opt_cap_def object_slots_slots_of split: prod.split_asm)+

lemma object_slots_opt_capI:
  "\<lbrakk>opt_cap (obj_id, slot) spec = Some cap; cdl_objects spec obj_id = Some obj\<rbrakk>
  \<Longrightarrow> object_slots obj slot = Some cap"
  by (clarsimp simp: opt_cap_def object_slots_slots_of split: prod.split_asm)

lemma object_slots_opt_capD:
  "\<lbrakk>opt_cap cap_ref spec = Some cap; cdl_objects spec (fst cap_ref) = Some obj\<rbrakk>
  \<Longrightarrow> object_slots obj (snd cap_ref) = Some cap"
  by (clarsimp simp: opt_cap_def object_slots_slots_of split: prod.split_asm)

lemma object_slots_has_slots:
  "object_slots obj \<noteq> empty \<Longrightarrow> has_slots obj"
  by (clarsimp simp: has_slots_def object_slots_def split: cdl_object.splits)

lemma opt_object_dom_cdl_objects [elim!]:
  "opt_object obj_id spec = Some obj \<Longrightarrow> obj_id \<in> dom (cdl_objects spec)"
  "opt_object obj_id spec = Some obj \<Longrightarrow> \<exists>slot. cdl_objects spec obj_id = Some slot"
  by (clarsimp simp: opt_object_def)+

lemma slots_of_dom_cdl_objects [elim!]:
  "slots_of obj_id spec slot = Some cap \<Longrightarrow> obj_id \<in> dom (cdl_objects spec)"
  "slots_of obj_id spec slot = Some cap \<Longrightarrow> \<exists>slot. cdl_objects spec obj_id = Some slot"
 by (clarsimp simp: slots_of_def split:option.splits)+

lemma opt_cap_dom_cdl_objects [elim]:
  "opt_cap (obj_id, slot) spec = Some cap \<Longrightarrow> obj_id \<in> dom (cdl_objects spec)"
  "opt_cap cap_ref spec = Some cap \<Longrightarrow> fst cap_ref \<in> dom (cdl_objects spec)"
  by (clarsimp simp: opt_cap_def split: prod.split_asm)+

lemma opt_cap_dom_slots_of [elim]:
  "opt_cap (obj_id, slot) spec = Some cap \<Longrightarrow> slot \<in> dom (slots_of obj_id spec)"
  "opt_cap cap_ref spec = Some cap \<Longrightarrow> snd cap_ref \<in> dom (slots_of (fst cap_ref) spec)"
  by (clarsimp simp: opt_cap_def split: prod.split_asm)+

(*
 * Untyped cap rules.
 *)

definition
  well_formed_untyped_cap :: "cdl_cap \<Rightarrow> bool"
where
  "well_formed_untyped_cap cap \<equiv> case cap of
    UntypedCap _ cover_ids available_ids \<Rightarrow> available_ids \<subseteq> cover_ids
  | _ \<Rightarrow> True"

lemma cap_free_ids_simps:
  "cap_free_ids (UntypedCap d cover_ids available_ids) = available_ids"
  by (clarsimp simp: cap_free_ids_def)

lemma cap_objects_remove_free_ids [simp]:
  "cap_objects (remove_free_ids cap obj_ids) = cap_objects cap"
  by (clarsimp simp: cap_objects_def remove_free_ids_def
              split: cdl_cap.splits)

lemma cap_free_ids_remove_free_ids:
  "cap_free_ids (remove_free_ids cap obj_ids) = cap_free_ids cap - obj_ids"
  by (clarsimp simp: remove_free_ids_def cap_free_ids_def
              split: cdl_cap.splits)

lemma cap_type_remove_free_ids [simp]:
  "cap_type (remove_free_ids cap obj_ids) = cap_type cap"
  by (clarsimp simp: cap_type_def remove_free_ids_def
              split: cdl_cap.splits)

definition
  is_device_cap :: "cdl_cap \<Rightarrow> bool"
where  "is_device_cap cap \<equiv> case cap of
   (UntypedCap dev cover_ids available_ids) \<Rightarrow> dev
   | (FrameCap dev _ _ _ _ _) \<Rightarrow> dev
   | _ \<Rightarrow> False"

lemmas is_device_cap_simps[simp] = is_device_cap_def[split_simps cdl_cap.split]

lemma remove_free_ids_simps:
  "\<lbrakk>is_untyped_cap cap; available_ids \<subseteq> cap_free_ids cap\<rbrakk>
  \<Longrightarrow> remove_free_ids cap (cap_free_ids cap - available_ids)
    = UntypedCap (is_device_cap cap) (cap_objects cap) available_ids"
  by (auto simp: remove_free_ids_def cap_free_ids_def cap_type_def
          split: cdl_cap.splits)

definition
  is_full_untyped_cap :: "cdl_cap \<Rightarrow> bool"
where
  "is_full_untyped_cap cap \<equiv> case cap of
     UntypedCap dev cover_ids available_ids \<Rightarrow> cover_ids = available_ids
   | _ \<Rightarrow> False"

lemma is_full_untyped_cap_is_untyped_cap:
  "is_full_untyped_cap cap \<Longrightarrow> is_untyped_cap cap"
  by (clarsimp simp: is_full_untyped_cap_def split: cdl_cap.splits)

lemma is_full_untyped_cap_simps:
  "is_full_untyped_cap cap \<Longrightarrow> cap_objects cap = cap_free_ids cap"
  by (auto simp: is_full_untyped_cap_def cap_free_ids_def
          split: cdl_cap.splits)

lemma is_full_untyped_cap_eq:
  "is_untyped_cap cap
  \<Longrightarrow> is_full_untyped_cap cap = (cap_objects cap = cap_free_ids cap)"
  by (auto simp: is_full_untyped_cap_def cap_free_ids_def
                 cap_objects_def cap_type_def
          split: cdl_cap.splits)

lemma well_formed_untyped_cap_remove_free_ids:
  "well_formed_untyped_cap cap
  \<Longrightarrow> well_formed_untyped_cap (remove_free_ids cap obj_ids)"
  by (auto simp: well_formed_untyped_cap_def remove_free_ids_def
          split: cdl_cap.splits)

lemma well_formed_untyped_cap_simps:
  "is_untyped_cap cap
  \<Longrightarrow> well_formed_untyped_cap cap = (cap_free_ids cap \<subseteq> cap_objects cap)"
  by (clarsimp simp: well_formed_untyped_cap_def cap_free_ids_def
                     cap_objects_def cap_type_def
              split: cdl_cap.splits)

definition
  some_nat :: "nat option \<Rightarrow> nat"
where
  "some_nat n \<equiv> case n of Some n \<Rightarrow> n | None \<Rightarrow> 0"

lemma some_nat_Some [simp]:
  "some_nat (Some n) = n"
  by (simp add: some_nat_def)

lemma some_nat_None [simp]:
  "some_nat None = 0"
  by (simp add: some_nat_def)

definition
  is_untyped :: "cdl_object \<Rightarrow> bool" where
 "is_untyped v \<equiv> case v of Untyped \<Rightarrow> True | _ \<Rightarrow> False"

definition
  is_ep :: "cdl_object \<Rightarrow> bool" where
 "is_ep v \<equiv> case v of Endpoint \<Rightarrow> True | _ \<Rightarrow> False"

definition
  is_ntfn :: "cdl_object \<Rightarrow> bool" where
 "is_ntfn v \<equiv> case v of Notification \<Rightarrow> True | _ \<Rightarrow> False"

definition
  is_tcb :: "cdl_object \<Rightarrow> bool" where
 "is_tcb v \<equiv> case v of Tcb _ \<Rightarrow> True | _ \<Rightarrow> False"

definition
  is_cnode :: "cdl_object \<Rightarrow> bool" where
 "is_cnode v \<equiv> case v of CNode _ \<Rightarrow> True | _ \<Rightarrow> False"

definition
  is_irq_node :: "cdl_object \<Rightarrow> bool" where
 "is_irq_node v \<equiv> case v of IRQNode _ \<Rightarrow> True | _ \<Rightarrow> False"

definition
  is_asidpool :: "cdl_object \<Rightarrow> bool" where
 "is_asidpool v \<equiv> case v of AsidPool _ \<Rightarrow> True | _ \<Rightarrow> False"

definition
  is_pt :: "cdl_object \<Rightarrow> bool" where
 "is_pt v \<equiv> case v of PageTable _ \<Rightarrow> True | _ \<Rightarrow> False"

definition
  is_pd :: "cdl_object \<Rightarrow> bool" where
 "is_pd v \<equiv> case v of PageDirectory _ \<Rightarrow> True | _ \<Rightarrow> False"

definition
  is_frame :: "cdl_object \<Rightarrow> bool" where
 "is_frame v \<equiv> case v of Frame _ \<Rightarrow> True | _ \<Rightarrow> False"

definition
  object_domain :: "cdl_object \<Rightarrow> word8"
where
  "object_domain obj \<equiv> case obj of
      Tcb tcb \<Rightarrow> cdl_tcb_domain tcb
    | _ \<Rightarrow> 0"

lemma is_object_simps [simp]:
  "is_untyped Untyped"
  "is_ep Endpoint"
  "is_ntfn Notification"
  "is_tcb (Tcb tcb)"
  "is_cnode (CNode c)"
  "is_asidpool (AsidPool a)"
  "is_pd (PageDirectory pd)"
  "is_pt (PageTable pt)"
  "is_frame (Frame f)"
  by (clarsimp simp: is_untyped_def is_ep_def is_ntfn_def is_tcb_def is_cnode_def
                     is_asidpool_def is_pt_def is_pd_def is_frame_def)+

(* These sizes are needed for ARM *)
definition pt_size :: nat
where
  "pt_size = 8"

definition pd_size :: nat
where
  "pd_size = 12"

definition small_frame_size :: nat
where
  "small_frame_size = 12"

definition
  object_size_bits :: "cdl_object \<Rightarrow> cdl_size_bits"
where
  "object_size_bits obj \<equiv> case obj of
      CNode cnode \<Rightarrow> cdl_cnode_size_bits cnode
    | AsidPool ap \<Rightarrow> asid_low_bits
    | Frame frame \<Rightarrow> cdl_frame_size_bits frame
    | PageTable cdl_page_table \<Rightarrow> pt_size
    | PageDirectory cdl_page_directory \<Rightarrow> pd_size
    | _ \<Rightarrow> 0"

lemma object_size_bits_default_tcb [simp]:
  "object_size_bits (Tcb (default_tcb domain)) = 0"
  by (clarsimp simp: object_size_bits_def default_tcb_def)

lemma object_size_bits_empty_cnode [simp]:
  "object_size_bits (CNode (empty_cnode sz)) = sz"
  by (clarsimp simp: object_size_bits_def empty_cnode_def)

definition
  object_at_pointer_size_bits :: "cdl_state \<Rightarrow> cdl_object_id \<Rightarrow> cdl_size_bits"
where
  "object_at_pointer_size_bits spec obj_id \<equiv>
   some_nat (option_map object_size_bits (cdl_objects spec obj_id))"

lemma object_at_pointer_size_bits_simp [simp]:
  "cdl_objects spec obj_id = Some object
  \<Longrightarrow> object_at_pointer_size_bits spec obj_id = object_size_bits object"
  by (simp add: object_at_pointer_size_bits_def)

definition
  object_at :: "(cdl_object \<Rightarrow> bool) \<Rightarrow> cdl_object_id \<Rightarrow> cdl_state \<Rightarrow> bool"
where
  "object_at P obj_id s \<equiv> \<exists>object. cdl_objects s obj_id = Some object \<and> P object"

abbreviation
  "untyped_at \<equiv> object_at is_untyped"
abbreviation
  "ep_at \<equiv> object_at is_ep"
abbreviation
  "ntfn_at \<equiv> object_at is_ntfn"
abbreviation
  "tcb_at \<equiv> object_at is_tcb"
abbreviation
  "cnode_at \<equiv> object_at is_cnode"
abbreviation
  "irq_node_at \<equiv> object_at is_irq_node"
abbreviation
  "asidpool_at \<equiv> object_at is_asidpool"
abbreviation
  "pt_at \<equiv> object_at is_pt"
abbreviation
  "pd_at \<equiv> object_at is_pd"
abbreviation
  "frame_at \<equiv> object_at is_frame"

(* Threads that are waiting to run. *)
definition
  is_waiting_thread :: "cdl_object \<Rightarrow> bool"
where
  "is_waiting_thread obj \<equiv> is_tcb obj \<and> object_slots obj tcb_pending_op_slot = Some RestartCap"

abbreviation
  "is_waiting_thread_at \<equiv> object_at is_waiting_thread"

definition
  irq_nodes :: "cdl_state \<Rightarrow> cdl_object_id set"
where
  "irq_nodes \<equiv> \<lambda>s. {obj_id. irq_node_at obj_id s}"

definition
  bound_irqs :: "cdl_state \<Rightarrow> cdl_irq set"
where
  "bound_irqs \<equiv> \<lambda>s. {irq. \<exists>cap. slots_of (cdl_irq_node s irq) s 0 = Some cap \<and> cap \<noteq> NullCap}"

definition
  bound_irq_list :: "cdl_state \<Rightarrow> cdl_irq list"
where
  "bound_irq_list \<equiv> \<lambda>s. sorted_list_of_set (bound_irqs s)"

definition
  used_irqs :: "cdl_state \<Rightarrow> cdl_irq set"
where
  "used_irqs \<equiv> \<lambda>s. {irq. \<exists>cap. cap \<in> all_caps s \<and> is_irqhandler_cap cap \<and> cap_irq cap = irq}"

definition
  used_irq_list :: "cdl_state \<Rightarrow> cdl_irq list"
where
  "used_irq_list \<equiv> \<lambda>s. sorted_list_of_set (used_irqs s)"

definition
  used_irq_nodes :: "cdl_state \<Rightarrow> cdl_object_id set"
where
  "used_irq_nodes \<equiv> \<lambda>s. cdl_irq_node s ` used_irqs s"

(* Distinctions between "real objects" and IRQ objects. *)
definition
  "real_object_at \<equiv> \<lambda> obj_id s. obj_id \<in> dom (cdl_objects s) \<and> obj_id \<notin> irq_nodes s"

(* Agregate object types. *)
abbreviation
  "table_at \<equiv> \<lambda>obj_id s. pt_at obj_id s \<or> pd_at obj_id s"
abbreviation
  "capless_at \<equiv> \<lambda>obj_id s. untyped_at obj_id s \<or> ep_at obj_id s \<or> ntfn_at obj_id s \<or> frame_at obj_id s"
abbreviation
  "cnode_or_tcb_at \<equiv> \<lambda>obj_id spec. cnode_at obj_id spec \<or> tcb_at obj_id spec"
abbreviation
  "memory_object_at \<equiv> \<lambda>obj_id spec. pt_at obj_id spec \<or> pd_at obj_id spec \<or> frame_at obj_id spec"

lemma capless_at_def2:
  "capless_at p s = object_at (\<lambda>obj. \<not> (has_slots obj)) p s"
  apply (clarsimp simp: has_slots_def object_at_def)
  apply (fastforce simp: is_untyped_def is_ep_def is_ntfn_def is_frame_def
                 split: cdl_object.splits)
  done

abbreviation
  "ko_at k \<equiv> object_at (op = k)"

lemma ko_at_tcb_at:
  "ko_at (Tcb t) p s \<Longrightarrow> tcb_at p s"
  by (simp add: object_at_def is_tcb_def)

abbreviation
  "type_at T \<equiv> object_at (\<lambda>ob. object_type ob = T)"

lemma length_sorted_list_of_set [simp]:
  "finite A \<Longrightarrow> length (sorted_list_of_set A) = card A"
  by (metis sorted_list_of_set distinct_card)

lemma length_used_irq_list [simp]:
  "length (used_irq_list spec) = card (used_irqs spec)"
  by (clarsimp simp: used_irq_list_def)

lemma distinct_used_irq_list [simp]:
  "distinct (used_irq_list spec)"
  by (simp add: used_irq_list_def)

lemma set_used_irq_list [simp]:
  "set (used_irq_list spec) = used_irqs spec"
  by (simp add: used_irq_list_def)

lemma object_type_is_object:
  "is_untyped obj  = (object_type obj = UntypedType)"
  "is_ep obj       = (object_type obj = EndpointType)"
  "is_ntfn obj      = (object_type obj = NotificationType)"
  "is_tcb obj      = (object_type obj = TcbType)"
  "is_cnode obj    = (object_type obj = CNodeType)"
  "is_irq_node obj = (object_type obj = IRQNodeType)"
  "is_asidpool obj = (object_type obj = AsidPoolType)"
  "is_pt obj       = (object_type obj = PageTableType)"
  "is_pd obj       = (object_type obj = PageDirectoryType)"
  "is_frame obj    = (\<exists>n. object_type obj = FrameType n)"
  by (simp_all add: object_type_def is_untyped_def is_ep_def is_ntfn_def is_tcb_def
                    is_cnode_def is_irq_node_def is_asidpool_def is_pt_def is_pd_def is_frame_def
             split: cdl_object.splits)

lemma object_at_object_type:
  "\<lbrakk>cdl_objects spec obj_id = Some obj; untyped_at obj_id spec\<rbrakk> \<Longrightarrow> object_type obj = UntypedType"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; ep_at obj_id spec\<rbrakk> \<Longrightarrow> object_type obj = EndpointType"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; ntfn_at obj_id spec\<rbrakk> \<Longrightarrow> object_type obj = NotificationType"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; tcb_at obj_id spec\<rbrakk> \<Longrightarrow> object_type obj = TcbType"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; cnode_at obj_id spec\<rbrakk> \<Longrightarrow> object_type obj = CNodeType"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; irq_node_at obj_id spec\<rbrakk> \<Longrightarrow> object_type obj = IRQNodeType"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; asidpool_at obj_id spec\<rbrakk> \<Longrightarrow> object_type obj = AsidPoolType"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; pt_at obj_id spec\<rbrakk> \<Longrightarrow> object_type obj = PageTableType"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; pd_at obj_id spec\<rbrakk> \<Longrightarrow> object_type obj = PageDirectoryType"
  by (simp_all add: object_at_def object_type_is_object)

lemma object_type_object_at:
  "\<lbrakk>cdl_objects spec obj_id = Some obj; object_type obj = UntypedType\<rbrakk> \<Longrightarrow> untyped_at obj_id spec"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; object_type obj = EndpointType\<rbrakk> \<Longrightarrow> ep_at obj_id spec"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; object_type obj = NotificationType\<rbrakk> \<Longrightarrow> ntfn_at obj_id spec"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; object_type obj = TcbType\<rbrakk> \<Longrightarrow> tcb_at obj_id spec"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; object_type obj = CNodeType\<rbrakk> \<Longrightarrow> cnode_at obj_id spec"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; object_type obj = IRQNodeType\<rbrakk> \<Longrightarrow> irq_node_at obj_id spec"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; object_type obj = AsidPoolType\<rbrakk> \<Longrightarrow> asidpool_at obj_id spec"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; object_type obj = PageTableType\<rbrakk> \<Longrightarrow> pt_at obj_id spec"
  "\<lbrakk>cdl_objects spec obj_id = Some obj; object_type obj = PageDirectoryType\<rbrakk> \<Longrightarrow> pd_at obj_id spec"
  by (simp_all add: object_at_def object_type_is_object)

lemma set_object_type [simp]:
  "{obj_id \<in> dom (cdl_objects spec). object_at P obj_id spec} = {obj_id. object_at P obj_id spec}"
  "{obj_id \<in> dom (cdl_objects spec). table_at obj_id spec} = {obj_id. table_at obj_id spec}"
  "{obj_id \<in> dom (cdl_objects spec). capless_at obj_id spec} = {obj_id. capless_at obj_id spec}"
  "{obj_id \<in> dom (cdl_objects spec). cnode_or_tcb_at obj_id spec} = {obj_id. cnode_or_tcb_at obj_id spec}"
  "{obj_id \<in> dom (cdl_objects spec). cnode_at obj_id spec} = {obj_id. cnode_at obj_id spec}"
  "{obj_id \<in> dom (cdl_objects spec). real_object_at obj_id spec} = {obj_id. real_object_at obj_id spec}"
  by (auto simp: object_at_def real_object_at_def)

definition
  real_objects :: "cdl_state \<Rightarrow> cdl_object_id set"
where
  "real_objects \<equiv> \<lambda>s. {obj_id. real_object_at obj_id s}"

lemma cnode_or_tcb_at_simps:
  "(cnode_or_tcb_at obj_id spec \<and> cnode_at obj_id spec) = cnode_at obj_id spec"
  "(cnode_or_tcb_at obj_id spec \<and> \<not> cnode_at obj_id spec) = tcb_at obj_id spec"
  by (auto simp: object_at_def object_type_is_object)

(******************************
 * Cap types and default caps *
 ******************************)
definition cap_at :: "(cdl_cap \<Rightarrow> bool) \<Rightarrow> cdl_cap_ref \<Rightarrow> cdl_state \<Rightarrow> bool"
where
  "cap_at P ref s \<equiv> \<exists>cap. opt_cap ref s = Some cap \<and> P cap"

definition is_fake_pt_cap :: "cdl_cap \<Rightarrow> bool"
where "is_fake_pt_cap cap \<equiv> case cap of
    PageTableCap _ Fake _ \<Rightarrow> True
  | _ \<Rightarrow> False"

lemma is_fake_pt_cap_is_pt_cap [elim!]:
  "is_fake_pt_cap cap \<Longrightarrow> is_pt_cap cap"
  by (clarsimp simp: is_fake_pt_cap_def split: cdl_cap.splits)

abbreviation "pd_cap_at \<equiv> cap_at is_pd_cap"
abbreviation "pt_cap_at \<equiv> cap_at is_pt_cap"
abbreviation "fake_pt_cap_at \<equiv> cap_at is_fake_pt_cap"
abbreviation "irqhandler_cap_at \<equiv> cap_at is_irqhandler_cap"

lemma is_cnode_cap_simps:
  "is_cnode_cap (UntypedCap dev ids ids') = False"
  "is_cnode_cap (IOPageTableCap x) = False"
  "is_cnode_cap (IOSpaceCap x) = False"
  "is_cnode_cap (IOPortsCap x a) = False"
  "is_cnode_cap (AsidPoolCap x b) = False"
  "is_cnode_cap (PageDirectoryCap x c d) = False"
  "is_cnode_cap (PageTableCap x e f) = False"
  "is_cnode_cap (FrameCap dev x g h i j) = False"
  "is_cnode_cap (TcbCap x) = False"
  "is_cnode_cap (MasterReplyCap x) = False"
  "is_cnode_cap (ReplyCap x) = False"
  "is_cnode_cap (NotificationCap x m n) = False"
  "is_cnode_cap (EndpointCap x p q) = False"
  "is_cnode_cap (ZombieCap x) = False"
  "is_cnode_cap (PendingSyncSendCap x s t u v) = False"
  "is_cnode_cap (PendingSyncRecvCap x t) = False"
  "is_cnode_cap (PendingNtfnRecvCap x) = False"

  "is_cnode_cap (CNodeCap x k l sz) = True"
  by (unfold cap_type_def, simp_all split: cdl_object_type.splits)

(* This is to be rarely used. original_cap_at is what you probably want. *)
definition cap_at_has_no_parents_in_cdt :: "cdl_cap_ref \<Rightarrow> cdl_state \<Rightarrow> bool"
where
  "cap_at_has_no_parents_in_cdt cap_ref \<equiv> \<lambda>spec. opt_parent cap_ref spec = None"

(* This predicate decides which capabilities should be moved, or copied.
 * The actual definition of this function is rarely used by the initialiser,
 * only to know that IRQ Handler caps are move, and so the definition can be
 * updated if newer caps are added that need to be moved.
 *)
definition
  original_cap_at :: "cdl_cap_ref \<Rightarrow> cdl_state \<Rightarrow> bool"
where
  "original_cap_at cap_ref \<equiv> \<lambda>spec. cap_at_has_no_parents_in_cdt cap_ref spec \<or>
                                     irqhandler_cap_at cap_ref spec"

definition is_default_cap :: "cdl_cap \<Rightarrow> bool"
where
  "is_default_cap cap \<equiv>
  (\<exists>type dev. cap_type cap = Some type \<and>
   cap = default_cap type (cap_objects cap) (cnode_cap_size cap) dev) \<or>
   is_irqhandler_cap cap"

lemma default_cap_eq:
  "\<lbrakk>is_default_cap cap; is_default_cap cap';
    cap_type cap = cap_type cap'; cap_objects cap = cap_objects cap';
    cnode_cap_size cap = cnode_cap_size cap';
    cap_irq cap = cap_irq cap'; is_device_cap cap = is_device_cap cap'\<rbrakk>
  \<Longrightarrow> cap = cap'"
  by (auto simp: is_default_cap_def cap_type_def cap_irq_def default_cap_def
          split: cdl_cap.splits )

lemma cnode_cap_size_non_cnode [simp]:
  "\<not> is_cnode_cap cap \<Longrightarrow> cnode_cap_size cap = 0"
  by (clarsimp simp: cap_type_def cnode_cap_size_def split: cdl_cap.splits)

lemma irqhandler_cap_irq_non_irqhandler [simp]:
  "\<not> is_irqhandler_cap cap \<Longrightarrow> cap_irq cap = undefined"
  by (clarsimp simp: cap_irq_def split: cdl_cap.splits)

lemma default_cap_eq_non_cnode:
  "\<lbrakk>is_default_cap cap; is_default_cap cap';
   \<not> is_cnode_cap cap; \<not> is_irqhandler_cap cap;
    cap_type cap = cap_type cap'; cap_objects cap = cap_objects cap';
    is_device_cap cap = is_device_cap cap'\<rbrakk>
  \<Longrightarrow> cap = cap'"
  apply (rule default_cap_eq)
   apply simp+
  done

lemma cap_type_default_cap [simp]:
  "cap_type (default_cap type {obj_id} sz dev) = Some type"
  by (clarsimp simp: default_cap_def cap_type_def split: cdl_object_type.splits)

lemma is_tcb_update_slots [simp]:
  "is_tcb (update_slots slots obj) = is_tcb obj"
  by (clarsimp simp: is_tcb_def update_slots_def split: cdl_object.splits)

lemma tcb_has_slots [elim!]:
  "is_tcb obj \<Longrightarrow> has_slots obj"
  by (clarsimp simp: is_tcb_def has_slots_def split: cdl_object.splits)

lemma cnode_has_slots [elim!]:
  "is_cnode obj \<Longrightarrow> has_slots obj"
  by (clarsimp simp: is_cnode_def has_slots_def split: cdl_object.splits)

lemma pt_has_slots [elim!]:
  "is_pt obj \<Longrightarrow> has_slots obj"
  by (clarsimp simp: is_pt_def has_slots_def split: cdl_object.splits)

lemma pd_has_slots [elim!]:
  "is_pd obj \<Longrightarrow> has_slots obj"
  by (clarsimp simp: is_pd_def has_slots_def split: cdl_object.splits)

lemma asidpool_has_slots [elim!]:
  "is_asidpool obj \<Longrightarrow> has_slots obj"
  by (clarsimp simp: is_asidpool_def has_slots_def split: cdl_object.splits)

lemma object_type_has_slots [elim!]:
  "object_type obj = TcbType \<Longrightarrow> has_slots obj"
  "object_type obj = CNodeType \<Longrightarrow> has_slots obj"
  "object_type obj = IRQNodeType \<Longrightarrow> has_slots obj"
  "object_type obj = PageTableType \<Longrightarrow> has_slots obj"
  "object_type obj = PageDirectoryType \<Longrightarrow> has_slots obj"
  "object_type obj = AsidPoolType \<Longrightarrow> has_slots obj"
  by (clarsimp simp: object_type_def has_slots_def split: cdl_object.splits)+

lemma cap_type_update_cap_objects [simp]:
  "cap_type (update_cap_objects x cap) = cap_type cap"
  apply (clarsimp simp: cap_type_def update_cap_objects_def)
  apply (cases cap, simp_all)
  done

lemma cap_type_update_cap_object [simp]:
  "cap_type (update_cap_object x cap) = cap_type cap"
  by (clarsimp simp: update_cap_object_def cap_type_def
              split: cdl_cap.splits)

lemma cap_has_object_update_cap_objects [simp]:
  "cap_has_object (update_cap_objects x cap) = cap_has_object cap"
  apply (clarsimp simp: update_cap_object_def
                        cap_has_object_def update_cap_objects_def)
  apply (cases cap, simp_all)
  done

lemma cap_has_object_update_cap_object [simp]:
  "cap_has_object (update_cap_object x cap) = cap_has_object cap"
  by (clarsimp simp: update_cap_object_def cap_has_object_def
              split: cdl_cap.splits)

lemma cap_object_default_cap' [simp]:
  "\<lbrakk>\<not>is_untyped obj; \<not>is_irq_node obj\<rbrakk>
  \<Longrightarrow> cap_object (default_cap (object_type obj) {obj_id} sz dev) = obj_id"
  by (clarsimp simp: default_cap_def  object_type_def is_untyped_def is_irq_node_def cap_object_simps
              split: cdl_object_type.splits cdl_object.splits)

lemma cap_object_default_cap [simp]:
  "\<lbrakk>type \<noteq> UntypedType; type \<noteq> IRQNodeType\<rbrakk>
  \<Longrightarrow> cap_object (default_cap type {obj_id} sz dev) = obj_id"
  by (clarsimp simp: default_cap_def  object_type_def is_untyped_def cap_object_simps
              split: cdl_object_type.splits cdl_object.splits)

lemma cap_object_default_cap_frame:
  "is_frame_cap cap \<Longrightarrow> cap_object (default_cap (the (cap_type cap)) {obj_id} sz dev) = obj_id"
  by clarsimp

lemma default_cap_not_null [elim!]:
  "default_cap type obj_ids sz dev = NullCap \<Longrightarrow> False"
  "NullCap = default_cap type obj_ids sz dev\<Longrightarrow> False"
  by (simp add: default_cap_def split: cdl_object_type.splits)+

lemma cap_objects_update_cap_object [simp]:
  "\<lbrakk>cap_has_object cap; \<not>is_untyped_cap cap\<rbrakk>
  \<Longrightarrow> cap_objects (update_cap_object obj_id cap) = {obj_id}"
  by (clarsimp simp: cap_has_object_def update_cap_object_def
              split: cdl_cap.splits)

lemma  cap_has_object_default_cap [simp]:
  "type \<noteq> IRQNodeType \<Longrightarrow> cap_has_object (default_cap type ids sz dev)"
  by (clarsimp simp: default_cap_def cap_has_object_def split: cdl_object_type.splits)

lemma cap_rights_default_cap_cnode [simp]:
  "cap_rights (default_cap CNodeType ids sz dev) = UNIV"
  by (clarsimp simp: cap_rights_def default_cap_def)

lemma cap_rights_cnode_cap [simp]:
  "is_cnode_cap cap \<Longrightarrow> cap_rights cap = UNIV"
  by (clarsimp simp: cap_type_def cap_rights_def
              split: cdl_cap.splits)

lemma cap_has_object_simps [simp]:
  "cap_has_object (IOPageTableCap x)"
  "cap_has_object (IOSpaceCap x)"
  "cap_has_object (IOPortsCap x a)"
  "cap_has_object (AsidPoolCap x b)"
  "cap_has_object (PageDirectoryCap x c d)"
  "cap_has_object (PageTableCap x e f)"
  "cap_has_object (FrameCap dev x g h i j)"
  "cap_has_object (TcbCap x)"
  "cap_has_object (CNodeCap x k l sz)"
  "cap_has_object (MasterReplyCap x)"
  "cap_has_object (ReplyCap x)"
  "cap_has_object (NotificationCap x m n)"
  "cap_has_object (EndpointCap x p q)"
  "cap_has_object (ZombieCap x)"
  "cap_has_object (PendingSyncSendCap x s t u v)"
  "cap_has_object (PendingSyncRecvCap x t)"
  "cap_has_object (PendingNtfnRecvCap x)"
  "cap_has_object (UntypedCap dev ids ids') = True"
  by (simp_all add:cap_has_object_def)

lemma is_cap_NullCap [simp]:
  "\<not> is_untyped_cap NullCap"
  "\<not> is_ep_cap NullCap"
  "\<not> is_ntfn_cap NullCap"
  "\<not> is_cnode_cap NullCap"
  "\<not> is_tcb_cap NullCap"
  "\<not> is_asidpool_cap NullCap"
  "\<not> is_pt_cap NullCap"
  "\<not> is_pd_cap NullCap"
  "\<not> is_frame_cap NullCap"
  "\<not> is_fake_pt_cap NullCap"
  "\<not> is_irqhandler_cap NullCap"
  by (clarsimp simp: cap_type_def is_fake_pt_cap_def)+

(* The slots of an object, returns an empty list for non-existing objects
   or objects that do not have caps *)
definition
  slots_of_list :: "cdl_state \<Rightarrow> cdl_object_id \<Rightarrow> cdl_cnode_index list"
where
  "slots_of_list spec obj_id \<equiv> sorted_list_of_set $ dom $ slots_of obj_id spec"

(* Encode the guard and guard size for passing to the kernel. *)
definition guard_as_rawdata :: "cdl_cap \<Rightarrow> cdl_raw_capdata"
where
  "guard_as_rawdata cap \<equiv>
  let
    reserved_bits = 3;
    guard_size_bits = 5
  in
    (cap_guard cap << (reserved_bits + guard_size_bits))
    + (of_nat (cap_guard_size cap) << reserved_bits)"

definition cap_data :: "cdl_cap \<Rightarrow> cdl_raw_capdata"
where
  "cap_data cap \<equiv>
  if (is_ep_cap cap) then
    cap_badge cap
  else if (is_ntfn_cap cap) then
    cap_badge cap
  else
    guard_as_rawdata cap"

(*
 * Deterministic version of update_cap_data used by the capDL kernel.
 * This is used in the specification of the CSpace kernel calls.
 *)
definition guard_update :: "cdl_cap \<Rightarrow> word32 \<Rightarrow> cdl_cap"
where "guard_update cap data  \<equiv>
  case cap of cdl_cap.CNodeCap oid _ _ sz \<Rightarrow>
    (let reserved_bits = 3; guard_bits = 18; guard_size_bits = 5; new_guard_size = unat ((data >> reserved_bits) && mask guard_size_bits);
        new_guard =
          (data >> reserved_bits + guard_size_bits) && mask (min (unat ((data >> reserved_bits) && mask guard_size_bits)) guard_bits)
    in CNodeCap oid new_guard new_guard_size sz)
  | _ \<Rightarrow> cap"

definition
  update_cap_data_det :: "cdl_raw_capdata \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
  "update_cap_data_det raw_data cap \<equiv>
   case cap of
        EndpointCap _ b _      \<Rightarrow> badge_update raw_data cap
      | NotificationCap _ b _ \<Rightarrow> badge_update raw_data cap
      | CNodeCap object g gs _  \<Rightarrow> guard_update cap raw_data
      | _ \<Rightarrow> cap"

definition "valid_src_cap cap data \<equiv>
   is_cnode_cap cap \<longrightarrow> (
         unat ((data >> 3) && mask 5) + cnode_cap_size cap \<le> word_bits)"

(* MOVE TO KHeap.thy in capDL and fix get_thread *)
(* Get a thread from the given pointer. *)
definition
  opt_thread :: "cdl_object_id \<Rightarrow> cdl_state \<Rightarrow> cdl_tcb option"
where
  "opt_thread p s \<equiv>
      case opt_object p s of
          Some (Tcb tcb) \<Rightarrow> (Some tcb)
        | _ \<Rightarrow> None"

definition derived_cap :: "cdl_cap \<Rightarrow> cdl_cap"
where "derived_cap cap \<equiv> case cap of
          ReplyCap _ \<Rightarrow> NullCap
        | MasterReplyCap _ \<Rightarrow> NullCap
        | IrqControlCap \<Rightarrow> NullCap
        | FrameCap d p r sz b x \<Rightarrow> FrameCap d p r sz b None
        | ZombieCap _ \<Rightarrow> NullCap
        | _ \<Rightarrow> cap "

lemma derive_cap_wp:
  "\<lbrace> P (derived_cap cap) \<rbrace> derive_cap slot cap \<lbrace>P\<rbrace>, -"
  apply (clarsimp simp: derive_cap_def derived_cap_def)
  apply (clarsimp simp: validE_R_def derive_cap_def split:cdl_cap.splits)
  apply (safe, (wp alternative_wp alternativeE_wp hoare_whenE_wp |
                clarsimp simp: ensure_no_children_def)+ )
  done

definition safe_for_derive :: "cdl_cap \<Rightarrow> bool"
where "safe_for_derive cap \<equiv> case cap of
    NullCap \<Rightarrow> False
  | UntypedCap _ _ _ \<Rightarrow> False
  | PageTableCap _ _ _ \<Rightarrow> False
  | PageDirectoryCap _ _ _ \<Rightarrow> False
  | ReplyCap _ \<Rightarrow> False
  | MasterReplyCap _ \<Rightarrow> False
  | IrqControlCap \<Rightarrow> False
  | ZombieCap _ \<Rightarrow> False
  | _ \<Rightarrow> True"

lemma is_exclusive_cap_update_cap_rights [simp]:
  "safe_for_derive (update_cap_rights rights cap) = safe_for_derive cap"
  by (clarsimp simp: update_cap_rights_def safe_for_derive_def
              split: cdl_cap.splits)

lemma derive_cap_non_exclusive:
  "\<lbrace> P (derived_cap cap) and K (safe_for_derive cap) \<rbrace> derive_cap slot cap \<lbrace>P\<rbrace>, \<lbrace>Q\<rbrace>"
  apply (clarsimp simp: derive_cap_def derived_cap_def)
  apply (clarsimp simp: validE_R_def derive_cap_def
    safe_for_derive_def
    split:cdl_cap.splits)
  apply (intro conjI allI impI, wp+)
  done

lemma derived_cap_safe_for_derive[simp]:
  "safe_for_derive (derived_cap cap) = safe_for_derive cap"
  apply (case_tac cap)
  apply (simp_all add:derived_cap_def safe_for_derive_def)
  done

lemma safe_for_derive_not_non:
  "safe_for_derive cap \<Longrightarrow> cap \<noteq> NullCap"
  by (simp add:safe_for_derive_def split:cdl_cap.splits)

(* Given an object, this returns what the default state is for the object.
 * This should be the same as what is created by a retype operation.
 *)
definition
  object_default_state :: "cdl_object \<Rightarrow> cdl_object"
where
  "object_default_state object \<equiv>
  the $ default_object (object_type object)
                       (object_size_bits object)
                       (object_domain object)"

lemma object_default_state_def2:
  "object_default_state obj = (
    case obj of
        Untyped \<Rightarrow> Untyped
      | Endpoint \<Rightarrow> Endpoint
      | Notification \<Rightarrow> Notification
      | Tcb tcb \<Rightarrow> Tcb (default_tcb (cdl_tcb_domain tcb))
      | CNode cnode \<Rightarrow> CNode (empty_cnode (cdl_cnode_size_bits cnode))
      | IRQNode cnode \<Rightarrow> IRQNode empty_irq_node
      | AsidPool ap \<Rightarrow> AsidPool \<lparr>cdl_asid_pool_caps = empty_cap_map asid_low_bits\<rparr>
      | PageTable pt \<Rightarrow> PageTable \<lparr> cdl_page_table_caps = empty_cap_map 8 \<rparr>
      | PageDirectory pd \<Rightarrow> PageDirectory \<lparr> cdl_page_directory_caps = empty_cap_map 12 \<rparr>
      | Frame frame \<Rightarrow> Frame \<lparr> cdl_frame_size_bits = (cdl_frame_size_bits frame) \<rparr>)"
  by (clarsimp simp: object_default_state_def object_type_def default_object_def
                     object_size_bits_def object_domain_def
              split: cdl_object.splits)

(******************************************************
 * More rules, that should be put in the right place. *
 ******************************************************)

lemma object_type_update_slots [simp]:
  "object_type (update_slots slots x) = object_type x"
  by (clarsimp simp: object_type_def update_slots_def split: cdl_object.splits)

lemma object_slots_empty [simp]:
  "\<not> has_slots obj \<Longrightarrow> object_slots obj = empty"
  by (clarsimp simp: object_slots_def has_slots_def split: cdl_object.splits)

lemma object_slots_update_slots [simp]:
  "has_slots obj \<Longrightarrow> object_slots (update_slots slots obj) = slots"
  by (clarsimp simp: object_slots_def update_slots_def has_slots_def
              split: cdl_object.splits)

lemma object_slots_update_slots_empty [simp]:
  "\<not>has_slots obj \<Longrightarrow> object_slots (update_slots slots obj) = empty"
  by (clarsimp simp: object_slots_def update_slots_def has_slots_def
                 split: cdl_object.splits)

lemma update_slots_no_slots [simp]:
  "\<not>has_slots obj \<Longrightarrow> update_slots slots obj = obj"
  by (clarsimp simp: update_slots_def has_slots_def split: cdl_object.splits)

lemma update_slots_update_slots [simp]:
  "update_slots slots (update_slots slots' obj) = update_slots slots obj"
  by (clarsimp simp: update_slots_def split: cdl_object.splits)

lemma update_slots_same_object:
  "a = b \<Longrightarrow> update_slots a obj = update_slots b obj"
  by (erule arg_cong)

lemma update_slots_eq_slots:
  "\<lbrakk>has_slots obj; update_slots slots obj = update_slots slots' obj'\<rbrakk> \<Longrightarrow> slots = slots'"
  by (clarsimp simp: update_slots_def has_slots_def cdl_tcb.splits cdl_cnode.splits
                     cdl_asid_pool.splits cdl_irq_node.splits
                     cdl_page_table.splits cdl_page_directory.splits
              split: cdl_object.splits)

lemma has_slots_object_type_has_slots:
  "\<lbrakk>has_slots x; object_type x = object_type y\<rbrakk> \<Longrightarrow> has_slots y"
  by (clarsimp simp: object_type_def has_slots_def split: cdl_object.splits)

lemma object_type_has_slots_eq:
  "object_type y = object_type x \<Longrightarrow> has_slots x = has_slots y"
  by (clarsimp simp: object_type_def has_slots_def split: cdl_object.splits)

lemma object_type_object_default_state [simp]:
  "object_type (object_default_state obj) = object_type obj"
  by (clarsimp simp: object_default_state_def2 object_type_def split: cdl_object.splits)

lemma is_cnode_object_default_state [simp]:
  "is_cnode (object_default_state obj) = is_cnode obj"
  by (clarsimp simp: object_default_state_def2 is_cnode_def split: cdl_object.splits)

lemma update_slots_same [simp]:
  "object_slots obj = cap_map \<Longrightarrow> update_slots cap_map obj = obj"
  by (clarsimp simp: update_slots_def object_slots_def split: cdl_object.splits)

lemma dom_sub_restrict [simp]:
  "dom (m `- A) = dom m \<inter> -A"
  by (auto simp: sub_restrict_map_def dom_def split: if_split_asm)

lemma inter_empty_not_both:
"\<lbrakk>x \<in> A; A \<inter> B = {}\<rbrakk> \<Longrightarrow> x \<notin> B"
  by fastforce

end


(*  Title:      HOL/Auth/n_german_lemma_inv__43_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__43_on_rules imports n_german_lemma_on_inv__43
begin
section{*All lemmas on causal relation between inv__43*}
lemma lemma_inv__43_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__43  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__43) 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__43) 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__43) 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__43) 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__43) 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__43) 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__43) 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__43) 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__43) 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__43) 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__43) 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__43) 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__43) 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__43) done
    }

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

end


(*  Title:      JinjaThreads/Execute/State_Refinement.thy
    Author:     Andreas Lochbihler
*)

header {* \chapter{Schedulers}
          \isaheader{Refinement for multithreaded states} *}

theory State_Refinement
imports
  "../Framework/FWSemantics"
  "../Common/StartConfig"
begin

type_synonym
  ('l,'t,'m,'m_t,'m_w,'s_i) state_refine = "('l,'t) locks \<times> ('m_t \<times> 'm) \<times> 'm_w \<times> 's_i"

locale state_refine_base =
  fixes final :: "'x \<Rightarrow> bool"
  and r :: "'t \<Rightarrow> ('x \<times> 'm) \<Rightarrow> (('l,'t,'x,'m,'w,'o) thread_action \<times> 'x \<times> 'm) Predicate.pred"
  and convert_RA :: "'l released_locks \<Rightarrow> 'o list"
  and thr_\<alpha> :: "'m_t \<Rightarrow> ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t \<Rightarrow> bool"
  and ws_\<alpha> :: "'m_w \<Rightarrow> ('w,'t) wait_sets"
  and ws_invar :: "'m_w \<Rightarrow> bool"
  and is_\<alpha> :: "'s_i \<Rightarrow> 't interrupts"
  and is_invar :: "'s_i \<Rightarrow> bool"
begin

fun state_\<alpha> :: "('l,'t,'m,'m_t,'m_w, 's_i) state_refine \<Rightarrow> ('l,'t,'x,'m,'w) state"
where "state_\<alpha> (ls, (ts, m), ws, is) = (ls, (thr_\<alpha> ts, m), ws_\<alpha> ws, is_\<alpha> is)"

lemma state_\<alpha>_conv [simp]:
  "locks (state_\<alpha> s) = locks s"
  "thr (state_\<alpha> s) = thr_\<alpha> (thr s)"
  "shr (state_\<alpha> s) = shr s"
  "wset (state_\<alpha> s) = ws_\<alpha> (wset s)"
  "interrupts (state_\<alpha> s) = is_\<alpha> (interrupts s)"
by(case_tac [!] s) auto

inductive state_invar :: "('l,'t,'m,'m_t,'m_w,'s_i) state_refine \<Rightarrow> bool"
where "\<lbrakk> thr_invar ts; ws_invar ws; is_invar is \<rbrakk> \<Longrightarrow> state_invar (ls, (ts, m), ws, is)"

inductive_simps state_invar_simps [simp]:
  "state_invar (ls, (ts, m), ws, is)"

lemma state_invarD [simp]:
  assumes "state_invar s"
  shows "thr_invar (thr s)" "ws_invar (wset s)" "is_invar (interrupts s)"
using assms by(case_tac [!] s) auto

end

sublocale state_refine_base < \<alpha>!: final_thread final .
sublocale state_refine_base < \<alpha>!:
  multithreaded_base
    final
    "\<lambda>t xm ta x'm'. Predicate.eval (r t xm) (ta, x'm')"
.

definition (in heap_base) start_state_refine ::
  "'m_t \<Rightarrow> ('thread_id \<Rightarrow> ('x \<times> 'addr released_locks) \<Rightarrow> 'm_t \<Rightarrow> 'm_t) \<Rightarrow> 'm_w \<Rightarrow> 's_i
  \<Rightarrow> (cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> 'md \<Rightarrow> 'addr val list \<Rightarrow> 'x) \<Rightarrow> 'md prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> 'addr val list
  \<Rightarrow> ('addr, 'thread_id, 'heap, 'm_t, 'm_w, 's_i) state_refine"
where
  "\<And>is_empty.
  start_state_refine thr_empty thr_update ws_empty is_empty f P C M vs =
  (let (D, Ts, T, m) = method P C M
   in (K$ None, (thr_update start_tid (f D M Ts T (the m) vs, no_wait_locks) thr_empty, start_heap), ws_empty, is_empty))"

definition Jinja_output ::
  "'s \<Rightarrow> 'thread_id \<Rightarrow> ('addr, 'thread_id, 'x, 'heap, 'addr, ('addr, 'thread_id) obs_event) thread_action
  \<Rightarrow> ('thread_id \<times> ('addr, 'thread_id) obs_event list) option"
where "Jinja_output \<sigma> t ta = (if \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> = [] then None else Some (t, \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))"

lemmas [code] =
  heap_base.start_state_refine_def

end


(*  Title:      HOL/Auth/n_german_lemma_inv__42_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__42_on_rules imports n_german_lemma_on_inv__42
begin
section{*All lemmas on causal relation between inv__42*}
lemma lemma_inv__42_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__42  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__42) 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__42) 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__42) 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__42) 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__42) 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__42) 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__42) 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__42) 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__42) 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__42) 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__42) 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__42) 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__42) 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__42) done
    }

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

end


theory Observe_Failure imports
  More_CC
begin

declare [[show_variants]]

context fixes "oracle" :: "('s, 'in, 'out) oracle'" begin

fun obsf_oracle :: "('s exception, 'in, 'out exception) oracle'" where
  "obsf_oracle Fault x = return_spmf (Fault, Fault)"
| "obsf_oracle (OK s) x = TRY map_spmf (map_prod OK OK) (oracle s x) ELSE return_spmf (Fault, Fault)"

end

type_synonym ('a, 'b) resource_obsf = "('a, 'b exception) resource"

translations
  (type) "('a, 'b) resource_obsf" <= (type) "('a, 'b exception) resource"

primcorec obsf_resource :: "('in, 'out) resource \<Rightarrow> ('in, 'out) resource_obsf" where
  "run_resource (obsf_resource res) = (\<lambda>x.
   map_spmf (map_prod id obsf_resource)
     (map_spmf (map_prod id (\<lambda>resF. case resF of OK res' \<Rightarrow> res' | Fault \<Rightarrow> fail_resource))
       (TRY map_spmf (map_prod OK OK) (run_resource res x) ELSE return_spmf (Fault, Fault))))"

lemma obsf_resource_sel:
  "run_resource (obsf_resource res) x =
   map_spmf (map_prod id (\<lambda>resF. obsf_resource (case resF of OK res' \<Rightarrow> res' | Fault \<Rightarrow> fail_resource)))
    (TRY map_spmf (map_prod OK OK) (run_resource res x) ELSE return_spmf (Fault, Fault))"
  by(simp add: spmf.map_comp prod.map_comp o_def id_def)

declare obsf_resource.simps [simp del]

lemma obsf_resource_exception [simp]: "obsf_resource fail_resource = const_resource Fault"
  by coinduction(simp add: rel_fun_def obsf_resource_sel)

lemma obsf_resource_sel2 [simp]:
  "run_resource (obsf_resource res) x =
   try_spmf (map_spmf (map_prod OK obsf_resource) (run_resource res x)) (return_spmf (Fault, const_resource Fault))"
  by(simp add: map_try_spmf spmf.map_comp o_def prod.map_comp obsf_resource_sel)

lemma lossless_obsf_resource [simp]: "lossless_resource \<I> (obsf_resource res)"
  by(coinduction arbitrary: res) auto

lemma WT_obsf_resource [WT_intro, simp]: "exception_\<I> \<I> \<turnstile>res obsf_resource res \<surd>" if "\<I> \<turnstile>res res \<surd>"
  using that by(coinduction arbitrary: res)(auto dest: WT_resourceD split: if_split_asm)

type_synonym ('a, 'b) distinguisher_obsf = "(bool, 'a, 'b exception) gpv"

translations
  (type) "('a, 'b) distinguisher_obsf" <= (type) "(bool, 'a, 'b exception) gpv"

abbreviation connect_obsf :: "('a, 'b) distinguisher_obsf \<Rightarrow> ('a, 'b) resource_obsf \<Rightarrow> bool spmf" where
  "connect_obsf == connect"

definition obsf_distinguisher :: "('a, 'b) distinguisher \<Rightarrow> ('a, 'b) distinguisher_obsf" where
  "obsf_distinguisher \<D> = map_gpv' (\<lambda>x. x = Some True) id option_of_exception (gpv_stop \<D>)"

lemma WT_obsf_distinguisher [WT_intro]:
  "exception_\<I> \<I> \<turnstile>g obsf_distinguisher \<A> \<surd>" if [WT_intro]: "\<I> \<turnstile>g \<A> \<surd>"
  unfolding obsf_distinguisher_def by(rule WT_intro|simp)+

lemma interaction_bounded_by_obsf_distinguisher [interaction_bound]:
  "interaction_bounded_by consider (obsf_distinguisher \<A>) bound"
  if [interaction_bound]: "interaction_bounded_by consider \<A> bound"
  unfolding obsf_distinguisher_def by(rule interaction_bound|simp)+

lemma plossless_obsf_distinguisher [simp]:
  "plossless_gpv (exception_\<I> \<I>) (obsf_distinguisher \<A>)"
  if "plossless_gpv \<I> \<A>" "\<I> \<turnstile>g \<A> \<surd>"
  using that unfolding obsf_distinguisher_def by(simp)

type_synonym ('a, 'b, 'c, 'd) converter_obsf = "('a, 'b exception, 'c, 'd exception) converter"

translations
  (type) "('a, 'b, 'c, 'd) converter_obsf" <= (type) "('a, 'b exception, 'c, 'd exception) converter"

primcorec obsf_converter :: "('a, 'b, 'c, 'd) converter \<Rightarrow> ('a, 'b, 'c, 'd) converter_obsf" where
  "run_converter (obsf_converter conv) = (\<lambda>x.
   map_gpv (map_prod id obsf_converter) id
    (map_gpv (\<lambda>convF. case convF of Fault \<Rightarrow> (Fault, fail_converter) | OK (a, conv') \<Rightarrow> (OK a, conv')) id
      (try_gpv (map_gpv' exception_of_option id option_of_exception (gpv_stop (run_converter conv x))) (Done Fault))))"

lemma obsf_converter_exception [simp]: "obsf_converter fail_converter = const_converter Fault"
  by(coinduction)(simp add: rel_fun_def)

lemma obsf_converter_sel [simp]:
  "run_converter (obsf_converter conv) x =
   TRY map_gpv' (\<lambda>y. case y of None \<Rightarrow> (Fault, const_converter Fault) | Some(x, conv') \<Rightarrow> (OK x, obsf_converter conv')) id option_of_exception
         (gpv_stop (run_converter conv x))
   ELSE Done (Fault, const_converter Fault)"
  by(simp add: map_try_gpv)
    (simp add: map_gpv_conv_map_gpv' map_gpv'_comp o_def option.case_distrib[where h="map_prod _ _"] split_def id_def cong del: option.case_cong)

declare obsf_converter.sel [simp del]

lemma exec_gpv_obsf_resource:
  defines "exec_gpv1 \<equiv> exec_gpv"
    and "exec_gpv2 \<equiv> exec_gpv"
  shows
  "exec_gpv1 run_resource (map_gpv' id id option_of_exception (gpv_stop gpv)) (obsf_resource res) \<upharpoonleft> {(Some x, y)|x y. True} =
   map_spmf (map_prod Some obsf_resource) (exec_gpv2 run_resource gpv res)"
  (is "?lhs = ?rhs")
proof(rule spmf.leq_antisym)
  show "ord_spmf (=) ?lhs ?rhs" unfolding exec_gpv1_def
  proof(induction arbitrary: gpv res rule: exec_gpv_fixp_induct_strong)
    case adm show ?case by simp
    case bottom show ?case by simp
    case (step exec_gpv')
    show ?case unfolding exec_gpv2_def
      apply(subst exec_gpv.simps)
      apply(clarsimp simp add: map_bind_spmf bind_map_spmf restrict_bind_spmf o_def try_spmf_def intro!: ord_spmf_bind_reflI split!: generat.split)
      apply(clarsimp simp add: bind_map_pmf bind_spmf_def bind_assoc_pmf bind_return_pmf spmf.leq_trans[OF restrict_spmf_mono, OF step.hyps] id_def step.IH[simplified, simplified id_def exec_gpv2_def] intro!: rel_pmf_bind_reflI split!: option.split)
      done
  qed

  show "ord_spmf (=) ?rhs ?lhs" unfolding exec_gpv2_def
  proof(induction arbitrary: gpv res rule: exec_gpv_fixp_induct)
    case adm show ?case by simp
    case bottom show ?case by simp
    case (step exec_gpv')
    show ?case unfolding exec_gpv1_def
      apply(subst exec_gpv.simps)
      apply(clarsimp simp add: bind_map_spmf map_bind_spmf restrict_bind_spmf o_def try_spmf_def intro!: ord_spmf_bind_reflI split!: generat.split)
      apply(clarsimp simp add: bind_spmf_def bind_assoc_pmf bind_map_pmf map_bind_pmf bind_return_pmf id_def step.IH[simplified, simplified id_def exec_gpv1_def] intro!: rel_pmf_bind_reflI split!: option.split)
      done
  qed
qed

lemma obsf_attach:
  assumes pfinite: "pfinite_converter \<I> \<I>' conv"
    and WT: "\<I>, \<I>' \<turnstile>\<^sub>C conv \<surd>"
    and WT_resource: "\<I>' \<turnstile>res res \<surd>"
  shows "outs_\<I> \<I> \<turnstile>\<^sub>R attach (obsf_converter conv) (obsf_resource res) \<sim> obsf_resource (attach conv res)"
  using assms
proof(coinduction arbitrary: conv res)
  case (eq_resource_on out conv res)
  then show ?case (is "rel_spmf ?X ?lhs ?rhs")
  proof -
    have "?lhs = map_spmf (\<lambda>((b, conv'), res'). (b, conv' \<rhd> res'))
     (exec_gpv run_resource
       (TRY map_gpv' (case_option (Fault, const_converter Fault) (\<lambda>(x, conv'). (OK x, obsf_converter conv'))) id option_of_exception (gpv_stop (run_converter conv out)) ELSE Done (Fault, const_converter Fault))
       (obsf_resource res))"
      (is "_ = map_spmf ?attach (exec_gpv _ (TRY ?gpv ELSE _) _)") by(clarsimp)
    also have "\<dots> =  TRY map_spmf ?attach (exec_gpv run_resource ?gpv (obsf_resource res)) ELSE return_spmf (Fault, const_resource Fault)"
      by(rule run_lossless_resource.exec_gpv_try_gpv[where \<I>="exception_\<I> \<I>'"])
        (use eq_resource_on in \<open>auto intro!: WT_gpv_map_gpv' WT_gpv_stop pfinite_gpv_stop[THEN iffD2] dest: WT_converterD pfinite_converterD lossless_resourceD\<close>)
    also have "\<dots> = TRY map_spmf (\<lambda>(rc, res'). case rc of None \<Rightarrow> (Fault, const_resource Fault) | Some (x, conv') \<Rightarrow> (OK x, obsf_converter conv' \<rhd> res'))
            ((exec_gpv run_resource (map_gpv' id id option_of_exception (gpv_stop (run_converter conv out))) (obsf_resource res)) \<upharpoonleft> {(Some x, y)|x y. True})
               ELSE return_spmf (Fault, const_resource Fault)" (is "_ = TRY map_spmf ?f _ ELSE ?z")
      by(subst map_gpv'_id12)(clarsimp simp add: map_gpv'_map_gpv_swap exec_gpv_map_gpv_id try_spmf_def restrict_spmf_def bind_map_pmf intro!: bind_pmf_cong[OF refl] split: option.split)
    also have "\<dots> = TRY map_spmf ?f (map_spmf (map_prod Some obsf_resource) (exec_gpv run_resource (run_converter conv out) res)) ELSE ?z"
      by(simp only: exec_gpv_obsf_resource)
    also have "rel_spmf ?X \<dots> ?rhs" using eq_resource_on
      by(auto simp add: spmf.map_comp o_def spmf_rel_map intro!: rel_spmf_try_spmf rel_spmf_reflI)
        (auto intro!: exI dest: run_resource.in_set_spmf_exec_gpv_into_results_gpv WT_converterD pfinite_converterD run_resource.exec_gpv_invariant)
    finally show ?case .
  qed
qed

lemma colossless_obsf_converter [simp]:
  "colossless_converter (exception_\<I> \<I>) \<I>' (obsf_converter conv)"
  by(coinduction arbitrary: conv)(auto split: option.split_asm)

lemma WT_obsf_converter [WT_intro]:
  "exception_\<I> \<I>, exception_\<I> \<I>' \<turnstile>\<^sub>C obsf_converter conv \<surd>" if "\<I>, \<I>' \<turnstile>\<^sub>C conv \<surd>"
  using that
  by(coinduction arbitrary: conv)(auto 4 3 dest: WT_converterD results_gpv_stop_SomeD split!: option.splits intro!: WT_intro)

lemma inline1_gpv_stop_obsf_converter:
  defines "inline1a \<equiv> inline1"
    and "inline1b \<equiv> inline1"
  shows "bind_spmf (inline1a run_converter (map_gpv' id id option_of_exception (gpv_stop gpv)) (obsf_converter conv))
     (\<lambda>xy. case xy of Inl (None, conv') \<Rightarrow> return_pmf None | Inl (Some x, conv') \<Rightarrow> return_spmf (Inl (x, conv')) | Inr y \<Rightarrow> return_spmf (Inr y)) =
   map_spmf (map_sum (apsnd obsf_converter)
       (apsnd (map_prod (\<lambda>rpv input. case input of Fault \<Rightarrow> Done (Fault, const_converter Fault) | OK input' \<Rightarrow>
            map_gpv' (\<lambda>res. case res of None \<Rightarrow> (Fault, const_converter Fault) | Some (x, conv') \<Rightarrow> (OK x, obsf_converter conv')) id option_of_exception (try_gpv (gpv_stop (rpv input')) (Done None)))
     (\<lambda>rpv input. case input of Fault \<Rightarrow> Done None | OK input' \<Rightarrow> map_gpv' id id option_of_exception (gpv_stop (rpv input'))))))
    (inline1b run_converter gpv conv)"
  (is "?lhs = ?rhs")
proof(rule spmf.leq_antisym)
  show "ord_spmf (=) ?lhs ?rhs" unfolding inline1a_def
  proof(induction arbitrary: gpv conv rule: inline1_fixp_induct_strong)
    case adm show ?case by simp
    case bottom show ?case by simp
    case (step inline1')
    show ?case unfolding inline1b_def
      apply(subst inline1_unfold)
      apply(clarsimp simp add: map_spmf_bind_spmf bind_map_spmf spmf.map_comp o_def generat.map_comp intro!: ord_spmf_bind_reflI split!: generat.split)
      apply(clarsimp simp add: bind_spmf_def try_spmf_def bind_assoc_pmf bind_map_pmf bind_return_pmf intro!: rel_pmf_bind_reflI split!: option.split)
      subgoal unfolding bind_spmf_def[symmetric]
        by(rule ord_spmf_bindI[OF step.hyps, THEN spmf.leq_trans])
          (auto split!: option.split intro!: ord_spmf_bindI[OF step.hyps, THEN spmf.leq_trans] ord_spmf_reflI)
      subgoal unfolding bind_spmf_def[symmetric]
        by(clarsimp simp add: in_set_spmf[symmetric] inline1b_def split!: generat.split intro!: step.IH[THEN spmf.leq_trans])
          (auto simp add: fun_eq_iff map'_try_gpv split: exception.split)
      done
  qed

  show "ord_spmf (=) ?rhs ?lhs" unfolding inline1b_def
  proof(induction arbitrary: gpv conv rule: inline1_fixp_induct_strong)
    case adm show ?case by simp
    case bottom show ?case by simp
    case (step inline1')
    show ?case unfolding inline1a_def
      apply(subst inline1_unfold)
      apply(clarsimp simp add: map_spmf_bind_spmf bind_map_spmf spmf.map_comp o_def generat.map_comp intro!: ord_spmf_bind_reflI split!: generat.split)
      apply(clarsimp simp add: bind_spmf_def try_spmf_def bind_assoc_pmf bind_map_pmf bind_return_pmf intro!: rel_pmf_bind_reflI split!: option.split)
      apply(clarsimp simp add: bind_spmf_def[symmetric] in_set_spmf[symmetric] inline1a_def id_def[symmetric] split!: generat.split intro!: step.IH[THEN spmf.leq_trans])
      apply(auto simp add: fun_eq_iff map'_try_gpv split: exception.split)
      done
  qed
qed

lemma inline_gpv_stop_obsf_converter:
  "bind_gpv (inline run_converter (map_gpv' id id option_of_exception (gpv_stop gpv)) (obsf_converter conv)) (\<lambda>(x, conv'). case x of None \<Rightarrow> Fail | Some x' \<Rightarrow> Done (x, conv')) =
   bind_gpv (map_gpv' id id option_of_exception (gpv_stop (inline run_converter gpv conv))) (\<lambda>x. case x of None \<Rightarrow> Fail | Some (x', conv) \<Rightarrow> Done (Some x', obsf_converter conv))"
proof(coinduction arbitrary: gpv conv rule: gpv_coinduct_bind)
  case (Eq_gpv gpv conv)
  show "?case TYPE('c \<times> ('b, 'c, 'd, 'e) converter) TYPE('c \<times> ('b, 'c, 'd, 'e) converter)" (is "rel_spmf ?X ?lhs ?rhs")
  proof -
    have "?lhs = map_spmf (\<lambda>xyz. case xyz of Inl (x, conv) \<Rightarrow> Pure (Some x, conv) | Inr (out, rpv, rpv') \<Rightarrow> IO out (\<lambda>input. bind_gpv (bind_gpv (rpv input) (\<lambda>(x, y). inline run_converter (rpv' x) y)) (\<lambda>(x, conv'). case x of None \<Rightarrow> Fail | Some x' \<Rightarrow> Done (x, conv'))))
      (bind_spmf (inline1 run_converter (map_gpv' id id option_of_exception (gpv_stop gpv)) (obsf_converter conv))
         (\<lambda>xy. case xy of Inl (None, conv') \<Rightarrow> return_pmf None | Inl (Some x, conv') \<Rightarrow> return_spmf (Inl (x, conv')) | Inr y \<Rightarrow> return_spmf (Inr y)))"
      (is "_ = map_spmf ?f _")
      by(auto simp del: bind_gpv_sel' simp add: bind_gpv.sel map_bind_spmf inline_sel bind_map_spmf o_def intro!: bind_spmf_cong[OF refl] split!: sum.split option.split)
    also have "\<dots> = map_spmf ?f (map_spmf (map_sum (apsnd obsf_converter) (apsnd (map_prod (\<lambda>rpv. case_exception (Done (Fault, const_converter Fault))
                     (\<lambda>input'. map_gpv' (case_option (Fault, const_converter Fault) (\<lambda>(x, conv'). (OK x, obsf_converter conv'))) id option_of_exception (TRY gpv_stop (rpv input') ELSE Done None)))
             (\<lambda>rpv. case_exception (Done None) (\<lambda>input'. map_gpv' id id option_of_exception (gpv_stop (rpv input')))))))
       (inline1 run_converter gpv conv))"
      by(simp only: inline1_gpv_stop_obsf_converter)
    also have "\<dots> = bind_spmf (inline1 run_converter gpv conv) (\<lambda>y. return_spmf (?f (map_sum (apsnd obsf_converter)
                     (apsnd (map_prod (\<lambda>rpv. case_exception (Done (Fault, const_converter Fault)) (\<lambda>input'. map_gpv' (case_option (Fault, const_converter Fault) (\<lambda>(x, conv'). (OK x, obsf_converter conv'))) id option_of_exception (TRY gpv_stop (rpv input') ELSE Done None)))
                         (\<lambda>rpv. case_exception (Done None) (\<lambda>input'. map_gpv' id id option_of_exception (gpv_stop (rpv input'))))))
                     y)))"
      by(simp add: map_spmf_conv_bind_spmf)
    also have "rel_spmf ?X \<dots> (bind_spmf (inline1 run_converter gpv conv)
       (\<lambda>x. map_spmf (map_generat id id ((\<circ>) (case_sum id (\<lambda>r. bind_gpv r (case_option Fail (\<lambda>(x', conv). Done (Some x', obsf_converter conv)))))))
              (case map_generat id id (map_fun option_of_exception (map_gpv' id id option_of_exception))
                     (map_generat Some id (\<lambda>rpv. case_option (Done None) (\<lambda>input'. gpv_stop (rpv input')))
                       (case x of Inl x \<Rightarrow> Pure x
                        | Inr (out, oracle, rpv) \<Rightarrow> IO out (\<lambda>input. bind_gpv (oracle input) (\<lambda>(x, y). inline run_converter (rpv x) y)))) of
               Pure x \<Rightarrow>
                 map_spmf (map_generat id id ((\<circ>) Inl)) (the_gpv (case x of None \<Rightarrow> Fail | Some (x', conv) \<Rightarrow> Done (Some x', obsf_converter conv)))
               | IO out c \<Rightarrow> return_spmf (IO out (\<lambda>input. Inr (c input))))))"
      (is "rel_spmf _ _ ?rhs2" is "rel_spmf _ (bind_spmf _ ?L) (bind_spmf _ ?R)")
    proof(rule rel_spmf_bind_reflI)
      fix x :: "'a \<times> ('b, 'c, 'd, 'e) converter + 'd \<times> ('c \<times> ('b, 'c, 'd, 'e) converter, 'd, 'e) rpv \<times> ('a, 'b, 'c) rpv"
      assume x: "x \<in> set_spmf (inline1 run_converter gpv conv)"
      consider (Inl) a conv' where "x = Inl (a, conv')" | (Inr) out rpv rpv' where "x = Inr (out, rpv, rpv')" by(cases x) auto
      then show "rel_spmf ?X (?L x) (?R x)"
      proof cases
        case Inr
        have "\<exists>(gpv2 :: ('c \<times> ('b, 'c, 'd, 'e) converter, 'd, 'e exception) gpv) (gpv2' :: ('c \<times> ('b, 'c, 'd, 'e) converter, 'd, 'e exception) gpv) f f'.
           bind_gpv (map_gpv' (case_option (Fault, const_converter Fault) (\<lambda>p. (OK (fst p), obsf_converter (snd p)))) id option_of_exception (TRY gpv_stop (rpv input) ELSE Done None))
             (\<lambda>x. case fst x of Fault \<Rightarrow> Fail | OK xa \<Rightarrow> bind_gpv (inline run_converter (map_gpv' id id option_of_exception (gpv_stop (rpv' xa))) (snd x)) (\<lambda>p. case fst p of None \<Rightarrow> Fail | Some x' \<Rightarrow> Done (Some x', snd p))) =
             bind_gpv gpv2 f \<and>
           bind_gpv (map_gpv' id id option_of_exception (gpv_stop (rpv input))) (case_option Fail (\<lambda>x. bind_gpv (map_gpv' id id option_of_exception (gpv_stop (inline run_converter (rpv' (fst x)) (snd x)))) (case_option Fail (\<lambda>p. Done (Some (fst p), obsf_converter (snd p)))))) =
             bind_gpv gpv2' f' \<and>
           rel_gpv (\<lambda>x y. \<exists>gpv conv. f x = bind_gpv (inline run_converter (map_gpv' id id option_of_exception (gpv_stop gpv)) (obsf_converter conv)) (\<lambda>p. case fst p of None \<Rightarrow> Fail | Some x' \<Rightarrow> Done (Some x', snd p)) \<and>
                     f' y = bind_gpv (map_gpv' id id option_of_exception (gpv_stop (inline run_converter gpv conv))) (case_option Fail (\<lambda>p. Done (Some (fst p), obsf_converter (snd p)))))
              (=) gpv2 gpv2'"
          (is "\<exists>gpv2 gpv2' f f'. ?lhs1 input = _ \<and> ?rhs1 input = _ \<and> rel_gpv (?X f f') _ _ _") for input
        proof(intro exI conjI)
          let ?gpv2 = "bind_gpv (map_gpv' id id option_of_exception (TRY gpv_stop (rpv input) ELSE Done None)) (\<lambda>x. case x of None \<Rightarrow> Fail | Some x \<Rightarrow> Done x)"
          let ?gpv2' = "bind_gpv (map_gpv' id id option_of_exception (gpv_stop (rpv input))) (\<lambda>x. case x of None \<Rightarrow> Fail | Some x \<Rightarrow> Done x)"
          let ?f = "\<lambda>x. bind_gpv (inline run_converter (map_gpv' id id option_of_exception (gpv_stop (rpv' (fst x)))) (obsf_converter (snd x))) (\<lambda>p. case fst p of None \<Rightarrow> Fail | Some x' \<Rightarrow> Done (Some x', snd p))"
          let ?f' = "\<lambda>x. bind_gpv (map_gpv' id id option_of_exception (gpv_stop (inline run_converter (rpv' (fst x)) (snd x)))) (case_option Fail (\<lambda>p. Done (Some (fst p), obsf_converter (snd p))))"
          show "?lhs1 input = bind_gpv ?gpv2 ?f"
            by(subst map_gpv'_id12[THEN trans, OF map_gpv'_map_gpv_swap])
              (auto simp add: bind_map_gpv o_def bind_gpv_assoc intro!: bind_gpv_cong split!: option.split)
          show "?rhs1 input = bind_gpv ?gpv2' ?f'"
            by(auto simp add: bind_gpv_assoc id_def[symmetric] intro!: bind_gpv_cong split!: option.split)
          show "rel_gpv (?X ?f ?f') (=) ?gpv2 ?gpv2'" using Inr x
            by(auto simp add: map'_try_gpv id_def[symmetric] bind_try_Done_Fail intro: gpv.rel_refl_strong)
        qed
        then show ?thesis using Inr
          by(clarsimp split!: sum.split exception.split simp add: rel_fun_def bind_gpv_assoc split_def map_gpv'_bind_gpv exception.case_distrib[where h="\<lambda>x. bind_gpv (inline _ x _) _"] option.case_distrib[where h="\<lambda>x. bind_gpv (map_gpv' _ _ _ x) _"] cong: exception.case_cong option.case_cong)
      qed simp
    qed
    moreover have "?rhs2 = ?rhs"
      by(simp del: bind_gpv_sel' add: bind_gpv.sel map_bind_spmf inline_sel bind_map_spmf o_def)
    ultimately show ?thesis by(simp only:)
  qed
qed

lemma obsf_comp_converter:
  assumes WT: "\<I>, \<I>' \<turnstile>\<^sub>C conv1 \<surd>" "\<I>', \<I>'' \<turnstile>\<^sub>C conv2 \<surd>"
    and pfinite1: "pfinite_converter \<I> \<I>' conv1"
  shows "exception_\<I> \<I>, exception_\<I> \<I>'' \<turnstile>\<^sub>C obsf_converter (comp_converter conv1 conv2) \<sim> comp_converter (obsf_converter conv1) (obsf_converter conv2)"
  using WT pfinite1 supply eq_\<I>_gpv_map_gpv[simp del]
proof(coinduction arbitrary: conv1 conv2)
  case eq_\<I>_converter
  show ?case (is "eq_\<I>_gpv ?X _ ?lhs ?rhs")
  proof -
    have "eq_\<I>_gpv (=) (exception_\<I> \<I>'') ?rhs (TRY map_gpv (\<lambda>((b, conv1'), conv2'). (b, conv1' \<odot> conv2')) id
               (inline run_converter
                 (map_gpv'
                   (case_option (Fault, const_converter Fault)
                     (\<lambda>(x, conv'). (OK x, obsf_converter conv')))
                   id option_of_exception (gpv_stop (run_converter conv1 q)))
                 (obsf_converter conv2)) ELSE Done (Fault, const_converter Fault))"
      (is "eq_\<I>_gpv _ _ _ ?rhs2" is "eq_\<I>_gpv _ _ _ (try_gpv (map_gpv ?f _ ?inline) ?else)")
      using eq_\<I>_converter
      apply simp
      apply(rule run_colossless_converter.inline_try_gpv[where \<I>="exception_\<I> \<I>'"])
          apply(auto intro!: WT_intro pfinite_gpv_stop[THEN iffD2] dest: WT_converterD pfinite_converterD colossless_converterD)
      done
    term "bind_gpv (inline run_converter (map_gpv' id id option_of_exception (gpv_stop (run_converter conv1 q))) (obsf_converter conv2))
           (\<lambda>(x, conv'). case x of None \<Rightarrow> Fail | Some x' \<Rightarrow> Done (x, conv'))"

    also have "?rhs2 = try_gpv (map_gpv ?f id
       (map_gpv (\<lambda>(xo, conv'). case xo of None \<Rightarrow> ((Fault, const_converter Fault), conv') | Some (x, conv) \<Rightarrow> ((OK x, obsf_converter conv), conv')) id
         (bind_gpv (inline run_converter (map_gpv' id id option_of_exception (gpv_stop (run_converter conv1 q))) (obsf_converter conv2))
           (\<lambda>(x, conv'). case x of None \<Rightarrow> Fail | Some x' \<Rightarrow> Done (x, conv')))))
        ?else"
      apply(simp add: map_gpv_bind_gpv gpv.map_id)
      apply(subst try_gpv_bind_gpv)
      apply(simp add: split_def option.case_distrib[where h="map_gpv _ _"] option.case_distrib[where h="fst"] option.case_distrib[where h="\<lambda>x. try_gpv x _"] cong del: option.case_cong)
      apply(subst option.case_distrib[where h=Done, symmetric, abs_def])+
      apply(fold map_gpv_conv_bind)
      apply(simp add: map_try_gpv gpv.map_comp o_def)
      apply(rule try_gpv_cong)
       apply(subst map_gpv'_id12)
       apply(subst map_gpv'_map_gpv_swap)
       apply(simp add: inline_map_gpv gpv.map_comp id_def[symmetric])
       apply(rule gpv.map_cong[OF refl])
        apply(auto split: option.split)
      done
    also have "\<dots> = try_gpv (map_gpv ?f id
       (map_gpv (\<lambda>(xo, conv'). case xo of None \<Rightarrow> ((Fault, const_converter Fault), conv') | Some (x, conv) \<Rightarrow> ((OK x, obsf_converter conv), conv')) id
(bind_gpv
                (map_gpv' id id option_of_exception
                  (gpv_stop (inline run_converter (run_converter conv1 q) conv2)))
                (case_option Fail
                  (\<lambda>(x', conv).
                      Done
                       (Some x',
                        obsf_converter
                         conv)))))) ?else"
      by(simp only: inline_gpv_stop_obsf_converter)
    also have "eq_\<I>_gpv ?X (exception_\<I> \<I>'') ?lhs \<dots>" using eq_\<I>_converter
      apply simp
      apply(simp add: map_gpv_bind_gpv gpv.map_id)
      apply(subst try_gpv_bind_gpv)
      apply(simp add: split_def option.case_distrib[where h="map_gpv _ _"] option.case_distrib[where h="fst"] option.case_distrib[where h="\<lambda>x. try_gpv x _"] cong del: option.case_cong)
      apply(subst option.case_distrib[where h=Done, symmetric, abs_def])+
      apply(fold map_gpv_conv_bind)
      apply(simp add: map_try_gpv gpv.map_comp o_def)
      apply(rule eq_\<I>_gpv_try_gpv_cong)
       apply(subst map_gpv'_id12)
       apply(subst map_gpv'_map_gpv_swap)
       apply(simp add: eq_\<I>_gpv_map_gpv id_def[symmetric])
       apply(subst map_gpv_conv_map_gpv')
       apply(subst gpv_stop_map')
       apply(subst option.map_id0)
       apply(subst map_gpv_conv_map_gpv'[symmetric])
       apply(subst map_gpv'_map_gpv_swap)
       apply(simp add: eq_\<I>_gpv_map_gpv id_def[symmetric])
       apply(rule eq_\<I>_gpv_reflI)
        apply(clarsimp split!: option.split simp add: eq_onp_def)
         apply(erule notE)
         apply(rule eq_\<I>_converter_reflI)
         apply simp
        apply(drule results_gpv_stop_SomeD)
        apply(rule conjI)
         apply(rule imageI)
         apply(drule run_converter.results_gpv_inline)
           apply(erule (1) WT_converterD)
          apply simp
         apply clarsimp
         apply(drule (2) WT_converterD_results)
         apply simp
        apply(rule disjI1)
        apply(rule exI conjI refl)+
         apply(drule run_converter.results_gpv_inline)
           apply(erule (1) WT_converterD)
          apply simp
         apply clarsimp
         apply(drule (2) WT_converterD_results)
         apply simp
         apply(drule run_converter.results_gpv_inline)
           apply(erule (1) WT_converterD)
          apply simp
        apply clarsimp
        apply(drule (1) pfinite_converterD)
        apply blast
       apply(rule WT_intro run_converter.WT_gpv_inline_invar|simp)+
        apply(erule (1) WT_converterD)
       apply simp
      apply(simp add: eq_onp_def)
      apply(rule disjI2)
      apply(rule eq_\<I>_converter_reflI)
      apply simp
      done
    finally (eq_\<I>_gpv_eq_OO2) show ?thesis .
  qed
qed

lemma resource_of_obsf_oracle_Fault [simp]:
  "resource_of_oracle (obsf_oracle oracle) Fault = const_resource Fault"
  by(coinduction)(auto simp add: rel_fun_def)

lemma obsf_resource_of_oracle [simp]:
  "obsf_resource (resource_of_oracle oracle s) = resource_of_oracle (obsf_oracle oracle) (OK s)"
  by(coinduction arbitrary: s rule: resource.coinduct_strong)
    (auto 4 3 simp add: rel_fun_def map_try_spmf spmf_rel_map intro!: rel_spmf_try_spmf rel_spmf_reflI)

lemma trace_callee_eq_obsf_Fault [simp]: "A \<turnstile>\<^sub>C obsf_oracle callee1(Fault) \<approx> obsf_oracle callee2(Fault)"
  by(coinduction rule: trace_callee_eq_coinduct) auto

lemma obsf_resource_eq_\<I>_cong: "A \<turnstile>\<^sub>R obsf_resource res1 \<sim> obsf_resource res2" if "A \<turnstile>\<^sub>R res1 \<sim> res2"
  using that by(coinduction arbitrary: res1 res2)(fastforce intro!: rel_spmf_try_spmf simp add: spmf_rel_map elim!: rel_spmf_mono dest: eq_resource_onD)

lemma trace_callee_eq_obsf_oracleI:
  assumes "trace_callee_eq callee1 callee2 A p q"
  shows "trace_callee_eq (obsf_oracle callee1) (obsf_oracle callee2) A (try_spmf (map_spmf OK p) (return_spmf Fault)) (try_spmf (map_spmf OK q) (return_spmf Fault))"
  using assms
proof(coinduction arbitrary: p q rule: trace_callee_eq_coinduct_strong)
  case (step z p q)
  have "?lhs = map_pmf (\<lambda>x. case x of None \<Rightarrow> Some Fault | Some y \<Rightarrow> Some (OK y)) (bind_spmf p (\<lambda>s'. map_spmf fst (callee1 s' z)))"
    by(auto simp add: bind_spmf_def try_spmf_def bind_assoc_pmf map_bind_pmf bind_map_pmf bind_return_pmf option.case_distrib[where h="map_pmf _"] option.case_distrib[where h=return_pmf, symmetric, abs_def] map_pmf_def[symmetric] pmf.map_comp o_def intro!: bind_pmf_cong[OF refl] pmf.map_cong[OF refl] split: option.split)
  also have "bind_spmf p (\<lambda>s'. map_spmf fst (callee1 s' z)) = bind_spmf q (\<lambda>s'. map_spmf fst (callee2 s' z))"
    using step(1)[THEN trace_callee_eqD[where xs="[]" and x=z]] step(2) by simp
  also have "map_pmf (\<lambda>x. case x of None \<Rightarrow> Some Fault | Some y \<Rightarrow> Some (OK y)) \<dots> = ?rhs"
    by(auto simp add: bind_spmf_def try_spmf_def bind_assoc_pmf map_bind_pmf bind_map_pmf bind_return_pmf option.case_distrib[where h="map_pmf _"] option.case_distrib[where h=return_pmf, symmetric, abs_def] map_pmf_def[symmetric] pmf.map_comp o_def intro!: bind_pmf_cong[OF refl] pmf.map_cong[OF refl] split: option.split)
  finally show ?case .
next
  case (sim x s1 s2 ye s1' s2' p q)
  have eq1: "bind_spmf (try_spmf (map_spmf OK p) (return_spmf Fault)) (\<lambda>s. obsf_oracle callee1 s x) =
     try_spmf (bind_spmf p (\<lambda>s. map_spmf (map_prod OK OK) (callee1 s x))) (return_spmf (Fault, Fault))"
    by(auto simp add: bind_spmf_def try_spmf_def bind_assoc_pmf bind_map_pmf bind_return_pmf intro!: bind_pmf_cong[OF refl] split: option.split)
  have eq2: "bind_spmf (try_spmf (map_spmf OK q) (return_spmf Fault)) (\<lambda>s. obsf_oracle callee2 s x) =
     try_spmf (bind_spmf q (\<lambda>s. map_spmf (map_prod OK OK) (callee2 s x))) (return_spmf (Fault, Fault))"
    by(auto simp add: bind_spmf_def try_spmf_def bind_assoc_pmf bind_map_pmf bind_return_pmf intro!: bind_pmf_cong[OF refl] split: option.split)

  show ?case
  proof(cases ye)
    case [simp]: Fault
    have "lossless_spmf (bind_spmf p (\<lambda>s. map_spmf (map_prod OK OK) (callee1 s x))) \<longleftrightarrow> lossless_spmf (bind_spmf q (\<lambda>s. map_spmf (map_prod OK OK) (callee2 s x)))"
      using sim(1)[THEN trace_callee_eqD[where xs="[]" and x=x], THEN arg_cong[where f="lossless_spmf"]] sim(2) by simp
    then have "?eq" by(simp add: eq1 eq2)(subst (1 2) cond_spmf_fst_try2, auto)
    then show ?thesis ..
  next
    case [simp]: (OK y)
    have eq3: "fst ` set_spmf (bind_spmf p (\<lambda>s. callee1 s x)) = fst ` set_spmf (bind_spmf q (\<lambda>s. callee2 s x))"
      using trace_callee_eqD[OF sim(1) _ sim(2), where xs="[]", THEN arg_cong[where f="set_spmf"]]
      by(auto simp add: bind_UNION image_UN del: equalityI)
    show ?thesis
    proof(cases "y \<in> fst ` set_spmf (bind_spmf p (\<lambda>s. callee1 s x))")
      case True
      have eq4: "cond_spmf_fst (bind_spmf p (\<lambda>s. map_spmf (apfst OK) (callee1 s x))) (OK y) = cond_spmf_fst (bind_spmf p (\<lambda>s. callee1 s x)) y"
        "cond_spmf_fst (bind_spmf q (\<lambda>s. map_spmf (apfst OK) (callee2 s x))) (OK y) = cond_spmf_fst (bind_spmf q (\<lambda>s. callee2 s x)) y"
        by(fold map_bind_spmf[unfolded o_def])(simp_all add: cond_spmf_fst_map_inj)
      have ?sim
        unfolding eq1 eq2
        apply(subst (1 2) cond_spmf_fst_try1)
          apply simp
         apply simp
        apply(rule exI[where x="cond_spmf_fst (bind_spmf p (\<lambda>s. map_spmf (apfst OK) (callee1 s x))) ye"])
        apply(rule exI[where x="cond_spmf_fst (bind_spmf q (\<lambda>s. map_spmf (apfst OK) (callee2 s x))) ye"])
        apply(subst (1 2) try_spmf_lossless)
        subgoal using True unfolding eq3 by(auto simp add: bind_UNION image_UN intro!: rev_bexI rev_image_eqI)
        subgoal using True by(auto simp add: bind_UNION image_UN intro!: rev_bexI rev_image_eqI)
        apply(simp add: map_cond_spmf_fst map_bind_spmf o_def spmf.map_comp map_prod_def split_def)
        apply(simp add: eq4)
        apply(rule trace_callee_eqI)
        subgoal for xs z
          using sim(1)[THEN trace_callee_eqD[where xs="(x, y) # xs" and x=z]] sim(2)
          apply simp
          done
        done
      then show ?thesis ..
    next
      case False
      with eq3 have "y \<notin> fst ` set_spmf (bind_spmf q (\<lambda>s. callee2 s x))" by auto
      with False have ?eq
        apply simp
        apply(subst (1 2) cond_spmf_fst_eq_return_None[THEN iffD2])
          apply(auto simp add: bind_UNION split: if_split_asm intro: rev_image_eqI)
        done
      then show ?thesis ..
    qed
  qed
qed

lemma trace_callee_eq'_obsf_resourceI:
  assumes " A \<turnstile>\<^sub>C callee1(s) \<approx> callee2(s')"
  shows "A \<turnstile>\<^sub>C obsf_oracle callee1(OK s) \<approx> obsf_oracle callee2(OK s')"
  using assms[THEN trace_callee_eq_obsf_oracleI] by simp

lemma trace_eq_obsf_resourceI:
  assumes "A \<turnstile>\<^sub>R res1 \<approx> res2"
  shows "A \<turnstile>\<^sub>R obsf_resource res1 \<approx> obsf_resource res2"
  using assms
  apply(subst (2 4) resource_of_oracle_run_resource[symmetric])
  apply(subst (asm) (1 2) resource_of_oracle_run_resource[symmetric])
  apply(drule trace_callee_eq'_obsf_resourceI)
  apply simp
  apply(simp add: resource_of_oracle_run_resource)
  done

lemma spmf_run_obsf_oracle_obsf_distinguisher [rule_format]:
  defines "eg1 \<equiv> exec_gpv" and "eg2 \<equiv> exec_gpv" shows
  "spmf (map_spmf fst (eg1 (obsf_oracle oracle) (obsf_distinguisher gpv) (OK s))) True =
   spmf (map_spmf fst (eg2 oracle gpv s)) True"
  (is "?lhs = ?rhs")
proof(rule antisym)
  show "?lhs \<le> ?rhs" unfolding eg1_def
  proof(induction arbitrary: gpv s rule: exec_gpv_fixp_induct_strong)
    case adm show ?case by simp
    case bottom show ?case by simp
    case (step exec_gpv')
    show ?case unfolding eg2_def
      apply(subst exec_gpv.simps)
      apply(clarsimp simp add: obsf_distinguisher_def bind_map_spmf map_bind_spmf o_def)
      apply(subst (1 2) spmf_bind)
      apply(rule Bochner_Integration.integral_mono)
        apply(rule measure_spmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)
       apply(rule measure_spmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)
      apply(clarsimp split: generat.split simp add: map_bind_spmf o_def)
      apply(simp add: try_spmf_def bind_spmf_pmf_assoc bind_map_pmf)
      apply(simp add: bind_spmf_def)
      apply(subst (1 2) pmf_bind)
      apply(rule Bochner_Integration.integral_mono)
        apply(rule measure_pmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)
       apply(rule measure_pmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)
      apply(clarsimp split!: option.split simp add: bind_return_pmf)
       apply(rule antisym)
        apply(rule order_trans)
         apply(rule step.hyps[THEN ord_spmf_map_spmfI, THEN ord_spmf_eq_leD])
        apply simp
       apply(simp)
      apply(rule step.IH[unfolded eg2_def obsf_distinguisher_def])
      done
  qed

  show "?rhs \<le> ?lhs" unfolding eg2_def
  proof(induction arbitrary: gpv s rule: exec_gpv_fixp_induct_strong)
    case adm show ?case by simp
    case bottom show ?case by simp
    case (step exec_gpv')
    show ?case unfolding eg1_def
      apply(subst exec_gpv.simps)
      apply(clarsimp simp add: obsf_distinguisher_def bind_map_spmf map_bind_spmf o_def)
      apply(subst (1 2) spmf_bind)
      apply(rule Bochner_Integration.integral_mono)
        apply(rule measure_spmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)
       apply(rule measure_spmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)
      apply(clarsimp split: generat.split simp add: map_bind_spmf o_def)
      apply(simp add: try_spmf_def bind_spmf_pmf_assoc bind_map_pmf)
      apply(simp add: bind_spmf_def)
      apply(subst (1 2) pmf_bind)
      apply(rule Bochner_Integration.integral_mono)
        apply(rule measure_pmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)
       apply(rule measure_pmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)
      apply(clarsimp split!: option.split simp add: bind_return_pmf)
      apply(rule step.IH[unfolded eg1_def obsf_distinguisher_def])
      done
  qed
qed

lemma spmf_obsf_distinguisher_obsf_resource_True:
  "spmf (connect_obsf (obsf_distinguisher \<A>) (obsf_resource res)) True = spmf (connect \<A> res) True"
  unfolding connect_def
  apply(subst (2) resource_of_oracle_run_resource[symmetric])
  apply(simp add: exec_gpv_resource_of_oracle spmf.map_comp spmf_run_obsf_oracle_obsf_distinguisher)
  done

lemma advantage_obsf_distinguisher:
  "advantage (obsf_distinguisher \<A>) (obsf_resource ideal_resource) (obsf_resource real_resource) =
   advantage \<A> ideal_resource real_resource"
  unfolding advantage_def by(simp add: spmf_obsf_distinguisher_obsf_resource_True)

end