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

theory ArchUntyped_AI
imports "../Untyped_AI"
begin

context Arch begin global_naming ARM

named_theorems Untyped_AI_assms

lemma of_bl_nat_to_cref[Untyped_AI_assms]:
    "\<lbrakk> x < 2 ^ bits; bits < word_bits \<rbrakk>
      \<Longrightarrow> (of_bl (nat_to_cref bits x) :: machine_word) = of_nat x"
  apply (clarsimp intro!: less_mask_eq
                  simp: nat_to_cref_def of_drop_to_bl
                        word_size word_less_nat_alt word_bits_def)
  apply (subst unat_of_nat)
  apply (erule order_le_less_trans [OF mod_less_eq_dividend])
  done

lemma cnode_cap_ex_cte[Untyped_AI_assms]:
  "\<lbrakk> is_cnode_cap cap; cte_wp_at (\<lambda>c. \<exists>m. cap = mask_cap m c) p s;
     (s::'state_ext::state_ext state) \<turnstile> cap; valid_objs s; pspace_aligned s \<rbrakk> \<Longrightarrow>
    ex_cte_cap_wp_to is_cnode_cap (obj_ref_of cap, nat_to_cref (bits_of cap) x) s"
  apply (simp only: ex_cte_cap_wp_to_def)
  apply (rule exI, erule cte_wp_at_weakenE)
  apply (clarsimp simp: is_cap_simps bits_of_def)
  apply (case_tac c, simp_all add: mask_cap_def cap_rights_update_def split:bool.splits)
  apply (clarsimp simp: nat_to_cref_def word_bits_def)
  apply (erule(2) valid_CNodeCapE)
  apply (simp add: word_bits_def cte_level_bits_def)
  done

lemma inj_on_nat_to_cref[Untyped_AI_assms]:
  "bits < 32 \<Longrightarrow> inj_on (nat_to_cref bits) {..< 2 ^ bits}"
  apply (rule inj_onI)
  apply (drule arg_cong[where f="\<lambda>x. replicate (32 - bits) False @ x"])
  apply (subst(asm) word_bl.Abs_inject[where 'a=32, symmetric])
    apply (simp add: nat_to_cref_def word_bits_def)
   apply (simp add: nat_to_cref_def word_bits_def)
  apply (simp add: of_bl_rep_False of_bl_nat_to_cref[simplified word_bits_def])
  apply (erule word_unat.Abs_eqD)
   apply (simp only: unats_def mem_simps)
   apply (erule order_less_le_trans)
   apply (rule power_increasing, simp+)
  apply (simp only: unats_def mem_simps)
  apply (erule order_less_le_trans)
  apply (rule power_increasing, simp+)
  done

lemma data_to_obj_type_sp[Untyped_AI_assms]:
  "\<lbrace>P\<rbrace> data_to_obj_type x \<lbrace>\<lambda>ts (s::'state_ext::state_ext state). ts \<noteq> ArchObject ASIDPoolObj \<and> P s\<rbrace>, -"
  unfolding data_to_obj_type_def
  apply (rule hoare_pre)
   apply (wp|wpc)+
  apply clarsimp
  apply (simp add: arch_data_to_obj_type_def split: if_split_asm)
  done

lemma dui_inv_wf[wp, Untyped_AI_assms]:
  "\<lbrace>invs and cte_wp_at ((=) (cap.UntypedCap dev w sz idx)) slot
     and (\<lambda>s. \<forall>cap \<in> set cs. is_cnode_cap cap
                      \<longrightarrow> (\<forall>r\<in>cte_refs cap (interrupt_irq_node s). ex_cte_cap_wp_to is_cnode_cap r s))
    and (\<lambda>s. \<forall>x \<in> set cs. s \<turnstile> x)\<rbrace>
     decode_untyped_invocation label args slot (cap.UntypedCap dev w sz idx) cs
   \<lbrace>valid_untyped_inv\<rbrace>,-"
proof -
  have inj: "\<And>node_cap s. \<lbrakk>is_cnode_cap node_cap;
    unat (args ! 5) \<le> 2 ^ bits_of node_cap - unat (args ! 4);valid_cap node_cap s\<rbrakk> \<Longrightarrow>
    inj_on (Pair (obj_ref_of node_cap) \<circ> nat_to_cref (bits_of node_cap))
                      {unat (args ! 4)..<unat (args ! 4) + unat (args ! 5)}"
    apply (simp add: comp_def)
    apply (rule inj_on_split)
    apply (rule subset_inj_on [OF inj_on_nat_to_cref])
     apply (clarsimp simp: is_cap_simps bits_of_def valid_cap_def
                           word_bits_def cap_aligned_def)
    apply clarsimp
    apply (rule less_le_trans)
     apply assumption
    apply (simp add: le_diff_conv2)
    done
  have nasty_strengthen:
    "\<And>S a f s. (\<forall>x\<in>S. cte_wp_at ((=) cap.NullCap) (a, f x) s)
    \<Longrightarrow> cte_wp_at (\<lambda>c. c \<noteq> cap.NullCap) slot s
    \<longrightarrow> slot \<notin> (Pair a \<circ> f) ` S"
    by (auto simp:cte_wp_at_caps_of_state)
  show ?thesis
    apply (simp add: decode_untyped_invocation_def unlessE_def[symmetric]
                     unlessE_whenE
             split del: if_split)
    apply (rule validE_R_sp[OF whenE_throwError_sp]
                validE_R_sp[OF data_to_obj_type_sp]
                validE_R_sp[OF dui_sp_helper] validE_R_sp[OF map_ensure_empty])+
     apply clarsimp
    apply (rule hoare_pre)
     apply (wp whenE_throwError_wp[THEN validE_validE_R] check_children_wp
               map_ensure_empty_wp)
    apply (clarsimp simp: distinct_map cases_imp_eq)
    apply (subgoal_tac "s \<turnstile> node_cap")
     prefer 2
     apply (erule disjE)
      apply (drule bspec [where x = "cs ! 0"],clarsimp)+
      apply fastforce
     apply clarsimp
     apply (clarsimp simp: cte_wp_at_caps_of_state)
     apply (drule(1) caps_of_state_valid[rotated])+
     apply assumption
    apply (subgoal_tac "\<forall>r\<in>cte_refs node_cap (interrupt_irq_node s). ex_cte_cap_wp_to is_cnode_cap r s")
     apply (clarsimp simp: cte_wp_at_caps_of_state)
     apply (frule(1) caps_of_state_valid[rotated])
     apply (clarsimp simp: not_less)
     apply (frule(2) inj)
     apply (clarsimp simp: comp_def)
     apply (frule(1) caps_of_state_valid)
     apply (simp add: nasty_strengthen[unfolded o_def] cte_wp_at_caps_of_state)
     apply (intro conjI)
      apply (intro impI)
      apply (frule range_cover_stuff[where w=w and rv = 0 and sz = sz], simp_all)[1]
        apply (clarsimp simp: valid_cap_simps cap_aligned_def)+
      apply (frule alignUp_idem[OF is_aligned_weaken,where a = w])
        apply (erule range_cover.sz)
       apply (simp add: range_cover_def)
      apply (clarsimp simp: get_free_ref_def empty_descendants_range_in)
      apply (rule conjI[rotated], blast, clarsimp)
      apply (drule_tac x = "(obj_ref_of node_cap,nat_to_cref (bits_of node_cap) slota)" in bspec)
       apply (clarsimp simp: is_cap_simps nat_to_cref_def word_bits_def
         bits_of_def valid_cap_simps cap_aligned_def)+
     apply (simp add: free_index_of_def)
     apply (frule(1) range_cover_stuff[where sz = sz])
        apply (clarsimp dest!: valid_cap_aligned simp: cap_aligned_def word_bits_def)+
      apply simp+
     apply (clarsimp simp: get_free_ref_def)
    apply (erule disjE)
     apply (drule_tac x= "cs!0" in bspec)
    subgoal by clarsimp
    subgoal by simp
    apply (clarsimp simp: cte_wp_at_caps_of_state ex_cte_cap_wp_to_def)
    apply (rule_tac x=aa in exI,rule exI,rule exI)
    apply (rule conjI, assumption)
    apply simp
   done
qed

lemma asid_bits_ge_0:
  "(0::word32) < 2 ^ asid_bits" by (simp add: asid_bits_def)

lemma retype_ret_valid_caps_captable[Untyped_AI_assms]:
  "\<lbrakk>pspace_no_overlap_range_cover ptr sz (s::'state_ext::state_ext state) \<and> 0 < us
      \<and> range_cover ptr sz (obj_bits_api CapTableObject us) n \<and> ptr \<noteq> 0
       \<rbrakk>
         \<Longrightarrow> \<forall>y\<in>{0..<n}. s
                \<lparr>kheap := foldr (\<lambda>p kh. kh(p \<mapsto> default_object CapTableObject dev us)) (map (\<lambda>p. ptr_add ptr (p * 2 ^ obj_bits_api CapTableObject us)) [0..<n])
                           (kheap s)\<rparr> \<turnstile> CNodeCap (ptr_add ptr (y * 2 ^ obj_bits_api CapTableObject us)) us []"
by ((clarsimp simp:valid_cap_def default_object_def cap_aligned_def
        cte_level_bits_def is_obj_defs well_formed_cnode_n_def empty_cnode_def
        dom_def arch_default_cap_def ptr_add_def | rule conjI | intro conjI obj_at_foldr_intro imageI
      | rule is_aligned_add_multI[OF _ le_refl],
        (simp add:range_cover_def word_bits_def obj_bits_api_def slot_bits_def)+)+)[1]

lemma retype_ret_valid_caps_aobj[Untyped_AI_assms]:
  "\<And>ptr sz (s::'state_ext::state_ext state) x6 us n.
  \<lbrakk>pspace_no_overlap_range_cover ptr sz s \<and> x6 \<noteq> ASIDPoolObj \<and>
  range_cover ptr sz (obj_bits_api (ArchObject x6) us) n \<and> ptr \<noteq> 0\<rbrakk>
            \<Longrightarrow> \<forall>y\<in>{0..<n}. s
                   \<lparr>kheap := foldr (\<lambda>p kh. kh(p \<mapsto> default_object (ArchObject x6) dev us)) (map (\<lambda>p. ptr_add ptr (p * 2 ^ obj_bits_api (ArchObject x6) us)) [0..<n])
                              (kheap s)\<rparr> \<turnstile> ArchObjectCap (ARM_A.arch_default_cap x6 (ptr_add ptr (y * 2 ^ obj_bits_api (ArchObject x6) us)) us dev)"
  apply (rename_tac aobject_type us n)
  apply (case_tac aobject_type)
  by (clarsimp simp: valid_cap_def default_object_def cap_aligned_def
                     cte_level_bits_def is_obj_defs well_formed_cnode_n_def empty_cnode_def
                     dom_def arch_default_cap_def ptr_add_def
      | intro conjI obj_at_foldr_intro
        imageI valid_vm_rights_def
      | rule is_aligned_add_multI[OF _ le_refl]
      | fastforce simp:range_cover_def obj_bits_api_def
        default_arch_object_def valid_vm_rights_def  word_bits_def a_type_def)+

lemma copy_global_mappings_hoare_lift:(*FIXME: arch_split  \<rightarrow> these do not seem to be used globally *)
  assumes wp: "\<And>ptr val. \<lbrace>Q\<rbrace> store_pde ptr val \<lbrace>\<lambda>rv. Q\<rbrace>"
  shows       "\<lbrace>Q\<rbrace> copy_global_mappings pd \<lbrace>\<lambda>rv. Q\<rbrace>"
  apply (simp add: copy_global_mappings_def)
  apply (wp mapM_x_wp' wp)
  done

lemma init_arch_objects_hoare_lift:
  assumes wp: "\<And>oper. \<lbrace>(P::'state_ext::state_ext state\<Rightarrow>bool)\<rbrace> do_machine_op oper \<lbrace>\<lambda>rv :: unit. Q\<rbrace>"
              "\<And>ptr val. \<lbrace>P\<rbrace> store_pde ptr val \<lbrace>\<lambda>rv. P\<rbrace>"
  shows       "\<lbrace>P and Q\<rbrace> init_arch_objects tp ptr sz us adds \<lbrace>\<lambda>rv. Q\<rbrace>"
proof -
  have pres: "\<And>oper. \<lbrace>P and Q\<rbrace> do_machine_op oper \<lbrace>\<lambda>rv :: unit. Q\<rbrace>"
             "\<lbrace>P and Q\<rbrace> return () \<lbrace>\<lambda>rv. Q\<rbrace>"
    by (wp wp | simp)+
  show ?thesis
    apply (simp add: init_arch_objects_def
                  pres reserve_region_def unless_def when_def
           split: Structures_A.apiobject_type.split
                  aobject_type.split)
    apply clarsimp
    apply (rule hoare_pre)
     apply (wp mapM_x_wp' copy_global_mappings_hoare_lift wp)
    apply simp
    done
qed

crunch pdistinct[wp]: do_machine_op "pspace_distinct"
crunch vmdb[wp]: do_machine_op "valid_mdb"
crunch mdb[wp]: do_machine_op "\<lambda>s. P (cdt s)"
crunch cte_wp_at[wp]: do_machine_op "\<lambda>s. P (cte_wp_at P' p s)"

lemma cap_refs_in_kernel_windowD2:
  "\<lbrakk> cte_wp_at P p (s::'state_ext::state_ext state); cap_refs_in_kernel_window s \<rbrakk>
       \<Longrightarrow> \<exists>cap. P cap \<and> region_in_kernel_window (cap_range cap) s"
  apply (clarsimp simp: cte_wp_at_caps_of_state region_in_kernel_window_def)
  apply (drule(1) cap_refs_in_kernel_windowD)
  apply fastforce
  done

lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]:
  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace> init_arch_objects ty ptr n us y
          \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
  apply (simp add:descendants_range_def)
  apply (rule hoare_pre)
   apply (wp retype_region_mdb init_arch_objects_hoare_lift)
    apply (wps do_machine_op_mdb)
    apply (wp hoare_vcg_ball_lift)
   apply (rule hoare_pre)
    apply (wps store_pde_mdb_inv)
    apply wp
   apply simp
  apply fastforce
  done

lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]:
  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). caps_overlap_reserved S s\<rbrace>
   init_arch_objects ty ptr n us y
   \<lbrace>\<lambda>rv s. caps_overlap_reserved S s\<rbrace>"
  apply (simp add:caps_overlap_reserved_def)
  apply (rule hoare_pre)
   apply (wp retype_region_mdb init_arch_objects_hoare_lift)
  apply fastforce
  done

lemma set_untyped_cap_invs_simple[Untyped_AI_assms]:
  "\<lbrace>\<lambda>s. descendants_range_in {ptr .. ptr+2^sz - 1} cref s \<and> pspace_no_overlap_range_cover ptr sz s \<and> invs s
  \<and> cte_wp_at (\<lambda>c. is_untyped_cap c \<and> cap_bits c = sz \<and> obj_ref_of c = ptr \<and> cap_is_device c = dev) cref s \<and> idx \<le> 2^ sz\<rbrace>
  set_cap (cap.UntypedCap dev ptr sz idx) cref
 \<lbrace>\<lambda>rv s. invs s\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp: cte_wp_at_caps_of_state invs_def valid_state_def)
  apply (rule hoare_pre)
  apply (wp set_free_index_valid_pspace_simple set_cap_valid_mdb_simple
    set_cap_idle update_cap_ifunsafe)
  apply (simp add:valid_irq_node_def)
  apply wps
  apply (wp hoare_vcg_all_lift set_cap_irq_handlers set_cap_valid_arch_caps
    set_cap_irq_handlers cap_table_at_lift_valid set_cap_typ_at
    set_untyped_cap_refs_respects_device_simple)
  apply (clarsimp simp:cte_wp_at_caps_of_state is_cap_simps)
  apply (intro conjI,clarsimp)
        apply (rule ext,clarsimp simp:is_cap_simps)
       apply (clarsimp split:cap.splits simp:is_cap_simps appropriate_cte_cap_def)
      apply (drule(1) if_unsafe_then_capD[OF caps_of_state_cteD])
       apply clarsimp
      apply (clarsimp simp:is_cap_simps ex_cte_cap_wp_to_def appropriate_cte_cap_def cte_wp_at_caps_of_state)
     apply (clarsimp dest!:valid_global_refsD2 simp:cap_range_def)
    apply (simp add:valid_irq_node_def)
   apply (clarsimp simp:valid_irq_node_def)
  apply (clarsimp simp:no_cap_to_obj_with_diff_ref_def cte_wp_at_caps_of_state vs_cap_ref_def)
  apply (case_tac cap)
   apply (simp_all add:vs_cap_ref_def table_cap_ref_def)
  apply (rename_tac arch_cap)
  apply (case_tac arch_cap)
   apply simp_all
  apply (clarsimp simp:cap_refs_in_kernel_window_def
              valid_refs_def simp del:split_paired_All)
  apply (drule_tac x = cref in spec)
  apply (clarsimp simp:cte_wp_at_caps_of_state)
  apply fastforce
  done

lemma pbfs_atleast_pageBits':
  "pageBits \<le> pageBitsForSize sz"by (cases sz, simp_all add: pageBits_def)

lemma pbfs_less_wb':
  "pageBitsForSize sz < word_bits"by (cases sz, simp_all add: word_bits_conv pageBits_def)

lemma delete_objects_rewrite[Untyped_AI_assms]:
  "\<lbrakk> word_size_bits \<le> sz; sz\<le> word_bits; ptr && ~~ mask sz = ptr \<rbrakk>
    \<Longrightarrow> delete_objects ptr sz =
          do y \<leftarrow> modify (clear_um {ptr + of_nat k |k. k < 2 ^ sz});
             modify (detype {ptr && ~~ mask sz..ptr + 2 ^ sz - 1})
          od"
  apply (clarsimp simp: delete_objects_def freeMemory_def word_size_def word_size_bits_def)
  apply (subgoal_tac "is_aligned (ptr &&~~ mask sz) sz")
  apply (subst mapM_storeWord_clear_um[simplified word_size_def word_size_bits_def])
  apply (simp)
  apply simp
  apply (simp add:range_cover_def)
  apply clarsimp
  apply (rule is_aligned_neg_mask)
  apply simp
  done

declare store_pde_pred_tcb_at [wp]

(* nonempty_table *)
definition
  nonempty_table :: "machine_word set \<Rightarrow> Structures_A.kernel_object \<Rightarrow> bool"
where
 "nonempty_table S ko \<equiv>
    (a_type ko = AArch APageTable \<or> a_type ko = AArch APageDirectory)
       \<and> \<not> empty_table S ko"

lemma reachable_pg_cap_exst_update[simp]:
  "reachable_pg_cap x (trans_state f (s::'state_ext::state_ext state)) = reachable_pg_cap x s"
  by (simp add: reachable_pg_cap_def vs_lookup_pages_def
                vs_lookup_pages1_def obj_at_def)

lemma create_cap_valid_arch_caps[wp, Untyped_AI_assms]:
  "\<lbrace>valid_arch_caps
      and valid_cap (default_cap tp oref sz dev)
      and (\<lambda>(s::'state_ext::state_ext state). \<forall>r\<in>obj_refs (default_cap tp oref sz dev).
                (\<forall>p'. \<not> cte_wp_at (\<lambda>cap. r \<in> obj_refs cap) p' s)
              \<and> \<not> obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
      and cte_wp_at ((=) cap.NullCap) cref
      and K (tp \<noteq> ArchObject ASIDPoolObj)\<rbrace>
     create_cap tp sz p dev (cref, oref) \<lbrace>\<lambda>rv. valid_arch_caps\<rbrace>"
  apply (simp add: create_cap_def set_cdt_def)
  apply (wp set_cap_valid_arch_caps)
  apply (simp add: trans_state_update[symmetric] del: trans_state_update)
  apply (wp hoare_vcg_disj_lift hoare_vcg_conj_lift hoare_vcg_all_lift hoare_vcg_imp_lift | simp)+
  apply (clarsimp simp del: split_paired_All split_paired_Ex
                            imp_disjL
                      simp: cte_wp_at_caps_of_state)
  apply (rule conjI)
   apply (clarsimp simp: no_cap_to_obj_with_diff_ref_def
                         cte_wp_at_caps_of_state)
   apply (case_tac "\<exists>x. x \<in> obj_refs cap")
    apply (clarsimp dest!: obj_ref_elemD)
    apply (case_tac cref, fastforce)
   apply (simp add: obj_ref_none_no_asid)
  apply (rule conjI)
   apply (auto simp: is_cap_simps valid_cap_def second_level_tables_def
                     obj_at_def nonempty_table_def a_type_simps)[1]
  apply (clarsimp simp del: imp_disjL)
  apply (case_tac "\<exists>x. x \<in> obj_refs cap")
   apply (clarsimp dest!: obj_ref_elemD)
   apply fastforce
  apply (auto simp: is_cap_simps)[1]
  done

lemma create_cap_cap_refs_in_kernel_window[wp, Untyped_AI_assms]:
  "\<lbrace>cap_refs_in_kernel_window and cte_wp_at (\<lambda>c. cap_range (default_cap tp oref sz dev) \<subseteq> cap_range c) p\<rbrace>
     create_cap tp sz p dev (cref, oref) \<lbrace>\<lambda>rv. cap_refs_in_kernel_window\<rbrace>"
  apply (simp add: create_cap_def)
  apply (wp | simp)+
  apply (clarsimp simp: cte_wp_at_caps_of_state)
  apply (drule(1) cap_refs_in_kernel_windowD)
  apply blast
  done

crunch irq_node[wp]: store_pde "\<lambda>s. P (interrupt_irq_node s)"
  (wp: crunch_wps)

(* make these available in the generic theory? *)
lemma init_arch_objects_irq_node[wp]:
  "\<lbrace>\<lambda>s. P (interrupt_irq_node s)\<rbrace> init_arch_objects tp ptr bits us refs \<lbrace>\<lambda>rv s. P (interrupt_irq_node s)\<rbrace>"
  by (wp init_arch_objects_hoare_lift, simp)

lemma init_arch_objects_excap[wp]:
  "\<lbrace>ex_cte_cap_wp_to P p\<rbrace> init_arch_objects tp ptr bits us refs \<lbrace>\<lambda>rv. ex_cte_cap_wp_to P p\<rbrace>"
  by (wp ex_cte_cap_to_pres init_arch_objects_irq_node init_arch_objects_cte_wp_at)

crunch nonempty_table[wp]: do_machine_op
  "\<lambda>s. P' (obj_at (nonempty_table (set (arm_global_pts (arch_state s)))) r s)"

lemma store_pde_weaken:
  "\<lbrace>\<lambda>s. page_directory_at (p && ~~ mask pd_bits) s \<longrightarrow> P s\<rbrace> store_pde p e \<lbrace>Q\<rbrace> =
   \<lbrace>P\<rbrace> store_pde p e \<lbrace>Q\<rbrace>"
  apply (rule iffI)
   apply (simp add: valid_def)
   apply (erule allEI)
   apply clarsimp
  apply (simp add: valid_def)
  apply (erule allEI)
  apply clarsimp
  apply (rule use_valid, assumption)
   apply (simp add: store_pde_def set_pd_def set_object_def)
   apply (wp get_object_wp)
  apply (clarsimp simp: obj_at_def a_type_simps)
  apply (drule bspec, assumption)
  apply (simp add: simpler_store_pde_def obj_at_def fun_upd_def
            split: Structures_A.kernel_object.splits arch_kernel_obj.splits)
  done

lemma store_pde_nonempty_table:
  "\<lbrace>\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
           \<and> (\<forall>rf. pde_ref pde = Some rf \<longrightarrow>
                   rf \<in> set (arm_global_pts (arch_state s)))
           \<and> ucast (pde_ptr && mask pd_bits >> 2) \<in> kernel_mapping_slots
           \<and> valid_pde_mappings pde\<rbrace>
     store_pde pde_ptr pde
   \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
  apply (simp add: store_pde_def set_pd_def set_object_def)
  apply (wp get_object_wp)
  apply (clarsimp simp: obj_at_def nonempty_table_def a_type_def)
  apply (clarsimp simp add: empty_table_def second_level_tables_def)
  done

lemma store_pde_global_global_objs:
  "\<lbrace>\<lambda>s. valid_global_objs s
           \<and> (\<forall>rf. pde_ref pde = Some rf \<longrightarrow>
                   rf \<in> set (arm_global_pts (arch_state s)))
           \<and> ucast (pde_ptr && mask pd_bits >> 2) \<in> kernel_mapping_slots
           \<and> valid_pde_mappings pde\<rbrace>
   store_pde pde_ptr pde
   \<lbrace>\<lambda>rv s. valid_global_objs s\<rbrace>"
  apply (simp add: store_pde_def set_pd_def set_object_def)
  apply (wp get_object_wp)
  apply (clarsimp simp: obj_at_def fun_upd_def[symmetric])
proof -
  fix s pd
  assume vg: "valid_global_objs s"
     and gr: "\<forall>rf. pde_ref pde = Some rf \<longrightarrow>
                   rf \<in> set (arm_global_pts (arch_state s))"
     and uc: "ucast (pde_ptr && mask pd_bits >> 2) \<in> kernel_mapping_slots"
     and vp: "valid_pde_mappings pde"
     and pd: "kheap s (pde_ptr && ~~ mask pd_bits) =
              Some (ArchObj (PageDirectory pd))"
  let ?ko' = "ArchObj (PageDirectory
                         (pd(ucast (pde_ptr && mask pd_bits >> 2) := pde)))"
  let ?s' = "s\<lparr>kheap := kheap s(pde_ptr && ~~ mask pd_bits \<mapsto> ?ko')\<rparr>"
  have typ_at: "\<And>T p. typ_at T p s \<Longrightarrow> typ_at T p ?s'"
    using pd
    by (clarsimp simp: obj_at_def a_type_def)
  have valid_pde: "\<And>pde. valid_pde pde s \<Longrightarrow> valid_pde pde ?s'"
    by (case_tac pdea, auto simp add: typ_at data_at_def)
  have valid_pte: "\<And>pte. valid_pte pte s \<Longrightarrow> valid_pte pte ?s'"
    by (case_tac pte, auto simp add: typ_at data_at_def)
  have valid_ao_at: "\<And>p. valid_ao_at p s \<Longrightarrow> valid_ao_at p ?s'"
    using pd uc
    apply (clarsimp simp: valid_ao_at_def obj_at_def)
    apply (intro conjI impI allI)
      apply (clarsimp simp: valid_pde vp)
    apply (case_tac ao, simp_all add: typ_at valid_pde valid_pte)
    done
  have valid_vso_at: "\<And>p. valid_vso_at p s \<Longrightarrow> valid_vso_at p ?s'"
    using pd uc
    apply (clarsimp simp: valid_vso_at_def obj_at_def)
    apply (intro conjI impI allI)
      apply (clarsimp simp: valid_pde vp)
    apply (case_tac ao, simp_all add: typ_at valid_pde valid_pte)
    done
  have empty:
    "\<And>p. obj_at (empty_table (set (second_level_tables (arch_state s)))) p s
          \<Longrightarrow> obj_at (empty_table (set (second_level_tables (arch_state s)))) p ?s'"
    using pd gr vp uc
    by (clarsimp simp: obj_at_def empty_table_def second_level_tables_def)
  show "valid_global_objs ?s'"
    using vg pd
    apply (clarsimp simp add: valid_global_objs_def valid_ao_at valid_vso_at empty)
    apply (fastforce simp add: obj_at_def)
    done
qed

lemma valid_arch_state_global_pd:
  "\<lbrakk> valid_arch_state s; pspace_aligned s \<rbrakk>
    \<Longrightarrow> obj_at (\<lambda>ko. \<exists>pd. ko = ArchObj (PageDirectory pd)) (arm_global_pd (arch_state s)) s
           \<and> is_aligned (arm_global_pd (arch_state s)) pd_bits"
  apply (clarsimp simp: valid_arch_state_def a_type_def
                        pd_aligned pd_bits_def pageBits_def
                 elim!: obj_at_weakenE)
  apply (clarsimp split: Structures_A.kernel_object.split_asm
                         arch_kernel_obj.split_asm if_split_asm)
  done

lemma pd_shifting':
  "is_aligned (pd :: word32) pd_bits \<Longrightarrow> pd + (vptr >> 20 << 2) && ~~ mask pd_bits = pd"
  by (rule pd_shifting, simp add: pd_bits_def pageBits_def)

lemma copy_global_mappings_nonempty_table:
  "is_aligned pd pd_bits \<Longrightarrow>
   \<lbrace>\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \<and>
        valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s\<rbrace>
   copy_global_mappings pd
   \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table
                        (set (second_level_tables (arch_state s)))) r s) \<and>
           valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s\<rbrace>"
  apply (simp add: copy_global_mappings_def)
  apply (rule hoare_seq_ext [OF _ gets_sp])
  apply (rule hoare_strengthen_post)
   apply (rule mapM_x_wp[where S="{x. kernel_base >> 20 \<le> x \<and>
                                      x < 2 ^ (pd_bits - 2)}"])
    apply (wp get_pde_wp hoare_vcg_ball_lift
              store_pde_weaken[THEN iffD2,OF store_pde_nonempty_table]
              store_pde_weaken[THEN iffD2,OF store_pde_global_global_objs]
           | simp)+
    apply clarsimp
    apply (subst (asm) is_aligned_add_helper[THEN conjunct2])
      apply (clarsimp simp: valid_arch_state_def pspace_aligned_def dom_def
                            obj_at_def)
      apply (drule_tac x="arm_global_pd (arch_state s)" in spec, erule impE,
             fastforce)
      apply (simp add: pd_bits_def pageBits_def)
     apply (erule shiftl_less_t2n)
     apply (simp add: pd_bits_def pageBits_def)
    apply (clarsimp simp: valid_arch_state_def valid_global_objs_def obj_at_def
                          empty_table_def second_level_tables_def)
    apply (simp add: kernel_mapping_slots_def)
    apply (subst is_aligned_add_helper[THEN conjunct1], assumption)
     apply (erule shiftl_less_t2n)
     apply (simp add: pd_bits_def pageBits_def)
    apply (simp add: kernel_base_shift_cast_le[symmetric] ucast_ucast_mask)
    apply (subst shiftl_shiftr_id)
      apply simp
     apply (simp add: word_less_nat_alt pd_bits_def pageBits_def)
    apply (subst less_mask_eq)
     apply (simp add: pd_bits_def pageBits_def)
    apply assumption
   apply (clarsimp simp: pd_bits_def)
  apply simp
  done

lemma mapM_copy_global_mappings_nonempty_table[wp]:
  "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
        \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
    K (\<forall>pd\<in>set pds. is_aligned pd pd_bits)\<rbrace>
   mapM_x copy_global_mappings pds
   \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (rule hoare_strengthen_post)
   apply (rule mapM_x_wp', rule copy_global_mappings_nonempty_table)
   apply simp_all
  done

lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]:
  "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
         \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
    K (\<forall>ref\<in>set refs. is_aligned ref (obj_bits_api tp us))\<rbrace>
        init_arch_objects tp ptr bits us refs
   \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (simp add: init_arch_objects_def split del: if_split)
  apply (rule hoare_pre)
   apply (wp hoare_unless_wp | wpc | simp add: reserve_region_def second_level_tables_def)+
  apply (clarsimp simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def)
  done

lemma nonempty_table_caps_of[Untyped_AI_assms]:
  "nonempty_table S ko \<Longrightarrow> caps_of ko = {}"
  by (auto simp: caps_of_def cap_of_def nonempty_table_def a_type_def
          split: Structures_A.kernel_object.split if_split_asm)

lemma nonempty_default[simp, Untyped_AI_assms]:
  "tp \<noteq> Untyped \<Longrightarrow> \<not> nonempty_table S (default_object tp dev us)"
  apply (case_tac tp, simp_all add: default_object_def nonempty_table_def
                                    a_type_def)
  apply (rename_tac aobject_type)
  apply (case_tac aobject_type, simp_all add: default_arch_object_def)
   apply (simp_all add: empty_table_def pde_ref_def valid_pde_mappings_def)
  done

lemma set_pd_cte_wp_at_iin[wp]:
  "\<lbrace>\<lambda>s. P (cte_wp_at (P' (interrupt_irq_node s)) p s)\<rbrace>
   set_pd q pd
   \<lbrace>\<lambda>_ s. P (cte_wp_at (P' (interrupt_irq_node s)) p s)\<rbrace>"
  apply (simp add: set_pd_def)
  including unfold_objects
  apply (wpsimp wp: set_object_wp_strong
              simp: a_type_def cte_wp_at_after_update')
  done

crunch cte_wp_at_iin[wp]: init_arch_objects
  "\<lambda>s. P (cte_wp_at (P' (interrupt_irq_node s)) p s)"
  (ignore: clearMemory wp: crunch_wps hoare_unless_wp)

lemmas init_arch_objects_ex_cte_cap_wp_to
    = init_arch_objects_excap

lemma obj_is_device_vui_eq[Untyped_AI_assms]:
  "valid_untyped_inv ui s
      \<Longrightarrow> case ui of Retype slot reset ptr_base ptr tp us slots dev
          \<Rightarrow> obj_is_device tp dev = dev"
  apply (cases ui, clarsimp)
  apply (clarsimp simp: obj_is_device_def
                 split: apiobject_type.split)
  apply (intro impI conjI allI, simp_all add: is_frame_type_def default_object_def)
  apply (simp add: default_arch_object_def split: aobject_type.split)
  apply (auto simp: arch_is_frame_type_def)
  done

lemma create_cap_ioports[wp, Untyped_AI_assms]:
  "\<lbrace>valid_ioports and cte_wp_at (\<lambda>_. True) cref\<rbrace> create_cap tp sz p dev (cref,oref) \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
  by wpsimp

end

global_interpretation Untyped_AI? : Untyped_AI
  where nonempty_table = ARM.nonempty_table
  proof goal_cases
    interpret Arch .
    case 1 show ?case
    by (unfold_locales; (fact Untyped_AI_assms)?)
  qed

end


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

(* Wellformedness of caps, kernel objects, states on the C level
*)

theory Wellformed_C
imports
  "CLib.CTranslationNICTA"
  CLevityCatch
  "CSpec.Substitute"
begin

context begin interpretation Arch . (*FIXME: arch_split*)

abbreviation
  cte_Ptr :: "word32 \<Rightarrow> cte_C ptr" where "cte_Ptr == Ptr"
abbreviation
  mdb_Ptr :: "word32 \<Rightarrow> mdb_node_C ptr" where "mdb_Ptr == Ptr"
abbreviation
  cap_Ptr :: "word32 \<Rightarrow> cap_C ptr" where "cap_Ptr == Ptr"
abbreviation
  tcb_Ptr :: "word32 \<Rightarrow> tcb_C ptr" where "tcb_Ptr == Ptr"
abbreviation
  ep_Ptr :: "word32 \<Rightarrow> endpoint_C ptr" where "ep_Ptr == Ptr"
abbreviation
  ntfn_Ptr :: "word32 \<Rightarrow> notification_C ptr" where "ntfn_Ptr == Ptr"
abbreviation
  ap_Ptr :: "word32 \<Rightarrow> asid_pool_C ptr" where "ap_Ptr == Ptr"
abbreviation
  pte_Ptr :: "word32 \<Rightarrow> pte_C ptr" where "pte_Ptr == Ptr"
abbreviation
  pde_Ptr :: "word32 \<Rightarrow> pde_C ptr" where "pde_Ptr == Ptr"
abbreviation
  pt_Ptr :: "32 word \<Rightarrow> (pte_C[256]) ptr" where "pt_Ptr == Ptr"
abbreviation
  pd_Ptr :: "32 word \<Rightarrow> (pde_C[4096]) ptr" where "pd_Ptr == Ptr"

lemma halt_spec:
  "Gamma \<turnstile> {} Call halt_'proc {}"
  apply (rule hoare_complete)
  apply (simp add: HoarePartialDef.valid_def)
  done

definition
  isUntypedCap_C :: "cap_CL \<Rightarrow> bool" where
  "isUntypedCap_C c \<equiv>
   case c of
   Cap_untyped_cap q \<Rightarrow> True
   | _ \<Rightarrow> False"

definition
  isNullCap_C :: "cap_CL \<Rightarrow> bool" where
  "isNullCap_C c \<equiv>
  case c of
   Cap_null_cap \<Rightarrow> True
   | _ \<Rightarrow> False"

definition
  isEndpointCap_C :: "cap_CL \<Rightarrow> bool" where
 "isEndpointCap_C v \<equiv> case v of
  Cap_endpoint_cap ec \<Rightarrow> True
  | _ \<Rightarrow> False"

definition
  isCNodeCap_C :: "cap_CL \<Rightarrow> bool" where
  "isCNodeCap_C c \<equiv> case c of
   Cap_cnode_cap a \<Rightarrow> True
   | _ \<Rightarrow> False"

definition
  isThreadCap_C :: "cap_CL \<Rightarrow> bool" where
  "isThreadCap_C c \<equiv> case c of
   Cap_thread_cap a \<Rightarrow> True
   | _ \<Rightarrow> False"

definition
  isIRQControlCap_C :: "cap_CL \<Rightarrow> bool" where
  "isIRQControlCap_C c \<equiv> case c of
   Cap_irq_control_cap \<Rightarrow> True
   | _ \<Rightarrow> False"

definition
  isIRQHandlerCap_C :: "cap_CL \<Rightarrow> bool" where
  "isIRQHandlerCap_C c \<equiv> case c of
   Cap_irq_handler_cap a \<Rightarrow> True
   | _ \<Rightarrow> False"

definition
  isNotificationCap_C :: "cap_CL \<Rightarrow> bool" where
 "isNotificationCap_C v \<equiv> case v of
  Cap_notification_cap aec \<Rightarrow> True
  | _ \<Rightarrow> False"

definition
  ep_at_C' :: "word32 \<Rightarrow> heap_raw_state \<Rightarrow> bool"
where
  "ep_at_C' p h \<equiv> Ptr p \<in> dom (clift h :: endpoint_C typ_heap)" \<comment> \<open>endpoint_lift is total\<close>

definition
  ntfn_at_C' :: "word32 \<Rightarrow> heap_raw_state \<Rightarrow> bool"
  where \<comment> \<open>notification_lift is total\<close>
  "ntfn_at_C' p h \<equiv> Ptr p \<in> dom (clift h :: notification_C typ_heap)"

definition
  tcb_at_C' :: "word32 \<Rightarrow> heap_raw_state \<Rightarrow> bool"
  where
  "tcb_at_C' p h \<equiv> Ptr p \<in> dom (clift h :: tcb_C typ_heap)"

definition
  cte_at_C' :: "word32 \<Rightarrow> heap_raw_state \<Rightarrow> bool"
  where
  "cte_at_C' p h \<equiv> Ptr p \<in> dom (clift h :: cte_C typ_heap)"

definition
  ctcb_ptr_to_tcb_ptr :: "tcb_C ptr \<Rightarrow> word32"
  where
  "ctcb_ptr_to_tcb_ptr p \<equiv> ptr_val p - ctcb_offset"

definition
  tcb_ptr_to_ctcb_ptr :: "word32 \<Rightarrow> tcb_C ptr"
  where
  "tcb_ptr_to_ctcb_ptr p \<equiv> Ptr (p + ctcb_offset)"

primrec
  tcb_queue_relation :: "(tcb_C \<Rightarrow> tcb_C ptr) \<Rightarrow> (tcb_C \<Rightarrow> tcb_C ptr) \<Rightarrow>
                         (tcb_C ptr \<Rightarrow> tcb_C option) \<Rightarrow> word32 list \<Rightarrow>
                         tcb_C ptr \<Rightarrow> tcb_C ptr \<Rightarrow> bool"
where
  "tcb_queue_relation getNext getPrev hp [] qprev qhead = (qhead = NULL)"
| "tcb_queue_relation getNext getPrev hp (x#xs) qprev qhead =
     (qhead = tcb_ptr_to_ctcb_ptr x \<and>
      (\<exists>tcb. (hp qhead = Some tcb \<and> getPrev tcb = qprev \<and> tcb_queue_relation getNext getPrev hp xs qhead (getNext tcb))))"

abbreviation
  "ep_queue_relation \<equiv> tcb_queue_relation tcbEPNext_C tcbEPPrev_C"

abbreviation
  "sched_queue_relation \<equiv> tcb_queue_relation tcbSchedNext_C tcbSchedPrev_C"

definition
wordSizeCase :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
"wordSizeCase a b \<equiv> (if bitSize (undefined::word32) = 32
        then  a
        else if bitSize (undefined::word32) = 64
        then  b
        else  error []
        )"

primrec
  capBits_C :: "cap_CL \<Rightarrow> nat"
where
  "capBits_C Cap_null_cap = 0"
| "capBits_C (Cap_untyped_cap uc) = unat (capBlockSize_CL uc)"
| "capBits_C (Cap_endpoint_cap ec) = wordSizeCase 4 5"
| "capBits_C (Cap_notification_cap aec) = wordSizeCase 4 5"
| "capBits_C (Cap_cnode_cap cnc) =  wordSizeCase 4 5"
| "capBits_C (Cap_thread_cap tc) = 10"
| "capBits_C (Cap_zombie_cap zc) =  (wordSizeCase 4 5)"

definition
capUntypedPtr_C :: "cap_CL \<Rightarrow> word32" where
  "capUntypedPtr_C cap \<equiv> case cap of
 (Cap_untyped_cap uc) \<Rightarrow> (capBlockSize_CL uc)
 |  Cap_endpoint_cap ep \<Rightarrow> (capEPPtr_CL ep)
 |  Cap_notification_cap ntfn \<Rightarrow> (capNtfnPtr_CL ntfn)
 |  Cap_cnode_cap ccap \<Rightarrow> (capCNodePtr_CL ccap)
 |  Cap_reply_cap rc \<Rightarrow>  (cap_reply_cap_CL.capTCBPtr_CL rc)
 |  Cap_thread_cap tc \<Rightarrow>  (cap_thread_cap_CL.capTCBPtr_CL tc)
 |  Cap_small_frame_cap sfc \<Rightarrow>  (cap_small_frame_cap_CL.capFBasePtr_CL sfc)
 |  Cap_frame_cap fc \<Rightarrow>  (cap_frame_cap_CL.capFBasePtr_CL fc)
 |  Cap_page_table_cap ptc \<Rightarrow>  (capPTBasePtr_CL ptc)
 |  Cap_page_directory_cap pdc \<Rightarrow>  (capPDBasePtr_CL pdc)
 | _ \<Rightarrow> error []"

definition ZombieTCB_C_def:
"ZombieTCB_C \<equiv> bit 5"

definition
  isZombieTCB_C :: "word32 \<Rightarrow> bool" where
 "isZombieTCB_C v \<equiv> v = ZombieTCB_C"

definition
vmrights_to_H :: "word32 \<Rightarrow> vmrights" where
"vmrights_to_H c \<equiv>
  if c = scast Kernel_C.VMNoAccess then VMNoAccess
  else if c = scast Kernel_C.VMKernelOnly then VMKernelOnly
  else if c = scast Kernel_C.VMReadOnly then VMReadOnly
  else VMReadWrite"

(* Force clarity over name collisions *)
abbreviation
  ARMSmallPage :: "vmpage_size" where
 "ARMSmallPage == ARM.ARMSmallPage"
abbreviation
  ARMLargePage :: "vmpage_size" where
 "ARMLargePage == ARM.ARMLargePage"
abbreviation
  ARMSection :: "vmpage_size" where
 "ARMSection == ARM.ARMSection"
abbreviation
  ARMSuperSection :: "vmpage_size" where
 "ARMSuperSection == ARM.ARMSuperSection"

\<comment> \<open>ARMSmallFrame is treated in a separate cap in C,
    so needs special treatment in ccap_relation\<close>
definition
framesize_to_H:: "word32 \<Rightarrow> vmpage_size" where
"framesize_to_H c \<equiv>
  if c = scast Kernel_C.ARMLargePage then ARMLargePage
  else if c = scast Kernel_C.ARMSection then ARMSection
  else ARMSuperSection"

\<comment> \<open>Use this for results of generic_frame_cap_get_capFSize\<close>
definition
gen_framesize_to_H:: "word32 \<Rightarrow> vmpage_size" where
"gen_framesize_to_H c \<equiv>
  if c = scast Kernel_C.ARMSmallPage then ARMSmallPage
  else if c = scast Kernel_C.ARMLargePage then ARMLargePage
  else if c = scast Kernel_C.ARMSection then ARMSection
  else ARMSuperSection"

end

record cte_CL =
  cap_CL :: cap_CL
  cteMDBNode_CL :: mdb_node_CL

context begin interpretation Arch . (*FIXME: arch_split*)

definition
  cte_lift :: "cte_C \<rightharpoonup> cte_CL"
  where
  "cte_lift c \<equiv> case cap_lift (cte_C.cap_C c) of
                     None \<Rightarrow> None
                   | Some cap \<Rightarrow> Some \<lparr> cap_CL = cap,
                                       cteMDBNode_CL = mdb_node_lift (cteMDBNode_C c) \<rparr>"

(* this is slightly weird, but the bitfield generator
   masks everything with the expected bit length.
   So we do that here too. *)
definition
  to_bool_bf :: "'a::len word \<Rightarrow> bool" where
  "to_bool_bf w \<equiv> (w && mask 1) = 1"

lemma to_bool_bf_0 [simp]: "\<not>to_bool_bf 0"
  by (simp add: to_bool_bf_def)

lemma to_bool_bf_1 [simp]: "to_bool_bf 1"
  by (simp add: to_bool_bf_def mask_def)

lemma to_bool_bf_and [simp]:
  "to_bool_bf (a && b) = (to_bool_bf a \<and> to_bool_bf (b::word32))"
  apply (clarsimp simp: to_bool_bf_def)
  apply (rule iffI)
   apply (subst (asm) bang_eq)
   apply (simp add: word_size)
   apply (rule conjI)
    apply (rule word_eqI)
    apply (auto simp add: word_size)[1]
   apply (rule word_eqI)
   apply (auto simp add: word_size)[1]
  apply clarsimp
  apply (rule word_eqI)
  apply (subst (asm) bang_eq)+
  apply (auto simp add: word_size)[1]
  done

lemma to_bool_bf_to_bool_mask:
  "w && mask (Suc 0) = w \<Longrightarrow> to_bool_bf w = to_bool (w::word32)"
  by (metis One_nat_def mask_eq1_nochoice fold_eq_0_to_bool mask_1 to_bool_bf_0 to_bool_bf_def)

definition
  mdb_node_to_H :: "mdb_node_CL \<Rightarrow> mdbnode"
  where
  "mdb_node_to_H n \<equiv> MDB (mdbNext_CL n)
                         (mdbPrev_CL n)
                         (to_bool (mdbRevocable_CL n))
                         (to_bool (mdbFirstBadged_CL n))"

definition
cap_to_H :: "cap_CL \<Rightarrow> capability"
where
"cap_to_H c \<equiv>  case c of
 Cap_null_cap \<Rightarrow> NullCap
 | Cap_zombie_cap zc \<Rightarrow>  (if isZombieTCB_C(capZombieType_CL zc)
                         then
                               (Zombie ((capZombieID_CL zc) && ~~(mask(5)))
                                       (ZombieTCB)
                                       (unat ((capZombieID_CL zc) && mask(5))))
                         else let radix = unat (capZombieType_CL zc) in
                               (Zombie ((capZombieID_CL zc) && ~~(mask (radix+1)))
                                       (ZombieCNode radix)
                                       (unat ((capZombieID_CL zc) && mask(radix+1)))))
 | Cap_cnode_cap ccap \<Rightarrow>
    CNodeCap (capCNodePtr_CL ccap) (unat (capCNodeRadix_CL ccap))
             (capCNodeGuard_CL ccap)
             (unat (capCNodeGuardSize_CL ccap))
 | Cap_untyped_cap uc \<Rightarrow> UntypedCap (to_bool(capIsDevice_CL uc)) (capPtr_CL uc) (unat (capBlockSize_CL uc)) (unat (capFreeIndex_CL uc << 4))
 | Cap_endpoint_cap ec \<Rightarrow>
    EndpointCap (capEPPtr_CL ec) (capEPBadge_CL ec) (to_bool(capCanSend_CL ec)) (to_bool(capCanReceive_CL ec))
                (to_bool(capCanGrant_CL ec)) (to_bool(capCanGrantReply_CL ec))
 | Cap_notification_cap ntfn \<Rightarrow>
    NotificationCap (capNtfnPtr_CL ntfn)(capNtfnBadge_CL ntfn)(to_bool(capNtfnCanSend_CL ntfn))
                     (to_bool(capNtfnCanReceive_CL ntfn))
 | Cap_reply_cap rc \<Rightarrow> ReplyCap (ctcb_ptr_to_tcb_ptr (Ptr (cap_reply_cap_CL.capTCBPtr_CL rc)))
                               (to_bool (capReplyMaster_CL rc)) (to_bool (capReplyCanGrant_CL rc))
 | Cap_thread_cap tc \<Rightarrow>  ThreadCap(ctcb_ptr_to_tcb_ptr (Ptr (cap_thread_cap_CL.capTCBPtr_CL tc)))
 | Cap_irq_handler_cap ihc \<Rightarrow> IRQHandlerCap (ucast(capIRQ_CL ihc))
 | Cap_irq_control_cap \<Rightarrow> IRQControlCap
 | Cap_asid_control_cap \<Rightarrow> ArchObjectCap ASIDControlCap
 | Cap_asid_pool_cap apc \<Rightarrow> ArchObjectCap (ASIDPoolCap (capASIDPool_CL apc) (capASIDBase_CL apc))
 | Cap_small_frame_cap sfc \<Rightarrow> ArchObjectCap (PageCap (to_bool(cap_small_frame_cap_CL.capFIsDevice_CL sfc)) (cap_small_frame_cap_CL.capFBasePtr_CL sfc)
                                            (vmrights_to_H(cap_small_frame_cap_CL.capFVMRights_CL sfc)) (ARMSmallPage)
                                            (if cap_small_frame_cap_CL.capFMappedASIDHigh_CL sfc = 0
                                                \<and> cap_small_frame_cap_CL.capFMappedASIDLow_CL sfc = 0
                                             then None else
                                             Some( (((cap_small_frame_cap_CL.capFMappedASIDHigh_CL sfc)<<asidLowBits) +
                                             (cap_small_frame_cap_CL.capFMappedASIDLow_CL sfc)) ,
                                             cap_small_frame_cap_CL.capFMappedAddress_CL sfc)))
 | Cap_frame_cap fc \<Rightarrow> ArchObjectCap (PageCap (to_bool(capFIsDevice_CL fc)) (capFBasePtr_CL fc)
                                            (vmrights_to_H(capFVMRights_CL fc)) (framesize_to_H(capFSize_CL fc))
                                            (if capFMappedASIDHigh_CL fc = 0
                                               \<and> capFMappedASIDLow_CL fc = 0
                                             then None else
                                             Some( (((capFMappedASIDHigh_CL fc)<<asidLowBits) +
                                             (capFMappedASIDLow_CL fc)),capFMappedAddress_CL fc)))
 | Cap_page_table_cap ptc \<Rightarrow> ArchObjectCap (PageTableCap (capPTBasePtr_CL ptc)
                                          (if to_bool (capPTIsMapped_CL ptc)
                                           then Some( ((capPTMappedASID_CL ptc)),(capPTMappedAddress_CL ptc))
                                           else None))
 | Cap_page_directory_cap pdf \<Rightarrow> ArchObjectCap (PageDirectoryCap (capPDBasePtr_CL pdf)
                                          (if to_bool (capPDIsMapped_CL pdf)
                                           then Some (capPDMappedASID_CL pdf)
                                           else None))
 | Cap_domain_cap \<Rightarrow> DomainCap"

lemmas cap_to_H_simps = cap_to_H_def[split_simps cap_CL.split]

definition
  cte_to_H :: "cte_CL \<Rightarrow> cte"
  where
  "cte_to_H cte \<equiv> CTE (cap_to_H (cap_CL cte)) (mdb_node_to_H (cteMDBNode_CL cte))"

definition
cl_valid_cap :: "cap_CL \<Rightarrow> bool"
where
"cl_valid_cap c \<equiv>
   case c of
     Cap_frame_cap fc \<Rightarrow> ((capFSize_CL fc) \<noteq>  scast Kernel_C.ARMSmallPage)
     | Cap_irq_handler_cap fc \<Rightarrow> ((capIRQ_CL fc) && mask 10 = capIRQ_CL fc)
     | x \<Rightarrow> True"

definition
c_valid_cap :: "cap_C \<Rightarrow> bool"
where
"c_valid_cap c \<equiv> case_option True cl_valid_cap (cap_lift c)"

definition
cl_valid_cte :: "cte_CL \<Rightarrow> bool"
where
"cl_valid_cte c \<equiv>  cl_valid_cap (cap_CL c)"

definition
c_valid_cte :: "cte_C \<Rightarrow> bool"
where
"c_valid_cte c \<equiv>  c_valid_cap (cte_C.cap_C c)"

lemma  c_valid_cap_simps [simp]:
  "cap_get_tag c = scast cap_small_frame_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_thread_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_notification_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_endpoint_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_cnode_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_page_directory_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_asid_control_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_irq_control_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_page_table_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_asid_pool_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_untyped_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_zombie_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_reply_cap \<Longrightarrow> c_valid_cap c"
  "cap_get_tag c = scast cap_null_cap \<Longrightarrow> c_valid_cap c"
  unfolding c_valid_cap_def  cap_lift_def cap_tag_defs
  by (simp add: cl_valid_cap_def)+

lemma ptr_val_tcb_ptr_mask2:
  "is_aligned thread tcbBlockSizeBits
      \<Longrightarrow> ptr_val (tcb_ptr_to_ctcb_ptr thread) && (~~ mask tcbBlockSizeBits)
                  = thread"
  apply (clarsimp simp: tcb_ptr_to_ctcb_ptr_def projectKOs)
  apply (simp add: is_aligned_add_helper ctcb_offset_defs objBits_simps')
  done

section \<open>Domains\<close>

text \<open>
  seL4's build system allows configuration of the number of domains. This means the proofs have to
  work for any number of domains provided it fits into the hard limit of a 8-bit word.

  In the C code, we have the enumerated constant numDomains, one greater than maxDom. In the
  abstract specs, we have the corresponding Platform_Config.numDomains and maxDomain.

  To keep the proofs as general as possible, we avoid unfolding definitions of:
  maxDom, maxDomain, numDomains except in this theory where we need to establish basic properties.

  Unfortunately, array bounds checks coming from the C code use numerical values, meaning we might
  get 0x10 instead of the number of domains, or 0x1000 for numDomains * numPriorities. To solve
  these, the "explicit" lemmas expose direct numbers. They are more risky to deploy, as one could
  prove that 0x5 is less than the number of domains when that's the case, and then the proof will
  break upon reconfiguration.
\<close>

text \<open>The @{text num_domains} enumerated type and constant represent the number of domains.\<close>

value_type num_domains = "numDomains"

context includes no_less_1_simps begin

(* The proofs expect the minimum priority and minimum domain to be zero.
   Note that minDom is unused in the C code. *)
lemma min_prio_dom_sanity:
  "seL4_MinPrio = 0"
  "Kernel_C.minDom = 0"
  by (auto simp: seL4_MinPrio_def minDom_def)

lemma less_numDomains_is_domain[simplified word_size, simplified]:
  "x < numDomains \<Longrightarrow> x < 2 ^ size (y::domain)"
  unfolding Kernel_Config.numDomains_def
  by (simp add: word_size)

lemma sint_numDomains_to_H:
  "sint Kernel_C.numDomains = int Kernel_Config.numDomains"
  by (clarsimp simp: Kernel_C.numDomains_def Kernel_Config.numDomains_def)

lemma unat_numDomains_to_H:
  "unat Kernel_C.numDomains = Kernel_Config.numDomains"
  by (clarsimp simp: Kernel_C.numDomains_def Kernel_Config.numDomains_def)

lemma maxDom_to_H:
  "ucast maxDom = maxDomain"
  by (simp add: maxDomain_def Kernel_C.maxDom_def Kernel_Config.numDomains_def)

lemma maxDom_sgt_0_maxDomain:
  "0 <s maxDom \<longleftrightarrow> 0 < maxDomain"
  unfolding Kernel_C.maxDom_def maxDomain_def Kernel_Config.numDomains_def
  by clarsimp

lemma num_domains_calculation:
  "num_domains = numDomains"
  unfolding num_domains_def by eval

private lemma num_domains_card_explicit:
  "num_domains = CARD(num_domains)"
  by (simp add: num_domains_def)

lemmas num_domains_index_updates =
  index_update[where 'b=num_domains, folded num_domains_card_explicit num_domains_def,
               simplified num_domains_calculation]
  index_update2[where 'b=num_domains, folded num_domains_card_explicit num_domains_def,
                simplified num_domains_calculation]

(* C ArrayGuards will throw these at us and there is no way to avoid a proof of being less than a
   specific number expressed as a word, so we must introduce these. However, being explicit means
   lack of discipline can lead to a violation. *)
lemma numDomains_less_numeric_explicit[simplified num_domains_def One_nat_def]:
  "x < Kernel_Config.numDomains \<Longrightarrow> x < num_domains"
  by (simp add: num_domains_calculation)

lemma numDomains_less_unat_ucast_explicit[simplified num_domains_def]:
  "unat x < Kernel_Config.numDomains \<Longrightarrow> (ucast (x::domain) :: machine_word) < of_nat num_domains"
  apply (rule word_less_nat_alt[THEN iffD2])
  apply transfer
  apply simp
  apply (drule numDomains_less_numeric_explicit, simp add: num_domains_def)
  done

lemmas maxDomain_le_unat_ucast_explicit =
  numDomains_less_unat_ucast_explicit[simplified le_maxDomain_eq_less_numDomains(2)[symmetric],
                                      simplified]

end (* numDomain abstraction definitions and lemmas *)

text \<open>Priorities - not expected to be configurable\<close>

lemma maxPrio_to_H:
  "ucast seL4_MaxPrio = maxPriority"
  by (simp add: maxPriority_def seL4_MaxPrio_def numPriorities_def)

text \<open>TCB scheduling queues\<close>

(* establish and sanity-check relationship between the calculation of the number of TCB queues and
   the size of the array in C *)
value_type num_tcb_queues = "numDomains * numPriorities"

lemma num_tcb_queues_calculation:
  "num_tcb_queues = numDomains * numPriorities"
  unfolding num_tcb_queues_def by eval

abbreviation(input)
  NotificationObject :: sword32
where
  "NotificationObject == seL4_NotificationObject"

abbreviation(input)
  CapTableObject :: sword32
where
  "CapTableObject == seL4_CapTableObject"

abbreviation(input)
  EndpointObject :: sword32
where
  "EndpointObject == seL4_EndpointObject"

abbreviation(input)
  LargePageObject :: sword32
where
  "LargePageObject == seL4_ARM_LargePageObject"

abbreviation(input)
  PageDirectoryObject :: sword32
where
  "PageDirectoryObject == seL4_ARM_PageDirectoryObject"

abbreviation(input)
  PageTableObject :: sword32
where
  "PageTableObject == seL4_ARM_PageTableObject"

abbreviation(input)
  SectionObject :: sword32
where
  "SectionObject == seL4_ARM_SectionObject"

abbreviation(input)
  SmallPageObject :: sword32
where
  "SmallPageObject == seL4_ARM_SmallPageObject"

abbreviation(input)
  SuperSectionObject :: sword32
where
  "SuperSectionObject == seL4_ARM_SuperSectionObject"

abbreviation(input)
  TCBObject :: sword32
where
  "TCBObject == seL4_TCBObject"

abbreviation(input)
  UntypedObject :: sword32
where
  "UntypedObject == seL4_UntypedObject"

abbreviation(input)
  maxPrio :: sword32
where
  "maxPrio == seL4_MaxPrio"

abbreviation(input)
  minPrio :: sword32
where
  "minPrio == seL4_MinPrio"

abbreviation(input)
  nAPIObjects :: sword32
where
  "nAPIObjects == seL4_NonArchObjectTypeCount"

abbreviation(input)
  nObjects :: sword32
where
  "nObjects == seL4_ObjectTypeCount"

abbreviation(input)
  prioInvalid :: sword32
where
  "prioInvalid == seL4_InvalidPrio"

end

end


(*******************************************************************************

  Project: Refining Authenticated Key Agreement with Strong Adversaries

  Module:  pfslvl2.thy (Isabelle/HOL 2016-1)
  ID:      $Id: pfslvl2.thy 133183 2017-01-31 13:55:43Z csprenge $
  Author:  Joseph Lallemand, INRIA Nancy <joseph.lallemand@loria.fr>
           Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Level-2 protocol using ephemeral asymmetric keys to achieve forward secrecy.

  Copyright (c) 2015-2016 Joseph Lallemand and Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>Key Transport Protocol with PFS (L2)\<close>

theory pfslvl2
imports pfslvl1 Channels
begin

declare domIff [simp, iff del]

(**************************************************************************************************)
subsection \<open>State and Events\<close>
(**************************************************************************************************)

text \<open>initial compromise\<close>

consts
  bad_init :: "agent set"

specification (bad_init)
  bad_init_spec: "test_owner \<notin> bad_init \<and> test_partner \<notin> bad_init"
by auto

text \<open>level 2 state\<close>
record l2_state =
  l1_state +
  chan :: "chan set"
  bad :: "agent set"

type_synonym l2_obs = "l2_state"

type_synonym
  l2_pred = "l2_state set"

type_synonym
  l2_trans = "(l2_state \<times> l2_state) set"

text \<open>attacker events\<close>
definition
  l2_dy_fake_msg :: "msg \<Rightarrow> l2_trans"
where
  "l2_dy_fake_msg m \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    m \<in> dy_fake_msg (bad s) (ik s) (chan s) \<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>ik := {m} \<union> ik s\<rparr>
  }"

definition
  l2_dy_fake_chan :: "chan \<Rightarrow> l2_trans"
where
  "l2_dy_fake_chan M \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    M \<in> dy_fake_chan (bad s) (ik s) (chan s)\<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>chan := {M} \<union> chan s\<rparr>
  }"

text \<open>partnering\<close>
fun
  role_comp :: "role_t \<Rightarrow> role_t"
where
  "role_comp Init = Resp"
| "role_comp Resp = Init"

definition
  matching :: "frame \<Rightarrow> frame \<Rightarrow> bool"
where
  "matching sigma sigma' \<equiv> \<forall> x. x \<in> dom sigma \<inter> dom sigma' \<longrightarrow> sigma x = sigma' x"

definition
  partner_runs :: "rid_t \<Rightarrow> rid_t \<Rightarrow> bool"
where
  "partner_runs R R' \<equiv>
    role (guessed_runs R) = role_comp (role (guessed_runs R')) \<and>
    owner (guessed_runs R) = partner (guessed_runs R') \<and>
    owner (guessed_runs R') = partner (guessed_runs R) \<and>
    matching (guessed_frame R) (guessed_frame R')
  "

lemma role_comp_inv [simp]:
  "role_comp (role_comp x) = x"
by (cases x, auto)

lemma role_comp_inv_eq:
  "y = role_comp x \<longleftrightarrow> x = role_comp y"
by (auto elim!: role_comp.elims [OF sym])

definition
  partners :: "rid_t set"
where
  "partners \<equiv> {R. partner_runs test R}"

lemma test_not_partner [simp]:
  "test \<notin> partners"
by (auto simp add: partners_def partner_runs_def, cases "role (guessed_runs test)", auto)

lemma matching_symmetric:
  "matching sigma sigma' \<Longrightarrow> matching sigma' sigma"
by (auto simp add: matching_def)

lemma partner_symmetric:
  "partner_runs R R' \<Longrightarrow> partner_runs R' R"
by (auto simp add: partner_runs_def matching_symmetric)

lemma partner_unique:
  "partner_runs R R'' \<Longrightarrow> partner_runs R R' \<Longrightarrow> R' = R''"
proof -
  assume H':"partner_runs R R'"
  then have Hm': "matching (guessed_frame R) (guessed_frame R')"
    by (auto simp add: partner_runs_def)
  assume H'':"partner_runs R R''"
  then have Hm'': "matching (guessed_frame R) (guessed_frame R'')"
    by (auto simp add: partner_runs_def)
  show ?thesis
    proof (cases "role (guessed_runs R')")
      case Init
      with H' partner_symmetric [OF H''] have Hrole:"role (guessed_runs R) = Resp"
                                                    "role (guessed_runs R'') = Init"
        by (auto simp add: partner_runs_def)
      with Init Hm' have "guessed_frame R xpkE = Some (epubKF (R'$kE))"
        by (simp add: matching_def)
      moreover from Hrole Hm'' have "guessed_frame R xpkE = Some (epubKF (R''$kE))"
        by (simp add: matching_def)
      ultimately show ?thesis by simp
    next
      case Resp
      with H' partner_symmetric [OF H''] have Hrole:"role (guessed_runs R) = Init"
                                                    "role (guessed_runs R'') = Resp"
        by (auto simp add: partner_runs_def)
      with Resp Hm' have "guessed_frame R xsk = Some (NonceF (R'$sk))"
        by (simp add: matching_def)
      moreover from Hrole Hm'' have "guessed_frame R xsk = Some (NonceF (R''$sk))"
        by (simp add: matching_def)
      ultimately show ?thesis by simp
    qed
qed

lemma partner_test:
  "R \<in> partners \<Longrightarrow> partner_runs R R' \<Longrightarrow> R' = test"
by (auto intro!:partner_unique simp add:partners_def partner_symmetric)

text \<open>compromising events\<close>
definition
  l2_lkr_others :: "agent \<Rightarrow> l2_trans"
where
  "l2_lkr_others A \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    A \<noteq> test_owner \<and>
    A \<noteq> test_partner \<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>bad := {A} \<union> bad s\<rparr>
  }"

definition
  l2_lkr_actor :: "agent \<Rightarrow> l2_trans"
where
  "l2_lkr_actor A \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    A = test_owner \<and>
    A \<noteq> test_partner \<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>bad := {A} \<union> bad s\<rparr>
  }"

definition
  l2_lkr_after :: "agent \<Rightarrow> l2_trans"
where
  "l2_lkr_after A \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    test_ended s \<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>bad := {A} \<union> bad s\<rparr>
  }"

definition
  l2_skr :: "rid_t \<Rightarrow> msg \<Rightarrow> l2_trans"
where
  "l2_skr R K \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    R \<noteq> test \<and> R \<notin> partners \<and>
    in_progress (progress s R) xsk \<and>
    guessed_frame R xsk = Some K \<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>ik := {K} \<union> ik s\<rparr>
  }"

text \<open>protocol events\<close>
definition
    l2_step1 :: "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> l2_trans"
where
  "l2_step1 Ra A B \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    Ra \<notin> dom (progress s) \<and>
    guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
    \<comment> \<open>actions:\<close>
    s' = s\<lparr>
      progress := (progress s)(Ra \<mapsto> {xpkE, xskE}),
      chan := {Auth A B (\<langle>Number 0, epubKF (Ra$kE)\<rangle>)} \<union> (chan s)
      \<rparr>
  }"

definition
  l2_step2 :: "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> msg \<Rightarrow> l2_trans"
where
  "l2_step2 Rb A B KE \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<and>
    Rb \<notin> dom (progress s) \<and>
    guessed_frame Rb xpkE = Some KE \<and>
    Auth A B \<langle>Number 0, KE\<rangle> \<in> chan s \<and>
    \<comment> \<open>actions:\<close>
    s' = s\<lparr>
      progress := (progress s)(Rb \<mapsto> {xpkE, xsk}),
      chan := {Auth B A (Aenc (NonceF (Rb$sk)) KE)} \<union> (chan s),
      signals := if can_signal s A B then
                   addSignal (signals s) (Running A B \<langle>KE, NonceF (Rb$sk)\<rangle>)
                 else
                   signals s,
      secret := {x. x = NonceF (Rb$sk) \<and> Rb = test} \<union> secret s
         \<rparr>
  }"

definition
  l2_step3 :: "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> msg \<Rightarrow> l2_trans"
where
  "l2_step3 Ra A B K \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
    progress s Ra = Some {xpkE, xskE} \<and>
    guessed_frame Ra xsk = Some K \<and>
    Auth B A (Aenc K (epubKF (Ra$kE))) \<in> chan s \<and>
    \<comment> \<open>actions:\<close>
    s' = s\<lparr> progress := (progress s)(Ra \<mapsto> {xpkE, xskE, xsk}),
            signals := if can_signal s A B then
                         addSignal (signals s) (Commit A B \<langle>epubKF (Ra$kE),K\<rangle>)
                       else
                         signals s,
            secret := {x. x = K \<and> Ra = test} \<union> secret s
          \<rparr>
  }"

text \<open>specification\<close>
definition
  l2_init :: "l2_state set"
where
  "l2_init \<equiv> { \<lparr>
    ik = {},
    secret = {},
    progress = Map.empty,
    signals = \<lambda>x. 0,
    chan = {},
    bad = bad_init
    \<rparr>}"

definition
  l2_trans :: "l2_trans" where
  "l2_trans \<equiv> (\<Union>m M KE Rb Ra A B K.
     l2_step1 Ra A B \<union>
     l2_step2 Rb A B KE \<union>
     l2_step3 Ra A B m \<union>
     l2_dy_fake_chan M \<union>
     l2_dy_fake_msg m \<union>
     l2_lkr_others A \<union>
     l2_lkr_after A \<union>
     l2_skr Ra K \<union>
     Id
  )"

definition
  l2 :: "(l2_state, l2_obs) spec" where
  "l2 \<equiv> \<lparr>
    init = l2_init,
    trans = l2_trans,
    obs = id
  \<rparr>"

lemmas l2_loc_defs =
  l2_step1_def l2_step2_def l2_step3_def
  l2_def l2_init_def l2_trans_def
  l2_dy_fake_chan_def l2_dy_fake_msg_def
  l2_lkr_after_def l2_lkr_others_def l2_skr_def

lemmas l2_defs = l2_loc_defs ik_dy_def

lemmas l2_nostep_defs = l2_def l2_init_def l2_trans_def

lemma l2_obs_id [simp]: "obs l2 = id"
by (simp add: l2_def)

text \<open>Once a run is finished, it stays finished, therefore if the test is not finished at some
point then it was not finished before either\<close>
declare domIff [iff]
lemma l2_run_ended_trans:
  "run_ended (progress s R) \<Longrightarrow>
   (s, s') \<in> trans l2 \<Longrightarrow>
   run_ended (progress s' R)"
apply (auto simp add: l2_nostep_defs)
apply (simp add: l2_defs, fast ?)+
done
declare domIff [iff del]

lemma l2_can_signal_trans:
  "can_signal s' A B \<Longrightarrow>
  (s, s') \<in> trans l2 \<Longrightarrow>
  can_signal s A B"
by (auto simp add: can_signal_def l2_run_ended_trans)

(**************************************************************************************************)
subsection \<open>Invariants\<close>
(**************************************************************************************************)

subsubsection \<open>inv1\<close>
(**************************************************************************************************)

text \<open>If @{term "can_signal s A B"} (i.e., @{term "A"}, @{term "B"} are the test session
agents and the test is not finished), then @{term "A"}, @{term "B"} are honest.\<close>

definition
  l2_inv1 :: "l2_state set"
where
  "l2_inv1 \<equiv> {s. \<forall>A B.
    can_signal s A B \<longrightarrow>
    A \<notin> bad s \<and> B \<notin> bad s
  }"

lemmas l2_inv1I = l2_inv1_def [THEN setc_def_to_intro, rule_format]
lemmas l2_inv1E [elim] = l2_inv1_def [THEN setc_def_to_elim, rule_format]
lemmas l2_inv1D = l2_inv1_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma l2_inv1_init [iff]:
  "init l2 \<subseteq> l2_inv1"
by (auto simp add: l2_def l2_init_def l2_inv1_def can_signal_def bad_init_spec)

lemma l2_inv1_trans [iff]:
  "{l2_inv1} trans l2 {> l2_inv1}"
proof (auto simp add: PO_hoare_defs intro!: l2_inv1I  del: conjI)
  fix s' s :: l2_state
  fix A B
  assume HI:"s \<in> l2_inv1"
  assume HT:"(s, s') \<in> trans l2"
  assume "can_signal s' A B"
  with HT have HS:"can_signal s A B"
    by (auto simp add: l2_can_signal_trans)
  with HI have "A \<notin> bad s \<and> B \<notin> bad s"
    by fast
  with HS HT show "A \<notin> bad s' \<and> B \<notin> bad s'"
    by (auto simp add: l2_nostep_defs can_signal_def)
       (simp_all add: l2_defs)
qed

lemma PO_l2_inv1 [iff]: "reach l2 \<subseteq> l2_inv1"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv2 (authentication guard)\<close>
(**************************************************************************************************)

text \<open>
  If @{term "Auth A B (\<langle>Number 0, KE\<rangle>) \<in> chan s"} and @{term "A"}, @{term "B"} are honest
  then the message has indeed been sent by an initiator run (with the right agents etc.)\<close>

definition
  l2_inv2 :: "l2_state set"
where
  "l2_inv2 \<equiv> {s. \<forall> A B KE.
    Auth A B \<langle>Number 0, KE\<rangle> \<in> chan s \<longrightarrow>
    A \<notin> bad s \<and> B \<notin> bad s \<longrightarrow>
    (\<exists> Ra.
      guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
      in_progress (progress s Ra) xpkE \<and>
      KE = epubKF (Ra$kE))
  }"

lemmas l2_inv2I = l2_inv2_def [THEN setc_def_to_intro, rule_format]
lemmas l2_inv2E [elim] = l2_inv2_def [THEN setc_def_to_elim, rule_format]
lemmas l2_inv2D = l2_inv2_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma l2_inv2_init [iff]:
  "init l2 \<subseteq> l2_inv2"
by (auto simp add: l2_def l2_init_def l2_inv2_def)

lemma l2_inv2_trans [iff]:
  "{l2_inv2} trans l2 {> l2_inv2}"
apply (auto simp add: PO_hoare_defs l2_nostep_defs intro!: l2_inv2I)
apply (auto simp add: l2_defs dy_fake_chan_def)
apply force+
done

lemma PO_l2_inv2 [iff]: "reach l2 \<subseteq> l2_inv2"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv3 (authentication guard)\<close>
(**************************************************************************************************)

text \<open>If @{term "Auth B A (Aenc K (epubKF (Ra $ kE))) \<in> chan s"}
 and @{term "A"}, @{term "B"} are honest then the message has indeed been sent by a
 responder run (etc).\<close>

definition
  l2_inv3 :: "l2_state set"
where
  "l2_inv3 \<equiv> {s. \<forall> Ra A B K.
     Auth B A (Aenc K (epubKF (Ra $ kE))) \<in> chan s \<longrightarrow>
     A \<notin> bad s \<and> B \<notin> bad s \<longrightarrow>
     (\<exists> Rb.
       guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<and>
       progress s Rb = Some {xpkE, xsk} \<and>
       guessed_frame Rb xpkE = Some (epubKF (Ra$kE))\<and>
       K = NonceF (Rb$sk)
     )
    }"

lemmas l2_inv3I = l2_inv3_def [THEN setc_def_to_intro, rule_format]
lemmas l2_inv3E [elim] = l2_inv3_def [THEN setc_def_to_elim, rule_format]
lemmas l2_inv3D = l2_inv3_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma l2_inv3_init [iff]:
  "init l2 \<subseteq> l2_inv3"
by (auto simp add: l2_def l2_init_def l2_inv3_def)

lemma l2_inv3_trans [iff]:
  "{l2_inv3} trans l2 {> l2_inv3}"
apply (auto simp add: PO_hoare_defs l2_nostep_defs intro!: l2_inv3I)
apply (auto simp add: l2_defs dy_fake_chan_def)
apply (simp_all add: domIff)
apply force+
done

lemma PO_l2_inv3 [iff]: "reach l2 \<subseteq> l2_inv3"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv4\<close>
(**************************************************************************************************)

text \<open>If the test run is finished and has the session key generated by a run,
  then this run is also finished.\<close>

definition
  l2_inv4 :: "l2_state set"
where
  "l2_inv4 \<equiv> {s. \<forall>Rb.
    in_progress (progress s test) xsk \<longrightarrow>
    guessed_frame test xsk = Some (NonceF (Rb$sk)) \<longrightarrow>
    progress s Rb = Some {xpkE, xsk}
  }"

lemmas l2_inv4I = l2_inv4_def [THEN setc_def_to_intro, rule_format]
lemmas l2_inv4E [elim] = l2_inv4_def [THEN setc_def_to_elim, rule_format]
lemmas l2_inv4D = l2_inv4_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma l2_inv4_init [iff]:
  "init l2 \<subseteq> l2_inv4"
by (auto simp add: l2_def l2_init_def l2_inv4_def)

lemma l2_inv4_trans [iff]:
  "{l2_inv4 \<inter> l2_inv3 \<inter> l2_inv1} trans l2 {> l2_inv4}"
apply (auto simp add: PO_hoare_defs l2_nostep_defs intro!: l2_inv4I)
apply (auto simp add: l2_defs dy_fake_chan_def)
apply (auto dest!: l2_inv4D simp add: domIff can_signal_def)
apply (auto dest!: l2_inv3D intro!:l2_inv1D simp add: can_signal_def)
done

lemma PO_l2_inv4 [iff]: "reach l2 \<subseteq> l2_inv4"
by (rule_tac J="l2_inv3 \<inter> l2_inv1" in inv_rule_incr) (auto)

subsubsection \<open>inv5\<close>
(**************************************************************************************************)

text \<open>The only confidential or secure messages on the channel have been put there
  by the attacker.\<close>

definition
  l2_inv5 :: "l2_state set"
where
  "l2_inv5 \<equiv> {s. \<forall>A B M.
    (Confid A B M \<in> chan s \<or> Secure A B M \<in> chan s) \<longrightarrow>
    M \<in> dy_fake_msg (bad s) (ik s) (chan s)
  }"

lemmas l2_inv5I = l2_inv5_def [THEN setc_def_to_intro, rule_format]
lemmas l2_inv5E [elim] = l2_inv5_def [THEN setc_def_to_elim, rule_format]
lemmas l2_inv5D = l2_inv5_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma l2_inv5_init [iff]:
  "init l2 \<subseteq> l2_inv5"
by (auto simp add: l2_def l2_init_def l2_inv5_def)

lemma l2_inv5_trans [iff]:
  "{l2_inv5} trans l2 {> l2_inv5}"
apply (auto simp add: PO_hoare_defs l2_nostep_defs intro!: l2_inv5I)
apply (auto simp add: l2_defs dy_fake_chan_def intro: l2_inv5D dy_fake_msg_monotone)
done

lemma PO_l2_inv5 [iff]: "reach l2 \<subseteq> l2_inv5"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv6\<close>
(**************************************************************************************************)

text \<open>If an initiator @{term "Ra"} knows a session key @{term "K"}, then the attacker
  knows @{term "Aenc K (epubKF (Ra$kE))"}.\<close>

definition
  l2_inv6 :: "l2_state set"
where
  "l2_inv6 \<equiv> {s. \<forall>Ra K.
    role (guessed_runs Ra) = Init \<longrightarrow>
    in_progress (progress s Ra) xsk \<longrightarrow>
    guessed_frame Ra xsk = Some K \<longrightarrow>
    Aenc K (epubKF (Ra$kE)) \<in> extr (bad s) (ik s) (chan s)
  }"

lemmas l2_inv6I = l2_inv6_def [THEN setc_def_to_intro, rule_format]
lemmas l2_inv6E [elim] = l2_inv6_def [THEN setc_def_to_elim, rule_format]
lemmas l2_inv6D = l2_inv6_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma l2_inv6_init [iff]:
  "init l2 \<subseteq> l2_inv6"
by (auto simp add: l2_def l2_init_def l2_inv6_def)

lemma l2_inv6_trans [iff]:
  "{l2_inv6} trans l2 {> l2_inv6}"
apply (auto simp add: PO_hoare_defs l2_nostep_defs intro!: l2_inv6I)
apply (auto simp add: l2_defs dy_fake_chan_def dest: l2_inv6D)
done

lemma PO_l2_inv6 [iff]: "reach l2 \<subseteq> l2_inv6"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv7\<close>
(**************************************************************************************************)

text \<open>Form of the messages in @{term "extr (bad s) (ik s) (chan s)"} =
  @{term "synth (analz (generators))"}.\<close>

abbreviation
  "generators \<equiv> range epubK \<union>
         {Aenc (NonceF (Rb $ sk)) (epubKF (Ra$kE)) |Ra Rb. \<exists> A B.
            guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
            guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<and>
            guessed_frame Rb xpkE = Some (epubKF (Ra$kE))} \<union>
         {NonceF (R $ sk) |R. R \<noteq> test \<and> R \<notin> partners}"

lemma analz_generators: "analz generators = generators"
by (rule, rule, erule analz.induct, auto)

definition
  l2_inv7 :: "l2_state set"
where
  "l2_inv7 \<equiv> {s.
    extr (bad s) (ik s) (chan s) \<subseteq>
      synth (analz (generators))
  }"

lemmas l2_inv7I = l2_inv7_def [THEN setc_def_to_intro, rule_format]
lemmas l2_inv7E [elim] = l2_inv7_def [THEN setc_def_to_elim, rule_format]
lemmas l2_inv7D = l2_inv7_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma l2_inv7_step1:
  "{l2_inv7} l2_step1 Ra A B {> l2_inv7}"
apply (auto simp add: PO_hoare_defs l2_defs intro!: l2_inv7I)
apply (auto dest: l2_inv7D [THEN [2] rev_subsetD])+
done

lemma l2_inv7_step2:
  "{l2_inv1 \<inter> l2_inv2 \<inter> l2_inv4 \<inter> l2_inv7} l2_step2 Rb A B KE {> l2_inv7}"
proof (auto simp add: PO_hoare_defs l2_nostep_defs intro!: l2_inv7I)
  fix s' s :: l2_state
  fix x
  assume Hx:"x \<in> extr (bad s') (ik s') (chan s')"
  assume Hi:"s \<in> l2_inv7"
  assume Hi':"s \<in> l2_inv1"
  assume Hi'':"s \<in> l2_inv2"
  assume Hi''':"s \<in> l2_inv4"
  assume Hs:"(s, s') \<in> l2_step2 Rb A B KE"
  from Hx Hi Hs show " x \<in> synth (analz (generators))"
    proof (auto simp add: l2_defs dest: l2_inv7D [THEN [2] rev_subsetD])
      txt \<open>first case: @{term "can_signal s A B"}, which implies that @{term "A"}, @{term "B"} are
      honest, and therefore the public key received by @{term "B"} is not from the attacker,
      which proves that the
      message added to the channel is in @{term "{z. \<exists>x k. z = Aenc x (epubKF k)}"}\<close>
      assume Hc:"Auth A B \<langle>Number 0, KE\<rangle> \<in> chan s"
      assume HRb:"guessed_runs Rb = \<lparr>role = Resp, owner = B, partner = A\<rparr>"
                 "guessed_frame Rb xpkE = Some KE"
      assume Hcs: "can_signal s A B"
      from Hcs Hi' have "A \<notin> bad s \<and> B \<notin> bad s"
        by auto
      with Hc Hi'' obtain Ra where "KE = epubKF (Ra$kE)"
                             and "guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr>"
        by (auto dest: l2_inv2D)
      with HRb show "Aenc (NonceF (Rb $ sk)) KE \<in> synth (analz generators)"
        by blast
    next
      txt \<open>second case: @{term "\<not> can_signal s A B"}. We show that @{term "Rb"} is not test and
        not a partner:
      - @{term "Rb"} is not test because in that case test is not finished and
        @{term "A"}, @{term "B"} are the test agents, thus
        @{term "can_signal s A B"}
      - @{term "Rb"} is not a partner for the same reason
      therefore the message added to the channel can be constructed from
      @{term "{NonceF (R $ sk) |R. R \<noteq> test \<and> R \<notin> partners}"}\<close>
      assume Hc:"Auth A B \<langle>Number 0, KE\<rangle> \<in> chan s"
      assume Hcs:"\<not> can_signal s A B"
      assume HRb:"Rb \<notin> dom (progress s)"
                  "guessed_runs Rb = \<lparr>role = Resp, owner = B, partner = A\<rparr>"
      from Hcs HRb have "Rb \<noteq> test"
        by (auto simp add: can_signal_def domIff)
      moreover from HRb Hi''' Hcs have "Rb \<notin> partners"
        by (clarify, auto simp add: partners_def partner_runs_def can_signal_def matching_def domIff)
      moreover from Hc Hi have "KE \<in> synth (analz (generators))"
        by auto
      ultimately show "Aenc (NonceF (Rb $ sk)) KE \<in> synth (analz (generators))"
        by blast
    qed
qed

lemma l2_inv7_step3:
  "{l2_inv7} l2_step3 Rb A B K {> l2_inv7}"
by (auto simp add: PO_hoare_defs l2_defs intro!: l2_inv7I dest: l2_inv7D [THEN [2] rev_subsetD])

lemma l2_inv7_dy_fake_msg:
  "{l2_inv7} l2_dy_fake_msg M {> l2_inv7}"
by (auto simp add: PO_hoare_defs l2_defs extr_insert_IK_eq
            intro!: l2_inv7I
            elim!: l2_inv7E dy_fake_msg_extr [THEN [2] rev_subsetD])

lemma l2_inv7_dy_fake_chan:
  "{l2_inv7} l2_dy_fake_chan M {> l2_inv7}"
by (auto simp add: PO_hoare_defs l2_defs
            intro!: l2_inv7I
            dest:  dy_fake_chan_extr_insert [THEN [2] rev_subsetD]
            elim!: l2_inv7E dy_fake_msg_extr [THEN [2] rev_subsetD])

lemma l2_inv7_lkr_others:
  "{l2_inv7 \<inter> l2_inv5} l2_lkr_others A {> l2_inv7}"
apply (auto simp add: PO_hoare_defs l2_defs
            intro!: l2_inv7I
            dest!: extr_insert_bad [THEN [2] rev_subsetD]
            elim!: l2_inv7E l2_inv5E)
apply (auto dest: dy_fake_msg_extr [THEN [2] rev_subsetD])
done

lemma l2_inv7_lkr_after:
  "{l2_inv7 \<inter> l2_inv5} l2_lkr_after A {> l2_inv7}"
apply (auto simp add: PO_hoare_defs l2_defs
            intro!: l2_inv7I
            dest!: extr_insert_bad [THEN [2] rev_subsetD]
            elim!: l2_inv7E l2_inv5E)
apply (auto dest: dy_fake_msg_extr [THEN [2] rev_subsetD])
done

lemma l2_inv7_skr:
  "{l2_inv7 \<inter> l2_inv6} l2_skr R K {> l2_inv7}"
proof (auto simp add: PO_hoare_defs l2_defs extr_insert_IK_eq intro!: l2_inv7I,
       auto elim: l2_inv7D [THEN subsetD])
  fix s
  assume HRtest: "R \<noteq> test" "R \<notin> partners"
  assume Hi: "s \<in> l2_inv7"
  assume Hi': "s \<in> l2_inv6"
  assume HRsk: "in_progress (progress s R) xsk" "guessed_frame R xsk = Some K"
  show "K \<in> synth (analz generators)"
    proof (cases "role (guessed_runs R)")
      txt \<open>first case: @{term "R"} is the initiator, then @{term "Aenc K epk"}
        is in @{term "extr (bad s) (ik s) (chan s)"} (by invariant)
        therefore either @{term "K \<in> synth (analz generators)"} which proves the goal
        or @{term "Aenc K epk \<in> generators"}, which means that
        @{term "K = NonceF (Rb$sk)"} where @{term "R"} and @{term "Rb"} are matching
        and since @{term "R"} is not partner or test, neither is
        @{term "Rb"}, and therefore @{term "K \<in> synth (analz (generators))"}\<close>
      assume HRI: "role (guessed_runs R) = Init"
      with HRsk Hi Hi' have "Aenc K (epubKF (R$kE)) \<in> synth (analz generators)"
        by (auto dest!: l2_inv7D)
      then have "K \<in> synth (analz generators) \<or> Aenc K (epubKF (R$kE)) \<in> generators"
        by (rule synth.cases, simp_all, simp add: analz_generators)
      with HRsk show ?thesis
        proof auto
          fix Rb A B
          assume HR: "guessed_runs R = \<lparr>role = Init, owner = A, partner = B\<rparr>"
                     "guessed_frame R xsk = Some (NonceF (Rb $ sk))"
          assume HRb: "guessed_runs Rb = \<lparr>role = Resp, owner = B, partner = A\<rparr>"
                      "guessed_frame Rb xpkE = Some (epubKF (R $ kE))"
          from HR HRb have "partner_runs Rb R"
            by (auto simp add: partner_runs_def matching_def)
          with HRtest have "Rb \<noteq> test \<and> Rb \<notin> partners"
            by (auto dest: partner_test, simp add:partners_def)
          then show "NonceF (Rb $ sk) \<in> analz generators"
            by blast
        qed
    next
      txt \<open>second case: @{term "R"} is the Responder, then @{term "K"} is @{term "R$sk"}
        which is in @{term "synth (analz (generators))"}
        since @{term "R"} is not test or partner\<close>
      assume HRI: "role (guessed_runs R) = Resp"
      with HRsk HRtest show ?thesis
        by auto
    qed
qed

lemmas l2_inv7_trans_aux =
  l2_inv7_step1 l2_inv7_step2 l2_inv7_step3
  l2_inv7_dy_fake_msg l2_inv7_dy_fake_chan
  l2_inv7_lkr_others l2_inv7_lkr_after l2_inv7_skr

lemma l2_inv7_trans [iff]:
  "{l2_inv7 \<inter> l2_inv1 \<inter> l2_inv2 \<inter> l2_inv4 \<inter> l2_inv5 \<inter> l2_inv6} trans l2 {> l2_inv7}"
by (auto simp add: l2_nostep_defs intro:l2_inv7_trans_aux)

lemma PO_l2_inv7 [iff]: "reach l2 \<subseteq> l2_inv7"
by (rule_tac J="l2_inv1 \<inter> l2_inv2 \<inter> l2_inv4 \<inter> l2_inv5 \<inter> l2_inv6" in inv_rule_incr) (auto)

lemma l2_inv7_aux:
  "NonceF (R$sk) \<in> analz (ik s) \<Longrightarrow> s \<in> l2_inv7 \<Longrightarrow> R \<noteq> test \<and> R \<notin> partners"
proof -
  assume H:"s \<in> l2_inv7" and H':"NonceF (R$sk) \<in> analz (ik s)"
  then have H'':"NonceF (R$sk) \<in> analz (extr (bad s) (ik s) (chan s))"
    by (auto elim: analz_monotone)
  from H have "analz (extr (bad s) (ik s) (chan s)) \<subseteq> analz (synth (analz generators))"
    by (blast dest: analz_mono intro: l2_inv7D)
  with H'' have "NonceF (R$sk) \<in> analz generators"
    by auto
  then have "NonceF (R$sk) \<in> generators"
    by (simp add: analz_generators)
  then show ?thesis
    by auto
qed

subsubsection \<open>inv8\<close>
text \<open>Form of the secrets = nonces generated by test or partners\<close>
(**************************************************************************************************)
definition
  l2_inv8 :: "l2_state set"
where
  "l2_inv8 \<equiv> {s.
    secret s \<subseteq> {NonceF (R$sk) | R. R = test \<or> R \<in> partners}
  }"

lemmas l2_inv8I = l2_inv8_def [THEN setc_def_to_intro, rule_format]
lemmas l2_inv8E [elim] = l2_inv8_def [THEN setc_def_to_elim, rule_format]
lemmas l2_inv8D = l2_inv8_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma l2_inv8_init [iff]:
  "init l2 \<subseteq> l2_inv8"
by (auto simp add: l2_def l2_init_def l2_inv8_def)

lemma PO_l2_inv8 [iff]: "reach l2 \<subseteq> l2_inv8"
by (rule_tac J="l2_inv1 \<inter> l2_inv3" in inv_rule_incr) (auto)

(**************************************************************************************************)
subsection \<open>Refinement\<close>
(**************************************************************************************************)

text \<open>mediator function\<close>
definition
  med12s :: "l2_obs \<Rightarrow> l1_obs"
where
  "med12s t \<equiv> \<lparr>
    ik = ik t,
    secret = secret t,
    progress = progress t,
    signals = signals t
    \<rparr>"

text \<open>relation between states\<close>
definition
  R12s :: "(l1_state * l2_state) set"
where
  "R12s \<equiv> {(s,s').
    s = med12s s'
    }"

lemmas R12s_defs = R12s_def med12s_def

lemma can_signal_R12 [simp]:
  "(s1, s2) \<in> R12s \<Longrightarrow>
   can_signal s1 A B \<longleftrightarrow> can_signal s2 A B"
by (auto simp add: can_signal_def R12s_defs)

text \<open>protocol events\<close>

lemma l2_step1_refines_step1:
  "{R12s} l1_step1 Ra A B, l2_step1 Ra A B {>R12s}"
by (auto simp add: PO_rhoare_defs R12s_defs l1_step1_def l2_step1_def)

text \<open>auxiliary lemma needed to prove that the nonce received by the test in step 3
comes from a partner\<close>
lemma l2_step3_partners:
  "guessed_runs test = \<lparr>role = Init, owner = A, partner = B\<rparr> \<Longrightarrow>
   guessed_frame test xsk = Some (NonceF (Rb$sk)) \<Longrightarrow>
   guessed_runs Rb = \<lparr>role = Resp, owner = B, partner = A\<rparr> \<Longrightarrow>
   guessed_frame Rb xpkE = Some (epubKF (test $ kE)) \<Longrightarrow>
   Rb \<in> partners"
by (auto simp add: partners_def partner_runs_def matching_def)

lemma l2_step3_refines_step3:
  "{R12s \<inter> UNIV \<times> (l2_inv1 \<inter> l2_inv3 \<inter> l2_inv7)}
      l1_step3 Ra A B K, l2_step3 Ra A B K
   {>R12s}"
apply (auto simp add: PO_rhoare_defs R12s_defs l1_step3_def, simp_all add: l2_step3_def)
apply (auto dest!: l2_inv3D l2_inv7_aux intro:l2_step3_partners)
apply (auto simp add: can_signal_def)
done

text \<open>attacker events\<close>
lemma l2_dy_fake_chan_refines_skip:
  "{R12s} Id, l2_dy_fake_chan M {>R12s}"
by (auto simp add: PO_rhoare_defs R12s_defs l2_defs)

lemma l2_dy_fake_msg_refines_learn:
  "{R12s \<inter> UNIV \<times> l2_inv7 \<inter> UNIV \<times> l2_inv8} l1_learn m, l2_dy_fake_msg m {>R12s}"
apply (auto simp add: PO_rhoare_defs R12s_defs l2_loc_defs l1_defs)
apply (drule Fake_insert_dy_fake_msg, erule l2_inv7D)
apply (auto simp add: analz_generators dest!: l2_inv8D)
apply (drule subsetD, simp, drule subsetD, simp, auto) (*change this ?*)
done

text \<open>compromising events\<close>
lemma l2_lkr_others_refines_skip:
  "{R12s} Id, l2_lkr_others A {>R12s}"
by (auto simp add: PO_rhoare_defs R12s_defs l2_loc_defs l1_defs)

lemma l2_lkr_after_refines_skip:
  "{R12s} Id, l2_lkr_after A {>R12s}"
by (auto simp add: PO_rhoare_defs R12s_defs l2_loc_defs l1_defs)

lemma l2_skr_refines_learn:
  "{R12s \<inter> UNIV \<times> l2_inv7 \<inter> UNIV \<times> l2_inv6 \<inter> UNIV \<times> l2_inv8} l1_learn K, l2_skr R K {>R12s}"
proof (auto simp add: PO_rhoare_defs R12s_defs l2_loc_defs l1_defs)
  fix s :: l2_state fix x
  assume H:"s \<in> l2_inv7" "s \<in> l2_inv6"
         "R \<notin> partners" "R \<noteq> test" "run_ended (progress s R)" "guessed_frame R xsk = Some K"
  assume Hx:"x \<in> synth (analz (insert K (ik s)))"
  assume "x \<in> secret s" "s \<in> l2_inv8"
  then obtain R where "x = NonceF (R$sk)" and "R = test \<or> R \<in> partners"
    by auto
  moreover from H have "s \<lparr>ik := insert K (ik s)\<rparr> \<in> l2_inv7"
    by (auto intro: hoare_apply [OF l2_inv7_skr] simp add: l2_defs)
  ultimately show False using Hx
    by (auto dest: l2_inv7_aux [rotated 1])
qed

text \<open>refinement proof\<close>
lemmas l2_trans_refines_l1_trans =
  l2_dy_fake_msg_refines_learn l2_dy_fake_chan_refines_skip
  l2_lkr_others_refines_skip l2_lkr_after_refines_skip l2_skr_refines_learn
  l2_step1_refines_step1 l2_step2_refines_step2 l2_step3_refines_step3

lemma l2_refines_init_l1 [iff]:
  "init l2 \<subseteq> R12s `` (init l1)"
by (auto simp add: R12s_defs l1_defs l2_loc_defs)

lemma l2_refines_trans_l1 [iff]:
  "{R12s \<inter> (UNIV \<times> (l2_inv1 \<inter> l2_inv2 \<inter> l2_inv3 \<inter> l2_inv6 \<inter> l2_inv7 \<inter> l2_inv8))} trans l1, trans l2 {> R12s}"
by (auto 0 3 simp add: l1_def l2_def l1_trans_def l2_trans_def
             intro!: l2_trans_refines_l1_trans)

lemma PO_obs_consistent_R12s [iff]:
  "obs_consistent R12s med12s l1 l2"
by (auto simp add: obs_consistent_def R12s_def med12s_def l2_defs)

lemma l2_refines_l1 [iff]:
  "refines
     (R12s \<inter>
      (reach l1 \<times> (l2_inv1 \<inter> l2_inv2 \<inter> l2_inv3 \<inter> l2_inv4 \<inter> l2_inv5 \<inter> l2_inv6 \<inter> l2_inv7 \<inter> l2_inv8)))
     med12s l1 l2"
by (rule Refinement_using_invariants, auto)

lemma l2_implements_l1 [iff]:
  "implements med12s l1 l2"
by (rule refinement_soundness) (auto)

subsection \<open>Derived invariants\<close>
(**************************************************************************************************)
text \<open>
  We want to prove @{term "l2_secrecy"}:
  @{term "dy_fake_msg (bad s) (ik s) (chan s) \<inter> secret s = {}"}
  but by refinement we only get @{term "l2_partial_secrecy"}:
  @{term "synth (analz (ik s)) \<inter> secret s = {}"}
  This is fine, since a message in
  @{term "dy_fake_msg (bad s) (ik s) (chan s)"} could be added to @{term "ik s"},
  and @{term "l2_partial_secrecy"} would still hold for this new state.
\<close>

definition
  l2_partial_secrecy :: "('a l2_state_scheme) set"
where
  "l2_partial_secrecy \<equiv> {s. synth (analz (ik s)) \<inter> secret s = {}}"

lemma l2_obs_partial_secrecy [iff]: "oreach l2 \<subseteq> l2_partial_secrecy"
apply (rule external_invariant_translation
         [OF l1_obs_secrecy _ l2_implements_l1])
apply (auto simp add: med12s_def s0_secrecy_def l2_partial_secrecy_def)
done

lemma l2_oreach_dy_fake_msg:
  "s \<in> oreach l2 \<Longrightarrow> x \<in> dy_fake_msg (bad s) (ik s) (chan s) \<Longrightarrow> s \<lparr>ik := insert x (ik s)\<rparr> \<in> oreach l2"
apply (auto simp add: oreach_def, rule, simp_all, simp add: l2_def l2_trans_def l2_dy_fake_msg_def)
apply blast
done

definition
  l2_secrecy :: "('a l2_state_scheme) set"
where
  "l2_secrecy \<equiv> {s. dy_fake_msg (bad s) (ik s) (chan s) \<inter> secret s = {}}"

lemma l2_obs_secrecy [iff]: "oreach l2 \<subseteq> l2_secrecy"
apply (auto simp add:l2_secrecy_def)
apply (drule l2_oreach_dy_fake_msg, simp_all)
apply (drule l2_obs_partial_secrecy [THEN [2] rev_subsetD], simp add: l2_partial_secrecy_def)
apply blast
done

lemma l2_secrecy [iff]: "reach l2 \<subseteq> l2_secrecy"
by (rule external_to_internal_invariant [OF l2_obs_secrecy], auto)

abbreviation "l2_iagreement \<equiv> l1_iagreement"

lemma l2_obs_iagreement [iff]: "oreach l2 \<subseteq> l2_iagreement"
apply (rule external_invariant_translation
         [OF l1_obs_iagreement _ l2_implements_l1])
apply (auto simp add: med12s_def l1_iagreement_def)
done

lemma l2_iagreement [iff]: "reach l2 \<subseteq> l2_iagreement"
by (rule external_to_internal_invariant [OF l2_obs_iagreement], auto)

end


(*  Title:      HOL/MicroJava/BV/Typing_Framework_JVM.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>The Typing Framework for the JVM \label{sec:JVM}\<close>

theory Typing_Framework_JVM
imports "../DFA/Abstract_BV" JVMType EffectMono BVSpec
begin

definition exec :: "jvm_prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> exception_table \<Rightarrow> instr list \<Rightarrow> JVMType.state step_type" where
  "exec G maxs rT et bs ==
  err_step (size bs) (\<lambda>pc. app (bs!pc) G maxs rT pc et) (\<lambda>pc. eff (bs!pc) G pc et)"

definition opt_states :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (ty list \<times> ty err list) option set" where
  "opt_states G maxs maxr \<equiv> opt (\<Union>{list n (types G) |n. n \<le> maxs} \<times> list maxr (err (types G)))"

subsection \<open>Executability of \<^term>\<open>check_bounded\<close>\<close>

primrec list_all'_rec :: "('a \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "list_all'_rec P n []     = True"
| "list_all'_rec P n (x#xs) = (P x n \<and> list_all'_rec P (Suc n) xs)"

definition list_all' :: "('a \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "list_all' P xs \<equiv> list_all'_rec P 0 xs"

lemma list_all'_rec:
  "list_all'_rec P n xs = (\<forall>p < size xs. P (xs!p) (p+n))"
  apply (induct xs arbitrary: n)
  apply auto
  apply (case_tac p)
  apply auto
  done

lemma list_all' [iff]:
  "list_all' P xs = (\<forall>n < size xs. P (xs!n) n)"
  by (unfold list_all'_def) (simp add: list_all'_rec)

subsection \<open>Connecting JVM and Framework\<close>

lemma check_bounded_is_bounded:
  "check_bounded ins et \<Longrightarrow> bounded (\<lambda>pc. eff (ins!pc) G pc et) (length ins)"
  by (unfold bounded_def) (blast dest: check_boundedD)

lemma special_ex_swap_

lemmas [iff del] = not_None_eq

theorem exec_pres_type:
  "wf_prog wf_mb S \<Longrightarrow>
  pres_type (exec S maxs rT et bs) (size bs) (states S maxs maxr)"
  apply (unfold exec_def JVM_states_unfold)
  apply (rule pres_type_lift)
  apply clarify
  apply (case_tac s)
   apply simp
   apply (drule effNone)
   apply simp
  apply (simp add: eff_def xcpt_eff_def norm_eff_def)
  apply (case_tac "bs!p")

  apply clarsimp
  apply (drule listE_nth_in, assumption)
  apply fastforce

  apply (fastforce simp add: not_None_eq)

  apply (fastforce simp add: not_None_eq typeof_empty_is_type)

  apply clarsimp
  apply (erule disjE)
   apply fastforce
  apply clarsimp
  apply (rule_tac x="1" in exI)
  apply fastforce

  apply clarsimp
  apply (erule disjE)
   apply (fastforce dest: field_fields fields_is_type)
  apply (simp add: match_some_entry image_iff)
  apply (rule_tac x=1 in exI)
  apply fastforce

  apply clarsimp
  apply (erule disjE)
   apply fastforce
  apply (simp add: match_some_entry image_iff)
  apply (rule_tac x=1 in exI)
  apply fastforce

  apply clarsimp
  apply (erule disjE)
   apply fastforce
  apply clarsimp
  apply (rule_tac x=1 in exI)
  apply fastforce

  defer

  apply fastforce
  apply fastforce

  apply clarsimp
  apply (rule_tac x="n'+2" in exI)
  apply simp

  apply clarsimp
  apply (rule_tac x="Suc (Suc (Suc (length ST)))" in exI)
  apply simp

  apply clarsimp
  apply (rule_tac x="Suc (Suc (Suc (Suc (length ST))))" in exI)
  apply simp

  apply fastforce
  apply fastforce
  apply fastforce
  apply fastforce

  apply clarsimp
  apply (erule disjE)
   apply fastforce
  apply clarsimp
  apply (rule_tac x=1 in exI)
  apply fastforce

  apply (erule disjE)
   apply clarsimp
   apply (drule method_wf_mdecl, assumption+)
   apply (clarsimp simp add: wf_mdecl_def wf_mhead_def)
   apply fastforce
  apply clarsimp
  apply (rule_tac x=1 in exI)
  apply fastforce
  done

lemmas [iff] = not_None_eq

lemma sup_state_opt_unfold:
  "sup_state_opt G \<equiv> Opt.le (Product.le (Listn.le (subtype G)) (Listn.le (Err.le (subtype G))))"
  by (simp add: sup_state_opt_def sup_state_def sup_loc_def sup_ty_opt_def)

lemma app_mono:
  "app_mono (sup_state_opt G) (\<lambda>pc. app (bs!pc) G maxs rT pc et) (length bs) (opt_states G maxs maxr)"
  by (unfold app_mono_def lesub_def) (blast intro: EffectMono.app_mono)

lemma list_appendI:
  "\<lbrakk>a \<in> list x A; b \<in> list y A\<rbrakk> \<Longrightarrow> a @ b \<in> list (x+y) A"
  apply (unfold list_def)
  apply (simp (no_asm))
  apply blast
  done

lemma list_map [simp]:
  "(map f xs \<in> list (length xs) A) = (f ` set xs \<subseteq> A)"
  apply (unfold list_def)
  apply simp
  done

lemma [iff]:
  "(OK ` A \<subseteq> err B) = (A \<subseteq> B)"
  apply (unfold err_def)
  apply blast
  done

lemma [intro]:
  "x \<in> A \<Longrightarrow> replicate n x \<in> list n A"
  by (induct n, auto)

lemma lesubstep_type_simple:
  "a <=[Product.le (=) r] b \<Longrightarrow> a \<le>|r| b"
  apply (unfold lesubstep_type_def)
  apply clarify
  apply (simp add: set_conv_nth)
  apply clarify
  apply (drule le_listD, assumption)
  apply (clarsimp simp add: lesub_def Product.le_def)
  apply (rule exI)
  apply (rule conjI)
   apply (rule exI)
   apply (rule conjI)
    apply (rule sym)
    apply assumption
   apply assumption
  apply assumption
  done

lemma eff_mono:
  "\<lbrakk>p < length bs; s <=_(sup_state_opt G) t; app (bs!p) G maxs rT pc et t\<rbrakk>
  \<Longrightarrow> eff (bs!p) G p et s \<le>|sup_state_opt G| eff (bs!p) G p et t"
  apply (unfold eff_def)
  apply (rule lesubstep_type_simple)
  apply (rule le_list_appendI)
   apply (simp add: norm_eff_def)
   apply (rule le_listI)
    apply simp
   apply simp
   apply (simp add: lesub_def)
   apply (case_tac s)
    apply simp
   apply (simp del: split_paired_All split_paired_Ex)
   apply (elim exE conjE)
   apply simp
   apply (drule eff'_mono, assumption)
   apply assumption
  apply (simp add: xcpt_eff_def)
  apply (rule le_listI)
    apply simp
  apply simp
  apply (simp add: lesub_def)
  apply (case_tac s)
   apply simp
  apply simp
  apply (case_tac t)
   apply simp
  apply (clarsimp simp add: sup_state_conv)
  done

lemma order_sup_state_opt:
  "ws_prog G \<Longrightarrow> order (sup_state_opt G)"
  by (unfold sup_state_opt_unfold) (blast dest: acyclic_subcls1 order_widen)

theorem exec_mono:
  "ws_prog G \<Longrightarrow> bounded (exec G maxs rT et bs) (size bs) \<Longrightarrow>
  mono (JVMType.le G maxs maxr) (exec G maxs rT et bs) (size bs) (states G maxs maxr)"
  apply (unfold exec_def JVM_le_unfold JVM_states_unfold)
  apply (rule mono_lift)
     apply (fold sup_state_opt_unfold opt_states_def)
     apply (erule order_sup_state_opt)
    apply (rule app_mono)
   apply assumption
  apply clarify
  apply (rule eff_mono)
  apply assumption+
  done

theorem semilat_JVM_slI:
  "ws_prog G \<Longrightarrow> semilat (JVMType.sl G maxs maxr)"
  apply (unfold JVMType.sl_def stk_esl_def reg_sl_def)
  apply (rule semilat_opt)
  apply (rule err_semilat_Product_esl)
  apply (rule err_semilat_upto_esl)
  apply (rule err_semilat_JType_esl, assumption+)
  apply (rule err_semilat_eslI)
  apply (rule Listn_sl)
  apply (rule err_semilat_JType_esl, assumption+)
  done

lemma sl_triple_conv:
  "JVMType.sl G maxs maxr ==
  (states G maxs maxr, JVMType.le G maxs maxr, JVMType.sup G maxs maxr)"
  by (simp (no_asm) add: states_def JVMType.le_def JVMType.sup_def)

lemma is_type_pTs:
  "\<lbrakk> wf_prog wf_mb G; (C,S,fs,mdecls) \<in> set G; ((mn,pTs),rT,code) \<in> set mdecls \<rbrakk>
  \<Longrightarrow> set pTs \<subseteq> types G"
proof
  assume "wf_prog wf_mb G"
         "(C,S,fs,mdecls) \<in> set G"
         "((mn,pTs),rT,code) \<in> set mdecls"
  hence "wf_mdecl wf_mb G C ((mn,pTs),rT,code)"
    by (rule wf_prog_wf_mdecl)
  hence "\<forall>t \<in> set pTs. is_type G t"
    by (unfold wf_mdecl_def wf_mhead_def) auto
  moreover
  fix t assume "t \<in> set pTs"
  ultimately
  have "is_type G t" by blast
  thus "t \<in> types G" ..
qed

lemma jvm_prog_lift:
  assumes wf:
  "wf_prog (\<lambda>G C bd. P G C bd) G"

  assumes rule:
  "\<And>wf_mb C mn pTs C rT maxs maxl b et bd.
   wf_prog wf_mb G \<Longrightarrow>
   method (G,C) (mn,pTs) = Some (C,rT,maxs,maxl,b,et) \<Longrightarrow>
   is_class G C \<Longrightarrow>
   set pTs \<subseteq> types G \<Longrightarrow>
   bd = ((mn,pTs),rT,maxs,maxl,b,et) \<Longrightarrow>
   P G C bd \<Longrightarrow>
   Q G C bd"

  shows
  "wf_prog (\<lambda>G C bd. Q G C bd) G"
  using wf
  apply (unfold wf_prog_def wf_cdecl_def)
  apply clarsimp
  apply (drule bspec, assumption)
  apply (unfold wf_cdecl_mdecl_def)
  apply clarsimp
  apply (drule bspec, assumption)
  apply (frule methd [OF wf [THEN wf_prog_ws_prog]], assumption+)
  apply (frule is_type_pTs [OF wf], assumption+)
  apply clarify
  apply (drule rule [OF wf], assumption+)
  apply (rule HOL.refl)
  apply assumption+
  done

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_inv__41_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_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_inv__41_on_rules imports n_germanSimp_lemma_on_inv__41
begin
section{*All lemmas on causal relation between inv__41*}
lemma lemma_inv__41_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__41  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__41) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

end