(* Author: Andrew Boyton, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

header "Instantiating capDL as a separation algebra."

theory Abstract_Separation_D
imports "../../Sep_Tactics" Types_D "../../Map_Extra"
begin

(**************************************
 * Start of lemmas to move elsewhere. *
 **************************************)

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

lemma union_intersection:
  "A \<inter> (A \<union> B) = A"
  "B \<inter> (A \<union> B) = B"
  "(A \<union> B) \<inter> A = A"
  "(A \<union> B) \<inter> B = B"
  by fastforce+

lemma union_intersection1: "A \<inter> (A \<union> B) = A"
  by (rule inf_sup_absorb)
lemma union_intersection2: "B \<inter> (A \<union> B) = B"
  by fastforce

(* 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

(************************************
 * End of lemmas to move elsewhere. *
 ************************************)

(* The state for separation logic has:
   * The memory heap.
   * A function for which objects own which fields.
     In capDL, we say that an object either owns all of its fields, or none of them.
   These are both taken from the cdl_state.
 *)

datatype sep_state = SepState cdl_heap cdl_ghost_state

(* Functions to get the heap and the ghost_state from the sep_state. *)
primrec sep_heap :: "sep_state \<Rightarrow> cdl_heap"
where  "sep_heap (SepState h gs) = h"

primrec sep_ghost_state :: "sep_state \<Rightarrow> cdl_ghost_state"
where  "sep_ghost_state (SepState h gs) = gs"

definition
  the_set :: "'a option set \<Rightarrow> 'a set"
where
  "the_set xs = {x. Some x \<in> xs}"

lemma the_set_union [simp]:
  "the_set (A \<union> B) = the_set A \<union> the_set B"
  by (fastforce simp: the_set_def)

lemma the_set_inter [simp]:
  "the_set (A \<inter> B) = the_set A \<inter> the_set B"
  by (fastforce simp: the_set_def)

lemma the_set_inter_empty:
  "A \<inter> B = {} \<Longrightarrow> the_set A \<inter> the_set B = {}"
  by (fastforce simp: the_set_def)

(* As the capDL operations mostly take the state (rather than the heap)
 * we need to redefine some of them again to take just the heap.
 *)
definition
  slots_of_heap :: "cdl_heap \<Rightarrow> cdl_object_id \<Rightarrow> cdl_cap_map"
where
  "slots_of_heap h \<equiv> \<lambda>obj_id.
  case h obj_id of
    None \<Rightarrow> empty
  | Some obj \<Rightarrow> object_slots obj"

(* Adds new caps to an object. It won't overwrite on a collision. *)
definition
  add_to_slots :: "cdl_cap_map \<Rightarrow> cdl_object \<Rightarrow> cdl_object"
where
  "add_to_slots new_val obj \<equiv> update_slots (new_val ++ (object_slots obj)) obj"

lemma add_to_slots_assoc:
  "add_to_slots x (add_to_slots (y ++ z) obj) =
   add_to_slots (x ++ y) (add_to_slots z obj)"
  apply (clarsimp simp: add_to_slots_def update_slots_def object_slots_def)
  apply (fastforce simp: cdl_tcb.splits cdl_cnode.splits
                 split: cdl_object.splits)
  done

(* Lemmas about add_to_slots, update_slots and object_slots. *)
lemma add_to_slots_twice [simp]:
  "add_to_slots x (add_to_slots y a) = add_to_slots (x ++ y) a"
  by (fastforce simp: add_to_slots_def update_slots_def object_slots_def
              split: cdl_object.splits)

lemma slots_of_heap_empty [simp]: "slots_of_heap empty object_id = empty"
  by (simp add: slots_of_heap_def)

lemma slots_of_heap_empty2 [simp]:
  "h obj_id = None \<Longrightarrow> slots_of_heap h obj_id = empty"
  by (simp add: slots_of_heap_def)

lemma update_slots_add_to_slots_empty [simp]:
  "update_slots empty (add_to_slots new obj) = update_slots empty obj"
  by (clarsimp simp: update_slots_def add_to_slots_def split:cdl_object.splits)

lemma update_object_slots_id [simp]: "update_slots (object_slots a) a = a"
  by (clarsimp simp: update_slots_def object_slots_def
              split: cdl_object.splits)

lemma update_slots_of_heap_id [simp]:
  "h obj_id = Some obj \<Longrightarrow> update_slots (slots_of_heap h obj_id) obj = obj"
  by (clarsimp simp: update_slots_def slots_of_heap_def object_slots_def
              split: cdl_object.splits)

lemma add_to_slots_empty [simp]: "add_to_slots empty h = h"
  by (simp add: add_to_slots_def)

lemma update_slots_eq:
  "update_slots a o1 = update_slots a o2 \<Longrightarrow> update_slots b o1 = update_slots b o2"
  by (fastforce simp: update_slots_def cdl_tcb.splits cdl_cnode.splits
              split: cdl_object.splits)

(* If there are not two conflicting objects at a position in two states.
 * Objects conflict if their types are different or their ghost_states collide.
 *)
definition
  not_conflicting_objects :: "sep_state \<Rightarrow> sep_state \<Rightarrow> cdl_object_id \<Rightarrow> bool"
where
  "not_conflicting_objects state_a state_b = (\<lambda>obj_id.
 let heap_a = sep_heap state_a;
     heap_b = sep_heap state_b;
     gs_a = sep_ghost_state state_a;
     gs_b = sep_ghost_state state_b
 in case (heap_a obj_id, heap_b obj_id) of
    (Some o1, Some o2) \<Rightarrow> object_type o1 = object_type o2 \<and> gs_a obj_id \<inter> gs_b obj_id = {}
   | _ \<Rightarrow> True)"

(* "Cleans" slots to conform with the compontents. *)
definition
  clean_slots :: "cdl_cap_map \<Rightarrow> cdl_components \<Rightarrow> cdl_cap_map"
where
  "clean_slots slots cmp \<equiv> slots |` the_set cmp"

(* Sets the fields of an object to a "clean" state.
   Because a frame's size is part of it's type, we don't reset it. *)
definition
  object_clean_fields :: "cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_clean_fields obj cmp \<equiv> if None \<in> cmp then obj else case obj of
    Tcb x \<Rightarrow> Tcb (x\<lparr>cdl_tcb_fault_endpoint := undefined\<rparr>)
  | CNode x \<Rightarrow> CNode (x\<lparr>cdl_cnode_size_bits := undefined \<rparr>)
  | _ \<Rightarrow> obj"

(* Sets the slots of an object to a "clean" state. *)
definition
  object_clean_slots :: "cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_clean_slots obj cmp \<equiv> update_slots (clean_slots (object_slots obj) cmp) obj"

(* Sets an object to a "clean" state. *)
definition
  object_clean :: "cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_clean obj gs \<equiv> object_clean_slots (object_clean_fields obj gs) gs"

(* Overrides the left object with the attributes of the right, as specified by the ghost state.
   If the components for an object are empty, then this object is treated as empty, and thus ignored.
 *)
definition
  object_add :: "cdl_object \<Rightarrow> cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_add obj_a obj_b cmps_a cmps_b \<equiv>
  let clean_obj_a = object_clean obj_a cmps_a;
      clean_obj_b = object_clean obj_b cmps_b
  in if (cmps_a = {})
     then clean_obj_b
     else if (cmps_b = {})
     then clean_obj_a
     else if (None \<in> cmps_b)
     then (update_slots (object_slots clean_obj_a ++ object_slots clean_obj_b) clean_obj_b)
     else (update_slots (object_slots clean_obj_a ++ object_slots clean_obj_b) clean_obj_a)"

(* Heaps are added by adding their repsective objects.
 * The ghost state tells us which object's fields should be taken.
 * Adding objects of the same type adds their caps
 *   (overwrites the left with the right).
 *)
definition
  cdl_heap_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> cdl_heap"
where
  "cdl_heap_add state_a state_b \<equiv> \<lambda>obj_id.
 let heap_a = sep_heap state_a;
     heap_b = sep_heap state_b;
     gs_a = sep_ghost_state state_a;
     gs_b = sep_ghost_state state_b
 in case heap_b obj_id of
      None \<Rightarrow> heap_a obj_id
    | Some obj_b \<Rightarrow> case heap_a obj_id of
                     None \<Rightarrow> heap_b obj_id
                   | Some obj_a \<Rightarrow> Some (object_add obj_a obj_b (gs_a obj_id) (gs_b obj_id))"

(* Heaps are added by adding their repsective objects.
 * The ghost state tells us which object's fields should be taken.
 * Adding objects of the same type adds their caps
 *   (overwrites the left with the right).
 *)
definition
  cdl_ghost_state_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> cdl_ghost_state"
where
  "cdl_ghost_state_add state_a state_b \<equiv> \<lambda>obj_id.
 let heap_a = sep_heap state_a;
     heap_b = sep_heap state_b;
     gs_a = sep_ghost_state state_a;
     gs_b = sep_ghost_state state_b
 in      if heap_a obj_id = None \<and> heap_b obj_id \<noteq> None then gs_b obj_id
    else if heap_b obj_id = None \<and> heap_a obj_id \<noteq> None then gs_a obj_id
    else gs_a obj_id \<union> gs_b obj_id"

(* Adding states adds their heaps,
 *  and each objects owns whichever fields it owned in either heap.
 *)
definition
  sep_state_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> sep_state"
where
  "sep_state_add state_a state_b \<equiv>
  let
    heap_a = sep_heap state_a;
    heap_b = sep_heap state_b;
    gs_a = sep_ghost_state state_a;
    gs_b = sep_ghost_state state_b
  in
    SepState (cdl_heap_add state_a state_b) (cdl_ghost_state_add state_a state_b)"

(* Heaps are disjoint if for all of their objects:
   * the caps of their respective objects are disjoint,
   * their respective objects don't conflict,
   * they don't both own any of the same fields.
*)
definition
  sep_state_disj :: "sep_state \<Rightarrow> sep_state \<Rightarrow> bool"
where
  "sep_state_disj state_a state_b \<equiv>
  let
    heap_a = sep_heap state_a;
    heap_b = sep_heap state_b;
    gs_a = sep_ghost_state state_a;
    gs_b = sep_ghost_state state_b
  in
    \<forall>obj_id. not_conflicting_objects state_a state_b obj_id"

lemma not_conflicting_objects_comm:
  "not_conflicting_objects h1 h2 obj = not_conflicting_objects h2 h1 obj"
  apply (clarsimp simp: not_conflicting_objects_def split:option.splits)
  apply (fastforce simp: update_slots_def cdl_tcb.splits cdl_cnode.splits
              split: cdl_object.splits)
  done

lemma object_clean_comm:
  "\<lbrakk>object_type obj_a = object_type obj_b;
    object_slots obj_a ++ object_slots obj_b = object_slots obj_b ++ object_slots obj_a; None \<notin> cmp\<rbrakk>
  \<Longrightarrow> object_clean (add_to_slots (object_slots obj_a) obj_b) cmp =
      object_clean (add_to_slots (object_slots obj_b) obj_a) cmp"
  apply (clarsimp simp: object_type_def split: cdl_object.splits)
  apply (clarsimp simp: object_clean_def object_clean_slots_def object_clean_fields_def
                        add_to_slots_def object_slots_def update_slots_def
                        cdl_tcb.splits cdl_cnode.splits
                 split: cdl_object.splits)+
  done

lemma add_to_slots_object_slots:
  "object_type y = object_type z
 \<Longrightarrow> add_to_slots (object_slots (add_to_slots (x) y)) z =
     add_to_slots (x ++ object_slots y) z"
  apply (clarsimp simp: add_to_slots_def update_slots_def object_slots_def)
  apply (fastforce simp: object_type_def cdl_tcb.splits cdl_cnode.splits
                 split: cdl_object.splits)
  done

lemma not_conflicting_objects_empty [simp]:
  "not_conflicting_objects s (SepState empty (\<lambda>obj_id. {})) obj_id"
  by (clarsimp simp: not_conflicting_objects_def split:option.splits)

lemma empty_not_conflicting_objects [simp]:
  "not_conflicting_objects (SepState empty (\<lambda>obj_id. {})) s obj_id"
  by (clarsimp simp: not_conflicting_objects_def split:option.splits)

lemma not_conflicting_objects_empty_object [elim!]:
  "(sep_heap x) obj_id = None \<Longrightarrow> not_conflicting_objects x y obj_id"
  by (clarsimp simp: not_conflicting_objects_def)

lemma empty_object_not_conflicting_objects [elim!]:
  "(sep_heap y) obj_id = None \<Longrightarrow> not_conflicting_objects x y obj_id"
  apply (drule not_conflicting_objects_empty_object [where y=x])
  apply (clarsimp simp: not_conflicting_objects_comm)
  done

lemma cdl_heap_add_empty [simp]:
 "cdl_heap_add (SepState h gs) (SepState empty (\<lambda>obj_id. {})) = h"
  by (simp add: cdl_heap_add_def)

lemma empty_cdl_heap_add [simp]:
  "cdl_heap_add (SepState empty (\<lambda>obj_id. {})) (SepState h gs)= h"
  apply (simp add: cdl_heap_add_def)
  apply (rule ext)
  apply (clarsimp split: option.splits)
  done

lemma map_add_result_empty1: "a ++ b = empty \<Longrightarrow> a = empty"
  apply (subgoal_tac "dom (a++b) = {}")
   apply (subgoal_tac "dom (a) = {}")
    apply clarsimp
   apply (unfold dom_map_add)[1]
   apply clarsimp
  apply clarsimp
  done

lemma map_add_result_empty2: "a ++ b = empty \<Longrightarrow> b = empty"
  apply (subgoal_tac "dom (a++b) = {}")
   apply (subgoal_tac "dom (a) = {}")
    apply clarsimp
   apply (unfold dom_map_add)[1]
   apply clarsimp
  apply clarsimp
  done

lemma map_add_emptyE [elim!]: "\<lbrakk>a ++ b = empty; \<lbrakk>a = empty; b = empty\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  apply (frule map_add_result_empty1)
  apply (frule map_add_result_empty2)
  apply clarsimp
  done

lemma clean_slots_empty [simp]:
  "clean_slots empty cmp = empty"
  by (clarsimp simp: clean_slots_def)

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_type_object_clean_slots [simp]:
  "object_type (object_clean_slots x cmp) = object_type x"
  by (clarsimp simp: object_clean_slots_def)

lemma object_type_object_clean_fields [simp]:
  "object_type (object_clean_fields x cmp) = object_type x"
  by (clarsimp simp: object_clean_fields_def object_type_def split: cdl_object.splits)

lemma object_type_object_clean [simp]:
  "object_type (object_clean x cmp) = object_type x"
  by (clarsimp simp: object_clean_def)

lemma object_type_add_to_slots [simp]:
  "object_type (add_to_slots slots x) = object_type x"
  by (clarsimp simp: object_type_def add_to_slots_def update_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 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_slots_object_clean_fields [simp]:
  "object_slots (object_clean_fields obj cmp) = object_slots obj"
  by (clarsimp simp: object_slots_def object_clean_fields_def split: cdl_object.splits)

lemma object_slots_object_clean_slots [simp]:
  "object_slots (object_clean_slots obj cmp) = clean_slots (object_slots obj) cmp"
  by (clarsimp simp: object_clean_slots_def object_slots_def update_slots_def split: cdl_object.splits)

lemma object_slots_object_clean [simp]:
  "object_slots (object_clean obj cmp) = clean_slots (object_slots obj) cmp"
  by (clarsimp simp: object_clean_def)

lemma object_slots_add_to_slots [simp]:
  "object_type y = object_type z \<Longrightarrow> object_slots (add_to_slots (object_slots y) z) = object_slots y ++ object_slots z"
  by (clarsimp simp: object_slots_def add_to_slots_def update_slots_def object_type_def split: cdl_object.splits)

lemma update_slots_object_clean_slots [simp]:
  "update_slots slots (object_clean_slots obj cmp) = update_slots slots obj"
  by (clarsimp simp: object_clean_slots_def)

lemma object_clean_fields_idem [simp]:
  "object_clean_fields (object_clean_fields obj cmp) cmp = object_clean_fields obj cmp"
  by (clarsimp simp: object_clean_fields_def split: cdl_object.splits)

lemma object_clean_slots_idem [simp]:
  "object_clean_slots (object_clean_slots obj cmp) cmp = object_clean_slots obj cmp"
  apply (case_tac  "has_slots obj")
  apply (clarsimp simp: object_clean_slots_def clean_slots_def)+
  done

lemma object_clean_fields_object_clean_slots [simp]:
  "object_clean_fields (object_clean_slots obj gs) gs = object_clean_slots (object_clean_fields obj gs) gs"
  by (clarsimp simp: object_clean_fields_def object_clean_slots_def
                     clean_slots_def object_slots_def update_slots_def
              split: cdl_object.splits)

lemma object_clean_idem [simp]:
  "object_clean (object_clean obj cmp) cmp = object_clean obj cmp"
  by (clarsimp simp: object_clean_def)

lemma has_slots_object_clean_slots:
 "has_slots (object_clean_slots obj cmp) = has_slots obj"
  by (clarsimp simp: has_slots_def object_clean_slots_def update_slots_def split: cdl_object.splits)

lemma has_slots_object_clean_fields:
 "has_slots (object_clean_fields obj cmp) = has_slots obj"
  by (clarsimp simp: has_slots_def object_clean_fields_def split: cdl_object.splits)

lemma has_slots_object_clean:
 "has_slots (object_clean obj cmp) = has_slots obj"
  by (clarsimp simp: object_clean_def has_slots_object_clean_slots has_slots_object_clean_fields)

lemma object_slots_update_slots_object_clean_fields [simp]:
  "object_slots (update_slots slots (object_clean_fields obj cmp)) = object_slots (update_slots slots obj)"
  apply (case_tac "has_slots obj")
   apply (clarsimp simp: has_slots_object_clean_fields)+
  done

lemma object_clean_fields_update_slots [simp]:
 "object_clean_fields (update_slots slots obj) cmp = update_slots slots (object_clean_fields obj cmp)"
  by (clarsimp simp: object_clean_fields_def update_slots_def split: cdl_object.splits)

lemma object_clean_fields_twice [simp]:
  "(object_clean_fields (object_clean_fields obj cmp') cmp) = object_clean_fields obj (cmp \<inter> cmp')"
  by (clarsimp simp: object_clean_fields_def split: cdl_object.splits)

lemma update_slots_object_clean_fields:
  "\<lbrakk>None \<notin> cmps; None \<notin> cmps'; object_type obj = object_type obj'\<rbrakk>
    \<Longrightarrow> update_slots slots (object_clean_fields obj cmps) =
        update_slots slots (object_clean_fields obj' cmps')"
  by (fastforce simp: update_slots_def object_clean_fields_def object_type_def split: cdl_object.splits)

lemma object_clean_fields_no_slots:
  "\<lbrakk>None \<notin> cmps; None \<notin> cmps'; object_type obj = object_type obj'; \<not> has_slots obj; \<not> has_slots obj'\<rbrakk>
    \<Longrightarrow> object_clean_fields obj cmps = object_clean_fields obj' cmps'"
  by (fastforce simp: object_clean_fields_def object_type_def has_slots_def split: cdl_object.splits)

lemma update_slots_object_clean:
  "\<lbrakk>None \<notin> cmps; None \<notin> cmps'; object_type obj = object_type obj'\<rbrakk>
   \<Longrightarrow> update_slots slots (object_clean obj cmps) = update_slots slots (object_clean obj' cmps')"
  apply (clarsimp simp: object_clean_def object_clean_slots_def)
  apply (erule (2) update_slots_object_clean_fields)
  done

lemma cdl_heap_add_assoc':
  "\<forall>obj_id. not_conflicting_objects x z obj_id \<and>
            not_conflicting_objects y z obj_id \<and>
            not_conflicting_objects x z obj_id \<Longrightarrow>
   cdl_heap_add (SepState (cdl_heap_add x y) (cdl_ghost_state_add x y)) z =
   cdl_heap_add x (SepState (cdl_heap_add y z) (cdl_ghost_state_add y z))"
  apply (rule ext)
  apply (rename_tac obj_id)
  apply (erule_tac x=obj_id in allE)
  apply (clarsimp simp: cdl_heap_add_def cdl_ghost_state_add_def not_conflicting_objects_def)
  apply (simp add: Let_unfold split: option.splits)
  apply (rename_tac obj_y obj_x obj_z)
  apply (clarsimp simp: object_add_def clean_slots_def object_clean_def object_clean_slots_def Let_unfold)
  apply (case_tac "has_slots obj_z")
   apply (subgoal_tac "has_slots obj_y")
    apply (subgoal_tac "has_slots obj_x")
     apply ((clarsimp simp: has_slots_object_clean_fields has_slots_object_clean_slots has_slots_object_clean
                           map_add_restrict union_intersection |
            drule inter_empty_not_both |
            erule update_slots_object_clean_fields |
            erule object_type_has_slots, simp |
            simp | safe)+)[3]
   apply (subgoal_tac "\<not> has_slots obj_y")
    apply (subgoal_tac "\<not> has_slots obj_x")
     apply ((clarsimp simp: has_slots_object_clean_fields has_slots_object_clean_slots has_slots_object_clean
                           map_add_restrict union_intersection |
            drule inter_empty_not_both |
            erule object_clean_fields_no_slots |
            erule object_type_has_slots, simp |
            simp | safe)+)
   apply (fastforce simp: object_type_has_slots)+
  done

lemma cdl_heap_add_assoc:
  "\<lbrakk>sep_state_disj x y; sep_state_disj y z; sep_state_disj x z\<rbrakk>
  \<Longrightarrow> cdl_heap_add (SepState (cdl_heap_add x y) (cdl_ghost_state_add x y)) z =
      cdl_heap_add x (SepState (cdl_heap_add y z) (cdl_ghost_state_add y z))"
  apply (clarsimp simp: sep_state_disj_def)
  apply (cut_tac cdl_heap_add_assoc')
   apply fast
  apply fastforce
  done

lemma cdl_ghost_state_add_assoc:
  "cdl_ghost_state_add (SepState (cdl_heap_add x y) (cdl_ghost_state_add x y)) z =
   cdl_ghost_state_add x (SepState (cdl_heap_add y z) (cdl_ghost_state_add y z))"
  apply (rule ext)
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def Let_unfold)
  done

lemma clean_slots_map_add_comm:
  "cmps_a \<inter> cmps_b = {}
  \<Longrightarrow> clean_slots slots_a cmps_a ++ clean_slots slots_b cmps_b =
      clean_slots slots_b cmps_b ++ clean_slots slots_a cmps_a"
  apply (clarsimp simp: clean_slots_def)
  apply (drule the_set_inter_empty)
  apply (erule map_add_restrict_comm)
  done

lemma object_clean_all:
  "object_type obj_a = object_type obj_b \<Longrightarrow> object_clean obj_b {} = object_clean obj_a {}"
  apply (clarsimp simp: object_clean_def object_clean_slots_def clean_slots_def the_set_def)
  apply (rule_tac cmps'1="{}" and obj'1="obj_a" in trans [OF update_slots_object_clean_fields], fastforce+)
  done

lemma object_add_comm:
  "\<lbrakk>object_type obj_a = object_type obj_b; cmps_a \<inter> cmps_b = {}\<rbrakk>
  \<Longrightarrow> object_add obj_a obj_b cmps_a cmps_b = object_add obj_b obj_a cmps_b cmps_a"
  apply (clarsimp simp: object_add_def Let_unfold)
  apply (rule conjI | clarsimp)+
    apply fastforce
  apply (rule conjI | clarsimp)+
   apply (drule_tac slots_a = "object_slots obj_a" and slots_b = "object_slots obj_b" in clean_slots_map_add_comm)
   apply fastforce
  apply (rule conjI | clarsimp)+
   apply (drule_tac slots_a = "object_slots obj_a" and slots_b = "object_slots obj_b" in clean_slots_map_add_comm)
   apply fastforce
  apply (rule conjI | clarsimp)+
   apply (erule object_clean_all)
  apply (clarsimp)
  apply (rule_tac cmps'1=cmps_b and obj'1=obj_b in trans [OF update_slots_object_clean], assumption+)
  apply (drule_tac slots_a = "object_slots obj_a" and slots_b = "object_slots obj_b" in clean_slots_map_add_comm)
  apply fastforce
  done

lemma sep_state_add_comm:
  "sep_state_disj x y \<Longrightarrow> sep_state_add x y = sep_state_add y x"
  apply (clarsimp simp: sep_state_add_def sep_state_disj_def)
  apply (rule conjI)
   apply (case_tac x, case_tac y, clarsimp)
   apply (rename_tac heap_a gs_a heap_b gs_b)
   apply (clarsimp simp: cdl_heap_add_def Let_unfold)
   apply (rule ext)
   apply (case_tac "heap_a obj_id")
    apply (case_tac "heap_b obj_id", simp_all add: slots_of_heap_def)
   apply (case_tac "heap_b obj_id", simp_all add: slots_of_heap_def)
   apply (rename_tac obj_a obj_b)
   apply (erule_tac x=obj_id in allE)
   apply (rule object_add_comm)
    apply (clarsimp simp: not_conflicting_objects_def)
   apply (clarsimp simp: not_conflicting_objects_def)
  apply (rule ext, fastforce simp: cdl_ghost_state_add_def Let_unfold Un_commute)
  done

lemma add_to_slots_comm:
  "\<lbrakk>object_slots y_obj \<bottom> object_slots z_obj; update_slots empty y_obj = update_slots empty z_obj \<rbrakk>
  \<Longrightarrow> add_to_slots (object_slots z_obj) y_obj = add_to_slots (object_slots y_obj) z_obj"
  by (fastforce simp: add_to_slots_def update_slots_def object_slots_def
                     cdl_tcb.splits cdl_cnode.splits
              dest!: map_add_com
              split: cdl_object.splits)

lemma cdl_heap_add_none1:
  "cdl_heap_add x y obj_id = None \<Longrightarrow> (sep_heap x) obj_id = None"
  by (clarsimp simp: cdl_heap_add_def Let_unfold split:option.splits split_if_asm)

lemma cdl_heap_add_none2:
  "cdl_heap_add x y obj_id = None \<Longrightarrow> (sep_heap y) obj_id = None"
  by (clarsimp simp: cdl_heap_add_def Let_unfold split:option.splits split_if_asm)

lemma object_type_object_addL:
  "object_type obj = object_type obj'
  \<Longrightarrow> object_type (object_add obj obj' cmp cmp') = object_type obj"
  by (clarsimp simp: object_add_def Let_unfold)

lemma object_type_object_addR:
  "object_type obj = object_type obj'
  \<Longrightarrow> object_type (object_add obj obj' cmp cmp') = object_type obj'"
  by (clarsimp simp: object_add_def Let_unfold)

lemma sep_state_add_disjL:
  "\<lbrakk>sep_state_disj y z; sep_state_disj x (sep_state_add y z)\<rbrakk> \<Longrightarrow> sep_state_disj x y"
  apply (clarsimp simp: sep_state_disj_def sep_state_add_def)
  apply (rename_tac obj_id)
  apply (clarsimp simp: not_conflicting_objects_def)
  apply (erule_tac x=obj_id in allE)+
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def object_type_object_addR
                 split: option.splits)
  done

lemma sep_state_add_disjR:
  "\<lbrakk>sep_state_disj y z; sep_state_disj x (sep_state_add y z)\<rbrakk> \<Longrightarrow> sep_state_disj x z"
  apply (clarsimp simp: sep_state_disj_def sep_state_add_def)
  apply (rename_tac obj_id)
  apply (clarsimp simp: not_conflicting_objects_def)
  apply (erule_tac x=obj_id in allE)+
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def object_type_object_addR
                 split: option.splits)
  done

lemma sep_state_add_disj:
  "\<lbrakk>sep_state_disj y z; sep_state_disj x y; sep_state_disj x z\<rbrakk> \<Longrightarrow> sep_state_disj x (sep_state_add y z)"
  apply (clarsimp simp: sep_state_disj_def sep_state_add_def)
  apply (rename_tac obj_id)
  apply (clarsimp simp: not_conflicting_objects_def)
  apply (erule_tac x=obj_id in allE)+
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def object_type_object_addR
                 split: option.splits)
  done

(*********************************************)
(* Definition of separation logic for capDL. *)
(*********************************************)

instantiation "sep_state" :: zero
begin
  definition "0 \<equiv> SepState empty (\<lambda>obj_id. {})"
  instance ..
end

instantiation "sep_state" :: stronger_sep_algebra
begin

definition "(op ##) \<equiv> sep_state_disj"
definition "(op +) \<equiv> sep_state_add"

(**********************************************
 * The proof that this is a separation logic. *
 **********************************************)

instance
  apply default
(* x ## 0 *)
       apply (simp add: sep_disj_sep_state_def sep_state_disj_def zero_sep_state_def)
(* x ## y \<Longrightarrow> y ## x *)
      apply (clarsimp simp: not_conflicting_objects_comm sep_disj_sep_state_def sep_state_disj_def Let_unfold
                            map_disj_com not_conflicting_objects_comm Int_commute)
(* x + 0 = x *)
     apply (simp add: plus_sep_state_def sep_state_add_def zero_sep_state_def)
     apply (case_tac x)
     apply (clarsimp simp: cdl_heap_add_def)
     apply (rule ext)
     apply (clarsimp simp: cdl_ghost_state_add_def split:split_if_asm)
(* x ## y \<Longrightarrow> x + y = y + x *)
    apply (clarsimp simp: plus_sep_state_def sep_disj_sep_state_def)
    apply (erule sep_state_add_comm)
(* (x + y) + z = x + (y + z) *)
   apply (simp add: plus_sep_state_def sep_state_add_def)
   apply (rule conjI)
   apply (clarsimp simp: sep_disj_sep_state_def)
    apply (erule (2) cdl_heap_add_assoc)
   apply (rule cdl_ghost_state_add_assoc)
(* x ## y + z = (x ## y \<and> x ## z) *)
  apply (clarsimp simp: plus_sep_state_def sep_disj_sep_state_def)
  apply (rule iffI)
   (* x ## y + z \<Longrightarrow> (x ## y \<and> x ## z) *)
   apply (rule conjI)
    (* x ## y + z \<Longrightarrow> (x ## y) *)
    apply (erule (1) sep_state_add_disjL)
   (* x ## y + z \<Longrightarrow> (x ## z) *)
   apply (erule (1) sep_state_add_disjR)
  (* x ## y + z \<Longleftarrow> (x ## y \<and> x ## z) *)
  apply clarsimp
  apply (erule (2) sep_state_add_disj)
  done

end

end


(*  Title:      HOL/Bali/Table.thy
    Author:     David von Oheimb
*)
subsection \<open>Abstract tables and their implementation as lists\<close>

theory Table imports Basis begin

text \<open>
design issues:
\begin{itemize}
\item definition of table: infinite map vs. list vs. finite set
      list chosen, because:
  \begin{itemize}
  \item[+]  a priori finite
  \item[+]  lookup is more operational than for finite set
  \item[-]  not very abstract, but function table converts it to abstract
            mapping
  \end{itemize}
\item coding of lookup result: Some/None vs. value/arbitrary
   Some/None chosen, because:
  \begin{itemize}
  \item[++] makes definedness check possible (applies also to finite set),
     which is important for the type standard, hiding/overriding, etc.
     (though it may perhaps be possible at least for the operational semantics
      to treat programs as infinite, i.e. where classes, fields, methods etc.
      of any name are considered to be defined)
  \item[-]  sometimes awkward case distinctions, alleviated by operator 'the'
  \end{itemize}
\end{itemize}
\<close>

type_synonym ('a, 'b) table    \<comment> \<open>table with key type 'a and contents type 'b\<close>
      = "'a \<rightharpoonup> 'b"
type_synonym ('a, 'b) tables   \<comment> \<open>non-unique table with key 'a and contents 'b\<close>
      = "'a \<Rightarrow> 'b set"

subsubsection "map of / table of"

abbreviation
  table_of :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) table"   \<comment> \<open>concrete table\<close>
  where "table_of \<equiv> map_of"

translations
  (type) "('a, 'b) table" <= (type) "'a \<rightharpoonup> 'b"

(* ### To map *)
lemma map_add_find_left[simp]: "n k = None \<Longrightarrow> (m ++ n) k = m k"
  by (simp add: map_add_def)

subsubsection \<open>Conditional Override\<close>

definition cond_override :: "('b \<Rightarrow>'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b)table \<Rightarrow> ('a, 'b)table \<Rightarrow> ('a, 'b) table" where

\<comment> \<open>when merging tables old and new, only override an entry of table old when
   the condition cond holds\<close>
"cond_override cond old new =
 (\<lambda>k.
  (case new k of
     None         \<Rightarrow> old k
   | Some new_val \<Rightarrow> (case old k of
                        None         \<Rightarrow> Some new_val
                      | Some old_val \<Rightarrow> (if cond new_val old_val
                                         then Some new_val
                                         else Some old_val))))"

lemma cond_override_empty1[simp]: "cond_override c Map.empty t = t"
  by (simp add: cond_override_def fun_eq_iff)

lemma cond_override_empty2[simp]: "cond_override c t Map.empty = t"
  by (simp add: cond_override_def fun_eq_iff)

lemma cond_override_None[simp]:
  "old k = None \<Longrightarrow> (cond_override c old new) k = new k"
  by (simp add: cond_override_def)

lemma cond_override_override:
  "\<lbrakk>old k = Some ov;new k = Some nv; C nv ov\<rbrakk>
    \<Longrightarrow> (cond_override C old new) k = Some nv"
  by (auto simp add: cond_override_def)

lemma cond_override_noOverride:
  "\<lbrakk>old k = Some ov;new k = Some nv; \<not> (C nv ov)\<rbrakk>
    \<Longrightarrow> (cond_override C old new) k = Some ov"
  by (auto simp add: cond_override_def)

lemma dom_cond_override: "dom (cond_override C s t) \<subseteq> dom s \<union> dom t"
  by (auto simp add: cond_override_def dom_def)

lemma finite_dom_cond_override:
 "\<lbrakk> finite (dom s); finite (dom t) \<rbrakk> \<Longrightarrow> finite (dom (cond_override C s t))"
apply (rule_tac B="dom s \<union> dom t" in finite_subset)
apply (rule dom_cond_override)
by (rule finite_UnI)

subsubsection \<open>Filter on Tables\<close>

definition filter_tab :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) table \<Rightarrow> ('a, 'b) table"
  where
    "filter_tab c t = (\<lambda>k. (case t k of
                             None   \<Rightarrow> None
                           | Some x \<Rightarrow> if c k x then Some x else None))"

lemma filter_tab_empty[simp]: "filter_tab c Map.empty = Map.empty"
by (simp add: filter_tab_def empty_def)

lemma filter_tab_True[simp]: "filter_tab (\<lambda>x y. True) t = t"
by (simp add: fun_eq_iff filter_tab_def)

lemma filter_tab_False[simp]: "filter_tab (\<lambda>x y. False) t = Map.empty"
by (simp add: fun_eq_iff filter_tab_def empty_def)

lemma filter_tab_ran_subset: "ran (filter_tab c t) \<subseteq> ran t"
by (auto simp add: filter_tab_def ran_def)

lemma filter_tab_range_subset: "range (filter_tab c t) \<subseteq> range t \<union> {None}"
apply (auto simp add: filter_tab_def)
apply (drule sym, blast)
done

lemma finite_range_filter_tab:
  "finite (range t) \<Longrightarrow> finite (range (filter_tab c t))"
apply (rule_tac B="range t \<union> {None} " in finite_subset)
apply (rule filter_tab_range_subset)
apply (auto intro: finite_UnI)
done

lemma filter_tab_SomeD[dest!]:
"filter_tab c t k = Some x \<Longrightarrow> (t k = Some x) \<and> c k x"
by (auto simp add: filter_tab_def)

lemma filter_tab_SomeI: "\<lbrakk>t k = Some x;C k x\<rbrakk> \<Longrightarrow>filter_tab C t k = Some x"
by (simp add: filter_tab_def)

lemma filter_tab_all_True:
 "\<forall> k y. t k = Some y \<longrightarrow> p k y \<Longrightarrow>filter_tab p t = t"
apply (auto simp add: filter_tab_def fun_eq_iff)
done

lemma filter_tab_all_True_Some:
 "\<lbrakk>\<forall> k y. t k = Some y \<longrightarrow> p k y; t k = Some v\<rbrakk> \<Longrightarrow> filter_tab p t k = Some v"
by (auto simp add: filter_tab_def fun_eq_iff)

lemma filter_tab_all_False:
 "\<forall> k y. t k = Some y \<longrightarrow> \<not> p k y \<Longrightarrow>filter_tab p t = Map.empty"
by (auto simp add: filter_tab_def fun_eq_iff)

lemma filter_tab_None: "t k = None \<Longrightarrow> filter_tab p t k = None"
apply (simp add: filter_tab_def fun_eq_iff)
done

lemma filter_tab_dom_subset: "dom (filter_tab C t) \<subseteq> dom t"
by (auto simp add: filter_tab_def dom_def)

lemma filter_tab_eq: "\<lbrakk>a=b\<rbrakk> \<Longrightarrow> filter_tab C a = filter_tab C b"
by (auto simp add: fun_eq_iff filter_tab_def)

lemma finite_dom_filter_tab:
"finite (dom t) \<Longrightarrow> finite (dom (filter_tab C t))"
apply (rule_tac B="dom t" in finite_subset)
by (rule filter_tab_dom_subset)

lemma filter_tab_weaken:
"\<lbrakk>\<forall> a \<in> t k: \<exists> b \<in> s k: P a b;
  \<And> k x y. \<lbrakk>t k = Some x;s k = Some y\<rbrakk> \<Longrightarrow> cond k x \<longrightarrow> cond k y
 \<rbrakk> \<Longrightarrow> \<forall> a \<in> filter_tab cond t k: \<exists> b \<in> filter_tab cond s k: P a b"
by (force simp add: filter_tab_def)

lemma cond_override_filter:
  "\<lbrakk>\<And> k old new. \<lbrakk>s k = Some new; t k = Some old\<rbrakk>
    \<Longrightarrow> (\<not> overC new old \<longrightarrow>  \<not> filterC k new) \<and>
        (overC new old \<longrightarrow> filterC k old \<longrightarrow> filterC k new)
   \<rbrakk> \<Longrightarrow>
    cond_override overC (filter_tab filterC t) (filter_tab filterC s)
    = filter_tab filterC (cond_override overC t s)"
by (auto simp add: fun_eq_iff cond_override_def filter_tab_def )

subsubsection \<open>Misc\<close>

lemma Ball_set_table: "(\<forall> (x,y)\<in> set l. P x y) \<Longrightarrow> \<forall> x. \<forall> y\<in> map_of l x: P x y"
apply (erule rev_mp)
apply (induct l)
apply simp
apply (simp (no_asm))
apply auto
done

lemma Ball_set_tableD:
  "\<lbrakk>(\<forall> (x,y)\<in> set l. P x y); x \<in> set_option (table_of l xa)\<rbrakk> \<Longrightarrow> P xa x"
apply (frule Ball_set_table)
by auto

declare map_of_SomeD [elim]

lemma table_of_Some_in_set:
"table_of l k = Some x \<Longrightarrow> (k,x) \<in> set l"
by auto

lemma set_get_eq:
  "unique l \<Longrightarrow> (k, the (table_of l k)) \<in> set l = (table_of l k \<noteq> None)"
by (auto dest!: weak_map_of_SomeI)

lemma inj_Pair_const2: "inj (\<lambda>k. (k, C))"
apply (rule inj_onI)
apply auto
done

lemma table_of_mapconst_SomeI:
  "\<lbrakk>table_of t k = Some y'; snd y=y'; fst y=c\<rbrakk> \<Longrightarrow>
    table_of (map (\<lambda>(k,x). (k,c,x)) t) k = Some y"
  by (induct t) auto

lemma table_of_mapconst_NoneI:
  "\<lbrakk>table_of t k = None\<rbrakk> \<Longrightarrow>
    table_of (map (\<lambda>(k,x). (k,c,x)) t) k = None"
  by (induct t) auto

lemmas table_of_map2_SomeI = inj_Pair_const2 [THEN map_of_mapk_SomeI]

lemma table_of_map_SomeI: "table_of t k = Some x \<Longrightarrow>
   table_of (map (\<lambda>(k,x). (k, f x)) t) k = Some (f x)"
  by (induct t) auto

lemma table_of_remap_SomeD:
  "table_of (map (\<lambda>((k,k'),x). (k,(k',x))) t) k = Some (k',x) \<Longrightarrow>
    table_of t (k, k') = Some x"
  by (induct t) auto

lemma table_of_mapf_Some:
  "\<forall>x y. f x = f y \<longrightarrow> x = y \<Longrightarrow>
    table_of (map (\<lambda>(k,x). (k,f x)) t) k = Some (f x) \<Longrightarrow> table_of t k = Some x"
  by (induct t) auto

lemma table_of_mapf_SomeD [dest!]:
  "table_of (map (\<lambda>(k,x). (k, f x)) t) k = Some z \<Longrightarrow> (\<exists>y\<in>table_of t k: z=f y)"
  by (induct t) auto

lemma table_of_mapf_NoneD [dest!]:
  "table_of (map (\<lambda>(k,x). (k, f x)) t) k = None \<Longrightarrow> (table_of t k = None)"
  by (induct t) auto

lemma table_of_mapkey_SomeD [dest!]:
  "table_of (map (\<lambda>(k,x). ((k,C),x)) t) (k,D) = Some x \<Longrightarrow> C = D \<and> table_of t k = Some x"
  by (induct t) auto

lemma table_of_mapkey_SomeD2 [dest!]:
  "table_of (map (\<lambda>(k,x). ((k,C),x)) t) ek = Some x \<Longrightarrow>
    C = snd ek \<and> table_of t (fst ek) = Some x"
  by (induct t) auto

lemma table_append_Some_iff: "table_of (xs@ys) k = Some z =
 (table_of xs k = Some z \<or> (table_of xs k = None \<and> table_of ys k = Some z))"
apply (simp)
apply (rule map_add_Some_iff)
done

lemma table_of_filter_unique_SomeD [rule_format (no_asm)]:
  "table_of (filter P xs) k = Some z \<Longrightarrow> unique xs \<longrightarrow> table_of xs k = Some z"
  by (induct xs) (auto del: map_of_SomeD intro!: map_of_SomeD)

definition Un_tables :: "('a, 'b) tables set \<Rightarrow> ('a, 'b) tables"
  where "Un_tables ts = (\<lambda>k. \<Union>t\<in>ts. t k)"

definition overrides_t :: "('a, 'b) tables \<Rightarrow> ('a, 'b) tables \<Rightarrow> ('a, 'b) tables"
    (infixl "\<oplus>\<oplus>" 100)
  where "s \<oplus>\<oplus> t = (\<lambda>k. if t k = {} then s k else t k)"

definition
  hidings_entails :: "('a, 'b) tables \<Rightarrow> ('a, 'c) tables \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
    ("_ hidings _ entails _" 20)
  where "(t hidings s entails R) = (\<forall>k. \<forall>x\<in>t k. \<forall>y\<in>s k. R x y)"

definition
  \<comment> \<open>variant for unique table:\<close>
  hiding_entails :: "('a, 'b) table  \<Rightarrow> ('a, 'c) table  \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
    ("_ hiding _ entails _"  20)
  where "(t hiding  s entails R) = (\<forall>k. \<forall>x\<in>t k: \<forall>y\<in>s k: R x y)"

definition
  \<comment> \<open>variant for a unique table and conditional overriding:\<close>
  cond_hiding_entails :: "('a, 'b) table  \<Rightarrow> ('a, 'c) table
                          \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
                          ("_ hiding _ under _ entails _"  20)
  where "(t hiding  s under C entails R) = (\<forall>k. \<forall>x\<in>t k: \<forall>y\<in>s k: C x y \<longrightarrow> R x y)"

subsubsection "Untables"

lemma Un_tablesI [intro]:  "t \<in> ts \<Longrightarrow> x \<in> t k \<Longrightarrow> x \<in> Un_tables ts k"
  by (auto simp add: Un_tables_def)

lemma Un_tablesD [dest!]: "x \<in> Un_tables ts k \<Longrightarrow> \<exists>t. t \<in> ts \<and> x \<in> t k"
  by (auto simp add: Un_tables_def)

lemma Un_tables_empty [simp]: "Un_tables {} = (\<lambda>k. {})"
  by (simp add: Un_tables_def)

subsubsection "overrides"

lemma empty_overrides_t [simp]: "(\<lambda>k. {}) \<oplus>\<oplus> m = m"
  by (simp add: overrides_t_def)

lemma overrides_empty_t [simp]: "m \<oplus>\<oplus> (\<lambda>k. {}) = m"
  by (simp add: overrides_t_def)

lemma overrides_t_Some_iff:
  "(x \<in> (s \<oplus>\<oplus> t) k) = (x \<in> t k \<or> t k = {} \<and> x \<in> s k)"
  by (simp add: overrides_t_def)

lemmas overrides_t_SomeD = overrides_t_Some_iff [THEN iffD1, dest!]

lemma overrides_t_right_empty [simp]: "n k = {} \<Longrightarrow> (m \<oplus>\<oplus> n) k = m k"
  by (simp add: overrides_t_def)

lemma overrides_t_find_right [simp]: "n k \<noteq> {} \<Longrightarrow> (m \<oplus>\<oplus> n) k = n k"
  by (simp add: overrides_t_def)

subsubsection "hiding entails"

lemma hiding_entailsD:
  "t hiding s entails R \<Longrightarrow> t k = Some x \<Longrightarrow> s k = Some y \<Longrightarrow> R x y"
  by (simp add: hiding_entails_def)

lemma empty_hiding_entails [simp]: "Map.empty hiding s entails R"
  by (simp add: hiding_entails_def)

lemma hiding_empty_entails [simp]: "t hiding Map.empty entails R"
  by (simp add: hiding_entails_def)

subsubsection "cond hiding entails"

lemma cond_hiding_entailsD:
"\<lbrakk>t hiding s under C entails R; t k = Some x; s k = Some y; C x y\<rbrakk> \<Longrightarrow> R x y"
by (simp add: cond_hiding_entails_def)

lemma empty_cond_hiding_entails[simp]: "Map.empty hiding s under C entails R"
by (simp add: cond_hiding_entails_def)

lemma cond_hiding_empty_entails[simp]: "t hiding Map.empty under C entails R"
by (simp add: cond_hiding_entails_def)

lemma hidings_entailsD: "\<lbrakk>t hidings s entails R; x \<in> t k; y \<in> s k\<rbrakk> \<Longrightarrow> R x y"
by (simp add: hidings_entails_def)

lemma hidings_empty_entails [intro!]: "t hidings (\<lambda>k. {}) entails R"
apply (unfold hidings_entails_def)
apply (simp (no_asm))
done

lemma empty_hidings_entails [intro!]:
  "(\<lambda>k. {}) hidings s entails R"apply (unfold hidings_entails_def)
by (simp (no_asm))

(*###TO Map?*)
primrec atleast_free :: "('a \<rightharpoonup> 'b) => nat => bool"
where
  "atleast_free m 0 = True"
| atleast_free_Suc: "atleast_free m (Suc n) = (\<exists>a. m a = None \<and> (\<forall>b. atleast_free (m(a\<mapsto>b)) n))"

lemma atleast_free_weaken [rule_format (no_asm)]:
  "\<forall>m. atleast_free m (Suc n) \<longrightarrow> atleast_free m n"
apply (induct_tac "n")
apply (simp (no_asm))
apply clarify
apply (simp (no_asm))
apply (drule atleast_free_Suc [THEN iffD1])
apply fast
done

lemma atleast_free_SucI:
"[| h a = None; \<forall>obj. atleast_free (h(a|->obj)) n |] ==> atleast_free h (Suc n)"
by force

declare fun_upd_apply [simp del]
lemma atleast_free_SucD_lemma [rule_format (no_asm)]:
"\<forall>m a. m a = None \<longrightarrow> (\<forall>c. atleast_free (m(a\<mapsto>c)) n) \<longrightarrow>
  (\<forall>b d. a \<noteq> b \<longrightarrow> atleast_free (m(b\<mapsto>d)) n)"
apply (induct_tac "n")
apply  auto
apply (rule_tac x = "a" in exI)
apply  (rule conjI)
apply  (force simp add: fun_upd_apply)
apply (erule_tac V = "m a = None" in thin_rl)
apply clarify
apply (subst fun_upd_twist)
apply  (erule not_sym)
apply (rename_tac "ba")
apply (drule_tac x = "ba" in spec)
apply clarify
apply (tactic "smp_tac \<^context> 2 1")
apply (erule (1) notE impE)
apply (case_tac "aa = b")
apply fast+
done
declare fun_upd_apply [simp]

lemma atleast_free_SucD: "atleast_free h (Suc n) ==> atleast_free (h(a|->b)) n"
apply auto
apply (case_tac "aa = a")
apply auto
apply (erule atleast_free_SucD_lemma)
apply auto
done

declare atleast_free_Suc [simp del]

end


theory Partially_Filled_Array_Iter
imports
  Partially_Filled_Array
  "Separation_Logic_Imperative_HOL.Imp_List_Spec"
begin

subsubsection \<open>Iterator\<close>

type_synonym 'a pfa_it = "'a pfarray \<times> nat"
definition "pfa_is_it c ls lsi ls2
  \<equiv> (\<lambda>(lsi',i). is_pfa c ls lsi * \<up>(ls2 = drop i ls \<and> i \<le> length ls \<and> lsi' = lsi))"

definition pfa_it_init :: "'a pfarray \<Rightarrow> ('a pfa_it) Heap"
  where "pfa_it_init l = return (l,0)"

fun pfa_it_next where
  "pfa_it_next (p,i) = do {
    x \<leftarrow> pfa_get p i;
    return (x, (p,Suc i))
  }"

definition pfa_it_has_next :: "('a::heap) pfa_it \<Rightarrow> bool Heap" where
  "pfa_it_has_next it \<equiv> do {
    l \<leftarrow> pfa_length (fst it);
    return (snd it \<noteq> l)
}"

lemma pfa_iterate_impl:
  "imp_list_iterate (is_pfa k) (pfa_is_it k) pfa_it_init pfa_it_has_next pfa_it_next"
  apply unfold_locales
  unfolding pfa_it_init_def pfa_is_it_def[abs_def]
proof(goal_cases)
  case 1
  then show ?case
    by (simp add: is_pfa_prec)
next
  case (2 l p)
  then show ?case
    by sep_auto
next
  case (3 l' l p it)
  then show ?case
  apply (case_tac it, simp)
  apply (case_tac l', simp)
  apply sep_auto
    subgoal by (metis drop_all list.simps(3) not_le_imp_less)
  apply (sep_auto)
    apply (metis drop_eq_ConsD list.sel(3))
    subgoal by (meson Suc_leI \<open>\<And>list ba b aa a. \<lbrakk>it = ((a, b), ba); l' = drop ba l; aa # list = drop ba l; ba \<le> length l; p = (a, b)\<rbrakk> \<Longrightarrow> ba < length l\<close>)
    subgoal by (metis list.sel(1) nth_via_drop)
    subgoal using ent_refl_true by presburger
    done
next
  case (4 l p l' it)
  then show ?case
  unfolding pfa_it_has_next_def
  apply (case_tac it, simp)
  by (sep_auto)
next
  case (5 l p l' it)
  then show ?case
  apply (case_tac it, simp)
    by sep_auto
qed

interpretation pfa_iter:
  imp_list_iterate "is_pfa k" "pfa_is_it k" pfa_it_init pfa_it_has_next pfa_it_next
  by (rule pfa_iterate_impl)

end


(*  Title:      HOL/Auth/Guard/Guard.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge
*)

section\<open>Protocol-Independent Confidentiality Theorem on Nonces\<close>

theory Guard imports Analz Extensions begin

(******************************************************************************
messages where all the occurrences of Nonce n are
in a sub-message of the form Crypt (invKey K) X with K:Ks
******************************************************************************)

inductive_set
  guard :: "nat \<Rightarrow> key set \<Rightarrow> msg set"
  for n :: nat and Ks :: "key set"
where
  No_Nonce [intro]: "Nonce n \<notin> parts {X} \<Longrightarrow> X \<in> guard n Ks"
| Guard_Nonce [intro]: "invKey K \<in> Ks \<Longrightarrow> Crypt K X \<in> guard n Ks"
| Crypt [intro]: "X \<in> guard n Ks \<Longrightarrow> Crypt K X \<in> guard n Ks"
| Pair [intro]: "[| X \<in> guard n Ks; Y \<in> guard n Ks |] ==> \<lbrace>X,Y\<rbrace> \<in> guard n Ks"

subsection\<open>basic facts about \<^term>\<open>guard\<close>\<close>

lemma Key_is_guard [iff]: "Key K \<in> guard n Ks"
by auto

lemma Agent_is_guard [iff]: "Agent A \<in> guard n Ks"
by auto

lemma Number_is_guard [iff]: "Number r \<in> guard n Ks"
by auto

lemma Nonce_notin_guard: "X \<in> guard n Ks \<Longrightarrow> X \<noteq> Nonce n"
by (erule guard.induct, auto)

lemma Nonce_notin_guard_iff [iff]: "Nonce n \<notin> guard n Ks"
by (auto dest: Nonce_notin_guard)

lemma guard_has_Crypt [rule_format]: "X \<in> guard n Ks ==> Nonce n \<in> parts {X}
\<longrightarrow> (\<exists>K Y. Crypt K Y \<in> kparts {X} \<and> Nonce n \<in> parts {Y})"
by (erule guard.induct, auto)

lemma Nonce_notin_kparts_msg: "X \<in> guard n Ks \<Longrightarrow> Nonce n \<notin> kparts {X}"
by (erule guard.induct, auto)

lemma Nonce_in_kparts_imp_no_guard: "Nonce n \<in> kparts H
\<Longrightarrow> \<exists>X. X \<in> H \<and> X \<notin> guard n Ks"
apply (drule in_kparts, clarify)
apply (rule_tac x=X in exI, clarify)
by (auto dest: Nonce_notin_kparts_msg)

lemma guard_kparts [rule_format]: "X \<in> guard n Ks \<Longrightarrow>
Y \<in> kparts {X} \<longrightarrow> Y \<in> guard n Ks"
by (erule guard.induct, auto)

lemma guard_Crypt: "[| Crypt K Y \<in> guard n Ks; K \<notin> invKey`Ks |] ==> Y \<in> guard n Ks"
  by (ind_cases "Crypt K Y \<in> guard n Ks") (auto intro!: image_eqI)

lemma guard_MPair [iff]: "(\<lbrace>X,Y\<rbrace> \<in> guard n Ks) = (X \<in> guard n Ks \<and> Y \<in> guard n Ks)"
by (auto, (ind_cases "\<lbrace>X,Y\<rbrace> \<in> guard n Ks", auto)+)

lemma guard_not_guard [rule_format]: "X \<in> guard n Ks \<Longrightarrow>
Crypt K Y \<in> kparts {X} \<longrightarrow> Nonce n \<in> kparts {Y} \<longrightarrow> Y \<notin> guard n Ks"
by (erule guard.induct, auto dest: guard_kparts)

lemma guard_extand: "[| X \<in> guard n Ks; Ks \<subseteq> Ks' |] ==> X \<in> guard n Ks'"
by (erule guard.induct, auto)

subsection\<open>guarded sets\<close>

definition Guard :: "nat \<Rightarrow> key set \<Rightarrow> msg set \<Rightarrow> bool" where
"Guard n Ks H \<equiv> \<forall>X. X \<in> H \<longrightarrow> X \<in> guard n Ks"

subsection\<open>basic facts about \<^term>\<open>Guard\<close>\<close>

lemma Guard_empty [iff]: "Guard n Ks {}"
by (simp add: Guard_def)

lemma notin_parts_Guard [intro]: "Nonce n \<notin> parts G \<Longrightarrow> Guard n Ks G"
apply (unfold Guard_def, clarify)
apply (subgoal_tac "Nonce n \<notin> parts {X}")
by (auto dest: parts_sub)

lemma Nonce_notin_kparts [simplified]: "Guard n Ks H \<Longrightarrow> Nonce n \<notin> kparts H"
by (auto simp: Guard_def dest: in_kparts Nonce_notin_kparts_msg)

lemma Guard_must_decrypt: "[| Guard n Ks H; Nonce n \<in> analz H |] ==>
\<exists>K Y. Crypt K Y \<in> kparts H \<and> Key (invKey K) \<in> kparts H"
apply (drule_tac P="\<lambda>G. Nonce n \<in> G" in analz_pparts_kparts_substD, simp)
by (drule must_decrypt, auto dest: Nonce_notin_kparts)

lemma Guard_kparts [intro]: "Guard n Ks H ==> Guard n Ks (kparts H)"
by (auto simp: Guard_def dest: in_kparts guard_kparts)

lemma Guard_mono: "[| Guard n Ks H; G <= H |] ==> Guard n Ks G"
by (auto simp: Guard_def)

lemma Guard_insert [iff]: "Guard n Ks (insert X H)
= (Guard n Ks H \<and> X \<in> guard n Ks)"
by (auto simp: Guard_def)

lemma Guard_Un [iff]: "Guard n Ks (G Un H) = (Guard n Ks G & Guard n Ks H)"
by (auto simp: Guard_def)

lemma Guard_synth [intro]: "Guard n Ks G ==> Guard n Ks (synth G)"
by (auto simp: Guard_def, erule synth.induct, auto)

lemma Guard_analz [intro]: "[| Guard n Ks G; \<forall>K. K \<in> Ks \<longrightarrow> Key K \<notin> analz G |]
==> Guard n Ks (analz G)"
apply (auto simp: Guard_def)
apply (erule analz.induct, auto)
by (ind_cases "Crypt K Xa \<in> guard n Ks" for K Xa, auto)

lemma in_Guard [dest]: "[| X \<in> G; Guard n Ks G |] ==> X \<in> guard n Ks"
by (auto simp: Guard_def)

lemma in_synth_Guard: "[| X \<in> synth G; Guard n Ks G |] ==> X \<in> guard n Ks"
by (drule Guard_synth, auto)

lemma in_analz_Guard: "[| X \<in> analz G; Guard n Ks G;
\<forall>K. K \<in> Ks \<longrightarrow> Key K \<notin> analz G |] ==> X \<in> guard n Ks"
by (drule Guard_analz, auto)

lemma Guard_keyset [simp]: "keyset G ==> Guard n Ks G"
by (auto simp: Guard_def)

lemma Guard_Un_keyset: "[| Guard n Ks G; keyset H |] ==> Guard n Ks (G \<union> H)"
by auto

lemma in_Guard_kparts: "[| X \<in> G; Guard n Ks G; Y \<in> kparts {X} |] ==> Y \<in> guard n Ks"
by blast

lemma in_Guard_kparts_neq: "[| X \<in> G; Guard n Ks G; Nonce n' \<in> kparts {X} |]
==> n \<noteq> n'"
by (blast dest: in_Guard_kparts)

lemma in_Guard_kparts_Crypt: "[| X \<in> G; Guard n Ks G; is_MPair X;
Crypt K Y \<in> kparts {X}; Nonce n \<in> kparts {Y} |] ==> invKey K \<in> Ks"
apply (drule in_Guard, simp)
apply (frule guard_not_guard, simp+)
apply (drule guard_kparts, simp)
by (ind_cases "Crypt K Y \<in> guard n Ks", auto)

lemma Guard_extand: "[| Guard n Ks G; Ks \<subseteq> Ks' |] ==> Guard n Ks' G"
by (auto simp: Guard_def dest: guard_extand)

lemma guard_invKey [rule_format]: "[| X \<in> guard n Ks; Nonce n \<in> kparts {Y} |] ==>
Crypt K Y \<in> kparts {X} \<longrightarrow> invKey K \<in> Ks"
by (erule guard.induct, auto)

lemma Crypt_guard_invKey [rule_format]: "[| Crypt K Y \<in> guard n Ks;
Nonce n \<in> kparts {Y} |] ==> invKey K \<in> Ks"
by (auto dest: guard_invKey)

subsection\<open>set obtained by decrypting a message\<close>

abbreviation (input)
  decrypt :: "msg set => key => msg => msg set" where
  "decrypt H K Y == insert Y (H - {Crypt K Y})"

lemma analz_decrypt: "[| Crypt K Y \<in> H; Key (invKey K) \<in> H; Nonce n \<in> analz H |]
==> Nonce n \<in> analz (decrypt H K Y)"
apply (drule_tac P="\<lambda>H. Nonce n \<in> analz H" in ssubst [OF insert_Diff])
apply assumption
apply (simp only: analz_Crypt_if, simp)
done

lemma parts_decrypt: "[| Crypt K Y \<in> H; X \<in> parts (decrypt H K Y) |] ==> X \<in> parts H"
by (erule parts.induct, auto intro: parts.Fst parts.Snd parts.Body)

subsection\<open>number of Crypt's in a message\<close>

fun crypt_nb :: "msg => nat"
where
  "crypt_nb (Crypt K X) = Suc (crypt_nb X)"
| "crypt_nb \<lbrace>X,Y\<rbrace> = crypt_nb X + crypt_nb Y"
| "crypt_nb X = 0" (* otherwise *)

subsection\<open>basic facts about \<^term>\<open>crypt_nb\<close>\<close>

lemma non_empty_crypt_msg: "Crypt K Y \<in> parts {X} \<Longrightarrow> crypt_nb X \<noteq> 0"
by (induct X, simp_all, safe, simp_all)

subsection\<open>number of Crypt's in a message list\<close>

primrec cnb :: "msg list => nat"
where
  "cnb [] = 0"
| "cnb (X#l) = crypt_nb X + cnb l"

subsection\<open>basic facts about \<^term>\<open>cnb\<close>\<close>

lemma cnb_app [simp]: "cnb (l @ l') = cnb l + cnb l'"
by (induct l, auto)

lemma mem_cnb_minus: "x \<in> set l ==> cnb l = crypt_nb x + (cnb l - crypt_nb x)"
  by (induct l) auto

lemmas mem_cnb_minus_substI = mem_cnb_minus [THEN ssubst]

lemma cnb_minus [simp]: "x \<in> set l ==> cnb (remove l x) = cnb l - crypt_nb x"
apply (induct l, auto)
apply (erule_tac l=l and x=x in mem_cnb_minus_substI)
apply simp
done

lemma parts_cnb: "Z \<in> parts (set l) \<Longrightarrow>
cnb l = (cnb l - crypt_nb Z) + crypt_nb Z"
by (erule parts.induct, auto simp: in_set_conv_decomp)

lemma non_empty_crypt: "Crypt K Y \<in> parts (set l) \<Longrightarrow> cnb l \<noteq> 0"
by (induct l, auto dest: non_empty_crypt_msg parts_insert_substD)

subsection\<open>list of kparts\<close>

lemma kparts_msg_set: "\<exists>l. kparts {X} = set l \<and> cnb l = crypt_nb X"
apply (induct X, simp_all)
apply (rename_tac agent, rule_tac x="[Agent agent]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Number nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Nonce nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Key nat]" in exI, simp)
apply (rename_tac X, rule_tac x="[Hash X]" in exI, simp)
apply (clarify, rule_tac x="l@la" in exI, simp)
by (clarify, rename_tac nat X y, rule_tac x="[Crypt nat X]" in exI, simp)

lemma kparts_set: "\<exists>l'. kparts (set l) = set l' \<and> cnb l' = cnb l"
apply (induct l)
apply (rule_tac x="[]" in exI, simp, clarsimp)
apply (rename_tac a b l')
apply (subgoal_tac "\<exists>l''.  kparts {a} = set l'' \<and> cnb l'' = crypt_nb a", clarify)
apply (rule_tac x="l''@l'" in exI, simp)
apply (rule kparts_insert_substI, simp)
by (rule kparts_msg_set)

subsection\<open>list corresponding to "decrypt"\<close>

definition decrypt' :: "msg list => key => msg => msg list" where
"decrypt' l K Y == Y # remove l (Crypt K Y)"

declare decrypt'_def [simp]

subsection\<open>basic facts about \<^term>\<open>decrypt'\<close>\<close>

lemma decrypt_minus: "decrypt (set l) K Y <= set (decrypt' l K Y)"
by (induct l, auto)

subsection\<open>if the analyse of a finite guarded set gives n then it must also gives
one of the keys of Ks\<close>

lemma Guard_invKey_by_list [rule_format]: "\<forall>l. cnb l = p
\<longrightarrow> Guard n Ks (set l) \<longrightarrow> Nonce n \<in> analz (set l)
\<longrightarrow> (\<exists>K. K \<in> Ks \<and> Key K \<in> analz (set l))"
apply (induct p)
(* case p=0 *)
apply (clarify, drule Guard_must_decrypt, simp, clarify)
apply (drule kparts_parts, drule non_empty_crypt, simp)
(* case p>0 *)
apply (clarify, frule Guard_must_decrypt, simp, clarify)
apply (drule_tac P="\<lambda>G. Nonce n \<in> G" in analz_pparts_kparts_substD, simp)
apply (frule analz_decrypt, simp_all)
apply (subgoal_tac "\<exists>l'. kparts (set l) = set l' \<and> cnb l' = cnb l", clarsimp)
apply (drule_tac G="insert Y (set l' - {Crypt K Y})"
and H="set (decrypt' l' K Y)" in analz_sub, rule decrypt_minus)
apply (rule_tac analz_pparts_kparts_substI, simp)
apply (case_tac "K \<in> invKey`Ks")
(* K:invKey`Ks *)
apply (clarsimp, blast)
(* K ~:invKey`Ks *)
apply (subgoal_tac "Guard n Ks (set (decrypt' l' K Y))")
apply (drule_tac x="decrypt' l' K Y" in spec, simp)
apply (subgoal_tac "Crypt K Y \<in> parts (set l)")
apply (drule parts_cnb, rotate_tac -1, simp)
apply (clarify, drule_tac X="Key Ka" and H="insert Y (set l')" in analz_sub)
apply (rule insert_mono, rule set_remove)
apply (simp add: analz_insertD, blast)
(* Crypt K Y:parts (set l) *)
apply (blast dest: kparts_parts)
(* Guard n Ks (set (decrypt' l' K Y)) *)
apply (rule_tac H="insert Y (set l')" in Guard_mono)
apply (subgoal_tac "Guard n Ks (set l')", simp)
apply (rule_tac K=K in guard_Crypt, simp add: Guard_def, simp)
apply (drule_tac t="set l'" in sym, simp)
apply (rule Guard_kparts, simp, simp)
apply (rule_tac B="set l'" in subset_trans, rule set_remove, blast)
by (rule kparts_set)

lemma Guard_invKey_finite: "[| Nonce n \<in> analz G; Guard n Ks G; finite G |]
==> \<exists>K. K \<in> Ks \<and> Key K \<in> analz G"
apply (drule finite_list, clarify)
by (rule Guard_invKey_by_list, auto)

lemma Guard_invKey: "[| Nonce n \<in> analz G; Guard n Ks G |]
==> \<exists>K. K \<in> Ks \<and> Key K \<in> analz G"
by (auto dest: analz_needs_only_finite Guard_invKey_finite)

subsection\<open>if the analyse of a finite guarded set and a (possibly infinite) set of keys
gives n then it must also gives Ks\<close>

lemma Guard_invKey_keyset: "[| Nonce n \<in> analz (G \<union> H); Guard n Ks G; finite G;
keyset H |] ==> \<exists>K. K \<in> Ks \<and> Key K \<in> analz (G \<union> H)"
apply (frule_tac P="\<lambda>G. Nonce n \<in> G" and G=G in analz_keyset_substD, simp_all)
apply (drule_tac G="G Un (H Int keysfor G)" in Guard_invKey_finite)
by (auto simp: Guard_def intro: analz_sub)

end


section {*I\_epda\_main*}
theory
  I_epda_main

imports
  I_epda_HS_H
  I_epda_S_HS

begin

lemma epdaS_inst_BF_LinDBRest_DetR_LaOp_axioms: "
  BF_LinDBRest_DetR_LaOp_axioms valid_epda epdaS_configurations
     epdaS_initial_configurations epda_step_labels epdaS_step_relation
     epdaS_marking_condition epdaS_marked_effect epdaS_unmarked_effect
     epda_effects right_quotient_word (@) epda_unfixed_scheduler_extendable
     epdaS_get_scheduler (@) epdaS_set_unfixed_scheduler_DB
     epdaS_get_unfixed_scheduler_DB epdaS_get_fixed_scheduler_DB"
  apply(simp add: BF_LinDBRest_DetR_LaOp_axioms_def)
  apply(clarsimp)
  apply(rename_tac M)(*strict*)
  apply(rule epdaS_vs_epdaHS.Nonblockingness_translation_rest2)
   apply(rename_tac M)(*strict*)
   apply(force)
  apply(rename_tac M)(*strict*)
  apply(metis epdaHS_inst_hlp_BF_LinDBRest_DetR_LaOp epdaS_vs_epdaHS_Nonblockingness_and_lang_transfer epdaS_vs_epdaHS_is_forward_deterministic_accessible_preserved)
  done

interpretation "epdaS" : loc_autS_5
  (* TSstructure *)
  "valid_epda"
  (* configurations *)
  "epdaS_configurations"
  (* initial_configurations *)
  "epdaS_initial_configurations"
  (* step_labels *)
  "epda_step_labels"
  (* step_relation *)
  "epdaS_step_relation"
  (* effects *)
  "epda_effects"
  (* marking_condition *)
  "epdaS_marking_condition"
  (* marked_effect *)
  "epdaS_marked_effect"
  (* unmarked_effect *)
  "epdaS_unmarked_effect"
  (* destinations *)
  "epda_destinations"
  (* get_destinations *)
  "epdaS_get_destinations"
  (* decreasing *)
  "True"
  (* string_state *)
  "epdaS_string_state"
  (* fixed_schedulers *)
  epda_fixed_schedulers
  (* empty_fixed_scheduler *)
  epda_empty_fixed_scheduler
  (* fixed_scheduler_extendable *)
  epda_fixed_scheduler_extendable
  (* scheduler_fragments *)
  "epda_effects"
  (* empty_scheduler_fragment *)
  epda_empty_scheduler_fragment
  (* join_scheduler_fragments *)
  "append"
  (* unfixed_schedulers *)
  "epda_effects"
  (* empty_unfixed_scheduler *)
  epda_empty_unfixed_scheduler
  (* unfixed_scheduler_right_quotient_word *)
  "right_quotient_word"
  (* extend_unfixed_scheduler *)
  "append"
  (* unfixed_scheduler_extendable *)
  epda_unfixed_scheduler_extendable
  (* schedulers *)
  "epda_effects"
  (* initial_schedulers *)
  "epda_effects"
  (* empty_scheduler *)
  epda_empty_scheduler
  (* get_scheduler *)
  "epdaS_get_scheduler"
  (* join_fixed_scheduler_unfixed_scheduler *)
  "append"
  (* extend_scheduler *)
  "append"
  (* set_unfixed_scheduler_DB *)
  "epdaS_set_unfixed_scheduler_DB"
  (* get_unfixed_scheduler_DB *)
  "epdaS_get_unfixed_scheduler_DB"
  (* get_fixed_scheduler_DB *)
  "epdaS_get_fixed_scheduler_DB"
  apply(simp add: LOCALE_DEFS)
  apply(simp add: epdaS_inst_AX_initial_configuration_belongs epdaS_inst_AX_step_relation_preserves_belongs )
  apply(simp add: epdaS_inst_ATS_Language_by_Finite_Derivations_axioms epdaS_inst_ATS_String_State_Modification_axioms epdaS_inst_ATS_Language_axioms )
  apply(simp add: epdaS_inst_ATS_Sched_Basic_axioms epdaS_inst_ATS_Scheduler_Fragment_axioms epdaS_inst_ATS_SchedUF_Basic_axioms epdaS_inst_ATS_SchedUF_DB_axioms epdaS_inst_ATS_SchedF_Basic_axioms epdaS_inst_ATS_SchedF_DB_axioms epdaS_inst_ATS_Sched_axioms )
  apply(simp add: epdaS_inst_ATS_Sched_DB0_axioms epdaS_inst_ATS_Sched_DB_axioms )
  apply(simp add: epdaS_inst_BF_LinDBRest_DetR_LaOp_axioms )
  done

lemma epdaS_inst_BF_LinDB_OpLa_axioms: "
  BF_LinDB_OpLa_axioms valid_epda epdaS_configurations
     epdaS_initial_configurations epda_step_labels epdaS_step_relation
     epdaS_marking_condition epdaS_marked_effect epdaS_unmarked_effect
     epda_effects right_quotient_word (@) epda_unfixed_scheduler_extendable
     epdaS_get_scheduler (@) epdaS_set_unfixed_scheduler_DB
     epdaS_get_unfixed_scheduler_DB epdaS_get_fixed_scheduler_DB"
  apply(simp add: BF_LinDB_OpLa_axioms_def)
  apply(clarsimp)
  apply(rename_tac M)(*strict*)
  apply(rule_tac
      t="epdaS.unmarked_language M"
      and s="epdaHS.unmarked_language M"
      in ssubst)
   apply(rename_tac M)(*strict*)
   apply (metis epdaS_vs_epdaHS_Nonblockingness_and_lang_transfer)
  apply(rename_tac M)(*strict*)
  apply(rule_tac
      t="epdaS.marked_language M"
      and s="epdaHS.marked_language M"
      in ssubst)
   apply(rename_tac M)(*strict*)
   apply (metis epdaS_vs_epdaHS_Nonblockingness_and_lang_transfer)
  apply(rename_tac M)(*strict*)
  apply(rule_tac
      t="epdaHS.unmarked_language M"
      and s="epdaH.unmarked_language M"
      in ssubst)
   apply(rename_tac M)(*strict*)
   apply (metis equalityI epdaH.AX_unmarked_language_finite epdaHS.AX_unmarked_language_finite epdaH_vs_epdaHS.ATS_Branching_Versus_Linear2_unmarked_language_translation1 epdaH_vs_epdaHS.ATS_Branching_Versus_Linear2_unmarked_language_translation2)
  apply(rename_tac M)(*strict*)
  apply(rule_tac
      t="epdaHS.marked_language M"
      and s="epdaH.marked_language M"
      in ssubst)
   apply(rename_tac M)(*strict*)
   apply (metis equalityI epdaH.AX_marked_language_finite epdaHS.AX_marked_language_finite epdaH_vs_epdaHS.ATS_Branching_Versus_Linear2_marked_language_translation2 epdaH_vs_epdaHS.ATS_Branching_Versus_Linear2_marked_language_translation1)
  apply(rename_tac M)(*strict*)
  apply(rule epdaH.AX_BF_Bra_OpLa)
   apply(rename_tac M)(*strict*)
   apply(force)
  apply(rename_tac M)(*strict*)
  apply(rule epdaH_vs_epdaHS.bflin_to_bfbra)
   apply(rename_tac M)(*strict*)
   apply(force)
  apply(rename_tac M)(*strict*)
  apply(rule_tac
      t="epdaHS.Nonblockingness_linear M"
      and s="epdaHS.Nonblockingness_linear_DB M"
      in ssubst)
   apply(rename_tac M)(*strict*)
   apply (metis epdaHS.Nonblockingness_linear_vs_Nonblockingness_linear_DB)
  apply(rename_tac M)(*strict*)
  apply(rule epdaS_vs_epdaHS.Nonblockingness_translation1)
   apply(rename_tac M)(*strict*)
   apply(force)
  apply(rename_tac M)(*strict*)
  apply(force)
  done

interpretation "epdaS" : loc_autS_6
  (* TSstructure *)
  "valid_epda"
  (* configurations *)
  "epdaS_configurations"
  (* initial_configurations *)
  "epdaS_initial_configurations"
  (* step_labels *)
  "epda_step_labels"
  (* step_relation *)
  "epdaS_step_relation"
  (* effects *)
  "epda_effects"
  (* marking_condition *)
  "epdaS_marking_condition"
  (* marked_effect *)
  "epdaS_marked_effect"
  (* unmarked_effect *)
  "epdaS_unmarked_effect"
  (* destinations *)
  "epda_destinations"
  (* get_destinations *)
  "epdaS_get_destinations"
  (* decreasing *)
  "True"
  (* string_state *)
  "epdaS_string_state"
  (* fixed_schedulers *)
  epda_fixed_schedulers
  (* empty_fixed_scheduler *)
  epda_empty_fixed_scheduler
  (* fixed_scheduler_extendable *)
  epda_fixed_scheduler_extendable
  (* scheduler_fragments *)
  "epda_effects"
  (* empty_scheduler_fragment *)
  epda_empty_scheduler_fragment
  (* join_scheduler_fragments *)
  "append"
  (* unfixed_schedulers *)
  "epda_effects"
  (* empty_unfixed_scheduler *)
  epda_empty_unfixed_scheduler
  (* unfixed_scheduler_right_quotient_word *)
  "right_quotient_word"
  (* extend_unfixed_scheduler *)
  "append"
  (* unfixed_scheduler_extendable *)
  epda_unfixed_scheduler_extendable
  (* schedulers *)
  "epda_effects"
  (* initial_schedulers *)
  "epda_effects"
  (* empty_scheduler *)
  epda_empty_scheduler
  (* get_scheduler *)
  "epdaS_get_scheduler"
  (* join_fixed_scheduler_unfixed_scheduler *)
  "append"
  (* extend_scheduler *)
  "append"
  (* set_unfixed_scheduler_DB *)
  "epdaS_set_unfixed_scheduler_DB"
  (* get_unfixed_scheduler_DB *)
  "epdaS_get_unfixed_scheduler_DB"
  (* get_fixed_scheduler_DB *)
  "epdaS_get_fixed_scheduler_DB"
  apply(simp add: LOCALE_DEFS)
  apply(simp add: epdaS_inst_AX_initial_configuration_belongs epdaS_inst_AX_step_relation_preserves_belongs )
  apply(simp add: epdaS_inst_ATS_Language_by_Finite_Derivations_axioms epdaS_inst_ATS_String_State_Modification_axioms epdaS_inst_ATS_Language_axioms )
  apply(simp add: epdaS_inst_ATS_Sched_Basic_axioms epdaS_inst_ATS_Scheduler_Fragment_axioms epdaS_inst_ATS_SchedUF_Basic_axioms epdaS_inst_ATS_SchedUF_DB_axioms epdaS_inst_ATS_SchedF_Basic_axioms epdaS_inst_ATS_SchedF_DB_axioms epdaS_inst_ATS_Sched_axioms )
  apply(simp add: epdaS_inst_ATS_Sched_DB0_axioms epdaS_inst_ATS_Sched_DB_axioms epdaS_inst_BF_LinDBRest_DetR_LaOp_axioms )
  apply(simp add: epdaS_inst_BF_LinDB_OpLa_axioms )
  done

end


(*****************************************************************************
 * Featherweight-OCL --- A Formal Semantics for UML-OCL Version OCL 2.5
 *                       for the OMG Standard.
 *                       http://www.brucker.ch/projects/hol-testgen/
 *
 * UML_Library.thy --- Library definitions.
 * This file is part of HOL-TestGen.
 *
 * Copyright (c) 2012-2015 Université Paris-Saclay, Univ. Paris-Sud, France
 *               2013-2015 IRT SystemX, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************)

theory  UML_Library
imports (* Basic Type Operations *)
        "basic_types/UML_Boolean"
        "basic_types/UML_Void"
        "basic_types/UML_Integer"
        "basic_types/UML_Real"
        "basic_types/UML_String"

        (* Collection Type Operations *)
        "collection_types/UML_Pair"
        "collection_types/UML_Bag"
        "collection_types/UML_Set"
        "collection_types/UML_Sequence"
begin

section\<open>Miscellaneous Stuff\<close>

subsection\<open>Definition: asBoolean\<close>

definition OclAsBoolean\<^sub>I\<^sub>n\<^sub>t  :: "('\<AA>) Integer \<Rightarrow> ('\<AA>) Boolean" ("(_)->oclAsType\<^sub>I\<^sub>n\<^sub>t'(Boolean')")
where     "OclAsBoolean\<^sub>I\<^sub>n\<^sub>t X = (\<lambda>\<tau>. if (\<delta> X) \<tau> = true \<tau>
                              then \<lfloor>\<lfloor>\<lceil>\<lceil>X \<tau>\<rceil>\<rceil> \<noteq> 0\<rfloor>\<rfloor>
                              else invalid \<tau>)"

interpretation OclAsBoolean\<^sub>I\<^sub>n\<^sub>t : profile_mono\<^sub>d OclAsBoolean\<^sub>I\<^sub>n\<^sub>t "\<lambda>x. \<lfloor>\<lfloor>\<lceil>\<lceil>x\<rceil>\<rceil> \<noteq> 0\<rfloor>\<rfloor>"
                                by unfold_locales (auto simp: OclAsBoolean\<^sub>I\<^sub>n\<^sub>t_def bot_option_def)

definition OclAsBoolean\<^sub>R\<^sub>e\<^sub>a\<^sub>l  :: "('\<AA>) Real \<Rightarrow> ('\<AA>) Boolean" ("(_)->oclAsType\<^sub>R\<^sub>e\<^sub>a\<^sub>l'(Boolean')")
where     "OclAsBoolean\<^sub>R\<^sub>e\<^sub>a\<^sub>l X = (\<lambda>\<tau>. if (\<delta> X) \<tau> = true \<tau>
                              then \<lfloor>\<lfloor>\<lceil>\<lceil>X \<tau>\<rceil>\<rceil> \<noteq> 0\<rfloor>\<rfloor>
                              else invalid \<tau>)"

interpretation OclAsBoolean\<^sub>R\<^sub>e\<^sub>a\<^sub>l : profile_mono\<^sub>d OclAsBoolean\<^sub>R\<^sub>e\<^sub>a\<^sub>l "\<lambda>x. \<lfloor>\<lfloor>\<lceil>\<lceil>x\<rceil>\<rceil> \<noteq> 0\<rfloor>\<rfloor>"
                                 by unfold_locales (auto simp: OclAsBoolean\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def bot_option_def)

subsection\<open>Definition: asInteger\<close>

definition OclAsInteger\<^sub>R\<^sub>e\<^sub>a\<^sub>l  :: "('\<AA>) Real \<Rightarrow> ('\<AA>) Integer" ("(_)->oclAsType\<^sub>R\<^sub>e\<^sub>a\<^sub>l'(Integer')")
where     "OclAsInteger\<^sub>R\<^sub>e\<^sub>a\<^sub>l X = (\<lambda>\<tau>. if (\<delta> X) \<tau> = true \<tau>
                              then \<lfloor>\<lfloor>floor \<lceil>\<lceil>X \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor>
                              else invalid \<tau>)"

interpretation OclAsInteger\<^sub>R\<^sub>e\<^sub>a\<^sub>l : profile_mono\<^sub>d OclAsInteger\<^sub>R\<^sub>e\<^sub>a\<^sub>l "\<lambda>x. \<lfloor>\<lfloor>floor \<lceil>\<lceil>x\<rceil>\<rceil>\<rfloor>\<rfloor>"
                                 by unfold_locales (auto simp: OclAsInteger\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def bot_option_def)

subsection\<open>Definition: asReal\<close>

definition OclAsReal\<^sub>I\<^sub>n\<^sub>t  :: "('\<AA>) Integer \<Rightarrow> ('\<AA>) Real" ("(_)->oclAsType\<^sub>I\<^sub>n\<^sub>t'(Real')")
where     "OclAsReal\<^sub>I\<^sub>n\<^sub>t X = (\<lambda>\<tau>. if (\<delta> X) \<tau> = true \<tau>
                              then \<lfloor>\<lfloor>real_of_int \<lceil>\<lceil>X \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor>
                              else invalid \<tau>)"

interpretation OclAsReal\<^sub>I\<^sub>n\<^sub>t : profile_mono\<^sub>d OclAsReal\<^sub>I\<^sub>n\<^sub>t "\<lambda>x. \<lfloor>\<lfloor>real_of_int \<lceil>\<lceil>x\<rceil>\<rceil>\<rfloor>\<rfloor>"
                             by unfold_locales (auto simp: OclAsReal\<^sub>I\<^sub>n\<^sub>t_def bot_option_def)

lemma Integer_subtype_of_Real:
  assumes "\<tau> \<Turnstile> \<delta> X"
  shows   "\<tau> \<Turnstile> X ->oclAsType\<^sub>I\<^sub>n\<^sub>t(Real) ->oclAsType\<^sub>R\<^sub>e\<^sub>a\<^sub>l(Integer) \<triangleq> X"
  apply(insert assms,  simp add: OclAsInteger\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def OclAsReal\<^sub>I\<^sub>n\<^sub>t_def OclValid_def StrongEq_def)
  apply(subst (2 4) cp_defined, simp add: true_def)
  by (metis assms bot_option_def drop.elims foundation16 null_option_def)

subsection\<open>Definition: asPair\<close>

definition OclAsPair\<^sub>S\<^sub>e\<^sub>q   :: "[('\<AA>,'\<alpha>::null)Sequence]\<Rightarrow>('\<AA>,'\<alpha>::null,'\<alpha>::null) Pair" ("(_)->asPair\<^sub>S\<^sub>e\<^sub>q'(')")
where     "OclAsPair\<^sub>S\<^sub>e\<^sub>q S = (if S->size\<^sub>S\<^sub>e\<^sub>q() \<doteq> \<two>
                            then Pair{S->at\<^sub>S\<^sub>e\<^sub>q(\<zero>),S->at\<^sub>S\<^sub>e\<^sub>q(\<one>)}
                            else invalid
                            endif)"

definition OclAsPair\<^sub>S\<^sub>e\<^sub>t   :: "[('\<AA>,'\<alpha>::null)Set]\<Rightarrow>('\<AA>,'\<alpha>::null,'\<alpha>::null) Pair" ("(_)->asPair\<^sub>S\<^sub>e\<^sub>t'(')")
where     "OclAsPair\<^sub>S\<^sub>e\<^sub>t S = (if S->size\<^sub>S\<^sub>e\<^sub>t() \<doteq> \<two>
                            then let v = S->any\<^sub>S\<^sub>e\<^sub>t() in
                                 Pair{v,S->excluding\<^sub>S\<^sub>e\<^sub>t(v)->any\<^sub>S\<^sub>e\<^sub>t()}
                            else invalid
                            endif)"

definition OclAsPair\<^sub>B\<^sub>a\<^sub>g   :: "[('\<AA>,'\<alpha>::null)Bag]\<Rightarrow>('\<AA>,'\<alpha>::null,'\<alpha>::null) Pair" ("(_)->asPair\<^sub>B\<^sub>a\<^sub>g'(')")
where     "OclAsPair\<^sub>B\<^sub>a\<^sub>g S = (if S->size\<^sub>B\<^sub>a\<^sub>g() \<doteq> \<two>
                            then let v = S->any\<^sub>B\<^sub>a\<^sub>g() in
                                 Pair{v,S->excluding\<^sub>B\<^sub>a\<^sub>g(v)->any\<^sub>B\<^sub>a\<^sub>g()}
                            else invalid
                            endif)"

subsection\<open>Definition: asSet\<close>

definition OclAsSet\<^sub>S\<^sub>e\<^sub>q   :: "[('\<AA>,'\<alpha>::null)Sequence]\<Rightarrow>('\<AA>,'\<alpha>)Set" ("(_)->asSet\<^sub>S\<^sub>e\<^sub>q'(')")
where     "OclAsSet\<^sub>S\<^sub>e\<^sub>q S = (S->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = Set{} | x ->including\<^sub>S\<^sub>e\<^sub>t(b)))"

definition OclAsSet\<^sub>P\<^sub>a\<^sub>i\<^sub>r   :: "[('\<AA>,'\<alpha>::null,'\<alpha>::null) Pair]\<Rightarrow>('\<AA>,'\<alpha>)Set" ("(_)->asSet\<^sub>P\<^sub>a\<^sub>i\<^sub>r'(')")
where     "OclAsSet\<^sub>P\<^sub>a\<^sub>i\<^sub>r S = Set{S .First(), S .Second()}"

definition OclAsSet\<^sub>B\<^sub>a\<^sub>g   :: "('\<AA>,'\<alpha>::null) Bag\<Rightarrow>('\<AA>,'\<alpha>)Set" ("(_)->asSet\<^sub>B\<^sub>a\<^sub>g'(')")
where     "OclAsSet\<^sub>B\<^sub>a\<^sub>g S =  (\<lambda> \<tau>. if (\<delta> S) \<tau> = true \<tau>
                                 then Abs_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<lfloor>\<lfloor> Rep_Set_base S \<tau> \<rfloor>\<rfloor>
                                 else if (\<upsilon> S) \<tau> = true \<tau> then null \<tau>
                                                          else invalid \<tau>)"

subsection\<open>Definition: asSequence\<close>

definition OclAsSeq\<^sub>S\<^sub>e\<^sub>t   :: "[('\<AA>,'\<alpha>::null)Set]\<Rightarrow>('\<AA>,'\<alpha>)Sequence" ("(_)->asSequence\<^sub>S\<^sub>e\<^sub>t'(')")
where     "OclAsSeq\<^sub>S\<^sub>e\<^sub>t S = (S->iterate\<^sub>S\<^sub>e\<^sub>t(b; x = Sequence{} | x ->including\<^sub>S\<^sub>e\<^sub>q(b)))"

definition OclAsSeq\<^sub>B\<^sub>a\<^sub>g   :: "[('\<AA>,'\<alpha>::null)Bag]\<Rightarrow>('\<AA>,'\<alpha>)Sequence" ("(_)->asSequence\<^sub>B\<^sub>a\<^sub>g'(')")
where     "OclAsSeq\<^sub>B\<^sub>a\<^sub>g S = (S->iterate\<^sub>B\<^sub>a\<^sub>g(b; x = Sequence{} | x ->including\<^sub>S\<^sub>e\<^sub>q(b)))"

definition OclAsSeq\<^sub>P\<^sub>a\<^sub>i\<^sub>r   :: "[('\<AA>,'\<alpha>::null,'\<alpha>::null) Pair]\<Rightarrow>('\<AA>,'\<alpha>)Sequence" ("(_)->asSequence\<^sub>P\<^sub>a\<^sub>i\<^sub>r'(')")
where     "OclAsSeq\<^sub>P\<^sub>a\<^sub>i\<^sub>r S = Sequence{S .First(), S .Second()}"

subsection\<open>Definition: asBag\<close>

definition OclAsBag\<^sub>S\<^sub>e\<^sub>q   :: "[('\<AA>,'\<alpha>::null)Sequence]\<Rightarrow>('\<AA>,'\<alpha>)Bag" ("(_)->asBag\<^sub>S\<^sub>e\<^sub>q'(')")
where     "OclAsBag\<^sub>S\<^sub>e\<^sub>q S = (\<lambda>\<tau>. Abs_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor>\<lambda>s. if list_ex ((=) s) \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (S \<tau>)\<rceil>\<rceil> then 1 else 0\<rfloor>\<rfloor>)"

definition OclAsBag\<^sub>S\<^sub>e\<^sub>t   :: "[('\<AA>,'\<alpha>::null)Set]\<Rightarrow>('\<AA>,'\<alpha>)Bag" ("(_)->asBag\<^sub>S\<^sub>e\<^sub>t'(')")
where     "OclAsBag\<^sub>S\<^sub>e\<^sub>t S = (\<lambda>\<tau>. Abs_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor>\<lambda>s. if s \<in> \<lceil>\<lceil>Rep_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e (S \<tau>)\<rceil>\<rceil> then 1 else 0\<rfloor>\<rfloor>)"

lemma assumes "\<tau> \<Turnstile> \<delta> (S ->size\<^sub>S\<^sub>e\<^sub>t())" (* S is finite *)
      shows "OclAsBag\<^sub>S\<^sub>e\<^sub>t S = (S->iterate\<^sub>S\<^sub>e\<^sub>t(b; x = Bag{} | x ->including\<^sub>B\<^sub>a\<^sub>g(b)))"
oops

definition OclAsBag\<^sub>P\<^sub>a\<^sub>i\<^sub>r   :: "[('\<AA>,'\<alpha>::null,'\<alpha>::null) Pair]\<Rightarrow>('\<AA>,'\<alpha>)Bag" ("(_)->asBag\<^sub>P\<^sub>a\<^sub>i\<^sub>r'(')")
where     "OclAsBag\<^sub>P\<^sub>a\<^sub>i\<^sub>r S = Bag{S .First(), S .Second()}"

text_raw\<open>\isatagafp\<close>
subsection\<open>Collection Types\<close>
lemmas cp_intro'' [intro!,simp,code_unfold] =
       cp_intro'
     (*  cp_intro''\<^sub>P\<^sub>a\<^sub>i\<^sub>r *)
       cp_intro''\<^sub>S\<^sub>e\<^sub>t
       cp_intro''\<^sub>S\<^sub>e\<^sub>q
text_raw\<open>\endisatagafp\<close>

subsection\<open>Test Statements\<close>

lemma syntax_test: "Set{\<two>,\<one>} = (Set{}->including\<^sub>S\<^sub>e\<^sub>t(\<one>)->including\<^sub>S\<^sub>e\<^sub>t(\<two>))"
by (rule refl)

text\<open>Here is an example of a nested collection.\<close>
lemma semantic_test2:
assumes H:"(Set{\<two>} \<doteq> null) = (false::('\<AA>)Boolean)"
shows   "(\<tau>::('\<AA>)st) \<Turnstile> (Set{Set{\<two>},null}->includes\<^sub>S\<^sub>e\<^sub>t(null))"
by(simp add: OclIncludes_execute\<^sub>S\<^sub>e\<^sub>t H)

lemma short_cut'[simp,code_unfold]: "(\<eight> \<doteq> \<six>) = false"
 apply(rule ext)
 apply(simp add: StrictRefEq\<^sub>I\<^sub>n\<^sub>t\<^sub>e\<^sub>g\<^sub>e\<^sub>r StrongEq_def OclInt8_def OclInt6_def
                 true_def false_def invalid_def bot_option_def)
done

lemma short_cut''[simp,code_unfold]: "(\<two> \<doteq> \<one>) = false"
 apply(rule ext)
 apply(simp add: StrictRefEq\<^sub>I\<^sub>n\<^sub>t\<^sub>e\<^sub>g\<^sub>e\<^sub>r StrongEq_def OclInt2_def OclInt1_def
                 true_def false_def invalid_def bot_option_def)
done
lemma short_cut'''[simp,code_unfold]: "(\<one> \<doteq> \<two>) = false"
 apply(rule ext)
 apply(simp add: StrictRefEq\<^sub>I\<^sub>n\<^sub>t\<^sub>e\<^sub>g\<^sub>e\<^sub>r StrongEq_def OclInt2_def OclInt1_def
                 true_def false_def invalid_def bot_option_def)
done

Assert   "\<tau> \<Turnstile> (\<zero> <\<^sub>i\<^sub>n\<^sub>t \<two>) and (\<zero> <\<^sub>i\<^sub>n\<^sub>t \<one>) "

text\<open>Elementary computations on Sets.\<close>

declare OclSelect_body_def [simp]

Assert "\<not> (\<tau> \<Turnstile> \<upsilon>(invalid::('\<AA>,'\<alpha>::null) Set))"
Assert    "\<tau> \<Turnstile> \<upsilon>(null::('\<AA>,'\<alpha>::null) Set)"
Assert "\<not> (\<tau> \<Turnstile> \<delta>(null::('\<AA>,'\<alpha>::null) Set))"
Assert    "\<tau> \<Turnstile> \<upsilon>(Set{})"
Assert    "\<tau> \<Turnstile> \<upsilon>(Set{Set{\<two>},null})"
Assert    "\<tau> \<Turnstile> \<delta>(Set{Set{\<two>},null})"
Assert    "\<tau> \<Turnstile> (Set{\<two>,\<one>}->includes\<^sub>S\<^sub>e\<^sub>t(\<one>))"
Assert "\<not> (\<tau> \<Turnstile> (Set{\<two>}->includes\<^sub>S\<^sub>e\<^sub>t(\<one>)))"
Assert "\<not> (\<tau> \<Turnstile> (Set{\<two>,\<one>}->includes\<^sub>S\<^sub>e\<^sub>t(null)))"
Assert    "\<tau> \<Turnstile> (Set{\<two>,null}->includes\<^sub>S\<^sub>e\<^sub>t(null))"
Assert    "\<tau> \<Turnstile> (Set{null,\<two>}->includes\<^sub>S\<^sub>e\<^sub>t(null))"

Assert    "\<tau> \<Turnstile> ((Set{})->forAll\<^sub>S\<^sub>e\<^sub>t(z | \<zero> <\<^sub>i\<^sub>n\<^sub>t z))"

Assert    "\<tau> \<Turnstile> ((Set{\<two>,\<one>})->forAll\<^sub>S\<^sub>e\<^sub>t(z | \<zero> <\<^sub>i\<^sub>n\<^sub>t z))"
Assert "\<not> (\<tau> \<Turnstile> ((Set{\<two>,\<one>})->exists\<^sub>S\<^sub>e\<^sub>t(z | z <\<^sub>i\<^sub>n\<^sub>t \<zero> )))"
Assert "\<not> (\<tau> \<Turnstile> (\<delta>(Set{\<two>,null})->forAll\<^sub>S\<^sub>e\<^sub>t(z | \<zero> <\<^sub>i\<^sub>n\<^sub>t z)))"
Assert "\<not> (\<tau> \<Turnstile> ((Set{\<two>,null})->forAll\<^sub>S\<^sub>e\<^sub>t(z | \<zero> <\<^sub>i\<^sub>n\<^sub>t z)))"
Assert    "\<tau> \<Turnstile> ((Set{\<two>,null})->exists\<^sub>S\<^sub>e\<^sub>t(z | \<zero> <\<^sub>i\<^sub>n\<^sub>t z))"

Assert "\<not> (\<tau> \<Turnstile> (Set{null::'a Boolean} \<doteq> Set{}))"
Assert "\<not> (\<tau> \<Turnstile> (Set{null::'a Integer} \<doteq> Set{}))"

Assert "\<not> (\<tau> \<Turnstile> (Set{true} \<doteq> Set{false}))"
Assert "\<not> (\<tau> \<Turnstile> (Set{true,true} \<doteq> Set{false}))"
Assert "\<not> (\<tau> \<Turnstile> (Set{\<two>} \<doteq> Set{\<one>}))"
Assert    "\<tau> \<Turnstile> (Set{\<two>,null,\<two>} \<doteq> Set{null,\<two>})"
Assert    "\<tau> \<Turnstile> (Set{\<one>,null,\<two>} <> Set{null,\<two>})"
Assert    "\<tau> \<Turnstile> (Set{Set{\<two>,null}} \<doteq> Set{Set{null,\<two>}})"
Assert    "\<tau> \<Turnstile> (Set{Set{\<two>,null}} <> Set{Set{null,\<two>},null})"
Assert    "\<tau> \<Turnstile> (Set{null}->select\<^sub>S\<^sub>e\<^sub>t(x | not x) \<doteq> Set{null})"
Assert    "\<tau> \<Turnstile> (Set{null}->reject\<^sub>S\<^sub>e\<^sub>t(x | not x) \<doteq> Set{null})"

lemma     "const (Set{Set{\<two>,null}, invalid})" by(simp add: const_ss)

text\<open>Elementary computations on Sequences.\<close>

Assert "\<not> (\<tau> \<Turnstile> \<upsilon>(invalid::('\<AA>,'\<alpha>::null) Sequence))"
Assert    "\<tau> \<Turnstile> \<upsilon>(null::('\<AA>,'\<alpha>::null) Sequence)"
Assert "\<not> (\<tau> \<Turnstile> \<delta>(null::('\<AA>,'\<alpha>::null) Sequence))"
Assert    "\<tau> \<Turnstile> \<upsilon>(Sequence{})"

lemma     "const (Sequence{Sequence{\<two>,null}, invalid})" by(simp add: const_ss)

end