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

theory ArchVSpaceEntries_AI
imports VSpaceEntries_AI
begin

context Arch begin global_naming X64 (*FIXME: arch_split*)

lemma a_type_pml4D:
  "a_type ko = AArch APageMapL4 \<Longrightarrow> \<exists>pm. ko = ArchObj (PageMapL4 pm)"
  by (clarsimp)

primrec
  pde_range :: "pde \<Rightarrow> 9 word \<Rightarrow> 9 word set"
where
    "pde_range (InvalidPDE) p = {}"
  | "pde_range (LargePagePDE ptr x y) p = {p}"
  | "pde_range (PageTablePDE ptr x z) p = {p}"

primrec
  pdpte_range :: "pdpte \<Rightarrow> 9 word \<Rightarrow> 9 word set"
where
    "pdpte_range (InvalidPDPTE) p = {}"
  | "pdpte_range (HugePagePDPTE ptr x y) p = {p}"
  | "pdpte_range (PageDirectoryPDPTE ptr x z) p = {p}"

primrec
  pml4e_range :: "pml4e \<Rightarrow> 9 word \<Rightarrow> 9 word set"
where
    "pml4e_range (InvalidPML4E) p = {}"
  | "pml4e_range (PDPointerTablePML4E ptr x z) p = {p}"

primrec
  pte_range :: "pte \<Rightarrow> 9 word \<Rightarrow> 9 word set"
where
    "pte_range (InvalidPTE) p = {}"
  | "pte_range (SmallPagePTE ptr x y) p = {p}"

abbreviation "valid_pt_entries \<equiv> \<lambda>pt. valid_entries pte_range pt"
abbreviation "valid_pd_entries \<equiv> \<lambda>pd. valid_entries pde_range pd"

abbreviation "valid_pdpt_entries \<equiv> \<lambda>pdpt. valid_entries pdpte_range pdpt"

abbreviation "valid_pml4_entries \<equiv> \<lambda>pml4. valid_entries pml4e_range pml4"

definition
  obj_valid_vspace :: "kernel_object \<Rightarrow> bool"
where
 "obj_valid_vspace obj \<equiv> case obj of
    ArchObj (PageTable pt) \<Rightarrow> valid_pt_entries pt
  | ArchObj (PageDirectory pd) \<Rightarrow> valid_pd_entries pd
  | ArchObj (PDPointerTable pdpt) \<Rightarrow> valid_pdpt_entries pdpt
  | ArchObj (PageMapL4 pml4) \<Rightarrow> valid_pml4_entries pml4
  | _ \<Rightarrow> True"

lemmas obj_valid_vspace_simps[simp]
    = obj_valid_vspace_def
        [split_simps Structures_A.kernel_object.split
                     arch_kernel_obj.split]

abbreviation
  valid_vspace_objs' :: "'z state \<Rightarrow> bool"
where
 "valid_vspace_objs' s \<equiv> \<forall>x \<in> ran (kheap s). obj_valid_vspace x"

(* FIXME x64: initial state
lemma valid_vspace_init[iff]:
  "valid_vspace_objs' init_A_st"
proof -
  have P: "valid_pml4_entries (global_pm :: 9 word \<Rightarrow> _)"
    apply (clarsimp simp: valid_entries_def)
  also have Q: "entries_align range_sz (global_pm :: 9 word \<Rightarrow> _)"
    by (clarsimp simp: entries_align_def)
  thus ?thesis using P
    by (auto simp: init_A_st_def init_kheap_def
            elim!: ranE split: if_split_asm)
qed
*)

lemma set_object_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and K (obj_valid_vspace obj)\<rbrace>
      set_object ptr obj
   \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  including unfold_objects
  apply (wpsimp wp: set_object_wp_strong simp: a_type_def)
  apply (auto simp: fun_upd_def[symmetric] del: ballI elim: ball_ran_updI)
  done

crunch valid_vspace_objs'[wp]: cap_insert, cap_swap_for_delete,empty_slot "valid_vspace_objs'"
  (wp: crunch_wps simp: crunch_simps ignore:set_object)

(*
lemma shift_0x3C_set:
  "\<lbrakk> is_aligned p 6; 8 \<le> bits; bits < 32; len_of TYPE('a) = bits - 2 \<rbrakk> \<Longrightarrow>
   (\<lambda>x. ucast (x + p && mask bits >> 2) :: ('a :: len) word) ` set [0 :: word32 , 4 .e. 0x3C]
        = {x. x && ~~ mask 4 = ucast (p && mask bits >> 2)}"
  apply (clarsimp simp: upto_enum_step_def word_shift_by_2 image_image)
  apply (subst image_cong[where N="{x. x < 2 ^ 4}"])
    apply (safe, simp_all)[1]
     apply (drule plus_one_helper2, simp_all)[1]
    apply (drule word_le_minus_one_leq, simp_all)[1]
   apply (rule_tac f="\<lambda>x. ucast (x && mask bits >> 2)" in arg_cong)
   apply (rule trans[OF add.commute is_aligned_add_or], assumption)
   apply (rule shiftl_less_t2n, simp_all)[1]
  apply safe
   apply (frule upper_bits_unset_is_l2p_32[THEN iffD2, rotated])
    apply (simp add: word_bits_conv)
   apply (rule word_eqI)
   apply (simp add: word_ops_nth_size word_size nth_ucast nth_shiftr
                    nth_shiftl neg_mask_test_bit
                    word_bits_conv)
   apply (safe, simp_all add: is_aligned_nth)[1]
   apply (drule_tac x="Suc (Suc n)" in spec)
   apply simp
  apply (rule_tac x="ucast x && mask 4" in image_eqI)
   apply (rule word_eqI)
   apply (drule_tac x=n in word_eqD)
   apply (simp add: word_ops_nth_size word_size nth_ucast nth_shiftr
                    nth_shiftl)
   apply (safe, simp_all)
  apply (rule order_less_le_trans, rule and_mask_less_size)
   apply (simp_all add: word_size)
  done
*)

lemma mapM_x_store_pte_updates:
  "\<forall>x \<in> set xs. f x && ~~ mask pt_bits = p \<Longrightarrow>
   \<lbrace>\<lambda>s. (\<not> page_table_at p s \<longrightarrow> Q s) \<and>
        (\<forall>pt. ko_at (ArchObj (PageTable pt)) p s
           \<longrightarrow> Q (s \<lparr> kheap := (kheap s) (p := Some (ArchObj (PageTable (\<lambda>y. if y \<in> (\<lambda>x.
         ucast (f x && mask pt_bits >> 3)) ` set xs then pte else pt y)))) \<rparr>))\<rbrace>
     mapM_x (\<lambda>x. store_pte (f x) pte) xs
   \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (induct xs)
   apply (simp add: mapM_x_Nil)
   apply wp
   apply (clarsimp simp: obj_at_def fun_upd_idem)
  apply (simp add: mapM_x_Cons)
  apply (rule hoare_seq_ext, assumption)
  apply (thin_tac "valid P f Q" for P f Q)
  apply (simp add: store_pte_def set_pt_def set_object_def word_size_bits_def)
  apply (wp get_pt_wp get_object_wp)
  apply (clarsimp simp: obj_at_def a_type_simps)
  apply (erule rsubst[where P=Q])
  apply (rule abstract_state.fold_congs[OF refl refl])
  apply (rule ext, clarsimp)
  apply (rule ext, clarsimp)
  done

lemma valid_pt_entries_invalid[simp]:
  "valid_pt_entries (\<lambda>x. InvalidPTE)"
   by (simp add:valid_entries_def)

lemma valid_pd_entries_invalid[simp]:
  "valid_pd_entries (\<lambda>x. InvalidPDE)"
  by (simp add:valid_entries_def)

lemma valid_pdpt_entries_invalid[simp]:
  "valid_pdpt_entries (\<lambda>x. InvalidPDPTE)"
  by (simp add:valid_entries_def)

lemma valid_pml4_entries_invalid[simp]:
  "valid_pml4_entries (\<lambda>x. InvalidPML4E)"
  by (simp add:valid_entries_def)

lemma valid_vspace_objs'_pml4D:
  "\<lbrakk>valid_vspace_objs' s;
    kheap s ptr = Some (ArchObj (arch_kernel_obj.PageMapL4 pml4))\<rbrakk>
   \<Longrightarrow> valid_pml4_entries pml4"
  by (fastforce simp:ran_def)

lemma valid_vspace_objs'_pdptD:
  "\<lbrakk>valid_vspace_objs' s;
    kheap s ptr = Some (ArchObj (arch_kernel_obj.PDPointerTable pdpt))\<rbrakk>
   \<Longrightarrow> valid_pdpt_entries pdpt"
  by (fastforce simp:ran_def)

lemma valid_vspace_objs'_pdD:
  "\<lbrakk>valid_vspace_objs' s;
    kheap s ptr = Some (ArchObj (arch_kernel_obj.PageDirectory pd))\<rbrakk>
   \<Longrightarrow> valid_pd_entries pd"
  by (fastforce simp:ran_def)

lemma valid_vspace_objs'_ptD:
  "\<lbrakk>valid_vspace_objs' s;
    kheap s ptr = Some (ArchObj (arch_kernel_obj.PageTable pt))\<rbrakk>
   \<Longrightarrow> valid_pt_entries pt"
  by (fastforce simp:ran_def)

lemma mapM_x_store_pde_updates:
  "\<forall>x \<in> set xs. f x && ~~ mask pd_bits = p \<Longrightarrow>
   \<lbrace>\<lambda>s. (\<not> page_directory_at p s \<longrightarrow> Q s) \<and>
        (\<forall>pd. ko_at (ArchObj (PageDirectory pd)) p s
           \<longrightarrow> Q (s \<lparr> kheap := (kheap s) (p := Some (ArchObj (PageDirectory (\<lambda>y. if y \<in> (\<lambda>x.
         ucast (f x && mask pd_bits >> 3)) ` set xs then pde else pd y)))) \<rparr>))\<rbrace>
     mapM_x (\<lambda>x. store_pde (f x) pde) xs
   \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (induct xs)
   apply (simp add: mapM_x_Nil)
   apply wp
   apply (clarsimp simp: obj_at_def fun_upd_idem)
  apply (simp add: mapM_x_Cons)
  apply (rule hoare_seq_ext, assumption)
  apply (thin_tac "valid P f Q" for P f Q)
  apply (simp add: store_pde_def set_pd_def set_object_def word_size_bits_def)
  apply (wp get_pd_wp get_object_wp)
  apply (clarsimp simp: obj_at_def a_type_simps)
  apply (erule rsubst[where P=Q])
  apply (rule abstract_state.fold_congs[OF refl refl])
  apply (rule ext, clarsimp)
  apply (rule ext, clarsimp)
  done

lemma store_pde_valid_vspace_objs':
  "\<lbrace>valid_vspace_objs'\<rbrace>
       store_pde p pde \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: store_pde_def set_pd_def)
  apply (wpsimp wp: set_object_valid_vspace_objs')
  apply (clarsimp simp: obj_at_def)
  apply (rule valid_entries_overwrite_0)
   apply (fastforce simp:ran_def)
  apply (drule bspec)
   apply fastforce
  apply (case_tac "pd pa")
    apply simp_all
   apply (case_tac pde,simp_all)
  apply (case_tac pde,simp_all)
  done

lemma store_pte_valid_vspace_objs':
  "\<lbrace>valid_vspace_objs'\<rbrace>
       store_pte p pte \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: store_pte_def set_pt_def)
  apply (wpsimp wp: set_object_valid_vspace_objs')
  apply (clarsimp simp: obj_at_def)
  apply (rule valid_entries_overwrite_0)
   apply (fastforce simp:ran_def)
  apply (drule bspec)
   apply fastforce
  apply (case_tac "pt pa")
   apply simp
  apply (case_tac pte,simp_all)
  done

lemma store_pdpte_valid_vspace_objs':
  "\<lbrace>valid_vspace_objs'\<rbrace>
       store_pdpte p pdpte \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: store_pdpte_def set_pdpt_def)
  apply (wpsimp wp: set_object_valid_vspace_objs')
  apply (clarsimp simp: obj_at_def)
  apply (rule valid_entries_overwrite_0)
   apply (fastforce simp:ran_def)
  apply (drule bspec)
   apply fastforce
  apply (case_tac "pd pa")
    apply simp
   apply (case_tac pdpte,simp_all)
  apply (case_tac pdpte,simp_all)
  done

lemma store_pml4e_valid_vspace_objs':
  "\<lbrace>valid_vspace_objs'\<rbrace>
       store_pml4e p pml4e \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: store_pml4e_def set_pml4_def)
  apply (wpsimp wp: set_object_valid_vspace_objs')
  apply (clarsimp simp: obj_at_def)
  apply (rule valid_entries_overwrite_0)
   apply (fastforce simp:ran_def)
  apply (drule bspec)
   apply fastforce
  apply (case_tac "pm pa")
   apply simp
  apply (case_tac pml4e,simp_all)
  done

lemma unmap_page_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs'\<rbrace> unmap_page sz asid vptr pptr \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: unmap_page_def mapM_discarded
             cong: vmpage_size.case_cong)
  apply (wp)
    prefer 2
    apply (rule valid_validE[OF find_vspace_for_asid_inv])
  apply (rule hoare_pre)
   apply (wp get_object_wp get_pte_wp get_pde_wp lookup_pt_slot_inv_any lookup_pd_slot_inv_any
             get_pdpte_wp lookup_pdpt_slot_inv_any
             store_pte_valid_vspace_objs' store_pde_valid_vspace_objs' store_pdpte_valid_vspace_objs'

                | simp add: mapM_x_map
                | wpc | simp add: check_mapping_pptr_def)+
  done

lemma flush_table_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs'\<rbrace> flush_table a b c d \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  by (wp mapM_x_wp' | wpc | simp add: flush_table_def | rule hoare_pre)+

crunch valid_vspace_objs'[wp]: invalidate_page_structure_cache_asid valid_vspace_objs'

crunch kheap[wp]: get_cap "\<lambda>s. P (kheap s)"
  (wp: crunch_wps simp: crunch_simps)

lemma flush_table_kheap[wp]:
  "\<lbrace>\<lambda>s. P (kheap s)\<rbrace> flush_table a b c d \<lbrace>\<lambda>rv s. P (kheap s)\<rbrace>"
  by (wp mapM_x_wp' | wpc | simp add: flush_table_def | rule hoare_pre)+

lemma unmap_page_table_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs'\<rbrace> unmap_page_table asid vptr pt \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: unmap_page_table_def)
  apply (wp get_object_wp store_pde_valid_vspace_objs' get_pde_wp lookup_pd_slot_inv_any | wpc)+
  apply (simp add: obj_at_def)
  done

crunch valid_vspace_objs'[wp]: set_simple_ko "valid_vspace_objs'"
  (wp: crunch_wps)

crunch valid_vspace_objs'[wp]: finalise_cap, cap_swap_for_delete, empty_slot "valid_vspace_objs'"
  (wp: crunch_wps select_wp preemption_point_inv simp: crunch_simps unless_def ignore:set_object)

lemma preemption_point_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs'\<rbrace> preemption_point \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  by (wp preemption_point_inv | simp)+

lemmas cap_revoke_preservation_valid_vspace_objs = cap_revoke_preservation[OF _,
                                                          where E=valid_vspace_objs',
                                                          simplified, THEN validE_valid]

lemmas rec_del_preservation_valid_vspace_objs = rec_del_preservation[OF _ _ _ _,
                                                    where P=valid_vspace_objs', simplified]

crunch valid_vspace_objs'[wp]: cap_delete, cap_revoke "valid_vspace_objs'"
  (rule: cap_revoke_preservation_valid_vspace_objs)

lemma mapM_x_copy_pml4e_updates:
  "\<lbrakk> \<forall>x \<in> set xs. f x && ~~ mask pml4_bits = 0; is_aligned p pml4_bits;
               is_aligned p' pml4_bits \<rbrakk> \<Longrightarrow>
   \<lbrace>\<lambda>s. (\<not> page_map_l4_at p s \<longrightarrow> Q s) \<and> (\<not> page_map_l4_at p' s \<longrightarrow> Q s) \<and>
        (\<forall>pml4 pml4'. ko_at (ArchObj (PageMapL4 pml4)) p s
                \<and> ko_at (ArchObj (PageMapL4 pml4')) p' s
           \<longrightarrow> Q (s \<lparr> kheap := (kheap s) (p' := Some (ArchObj (PageMapL4 (\<lambda>y. if y \<in> (\<lambda>x.
         ucast (f x && mask pml4_bits >> 3)) ` set xs then pml4 y else pml4' y)))) \<rparr>))\<rbrace>
     mapM_x (\<lambda>x. get_pml4e (p + f x) >>= store_pml4e (p' + f x)) xs
   \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (induct xs)
   apply (simp add: mapM_x_Nil)
   apply wp
   apply (clarsimp simp: obj_at_def fun_upd_idem dest!: a_type_pml4D)
  apply (simp add: mapM_x_Cons)
  apply wp
   apply (thin_tac "valid P f Q" for P f Q)
   apply (simp add: store_pml4e_def set_pml4_def set_object_def
              cong: bind_cong split del: if_split)
   apply (wp get_object_wp get_pml4e_wp)
  apply (clarsimp simp: obj_at_def a_type_simps mask_out_add_aligned[symmetric] word_size_bits_def
             split del: if_split)
  apply (simp add: a_type_simps, safe)
   apply (erule rsubst[where P=Q])
   apply (rule abstract_state.fold_congs[OF refl refl])
   apply (rule ext, clarsimp)
   apply (rule ext, simp)
  apply (erule rsubst[where P=Q])
  apply (rule abstract_state.fold_congs[OF refl refl])
  apply (rule ext, clarsimp)
  apply (rule ext, simp add: mask_add_aligned)
  done

lemma copy_global_mappings_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and valid_arch_state and pspace_aligned
            and K (is_aligned p pml4_bits)\<rbrace>
       copy_global_mappings p \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (simp add: copy_global_mappings_def)
  apply wp
   apply (rule_tac P="is_aligned global_pm pml4_bits" in hoare_gen_asm)
   apply (rule mapM_x_copy_pml4e_updates; simp)
   apply (clarsimp simp: mask_eq_x_eq_0[symmetric])
   apply (rule less_mask_eq, rule shiftl_less_t2n,
          simp_all add: bit_simps)[1]
   apply (drule plus_one_helper2, simp+)
  apply wp
  apply (clarsimp simp: invs_aligned_pml4D ranI
                 elim!: ranE split: if_split_asm)
  apply (rule_tac S="{x. ucast x \<ge> (get_pml4_index pptr_base)}"
                 in valid_entries_partial_copy)
     apply (fastforce simp: obj_at_def ran_def)
    apply (fastforce simp: obj_at_def ran_def)
   apply (clarsimp simp:image_def)
   apply (subst (asm) less_mask_eq)
    apply (rule shiftl_less_t2n)
     apply (simp add:pd_bits_def pageBits_def word_le_make_less bit_simps)
    apply (simp add:pd_bits_def pageBits_def bit_simps)
   apply (subst (asm) shiftl_shiftr1)
    apply (simp add: word_size_bits_def)
   apply (simp add:word_size)
   apply (subst (asm) less_mask_eq)
    apply (simp add:pd_bits_def pageBits_def le_less_trans bit_simps)
   apply (case_tac v)
    apply ((simp add:ucast_ucast_len pd_bits_def pageBits_def le_less_trans bit_simps)+)[2]
  apply (clarsimp simp:image_def)
  apply (rule disjointI)
  apply clarsimp
  apply (drule_tac x = "ucast x" in spec)
  apply (erule impE)
   apply (simp add: bit_simps)
   apply word_bitwise
  apply (subgoal_tac "get_pml4_index pptr_base \<le> ucast x")
   apply simp
   apply (subst (asm) less_mask_eq)
    apply (rule shiftl_less_t2n)
     apply (simp add: word_le_make_less bit_simps)
     apply word_bitwise
    apply (simp add: bit_simps)
   apply (subst (asm) shiftl_shiftr1)
    apply (simp add: word_size_bits_def)
   apply (simp add:word_size)
   apply (subst (asm) less_mask_eq)
    apply (rule less_le_trans[OF ucast_less])
     apply simp
    apply (simp add: word_size_bits_def)
   apply (simp add: word_size_bits_def get_pml4_index_def bit_simps)
   apply word_bitwise
  apply (case_tac v;simp)
  done

lemma in_pte_rangeD:
  "x \<in> pte_range v y \<Longrightarrow> x = y"
  by (case_tac v,simp_all split:if_splits)

lemma in_pde_rangeD:
  "x \<in> pde_range v y \<Longrightarrow> x = y"
  by (case_tac v,simp_all split:if_splits)

lemma in_pdpte_rangeD:
  "x \<in> pdpte_range v y \<Longrightarrow> x = y"
  by (case_tac v,simp_all split:if_splits)

lemma in_pml4e_rangeD:
  "x \<in> pml4e_range v y \<Longrightarrow> x = y"
  by (case_tac v,simp_all split:if_splits)

lemma non_invalid_in_pde_range:
  "pde \<noteq> InvalidPDE
  \<Longrightarrow> x \<in> pde_range pde x"
  by (case_tac pde,simp_all)

lemma non_invalid_in_pte_range:
  "pte \<noteq> InvalidPTE
  \<Longrightarrow> x \<in> pte_range pte x"
  by (case_tac pte,simp_all)

lemma non_invalid_in_pml4e_range:
  "pml4e \<noteq> InvalidPML4E
  \<Longrightarrow> x \<in> pml4e_range pml4e x"
  by (case_tac pml4e,simp_all)

lemma non_invalid_in_pdpte_range:
  "pdpte \<noteq> InvalidPDPTE
  \<Longrightarrow> x \<in> pdpte_range pdpte x"
  by (case_tac pdpte,simp_all)

crunch valid_vspace_objs'[wp]: cancel_badged_sends "valid_vspace_objs'"
  (simp: crunch_simps filterM_mapM wp: crunch_wps ignore: filterM)

crunch valid_vspace_objs'[wp]: cap_move, cap_insert "valid_vspace_objs'"

lemma invoke_cnode_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and invs and valid_cnode_inv i\<rbrace> invoke_cnode i \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: invoke_cnode_def)
  apply (rule hoare_pre)
   apply (wp get_cap_wp | wpc | simp split del: if_split)+
  done

crunch valid_vspace_objs'[wp]: invoke_tcb "valid_vspace_objs'"
  (wp: check_cap_inv crunch_wps simp: crunch_simps
       ignore: check_cap_at)

lemma invoke_domain_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs'\<rbrace> invoke_domain t d \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  by (simp add: invoke_domain_def | wp)+

crunch valid_vspace_objs'[wp]: set_extra_badge, transfer_caps_loop "valid_vspace_objs'"
  (rule: transfer_caps_loop_pres)

crunch valid_vspace_objs'[wp]: send_ipc, send_signal,
    do_reply_transfer, invoke_irq_control, invoke_irq_handler "valid_vspace_objs'"
  (wp: crunch_wps simp: crunch_simps
         ignore: clearMemory const_on_failure set_object)

lemma valid_vspace_objs'_trans_state[simp]: "valid_vspace_objs' (trans_state f s) = valid_vspace_objs' s"
  apply (simp add: obj_valid_vspace_def)
  done

lemma retype_region_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs'\<rbrace> retype_region ptr bits o_bits type dev \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: retype_region_def split del: if_split)
  apply (wp | simp only: valid_vspace_objs'_trans_state trans_state_update[symmetric])+
  apply (clarsimp simp: retype_addrs_fold foldr_upd_app_if ranI
                 elim!: ranE split: if_split_asm simp del:fun_upd_apply)
  apply (simp add: default_object_def default_arch_object_def
            split: Structures_A.kernel_object.splits
    Structures_A.apiobject_type.split aobject_type.split)+
  done

lemma detype_valid_vspace[elim!]:
  "valid_vspace_objs' s \<Longrightarrow> valid_vspace_objs' (detype S s)"
  by (auto simp add: detype_def ran_def)

crunch valid_vspace_objs'[wp]: create_cap "valid_vspace_objs'"
  (ignore: clearMemory simp: crunch_simps)

lemma init_arch_objects_valid_vspace:
  "\<lbrace>valid_vspace_objs' and pspace_aligned and valid_arch_state
           and K (orefs = retype_addrs ptr type n us)
           and K (range_cover ptr sz (obj_bits_api type us) n)\<rbrace>
     init_arch_objects type ptr n obj_sz orefs
   \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (rule hoare_gen_asm)+
  apply (simp add: init_arch_objects_def)
  apply (rule hoare_pre)
   apply (wp | wpc)+
     apply (rule_tac Q="\<lambda>rv. valid_vspace_objs' and pspace_aligned and valid_arch_state"
                  in hoare_post_imp, simp)
     apply (rule mapM_x_wp')
     apply (rule hoare_pre, wp copy_global_mappings_valid_vspace_objs')
     apply clarsimp
     apply (drule retype_addrs_aligned[where sz = sz])
        apply (simp add:range_cover_def)
       apply (drule range_cover.sz,simp add:word_bits_def)
      apply (simp add:range_cover_def)
     apply (clarsimp simp:obj_bits_api_def bit_simps
       arch_kobj_size_def default_arch_object_def range_cover_def)+
  done

lemma delete_objects_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs'\<rbrace> delete_objects ptr bits \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  by (rule delete_objects_reduct) (wp detype_valid_vspace)

crunch valid_vspace_objs'[wp]: reset_untyped_cap "valid_vspace_objs'"
  (wp: mapME_x_inv_wp crunch_wps simp: crunch_simps unless_def)

lemma invoke_untyped_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and invs and ct_active
          and valid_untyped_inv ui\<rbrace>
       invoke_untyped ui
   \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (rule hoare_pre, rule invoke_untyped_Q)
      apply (wp init_arch_objects_valid_vspace | simp)+
     apply (auto simp: post_retype_invs_def split: if_split_asm)[1]
    apply (wp | simp)+
  done

crunch valid_vspace_objs'[wp]: perform_asid_pool_invocation,
     perform_asid_control_invocation "valid_vspace_objs'"
  (ignore: delete_objects set_object
       wp: static_imp_wp select_wp crunch_wps
     simp: crunch_simps unless_def)

lemma pte_range_interD:
 "pte_range pte p \<inter> pte_range pte' p' \<noteq> {}
  \<Longrightarrow> pte \<noteq> InvalidPTE \<and> pte' \<noteq> InvalidPTE
      \<and> p = p'"
  apply (drule int_not_emptyD)
  apply (case_tac pte,simp_all split:if_splits)
   apply (case_tac pte',simp_all split:if_splits)
  done

lemma pde_range_interD:
 "pde_range pde p \<inter> pde_range pde' p' \<noteq> {}
  \<Longrightarrow> pde \<noteq> InvalidPDE \<and> pde' \<noteq> InvalidPDE
      \<and> p = p'"
  apply (drule int_not_emptyD)
  apply (case_tac pde,simp_all split:if_splits)
     apply (case_tac pde',simp_all split:if_splits)
    apply (case_tac pde',simp_all split:if_splits)
  done

lemma pdpte_range_interD:
 "pdpte_range pdpte p \<inter> pdpte_range pdpte' p' \<noteq> {}
  \<Longrightarrow> pdpte \<noteq> InvalidPDPTE \<and> pdpte' \<noteq> InvalidPDPTE
      \<and> p = p'"
  apply (drule int_not_emptyD)
  apply (case_tac pdpte,simp_all split:if_splits)
     apply (case_tac pdpte',simp_all split:if_splits)
    apply (case_tac pdpte',simp_all split:if_splits)
  done

lemma pml4e_range_interD:
 "pml4e_range pml4e p \<inter> pml4e_range pml4e' p' \<noteq> {}
  \<Longrightarrow> pml4e \<noteq> InvalidPML4E \<and> pml4e' \<noteq> InvalidPML4E
      \<and> p = p'"
  apply (drule int_not_emptyD)
  apply (case_tac pml4e,simp_all split:if_splits)
     apply (case_tac pml4e',simp_all split:if_splits)
  done

lemma mask_pd_bits_shift_ucast_align[simp]:
  "is_aligned (ucast (p && mask pml4_bits >> word_size_bits)::9 word) 4 =
   is_aligned ((p::machine_word) >> word_size_bits) 4"
  by (clarsimp simp: is_aligned_mask mask_def bit_simps) word_bitwise

crunch valid_vspace_objs'[wp]: pte_check_if_mapped, pde_check_if_mapped "valid_vspace_objs'"

lemma perform_page_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and valid_page_inv pinv\<rbrace>
        perform_page_invocation pinv \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: perform_page_invocation_def )
  apply (cases pinv,
         simp_all add: mapM_discarded
            split: sum.split arch_cap.split option.split,
         safe intro!: hoare_gen_asm hoare_gen_asm[unfolded K_def],
         simp_all add: mapM_x_Nil mapM_x_Cons mapM_x_map)
            apply (wp store_pte_valid_vspace_objs' store_pde_valid_vspace_objs'
                      store_pdpte_valid_vspace_objs'
                      hoare_vcg_imp_lift[OF set_cap_arch_obj_neg] hoare_vcg_all_lift
                 | clarsimp simp: cte_wp_at_weakenE[OF _ TrueI] obj_at_def
                                  swp_def valid_page_inv_def perform_page_invocation_unmap_def
                                  valid_slots_def pte_check_if_mapped_def
                                  pde_check_if_mapped_def
                           split: pte.splits pde.splits
                 | wpc
                 | wp (once) hoare_drop_imps)+
  done

lemma perform_page_table_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and valid_pti pinv\<rbrace>
      perform_page_table_invocation pinv \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: perform_page_table_invocation_def split_def
             cong: page_table_invocation.case_cong
                   option.case_cong cap.case_cong arch_cap.case_cong)
  apply (rule hoare_pre)
   apply (wp hoare_vcg_ex_lift store_pde_valid_vspace_objs' store_pte_valid_vspace_objs'
             set_cap_arch_obj hoare_vcg_all_lift mapM_x_wp'
              | wpc
              | simp add: swp_def
              | strengthen all_imp_ko_at_from_ex_strg
              | wp (once) hoare_drop_imps)+
  done

lemma perform_page_directory_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and valid_pdi pinv\<rbrace>
      perform_page_directory_invocation pinv \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: perform_page_directory_invocation_def split_def
             cong: page_directory_invocation.case_cong
                   option.case_cong cap.case_cong arch_cap.case_cong)
  apply (rule hoare_pre)
   apply (wp hoare_vcg_ex_lift store_pde_valid_vspace_objs' store_pte_valid_vspace_objs'
             store_pdpte_valid_vspace_objs'
             set_cap_arch_obj hoare_vcg_all_lift mapM_x_wp'
              | wpc
              | simp add: swp_def
              | strengthen all_imp_ko_at_from_ex_strg
              | wp (once) hoare_drop_imps)+
  done

lemma perform_pdpt_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and valid_pdpti pinv\<rbrace>
      perform_pdpt_invocation pinv \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: perform_pdpt_invocation_def split_def
             cong: pdpt_invocation.case_cong
                   option.case_cong cap.case_cong arch_cap.case_cong)
  apply (rule hoare_pre)
   apply (wp hoare_vcg_ex_lift store_pde_valid_vspace_objs' store_pte_valid_vspace_objs'
             store_pdpte_valid_vspace_objs' store_pml4e_valid_vspace_objs'
             set_cap_arch_obj hoare_vcg_all_lift mapM_x_wp'
              | wpc
              | simp add: swp_def
              | strengthen all_imp_ko_at_from_ex_strg
              | wp (once) hoare_drop_imps)+
  done

crunch valid_vspace_objs'[wp]: perform_io_port_invocation, perform_ioport_control_invocation valid_vspace_objs'

lemma perform_invocation_valid_vspace_objs'[wp]:
  "\<lbrace>invs and ct_active and valid_invocation i and valid_vspace_objs'\<rbrace>
      perform_invocation blocking call i
         \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (cases i, simp_all)
  apply (wp send_signal_interrupt_states | simp)+
  apply (simp add: arch_perform_invocation_def)
  apply (wp | wpc | simp)+
  apply (auto simp: valid_arch_inv_def )
  done

crunch valid_vspace_objs'[wp]: handle_fault, reply_from_kernel "valid_vspace_objs'"
  (simp: crunch_simps wp: crunch_wps)

lemma handle_invocation_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and invs and ct_active\<rbrace>
        handle_invocation calling blocking \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (simp add: handle_invocation_def)
  apply (wp syscall_valid set_thread_state_ct_st
               | simp add: split_def | wpc
               | wp (once) hoare_drop_imps)+
  apply (auto simp: ct_in_state_def elim: st_tcb_ex_cap)
  done

crunch valid_vspace_objs'[wp]: activate_thread,switch_to_thread, handle_hypervisor_fault,
       switch_to_idle_thread, handle_call, handle_recv, handle_reply,
       handle_send, handle_yield, handle_interrupt "valid_vspace_objs'"
  (simp: crunch_simps wp: crunch_wps alternative_wp select_wp OR_choice_weak_wp select_ext_weak_wp
      ignore: without_preemption getActiveIRQ resetTimer ackInterrupt
              getFaultAddress OR_choice set_scheduler_action)

lemma handle_event_valid_vspace_objs'[wp]:
  "\<lbrace>valid_vspace_objs' and invs and ct_active\<rbrace> handle_event e \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
  apply (case_tac e; simp)
   by (wp | wpc | simp add: handle_vm_fault_def | wp (once) hoare_drop_imps)+

lemma schedule_valid_vspace_objs'[wp]: "\<lbrace>valid_vspace_objs'\<rbrace> schedule :: (unit,unit) s_monad \<lbrace>\<lambda>_. valid_vspace_objs'\<rbrace>"
  apply (simp add: schedule_def allActiveTCBs_def)
  apply (wp alternative_wp select_wp)
  apply simp
  done

lemma call_kernel_valid_vspace_objs'[wp]:
  "\<lbrace>invs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_running s) and valid_vspace_objs'\<rbrace>
      (call_kernel e) :: (unit,unit) s_monad
   \<lbrace>\<lambda>_. valid_vspace_objs'\<rbrace>"
  apply (cases e, simp_all add: call_kernel_def)
      apply (rule hoare_pre)
       apply (wp | simp add: handle_vm_fault_def | wpc
                 | rule conjI | clarsimp simp: ct_in_state_def
                 | erule pred_tcb_weakenE
                 | wp (once) hoare_drop_imps)+
  done

end

end


text {* Temporary code. *}

theory Tmp
  imports Main
begin

text {* An input for the execution is the sequence of instructions ordered by
how the processor issues the instructions. This is also the order of the instructions
in the program control-flow at the software level. *}

type_synonym proc_instr_order = "(proc \<times> (instruction list))"

text {* In our memory model, we separate the instructions SWAP and CASA to two parts.
Their atomicity is handled by the memory model.
We need to pre-process the sequence of instructions and separate them before execution. *}

primrec pre_proc_instr:: "instruction list \<Rightarrow> instruction list" where
"pre_proc_instr [] = []"
|"pre_proc_instr (x#xs) = (case (fst x) of
  load_store_type SWAP \<Rightarrow> [(load_store_type SWAP_L, snd x)]@[(load_store_type SWAP_S, snd x)]@
                          (pre_proc_instr xs)
 |load_store_type CASA \<Rightarrow> [(load_store_type CASA_L, snd x)]@[(load_store_type CASA_S, snd x)]@
                          (pre_proc_instr xs)
 |_ \<Rightarrow> x#(pre_proc_instr xs))"

text {* Get the last instruction of the mem_op_block. *}

definition last_op_of_mem_op_block:: "mem_op_block \<Rightarrow> instruction option" where
"last_op_of_mem_op_block b \<equiv> if inst b = [] then None else Some (List.last (inst b))"

text {* Get the processor of the mem_op_block. *}

definition proc_of_mem_op_block:: "mem_op_block \<Rightarrow> proc" where
"proc_of_mem_op_block b \<equiv> pr b"

text {* Add an instruction in a block. *}

definition block_add:: "instruction \<Rightarrow> mem_op_block \<Rightarrow> mem_op_block" where
"block_add instr b \<equiv> b\<lparr>inst := (inst b)@[instr]\<rparr>"

text {* The function below converts a list of instructions in an execution
instance into a list of mem_op_block, where each mem_op_block contains at most
one memory access instructions which must be the last instruction of the block.
We also add a unique number to identify each block. *}

primrec blockify :: "instruction list \<Rightarrow> nat \<Rightarrow> mem_op_block list \<Rightarrow> (nat \<times> mem_op_block list)" where
"blockify [] n acc = (if inst (List.last acc) = [] then ((Suc n), List.butlast acc)
  else ((Suc n),acc))"
|"blockify (x#xs) n acc = (case (fst x) of
  load_store_type lsi \<Rightarrow> blockify xs (Suc n) ((List.butlast acc)@
    [block_add x (List.last acc)]@[emp_mem_op_block\<lparr>id := (Suc n)\<rparr>\<lparr>pr := (pr (List.last acc))\<rparr>])
 |_ \<Rightarrow> blockify xs n ((List.butlast acc)@[block_add x (List.last acc)]))"

text {* A wrapper for executing a mem_op_block. *}

definition execute_block:: "proc \<Rightarrow> mem_op_block \<Rightarrow> virtual_address option \<Rightarrow> memory_value option \<Rightarrow>
 sparc_state \<Rightarrow> (sparc_state \<times> virtual_address option \<times> memory_value option)" where
"execute_block p b a v s \<equiv> sequential_execution p (inst b) a v s"

text {* Given a list of proc_instr_order (one list per processor),
return all the program orders (one list per processor). *}

primrec get_program_order_list :: "proc_instr_order list \<Rightarrow> nat \<Rightarrow> program_order \<Rightarrow>
  program_order" where
"get_program_order_list [] n po = po"
|"get_program_order_list (x#xs) n po = (
  let (nn,nb) = blockify (snd x) n [emp_mem_op_block\<lparr>id := n, pr := (fst x)\<rparr>] in
  get_program_order_list xs nn (po((fst x) := nb)))"

text {* Given the list of instruction sequences of all processors, return
the list of all program orders for all processors. *}

definition get_program_order:: "proc_instr_order list \<Rightarrow> program_order" where
"get_program_order instr_list \<equiv> get_program_order_list instr_list 0 emp_program_order"

text {* Given a sequence of mem_op_block, and a sequence of executed mem_op_block.
Check if all loads in the former list are already executed. *}

primrec all_loads_executed:: "mem_op_block list \<Rightarrow> mem_op_block list \<Rightarrow> bool" where
"all_loads_executed [] xseq = True"
|"all_loads_executed (x#xs) xseq = (case last_op_of_mem_op_block x of
  Some ((load_store_type LD),_) \<Rightarrow> if List.member xseq x then all_loads_executed xs xseq else False
  |Some ((load_store_type SWAP_L),_) \<Rightarrow> if List.member xseq x then all_loads_executed xs xseq else False
  |Some ((load_store_type CASA_L),_) \<Rightarrow> if List.member xseq x then all_loads_executed xs xseq else False
  |_ \<Rightarrow> all_loads_executed xs xseq)"

text {* Given a mem_op_block b, all the program orders, a sequence of executed mem_op_block,
check if all load ops issued by the same processor before b are executed. *}

definition all_loads_before_executed:: "mem_op_block \<Rightarrow> program_order \<Rightarrow> mem_op_block list \<Rightarrow>
  bool" where
"all_loads_before_executed b po xseq \<equiv>
  all_loads_executed (sub_list_before b (po (proc_of_mem_op_block b))) xseq"

text {* Given a sequence of mem_op_block, and a sequence of executed mem_op_block.
Check if all stores in the former list are already executed. *}

primrec all_stores_executed:: "mem_op_block list \<Rightarrow> mem_op_block list \<Rightarrow> bool" where
"all_stores_executed [] xseq = True"
|"all_stores_executed (x#xs) xseq = (case last_op_of_mem_op_block x of
  Some ((load_store_type ST),_) \<Rightarrow> if List.member xseq x then all_stores_executed xs xseq else False
  |Some ((load_store_type SWAP_S),_) \<Rightarrow> if List.member xseq x then all_stores_executed xs xseq else False
  |Some ((load_store_type CASA_S),_) \<Rightarrow> if List.member xseq x then all_stores_executed xs xseq else False
  |_ \<Rightarrow> all_stores_executed xs xseq)"

text {* Given a mem_op_block b, all the program orders, a sequence of executed mem_op_block,
check if all store ops issued by the same processor before b are executed. *}

definition all_stores_before_executed:: "mem_op_block \<Rightarrow> program_order \<Rightarrow> mem_op_block list \<Rightarrow>
  bool" where
"all_stores_before_executed b po xseq \<equiv>
  all_stores_executed (sub_list_before b (po (proc_of_mem_op_block b))) xseq"

section {* This section defines an operational TSO memory model. *}

text {* The sequence of executed meomry operation blocks. *}

type_synonym executed_mem_ops = "op_id list"

text {* Given a sequence of executed mem_op_block, the memory order op1 m< op2 is
true when op1 is in the sequence before op2.
If both are not in the sequence, the result is None.
If one of them is not in the sequence, then it is later than the one
that occurs in the sequence.  *}

definition memory_order_before:: "op_id \<Rightarrow> executed_mem_ops \<Rightarrow> op_id \<Rightarrow>
  bool option" ("_ m<_ _") where
"op1 m<xseq op2 \<equiv>
  if (List.member xseq op1) \<and> (List.member xseq op2) then
    if list_pos op1 xseq < list_pos op2 xseq then Some True
    else Some False
  else if List.member xseq op1 then Some True
  else if List.member xseq op2 then Some False
  else None"

text {* Given an address and the executed sequence of mem_op_block ids, return
the id of the first store in the executed sequence at the same address.
If there are none, return None.
N.B. We could formulate the below functions more mathematically (i.e., using sets
and first-order logic), but we choose the define it in a more operational way
for performance reasons. *}

primrec get_first_store:: "virtual_address \<Rightarrow> op_id list \<Rightarrow> sparc_state \<Rightarrow> op_id option" where
"get_first_store addr [] state = None"
|"get_first_store addr (x#xs) state = (
  if Some addr = (op_addr (mem_op_val x state)) \<and>
     type_of_mem_op_block (mem_op_val x state) \<in> {st_block, ast_block}
  then
    Some x
  else get_first_store addr xs state)"

definition mem_most_recent_store:: "virtual_address \<Rightarrow> executed_mem_ops \<Rightarrow> sparc_state \<Rightarrow>
  op_id option" where
"mem_most_recent_store addr xseq state \<equiv> get_first_store addr (List.rev xseq) state"

text {* Given a load operation id and the program order, return the id of most recent
store at the same address in the program order that is before the load.
If there are none, return None. *}

definition proc_most_recent_store:: "proc \<Rightarrow> virtual_address \<Rightarrow> op_id \<Rightarrow> program_order \<Rightarrow>
  sparc_state \<Rightarrow> op_id option" where
"proc_most_recent_store p addr opid po state \<equiv>
  get_first_store addr (List.rev (sub_list_before opid (po p))) state"

text {* The value of the load operation based on the axiom value. *}

definition load_value:: "proc \<Rightarrow> virtual_address \<Rightarrow> op_id \<Rightarrow> program_order \<Rightarrow> executed_mem_ops \<Rightarrow> sparc_state \<Rightarrow>
  memory_value option" where
"load_value p addr opid po xseq state \<equiv>
  case ((mem_most_recent_store addr xseq state),(proc_most_recent_store p addr opid po state)) of
  (Some s1, Some s2) \<Rightarrow> (case (s1 m<xseq s2) of
    Some True \<Rightarrow> op_val (mem_op_val s2 state)
    |Some False \<Rightarrow> op_val (mem_op_val s1 state)
    |None \<Rightarrow> None)
  |(None, Some s2) \<Rightarrow> op_val (mem_op_val s2 state)
  |(Some s1, None) \<Rightarrow> op_val (mem_op_val s1 state)
  |(None, None) \<Rightarrow> None"

text {* Given (1) the program order, (2) a list of executed mem_op_block ids,
(3) a list of remaining (not executed) mem_op_block.
Return a list of all possible (under TSO) new list of executed mem_op_block, each item
in the resultant list is an extension of (2),
and the corresponding remaining mem_op_block,
and the corresponding states. *}

primrec tso_exe_step:: "program_order \<Rightarrow> executed_mem_ops \<Rightarrow> op_id list \<Rightarrow>
  sparc_state \<Rightarrow> (executed_mem_ops \<times> (op_id list) \<times> sparc_state) list" where
"tso_exe_step po xseq [] state = []"
|"tso_exe_step po xseq (x#xs) state = (
  let p = proc_of_op x state in
  case type_of_mem_op_block (mem_op_val x state) of
  ld_block \<Rightarrow>
    if \<forall>opid. (((opid ;po^p x) \<and>
                (type_of_mem_op_block (mem_op_val opid state) \<in> {ld_block, ald_block})) \<longrightarrow>
               (List.member xseq opid))
    then (* x can be executed. *)
      let addr = load_addr p (List.last (insts (mem_op_val x state))) state;
          vop = load_value p addr x po xseq state
      in
      [(xseq@[x], xs, (proc_exe_to p po (nat (list_pos x (po p))) vop (Some addr) state))]@
      (tso_exe_step po xseq xs state)
    else tso_exe_step po xseq xs state (* x can't be executed. *)
  |st_block \<Rightarrow>
    if (atomic_flag_val state) = False \<and>
       (\<forall>opid. (((opid ;po^p x) \<and>
                (type_of_mem_op_block (mem_op_val opid state) \<in> {ld_block, ald_block, st_block, ast_block})) \<longrightarrow>
               (List.member xseq opid)))
    then (* x can be executed. *)
      [(xseq@[x], xs, (proc_exe_to p po (nat (list_pos x (po p))) None None state))]@
      (tso_exe_step po xseq xs state)
    else tso_exe_step po xseq xs state (* x can't be executed. *)
  |ald_block \<Rightarrow>
    if (atomic_flag_val state) = False \<and>
       (\<forall>opid. (((opid ;po^p x) \<and>
                (type_of_mem_op_block (mem_op_val opid state) \<in> {ld_block, ald_block, st_block, ast_block})) \<longrightarrow>
               (List.member xseq opid)))
    then (* x can be executed. *)
      let addr = atomic_load_addr p (List.last (insts (mem_op_val x state))) state;
          vop = load_value p addr x po xseq state;
          state1 = atomic_flag_mod True state
      in
      [(xseq@[x], xs, (proc_exe_to p po (nat (list_pos x (po p))) vop (Some addr) state1))]@
      (tso_exe_step po xseq xs state1)
    else tso_exe_step po xseq xs state (* x can't be executed. *)
  |ast_block \<Rightarrow>
    if (atomic_flag_val state) = True \<and>
       (\<forall>opid. (((opid ;po^p x) \<and>
                (type_of_mem_op_block (mem_op_val opid state) \<in> {ld_block, ald_block, st_block, ast_block})) \<longrightarrow>
               (List.member xseq opid)))
    then (* x can be executed. *)
      let state1 = atomic_flag_mod False state in
      [(xseq@[x], xs, (proc_exe_to p po (nat (list_pos x (po p))) None None state1))]@
      (tso_exe_step po xseq xs state1)
    else tso_exe_step po xseq xs state (* x can't be executed. *)
  |o_block \<Rightarrow>
    [(xseq@[x], xs, (proc_exe_to p po (nat (list_pos x (po p))) None None state))]@
    (tso_exe_step po xseq xs state))"

primrec tso_exe_1round:: "program_order \<Rightarrow> (executed_mem_ops \<times> (op_id list) \<times> sparc_state) list \<Rightarrow>
  (executed_mem_ops \<times> (op_id list) \<times> sparc_state) list" where
"tso_exe_1round po [] = []"
|"tso_exe_1round po (x#xs) =
  (tso_exe_step po (fst x) (fst (snd x)) (snd (snd x)))@(tso_exe_1round po xs)"

definition "tso_exe_all = undefined (* Executed tso_exe_1round until each item in the list has its
executed_mem_ops containing all ops in program_order. *)"

text {* Given an element, find it's position in the list. Return -1
if it's not in the list. *}

primrec find_elem_list:: "'a \<Rightarrow> 'a list \<Rightarrow> int \<Rightarrow> int" where
"find_elem_list e [] i = -1"
|"find_elem_list e (x#xs) i = (if e = x then i else find_elem_list e xs (i+1))"

definition list_pos:: "'a \<Rightarrow> 'a list \<Rightarrow> int" where
"list_pos e l \<equiv> find_elem_list e l 0"

lemma pos_range: "List.member l x \<Longrightarrow> 0 \<le> list_pos x l \<and> nat (list_pos x l) < List.length l"
proof (induction l arbitrary: x)
  case Nil
  then show ?case
    using member_rec(2) by fastforce
next
  case (Cons a l)
  then show ?case
  proof (cases "List.member l x")
    case True
    then have "0 \<le> list_pos x l \<and> nat (list_pos x l) < length l"
      using Cons by auto
    then show ?thesis

  next
    case False
    then show ?thesis sorry
  qed
qed

lemma pos_unique: "non_repeat_list l \<Longrightarrow> List.member l x \<Longrightarrow> List.member l x' \<Longrightarrow>
  x \<noteq> x' \<Longrightarrow> list_pos x l \<noteq> list_pos x' l"
proof (induction l arbitrary: x x')
  case Nil
  then show ?case
    using member_rec(2) by fastforce
next
  case (Cons a l)
  then show ?case sorry
qed

end


theory HO_ontological_arg
imports Main
begin

(*
"Mechanized Analysis Of a Formalization of Anselm’s Ontological Argument by Eder and Ramharter"
John Rushby

http://www.csl.sri.com/users/rushby/papers/er-ontarg.pdf

Figure 3: Higher-Order Version of the Argument in PVS

HO_ontological_arg: THEORY
BEGIN
U_beings: TYPE
x, y: VAR U_beings
re?: pred[U_beings]
P: set[ pred[U_beings] ]
F: VAR (P)
>(x, y): bool = (FORALL F: F(y) => F(x)) & (EXISTS F: F(x) AND NOT F(y))
God?(x): bool = NOT EXISTS y: y > x
ExUnd: AXIOM EXISTS x: God?(x)
Realization: AXIOM
FORALL (FF:setof[(P)]): EXISTS x: FORALL F: FF(F) = F(x)
God_re: THEOREM member(re?, P) => EXISTS x: God?(x) AND re?(x)
END HO_ontological_arg

*)

definition mygreater :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "mygreater x y \<equiv> (\<forall>F. F y \<longrightarrow> F x) \<and> (\<exists> F. F x \<and> \<not> F y)"

text\<open>Let's write down explicitly that @{term F} really is the set of all predicates.\<close>
lemma mygreater_explicit_typtes:
  "mygreater x y \<longleftrightarrow>
    (\<forall>F \<in> (UNIV :: ('a \<Rightarrow> bool) set). F y \<longrightarrow> F x) \<and> (\<exists> F \<in> (UNIV :: ('a \<Rightarrow> bool) set). F x \<and> \<not> F y)"
  by(simp add: mygreater_def)

definition God :: "'a \<Rightarrow> bool" where
  "God x \<equiv> \<not> (\<exists>y. mygreater y x)"

lemma allGod: "God x"
  unfolding God_def
  apply(simp add: mygreater_def)
  by fast

corollary "\<forall>x. God x" using allGod by blast

lemma trans: "mygreater x y \<Longrightarrow> mygreater y z \<Longrightarrow> mygreater x z"
  apply(simp add: mygreater_def)
  by meson

lemma eq: "mygreater x y \<longleftrightarrow> mygreater y x"
  apply(simp add: mygreater_def)
  by fast

lemma comparable: "mygreater x y \<Longrightarrow> False"
  by (meson God_def allGod)

lemma "\<exists>tea coffee. mygreater tea coffee \<Longrightarrow> \<forall>god. \<not> god"
  using comparable by fast

text\<open>Of course, the whole theory is just a blank abuse of the @{const mygreater} definition used
     out of context. Not to be taken seriously.\<close>
end


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

header{*The n_mutualExDeadFree Protocol Case Study*}

theory n_mutualExDeadFree_lemma_inv__3_on_rules imports n_mutualExDeadFree_lemma_on_inv__3
begin
section{*All lemmas on causal relation between inv__3*}
lemma lemma_inv__3_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__3  p__Inv0 p__Inv1)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__3) done
    }

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

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

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

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

end


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

header{*The n_mutualExDeadFree Protocol Case Study*}

theory n_mutualExDeadFree_lemma_inv__6_on_rules imports n_mutualExDeadFree_lemma_on_inv__6
begin
section{*All lemmas on causal relation between inv__6*}
lemma lemma_inv__6_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__6  p__Inv0 p__Inv1)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__6) done
    }

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

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

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

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

end


theory Tagged_Packet
imports Simple_Firewall.Simple_Packet Conntrack_State
begin

section\<open>Tagged Simple Packet\<close>
  text\<open>Packet constants are prefixed with \<open>p\<close>\<close>

  text\<open>A packet tagged with the following phantom fields:
             conntrack connection state\<close>

  text\<open>The idea to tag the connection state into the packet is sound.
       See @{file \<open>../Semantics_Stateful.thy\<close>}\<close>

  record (overloaded) 'i tagged_packet = "'i::len simple_packet" +
                         p_tag_ctstate :: ctstate

  value "\<lparr>
          p_iiface = ''eth1'', p_oiface = '''',
          p_src = 0, p_dst = 0,
          p_proto = TCP, p_sport = 0, p_dport = 0,
          p_tcp_flags = {TCP_SYN},
          p_payload = ''arbitrary payload'',
          p_tag_ctstate = CT_New
         \<rparr>:: 32 tagged_packet"

  definition simple_packet_tag
    :: "ctstate \<Rightarrow> ('i::len, 'a) simple_packet_scheme \<Rightarrow> ('i::len, 'a) tagged_packet_scheme" where
    "simple_packet_tag ct_state p \<equiv>
      \<lparr>p_iiface = p_iiface p, p_oiface = p_oiface p, p_src = p_src p, p_dst = p_dst p, p_proto = p_proto p,
       p_sport = p_sport p, p_dport = p_dport p, p_tcp_flags = p_tcp_flags p,
       p_payload = p_payload p,
       p_tag_ctstate = ct_state,
       \<dots> = simple_packet.more p\<rparr>"

  definition tagged_packet_untag
    :: "('i::len, 'a) tagged_packet_scheme \<Rightarrow> ('i::len, 'a) simple_packet_scheme" where
    "tagged_packet_untag p \<equiv>
      \<lparr>p_iiface = p_iiface p, p_oiface = p_oiface p, p_src = p_src p, p_dst = p_dst p, p_proto = p_proto p,
       p_sport = p_sport p, p_dport = p_dport p, p_tcp_flags = p_tcp_flags p,
       p_payload = p_payload p,
       \<dots> = tagged_packet.more p\<rparr>"

  lemma "tagged_packet_untag (simple_packet_tag ct_state p) = p"
        "simple_packet_tag ct_state (tagged_packet_untag p) = p\<lparr>p_tag_ctstate := ct_state\<rparr>"
    apply(case_tac [!] p)
     by(simp add: tagged_packet_untag_def simple_packet_tag_def)+

end


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

header{*The n_germanSymIndex Protocol Case Study*}

theory n_germanSymIndex_lemma_invs_on_rules imports n_germanSymIndex_lemma_inv__1_on_rules n_germanSymIndex_lemma_inv__2_on_rules n_germanSymIndex_lemma_inv__3_on_rules n_germanSymIndex_lemma_inv__4_on_rules n_germanSymIndex_lemma_inv__5_on_rules n_germanSymIndex_lemma_inv__6_on_rules n_germanSymIndex_lemma_inv__7_on_rules n_germanSymIndex_lemma_inv__8_on_rules n_germanSymIndex_lemma_inv__9_on_rules n_germanSymIndex_lemma_inv__10_on_rules n_germanSymIndex_lemma_inv__11_on_rules n_germanSymIndex_lemma_inv__12_on_rules n_germanSymIndex_lemma_inv__13_on_rules n_germanSymIndex_lemma_inv__14_on_rules n_germanSymIndex_lemma_inv__15_on_rules n_germanSymIndex_lemma_inv__16_on_rules n_germanSymIndex_lemma_inv__17_on_rules n_germanSymIndex_lemma_inv__18_on_rules n_germanSymIndex_lemma_inv__19_on_rules n_germanSymIndex_lemma_inv__20_on_rules n_germanSymIndex_lemma_inv__21_on_rules n_germanSymIndex_lemma_inv__22_on_rules n_germanSymIndex_lemma_inv__23_on_rules n_germanSymIndex_lemma_inv__24_on_rules n_germanSymIndex_lemma_inv__25_on_rules n_germanSymIndex_lemma_inv__26_on_rules n_germanSymIndex_lemma_inv__27_on_rules n_germanSymIndex_lemma_inv__28_on_rules n_germanSymIndex_lemma_inv__29_on_rules n_germanSymIndex_lemma_inv__30_on_rules n_germanSymIndex_lemma_inv__31_on_rules n_germanSymIndex_lemma_inv__32_on_rules n_germanSymIndex_lemma_inv__33_on_rules n_germanSymIndex_lemma_inv__34_on_rules n_germanSymIndex_lemma_inv__35_on_rules n_germanSymIndex_lemma_inv__36_on_rules n_germanSymIndex_lemma_inv__37_on_rules n_germanSymIndex_lemma_inv__38_on_rules n_germanSymIndex_lemma_inv__39_on_rules n_germanSymIndex_lemma_inv__40_on_rules n_germanSymIndex_lemma_inv__41_on_rules n_germanSymIndex_lemma_inv__42_on_rules n_germanSymIndex_lemma_inv__43_on_rules n_germanSymIndex_lemma_inv__44_on_rules n_germanSymIndex_lemma_inv__45_on_rules n_germanSymIndex_lemma_inv__46_on_rules n_germanSymIndex_lemma_inv__47_on_rules n_germanSymIndex_lemma_inv__48_on_rules n_germanSymIndex_lemma_inv__49_on_rules n_germanSymIndex_lemma_inv__50_on_rules n_germanSymIndex_lemma_inv__51_on_rules n_germanSymIndex_lemma_inv__52_on_rules
begin
lemma invs_on_rules:
  assumes a1: "f \<in> invariants N" and a2: "r \<in> rules N"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have b1: "(\<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>
    (f=inv__3  )\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__4  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__5  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__6  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__7  p__Inv0 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__8  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__9  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__10  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__11  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__12  p__Inv0 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__13  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__14  p__Inv0 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__15  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__16  p__Inv0 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__17  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__18  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__19  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__20  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__21  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__22  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__23  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__24  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__25  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__26  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__27  p__Inv0 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__29  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__30  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__31  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__32  p__Inv0 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__33  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__34  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__35  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__36  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__37  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__38  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__39  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__40  p__Inv0 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__41  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__42  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__43  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__44  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__45  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__46  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__47  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__48  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__49  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__50  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__51  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__52  p__Inv0 p__Inv2)"
  apply (cut_tac a1, auto) done
    moreover {
      assume 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)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__1_on_rules) done
    }

    moreover {
      assume c1: "(\<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 "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__2_on_rules) done
    }

    moreover {
      assume c1: "(f=inv__3  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__3_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__4  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__4_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__5_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__6  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__6_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__7  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__7_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__8  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__8_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__9  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__9_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__10  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__10_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__11  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__11_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__12  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__12_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__13  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__13_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__14  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__14_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__15  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__15_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__16  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__16_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__17  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__17_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__18  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__18_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__19  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__19_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__20  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__20_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__21  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__21_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__22  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__22_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__23  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__23_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__24  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__24_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__25  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__25_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__26  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__26_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__27  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__27_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__28_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__29  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__29_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__30  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__30_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__31  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__31_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__32  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__32_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__33  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__33_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__34  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__34_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__35  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__35_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__36  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__36_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__37  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__37_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__38  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__38_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__39  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__39_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__40  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__40_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__41  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__41_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__42  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__42_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__43  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__43_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__44  p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__44_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__45  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__45_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__46  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__46_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__47  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__47_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__48  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__48_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__49_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__50_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__51  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__51_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__52  p__Inv0 p__Inv2)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__52_on_rules) done
    }

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

end


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

header{*The n_mutualExOnI Protocol Case Study*}

theory n_mutualExOnI_lemma_invs_on_rules imports n_mutualExOnI_lemma_inv__1_on_rules n_mutualExOnI_lemma_inv__2_on_rules n_mutualExOnI_lemma_inv__3_on_rules n_mutualExOnI_lemma_inv__4_on_rules
begin
lemma invs_on_rules:
  assumes a1: "f \<in> invariants N" and a2: "r \<in> rules N"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have b1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__1  p__Inv0 p__Inv1)\<or>
    (\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__2  p__Inv0 p__Inv1)\<or>
    (\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__3  p__Inv0 p__Inv1)\<or>
    (\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__4  p__Inv0 p__Inv1)"
  apply (cut_tac a1, auto) done
    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__1  p__Inv0 p__Inv1)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__1_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__2  p__Inv0 p__Inv1)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__2_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__3  p__Inv0 p__Inv1)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__3_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__4  p__Inv0 p__Inv1)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__4_on_rules) done
    }

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

end


(*  Title:      HOL/MicroJava/J/Conform.thy
    Author:     David von Oheimb
    Copyright   1999 Technische Universitaet Muenchen
*)

section \<open>Conformity Relations for Type Soundness Proof\<close>

theory Conform imports State WellType Exceptions begin

type_synonym 'c env' = "'c prog \<times> (vname \<rightharpoonup> ty)"  \<comment> \<open>same as \<open>env\<close> of \<open>WellType.thy\<close>\<close>

definition hext :: "aheap => aheap => bool" ("_ \<le>| _" [51,51] 50) where
 "h\<le>|h' == \<forall>a C fs. h a = Some(C,fs) --> (\<exists>fs'. h' a = Some(C,fs'))"

definition conf :: "'c prog => aheap => val => ty => bool"
                                   ("_,_ \<turnstile> _ ::\<preceq> _"  [51,51,51,51] 50) where
 "G,h\<turnstile>v::\<preceq>T == \<exists>T'. typeof (map_option obj_ty o h) v = Some T' \<and> G\<turnstile>T'\<preceq>T"

definition lconf :: "'c prog => aheap => ('a \<rightharpoonup> val) => ('a \<rightharpoonup> ty) => bool"
                                   ("_,_ \<turnstile> _ [::\<preceq>] _" [51,51,51,51] 50) where
 "G,h\<turnstile>vs[::\<preceq>]Ts == \<forall>n T. Ts n = Some T --> (\<exists>v. vs n = Some v \<and> G,h\<turnstile>v::\<preceq>T)"

definition oconf :: "'c prog => aheap => obj => bool" ("_,_ \<turnstile> _ \<surd>" [51,51,51] 50) where
 "G,h\<turnstile>obj \<surd> == G,h\<turnstile>snd obj[::\<preceq>]map_of (fields (G,fst obj))"

definition hconf :: "'c prog => aheap => bool" ("_ \<turnstile>h _ \<surd>" [51,51] 50) where
 "G\<turnstile>h h \<surd>    == \<forall>a obj. h a = Some obj --> G,h\<turnstile>obj \<surd>"

definition xconf :: "aheap \<Rightarrow> val option \<Rightarrow> bool" where
  "xconf hp vo  == preallocated hp \<and> (\<forall> v. (vo = Some v) \<longrightarrow> (\<exists> xc. v = (Addr (XcptRef xc))))"

definition conforms :: "xstate => java_mb env' => bool" ("_ ::\<preceq> _" [51,51] 50) where
 "s::\<preceq>E == prg E\<turnstile>h heap (store s) \<surd> \<and>
            prg E,heap (store s)\<turnstile>locals (store s)[::\<preceq>]localT E \<and>
            xconf (heap (store s)) (abrupt s)"

subsection "hext"

lemma hextI:
" \<forall>a C fs . h  a = Some (C,fs) -->
      (\<exists>fs'. h' a = Some (C,fs')) ==> h\<le>|h'"
apply (unfold hext_def)
apply auto
done

lemma hext_objD: "[|h\<le>|h'; h a = Some (C,fs) |] ==> \<exists>fs'. h' a = Some (C,fs')"
apply (unfold hext_def)
apply (force)
done

lemma hext_refl [simp]: "h\<le>|h"
apply (rule hextI)
apply (fast)
done

lemma hext_new [simp]: "h a = None ==> h\<le>|h(a\<mapsto>x)"
apply (rule hextI)
apply auto
done

lemma hext_trans: "[|h\<le>|h'; h'\<le>|h''|] ==> h\<le>|h''"
apply (rule hextI)
apply (fast dest: hext_objD)
done

lemma hext_upd_obj: "h a = Some (C,fs) ==> h\<le>|h(a\<mapsto>(C,fs'))"
apply (rule hextI)
apply auto
done

subsection "conf"

lemma conf_Null [simp]: "G,h\<turnstile>Null::\<preceq>T = G\<turnstile>RefT NullT\<preceq>T"
apply (unfold conf_def)
apply (simp (no_asm))
done

lemma conf_litval [rule_format (no_asm), simp]:
  "typeof (\<lambda>v. None) v = Some T --> G,h\<turnstile>v::\<preceq>T"
apply (unfold conf_def)
apply (rule val.induct)
apply auto
done

lemma conf_AddrI: "[|h a = Some obj; G\<turnstile>obj_ty obj\<preceq>T|] ==> G,h\<turnstile>Addr a::\<preceq>T"
apply (unfold conf_def)
apply (simp)
done

lemma conf_obj_AddrI: "[|h a = Some (C,fs); G\<turnstile>C\<preceq>C D|] ==> G,h\<turnstile>Addr a::\<preceq> Class D"
apply (unfold conf_def)
apply (simp)
done

lemma defval_conf [rule_format (no_asm)]:
  "is_type G T --> G,h\<turnstile>default_val T::\<preceq>T"
apply (unfold conf_def)
apply (rule_tac y = "T" in ty.exhaust)
apply  (erule ssubst)
apply  (rename_tac prim_ty, rule_tac y = "prim_ty" in prim_ty.exhaust)
apply    (auto simp add: widen.null)
done

lemma conf_upd_obj:
"h a = Some (C,fs) ==> (G,h(a\<mapsto>(C,fs'))\<turnstile>x::\<preceq>T) = (G,h\<turnstile>x::\<preceq>T)"
apply (unfold conf_def)
apply (rule val.induct)
apply auto
done

lemma conf_widen [rule_format (no_asm)]:
  "wf_prog wf_mb G ==> G,h\<turnstile>x::\<preceq>T --> G\<turnstile>T\<preceq>T' --> G,h\<turnstile>x::\<preceq>T'"
apply (unfold conf_def)
apply (rule val.induct)
apply (auto intro: widen_trans)
done

lemma conf_hext [rule_format (no_asm)]: "h\<le>|h' ==> G,h\<turnstile>v::\<preceq>T --> G,h'\<turnstile>v::\<preceq>T"
apply (unfold conf_def)
apply (rule val.induct)
apply (auto dest: hext_objD)
done

lemma new_locD: "[|h a = None; G,h\<turnstile>Addr t::\<preceq>T|] ==> t\<noteq>a"
apply (unfold conf_def)
apply auto
done

lemma conf_RefTD [rule_format]:
 "G,h\<turnstile>a'::\<preceq>RefT T \<Longrightarrow> a' = Null \<or>
  (\<exists>a obj T'. a' = Addr a \<and>  h a = Some obj \<and>  obj_ty obj = T' \<and>  G\<turnstile>T'\<preceq>RefT T)"
unfolding conf_def by (induct a') auto

lemma conf_NullTD: "G,h\<turnstile>a'::\<preceq>RefT NullT ==> a' = Null"
apply (drule conf_RefTD)
apply auto
done

lemma non_npD: "[|a' \<noteq> Null; G,h\<turnstile>a'::\<preceq>RefT t|] ==>
  \<exists>a C fs. a' = Addr a \<and>  h a = Some (C,fs) \<and>  G\<turnstile>Class C\<preceq>RefT t"
apply (drule conf_RefTD)
apply auto
done

lemma non_np_objD: "!!G. [|a' \<noteq> Null; G,h\<turnstile>a'::\<preceq> Class C|] ==>
  (\<exists>a C' fs. a' = Addr a \<and>  h a = Some (C',fs) \<and>  G\<turnstile>C'\<preceq>C C)"
apply (fast dest: non_npD)
done

lemma non_np_objD' [rule_format (no_asm)]:
  "a' \<noteq> Null ==> wf_prog wf_mb G ==> G,h\<turnstile>a'::\<preceq>RefT t -->
  (\<exists>a C fs. a' = Addr a \<and>  h a = Some (C,fs) \<and>  G\<turnstile>Class C\<preceq>RefT t)"
apply(rule_tac y = "t" in ref_ty.exhaust)
 apply (fast dest: conf_NullTD)
apply (fast dest: non_np_objD)
done

lemma conf_list_gext_widen [rule_format (no_asm)]:
  "wf_prog wf_mb G ==> \<forall>Ts Ts'. list_all2 (conf G h) vs Ts -->
  list_all2 (\<lambda>T T'. G\<turnstile>T\<preceq>T') Ts Ts' -->  list_all2 (conf G h) vs Ts'"
apply(induct_tac "vs")
 apply(clarsimp)
apply(clarsimp)
apply(frule list_all2_lengthD [symmetric])
apply(simp (no_asm_use) add: length_Suc_conv)
apply(safe)
apply(frule list_all2_lengthD [symmetric])
apply(simp (no_asm_use) add: length_Suc_conv)
apply(clarify)
apply(fast elim: conf_widen)
done

subsection "lconf"

lemma lconfD: "[| G,h\<turnstile>vs[::\<preceq>]Ts; Ts n = Some T |] ==> G,h\<turnstile>(the (vs n))::\<preceq>T"
apply (unfold lconf_def)
apply (force)
done

lemma lconf_hext [elim]: "[| G,h\<turnstile>l[::\<preceq>]L; h\<le>|h' |] ==> G,h'\<turnstile>l[::\<preceq>]L"
apply (unfold lconf_def)
apply  (fast elim: conf_hext)
done

lemma lconf_upd: "!!X. [| G,h\<turnstile>l[::\<preceq>]lT;
  G,h\<turnstile>v::\<preceq>T; lT va = Some T |] ==> G,h\<turnstile>l(va\<mapsto>v)[::\<preceq>]lT"
apply (unfold lconf_def)
apply auto
done

lemma lconf_init_vars_lemma [rule_format (no_asm)]:
  "\<forall>x. P x --> R (dv x) x ==> (\<forall>x. map_of fs f = Some x --> P x) -->
  (\<forall>T. map_of fs f = Some T -->
  (\<exists>v. map_of (map (\<lambda>(f,ft). (f, dv ft)) fs) f = Some v \<and>  R v T))"
apply( induct_tac "fs")
apply auto
done

lemma lconf_init_vars [intro!]:
"\<forall>n. \<forall>T. map_of fs n = Some T --> is_type G T ==> G,h\<turnstile>init_vars fs[::\<preceq>]map_of fs"
apply (unfold lconf_def init_vars_def)
apply auto
apply( rule lconf_init_vars_lemma)
apply(   erule_tac [3] asm_rl)
apply(  intro strip)
apply(  erule defval_conf)
apply auto
done

lemma lconf_ext: "[|G,s\<turnstile>l[::\<preceq>]L; G,s\<turnstile>v::\<preceq>T|] ==> G,s\<turnstile>l(vn\<mapsto>v)[::\<preceq>]L(vn\<mapsto>T)"
apply (unfold lconf_def)
apply auto
done

lemma lconf_ext_list [rule_format (no_asm)]:
  "G,h\<turnstile>l[::\<preceq>]L ==> \<forall>vs Ts. distinct vns --> length Ts = length vns -->
  list_all2 (\<lambda>v T. G,h\<turnstile>v::\<preceq>T) vs Ts --> G,h\<turnstile>l(vns[\<mapsto>]vs)[::\<preceq>]L(vns[\<mapsto>]Ts)"
apply (unfold lconf_def)
apply( induct_tac "vns")
apply(  clarsimp)
apply( clarsimp)
apply( frule list_all2_lengthD)
apply( auto simp add: length_Suc_conv)
done

lemma lconf_restr: "\<lbrakk>lT vn = None; G, h \<turnstile> l [::\<preceq>] lT(vn\<mapsto>T)\<rbrakk> \<Longrightarrow> G, h \<turnstile> l [::\<preceq>] lT"
apply (unfold lconf_def)
apply (intro strip)
apply (case_tac "n = vn")
apply auto
done

subsection "oconf"

lemma oconf_hext: "G,h\<turnstile>obj\<surd> ==> h\<le>|h' ==> G,h'\<turnstile>obj\<surd>"
apply (unfold oconf_def)
apply (fast)
done

lemma oconf_obj: "G,h\<turnstile>(C,fs)\<surd> =
  (\<forall>T f. map_of(fields (G,C)) f = Some T --> (\<exists>v. fs f = Some v \<and>  G,h\<turnstile>v::\<preceq>T))"
apply (unfold oconf_def lconf_def)
apply auto
done

lemmas oconf_objD = oconf_obj [THEN iffD1, THEN spec, THEN spec, THEN mp]

subsection "hconf"

lemma hconfD: "[|G\<turnstile>h h\<surd>; h a = Some obj|] ==> G,h\<turnstile>obj\<surd>"
apply (unfold hconf_def)
apply (fast)
done

lemma hconfI: "\<forall>a obj. h a=Some obj --> G,h\<turnstile>obj\<surd> ==> G\<turnstile>h h\<surd>"
apply (unfold hconf_def)
apply (fast)
done

subsection "xconf"

lemma xconf_raise_if: "xconf h x \<Longrightarrow> xconf h (raise_if b xcn x)"
by (simp add: xconf_def raise_if_def)

subsection "conforms"

lemma conforms_heapD: "(x, (h, l))::\<preceq>(G, lT) ==> G\<turnstile>h h\<surd>"
apply (unfold conforms_def)
apply (simp)
done

lemma conforms_localD: "(x, (h, l))::\<preceq>(G, lT) ==> G,h\<turnstile>l[::\<preceq>]lT"
apply (unfold conforms_def)
apply (simp)
done

lemma conforms_xcptD: "(x, (h, l))::\<preceq>(G, lT) ==> xconf h x"
apply (unfold conforms_def)
apply (simp)
done

lemma conformsI: "[|G\<turnstile>h h\<surd>; G,h\<turnstile>l[::\<preceq>]lT; xconf h x|] ==> (x, (h, l))::\<preceq>(G, lT)"
apply (unfold conforms_def)
apply auto
done

lemma conforms_restr: "\<lbrakk>lT vn = None; s ::\<preceq> (G, lT(vn\<mapsto>T)) \<rbrakk> \<Longrightarrow> s ::\<preceq> (G, lT)"
by (simp add: conforms_def, fast intro: lconf_restr)

lemma conforms_xcpt_change: "\<lbrakk> (x, (h,l))::\<preceq> (G, lT); xconf h x \<longrightarrow> xconf h x' \<rbrakk> \<Longrightarrow> (x', (h,l))::\<preceq> (G, lT)"
by (simp add: conforms_def)

lemma preallocated_hext: "\<lbrakk> preallocated h; h\<le>|h'\<rbrakk> \<Longrightarrow> preallocated h'"
by (simp add: preallocated_def hext_def)

lemma xconf_hext: "\<lbrakk> xconf h vo; h\<le>|h'\<rbrakk> \<Longrightarrow> xconf h' vo"
by (simp add: xconf_def preallocated_def hext_def)

lemma conforms_hext: "[|(x,(h,l))::\<preceq>(G,lT); h\<le>|h'; G\<turnstile>h h'\<surd> |]
  ==> (x,(h',l))::\<preceq>(G,lT)"
by (fast dest: conforms_localD conforms_xcptD elim!: conformsI xconf_hext)

lemma conforms_upd_obj:
  "[|(x,(h,l))::\<preceq>(G, lT); G,h(a\<mapsto>obj)\<turnstile>obj\<surd>; h\<le>|h(a\<mapsto>obj)|]
  ==> (x,(h(a\<mapsto>obj),l))::\<preceq>(G, lT)"
apply(rule conforms_hext)
apply  auto
apply(rule hconfI)
apply(drule conforms_heapD)
apply(auto elim: oconf_hext dest: hconfD)
done

lemma conforms_upd_local:
"[|(x,(h, l))::\<preceq>(G, lT); G,h\<turnstile>v::\<preceq>T; lT va = Some T|]
  ==> (x,(h, l(va\<mapsto>v)))::\<preceq>(G, lT)"
apply (unfold conforms_def)
apply( auto elim: lconf_upd)
done

end