(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
 * This file contains theorems for dealing with a "simply" lifted
 * heap, where each byte of memory can be accessed as one (and only)
 * type.
 *
 * This is a simpler model of Tuch's "lift_t" model, where nested
 * struct fields cannot be directly accessed as pointers.
 *)

theory TypHeapSimple
imports
  "CParser.TypHeapLib"
begin

(*
 * Each address in the heap can contain one of three things:
 *
 *   - A type tag, which inidicates that this address is the first
 *     byte of an object;
 *
 *   - A footprint, which indicates that this address is a latter byte
 *     of an object;
 *
 *   - Nothing, which indicates that this address does not fall inside
 *     an object.
 *)
datatype heap_typ_contents =
    HeapType typ_uinfo
  | HeapFootprint
  | HeapEmpty

(*
 * Given a Tuch-style heap representation (where each memory location
 * contains a set of different types, representing nested field types)
 * calculate a single top-level type of the heap.
 *
 * We just want to commit to a single type for this heap location,
 * and nothing more.
 *)
definition
  heap_type_tag :: "heap_typ_desc \<Rightarrow> addr \<Rightarrow> heap_typ_contents"
where
  "heap_type_tag d a \<equiv>
     (if fst (d a) = False \<or> (\<forall>x. (snd (d a)) x = None) \<or> (\<forall>x. (snd (d a)) x \<noteq> None) then
       HeapEmpty
     else
       case (snd (d a)) (GREATEST x. snd (d a) x \<noteq> None) of
         Some (_, False) \<Rightarrow> HeapFootprint
       | Some (x, True) \<Rightarrow> HeapType x
       | None \<Rightarrow> HeapEmpty)"

(*
 * Determine if the heap has a valid footprint for the given type at
 * the given address.
 *
 * A valid footprint means that the user has committed that the given
 * memory location will only be used for the given type.
 *
 * A "simple" footprint differs from the Tuch-style because we only
 * commit to a single type, and have no support for accessing nested
 * structures.
 *)
definition
  valid_simple_footprint :: "heap_typ_desc \<Rightarrow> addr \<Rightarrow> typ_uinfo \<Rightarrow> bool"
where
  "valid_simple_footprint d x t \<equiv>
    heap_type_tag d x = HeapType t \<and>
      (\<forall>y. y \<in> {x + 1..+  (size_td t)- Suc 0} \<longrightarrow> heap_type_tag d y = HeapFootprint)"

lemma valid_simple_footprintI:
  "\<lbrakk> heap_type_tag d x = HeapType t; \<And>y. y \<in> {x + 1..+(size_td t) - Suc 0} \<Longrightarrow> heap_type_tag d y = HeapFootprint \<rbrakk>
      \<Longrightarrow> valid_simple_footprint d x t"
  by (clarsimp simp: valid_simple_footprint_def)

lemma valid_simple_footprintD:
  "valid_simple_footprint d x t \<Longrightarrow> heap_type_tag d x = HeapType t"
  by (simp add: valid_simple_footprint_def)

lemma valid_simple_footprintD2:
  "\<lbrakk> valid_simple_footprint d x t; y \<in> {x + 1..+(size_td t) - Suc 0} \<rbrakk> \<Longrightarrow> heap_type_tag d y = HeapFootprint"
  by (simp add: valid_simple_footprint_def)

lemma typ_slices_not_empty:
    "typ_slices (x::('a::{mem_type} itself)) \<noteq> []"
  apply (clarsimp simp: typ_slices_def)
  done

lemma last_typ_slice_t:
    "(last (typ_slice_t t 0)) = (t, True)"
  apply (case_tac t)
  apply clarsimp
  done

lemma if_eqI:
 "\<lbrakk> a \<Longrightarrow> x = z; \<not> a \<Longrightarrow> y = z \<rbrakk> \<Longrightarrow> (if a then x else y) = z"
  by simp

lemma heap_type_tag_ptr_retyp:
    "snd (s (ptr_val t)) = Map.empty \<Longrightarrow>
        heap_type_tag (ptr_retyp (t :: 'a::mem_type ptr) s) (ptr_val t) = HeapType (typ_uinfo_t TYPE('a))"
  apply (unfold ptr_retyp_def heap_type_tag_def)
  apply (subst htd_update_list_index, fastforce, fastforce)+
  apply (rule if_eqI)
   apply clarsimp
   apply (erule disjE)
    apply (erule_tac x=0 in allE)
    apply clarsimp
   apply (erule_tac x="length (typ_slice_t (typ_uinfo_t TYPE('a)) 0)" in allE)
   apply (clarsimp simp: list_map_eq)
  apply (clarsimp simp: list_map_eq last_conv_nth [simplified, symmetric] last_typ_slice_t
            split: option.splits if_split_asm prod.splits)
  done

lemma not_snd_last_typ_slice_t:
    "k \<noteq> 0 \<Longrightarrow> \<not> snd (last (typ_slice_t z k))"
  by (case_tac z, clarsimp)

lemma heap_type_tag_ptr_retyp_rest:
    "\<lbrakk> snd (s (ptr_val t + k)) = Map.empty; 0 < k; unat k < size_td (typ_uinfo_t TYPE('a)) \<rbrakk> \<Longrightarrow>
        heap_type_tag (ptr_retyp (t :: 'a::mem_type ptr) s) (ptr_val t + k) = HeapFootprint"
  apply (unfold ptr_retyp_def heap_type_tag_def)
  apply (subst htd_update_list_index, simp, clarsimp,
      metis intvlI size_of_def word_unat.Rep_inverse)+
  apply (rule if_eqI)
   apply clarsimp
   apply (erule disjE)
    apply (erule_tac x=0 in allE)
    apply (clarsimp simp: size_of_def)
   apply (erule_tac x="length (typ_slice_t (typ_uinfo_t TYPE('a)) (unat k))" in allE)
   apply (clarsimp simp: size_of_def list_map_eq)
  apply (clarsimp simp: list_map_eq last_conv_nth [simplified, symmetric] size_of_def
      split: option.splits if_split_asm prod.splits bool.splits)
   apply (metis surj_pair)
  apply (subst (asm) (2) surjective_pairing)
  apply (subst (asm) not_snd_last_typ_slice_t)
   apply clarsimp
   apply unat_arith
  apply simp
  done

lemma typ_slices_addr_card [simp]:
    "length (typ_slices (x::('a::{mem_type} itself))) < addr_card"
  apply (clarsimp simp: typ_slices_def)
  done

lemma htd_update_list_same':
  "\<lbrakk>0 < unat k; unat k \<le> addr_card - length v\<rbrakk> \<Longrightarrow> htd_update_list (p + k) v h p = h p"
  apply (insert htd_update_list_same [where v=v and p=p and h=h and k="unat k"])
  apply clarsimp
  done

lemma unat_less_impl_less:
    "unat a < unat b \<Longrightarrow> a < b"
  by unat_arith

lemma valid_simple_footprint_ptr_retyp:
    "\<lbrakk> \<forall>k < size_td (typ_uinfo_t TYPE('a)). snd (s (ptr_val t + of_nat k)) = Map.empty;
        1 \<le> size_td (typ_uinfo_t TYPE('a));
        size_td (typ_uinfo_t TYPE('a)) < addr_card \<rbrakk>
        \<Longrightarrow> valid_simple_footprint (ptr_retyp (t :: 'a::mem_type ptr) s) (ptr_val t) (typ_uinfo_t TYPE('a))"
  apply (clarsimp simp: valid_simple_footprint_def)
  apply (rule conjI)
   apply (subst heap_type_tag_ptr_retyp)
    apply (erule allE [where x="0"])
    apply clarsimp
   apply clarsimp
  apply (clarsimp simp: intvl_def)
  apply (erule_tac x="k + 1" in allE)
  apply (erule impE)
   apply (metis One_nat_def less_diff_conv)
  apply (subst add.assoc, subst heap_type_tag_ptr_retyp_rest)
     apply clarsimp
    apply (case_tac "1 + of_nat k = (0 :: addr)")
     apply (metis add.left_neutral intvlI intvl_Suc_nmem size_of_def)
    apply unat_arith
   apply clarsimp
   apply (metis lt_size_of_unat_simps size_of_def Suc_eq_plus1 One_nat_def less_diff_conv of_nat_Suc)
  apply simp
  done

(* Determine if the given pointer is valid in the given heap. *)
definition
  heap_ptr_valid :: "heap_typ_desc \<Rightarrow> 'a::c_type ptr \<Rightarrow> bool"
where
  "heap_ptr_valid d p \<equiv>
      valid_simple_footprint d (ptr_val (p::'a ptr)) (typ_uinfo_t TYPE('a))
        \<and> c_guard p"

(*
 * Lift a heap from raw bytes and a heap description into
 * higher-level objects.
 *
 * This differs from Tuch's "lift_t" because we only support
 * simple lifting; that is, each byte in the heap may only
 * be accessed as a single type. Accessing struct fields by
 * their pointers is not supported.
 *)
definition
  simple_lift :: "heap_raw_state \<Rightarrow> ('a::c_type) ptr \<Rightarrow> 'a option"
where
  "simple_lift s p = (
     if (heap_ptr_valid (hrs_htd s) p) then
       (Some (h_val (hrs_mem s) p))
     else
       None)"

lemma simple_lift_heap_ptr_valid:
  "simple_lift s p = Some x \<Longrightarrow> heap_ptr_valid (hrs_htd s) p"
  apply (clarsimp simp: simple_lift_def split: if_split_asm)
  done

lemma simple_lift_c_guard:
  "simple_lift s p = Some x \<Longrightarrow> c_guard p"
  apply (clarsimp simp: simple_lift_def heap_ptr_valid_def split: if_split_asm)
  done

(* Two valid footprints will either overlap completely or not at all. *)
lemma valid_simple_footprint_neq:
  assumes valid_p: "valid_simple_footprint d p s"
      and valid_q: "valid_simple_footprint d q t"
      and neq: "p \<noteq> q"
  shows "p \<notin> {q..+ (size_td t)}"
proof -
  have heap_type_p: "heap_type_tag d p = HeapType s"
    apply (metis valid_p valid_simple_footprint_def)
    done

  have heap_type_q: "heap_type_tag d q = HeapType t"
    apply (metis valid_q valid_simple_footprint_def)
    done

  have heap_type_q_footprint:
    "\<And>x. x \<in> {(q + 1)..+(size_td t - Suc 0)} \<Longrightarrow> heap_type_tag d x = HeapFootprint"
    apply (insert valid_q)
    apply (simp add: valid_simple_footprint_def)
    done

  show ?thesis
    using heap_type_q_footprint heap_type_p neq
         intvl_neq_start heap_type_q
    by (metis heap_typ_contents.simps(2))
qed

(* Two valid footprints with different types will never overlap. *)
lemma valid_simple_footprint_type_neq:
  "\<lbrakk> valid_simple_footprint d p s;
     valid_simple_footprint d q t;
     s \<noteq> t \<rbrakk> \<Longrightarrow>
   p \<notin> {q..+ (size_td t)}"
  apply (subgoal_tac "p \<noteq> q")
   apply (rule valid_simple_footprint_neq, simp_all)[1]
  apply (clarsimp simp: valid_simple_footprint_def)
  done

lemma valid_simple_footprint_neq_disjoint:
  "\<lbrakk> valid_simple_footprint d p s; valid_simple_footprint d q t; p \<noteq> q \<rbrakk> \<Longrightarrow>
      {p..+(size_td s)} \<inter> {q..+ (size_td t)} = {}"
  apply (rule ccontr)
  apply (fastforce simp: valid_simple_footprint_neq dest!: intvl_inter)
  done

lemma valid_simple_footprint_type_neq_disjoint:
  "\<lbrakk> valid_simple_footprint d p s;
     valid_simple_footprint d q t;
     s \<noteq> t \<rbrakk> \<Longrightarrow>
   {p..+(size_td s)} \<inter> {q..+ (size_td t)} = {}"
  apply (subgoal_tac "p \<noteq> q")
   apply (rule valid_simple_footprint_neq_disjoint, simp_all)[1]
  apply (clarsimp simp: valid_simple_footprint_def)
  done

lemma heap_ptr_valid_neq_disjoint:
  "\<lbrakk> heap_ptr_valid d (p::'a::c_type ptr);
     heap_ptr_valid d (q::'b::c_type ptr);
     ptr_val p \<noteq> ptr_val q \<rbrakk> \<Longrightarrow>
   {ptr_val p..+size_of TYPE('a)} \<inter>
          {ptr_val q..+size_of TYPE('b)} = {}"
  apply (clarsimp simp only: size_of_tag [symmetric])
  apply (rule valid_simple_footprint_neq_disjoint [where d="d"])
    apply (clarsimp simp: heap_ptr_valid_def)
   apply (clarsimp simp: heap_ptr_valid_def)
  apply simp
  done

lemma heap_ptr_valid_type_neq_disjoint:
  "\<lbrakk> heap_ptr_valid d (p::'a::c_type ptr);
     heap_ptr_valid d (q::'b::c_type ptr);
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   {ptr_val p..+size_of TYPE('a)} \<inter>
          {ptr_val q..+size_of TYPE('b)} = {}"
  apply (subgoal_tac "ptr_val p \<noteq> ptr_val q")
   apply (rule heap_ptr_valid_neq_disjoint, auto)[1]
  apply (clarsimp simp: heap_ptr_valid_def valid_simple_footprint_def)
  done

(* If we update one pointer in the heap, other valid pointers will be unaffected. *)
lemma heap_ptr_valid_heap_update_other:
  assumes val_p: "heap_ptr_valid d (p::'a::mem_type ptr)"
      and val_q: "heap_ptr_valid d (q::'b::c_type ptr)"
      and neq: "ptr_val p \<noteq> ptr_val q"
  shows "h_val (heap_update p v h) q = h_val h q"
  apply (clarsimp simp: h_val_def heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply simp
   apply (rule heap_ptr_valid_neq_disjoint [OF val_p val_q neq])
  apply simp
  done

(* If we update one type in the heap, other types will be unaffected. *)
lemma heap_ptr_valid_heap_update_other_typ:
  assumes val_p: "heap_ptr_valid d (p::'a::mem_type ptr)"
      and val_q: "heap_ptr_valid d (q::'b::c_type ptr)"
      and neq: "typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b)"
  shows "h_val (heap_update p v h) q = h_val h q"
  apply (clarsimp simp: h_val_def heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply simp
   apply (rule heap_ptr_valid_type_neq_disjoint [OF val_p val_q neq])
  apply simp
  done

(* Updating the raw heap is equivalent to updating the lifted heap. *)
lemma simple_lift_heap_update:
  "\<lbrakk> heap_ptr_valid (hrs_htd h) p \<rbrakk> \<Longrightarrow>
      simple_lift (hrs_mem_update (heap_update p v) h)
          = (simple_lift h)(p := Some (v::'a::mem_type))"
  apply (rule ext)
  apply (clarsimp simp: simple_lift_def hrs_mem_update h_val_heap_update)
  apply (fastforce simp: heap_ptr_valid_heap_update_other)
  done

(* Updating the raw heap of one type doesn't affect the lifted heap of other types. *)
lemma simple_lift_heap_update_other:
  "\<lbrakk> heap_ptr_valid (hrs_htd d) (p::'b::mem_type ptr);
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   simple_lift (hrs_mem_update (heap_update p v) d) = ((simple_lift d)::'a::c_type typ_heap)"
  apply (rule ext)+
  apply (clarsimp simp: simple_lift_def h_val_heap_update hrs_mem_update)
  apply (auto intro: heap_ptr_valid_heap_update_other_typ)
  done

lemma h_val_simple_lift:
  "simple_lift h p = Some v \<Longrightarrow> h_val (hrs_mem h) p = v"
  apply (clarsimp simp: simple_lift_def split: if_split_asm)
  done

lemma h_val_field_simple_lift:
  "\<lbrakk> simple_lift h (pa :: 'a ptr) = Some (v::'a::mem_type);
     \<exists>t. field_ti TYPE('a) f = Some t;
     export_uinfo (the (field_ti TYPE('a) f)) = export_uinfo (typ_info_t TYPE('b :: mem_type)) \<rbrakk> \<Longrightarrow>
   h_val (hrs_mem h) (Ptr &(pa\<rightarrow>f) :: 'b :: mem_type ptr) = from_bytes (access_ti\<^sub>0 (the (field_ti TYPE('a) f)) v)"
  apply (clarsimp simp: simple_lift_def split: if_split_asm)
  apply (clarsimp simp: h_val_field_from_bytes)
  done

lemma simple_lift_heap_update':
  "simple_lift h p = Some v' \<Longrightarrow>
      simple_lift (hrs_mem_update (heap_update (p::('a::{mem_type}) ptr) v) h)
          = (simple_lift h)(p := Some v)"
  apply (rule simple_lift_heap_update)
  apply (erule simple_lift_heap_ptr_valid)
  done

lemma simple_lift_hrs_mem_update_None [simp]:
    "(simple_lift (hrs_mem_update a hp) x = None) = (simple_lift hp x = None)"
  apply (clarsimp simp: simple_lift_def)
  done

lemma simple_lift_data_eq:
   "\<lbrakk> h_val (hrs_mem h) p = h_val (hrs_mem h') p';
     heap_ptr_valid (hrs_htd h) p = heap_ptr_valid (hrs_htd h') p' \<rbrakk> \<Longrightarrow>
    simple_lift h p = simple_lift h' p'"
  apply (clarsimp simp: simple_lift_def)
  done

lemma h_val_heap_update_disjoint:
  "\<lbrakk> {ptr_val p ..+ size_of TYPE('a::c_type)}
        \<inter> {ptr_val q ..+ size_of TYPE('b::mem_type)} = {} \<rbrakk> \<Longrightarrow>
      h_val (heap_update (q :: 'b ptr) r h) (p :: 'a ptr) = h_val h p"
  apply (clarsimp simp: h_val_def)
  apply (clarsimp simp: heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply clarsimp
   apply blast
   apply clarsimp
  done

lemma update_ti_t_valid_size:
  "size_of TYPE('b) = size_td t \<Longrightarrow>
   update_ti_t t (to_bytes_p (val::'b::mem_type)) obj = update_ti t (to_bytes_p val) obj"
  apply (clarsimp simp: update_ti_t_def to_bytes_p_def)
  done

lemma h_val_field_from_bytes':
  "\<lbrakk> field_ti TYPE('a::{mem_type}) f = Some t;
     export_uinfo t = export_uinfo (typ_info_t TYPE('b::{mem_type})) \<rbrakk> \<Longrightarrow>
    h_val h (Ptr &(pa\<rightarrow>f) :: 'b ptr) = from_bytes (access_ti\<^sub>0 t (h_val h pa))"
  apply (insert h_val_field_from_bytes[where f=f and pa=pa and t=t and h="(h,x)"
                                         and 'a='a and 'b='b for x])
  apply (clarsimp simp: hrs_mem_def)
  done

lemma simple_lift_super_field_update_lookup:
  fixes dummy :: "'b :: mem_type"
  assumes "field_lookup (typ_info_t TYPE('b::mem_type)) f 0 = Some (s,n)"
    and "typ_uinfo_t TYPE('a) = export_uinfo s"
    and "simple_lift h p = Some v'"
  shows "(super_field_update_t (Ptr (&(p\<rightarrow>f))) (v::'a::mem_type) ((simple_lift h)::'b ptr \<Rightarrow> 'b option)) =
          ((simple_lift h)(p \<mapsto> field_update (field_desc s) (to_bytes_p v) v'))"
proof -
  from assms have [simp]: "unat (of_nat n :: addr) = n"
     apply (subst unat_of_nat)
     apply (subst mod_less)
      apply (drule td_set_field_lookupD)+
      apply (drule td_set_offset_size)+
      apply (subst len_of_addr_card)
      apply (subst (asm) size_of_def [symmetric, where t="TYPE('b)"])+
      apply (subgoal_tac "size_of TYPE('b) < addr_card")
       apply arith
      apply simp
     apply simp
     done
  from assms show ?thesis
    apply (clarsimp simp: super_field_update_t_def)
    apply (rule ext)
    apply (clarsimp simp: field_lvalue_def split: option.splits)
    apply (safe, simp_all)
       apply (frule_tac v=v and v'=v' in update_field_update)
       apply (clarsimp simp: field_of_t_def field_of_def typ_uinfo_t_def)
       apply (frule_tac m=0 in field_names_SomeD2)
        apply simp
       apply clarsimp
       apply (simp add: field_typ_def field_typ_untyped_def)
       apply (frule field_lookup_export_uinfo_Some)
       apply (frule_tac s=k in field_lookup_export_uinfo_Some)
       apply simp
       apply (drule (1) field_lookup_inject)
        apply (subst typ_uinfo_t_def [symmetric, where t="TYPE('b)"])
        apply simp
       apply simp
      apply (drule field_of_t_mem)+
      apply (case_tac h)
      apply (clarsimp simp: simple_lift_def split: if_split_asm)
      apply (drule (1) heap_ptr_valid_neq_disjoint)
       apply simp
      apply fast
     apply (clarsimp simp: field_of_t_def field_of_def)
     apply (subst (asm) td_set_field_lookup)
      apply simp
     apply simp
     apply (frule field_lookup_export_uinfo_Some)
     apply (simp add: typ_uinfo_t_def)
    apply (clarsimp simp: field_of_t_def field_of_def)
    apply (subst (asm) td_set_field_lookup)
     apply simp
    apply simp
    apply (frule field_lookup_export_uinfo_Some)
    apply (simp add: typ_uinfo_t_def)
    done
qed

lemma field_offset_addr_card:
  "\<exists>x. field_lookup (typ_info_t TYPE('a::mem_type)) f 0 = Some x
    \<Longrightarrow> field_offset TYPE('a) f < addr_card"
  apply (clarsimp simp: field_offset_def field_offset_untyped_def typ_uinfo_t_def)
  apply (subst field_lookup_export_uinfo_Some)
   apply assumption
  apply (frule td_set_field_lookupD)
  apply (drule td_set_offset_size)
  apply (insert max_size [where ?'a="'a"])
  apply (clarsimp simp: size_of_def)
  done

lemma unat_of_nat_field_offset:
  "\<exists>x. field_lookup (typ_info_t TYPE('a::mem_type)) f 0 = Some x \<Longrightarrow>
      unat (of_nat (field_offset TYPE('a) f)  :: addr) = field_offset TYPE('a) f"
  apply (subst word_unat.Abs_inverse)
   apply (clarsimp simp: unats_def)
   apply (insert field_offset_addr_card [where f=f and ?'a="'a"])[1]
   apply (fastforce simp: addr_card)
  apply simp
  done

lemma field_of_t_field_lookup:
  assumes a: "field_lookup (typ_info_t TYPE('a::mem_type)) f 0 = Some (s, n)"
  assumes b: "export_uinfo s = typ_uinfo_t TYPE('b::mem_type)"
  assumes n: "n = field_offset TYPE('a) f"
  shows "field_of_t (Ptr &(ptr\<rightarrow>f) :: ('b ptr)) (ptr :: 'a ptr)"
  apply (clarsimp simp del: field_lookup_offset_eq
                 simp: field_of_t_def field_of_def)
  apply (subst td_set_field_lookup)
   apply (rule wf_desc_typ_tag)
  apply (rule exI [where x=f])
  using a[simplified n] b
  apply (clarsimp simp: typ_uinfo_t_def)
  apply (subst field_lookup_export_uinfo_Some)
   apply assumption
  apply (clarsimp simp del: field_lookup_offset_eq
                  simp: field_lvalue_def unat_of_nat_field_offset)
  done

lemma simple_lift_field_update':
  fixes val :: "'b :: mem_type" and ptr :: "'a :: mem_type ptr"
  assumes   fl: "field_lookup (typ_info_t TYPE('a)) f 0 =
                     Some (adjust_ti (typ_info_t TYPE('b)) xf xfu, n)"
  and   xf_xfu: "fg_cons xf xfu"
  and       cl: "simple_lift hp ptr = Some z"
  shows "(simple_lift (hrs_mem_update (heap_update (Ptr &(ptr\<rightarrow>f)) val) hp)) =
                simple_lift hp(ptr \<mapsto> xfu val z)"
    (is "?LHS = ?RHS")
proof (rule ext)
  fix p

  have eui: "typ_uinfo_t TYPE('b) =
       export_uinfo (adjust_ti (typ_info_t TYPE('b)) xf xfu)"
    using xf_xfu
    apply (subst export_tag_adjust_ti2 [OF _ wf_lf wf_desc])
    apply (simp add: fg_cons_def )
    apply (rule meta_eq_to_obj_eq [OF typ_uinfo_t_def])
    done

  have n_is_field_offset: "n = field_offset TYPE('a) f"
    apply (insert field_lookup_offset_eq [OF fl])
    apply (clarsimp)
    done

  have equal_case: "?LHS ptr = ?RHS ptr"
    apply (insert cl)
    apply (clarsimp simp: simple_lift_def split: if_split_asm)
    apply (clarsimp simp: hrs_mem_update)
    apply (subst h_val_super_update_bs)
     apply (rule field_of_t_field_lookup [OF fl])
      apply (clarsimp simp: eui)
     apply (clarsimp simp: n_is_field_offset)
    apply clarsimp
    apply (unfold from_bytes_def)
    apply (subst fi_fu_consistentD [where f=f and s="adjust_ti (typ_info_t TYPE('b)) xf xfu"])
        apply (clarsimp simp: fl)
        apply (clarsimp simp: n_is_field_offset field_lvalue_def)
        apply (metis unat_of_nat_field_offset fl)
       apply clarsimp
      apply (clarsimp simp: size_of_def)
     apply (clarsimp simp: size_of_def)
    apply clarsimp
    apply (subst update_ti_s_from_bytes)
     apply clarsimp
    apply (subst update_ti_adjust_ti)
     apply (rule xf_xfu)
    apply (subst update_ti_s_from_bytes)
     apply clarsimp
    apply clarsimp
    apply (clarsimp simp: h_val_def)
    done

  show "?LHS p = ?RHS p"
    apply (case_tac "p = ptr")
     apply (erule ssubst)
     apply (rule equal_case)
    apply (insert cl)
    apply (clarsimp simp: simple_lift_def hrs_mem_update split: if_split_asm)
    apply (rule h_val_heap_update_disjoint)
    apply (insert field_tag_sub [OF fl, where p=ptr])
    apply (clarsimp simp: size_of_def)
    apply (clarsimp simp: heap_ptr_valid_def)
    apply (frule (1) valid_simple_footprint_neq_disjoint, fastforce)
    apply clarsimp
    apply blast
    done
qed

lemma simple_lift_field_update:
  fixes val :: "'b :: mem_type" and ptr :: "'a :: mem_type ptr"
  assumes   fl: "field_ti TYPE('a) f =
                     Some (adjust_ti (typ_info_t TYPE('b)) xf (xfu o (\<lambda>x _. x)))"
  and   xf_xfu: "fg_cons xf (xfu o (\<lambda>x _. x))"
  and       cl: "simple_lift hp ptr = Some z"
  shows "(simple_lift (hrs_mem_update (heap_update (Ptr &(ptr\<rightarrow>f)) val) hp)) =
                simple_lift hp(ptr \<mapsto> xfu (\<lambda>_. val) z)"
    (is "?LHS = ?RHS")
  apply (insert fl [unfolded field_ti_def])
  apply (clarsimp split: option.splits)
  apply (subst simple_lift_field_update' [where xf=xf and xfu="xfu o (\<lambda>x _. x)" and z=z])
     apply (clarsimp simp: o_def split: option.splits)
     apply (rule refl)
    apply (rule xf_xfu)
   apply (rule cl)
  apply clarsimp
  done

lemma simple_heap_diff_types_impl_diff_ptrs:
  "\<lbrakk> heap_ptr_valid h (p::('a::c_type) ptr);
     heap_ptr_valid h (q::('b::c_type) ptr);
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   ptr_val p \<noteq> ptr_val q"
  apply (clarsimp simp: heap_ptr_valid_def)
  apply (clarsimp simp: valid_simple_footprint_def)
  done

lemma h_val_update_regions_disjoint:
  "\<lbrakk> { ptr_val p ..+ size_of TYPE('a) } \<inter> { ptr_val x ..+ size_of TYPE('b)} = {} \<rbrakk> \<Longrightarrow>
        h_val (heap_update p (v::('a::mem_type)) h) x = h_val h (x::('b::c_type) ptr)"
  apply (clarsimp simp: heap_update_def)
  apply (clarsimp simp: h_val_def)
  apply (subst heap_list_update_disjoint_same)
   apply clarsimp
  apply clarsimp
  done

lemma simple_lift_field_update_t:
  fixes    val :: "'b :: mem_type" and ptr :: "'a :: mem_type ptr"
  assumes  fl: "field_ti TYPE('a) f = Some t"
  and      diff: "typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('c :: c_type)"
  and      eu: "export_uinfo t = export_uinfo (typ_info_t TYPE('b))"
  and      cl: "simple_lift hp ptr = Some z"
  shows "((simple_lift (hrs_mem_update (heap_update (Ptr &(ptr\<rightarrow>f)) val) hp)) :: 'c ptr \<Rightarrow> 'c option) =
             simple_lift hp"
  apply (rule ext)
  apply (case_tac "simple_lift hp x")
   apply clarsimp
  apply (case_tac "ptr_val x = ptr_val ptr")
   apply clarsimp
   apply (clarsimp simp: simple_lift_def hrs_mem_update split: if_split_asm)
   apply (cut_tac simple_lift_heap_ptr_valid [OF cl])
   apply (drule (1) simple_heap_diff_types_impl_diff_ptrs [OF _ _ diff])
   apply simp
  apply (clarsimp simp: simple_lift_def hrs_mem_update split: if_split_asm)
  apply (rule field_ti_field_lookupE [OF fl])
  apply (frule_tac p=ptr in field_tag_sub)
  apply (clarsimp simp: h_val_def heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply clarsimp
   apply (cut_tac simple_lift_heap_ptr_valid [OF cl])
   apply (drule (2) heap_ptr_valid_neq_disjoint)
   apply (clarsimp simp: export_size_of [unfolded typ_uinfo_t_def, OF eu])
   apply blast
  apply simp
  done

lemma simple_lift_heap_update_other':
  "\<lbrakk> simple_lift h (p::'b::mem_type ptr) = Some v';
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   simple_lift (hrs_mem_update (heap_update p v) h) = ((simple_lift h)::'a::c_type typ_heap)"
  apply (rule simple_lift_heap_update_other)
   apply (erule simple_lift_heap_ptr_valid)
  apply simp
  done

(* If you update bytes inside an object of one type, it won't affect
 * heaps of other types. *)
lemma simple_lift_heap_update_bytes_in_other:
  "\<lbrakk> simple_lift h (p::'b::mem_type ptr) = Some v';
     typ_uinfo_t TYPE('b) \<noteq> typ_uinfo_t TYPE('c);
     { ptr_val q ..+ size_of TYPE('a)} \<subseteq> {ptr_val p  ..+ size_of TYPE('b) }  \<rbrakk> \<Longrightarrow>
   simple_lift (hrs_mem_update (heap_update (q::'a::mem_type ptr) v) h) = ((simple_lift h)::'c::mem_type typ_heap)"
  apply (rule ext)
  apply (clarsimp simp: simple_lift_def split: if_split_asm)
  apply (drule (1) heap_ptr_valid_type_neq_disjoint, simp)
  apply (clarsimp simp: hrs_mem_update)
  apply (rule h_val_heap_update_disjoint)
  apply blast
  done

lemma typ_name_neq:
    "typ_name (export_uinfo (typ_info_t TYPE('a::c_type)))
        \<noteq> typ_name (export_uinfo (typ_info_t TYPE('b::c_type)))
    \<Longrightarrow> typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b)"
  apply (metis typ_uinfo_t_def)
  done

lemma of_nat_mod_div_decomp:
  "of_nat k
        = of_nat (k div size_of TYPE('b)) * of_nat (size_of TYPE('b::mem_type)) +
              of_nat (k mod size_of TYPE('b))"
  by (metis mod_div_decomp of_nat_add of_nat_mult)

lemma c_guard_array_c_guard:
  "\<lbrakk> \<And>x. x < CARD('a) \<Longrightarrow> c_guard (ptr_coerce p +\<^sub>p int x :: 'b ptr) \<rbrakk> \<Longrightarrow> c_guard ( p :: ('b :: mem_type, 'a :: finite) array ptr)"
  apply atomize
  apply (clarsimp simp: c_guard_def)
  apply (rule conjI)
   apply (drule_tac x=0 in spec)
   apply (clarsimp simp: ptr_aligned_def align_of_def align_td_array)
  apply (simp add: c_null_guard_def)
  apply (clarsimp simp: intvl_def)
  apply (drule_tac x="k div size_of TYPE('b)" in spec)
  apply (erule impE)
   apply (metis (full_types) less_nat_zero_code mult_is_0 neq0_conv td_gal_lt)
  apply clarsimp
  apply (drule_tac x="k mod size_of TYPE('b)" in spec)
  apply (clarsimp simp: CTypesDefs.ptr_add_def)
  apply (subst (asm) add.assoc)
  apply (subst (asm) of_nat_mod_div_decomp [symmetric])
  apply clarsimp
  done

lemma heap_list_update_list':
  "\<lbrakk> n + x \<le> length v; length v < addr_card; q = (p + of_nat x) \<rbrakk> \<Longrightarrow>
      heap_list (heap_update_list p v h) n q = take n (drop x v)"
  by (metis heap_list_update_list)

lemma outside_intvl_range:
    "p \<notin> {a ..+ b} \<Longrightarrow> p < a \<or> p \<ge> a + of_nat b"
  apply (clarsimp simp: intvl_def not_le not_less)
  apply (drule_tac x="unat (p-a)" in spec)
  apply clarsimp
  apply (metis add_diff_cancel2 le_less_linear le_unat_uoi
      mpl_lem not_add_less2 unat_mono word_less_minus_mono_left)
  done

lemma first_in_intvl:
  "b \<noteq> 0 \<Longrightarrow> a \<in> {a ..+ b}"
  by (force simp: intvl_def)

lemma zero_not_in_intvl_no_overflow:
  "0 \<notin> {a :: 'a::len word ..+ b} \<Longrightarrow> unat a + b \<le> 2 ^ len_of TYPE('a)"
  apply (rule ccontr)
  apply (simp add: intvl_def not_le)
  apply (drule_tac x="2 ^ len_of TYPE('a) - unat a" in spec)
  apply (clarsimp simp: not_less)
  apply (erule disjE)
   apply (metis (erased) diff_add_inverse less_imp_add_positive of_nat_2p of_nat_add
                unat_lt2p word_neq_0_conv word_unat.Rep_inverse)
  apply (metis le_add_diff_inverse le_antisym le_diff_conv le_refl
               less_imp_le_nat add.commute not_add_less1 unat_lt2p)
  done

lemma intvl_split:
  "\<lbrakk> n \<ge> a \<rbrakk> \<Longrightarrow> { p :: ('a :: len) word ..+ n } = { p ..+ a } \<union> { p + of_nat a ..+ (n - a)}"
  apply (rule set_eqI, rule iffI)
   apply (clarsimp simp: intvl_def not_less)
   apply (rule_tac x=k in exI)
   apply clarsimp
   apply (rule classical)
   apply (drule_tac x="k - a" in spec)
   apply (clarsimp simp: not_less)
   apply (metis diff_less_mono not_less)
  apply (clarsimp simp: intvl_def not_less)
  apply (rule_tac x="unat (x - p)" in exI)
  apply clarsimp
  apply (erule disjE)
   apply clarsimp
   apply (metis le_unat_uoi less_or_eq_imp_le not_less order_trans)
  apply clarsimp
  apply (metis le_def le_eq_less_or_eq le_unat_uoi less_diff_conv
    add.commute of_nat_add)
  done

lemma heap_ptr_valid_range_not_NULL:
  "heap_ptr_valid htd (p :: ('a :: c_type) ptr)
      \<Longrightarrow> 0 \<notin> {ptr_val p ..+ size_of TYPE('a)}"
  apply (clarsimp simp: heap_ptr_valid_def)
  apply (metis c_guard_def c_null_guard_def)
  done

lemma heap_ptr_valid_last_byte_no_overflow:
  "heap_ptr_valid htd (p :: ('a :: c_type) ptr)
      \<Longrightarrow> unat (ptr_val p) + size_of TYPE('a) \<le> 2 ^ len_of TYPE(addr_bitsize)"
  by (metis c_guard_def c_null_guard_def heap_ptr_valid_def
        zero_not_in_intvl_no_overflow)

lemma heap_ptr_valid_intersect_array:
  "\<lbrakk> \<forall>j < n. heap_ptr_valid htd (p +\<^sub>p int j);
        heap_ptr_valid htd (q :: ('a :: c_type) ptr) \<rbrakk>
         \<Longrightarrow> (\<exists>m < n. q = (p +\<^sub>p int m))
    \<or> ({ptr_val p ..+ size_of TYPE ('a) * n} \<inter> {ptr_val q ..+ size_of TYPE ('a :: c_type)} = {})"
  apply (induct n)
   apply clarsimp
  apply atomize
  apply simp
  apply (case_tac "n = 0")
   apply clarsimp
   apply (metis heap_ptr_valid_neq_disjoint ptr_val_inj)
  apply (erule disjE)
   apply (metis less_Suc_eq)
  apply (case_tac "q = p +\<^sub>p int n")
   apply force
  apply (frule_tac x=n in spec)
  apply (erule impE, simp)
  apply (drule (1) heap_ptr_valid_neq_disjoint)
  apply simp
  apply (simp add: CTypesDefs.ptr_add_def)
  apply (rule disjI2)
  apply (cut_tac a=" of_nat n * of_nat (size_of TYPE('a))"
      and p="ptr_val p" and n="n * size_of TYPE('a) + size_of TYPE('a)" in intvl_split)
   apply clarsimp
  apply (clarsimp simp: field_simps Int_Un_distrib2)
  apply (metis IntI emptyE intvl_empty intvl_inter intvl_self neq0_conv)
  done

(* Simplification rules for dealing with "lift_simple". *)

lemmas simple_lift_simps =
  typ_name_neq
  simple_lift_c_guard
  h_val_simple_lift
  simple_lift_heap_update'
  simple_lift_heap_update_other'
  c_guard_field
  h_val_field_simple_lift
  simple_lift_field_update
  simple_lift_field_update_t
  c_guard_array_field
  nat_to_bin_string_simps

(* Old name for the above simpset. *)
lemmas typ_simple_heap_simps = simple_lift_simps

end


(*
   Title: Psi-calculi
   Based on the AFP entry by Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Cong_Simulation
  imports Weak_Simulation Tau_Chain
begin

context env begin

definition
  "weakCongSimulation" :: "'b \<Rightarrow> ('a, 'b, 'c) psi \<Rightarrow>
                       ('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set \<Rightarrow>
                       ('a, 'b, 'c) psi \<Rightarrow> bool" ("_ \<rhd> _ \<leadsto>\<guillemotleft>_\<guillemotright> _" [80, 80, 80, 80] 80)
where
  "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q \<equiv> \<forall>Q'. \<Psi> \<rhd> Q \<longmapsto>None @ \<tau> \<prec> Q' \<longrightarrow> (\<exists>P'. \<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P' \<and> (\<Psi>, P', Q') \<in> Rel)"

abbreviation
  weakCongSimulationNilJudge ("_ \<leadsto>\<guillemotleft>_\<guillemotright> _" [80, 80, 80] 80) where "P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q \<equiv> \<one> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"

lemma weakCongSimI[case_names c_tau]:
  fixes \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"
  and   C   :: "'d::fs_name"

  assumes rTau:  "\<And>Q'. \<Psi> \<rhd> Q \<longmapsto>None @ \<tau> \<prec> Q' \<Longrightarrow> \<exists>P'. \<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P' \<and> (\<Psi>, P', Q') \<in> Rel"

  shows "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"
using assms
by(auto simp add: weakCongSimulation_def)

lemma weakCongSimE:
  fixes F   :: 'b
  and   P   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"
  and "\<Psi> \<rhd> Q \<longmapsto>None @ \<tau> \<prec> Q'"

  obtains P' where "\<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P'" and "(\<Psi>, P', Q') \<in> Rel"
using assms
by(auto simp add: weakCongSimulation_def)

lemma weakCongSimClosedAux:
  fixes \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"
  and   p   :: "name prm"

  assumes EqvtRel: "eqvt Rel"
  and     PSimQ: "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"

  shows "(p \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<leadsto>\<guillemotleft>Rel\<guillemotright> (p \<bullet> Q)"
proof(induct rule: weakCongSimI)
  case(c_tau Q')
  from `p \<bullet> \<Psi> \<rhd> p \<bullet> Q \<longmapsto>None @ \<tau> \<prec> Q'`
  have "(rev p \<bullet> p \<bullet> \<Psi>) \<rhd> (rev p \<bullet> p \<bullet> Q) \<longmapsto>(rev p\<bullet> None) @ (rev p \<bullet> (\<tau> \<prec> Q'))"
    by(blast dest: semantics.eqvt)
  hence "\<Psi> \<rhd> Q \<longmapsto>None @ \<tau> \<prec> (rev p \<bullet> Q')" by(simp add: eqvts)
  with PSimQ obtain P' where PChain: "\<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(\<Psi>, P', rev p \<bullet> Q') \<in> Rel"
    by(blast dest: weakCongSimE)
  from PChain have "(p \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<Longrightarrow>\<^sub>\<tau> (p \<bullet> P')" by(rule tau_step_chainEqvt)
  moreover from P'RelQ' EqvtRel have "(p \<bullet> (\<Psi>,  P', rev p \<bullet> Q')) \<in> Rel"
    by(simp only: eqvt_def)
  hence "(p \<bullet> \<Psi>, p \<bullet> P', Q') \<in> Rel" by(simp add: eqvts)
  ultimately show ?case
    by blast
qed

lemma weakCongSimClosed:
  fixes \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"
  and   p   :: "name prm"

  assumes EqvtRel: "eqvt Rel"

  shows "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q \<Longrightarrow> (p \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<leadsto>\<guillemotleft>Rel\<guillemotright> (p \<bullet> Q)"
  and   "P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q \<Longrightarrow> (p \<bullet> P) \<leadsto>\<guillemotleft>Rel\<guillemotright> (p \<bullet> Q)"
using EqvtRel
by(force dest: weakCongSimClosedAux simp add: perm_bottom)+

lemma weakCongSimReflexive:
  fixes Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"

  assumes "{(\<Psi>, P, P) | \<Psi> P. True} \<subseteq> Rel"

  shows "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> P"
using assms
by(auto simp add: weakCongSimulation_def dest: rtrancl_into_rtrancl)

lemma weakStepSimTauChain:
  fixes \<Psi>   :: 'b
  and   Q   :: "('a, 'b, 'c) psi"
  and   Q'  :: "('a, 'b, 'c) psi"
  and   P   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes "\<Psi> \<rhd> Q \<Longrightarrow>\<^sub>\<tau> Q'"
  and     "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"
  and     Sim: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> Rel \<Longrightarrow> \<Psi> \<rhd> P \<leadsto><Rel> Q"

  obtains P' where "\<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P'" and "(\<Psi>, P', Q') \<in> Rel"
proof -
  assume A: "\<And>P'. \<lbrakk>\<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P'; (\<Psi>, P', Q') \<in> Rel\<rbrakk> \<Longrightarrow> thesis"
  from `\<Psi> \<rhd> Q \<Longrightarrow>\<^sub>\<tau> Q'` `\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q` A show ?thesis
  proof(induct arbitrary: P thesis rule: tau_step_chain_induct)
    case(tau_base Q Q' P)
    with `\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q` `\<Psi> \<rhd> Q \<longmapsto>None @ \<tau> \<prec> Q'` obtain P' where PChain: "\<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(\<Psi>, P', Q') \<in> Rel"
      by(rule_tac weakCongSimE)
    thus ?case by(rule tau_base)
  next
    case(tau_step Q Q' Q'' P)
    from `\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q` obtain P' where PChain: "\<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P'" and "(\<Psi>, P', Q') \<in> Rel"
      by(rule tau_step)
    from `(\<Psi>, P', Q') \<in> Rel` have "\<Psi> \<rhd> P' \<leadsto><Rel> Q'" by(rule Sim)
    then obtain P'' where P'Chain: "\<Psi> \<rhd> P' \<Longrightarrow>\<^sup>^\<^sub>\<tau> P''" and "(\<Psi>, P'', Q'') \<in> Rel"
      using `\<Psi> \<rhd> Q' \<longmapsto>None @ \<tau> \<prec> Q''` by(blast dest: weakSimE)
    from PChain P'Chain have "\<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P''" by simp
    thus ?case using `(\<Psi>, P'', Q'') \<in> Rel` by(rule tau_step)
  qed
qed

lemma weakCongSimTransitive:
  fixes \<Psi>     :: 'b
  and   P      :: "('a, 'b, 'c) psi"
  and   Rel    :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q      :: "('a, 'b, 'c) psi"
  and   Rel'   :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   T      :: "('a, 'b, 'c) psi"
  and   Rel''  :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes PRelQ: "(\<Psi>, P, Q) \<in> Rel"
  and     PSimQ: "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"
  and     QSimR: "\<Psi> \<rhd> Q \<leadsto>\<guillemotleft>Rel'\<guillemotright> R"
  and     Set: "{(\<Psi>, P, R) | \<Psi> P R. \<exists>Q. (\<Psi>, P, Q) \<in> Rel \<and> (\<Psi>, Q, R) \<in> Rel'} \<subseteq> Rel''"
  and     Sim: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> Rel \<Longrightarrow> \<Psi> \<rhd> P \<leadsto><Rel> Q"

  shows "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel''\<guillemotright> R"
proof(induct rule: weakCongSimI)
  case(c_tau R')
  from QSimR `\<Psi> \<rhd> R \<longmapsto>None @ \<tau> \<prec> R'` obtain Q' where QChain: "\<Psi> \<rhd> Q \<Longrightarrow>\<^sub>\<tau> Q'" and Q'RelR': "(\<Psi>, Q', R') \<in> Rel'"
    by(blast dest: weakCongSimE)
  from QChain PSimQ Sim obtain P' where PChain: "\<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(\<Psi>, P', Q') \<in> Rel"
    by(rule weakStepSimTauChain)
  moreover from P'RelQ' Q'RelR' Set have "(\<Psi>, P', R') \<in> Rel''" by blast
  ultimately show ?case by blast
qed

lemma weakCongSimStatEq:
  fixes \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"
  and   \<Psi>'  :: 'b

  assumes PSimQ: "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"
  and     "\<Psi> \<simeq> \<Psi>'"
  and     C1: "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>(\<Psi>, P, Q) \<in> Rel; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> Rel'"

  shows "\<Psi>' \<rhd> P \<leadsto>\<guillemotleft>Rel'\<guillemotright> Q"
proof(induct rule: weakCongSimI)
  case(c_tau Q')
  from `\<Psi>' \<rhd> Q \<longmapsto>None @ \<tau> \<prec> Q'` `\<Psi> \<simeq> \<Psi>'`
  have "\<Psi> \<rhd> Q \<longmapsto>None @ \<tau> \<prec> Q'" by(metis stat_eq_transition Assertion_stat_eq_sym)
  with PSimQ obtain P' where PChain: "\<Psi> \<rhd> P \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(\<Psi>, P', Q') \<in> Rel"
    by(blast dest: weakCongSimE)

  from PChain `\<Psi> \<simeq> \<Psi>'` have "\<Psi>' \<rhd> P \<Longrightarrow>\<^sub>\<tau> P'" by(rule tau_step_chain_stat_eq)
  moreover from `(\<Psi>, P', Q') \<in> Rel` `\<Psi> \<simeq> \<Psi>'` have "(\<Psi>', P', Q') \<in> Rel'"
    by(rule C1)
  ultimately show ?case by blast
qed

lemma weakCongSimMonotonic:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   A :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q :: "('a, 'b, 'c) psi"
  and   B :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>A\<guillemotright> Q"
  and     "A \<subseteq> B"

  shows "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>B\<guillemotright> Q"
using assms
by(simp (no_asm) add: weakCongSimulation_def) (blast dest: weakCongSimE)+

lemma strongSimWeakCongSim:
  fixes \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<leadsto>[Rel] Q"
  and     "Rel \<subseteq> Rel'"

  shows "\<Psi> \<rhd> P \<leadsto>\<guillemotleft>Rel'\<guillemotright> Q"
using assms
apply(auto simp add: simulation_def weakCongSimulation_def)
by(erule_tac x=\<tau> in allE) (fastforce elim: tau_no_provenance')

end

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HoareTotal.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section \<open>Derived Hoare Rules for Total Correctness\<close>

theory HoareTotal imports HoareTotalProps begin

lemma conseq_no_aux:
  "\<lbrakk>\<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q',A';
    \<forall>s. s \<in> P \<longrightarrow> (s\<in>P' \<and> (Q' \<subseteq> Q)\<and> (A' \<subseteq> A))\<rbrakk>
  \<Longrightarrow>
  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq [where P'="\<lambda>Z. P'" and Q'="\<lambda>Z. Q'" and A'="\<lambda>Z. A'"]) auto

text \<open>If for example a specification for a "procedure pointer" parameter
is in the precondition we can extract it with this rule\<close>
lemma conseq_exploit_pre:
             "\<lbrakk>\<forall>s \<in> P. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s} \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  apply (rule Conseq)
  apply clarify
  apply (rule_tac x="{s} \<inter> P" in exI)
  apply (rule_tac x="Q" in exI)
  apply (rule_tac x="A" in exI)
  by simp

lemma conseq:"\<lbrakk>\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
              \<forall>s. s \<in> P \<longrightarrow> (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q)\<and> (A' Z \<subseteq> A))\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (rule Conseq') blast

lemma Lem:"\<lbrakk>\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
            P \<subseteq> {s. \<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A)}\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (lem x c) Q,A"
  apply (unfold lem_def)
  apply (erule conseq)
  apply blast
  done

lemma LemAnno:
assumes conseq:  "P \<subseteq> {s. \<exists>Z. s\<in>P' Z \<and>
                     (\<forall>t. t \<in> Q' Z \<longrightarrow> t \<in> Q) \<and> (\<forall>t. t \<in> A' Z \<longrightarrow> t \<in> A)}"
assumes lem: "\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (lem x c) Q,A"
  apply (rule Lem [OF lem])
  using conseq
  by blast

lemma LemAnnoNoAbrupt:
assumes conseq:  "P \<subseteq>  {s. \<exists>Z. s\<in>P' Z \<and> (\<forall>t. t \<in> Q' Z \<longrightarrow> t \<in> Q)}"
assumes lem: "\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),{}"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (lem x c) Q,{}"
  apply (rule Lem [OF lem])
  using conseq
  by blast

lemma TrivPost: "\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)
                 \<Longrightarrow>
                 \<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c UNIV,UNIV"
apply (rule allI)
apply (erule conseq)
apply auto
done

lemma TrivPostNoAbr: "\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),{}
                 \<Longrightarrow>
                 \<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c UNIV,{}"
apply (rule allI)
apply (erule conseq)
apply auto
done

lemma DynComConseq:
  assumes "P \<subseteq> {s. \<exists>P' Q' A'.  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F \<^esub>P' (c s) Q',A' \<and> P \<subseteq> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F \<^esub>P DynCom c Q,A"
  using assms
  apply -
  apply (rule hoaret.DynCom)
  apply clarsimp
  apply (rule hoaret.Conseq)
  apply clarsimp
  apply blast
  done

lemma SpecAnno:
 assumes consequence: "P \<subseteq> {s. (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A))}"
 assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) (c Z) (Q' Z),(A' Z)"
 assumes bdy_constant:  "\<forall>Z. c Z = c undefined"
 shows   "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (specAnno P' c Q' A') Q,A"
proof -
  from spec bdy_constant
  have "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) (c undefined) (Q' Z),(A' Z)"
    apply -
    apply (rule allI)
    apply (erule_tac x=Z in allE)
    apply (erule_tac x=Z in allE)
    apply simp
    done
  with consequence show ?thesis
    apply (simp add: specAnno_def)
    apply (erule conseq)
    apply blast
    done
qed

lemma SpecAnno':
 "\<lbrakk>P \<subseteq> {s.  \<exists> Z. s\<in>P' Z \<and>
            (\<forall>t. t \<in> Q' Z \<longrightarrow>  t \<in> Q) \<and> (\<forall>t. t \<in> A' Z \<longrightarrow> t \<in>  A)};
   \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) (c Z) (Q' Z),(A' Z);
   \<forall>Z. c Z = c undefined
  \<rbrakk> \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (specAnno P' c Q' A') Q,A"
apply (simp only: subset_iff [THEN sym])
apply (erule (1) SpecAnno)
apply assumption
done

lemma SpecAnnoNoAbrupt:
 "\<lbrakk>P \<subseteq> {s.  \<exists> Z. s\<in>P' Z \<and>
            (\<forall>t. t \<in> Q' Z \<longrightarrow>  t \<in> Q)};
   \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) (c Z) (Q' Z),{};
   \<forall>Z. c Z = c undefined
  \<rbrakk> \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (specAnno P' c Q' (\<lambda>s. {})) Q,A"
apply (rule SpecAnno')
apply auto
done

lemma Skip: "P \<subseteq> Q \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Skip Q,A"
  by (rule hoaret.Skip [THEN conseqPre],simp)

lemma Basic: "P \<subseteq> {s. (f s) \<in> Q} \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Basic f) Q,A"
  by (rule hoaret.Basic [THEN conseqPre])

lemma BasicCond:
  "\<lbrakk>P \<subseteq> {s. (b s \<longrightarrow> f s\<in>Q) \<and> (\<not> b s \<longrightarrow> g s\<in>Q)}\<rbrakk> \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Basic (\<lambda>s. if b s then f s else g s) Q,A"
  apply (rule Basic)
  apply auto
  done

lemma Spec: "P \<subseteq> {s. (\<forall>t. (s,t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s,t) \<in> r)}
            \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Spec r) Q,A"
by (rule hoaret.Spec [THEN conseqPre])

lemma SpecIf:
  "\<lbrakk>P \<subseteq> {s. (b s \<longrightarrow> f s \<in> Q) \<and> (\<not> b s \<longrightarrow> g s \<in> Q \<and> h s \<in> Q)}\<rbrakk> \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Spec (if_rel b f g h) Q,A"
  apply (rule Spec)
  apply (auto simp add: if_rel_def)
  done

lemma Seq [trans, intro?]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Seq c\<^sub>1 c\<^sub>2 Q,A"
  by (rule hoaret.Seq)

lemma SeqSwap:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c2 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c1 R,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Seq c1 c2 Q,A"
  by (rule Seq)

lemma BSeq:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (bseq c\<^sub>1 c\<^sub>2) Q,A"
  by (unfold bseq_def) (rule Seq)

lemma Cond:
  assumes wp: "P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
  assumes deriv_c1: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q,A"
  assumes deriv_c2: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"
proof (rule hoaret.Cond [THEN conseqPre])
  from deriv_c1
  show "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. (s \<in> b \<longrightarrow> s \<in> P\<^sub>1) \<and> (s \<notin> b \<longrightarrow> s \<in> P\<^sub>2)} \<inter> b) c\<^sub>1 Q,A"
    by (rule conseqPre) blast
next
  from deriv_c2
  show "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. (s \<in> b \<longrightarrow> s \<in> P\<^sub>1) \<and> (s \<notin> b \<longrightarrow> s \<in> P\<^sub>2)} \<inter> - b) c\<^sub>2 Q,A"
    by (rule conseqPre) blast
qed (insert wp)

lemma CondSwap:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P1 c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P2 c2 Q,A;
    P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P1) \<and> (s\<notin>b \<longrightarrow> s\<in>P2)}\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Cond b c1 c2) Q,A"
  by (rule Cond)

lemma Cond':
  "\<lbrakk>P \<subseteq> {s. (b \<subseteq> P1) \<and> (- b \<subseteq> P2)};\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P1 c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P2 c2 Q,A\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Cond b c1 c2) Q,A"
  by (rule CondSwap) blast+

lemma CondInv:
  assumes wp: "P \<subseteq> Q"
  assumes inv: "Q \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
  assumes deriv_c1: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q,A"
  assumes deriv_c2: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"
proof -
  from wp inv
  have "P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
    by blast
  from Cond [OF this deriv_c1 deriv_c2]
  show ?thesis .
qed

lemma CondInv':
  assumes wp: "P \<subseteq> I"
  assumes inv: "I \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
  assumes wp': "I \<subseteq> Q"
  assumes deriv_c1: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 I,A"
  assumes deriv_c2: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 I,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"
proof -
  from CondInv [OF wp inv deriv_c1 deriv_c2]
  have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) I,A" .
  from conseqPost [OF this wp' subset_refl]
  show ?thesis .
qed

lemma switchNil:
  "P \<subseteq> Q \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F \<^esub>P (switch v []) Q,A"
  by (simp add: Skip)

lemma switchCons:
  "\<lbrakk>P \<subseteq> {s. (v s \<in> V \<longrightarrow> s \<in> P\<^sub>1) \<and> (v s \<notin> V \<longrightarrow> s \<in> P\<^sub>2)};
        \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F \<^esub>P\<^sub>1 c Q,A;
        \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F \<^esub>P\<^sub>2 (switch v vs) Q,A\<rbrakk>
\<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F \<^esub>P (switch v ((V,c)#vs)) Q,A"
  by (simp add: Cond)

lemma Guard:
 "\<lbrakk>P \<subseteq> g \<inter> R; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Guard f g c Q,A"
apply (rule HoareTotalDef.Guard [THEN conseqPre, of _ _ _ _ R])
apply (erule conseqPre)
apply auto
done

lemma GuardSwap:
 "\<lbrakk> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> g \<inter> R\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Guard f g c Q,A"
  by (rule Guard)

lemma Guarantee:
 "\<lbrakk>P \<subseteq> {s. s \<in> g \<longrightarrow> s \<in> R}; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
apply (rule Guarantee [THEN conseqPre, of _ _ _ _ _ "{s. s \<in> g \<longrightarrow> s \<in> R}"])
apply   assumption
apply  (erule conseqPre)
apply auto
done

lemma GuaranteeSwap:
 "\<lbrakk> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> {s. s \<in> g \<longrightarrow> s \<in> R}; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
  by (rule Guarantee)

lemma GuardStrip:
 "\<lbrakk>P \<subseteq> R; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
apply (rule Guarantee [THEN conseqPre])
apply auto
done

lemma GuardStripSwap:
 "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> R; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
  by (rule GuardStrip)

lemma GuaranteeStrip:
 "\<lbrakk>P \<subseteq> R; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (unfold guaranteeStrip_def) (rule GuardStrip)

lemma GuaranteeStripSwap:
 "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> R; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (unfold guaranteeStrip_def) (rule GuardStrip)

lemma GuaranteeAsGuard:
 "\<lbrakk>P \<subseteq> g \<inter> R; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P guaranteeStrip f g c Q,A"
  by (unfold guaranteeStrip_def) (rule Guard)

lemma GuaranteeAsGuardSwap:
 "\<lbrakk> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> g \<inter> R\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P guaranteeStrip f g c Q,A"
  by (rule GuaranteeAsGuard)

lemma GuardsNil:
  "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (guards [] c) Q,A"
  by simp

lemma GuardsConsGuaranteeStrip:
  "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P guaranteeStrip f g (guards gs c) Q,A \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (guards (guaranteeStripPair f g#gs) c) Q,A"
  by (simp add: guaranteeStripPair_def guaranteeStrip_def)

lemma While:
  assumes P_I: "P \<subseteq> I"
  assumes deriv_body:
  "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> I \<inter> b) c ({t. (t, \<sigma>) \<in> V} \<inter> I),A"
  assumes I_Q: "I \<inter> -b \<subseteq> Q"
  assumes wf: "wf V"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnno  b I V c) Q,A"
proof -
  from wf deriv_body P_I I_Q
  show ?thesis
    apply (unfold whileAnno_def)
    apply (erule conseqPrePost [OF HoareTotalDef.While])
    apply auto
    done
qed

lemma WhileInvPost:
  assumes P_I: "P \<subseteq> I"
  assumes termi_body:
  "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/UNIV\<^esub> ({\<sigma>} \<inter> I \<inter> b) c ({t. (t, \<sigma>) \<in> V} \<inter> P),A"
  assumes deriv_body:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (I \<inter> b) c I,A"
  assumes I_Q: "I \<inter> -b \<subseteq> Q"
  assumes wf: "wf V"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnno  b I V c) Q,A"
proof -
  have "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> I \<inter> b) c ({t. (t, \<sigma>) \<in> V} \<inter> I),A"
  proof
    fix \<sigma>
    from hoare_sound [OF deriv_body] hoaret_sound [OF termi_body [rule_format, of \<sigma>]]
    have "\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> I \<inter> b) c ({t. (t, \<sigma>) \<in> V} \<inter> I),A"
      by (fastforce simp add: cvalidt_def validt_def cvalid_def valid_def)
    then
    show "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> I \<inter> b) c ({t. (t, \<sigma>) \<in> V} \<inter> I),A"
      by (rule hoaret_complete')
  qed

  from While [OF P_I this I_Q wf]
  show ?thesis .
qed

(* *)
lemma "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) (Seq c (Guard f Q Skip)) Q,A"
oops

text \<open>@{term "J"} will be instantiated by tactic with @{term "gs' \<inter> I"} for
  those guards that are not stripped.\<close>
lemma WhileAnnoG:
  "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (guards gs
                    (whileAnno  b J V (Seq c (guards gs Skip)))) Q,A
        \<Longrightarrow>
        \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnnoG gs b I V c) Q,A"
  by (simp add: whileAnnoG_def whileAnno_def while_def)

text \<open>This form stems from @{term "strip_guards F (whileAnnoG gs b I V c)"}\<close>

lemma WhileAnnoFix':
assumes consequence: "P \<subseteq> {s. (\<exists> Z. s\<in>I Z \<and>
                               (\<forall>t. t \<in> I Z \<inter> -b \<longrightarrow> t \<in> Q)) }"
assumes bdy: "\<forall>Z \<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> I Z \<inter> b) (c Z) ({t. (t, \<sigma>) \<in> V Z} \<inter> I Z),A"
assumes bdy_constant:  "\<forall>Z. c Z = c undefined"
assumes wf: "\<forall>Z. wf (V Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnnoFix b I V c) Q,A"
  apply (rule WhileAnnoFix [OF _ bdy bdy_constant wf])
  using consequence by blast

lemma WhileAnnoGFix:
assumes whileAnnoFix:
  "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (guards gs
                (whileAnnoFix  b J V (\<lambda>Z. (Seq (c Z) (guards gs Skip))))) Q,A"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnnoGFix gs b I V c) Q,A"
  using whileAnnoFix
  by (simp add: whileAnnoGFix_def whileAnnoFix_def while_def)

lemma Bind:
  assumes adapt: "P \<subseteq> {s. s \<in> P' s}"
  assumes c: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' s) (c (e s)) Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (bind e c) Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. s=Z \<and> s \<in> P' Z}" and Q'="\<lambda>Z. Q" and
A'="\<lambda>Z. A"])
apply  (rule allI)
apply  (unfold bind_def)
apply  (rule HoareTotalDef.DynCom)
apply  (rule ballI)
apply  clarsimp
apply  (rule conseqPre)
apply   (rule c [rule_format])
apply  blast
using adapt
apply blast
done

lemma Block:
assumes adapt: "P \<subseteq> {s. init s \<in> P' s}"
assumes bdy: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \<in> R s t},{t. return s t \<in> A}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (block init bdy return c) Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. s=Z \<and> init s \<in> P' Z}" and Q'="\<lambda>Z. Q" and
A'="\<lambda>Z. A"])
prefer 2
using adapt
apply  blast
apply (rule allI)
apply (unfold block_def)
apply (rule HoareTotalDef.DynCom)
apply (rule ballI)
apply clarsimp
apply (rule_tac R="{t. return Z t \<in> R Z t}" in SeqSwap )
apply  (rule_tac  P'="\<lambda>Z'. {t. t=Z' \<and> return Z t \<in> R Z t}" and
          Q'="\<lambda>Z'. Q" and A'="\<lambda>Z'. A" in conseq)
prefer 2 apply simp
apply  (rule allI)
apply  (rule HoareTotalDef.DynCom)
apply  (clarsimp)
apply  (rule SeqSwap)
apply   (rule c [rule_format])
apply  (rule Basic)
apply  clarsimp
apply (rule_tac R="{t. return Z t \<in> A}" in HoareTotalDef.Catch)
apply  (rule_tac R="{i. i \<in> P' Z}" in Seq)
apply   (rule Basic)
apply   clarsimp
apply  simp
apply  (rule bdy [rule_format])
apply (rule SeqSwap)
apply  (rule Throw)
apply (rule Basic)
apply simp
done

lemma BlockSwap:
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes bdy: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \<in> R s t},{t. return s t \<in> A}"
assumes adapt: "P \<subseteq> {s. init s \<in> P' s}"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (block init bdy return c) Q,A"
  using adapt bdy c
  by (rule Block)

lemma BlockSpec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                             (\<forall>t. t \<in> A' Z \<longrightarrow> return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes bdy: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) bdy (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (block init bdy return c) Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                             (\<forall>t. t \<in> A' Z \<longrightarrow> return s t \<in> A)}" and Q'="\<lambda>Z. Q" and
A'="\<lambda>Z. A"])
prefer 2
using adapt
apply  blast
apply (rule allI)
apply (unfold block_def)
apply (rule HoareTotalDef.DynCom)
apply (rule ballI)
apply clarsimp
apply (rule_tac R="{t. return s t \<in> R s t}" in SeqSwap )
apply  (rule_tac  P'="\<lambda>Z'. {t. t=Z' \<and> return s t \<in> R s t}" and
          Q'="\<lambda>Z'. Q" and A'="\<lambda>Z'. A" in conseq)
prefer 2 apply simp
apply  (rule allI)
apply  (rule HoareTotalDef.DynCom)
apply  (clarsimp)
apply  (rule SeqSwap)
apply   (rule c [rule_format])
apply  (rule Basic)
apply  clarsimp
apply (rule_tac R="{t. return s t \<in> A}" in HoareTotalDef.Catch)
apply  (rule_tac R="{i. i \<in> P' Z}" in Seq)
apply   (rule Basic)
apply   clarsimp
apply  simp
apply  (rule conseq [OF bdy])
apply  clarsimp
apply  blast
apply (rule SeqSwap)
apply  (rule Throw)
apply (rule Basic)
apply simp
done

lemma Throw: "P \<subseteq> A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Throw Q,A"
  by (rule hoaret.Throw [THEN conseqPre])

lemmas Catch = hoaret.Catch
lemma CatchSwap: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c\<^sub>2 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c\<^sub>1 Q,R\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A"
  by (rule hoaret.Catch)

lemma raise: "P \<subseteq> {s. f s \<in> A} \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P raise f Q,A"
  apply (simp add: raise_def)
  apply (rule Seq)
  apply  (rule Basic)
  apply  (assumption)
  apply (rule Throw)
  apply (rule subset_refl)
  done

lemma condCatch: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c\<^sub>1 Q,((b \<inter> R) \<union> (-b \<inter> A));\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk>
                  \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P condCatch c\<^sub>1 b c\<^sub>2 Q,A"
  apply (simp add: condCatch_def)
  apply (rule Catch)
  apply  assumption
  apply (rule CondSwap)
  apply   (assumption)
  apply  (rule hoaret.Throw)
  apply blast
  done

lemma condCatchSwap: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c\<^sub>2 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c\<^sub>1 Q,((b \<inter> R) \<union> (-b \<inter> A))\<rbrakk>
                     \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P condCatch c\<^sub>1 b c\<^sub>2 Q,A"
  by (rule condCatch)

lemma ProcSpec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                             (\<forall>t. t \<in> A' Z \<longrightarrow> return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A"
using adapt c p
apply (unfold call_def)
by (rule BlockSpec)

lemma ProcSpec':
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t \<in> Q' Z. return s t \<in> R s t) \<and>
                             (\<forall>t \<in> A' Z. return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A"
apply (rule ProcSpec [OF _ c p])
apply (insert adapt)
apply clarsimp
apply (drule (1) subsetD)
apply (clarsimp)
apply (rule_tac x=Z in exI)
apply blast
done

lemma ProcSpecNoAbrupt:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A"
apply (rule ProcSpec [OF _ c p])
using adapt
apply simp
done

lemma FCall:
"\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (call init p return (\<lambda>s t. c (result t))) Q,A
\<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (fcall init p return result c) Q,A"
  by (simp add: fcall_def)

lemma ProcRec:
  assumes deriv_bodies:
   "\<forall>p\<in>Procs.
    \<forall>\<sigma> Z. \<Gamma>,\<Theta>\<union>(\<Union>q\<in>Procs. \<Union>Z.
       {(P q Z \<inter> {s. ((s,q), \<sigma>,p) \<in> r},q,Q q Z,A q Z)})
        \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  assumes wf: "wf r"
  assumes Procs_defined: "Procs \<subseteq> dom \<Gamma>"
  shows "\<forall>p\<in>Procs. \<forall>Z.
  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub>(P p Z) Call p (Q p Z),(A p Z)"
  by (intro strip)
     (rule HoareTotalDef.CallRec'
     [OF _  Procs_defined wf deriv_bodies],
     simp_all)

lemma ProcRec':
  assumes ctxt:
   "\<Theta>'=(\<lambda>\<sigma> p. \<Theta>\<union>(\<Union>q\<in>Procs.
                   \<Union>Z. {(P q Z \<inter> {s. ((s,q), \<sigma>,p) \<in> r},q,Q q Z,A q Z)}))"
  assumes deriv_bodies:
   "\<forall>p\<in>Procs.
    \<forall>\<sigma> Z. \<Gamma>,\<Theta>' \<sigma> p\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  assumes wf: "wf r"
  assumes Procs_defined: "Procs \<subseteq> dom \<Gamma>"
  shows "\<forall>p\<in>Procs. \<forall>Z.  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub>(P p Z) Call p (Q p Z),(A p Z)"
  using ctxt deriv_bodies
  apply simp
  apply (erule ProcRec [OF _ wf Procs_defined])
  done

lemma ProcRecList:
  assumes deriv_bodies:
   "\<forall>p\<in>set Procs.
    \<forall>\<sigma> Z. \<Gamma>,\<Theta>\<union>(\<Union>q\<in>set Procs. \<Union>Z.
       {(P q Z \<inter> {s. ((s,q), \<sigma>,p) \<in> r},q,Q q Z,A q Z)})
        \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  assumes wf: "wf r"
  assumes dist: "distinct Procs"
  assumes Procs_defined: "set Procs \<subseteq> dom \<Gamma>"
  shows "\<forall>p\<in>set Procs. \<forall>Z.
  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub>(P p Z) Call p (Q p Z),(A p Z)"
  using deriv_bodies wf Procs_defined
  by (rule ProcRec)

lemma  ProcRecSpecs:
  "\<lbrakk>\<forall>\<sigma>. \<forall>(P,p,Q,A) \<in> Specs.
     \<Gamma>,\<Theta>\<union> ((\<lambda>(P,q,Q,A). (P \<inter> {s. ((s,q),(\<sigma>,p)) \<in> r},q,Q,A)) ` Specs)
      \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P) (the (\<Gamma> p)) Q,A;
    wf r;
    \<forall>(P,p,Q,A) \<in> Specs. p \<in> dom \<Gamma>\<rbrakk>
  \<Longrightarrow> \<forall>(P,p,Q,A) \<in> Specs. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A"
apply (rule ballI)
apply (case_tac x)
apply (rename_tac x P p Q A)
apply simp
apply (rule hoaret.CallRec)
apply auto
done

lemma ProcRec1:
  assumes deriv_body:
   "\<forall>\<sigma> Z. \<Gamma>,\<Theta>\<union>(\<Union>Z. {(P Z \<inter> {s. ((s,p), \<sigma>,p) \<in> r},p,Q Z,A Z)})
           \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
  assumes wf: "wf r"
  assumes p_defined: "p \<in> dom \<Gamma>"
  shows "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) Call p (Q Z),(A Z)"
proof -
  from deriv_body wf p_defined
  have "\<forall>p\<in>{p}. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) Call p (Q Z),(A Z)"
    apply -
    apply (rule ProcRec [where  A="\<lambda>p. A" and P="\<lambda>p. P" and Q="\<lambda>p. Q"])
    apply simp_all
    done
  thus ?thesis
    by simp
qed

lemma ProcNoRec1:
  assumes deriv_body:
   "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
  assumes p_defined: "p \<in> dom \<Gamma>"
  shows "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) Call p (Q Z),(A Z)"
proof -
  have "\<forall>\<sigma> Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
    by (blast intro: conseqPre deriv_body [rule_format])
  with p_defined have "\<forall>\<sigma> Z. \<Gamma>,\<Theta>\<union>(\<Union>Z. {(P Z \<inter> {s. ((s,p), \<sigma>,p) \<in> {}},
                         p,Q Z,A Z)})
             \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
    by (blast intro: hoaret_augment_context)
  from this
  show ?thesis
    by (rule ProcRec1) (auto simp add: p_defined)
qed

lemma ProcBody:
 assumes WP: "P \<subseteq> P'"
 assumes deriv_body: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' body Q,A"
 assumes body: "\<Gamma> p = Some body"
 shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Call p Q,A"
apply (rule conseqPre [OF _ WP])
apply (rule ProcNoRec1 [rule_format, where P="\<lambda>Z. P'" and Q="\<lambda>Z. Q" and A="\<lambda>Z. A"])
apply  (insert body)
apply  simp
apply  (rule hoaret_augment_context [OF deriv_body])
apply  blast
apply fastforce
done

lemma CallBody:
assumes adapt: "P \<subseteq> {s. init s \<in> P' s}"
assumes bdy: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' s) body {t. return s t \<in> R s t},{t. return s t \<in> A}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes body: "\<Gamma> p = Some body"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A"
apply (unfold call_def)
apply (rule Block [OF adapt _ c])
apply (rule allI)
apply (rule ProcBody [where \<Gamma>=\<Gamma>, OF _ bdy [rule_format] body])
apply simp
done

lemmas ProcModifyReturn = HoareTotalProps.ProcModifyReturn
lemmas ProcModifyReturnSameFaults = HoareTotalProps.ProcModifyReturnSameFaults

lemma ProcModifyReturnNoAbr:
  assumes spec: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (call init p return' c) Q,A"
  assumes result_conform:
      "\<forall>s t. t \<in> Modif (init s) \<longrightarrow> (return' s t) = (return s t)"
  assumes modifies_spec:
  "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} Call p (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A"
by (rule ProcModifyReturn [OF spec result_conform _ modifies_spec]) simp

lemma ProcModifyReturnNoAbrSameFaults:
  assumes spec: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (call init p return' c) Q,A"
  assumes result_conform:
      "\<forall>s t. t \<in> Modif (init s) \<longrightarrow> (return' s t) = (return s t)"
  assumes modifies_spec:
  "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} Call p (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A"
by (rule ProcModifyReturnSameFaults [OF spec result_conform _ modifies_spec]) simp

lemma DynProc:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' s Z \<and>
                          (\<forall>t. t \<in> Q' s Z \<longrightarrow>  return s t \<in> R s t) \<and>
                          (\<forall>t. t \<in> A' s Z \<longrightarrow> return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>s\<in> P. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return c Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. s=Z \<and> s \<in> P}"
  and Q'="\<lambda>Z. Q" and A'="\<lambda>Z. A"])
prefer 2
using adapt
apply  blast
apply (rule allI)
apply (unfold dynCall_def call_def block_def)
apply (rule HoareTotalDef.DynCom)
apply clarsimp
apply (rule HoareTotalDef.DynCom)
apply clarsimp
apply (frule in_mono [rule_format, OF adapt])
apply clarsimp
apply (rename_tac Z')
apply (rule_tac R="Q' Z Z'" in Seq)
apply  (rule CatchSwap)
apply   (rule SeqSwap)
apply    (rule Throw)
apply    (rule subset_refl)
apply   (rule Basic)
apply   (rule subset_refl)
apply  (rule_tac R="{i. i \<in> P' Z Z'}" in Seq)
apply   (rule Basic)
apply   clarsimp
apply  simp
apply  (rule_tac Q'="Q' Z Z'" and A'="A' Z Z'" in conseqPost)
using p
apply    clarsimp
apply   simp
apply  clarsimp
apply  (rule_tac  P'="\<lambda>Z''. {t. t=Z'' \<and> return Z t \<in> R Z t}" and
          Q'="\<lambda>Z''. Q" and A'="\<lambda>Z''. A" in conseq)
prefer 2 apply simp
apply (rule allI)
apply (rule HoareTotalDef.DynCom)
apply clarsimp
apply (rule SeqSwap)
apply  (rule c [rule_format])
apply (rule Basic)
apply clarsimp
done

lemma DynProc':
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' s Z \<and>
                          (\<forall>t \<in> Q' s Z. return s t \<in> R s t) \<and>
                          (\<forall>t \<in> A' s Z. return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>s\<in> P. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return c Q,A"
proof -
  from adapt have "P \<subseteq> {s. \<exists>Z. init s \<in> P' s Z \<and>
                          (\<forall>t. t \<in> Q' s Z \<longrightarrow>  return s t \<in> R s t) \<and>
                          (\<forall>t. t \<in> A' s Z \<longrightarrow> return s t \<in> A)}"
    by blast
  from this c p show ?thesis
    by (rule DynProc)
qed

lemma DynProcStaticSpec:
assumes adapt: "P \<subseteq> {s. s \<in> S \<and> (\<exists>Z. init s \<in> P' Z  \<and>
                            (\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>) \<and>
                            (\<forall>\<tau>. \<tau> \<in> A' Z \<longrightarrow> return s \<tau> \<in> A))}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>s\<in>S. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call (p s) (Q' Z),(A' Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from adapt have P_S: "P \<subseteq> S"
    by blast
  have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P \<inter> S) (dynCall init p return c) Q,A"
    apply (rule DynProc [where P'="\<lambda>s Z. P' Z" and Q'="\<lambda>s Z. Q' Z"
                         and A'="\<lambda>s Z. A' Z", OF _ c])
    apply  clarsimp
    apply  (frule in_mono [rule_format, OF adapt])
    apply  clarsimp
    using spec
    apply clarsimp
    done
  thus ?thesis
    by (rule conseqPre) (insert P_S,blast)
qed

lemma DynProcProcPar:
assumes adapt: "P \<subseteq> {s. p s = q \<and> (\<exists>Z. init s \<in> P' Z  \<and>
                            (\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>) \<and>
                            (\<forall>\<tau>. \<tau> \<in> A' Z \<longrightarrow> return s \<tau> \<in> A))}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),(A' Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
  apply (rule DynProcStaticSpec [where S="{s. p s = q}",simplified, OF adapt c])
  using spec
  apply simp
  done

lemma DynProcProcParNoAbrupt:
assumes adapt: "P \<subseteq> {s. p s = q \<and> (\<exists>Z. init s \<in> P' Z  \<and>
                            (\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>))}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),{}"
shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  have "P \<subseteq> {s. p s = q \<and> (\<exists> Z. init s \<in> P' Z \<and>
                      (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                      (\<forall>t. t \<in> {} \<longrightarrow> return s t \<in> A))}"
    (is "P \<subseteq> ?P'")
  proof
    fix s
    assume P: "s\<in>P"
    with adapt obtain Z where
      Pre: "p s = q \<and> init s \<in> P' Z" and
      adapt_Norm: "\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>"
      by blast
    from  adapt_Norm
    have "\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t"
      by auto
    then
    show "s\<in>?P'"
      using Pre by blast
  qed
  note P = this
  show ?thesis
    apply -
    apply (rule DynProcStaticSpec [where S="{s. p s = q}",simplified, OF P c])
    apply (insert spec)
    apply auto
    done
qed

lemma DynProcModifyReturnNoAbr:
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>s \<in> P. \<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} Call (p s)  (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from ret_nrm_modif
  have "\<forall>s t. t  \<in> (Modif (init s))
        \<longrightarrow> return' s t = return s t"
    by iprover
  then
  have ret_nrm_modif': "\<forall>s t. t \<in> (Modif (init s))
                      \<longrightarrow> return' s t = return s t"
    by simp
  have ret_abr_modif': "\<forall>s t. t \<in> {}
                        \<longrightarrow> return' s t = return s t"
    by simp
  from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis
    by (rule dynProcModifyReturn)
qed

lemma ProcDynModifyReturnNoAbrSameFaults:
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>s \<in> P. \<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} (Call (p s)) (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from ret_nrm_modif
  have "\<forall>s t. t  \<in> (Modif (init s))
        \<longrightarrow> return' s t = return s t"
    by iprover
  then
  have ret_nrm_modif': "\<forall>s t. t \<in> (Modif (init s))
                      \<longrightarrow> return' s t = return s t"
    by simp
  have ret_abr_modif': "\<forall>s t. t \<in> {}
                        \<longrightarrow> return' s t = return s t"
    by simp
  from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis
    by (rule dynProcModifyReturnSameFaults)
qed

lemma ProcProcParModifyReturn:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   \<comment>\<open>@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in
         @{term P'}, so the vcg can simplify it.\<close>
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes ret_abr_modif: "\<forall>s t. t \<in> (ModifAbr (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
          "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} (Call q) (Modif \<sigma>),(ModifAbr \<sigma>)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
       ret_abr_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule dynProcModifyReturn) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma ProcProcParModifyReturnSameFaults:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   \<comment>\<open>@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in
         @{term P'}, so the vcg can simplify it.\<close>
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes ret_abr_modif: "\<forall>s t. t \<in> (ModifAbr (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
          "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} Call q (Modif \<sigma>),(ModifAbr \<sigma>)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove
  have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
       ret_abr_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule dynProcModifyReturnSameFaults) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma ProcProcParModifyReturnNoAbr:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   \<comment>\<open>@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as
      first conjunction in @{term P'}, so the vcg can simplify it.\<close>
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} (Call q) (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule DynProcModifyReturnNoAbr) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma ProcProcParModifyReturnNoAbrSameFaults:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
      \<comment>\<open>@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as
      first conjunction in @{term P'}, so the vcg can simplify it.\<close>
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} (Call q) (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove have
    "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule ProcDynModifyReturnNoAbrSameFaults) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma MergeGuards_iff: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P merge_guards c Q,A = \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (auto intro: MergeGuardsI MergeGuardsD)

lemma CombineStrip':
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c' Q,A"
  assumes deriv_strip_triv: "\<Gamma>,{}\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
  assumes c'': "c''= mark_guards False (strip_guards (-F) c')"
  assumes c: "merge_guards c = merge_guards (mark_guards False c')"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P c Q,A"
proof -
  from deriv_strip_triv have deriv_strip: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
    by (auto intro: hoare_augment_context)
  from deriv_strip [simplified c'']
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P (strip_guards (- F) c') UNIV,UNIV"
    by (rule HoarePartialProps.MarkGuardsD)
  with deriv
  have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P c' Q,A"
    by (rule CombineStrip)
  hence "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P mark_guards False c' Q,A"
    by (rule MarkGuardsI)
  hence "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P merge_guards (mark_guards False c') Q,A"
    by (rule MergeGuardsI)
  hence "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P merge_guards c Q,A"
    by (simp add: c)
  thus ?thesis
    by (rule MergeGuardsD)
qed

lemma CombineStrip'':
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/{True}\<^esub> P c' Q,A"
  assumes deriv_strip_triv: "\<Gamma>,{}\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
  assumes c'': "c''= mark_guards False (strip_guards ({False}) c')"
  assumes c: "merge_guards c = merge_guards (mark_guards False c')"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P c Q,A"
  apply (rule CombineStrip' [OF deriv deriv_strip_triv _ c])
  apply (insert c'')
  apply (subgoal_tac "- {True} = {False}")
  apply auto
  done

lemma AsmUN:
  "(\<Union>Z. {(P Z, p, Q Z,A Z)}) \<subseteq> \<Theta>
  \<Longrightarrow>
  \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) (Call p) (Q Z),(A Z)"
  by (blast intro: hoaret.Asm)

lemma hoaret_to_hoarep':
  "\<forall>Z. \<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z) \<Longrightarrow> \<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)"
  by (iprover intro: total_to_partial)

lemma augment_context':
  "\<lbrakk>\<Theta> \<subseteq> \<Theta>'; \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z)  p (Q Z),(A Z)\<rbrakk>
   \<Longrightarrow> \<forall>Z. \<Gamma>,\<Theta>'\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)"
  by (iprover intro: hoaret_augment_context)

lemma augment_emptyFaults:
 "\<lbrakk>\<forall>Z. \<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> (P Z) p (Q Z),(A Z)\<rbrakk> \<Longrightarrow>
    \<forall>Z. \<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)"
  by (blast intro: augment_Faults)

lemma augment_FaultsUNIV:
 "\<lbrakk>\<forall>Z. \<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)\<rbrakk> \<Longrightarrow>
    \<forall>Z. \<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/UNIV\<^esub> (P Z) p (Q Z),(A Z)"
  by (blast intro: augment_Faults)

lemma PostConjI [trans]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c R,B\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c (Q \<inter> R),(A \<inter> B)"
  by (rule PostConjI)

lemma PostConjI' :
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c R,B\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c (Q \<inter> R),(A \<inter> B)"
  by (rule PostConjI) iprover+

lemma PostConjE [consumes 1]:
  assumes conj: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c (Q \<inter> R),(A \<inter> B)"
  assumes E: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c R,B\<rbrakk> \<Longrightarrow> S"
  shows "S"
proof -
  from conj have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A" by (rule conseqPost) blast+
  moreover
  from conj have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c R,B" by (rule conseqPost) blast+
  ultimately show "S"
    by (rule E)
qed

subsubsection \<open>Rules for Single-Step Proof \label{sec:hoare-isar}\<close>

text \<open>
 We are now ready to introduce a set of Hoare rules to be used in
 single-step structured proofs in Isabelle/Isar.

 \medskip Assertions of Hoare Logic may be manipulated in
 calculational proofs, with the inclusion expressed in terms of sets
 or predicates.  Reversed order is supported as well.
\<close>

lemma annotateI [trans]:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P anno Q,A; c = anno\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (simp)

lemma annotate_normI:
  assumes deriv_anno: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub>P anno Q,A"
  assumes norm_eq: "normalize c = normalize anno"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub>P c Q,A"
proof -
  from HoareTotalProps.NormalizeI [OF deriv_anno] norm_eq
  have "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F \<^esub>P normalize c Q,A"
    by simp
  from NormalizeD [OF this]
  show ?thesis .
qed

lemma annotateWhile:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnnoG gs b I V c) Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (while gs b c) Q,A"
  by (simp add: whileAnnoG_def)

lemma reannotateWhile:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnnoG gs b I V c) Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnnoG gs b J V c) Q,A"
  by (simp add: whileAnnoG_def)

lemma reannotateWhileNoGuard:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnno b I V c) Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (whileAnno b J V c) Q,A"
  by (simp add: whileAnno_def)

lemma [trans] : "P' \<subseteq> P \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q,A"
  by (rule conseqPre)

lemma [trans]: "Q \<subseteq> Q' \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q',A"
  by (rule conseqPost) blast+

lemma [trans]:
    "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. P s} c Q,A \<Longrightarrow> (\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. P' s} c Q,A"
  by (rule conseqPre) auto

lemma [trans]:
    "(\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. P s} c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. P' s} c Q,A"
  by (rule conseqPre) auto

lemma [trans]:
    "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c {s. Q s},A \<Longrightarrow> (\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c {s. Q' s},A"
  by (rule conseqPost) auto

lemma [trans]:
    "(\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c {s. Q s},A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c {s. Q' s},A"
  by (rule conseqPost) auto

lemma [intro?]: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Skip P,A"
  by (rule Skip) auto

lemma CondInt [trans,intro?]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P \<inter> b) c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P \<inter> - b) c2 Q,A\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Cond b c1 c2) Q,A"
  by (rule Cond) auto

lemma CondConj [trans, intro?]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. P s \<and> b s} c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. P s \<and> \<not> b s} c2 Q,A\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. P s} (Cond {s. b s} c1 c2) Q,A"
  by (rule Cond) auto
end