(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
 * 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
  "../lib/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)) = 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)) = 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: typ_slices_index size_of_def)
   apply (erule_tac x="length (typ_slice_t (typ_uinfo_t TYPE('a)) (unat k))" in allE)
   apply (clarsimp simp: typ_slices_index 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 ptr_val_inj)
  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, hide_lams) 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:      JinjaThreads/Compiler/J0J1Bisim.thy
    Author:     Andreas Lochbihler

    Reminiscent of the Jinja theory Compiler/Correctness1
*)

section \<open>The bisimulation relation betwenn source and intermediate language\<close>

theory J0J1Bisim imports
  J1
  J1WellForm
  Compiler1
  "../J/JWellForm"
  J0
begin

subsection\<open>Correctness of program compilation\<close>

primrec unmod :: "'addr expr1 \<Rightarrow> nat \<Rightarrow> bool"
  and unmods :: "'addr expr1 list \<Rightarrow> nat \<Rightarrow> bool"
where
  "unmod (new C) i = True"
| "unmod (newA T\<lfloor>e\<rceil>) i = unmod e i"
| "unmod (Cast C e) i = unmod e i"
| "unmod (e instanceof T) i = unmod e i"
| "unmod (Val v) i = True"
| "unmod (e1 \<guillemotleft>bop\<guillemotright> e2) i = (unmod e1 i \<and> unmod e2 i)"
| "unmod (Var i) j = True"
| "unmod (i:=e) j = (i \<noteq> j \<and> unmod e j)"
| "unmod (a\<lfloor>i\<rceil>) j = (unmod a j \<and> unmod i j)"
| "unmod (a\<lfloor>i\<rceil>:=e) j = (unmod a j \<and> unmod i j \<and> unmod e j)"
| "unmod (a\<bullet>length) j = unmod a j"
| "unmod (e\<bullet>F{D}) i = unmod e i"
| "unmod (e1\<bullet>F{D}:=e2) i = (unmod e1 i \<and> unmod e2 i)"
| "unmod (e1\<bullet>compareAndSwap(D\<bullet>F, e2, e3)) i = (unmod e1 i \<and> unmod e2 i \<and> unmod e3 i)"
| "unmod (e\<bullet>M(es)) i = (unmod e i \<and> unmods es i)"
| "unmod {j:T=vo; e} i = ((i = j \<longrightarrow> vo = None) \<and> unmod e i)"
| "unmod (sync\<^bsub>V\<^esub> (o') e) i = (unmod o' i \<and> unmod e i \<and> i \<noteq> V)"
| "unmod (insync\<^bsub>V\<^esub> (a) e) i = unmod e i"
| "unmod (e1;;e2) i = (unmod e1 i \<and> unmod e2 i)"
| "unmod (if (e) e\<^sub>1 else e\<^sub>2) i = (unmod e i \<and> unmod e\<^sub>1 i \<and> unmod e\<^sub>2 i)"
| "unmod (while (e) c) i = (unmod e i \<and> unmod c i)"
| "unmod (throw e) i = unmod e i"
| "unmod (try e\<^sub>1 catch(C i) e\<^sub>2) j = (unmod e\<^sub>1 j \<and> (if i=j then False else unmod e\<^sub>2 j))"

| "unmods ([]) i = True"
| "unmods (e#es) i = (unmod e i \<and> unmods es i)"

lemma unmods_map_Val [simp]: "unmods (map Val vs) V"
by(induct vs) simp_all

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows hidden_unmod: "hidden Vs i \<Longrightarrow> unmod (compE1 Vs e) i"
  and hidden_unmods: "hidden Vs i \<Longrightarrow> unmods (compEs1 Vs es) i"
apply(induct Vs e and Vs es rule: compE1_compEs1_induct)
apply (simp_all add:hidden_inacc)
apply(auto simp add:hidden_def)
done

lemma unmod_extRet2J [simp]: "unmod e i \<Longrightarrow> unmod (extRet2J e va) i"
by(cases va) simp_all

lemma max_dest: "(n :: nat) + max a b \<le> c \<Longrightarrow> n + a \<le> c \<and> n + b \<le> c"
apply(auto simp add: max_def split: if_split_asm)
done

declare max_dest [dest!]

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows fv_unmod_compE1: "\<lbrakk> i < length Vs; Vs ! i \<notin> fv e \<rbrakk> \<Longrightarrow> unmod (compE1 Vs e) i"
  and fvs_unmods_compEs1: "\<lbrakk> i < length Vs; Vs ! i \<notin> fvs es \<rbrakk> \<Longrightarrow> unmods (compEs1 Vs es) i"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Block Vs V ty vo exp)
  note IH = \<open>\<lbrakk>i < length (Vs @ [V]); (Vs @ [V]) ! i \<notin> fv exp \<rbrakk> \<Longrightarrow> unmod (compE1 (Vs @ [V]) exp) i\<close>
  note len = \<open>i < length Vs\<close>
  hence i: "i < length (Vs @ [V])" by simp
  show ?case
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True show ?thesis by(auto intro: hidden_unmod)
  next
    case False
    with \<open>Vs ! i \<notin> fv {V:ty=vo; exp}\<close> len have "(Vs @ [V]) ! i \<notin> fv exp"
      by(auto simp add: nth_append)
    from IH[OF i this] len show ?thesis by(auto)
  qed
next
  case (TryCatch Vs e1 C V e2)
  note IH1 = \<open>\<lbrakk>i < length Vs; Vs ! i \<notin> fv e1 \<rbrakk> \<Longrightarrow> unmod (compE1 Vs e1) i\<close>
  note IH2 = \<open>\<lbrakk>i < length (Vs @ [V]); (Vs @ [V]) ! i \<notin> fv e2 \<rbrakk> \<Longrightarrow> unmod (compE1 (Vs @ [V]) e2) i\<close>
  note len = \<open>i < length Vs\<close>
  hence i: "i < length (Vs @ [V])" by simp
  have "unmod (compE1 (Vs @ [V]) e2) i"
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True show ?thesis by(auto intro: hidden_unmod)
  next
    case False
    with \<open>Vs ! i \<notin> fv (try e1 catch(C V) e2)\<close> len have "(Vs @ [V]) ! i \<notin> fv e2"
      by(auto simp add: nth_append)
    from IH2[OF i this] len show ?thesis by(auto)
  qed
  with IH1[OF len] \<open>Vs ! i \<notin> fv (try e1 catch(C V) e2)\<close> len show ?case by(auto)
qed(auto dest: index_le_lengthD simp add: nth_append)

lemma hidden_lengthD: "hidden Vs i \<Longrightarrow> i < length Vs"
by(simp add: hidden_def)

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows fv_B_unmod: "\<lbrakk> V \<notin> fv e; \<B> e n; V < n \<rbrakk> \<Longrightarrow> unmod e V"
  and fvs_Bs_unmods: "\<lbrakk> V \<notin> fvs es; \<B>s es n; V < n \<rbrakk> \<Longrightarrow> unmods es V"
by(induct e and es arbitrary: n and n rule: unmod.induct unmods.induct) auto

subsection \<open>The delay bisimulation relation\<close>

text \<open>Delay bisimulation for expressions\<close>

inductive bisim :: "vname list \<Rightarrow> 'addr expr \<Rightarrow> 'addr expr1 \<Rightarrow> 'addr val list \<Rightarrow> bool"
  and bisims :: "vname list \<Rightarrow> 'addr expr list \<Rightarrow> 'addr expr1 list \<Rightarrow> 'addr val list \<Rightarrow> bool"
where
  bisimNew: "bisim Vs (new C) (new C) xs"
| bisimNewArray: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (newA T\<lfloor>e\<rceil>) (newA T\<lfloor>e'\<rceil>) xs"
| bisimCast: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (Cast T e) (Cast T e') xs"
| bisimInstanceOf: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (e instanceof T) (e' instanceof T) xs"
| bisimVal: "bisim Vs (Val v) (Val v) xs"
| bisimBinOp1:
  "\<lbrakk> bisim Vs e e' xs; \<not> is_val e; \<not> contains_insync e'' \<rbrakk> \<Longrightarrow> bisim Vs (e \<guillemotleft>bop\<guillemotright> e'') (e' \<guillemotleft>bop\<guillemotright> compE1 Vs e'') xs"
| bisimBinOp2: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (Val v \<guillemotleft>bop\<guillemotright> e) (Val v \<guillemotleft>bop\<guillemotright> e') xs"
| bisimVar: "bisim Vs (Var V) (Var (index Vs V)) xs"
| bisimLAss: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (V:=e) (index Vs V:=e') xs"
| bisimAAcc1: "\<lbrakk> bisim Vs a a' xs; \<not> is_val a; \<not> contains_insync i \<rbrakk> \<Longrightarrow> bisim Vs (a\<lfloor>i\<rceil>) (a'\<lfloor>compE1 Vs i\<rceil>) xs"
| bisimAAcc2: "bisim Vs i i' xs \<Longrightarrow> bisim Vs (Val v\<lfloor>i\<rceil>) (Val v\<lfloor>i'\<rceil>) xs"
| bisimAAss1:
  "\<lbrakk> bisim Vs a a' xs; \<not> is_val a; \<not> contains_insync i; \<not> contains_insync e \<rbrakk>
  \<Longrightarrow> bisim Vs (a\<lfloor>i\<rceil>:=e) (a'\<lfloor>compE1 Vs i\<rceil>:=compE1 Vs e) xs"
| bisimAAss2: "\<lbrakk> bisim Vs i i' xs; \<not> is_val i; \<not> contains_insync e \<rbrakk> \<Longrightarrow> bisim Vs (Val v\<lfloor>i\<rceil>:=e) (Val v\<lfloor>i'\<rceil>:=compE1 Vs e) xs"
| bisimAAss3: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (Val v\<lfloor>Val i\<rceil> := e) (Val v\<lfloor>Val i\<rceil> := e') xs"
| bisimALength: "bisim Vs a a' xs \<Longrightarrow> bisim Vs (a\<bullet>length) (a'\<bullet>length) xs"
| bisimFAcc: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (e\<bullet>F{D}) (e'\<bullet>F{D}) xs"
| bisimFAss1: "\<lbrakk> bisim Vs e e' xs; \<not> is_val e; \<not> contains_insync e'' \<rbrakk> \<Longrightarrow> bisim Vs (e\<bullet>F{D}:=e'') (e'\<bullet>F{D}:=compE1 Vs e'') xs"
| bisimFAss2: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (Val v\<bullet>F{D} := e) (Val v\<bullet>F{D} := e') xs"
| bisimCAS1: "\<lbrakk> bisim Vs e e' xs; \<not> is_val e; \<not> contains_insync e2; \<not> contains_insync e3 \<rbrakk>
  \<Longrightarrow> bisim Vs (e\<bullet>compareAndSwap(D\<bullet>F, e2, e3)) (e'\<bullet>compareAndSwap(D\<bullet>F, compE1 Vs e2, compE1 Vs e3)) xs"
| bisimCAS2: "\<lbrakk> bisim Vs e e' xs; \<not> is_val e; \<not> contains_insync e3 \<rbrakk>
  \<Longrightarrow> bisim Vs (Val v\<bullet>compareAndSwap(D\<bullet>F, e, e3)) (Val v\<bullet>compareAndSwap(D\<bullet>F, e', compE1 Vs e3)) xs"
| bisimCAS3: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (Val v\<bullet>compareAndSwap(D\<bullet>F, Val v', e)) (Val v\<bullet>compareAndSwap(D\<bullet>F, Val v', e')) xs"
| bisimCallObj: "\<lbrakk> bisim Vs e e' xs; \<not> is_val e; \<not> contains_insyncs es \<rbrakk> \<Longrightarrow> bisim Vs (e\<bullet>M(es)) (e'\<bullet>M(compEs1 Vs es)) xs"
| bisimCallParams: "bisims Vs es es' xs \<Longrightarrow> bisim Vs (Val v\<bullet>M(es)) (Val v\<bullet>M(es')) xs"
| bisimBlockNone: "bisim (Vs@[V]) e e' xs \<Longrightarrow> bisim Vs {V:T=None; e} {(length Vs):T=None; e'} xs"
| bisimBlockSome: "\<lbrakk> bisim (Vs@[V]) e e' (xs[length Vs := v]) \<rbrakk> \<Longrightarrow> bisim Vs {V:T=\<lfloor>v\<rfloor>; e} {(length Vs):T=\<lfloor>v\<rfloor>; e'} xs"
| bisimBlockSomeNone: "\<lbrakk> bisim (Vs@[V]) e e' xs; xs ! (length Vs) = v \<rbrakk> \<Longrightarrow> bisim Vs {V:T=\<lfloor>v\<rfloor>; e} {(length Vs):T=None; e'} xs"
| bisimSynchronized:
  "\<lbrakk> bisim Vs o' o'' xs; \<not> contains_insync e \<rbrakk>
  \<Longrightarrow> bisim Vs (sync(o') e) (sync\<^bsub>length Vs\<^esub>(o'') (compE1 (Vs@[fresh_var Vs]) e)) xs"
| bisimInSynchronized:
  "\<lbrakk> bisim (Vs@[fresh_var Vs]) e e' xs; xs ! length Vs = Addr a \<rbrakk> \<Longrightarrow> bisim Vs (insync(a) e) (insync\<^bsub>length Vs\<^esub>(a) e') xs"
| bisimSeq: "\<lbrakk> bisim Vs e e' xs; \<not> contains_insync e'' \<rbrakk> \<Longrightarrow> bisim Vs (e;;e'') (e';;compE1 Vs e'') xs"
| bisimCond:
  "\<lbrakk> bisim Vs e e' xs; \<not> contains_insync e1; \<not> contains_insync e2 \<rbrakk>
  \<Longrightarrow> bisim Vs (if (e) e1 else e2) (if (e') (compE1 Vs e1) else (compE1 Vs e2)) xs"
| bisimWhile:
  "\<lbrakk> \<not> contains_insync b; \<not> contains_insync e \<rbrakk> \<Longrightarrow> bisim Vs (while (b) e) (while (compE1 Vs b) (compE1 Vs e)) xs"
| bisimThrow: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (throw e) (throw e') xs"
| bisimTryCatch:
  "\<lbrakk> bisim Vs e e' xs; \<not> contains_insync e'' \<rbrakk>
  \<Longrightarrow> bisim Vs (try e catch(C V) e'') (try e' catch(C (length Vs)) compE1 (Vs@[V]) e'') xs"

| bisimsNil: "bisims Vs [] [] xs"
| bisimsCons1: "\<lbrakk> bisim Vs e e' xs; \<not> is_val e; \<not> contains_insyncs es \<rbrakk> \<Longrightarrow> bisims Vs (e # es) (e' # compEs1 Vs es) xs"
| bisimsCons2: "bisims Vs es es' xs \<Longrightarrow> bisims Vs (Val v # es) (Val v # es') xs"

declare bisimNew [iff]
declare bisimVal [iff]
declare bisimVar [iff]
declare bisimWhile [iff]
declare bisimsNil [iff]

declare bisim_bisims.intros [intro!]
declare bisimsCons1 [rule del, intro] bisimsCons2 [rule del, intro]
  bisimBinOp1 [rule del, intro] bisimAAcc1 [rule del, intro]
  bisimAAss1 [rule del, intro] bisimAAss2 [rule del, intro]
  bisimFAss1 [rule del, intro]
  bisimCAS1 [rule del, intro] bisimCAS2 [rule del, intro]
  bisimCallObj [rule del, intro]

inductive_cases bisim_safe_cases [elim!]:
  "bisim Vs (new C) e' xs"
  "bisim Vs (newA T\<lfloor>e\<rceil>) e' xs"
  "bisim Vs (Cast T e) e' xs"
  "bisim Vs (e instanceof T) e' xs"
  "bisim Vs (Val v) e' xs"
  "bisim Vs (Var V) e' xs"
  "bisim Vs (V:=e) e' xs"
  "bisim Vs (Val v\<lfloor>i\<rceil>) e' xs"
  "bisim Vs (Val v\<lfloor>Val v'\<rceil> := e) e' xs"
  "bisim Vs (Val v\<bullet>compareAndSwap(D\<bullet>F, Val v', e)) e' xs"
  "bisim Vs (a\<bullet>length) e' xs"
  "bisim Vs (e\<bullet>F{D}) e' xs"
  "bisim Vs (sync(o') e) e' xs"
  "bisim Vs (insync(a) e) e' xs"
  "bisim Vs (e;;e') e'' xs"
  "bisim Vs (if (b) e1 else e2) e' xs"
  "bisim Vs (while (b) e) e' xs"
  "bisim Vs (throw e) e' xs"
  "bisim Vs (try e catch(C V) e') e'' xs"
  "bisim Vs e' (new C) xs"
  "bisim Vs e' (newA T\<lfloor>e\<rceil>) xs"
  "bisim Vs e' (Cast T e) xs"
  "bisim Vs e' (e instanceof T) xs"
  "bisim Vs e' (Val v) xs"
  "bisim Vs e' (Var V) xs"
  "bisim Vs e' (V:=e) xs"
  "bisim Vs e' (Val v\<lfloor>i\<rceil>) xs"
  "bisim Vs e' (Val v\<lfloor>Val v'\<rceil> := e) xs"
  "bisim Vs e' (Val v\<bullet>compareAndSwap(D\<bullet>F, Val v', e)) xs"
  "bisim Vs e' (a\<bullet>length) xs"
  "bisim Vs e' (e\<bullet>F{D}) xs"
  "bisim Vs e' (sync\<^bsub>V\<^esub> (o') e) xs"
  "bisim Vs e' (insync\<^bsub>V\<^esub> (a) e) xs"
  "bisim Vs e'' (e;;e') xs"
  "bisim Vs e' (if (b) e1 else e2) xs"
  "bisim Vs e' (while (b) e) xs"
  "bisim Vs e' (throw e) xs"
  "bisim Vs e'' (try e catch(C V) e') xs"

inductive_cases bisim_cases [elim]:
  "bisim Vs (e1 \<guillemotleft>bop\<guillemotright> e2) e' xs"
  "bisim Vs (a\<lfloor>i\<rceil>) e' xs"
  "bisim Vs (a\<lfloor>i\<rceil>:=e) e' xs"
  "bisim Vs (e\<bullet>F{D}:=e') e'' xs"
  "bisim Vs (e\<bullet>compareAndSwap(D\<bullet>F, e', e'')) e''' xs"
  "bisim Vs (e\<bullet>M(es)) e' xs"
  "bisim Vs {V:T=vo; e} e' xs"
  "bisim Vs e' (e1 \<guillemotleft>bop\<guillemotright> e2) xs"
  "bisim Vs e' (a\<lfloor>i\<rceil>) xs"
  "bisim Vs e' (a\<lfloor>i\<rceil>:=e) xs"
  "bisim Vs e'' (e\<bullet>F{D}:=e') xs"
  "bisim Vs e''' (e\<bullet>compareAndSwap(D\<bullet>F, e', e'')) xs"
  "bisim Vs e' (e\<bullet>M(es)) xs"
  "bisim Vs e' {V:T=vo; e} xs"

inductive_cases bisims_safe_cases [elim!]:
  "bisims Vs [] es xs"
  "bisims Vs es [] xs"

inductive_cases bisims_cases [elim]:
  "bisims Vs (e # es) es' xs"
  "bisims Vs es' (e # es) xs"

text \<open>Delay bisimulation for call stacks\<close>

inductive bisim01 :: "'addr expr \<Rightarrow> 'addr expr1 \<times> 'addr locals1 \<Rightarrow> bool"
where
  "\<lbrakk> bisim [] e e' xs; fv e = {}; \<D> e \<lfloor>{}\<rfloor>; max_vars e' \<le> length xs; call e = \<lfloor>aMvs\<rfloor>; call1 e' = \<lfloor>aMvs\<rfloor> \<rbrakk>
  \<Longrightarrow> bisim01 e (e', xs)"

inductive bisim_list :: "'addr expr list \<Rightarrow> ('addr expr1 \<times> 'addr locals1) list \<Rightarrow> bool"
where
  bisim_listNil: "bisim_list [] []"
| bisim_listCons:
  "\<lbrakk> bisim_list es exs'; bisim [] e e' xs;
     fv e = {}; \<D> e \<lfloor>{}\<rfloor>;
     max_vars e' \<le> length xs;
     call e = \<lfloor>aMvs\<rfloor>; call1 e' = \<lfloor>aMvs\<rfloor> \<rbrakk>
  \<Longrightarrow> bisim_list (e # es) ((e', xs) # exs')"

inductive_cases bisim_list_cases [elim!]:
 "bisim_list [] exs'"
 "bisim_list (ex # exs) exs'"
 "bisim_list exs (ex' # exs')"

fun bisim_list1 ::
  "'addr expr \<times> 'addr expr list \<Rightarrow> ('addr expr1 \<times> 'addr locals1) \<times> ('addr expr1 \<times> 'addr locals1) list \<Rightarrow> bool"
where
  "bisim_list1 (e, es) ((e1, xs1), exs1) \<longleftrightarrow>
   bisim_list es exs1 \<and> bisim [] e e1 xs1 \<and> fv e = {} \<and> \<D> e \<lfloor>{}\<rfloor> \<and> max_vars e1 \<le> length xs1"

definition bisim_red0_Red1 ::
  "(('addr expr \<times> 'addr expr list) \<times> 'heap)
  \<Rightarrow> ((('addr expr1 \<times> 'addr locals1) \<times> ('addr expr1 \<times> 'addr locals1) list) \<times> 'heap) \<Rightarrow> bool"
where "bisim_red0_Red1 \<equiv> (\<lambda>(es, h) (exs, h'). bisim_list1 es exs \<and> h = h')"

abbreviation ta_bisim01 ::
  "('addr, 'thread_id, 'heap) J0_thread_action \<Rightarrow> ('addr, 'thread_id, 'heap) J1_thread_action \<Rightarrow> bool"
where
  "ta_bisim01 \<equiv> ta_bisim (\<lambda>t. bisim_red0_Red1)"

definition bisim_wait01 ::
  "('addr expr \<times> 'addr expr list) \<Rightarrow> ('addr expr1 \<times> 'addr locals1) \<times> ('addr expr1 \<times> 'addr locals1) list \<Rightarrow> bool"
where "bisim_wait01 \<equiv> \<lambda>(e0, es0) ((e1, xs1), exs1). call e0 \<noteq> None \<and> call1 e1 \<noteq> None"

lemma bisim_list1I[intro?]:
  "\<lbrakk> bisim_list es exs1; bisim [] e e1 xs1; fv e = {};
     \<D> e \<lfloor>{}\<rfloor>; max_vars e1 \<le> length xs1 \<rbrakk>
  \<Longrightarrow> bisim_list1 (e, es) ((e1, xs1), exs1)"
by simp

lemma bisim_list1E[elim?]:
  assumes "bisim_list1 (e, es) ((e1, xs1), exs1)"
  obtains "bisim_list es exs1" "bisim [] e e1 xs1" "fv e = {}" "\<D> e \<lfloor>{}\<rfloor>" "max_vars e1 \<le> length xs1"
using assms by auto

lemma bisim_list1_elim:
  assumes "bisim_list1 es' exs"
  obtains e es e1 xs1 exs1
  where "es' = (e, es)" "exs = ((e1, xs1), exs1)"
  and "bisim_list es exs1" "bisim [] e e1 xs1" "fv e = {}" "\<D> e \<lfloor>{}\<rfloor>" "max_vars e1 \<le> length xs1"
using assms by(cases es')(cases exs, fastforce)

declare bisim_list1.simps [simp del]

lemma bisims_map_Val_conv [simp]: "bisims Vs (map Val vs) es xs = (es = map Val vs)"
apply(induct vs arbitrary: es)
 apply(fastforce)
apply(simp)
apply(rule iffI)
apply(erule bisims_cases, auto)
done

declare compEs1_conv_map [simp del]

lemma bisim_contains_insync: "bisim Vs e e' xs \<Longrightarrow> contains_insync e = contains_insync e'"
  and bisims_contains_insyncs: "bisims Vs es es' xs \<Longrightarrow> contains_insyncs es = contains_insyncs es'"
by(induct rule: bisim_bisims.inducts)(auto)

lemma bisims_map_Val_Throw:
  "bisims Vs (map Val vs @ Throw a # es) es' xs \<longleftrightarrow> es' = map Val vs @ Throw a # compEs1 Vs es \<and> \<not> contains_insyncs es"
apply(induct vs arbitrary: es')
 apply(simp)
 apply(fastforce simp add: compEs1_conv_map)
apply(fastforce elim!: bisims_cases intro: bisimsCons2)
done

lemma compE1_bisim [intro]: "\<lbrakk> fv e \<subseteq> set Vs; \<not> contains_insync e \<rbrakk> \<Longrightarrow> bisim Vs e (compE1 Vs e) xs"
  and compEs1_bisims [intro]: "\<lbrakk> fvs es \<subseteq> set Vs; \<not> contains_insyncs es \<rbrakk> \<Longrightarrow> bisims Vs es (compEs1 Vs es) xs"
proof(induct Vs e and Vs es arbitrary: xs and xs rule: compE1_compEs1_induct)
  case (BinOp Vs exp1 bop exp2 x)
  thus ?case by(cases "is_val exp1")(auto)
next
  case (AAcc Vs exp1 exp2 x)
  thus ?case by(cases "is_val exp1")(auto)
next
  case (AAss Vs exp1 exp2 exp3 x)
  thus ?case by(cases "is_val exp1", cases "is_val exp2", fastforce+)
next
  case (FAss Vs exp1 F D exp2 x)
  thus ?case by(cases "is_val exp1", auto)
next
  case (CAS Vs e1 D F e2 e3 x)
  thus ?case by(cases "is_val e1", cases "is_val e2", fastforce+)
next
  case (Call Vs obj M params x)
  thus ?case by(cases "is_val obj")(auto)
next
  case (Block Vs V T vo exp xs)
  from \<open>fv {V:T=vo; exp} \<subseteq> set Vs\<close> have "fv exp \<subseteq> set (Vs@[V])" by(auto)
  with Block show ?case by(cases vo)(auto)
next
  case (Cons Vs exp list x)
  thus ?case by(cases "is_val exp")(auto intro!: bisimsCons2)
qed(auto)

lemma bisim_hidden_unmod: "\<lbrakk> bisim Vs e e' xs; hidden Vs i \<rbrakk> \<Longrightarrow> unmod e' i"
  and bisims_hidden_unmods: "\<lbrakk> bisims Vs es es' xs; hidden Vs i \<rbrakk> \<Longrightarrow> unmods es' i"
by(induct rule: bisim_bisims.inducts)(auto intro: hidden_unmod hidden_unmods dest: hidden_inacc hidden_lengthD)

lemma bisim_fv_unmod: "\<lbrakk> bisim Vs e e' xs; i < length Vs; Vs ! i \<notin> fv e \<rbrakk> \<Longrightarrow> unmod e' i"
  and bisims_fvs_unmods: "\<lbrakk> bisims Vs es es' xs; i < length Vs; Vs ! i \<notin> fvs es \<rbrakk> \<Longrightarrow> unmods es' i"
proof(induct rule: bisim_bisims.inducts)
  case (bisimBlockNone Vs V e e' xs T)
  note len = \<open>i < length Vs\<close>
  have "unmod e' i"
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True \<open>bisim (Vs @ [V]) e e' xs\<close> show ?thesis by(auto intro: bisim_hidden_unmod)
  next
    case False
    with bisimBlockNone show ?thesis by(auto simp add: nth_append)
  qed
  thus ?case by simp
next
  case (bisimBlockSome Vs V e e' xs v T)
  note len = \<open>i < length Vs\<close>
  show ?case
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True \<open>bisim (Vs @ [V]) e e' (xs[length Vs := v])\<close>
    show ?thesis by(auto intro: bisim_hidden_unmod)
  next
    case False
    with bisimBlockSome show ?thesis by(auto simp add: nth_append)
  qed
next
  case (bisimBlockSomeNone Vs V e e' xs v T)
  note len = \<open>i < length Vs\<close>
  show ?case
  proof(cases "Vs ! i = V")
    case True
    from len have "hidden (Vs @ [Vs ! i]) i" by(rule hidden_snoc_nth)
    with len True \<open>bisim (Vs @ [V]) e e' xs\<close>
    show ?thesis by(auto intro: bisim_hidden_unmod)
  next
    case False
    with bisimBlockSomeNone show ?thesis by(auto simp add: nth_append)
  qed
qed(fastforce dest: fv_unmod_compE1 fvs_unmods_compEs1 index_le_lengthD simp add: nth_append)+

lemma bisim_extRet2J [intro!]: "bisim Vs e e' xs \<Longrightarrow> bisim Vs (extRet2J e va) (extRet2J1 e' va) xs"
by(cases va) auto

lemma bisims_map_Val_conv2 [simp]: "bisims Vs es (map Val vs) xs = (es = map Val vs)"
apply(induct vs arbitrary: es)
apply(fastforce elim!: bisims_cases)+
done

lemma bisims_map_Val_Throw2:
  "bisims Vs es' (map Val vs @ Throw a # es) xs \<longleftrightarrow>
   (\<exists>es''. es' = map Val vs @ Throw a # es'' \<and> es = compEs1 Vs es'' \<and> \<not> contains_insyncs es'')"
apply(induct vs arbitrary: es')
 apply(simp)
 apply(fastforce simp add: compEs1_conv_map)
apply(fastforce elim!: bisims_cases)
done

lemma hidden_bisim_unmod: "\<lbrakk> bisim Vs e e' xs; hidden Vs i \<rbrakk> \<Longrightarrow> unmod e' i"
  and hidden_bisims_unmods: "\<lbrakk> bisims Vs es es' xs; hidden Vs i \<rbrakk> \<Longrightarrow> unmods es' i"
apply(induct rule: bisim_bisims.inducts)
apply(auto simp add:hidden_inacc intro: hidden_unmod hidden_unmods)
apply(auto simp add: hidden_def)
done

lemma bisim_list_list_all2_conv:
  "bisim_list es exs' \<longleftrightarrow> list_all2 bisim01 es exs'"
proof
  assume "bisim_list es exs'"
  thus "list_all2 bisim01 es exs'"
    by induct(auto intro!: bisim01.intros)
next
  assume "list_all2 bisim01 es exs'"
  thus "bisim_list es exs'"
    by(induct es arbitrary: exs')(auto intro!: bisim_listCons bisim_listNil elim!: bisim01.cases simp add: list_all2_Cons1)
qed

lemma bisim_list_extTA2J0_extTA2J1:
  assumes wf: "wf_J_prog P"
  and sees: "P \<turnstile> C sees M:[]\<rightarrow>T = \<lfloor>meth\<rfloor> in D"
  shows "bisim_list1 (extNTA2J0 P (C, M, a)) (extNTA2J1 (compP1 P) (C, M, a))"
proof -
  obtain pns body where "meth = (pns, body)" by(cases meth)
  with sees have sees: "P \<turnstile> C sees M:[]\<rightarrow>T = \<lfloor>(pns, body)\<rfloor> in D" by simp
  moreover let ?xs = "Addr a # replicate (max_vars body) undefined_value"
  let ?e' = "{0:Class D=None; compE1 (this # pns) body}"
  have "bisim_list1 ({this:Class D=\<lfloor>Addr a\<rfloor>; body}, []) ((?e', ?xs), [])"
  proof
    show "bisim_list [] []" ..
    from sees_wf_mdecl[OF wf_prog_wwf_prog[OF wf] sees] have "fv body \<subseteq> set [this]" "pns = []"
      by(auto simp add: wf_mdecl_def)
    thus "fv ({this:Class D=\<lfloor>Addr a\<rfloor>; body}) = {}" by simp
    from sees_wf_mdecl[OF wf sees] obtain T' where "P,[this \<mapsto> Class D] \<turnstile> body :: T'" "this \<notin> set pns"
      and "\<D> body \<lfloor>dom [this \<mapsto> Addr a]\<rfloor>" by(auto simp add: wf_mdecl_def)
    hence "\<not> contains_insync body" by(auto simp add: contains_insync_conv dest: WT_expr_locks)
    with \<open>fv body \<subseteq> set [this]\<close>
    have "bisim ([] @ [this]) body (compE1 (this # pns) body) ?xs"
      unfolding append.simps \<open>pns = []\<close> by(rule compE1_bisim)
    hence "bisim [] {this:Class D=\<lfloor>Addr a\<rfloor>; body} {length ([] :: String.literal list):Class D=None; compE1 (this # pns) body} ?xs"
      by(rule bisimBlockSomeNone)(simp)
    thus "bisim [] ({this:Class D=\<lfloor>Addr a\<rfloor>; body}) ?e' ?xs" by simp
    from \<open>\<D> body \<lfloor>dom [this \<mapsto> Addr a]\<rfloor>\<close> show "\<D> ({this:Class D=\<lfloor>Addr a\<rfloor>; body}) \<lfloor>{}\<rfloor>" by simp
    show "max_vars ?e' \<le> length ?xs" by simp
  qed
  ultimately show ?thesis by(simp)
qed

lemma bisim_max_vars: "bisim Vs e e' xs \<Longrightarrow> max_vars e = max_vars e'"
  and bisims_max_varss: "bisims Vs es es' xs \<Longrightarrow> max_varss es = max_varss es'"
apply(induct rule: bisim_bisims.inducts)
apply(auto simp add: max_vars_compE1 max_varss_compEs1)
done

lemma bisim_call: "bisim Vs e e' xs \<Longrightarrow> call e = call e'"
  and bisims_calls: "bisims Vs es es' xs \<Longrightarrow> calls es = calls es'"
apply(induct rule: bisim_bisims.inducts)
apply(auto simp add: is_vals_conv)
done

lemma bisim_call_None_call1: "\<lbrakk> bisim Vs e e' xs; call e = None \<rbrakk> \<Longrightarrow> call1 e' = None"
  and bisims_calls_None_calls1: "\<lbrakk> bisims Vs es es' xs; calls es = None \<rbrakk> \<Longrightarrow> calls1 es' = None"
by(induct rule: bisim_bisims.inducts)(auto simp add: is_vals_conv split: if_split_asm)

lemma bisim_call1_Some_call:
  "\<lbrakk> bisim Vs e e' xs; call1 e' = \<lfloor>aMvs\<rfloor> \<rbrakk> \<Longrightarrow> call e = \<lfloor>aMvs\<rfloor>"

  and bisims_calls1_Some_calls:
  "\<lbrakk> bisims Vs es es' xs; calls1 es' = \<lfloor>aMvs\<rfloor> \<rbrakk> \<Longrightarrow> calls es = \<lfloor>aMvs\<rfloor>"
by(induct rule: bisim_bisims.inducts)(auto simp add: is_vals_conv split: if_split_asm)

lemma blocks_bisim:
  assumes bisim: "bisim (Vs @ pns) e e' xs"
  and length: "length vs = length pns" "length Ts = length pns"
  and xs: "\<forall>i. i < length vs \<longrightarrow> xs ! (i + length Vs) = vs ! i"
  shows "bisim Vs (blocks pns Ts vs e) (blocks1 (length Vs) Ts e') xs"
using bisim length xs
proof(induct pns Ts vs e arbitrary: e' Vs rule: blocks.induct)
  case (1 V Vs T Ts v vs e e' VS)
  note IH = \<open>\<And>e' Vsa. \<lbrakk>bisim (Vsa @ Vs) e e' xs;
                       length vs = length Vs; length Ts = length Vs; \<forall>i<length vs. xs ! (i + length Vsa) = vs ! i\<rbrakk>
           \<Longrightarrow> bisim Vsa (blocks Vs Ts vs e) (blocks1 (length Vsa) Ts e') xs\<close>
  note xs = \<open>\<forall>i<length (v # vs). xs ! (i + length VS) = (v # vs) ! i\<close>
  hence xs': "\<forall>i<length vs. xs ! (i + length (VS @ [V])) = vs ! i" and v: "xs ! length VS = v" by(auto)
  from \<open>bisim (VS @ V # Vs) e e' xs\<close> have "bisim ((VS @ [V]) @ Vs) e e' xs" by simp
  from IH[OF this _ _ xs'] \<open>length (v # vs) = length (V # Vs)\<close> \<open>length (T # Ts) = length (V # Vs)\<close>
  have "bisim (VS @ [V]) (blocks Vs Ts vs e) (blocks1 (length (VS @ [V])) Ts e') xs"
    by auto
  hence "bisim VS ({V:T=\<lfloor>v\<rfloor>; blocks Vs Ts vs e}) {length VS:T=None; blocks1 (length (VS @ [V])) Ts e'} xs"
    using v by(rule bisimBlockSomeNone)
  thus ?case by simp
qed(auto)

lemma fixes e :: "('a,'b,'addr) exp" and es :: "('a,'b,'addr) exp list"
  shows inline_call_max_vars: "call e = \<lfloor>aMvs\<rfloor> \<Longrightarrow> max_vars (inline_call e' e) \<le> max_vars e + max_vars e'"
  and inline_calls_max_varss: "calls es = \<lfloor>aMvs\<rfloor> \<Longrightarrow> max_varss (inline_calls e' es) \<le> max_varss es + max_vars e'"
by(induct e and es rule: call.induct calls.induct)(auto)

lemma assumes "final E" "bisim VS E E' xs"
  shows inline_call_compE1: "call e = \<lfloor>aMvs\<rfloor> \<Longrightarrow> inline_call E' (compE1 Vs e) = compE1 Vs (inline_call E e)"
  and inline_calls_compEs1: "calls es = \<lfloor>aMvs\<rfloor> \<Longrightarrow> inline_calls E' (compEs1 Vs es) = compEs1 Vs (inline_calls E es)"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Call Vs obj M params)
  note IHobj = \<open>call obj = \<lfloor>aMvs\<rfloor> \<Longrightarrow> inline_call E' (compE1 Vs obj) = compE1 Vs (inline_call E obj)\<close>
  note IHparams = \<open>calls params = \<lfloor>aMvs\<rfloor> \<Longrightarrow> inline_calls E' (compEs1 Vs params) = compEs1 Vs (inline_calls E params)\<close>
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by (cases aMvs, auto)
  with \<open>call (obj\<bullet>M(params)) = \<lfloor>aMvs\<rfloor>\<close> have "call (obj\<bullet>M(params)) = \<lfloor>(a, M', vs)\<rfloor>" by simp
  thus ?case
  proof(induct rule: call_callE)
    case CallObj
    with IHobj have "inline_call E' (compE1 Vs obj) = compE1 Vs (inline_call E obj)" by auto
    with CallObj show ?case by auto
  next
    case (CallParams v)
    with IHparams have "inline_calls E' (compEs1 Vs params) = compEs1 Vs (inline_calls E params)" by auto
    with CallParams show ?case by(auto simp add: is_vals_conv)
  next
    case Call
    with \<open>final E\<close> \<open>bisim VS E E' xs\<close> show ?case by(auto simp add: is_vals_conv)
  qed
qed(auto split: if_split_asm)

lemma assumes bisim: "bisim VS E E' XS"
  and final: "final E"
  shows bisim_inline_call:
  "\<lbrakk> bisim Vs e e' xs; call e = \<lfloor>aMvs\<rfloor>; fv e \<subseteq> set Vs \<rbrakk>
  \<Longrightarrow> bisim Vs (inline_call E e) (inline_call E' e') xs"

  and bisims_inline_calls:
  "\<lbrakk> bisims Vs es es' xs; calls es = \<lfloor>aMvs\<rfloor>; fvs es \<subseteq> set Vs \<rbrakk>
  \<Longrightarrow> bisims Vs (inline_calls E es) (inline_calls E' es') xs"
proof(induct rule: bisim_bisims.inducts)
  case (bisimBinOp1 Vs e e' xs bop e'')
  thus ?case by(cases "is_val (inline_call E e)")(fastforce)+
next
  case (bisimAAcc1 Vs a a' xs i)
  thus ?case by(cases "is_val (inline_call E a)")(fastforce)+
next
  case (bisimAAss1 Vs a a' xs i e)
  thus ?case by(cases "is_val (inline_call E a)", cases "is_val i")(fastforce)+
next
  case (bisimAAss2 Vs i i' xs a e)
  thus ?case by(cases "is_val (inline_call E i)")(fastforce)+
next
  case (bisimFAss1 Vs e e' xs F D e'')
  thus ?case by(cases "is_val (inline_call E e)")(fastforce)+
next
  case (bisimCAS1 Vs e e' xs e2 e3 D F)
  thus ?case
    apply(cases "is_val (inline_call E e)")
     apply(cases "is_val e2")
      apply(fastforce)
     apply clarsimp
     apply(safe; clarsimp?)
     apply auto
    done
next
  case (bisimCAS2 Vs e e' xs e3 v D F)
  thus ?case by(cases "is_val (inline_call E e)"; safe?; clarsimp; fastforce)
next
  case (bisimCallObj Vs e e' xs es M)
  obtain a M' vs where "aMvs = (a, M', vs)" by(cases aMvs, auto)
  with \<open>call (e\<bullet>M(es)) = \<lfloor>aMvs\<rfloor>\<close> have "call (e\<bullet>M(es)) = \<lfloor>(a, M', vs)\<rfloor>"  by simp
  thus ?case
  proof(induct rule: call_callE)
    case CallObj
    with \<open>fv (e\<bullet>M(es)) \<subseteq> set Vs\<close> \<open>aMvs = (a, M', vs)\<close>
      \<open>\<lbrakk>call e = \<lfloor>aMvs\<rfloor>; fv e \<subseteq> set Vs\<rbrakk> \<Longrightarrow> bisim Vs (inline_call E e) (inline_call E' e') xs\<close>
    have IH': "bisim Vs (inline_call E e) (inline_call E' e') xs" by(auto)
    with \<open>bisim Vs e e' xs\<close> \<open>fv (e\<bullet>M(es)) \<subseteq> set Vs\<close> CallObj \<open>\<not> contains_insyncs es\<close> show ?thesis
      by(cases "is_val (inline_call E e)")(fastforce)+
  next
    case (CallParams v)
    hence "inline_calls E' (compEs1 Vs es) = compEs1 Vs (inline_calls E es)"
      by -(rule inline_calls_compEs1[OF final bisim])
    moreover from \<open>fv (e\<bullet>M(es)) \<subseteq> set Vs\<close> final fvs_inline_calls[of E es]
    have "fvs (inline_calls E es) \<subseteq> set Vs" by(auto elim!: final.cases)
    moreover note CallParams \<open>bisim Vs e e' xs\<close> \<open>fv (e\<bullet>M(es)) \<subseteq> set Vs\<close> \<open>\<not> contains_insyncs es\<close> final
    ultimately show ?case by(auto simp add: is_vals_conv final_iff)
  next
    case Call
    with final bisim \<open>bisim Vs e e' xs\<close> show ?case by(auto simp add: is_vals_conv)
  qed
next
  case (bisimCallParams Vs es es' xs v M)
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by(cases aMvs, auto)
  with \<open>call (Val v\<bullet>M(es)) = \<lfloor>aMvs\<rfloor>\<close> have "call (Val v\<bullet>M(es)) = \<lfloor>(a, M', vs)\<rfloor>"  by simp
  thus ?case
  proof(induct rule: call_callE)
    case CallObj thus ?case by simp
  next
    case (CallParams v')
    with \<open> \<lbrakk>calls es = \<lfloor>aMvs\<rfloor>; fvs es \<subseteq> set Vs\<rbrakk> \<Longrightarrow> bisims Vs (inline_calls E es) (inline_calls E' es') xs\<close> \<open>fv (Val v\<bullet>M(es)) \<subseteq> set Vs\<close>
    have "bisims Vs (inline_calls E es) (inline_calls E' es') xs" by(auto)
    with final bisim \<open>bisims Vs es es' xs\<close> show ?case by(auto simp add: is_vals_conv)
  next
    case Call
    with final bisim \<open>bisims Vs es es' xs\<close> show ?case by(auto)
  qed
next
  case (bisimsCons1 Vs e e' xs es)
  thus ?case by(cases "is_val (inline_call E e)")(fastforce)+
qed(fastforce)+

declare hyperUn_ac [simp del]

lemma sqInt_lem3: "\<lbrakk> A \<sqsubseteq> A'; B \<sqsubseteq> B' \<rbrakk> \<Longrightarrow> A \<sqinter> B \<sqsubseteq> A' \<sqinter> B'"
by(auto simp add: hyperset_defs)

lemma sqUn_lem3: "\<lbrakk> A \<sqsubseteq> A'; B \<sqsubseteq> B' \<rbrakk> \<Longrightarrow> A \<squnion> B \<sqsubseteq> A' \<squnion> B'"
by(auto simp add: hyperset_defs)

lemma A_inline_call: "call e = \<lfloor>aMvs\<rfloor> \<Longrightarrow> \<A> e \<sqsubseteq> \<A> (inline_call e' e)"
  and As_inline_calls: "calls es = \<lfloor>aMvs\<rfloor> \<Longrightarrow>  \<A>s es \<sqsubseteq> \<A>s (inline_calls e' es)"
proof(induct e and es rule: call.induct calls.induct)
  case (Call obj M params)
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by(cases aMvs, auto)
  with \<open>call (obj\<bullet>M(params)) = \<lfloor>aMvs\<rfloor>\<close> have "call (obj\<bullet>M(params)) = \<lfloor>(a, M', vs)\<rfloor>"  by simp
  thus ?case
  proof(induct rule: call_callE)
    case CallObj
    with \<open>call obj = \<lfloor>aMvs\<rfloor> \<Longrightarrow> \<A> obj \<sqsubseteq> \<A> (inline_call e' obj)\<close>
    show ?case by(auto intro: sqUn_lem)
  next
    case CallParams
    with \<open>calls params = \<lfloor>aMvs\<rfloor> \<Longrightarrow> \<A>s params \<sqsubseteq> \<A>s (inline_calls e' params)\<close>
    show ?case by(auto intro: sqUn_lem)
  next
    case Call
    thus ?case by(auto simp add: hyperset_defs)
  qed
next
  case Block thus ?case by(fastforce intro: diff_lem)
next
  case throw thus ?case by(simp add: hyperset_defs)
next
  case TryCatch thus ?case by(auto intro: sqInt_lem)
qed(fastforce intro: sqUn_lem sqUn_lem2)+

lemma assumes "final e'"
  shows defass_inline_call: "\<lbrakk> call e = \<lfloor>aMvs\<rfloor>; \<D> e A \<rbrakk> \<Longrightarrow> \<D> (inline_call e' e) A"
  and defasss_inline_calls: "\<lbrakk> calls es = \<lfloor>aMvs\<rfloor>; \<D>s es A \<rbrakk> \<Longrightarrow> \<D>s (inline_calls e' es) A"
proof(induct e and es arbitrary: A and A rule: call.induct calls.induct)
  case (Call obj M params A)
  obtain a M' vs where [simp]: "aMvs = (a, M', vs)" by(cases aMvs, auto)
  with \<open>call (obj\<bullet>M(params)) = \<lfloor>aMvs\<rfloor>\<close> have "call (obj\<bullet>M(params)) = \<lfloor>(a, M', vs)\<rfloor>"  by simp
  thus ?case
  proof(cases rule: call_callE)
    case CallObj
    with \<open>\<D> (obj\<bullet>M(params)) A\<close> \<open>\<lbrakk>call obj = \<lfloor>aMvs\<rfloor>; \<D> obj A\<rbrakk> \<Longrightarrow> \<D> (inline_call e' obj) A\<close>
    have "\<D> (inline_call e' obj) A" by simp
    moreover from A_inline_call[OF CallObj, of e']
    have "A \<squnion> (\<A> obj) \<sqsubseteq> A \<squnion> (\<A> (inline_call e' obj))" by(rule sqUn_lem2)
    with \<open>\<D> (obj\<bullet>M(params)) A\<close> have "\<D>s params (A \<squnion> \<A> (inline_call e' obj))" by(auto elim: Ds_mono')
    ultimately show ?thesis using CallObj by auto
  next
    case (CallParams v)
    with \<open>\<D> (obj\<bullet>M(params)) A\<close> \<open>\<lbrakk>calls params = \<lfloor>aMvs\<rfloor>; \<D>s params A\<rbrakk> \<Longrightarrow> \<D>s (inline_calls e' params) A\<close>
    have "\<D>s (inline_calls e' params) A" by(simp)
    with CallParams show ?thesis by(auto)
  next
    case Call
    with \<open>final e'\<close> show ?thesis by(auto elim!: D_mono' simp add: hyperset_defs)
  qed
next
  case (Cons_exp exp exps A)
  show ?case
  proof(cases "is_val exp")
    case True
    with \<open>\<D>s (exp # exps) A\<close> \<open>\<lbrakk>calls exps = \<lfloor>aMvs\<rfloor>; \<D>s exps A\<rbrakk> \<Longrightarrow> \<D>s (inline_calls e' exps) A\<close>
      \<open>calls (exp # exps) = \<lfloor>aMvs\<rfloor>\<close>
    have "\<D>s (inline_calls e' exps) A" by(auto)
    with True show ?thesis by(auto)
  next
    case False
    with \<open>\<lbrakk>call exp = \<lfloor>aMvs\<rfloor>; \<D> exp A\<rbrakk> \<Longrightarrow> \<D> (inline_call e' exp) A\<close> \<open>calls (exp # exps) = \<lfloor>aMvs\<rfloor>\<close> \<open>\<D>s (exp # exps) A\<close>
    have "\<D> (inline_call e' exp) A" by auto
    moreover from False \<open>calls (exp # exps) = \<lfloor>aMvs\<rfloor>\<close> have "\<A> exp \<sqsubseteq> \<A> (inline_call e' exp)"
      by(auto intro: A_inline_call)
    hence "A \<squnion> \<A> exp \<sqsubseteq> A \<squnion> \<A> (inline_call e' exp)" by(rule sqUn_lem2)
    with \<open>\<D>s (exp # exps) A\<close> have "\<D>s exps (A \<squnion> \<A> (inline_call e' exp))"
      by(auto intro: Ds_mono')
    ultimately show ?thesis using False by(auto)
  qed
qed(fastforce split: if_split_asm elim: D_mono' intro: sqUn_lem2 sqUn_lem A_inline_call)+

lemma bisim_B: "bisim Vs e E xs \<Longrightarrow> \<B> E (length Vs)"
  and bisims_Bs: "bisims Vs es Es xs \<Longrightarrow> \<B>s Es (length Vs)"
apply(induct rule: bisim_bisims.inducts)
apply(auto intro: \<B> \<B>s)
done

lemma bisim_expr_locks_eq: "bisim Vs e e' xs \<Longrightarrow> expr_locks e = expr_locks e'"
  and bisims_expr_lockss_eq: "bisims Vs es es' xs \<Longrightarrow> expr_lockss es = expr_lockss es'"
by(induct rule: bisim_bisims.inducts)(auto intro!: ext)

lemma bisim_list_expr_lockss_eq: "bisim_list es exs' \<Longrightarrow> expr_lockss es = expr_lockss (map fst exs')"
apply(induct rule: bisim_list.induct)
apply(auto dest: bisim_expr_locks_eq)
done

context J1_heap_base begin

lemma \<tau>Move1_compP [simp]: "\<tau>Move1 (compP f P) = \<tau>Move1 P"
by(intro ext) auto

lemma red1_preserves_unmod:
  "\<lbrakk> uf,P,t \<turnstile>1 \<langle>e, s\<rangle> -ta\<rightarrow> \<langle>e', s'\<rangle>; unmod e i \<rbrakk> \<Longrightarrow> (lcl s') ! i = (lcl s) ! i"

  and reds1_preserves_unmod:
  "\<lbrakk> uf,P,t \<turnstile>1 \<langle>es, s\<rangle> [-ta\<rightarrow>] \<langle>es', s'\<rangle>; unmods es i \<rbrakk> \<Longrightarrow> (lcl s') ! i = (lcl s) ! i"
apply(induct rule: red1_reds1.inducts)
apply(auto split: if_split_asm)
done

lemma red1_unmod_preserved:
  "\<lbrakk> uf,P,t \<turnstile>1 \<langle>e, s\<rangle> -ta\<rightarrow> \<langle>e', s'\<rangle>; unmod e i \<rbrakk> \<Longrightarrow> unmod e' i"
  and reds1_unmods_preserved:
  "\<lbrakk> uf,P,t \<turnstile>1 \<langle>es, s\<rangle> [-ta\<rightarrow>] \<langle>es', s'\<rangle>; unmods es i \<rbrakk> \<Longrightarrow> unmods es' i"
by(induct rule: red1_reds1.inducts)(auto split: if_split_asm)

lemma \<tau>red1t_unmod_preserved:
  "\<lbrakk> \<tau>red1gt uf P t h (e, xs) (e', xs'); unmod e i \<rbrakk> \<Longrightarrow> unmod e' i"
by(induct rule: tranclp_induct2)(auto intro: red1_unmod_preserved)

lemma \<tau>red1r_unmod_preserved:
  "\<lbrakk> \<tau>red1gr uf P t h (e, xs) (e', xs'); unmod e i \<rbrakk> \<Longrightarrow> unmod e' i"
by(induct rule: rtranclp_induct2)(auto intro: red1_unmod_preserved)

lemma \<tau>red1t_preserves_unmod:
  "\<lbrakk>\<tau>red1gt uf P t h (e, xs) (e', xs'); unmod e i; i < length xs \<rbrakk>
  \<Longrightarrow> xs' ! i = xs ! i"
apply(induct rule: tranclp_induct2)
 apply(auto dest: red1_preserves_unmod)
apply(drule red1_preserves_unmod)
apply(erule (1) \<tau>red1t_unmod_preserved)
apply(drule \<tau>red1t_preserves_len)
apply auto
done

lemma \<tau>red1'r_preserves_unmod:
  "\<lbrakk>\<tau>red1gr uf P t h (e, xs) (e', xs'); unmod e i; i < length xs \<rbrakk>
  \<Longrightarrow> xs' ! i = xs ! i"
apply(induct rule: converse_rtranclp_induct2)
 apply(auto dest: red1_preserves_unmod red1_unmod_preserved red1_preserves_len)
apply(frule (1) red1_unmod_preserved)
apply(frule red1_preserves_len)
apply(frule (1) red1_preserves_unmod)
apply auto
done

end

context J_heap_base begin

lemma [simp]:
  fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows \<tau>move0_compP: "\<tau>move0 (compP f P) h e = \<tau>move0 P h e"
  and \<tau>moves0_compP: "\<tau>moves0 (compP f P) h es = \<tau>moves0 P h es"
by(induct e and es rule: \<tau>move0.induct \<tau>moves0.induct) auto

lemma \<tau>Move0_compP [simp]: "\<tau>Move0 (compP f P) = \<tau>Move0 P"
by(intro ext) auto

end

end


section \<open>Implementation of Maps by Arrays\<close>
theory IICF_ArrayMap_Map
  imports "../Intf/IICF_Map" "Imperative_HOL_Time.IHT_Red_Black_Tree"
begin

(* inspired by Separation_Logic_Imperative_HOL/Examples/Array_Map_Impl *)

  subsection "Array Map"

  type_synonym 'v array_map = "'v option array"

  definition "iam_of_list l \<equiv> (\<lambda>i. if i<length l then l!i else None)"

  lemma finite_dom_iam_of_list: "finite (dom (iam_of_list l))"
    by(auto intro: subset_eq_atLeast0_lessThan_finite
          simp: iam_of_list_def domIff split: if_splits)

  definition is_liam   where
    "is_liam s m a \<equiv> \<exists>\<^sub>Al f. snd a\<mapsto>\<^sub>rf * fst a\<mapsto>\<^sub>al * \<up>(length l=s \<and> card (dom m) = f \<and> m=iam_of_list l)"

  definition new_liam :: "nat \<Rightarrow> (('a::{heap}) array_map \<times> 'b::{heap,zero} ref) Heap"  where
    "new_liam n = do { a \<leftarrow> Array_Time.new n None; s\<leftarrow>Ref_Time.ref 0; return (a,s) } "

schematic_goal "\<And>x xa. x \<mapsto>\<^sub>a replicate n None * xa \<mapsto>\<^sub>r 0 * $0\<Longrightarrow>\<^sub>A xa \<mapsto>\<^sub>r 0 * x \<mapsto>\<^sub>a ?f51 x xa  * $0"
  apply solve_entails oops

lemma new_liam_rule: "<$(n+3)> new_liam n <is_liam n (Map.empty)>"
  unfolding new_liam_def is_liam_def
  by (sep_auto heap: ref_rule SLTC.return_rule
        simp: iam_of_list_def)

lemma mop_map_empty_rule:
  "s+3\<le>t () \<Longrightarrow> hn_refine (emp) (new_liam s) emp (is_liam s) (PR_CONST (mop_map_empty t))"
  unfolding autoref_tag_defs mop_map_empty_def
  apply (rule extract_cost_otherway[OF _ new_liam_rule, where Cost_lb="s+3" and F=emp])
    apply solve_entails+
  by auto

thm mop_map_empty_rule[to_hfref]

definition "mop_map_empty_fs s t = SPECT [ Map.empty \<mapsto> enat (t ())]"

context
  fixes s::nat and t ::  "unit \<Rightarrow> nat"
begin
  sepref_register "(mop_map_empty_fs s t )"
end

lemma  mop_map_empty_fs: "tt \<le> lst (SPECT [ Map.empty \<mapsto> t ()  ])  Q
      \<Longrightarrow> tt \<le> lst (mop_map_empty_fs s t ) Q"
  unfolding mop_map_empty_fs_def by simp

definition "mop_map_empty_fixed_length s = mop_map_empty "

context fixes s :: nat begin
    sepref_register " (mop_map_empty_fixed_length s)"
end

lemma mop_map_empty_add_mn: "mop_map_empty = mop_map_empty_fs s"  by(auto simp: mop_map_empty_def mop_map_empty_fs_def)

lemma mop_map_empty_rule'[sepref_fr_rules]:
  "s+3\<le>n () \<Longrightarrow> hn_refine (emp) (new_liam s) emp (is_liam s) (PR_CONST (mop_map_empty_fs s n))"
  unfolding mop_map_empty_fs_def apply(rule mop_map_empty_rule[unfolded mop_map_empty_def]) by simp

definition update_liam where
    "update_liam m k v = do {
          ov \<leftarrow> Array_Time.nth (fst m) k;
          a \<leftarrow> Array_Time.upd k (Some v) (fst m);
          (if ov = None then do {
              s \<leftarrow> Ref_Time.lookup (snd m);
              Ref_Time.update (snd m) (s+1);
              return (a,snd m)
            } else return (a, snd m))
        }
      "
lemma zz: "xs!i = n \<Longrightarrow> xs[i:=n] = xs" by auto

lemma knotin_dom_iam_of_listI: "l ! k = None \<Longrightarrow> k \<notin> dom (iam_of_list l)"
  by(auto simp: iam_of_list_def split: if_splits)

lemma kin_dom_iam_of_listI: "k < length l \<Longrightarrow> l ! k = Some y \<Longrightarrow>  k \<in> dom (iam_of_list l) "
  by(auto simp: iam_of_list_def)

lemma iam_of_list_update: "k < length l \<Longrightarrow> iam_of_list (l[k := Some v]) = iam_of_list l(k \<mapsto> v)"
  by (auto simp: iam_of_list_def split: if_splits)

lemma update_liam_rule: "k<n \<Longrightarrow> <is_liam n M m * $6> update_liam m k v <\<lambda>r. is_liam n (M(k:=Some v)) r >\<^sub>t"
  unfolding update_liam_def is_liam_def
  apply(sep_auto heap: nth_rule lookup_rule update_rule SLTC.return_rule)
    apply(auto simp: zz card.insert_remove finite_dom_iam_of_list
              set_minus_singleton_eq knotin_dom_iam_of_listI iam_of_list_update )
  apply(sep_auto heap: SLTC.return_rule)
   apply(auto intro!: card_Suc_Diff1   simp:    iam_of_list_update finite_dom_iam_of_list )
  by(auto simp: iam_of_list_def)

lemma mop_set_insert_rule[sepref_fr_rules]:
  "(uncurry2 update_liam, uncurry2 (PR_CONST (mop_map_update t)))
     \<in> [\<lambda>((a, b), x). 6 \<le> t ((a, b), x) \<and> b < mn]\<^sub>a (is_liam mn)\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow> is_liam mn"
  apply sepref_to_hoare
  unfolding mop_map_update_def autoref_tag_defs
  apply (rule extract_cost_otherway'[OF _  update_liam_rule ])
  by (auto simp: emb'_def | solve_entails; auto)+

definition dom_member_liam where
    "dom_member_liam m k = do { f \<leftarrow> Array_Time.nth (fst m) k; return (f \<noteq> None) }"

lemma dom_member_liam_rule: "k<n  \<Longrightarrow> <is_liam n M m * $2> dom_member_liam m k <\<lambda>r. is_liam n M m * \<up>(r\<longleftrightarrow>k\<in>dom M)  >\<^sub>t"
  unfolding dom_member_liam_def is_liam_def
  apply(sep_auto heap: nth_rule SLTC.return_rule )
  by(auto simp: iam_of_list_def)

lemma mop_mem_set_rule[sepref_fr_rules]:
  "2 \<le> t (M,x) \<Longrightarrow> x < n \<Longrightarrow>
    hn_refine (hn_val Id x x' * hn_ctxt (is_liam n) M p)
     (dom_member_liam p x')
     (hn_ctxt (pure Id) x x' * hn_ctxt (is_liam n) M p) id_assn ( PR_CONST (mop_map_dom_member t) $ M $ x)"
  apply sepref_to_hoare
  unfolding autoref_tag_defs mop_map_dom_member_def
  apply (rule extract_cost_otherway'[OF _  dom_member_liam_rule])
  by (auto simp: emb'_def | solve_entails; auto)+

definition nth_liam where
    "nth_liam m k = do { f \<leftarrow> Array_Time.nth (fst m) k; return (the f) }"

lemma nth_liam_rule: "k<n \<Longrightarrow> k \<in> dom M \<Longrightarrow> <is_liam n M m * $2> nth_liam m k <\<lambda>r. is_liam n M m * \<up>(r=the (M k))>\<^sub>t"
  unfolding nth_liam_def is_liam_def
  apply(sep_auto heap: nth_rule SLTC.return_rule )
  by(auto simp: iam_of_list_def)

lemma mop_map_lookup_rule[sepref_fr_rules]:
  "2 \<le> t (M,x) \<Longrightarrow> x < n \<Longrightarrow>
    hn_refine (hn_val Id x x' * hn_ctxt (is_liam n) M p)
     (nth_liam p x')
     (hn_ctxt (pure Id) x x' * hn_ctxt (is_liam n) M p) id_assn ( PR_CONST (mop_map_lookup t) $ M $ x)"
  apply sepref_to_hoare
  unfolding autoref_tag_defs mop_map_lookup_def
  apply(rule hnr_ASSERT)
  apply (rule extract_cost_otherway'[OF _ nth_liam_rule] )
    by (auto | solve_entails; auto)+

end


section \<open>Final Instantiation of Algorithms Related to Complementation\<close>

theory Complementation_Final
imports
  "Complementation_Implement"
  "Formula"
  "Transition_Systems_and_Automata.NBA_Translate"
  "Transition_Systems_and_Automata.NGBA_Algorithms"
  "HOL-Library.Permutation"
begin

  subsection \<open>Syntax\<close>

  (* TODO: this syntax has unnecessarily high inner binding strength, requiring extra parentheses
    the regular let syntax correctly uses inner binding strength 0: ("(2_ =/ _)" 10) *)
  no_syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" [1000, 13] 13)
  syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" 13)

  subsection \<open>Hashcodes on Complement States\<close>

  definition "hci k \<equiv> uint32_of_nat k * 1103515245 + 12345"
  definition "hc \<equiv> \<lambda> (p, q, b). hci p + hci q * 31 + (if b then 1 else 0)"
  definition "list_hash xs \<equiv> fold (bitXOR \<circ> hc) xs 0"

  lemma list_hash_eq:
    assumes "distinct xs" "distinct ys" "set xs = set ys"
    shows "list_hash xs = list_hash ys"
  proof -
    have "remdups xs <~~> remdups ys" using eq_set_perm_remdups assms(3) by this
    then have "xs <~~> ys" using assms(1, 2) by (simp add: distinct_remdups_id)
    then have "fold (bitXOR \<circ> hc) xs a = fold (bitXOR \<circ> hc) ys a" for a
    proof (induct arbitrary: a)
      case (swap y x l)
      have "x XOR y XOR a = y XOR x XOR a" for x y by (transfer) (simp add: word_bw_lcs(3))
      then show ?case by simp
    qed simp+
    then show ?thesis unfolding list_hash_def by this
  qed

  definition state_hash :: "nat \<Rightarrow> Complementation_Implement.state \<Rightarrow> nat" where
    "state_hash n p \<equiv> nat_of_hashcode (list_hash p) mod n"

  lemma state_hash_bounded_hashcode[autoref_ga_rules]: "is_bounded_hashcode state_rel
    (gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
    (prod_eq (=) (\<longleftrightarrow>))) state_hash"
  proof
    show [param]: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
      (prod_eq (=) (\<longleftrightarrow>)), (=)) \<in> state_rel \<rightarrow> state_rel \<rightarrow> bool_rel" by autoref
    show "state_hash n xs = state_hash n ys" if "xs \<in> Domain state_rel" "ys \<in> Domain state_rel"
      "gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list))
      (list_map_lookup (=)) (prod_eq (=) (=)) xs ys" for xs ys n
    proof -
      have 1: "distinct (map fst xs)" "distinct (map fst ys)"
        using that(1, 2) unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
      have 2: "distinct xs" "distinct ys" using 1 by (auto intro: distinct_mapI)
      have 3: "(xs, map_of xs) \<in> state_rel" "(ys, map_of ys) \<in> state_rel"
        using 1 unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
      have 4: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
        (prod_eq (=) (\<longleftrightarrow>)) xs ys, map_of xs = map_of ys) \<in> bool_rel" using 3 by parametricity
      have 5: "map_to_set (map_of xs) = map_to_set (map_of ys)" using that(3) 4 by simp
      have 6: "set xs = set ys" using map_to_set_map_of 1 5 by blast
      show "state_hash n xs = state_hash n ys" unfolding state_hash_def using list_hash_eq 2 6 by metis
    qed
    show "state_hash n x < n" if "1 < n" for n x using that unfolding state_hash_def by simp
  qed

  subsection \<open>Complementation\<close>

  schematic_goal complement_impl:
    assumes [simp]: "finite (NBA.nodes A)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, op_translate (complement_4 A)) \<in> ?R"
    by (autoref_monadic (plain))
  concrete_definition complement_impl uses complement_impl

  theorem complement_impl_correct:
    assumes "finite (NBA.nodes A)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "NBA.language (nbae_nba (nbaei_nbae (complement_impl Ai))) =
      streams (nba.alphabet A) - NBA.language A"
    using op_translate_language[OF complement_impl.refine[OF assms]]
    using complement_4_correct[OF assms(1)]
    by simp

  subsection \<open>Language Subset\<close>

  definition [simp]: "op_language_subset A B \<equiv> NBA.language A \<subseteq> NBA.language B"

  lemmas [autoref_op_pat] = op_language_subset_def[symmetric]

  (* TODO: maybe we can implement emptiness check on NGBAs and skip degeneralization step *)
  schematic_goal language_subset_impl:
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, do {
      let AB' = intersect A (complement_4 B);
      ASSERT (finite (NBA.nodes AB'));
      RETURN (NBA.language AB' = {})
    }) \<in> ?R"
		by (autoref_monadic (plain))
  concrete_definition language_subset_impl uses language_subset_impl
  lemma language_subset_impl_refine[autoref_rules]:
    assumes "SIDE_PRECOND (finite (NBA.nodes A))"
    assumes "SIDE_PRECOND (finite (NBA.nodes B))"
    assumes "SIDE_PRECOND (nba.alphabet A \<subseteq> nba.alphabet B)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(language_subset_impl Ai Bi, (OP op_language_subset :::
      \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
  proof -
    have "(RETURN (language_subset_impl Ai Bi), do {
      let AB' = intersect A (complement_4 B);
      ASSERT (finite (NBA.nodes AB'));
      RETURN (NBA.language AB' = {})
    }) \<in> \<langle>bool_rel\<rangle> nres_rel"
      using language_subset_impl.refine assms(2, 4, 5) unfolding autoref_tag_defs by this
    also have "(do {
      let AB' = intersect A (complement_4 B);
      ASSERT (finite (NBA.nodes AB'));
      RETURN (NBA.language AB' = {})
    }, RETURN (NBA.language A \<subseteq> NBA.language B)) \<in> \<langle>bool_rel\<rangle> nres_rel"
    proof refine_vcg
      show "finite (NBA.nodes (intersect A (complement_4 B)))" using assms(1, 2) by auto
      have 1: "NBA.language A \<subseteq> streams (nba.alphabet B)"
        using nba.language_alphabet streams_mono2 assms(3) unfolding autoref_tag_defs by blast
      have 2: "NBA.language (complement_4 B) = streams (nba.alphabet B) - NBA.language B"
        using complement_4_correct assms(2) by auto
      show "(NBA.language (intersect A (complement_4 B)) = {},
        NBA.language A \<subseteq> NBA.language B) \<in> bool_rel" using 1 2 by auto
    qed
    finally show ?thesis using RETURN_nres_relD unfolding nres_rel_comp by force
  qed

  subsection \<open>Language Equality\<close>

  definition [simp]: "op_language_equal A B \<equiv> NBA.language A = NBA.language B"

  lemmas [autoref_op_pat] = op_language_equal_def[symmetric]

  schematic_goal language_equal_impl:
    assumes [simp]: "finite (NBA.nodes A)"
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [simp]: "nba.alphabet A = nba.alphabet B"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, NBA.language A \<subseteq> NBA.language B \<and> NBA.language B \<subseteq> NBA.language A) \<in> ?R"
    by autoref
  concrete_definition language_equal_impl uses language_equal_impl
  lemma language_equal_impl_refine[autoref_rules]:
    assumes "SIDE_PRECOND (finite (NBA.nodes A))"
    assumes "SIDE_PRECOND (finite (NBA.nodes B))"
    assumes "SIDE_PRECOND (nba.alphabet A = nba.alphabet B)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(language_equal_impl Ai Bi, (OP op_language_equal :::
      \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
    using language_equal_impl.refine[OF assms[unfolded autoref_tag_defs]] by auto

  schematic_goal product_impl:
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, do {
      let AB' = intersect A (complement_4 B);
      ASSERT (finite (NBA.nodes AB'));
      op_translate AB'
    }) \<in> ?R"
		by (autoref_monadic (plain))
  concrete_definition product_impl uses product_impl

  (* TODO: possible optimizations:
    - introduce op_map_map operation for maps instead of manually iterating via FOREACH
    - consolidate various binds and maps in expand_map_get_7 *)
  export_code
    Set.empty Set.insert Set.member
    "Inf :: 'a set set \<Rightarrow> 'a set" "Sup :: 'a set set \<Rightarrow> 'a set" image Pow set
    nat_of_integer integer_of_nat
    Variable Negation Conjunction Disjunction satisfies
    nbaei alphabetei initialei transitionei acceptingei
    nbae_nba_impl complement_impl language_equal_impl product_impl
    in SML module_name Complementation file_prefix Complementation

end


;;; -*- syntax: common-lisp; package: KEIM; base: 10; mode: Theory -*-
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;;                                                                          ;;
;;   Copyright (C) 1998 by AG Siekmann, Fachbereich Informatik,             ;;
;;   Universitaet des Saarlandes, Saarbruecken, Germany.                    ;;
;;   All rights reserved.                                                   ;;
;;   For information about this program, write to:                          ;;
;;     KEIM Project                                                         ;;
;;     AG Siekmann/FB Informatik                                            ;;
;;     Universitaet des Saarlandes                                          ;;
;;     Postfach 1150                                                        ;;
;;     D-66041 Saarbruecken                                                 ;;
;;     Germany                                                              ;;
;;   electronic mail: keim@ags.uni-sb.de                                     ;;
;;                                                                          ;;
;;   The author makes no representations about the suitability of this      ;;
;;   software for any purpose.  It is provided "AS IS" without express or   ;;
;;   implied warranty.  In particular, it must be understood that this      ;;
;;   software is an experimental version, and is not suitable for use in    ;;
;;   any safety-critical application, and the author denies a license for   ;;
;;   such use.                                                              ;;
;;                                                                          ;;
;;   You may use, copy, modify and distribute this software for any         ;;
;;   noncommercial and non-safety-critical purpose.  Use of this software   ;;
;;   in a commercial product is not included under this license.  You must  ;;
;;   maintain this copyright statement in all copies of this software that  ;;
;;   you modify or distribute.                                              ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
(in-package :omega)

;Beispiel aus LIMIT
;(th~deftheorem absval-idempotence
;               (in limit)
;               (conclusion
;                (forall (lam (a num)
;                             (= (absval (absval a))
;                                (absval a)))))
;               (help "The idempotence of |.| "))

(th~deftheorem fact1
	       (in lock-res)
	       (conclusion
		(forall (lam (x (o form)) (forall (lam (y (o (o form)))
				(implies (in x y)
					 (derivable x y crule-set)))))))
	       (help "Theorem for the fact, that every element of a set of clauses is derivable."))

(th~deftheorem fact2
               (in lock-res)
               (conclusion
                (forall (lam (y (o (o form)))
                            (implies (and (forall (lam (x (o form))
                                                       (implies (in x y) (setunit x))))
                                          (unsat-cl-set y))
                                     (derivable empty-cl y crule-set)))))
               (help "Theorem for the fact, that resolvable unit cluase, result in the empty clause."))

;(th~deftheorem fact2
;               (in lock-res)
;               (conclusion
;                (forall (lam (cs (o (o form)))
;                  (implies
;                   (exists (lam (x (o form))
;                           (exists (lam (y (o form))
;                                   (and (and (and (setunit x) (setunit y))
;                                             (resolvable-s x y))
;                                        (and (cs x) (cs y)))))))
;                   (derivable empty-cl cs crule-set))))))

(th~deftheorem fact3
	       (in lock-res)
	       (conclusion
		(forall (lam (klm (o (o form))) (forall (lam (gkl (o form))
                           (implies
                            (and (in klm all-clause-sets)
                                 (exists (lam  (kl1 (o form)) (and (klm kl1) (card>2 kl1)))))
                            (exists (lam (kl (o form)) (exists (lam (l form)
                                (and (and (implies
                                           (derivable
                                            gkl
                                            (union (setminus klm (singleton kl))
                                                   (singleton (setminus kl (singleton l))))
                                            crule-set)
                                           (or (derivable gkl klm crule-set)
                                               (derivable (union gkl (singleton l))
                                                          klm crule-set)))
                                          (kl l))
                                     (and (klm kl)
                                          (card>2 kl)))))))))))))
	       (help "A calculus independet formulation of the Disjunction Lemma"))

(th~defaxiom fact4
	     (in lock-res)
	     (formula (forall (lam (klm (o (o form))) (forall (lam (kl (o form))
			     (forall (lam (l form)
			       (implies
				(and
				 (and (klm kl) (kl l))
				 (and (derivable
				       (union empty-cl (singleton l))
				       klm
				       crule-set)
				      (derivable
				       empty-cl
				       (union (setminus klm (singleton kl))
					      (singleton (singleton l)))
				       crule-set)))
				 (derivable empty-cl klm crule-set)))))))))
	     (help "A formula helping to close the eln-technique application."))

(th~deftheorem leq-thm-1
	       (in lock-res)
	       (conclusion
		(forall (lam (x num) (forall (lam (y num)
			     (implies (and (nat x) (nat y))
				      (equiv (leq x y)
					      (or (= x y)
						  (leq (s x) y))))))))))

(th~deftheorem card2
	       (in lock-res)
	       (conclusion
		(forall (lam (as (o form))
			     (implies (card>2 as)
				      (exists (lam (el form)
						   (as el))))))))


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

header{*The n_moesi Protocol Case Study*}

theory n_moesi_on_inis imports n_moesi_on_ini
begin
lemma on_inis:
  assumes b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  shows "formEval f s"
  proof -
  have c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__1  p__Inv0 p__Inv2)\<or>
    (\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__2  p__Inv0 p__Inv2)\<or>
    (\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__3  p__Inv0 p__Inv2)"
  apply (cut_tac b1, simp) done
    moreover {
      assume d1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__1  p__Inv0 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__1)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__2  p__Inv0 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__2)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__3  p__Inv0 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__3)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

  ultimately show "formEval f s"
  by satx
qed

end