theory Update_Root_Ref

imports  Read_Write_Ref

begin

lemma  update_root_non_det_det_refine:
  "\<lbrakk> update_TTBR0 r (s::'a non_det_tlb_state_scheme) = ((), s') ;  update_TTBR0 r (t::'b det_tlb_state_scheme) = ((), t');
         tlb_rel_det (typ_non_det_tlb s) (typ_det_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel_det (typ_non_det_tlb s') (typ_det_tlb t')"
  apply (clarsimp simp: update_TTBR0_non_det_tlb_state_ext_def update_TTBR0_det_tlb_state_ext_def)
  apply (clarsimp simp: tlb_rel_det_def  saturated_def)
  by (cases s, cases t , clarsimp simp: state.defs )

lemma  update_root_det_sat_refine:
  "\<lbrakk> update_TTBR0 r (s::'a det_tlb_state_scheme) = ((), s') ;  update_TTBR0 r (t::'b sat_tlb_state_scheme) = ((), t');
         tlb_rel_sat (typ_det_tlb s) (typ_sat_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel_sat (typ_det_tlb s') (typ_sat_tlb t')"
  apply (clarsimp simp: update_TTBR0_det_tlb_state_ext_def update_TTBR0_sat_tlb_state_ext_def)
  apply (clarsimp simp: tlb_rel_sat_def  saturated_def)
  apply (cases s, cases t , clarsimp simp: state.defs)
  by blast

lemma update_root_sat_incon_refine:
  "\<lbrakk> update_TTBR0 r (s::'a sat_tlb_state_scheme) = ((), s') ;  update_TTBR0 r (t::'b set_tlb_state_scheme) = ((), t');
             tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                     tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t')"
  apply (clarsimp simp: update_TTBR0_sat_tlb_state_ext_def update_TTBR0_set_tlb_state_ext_def tlb_rel_abs_def)
  apply (subgoal_tac "  TTBR0 t = TTBR0 s \<and> MEM t = MEM s")
   prefer 2
   apply (clarsimp simp:  typ_sat_tlb_def state.defs)
  apply (rule conjI)
   apply (clarsimp simp: typ_sat_tlb_def state.defs)
  apply (clarsimp simp: incon_addrs_def)
  apply (rule conjI)
   apply (clarsimp simp: inconsistent_vaddrs_def incoherrent_vaddrs_def)
   apply (drule union_incon_cases)
   apply (erule disjE, clarsimp simp: lookup_range_pt_walk_not_incon)
   apply (erule disjE, clarsimp)
    apply (clarsimp simp: incon_comp_def ptable_comp_def Let_def)
    apply (erule disjE)
     apply blast
    apply (erule disjE)
     apply (subgoal_tac "the (pt_walk () (MEM s) r xc) = the (pt_walk () (MEM s) (TTBR0 s) x)")
      apply (case_tac "\<not>is_fault (pt_walk ()   (MEM s) (TTBR0 s) x)")
       apply clarsimp
  using saturatd_lookup_hit_no_fault apply fastforce
     apply (subgoal_tac "the (pt_walk ()   (MEM s) r xc) = the (pt_walk ()   (MEM s) r x)")
      apply (force simp: is_fault_def)
     apply (frule lookup_range_fault_pt_walk)
     apply (drule_tac x = x in bspec; clarsimp simp: lookup_hit_entry_range)
    apply (subgoal_tac "is_fault (pt_walk () (MEM s) (TTBR0 s) x)")
     apply blast
    apply (erule disjE)
     apply (force simp: is_fault_def)
    apply clarsimp
    apply (subgoal_tac "the (pt_walk () (MEM s) r xc) = the (pt_walk () (MEM s) r x)")
     prefer 2
  using lookup_hit_entry_range_asid_tags va_entry_set_pt_palk_same apply blast
    apply clarsimp
    apply (subgoal_tac "\<not> is_fault (pt_walk () (MEM s) (TTBR0 s) x)") prefer 2 apply force
    apply (subgoal_tac " xa = the (pt_walk () (MEM s) r x)")
     apply clarsimp
    apply (subgoal_tac "lookup' (sat_tlb s \<union> the ` {e \<in> range (pt_walk () (MEM s) (TTBR0 s)). \<not> is_fault e}) x = Hit xa")
     prefer 2
     apply (clarsimp simp: saturated_def) apply (simp add: sup_absorb1)
    apply (drule lookup_hit_union_cases')
    apply (erule disjE)
     apply clarsimp
  using saturatd_lookup_hit_no_fault apply fastforce
    apply (erule disjE)
     apply clarsimp
    apply clarsimp
  using saturatd_lookup_hit_no_fault apply fastforce
  using lookup_range_pt_walk_not_incon apply blast
  apply (rule conjI)
   apply clarsimp
   apply (clarsimp simp: incoherrent_vaddrs_def  inconsistent_vaddrs_def)
   apply (simp only: incon_comp_def ptable_comp_def)
   apply clarsimp
   apply (drule lookup_hit_union_cases')
   apply (clarsimp simp: lookup_miss_is_fault_intro  subset_eq)
  by (clarsimp simp: saturated_def)

lemma  flush_tlb_non_det_det_refine:
  "\<lbrakk> flush FlushTLB (s::'a non_det_tlb_state_scheme) = ((), s') ;  flush FlushTLB (t::'b det_tlb_state_scheme) = ((), t');
         tlb_rel_det (typ_non_det_tlb s) (typ_det_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel_det (typ_non_det_tlb s') (typ_det_tlb t')"
  apply (clarsimp simp: flush_non_det_tlb_state_ext_def flush_det_tlb_state_ext_def)
  apply (clarsimp simp: tlb_rel_det_def)
  by (cases s, cases t , clarsimp simp: state.defs)

lemma  flush_varange_non_det_det_refine:
  "\<lbrakk>flush (Flushvarange vset) (s::'a non_det_tlb_state_scheme) = ((), s') ;  flush (Flushvarange vset) (t::'b det_tlb_state_scheme) = ((), t');
         tlb_rel_det (typ_non_det_tlb s) (typ_det_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel_det (typ_non_det_tlb s') (typ_det_tlb t')"
  apply (clarsimp simp: flush_non_det_tlb_state_ext_def flush_det_tlb_state_ext_def flush_tlb_vset_def)
  apply (clarsimp simp: tlb_rel_det_def)
  apply (cases s, cases t , clarsimp simp: state.defs)
  by blast

lemma  flush_non_det_det_refine:
  "\<lbrakk> flush f (s::'a non_det_tlb_state_scheme) = ((), s') ;  flush f (t::'b det_tlb_state_scheme) = ((), t');
         tlb_rel_det (typ_non_det_tlb s) (typ_det_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel_det (typ_non_det_tlb s') (typ_det_tlb t')"
  by (cases f; clarsimp simp: flush_tlb_non_det_det_refine flush_varange_non_det_det_refine )

lemma  flush_tlb_non_det_sat_refine:
  "\<lbrakk> flush FlushTLB (s::'a det_tlb_state_scheme) = ((), s') ;  flush FlushTLB (t::'b sat_tlb_state_scheme) = ((), t');
         tlb_rel_sat (typ_det_tlb s) (typ_sat_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel_sat (typ_det_tlb s') (typ_sat_tlb t')"
  apply (clarsimp simp: flush_det_tlb_state_ext_def flush_sat_tlb_state_ext_def)
  apply (clarsimp simp: tlb_rel_sat_def saturated_def)
  apply (cases s, cases t , clarsimp simp: state.defs)
  done

lemma  flush_varange_non_det_sat_refine:
  "\<lbrakk> flush (Flushvarange vset) (s::'a det_tlb_state_scheme) = ((), s') ;  flush (Flushvarange vset) (t::'b sat_tlb_state_scheme) = ((), t');
         tlb_rel_sat (typ_det_tlb s) (typ_sat_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel_sat (typ_det_tlb s') (typ_sat_tlb t')"
  apply (clarsimp simp: flush_det_tlb_state_ext_def flush_sat_tlb_state_ext_def flush_tlb_vset_def)
  apply (clarsimp simp: tlb_rel_sat_def  saturated_def)
  apply (cases s, cases t , clarsimp simp: state.defs )
  by blast

lemma  flush_det_sat_refine:
  "\<lbrakk> flush f (s::'a det_tlb_state_scheme) = ((), s') ;  flush f (t::'b sat_tlb_state_scheme) = ((), t');
         tlb_rel_sat (typ_det_tlb s) (typ_sat_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel_sat (typ_det_tlb s') (typ_sat_tlb t')"
  by (cases f; clarsimp simp: flush_tlb_non_det_sat_refine   flush_varange_non_det_sat_refine )

lemma flush_tlb_sat_incon_refine:
  "\<lbrakk>flush FlushTLB (s::'a sat_tlb_state_scheme) = ((), s') ;  flush FlushTLB (t::'b set_tlb_state_scheme) = ((), t');
             tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                     tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t')"
  apply (clarsimp simp: flush_sat_tlb_state_ext_def  flush_set_tlb_state_ext_def tlb_rel_abs_def)
  apply (rule conjI)
   apply (cases s, cases t, clarsimp simp: state.defs)
  apply (rule conjI)
   apply (clarsimp simp: incon_addrs_def)
   apply (rule conjI)
    apply (clarsimp simp: inconsistent_vaddrs_def lookup_range_pt_walk_not_incon)
   apply (clarsimp simp: incoherrent_vaddrs_def)
    apply (clarsimp simp: lookup_miss_is_fault_intro)
  by (clarsimp simp: saturated_def)

lemma flush_varange_sat_incon_refine:
  "\<lbrakk>flush (Flushvarange vset) (s::'a sat_tlb_state_scheme) = ((), s') ;  flush (Flushvarange vset) (t::'b set_tlb_state_scheme) = ((), t');
             tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                     tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t')"
  apply (clarsimp simp: flush_sat_tlb_state_ext_def  flush_set_tlb_state_ext_def tlb_rel_abs_def flush_tlb_vset_def)
  apply (rule conjI)
   apply (cases s, cases t, clarsimp simp: state.defs)
  apply (subgoal_tac "(sat_tlb s) = (sat_tlb s) \<union>
                              the ` {e \<in> range (pt_walk () (MEM s) (TTBR0 s)). \<not> is_fault e} ")
   prefer 2
   apply (drule sat_state_tlb, clarsimp simp: state.defs)
  apply (rule conjI)
   apply (clarsimp simp: incon_addrs_def)
   apply (rule conjI)
    apply (clarsimp simp: inconsistent_vaddrs_def)
     apply (drule union_incon_cases)
     apply (erule disjE)
      apply (clarsimp simp: lookup_range_pt_walk_not_incon)
     apply (erule disjE)
      apply clarsimp
      apply (rule conjI)
       prefer 2 using lookup_hit_entry_range apply force
      apply (drule lookup_hit_incon_minus, erule disjE)
       prefer 2
       apply blast
      apply (subgoal_tac "the (pt_walk ()   (MEM s) (TTBR0 s) xc) = the (pt_walk ()   (MEM s) (TTBR0 s) x)")
       prefer 2
       apply (frule lookup_range_fault_pt_walk)
       apply (drule_tac x = x and A = "range_of (the (pt_walk ()   (MEM s) (TTBR0 s) xc))" in bspec; simp add : lookup_hit_entry_range)
      apply (clarsimp simp: incoherrent_vaddrs_def)
     apply (frule_tac b = x and x = xa in saturatd_lookup_hit_no_fault, simp) prefer 2 apply force
  apply (smt lookup_hit_entry_range_asid_tags va_entry_set_pt_palk_same')
     apply (erule disjE)
      apply clarsimp
      apply (simp add: lookup_range_pt_walk_not_incon)
     apply (erule disjE)
      prefer 2
      apply (erule disjE, clarsimp)
  using lookup_range_pt_walk_not_incon apply force
      apply (rule conjI) prefer 2
  subgoal
  proof -
    fix x :: vaddr
    assume "lookup' ((sat_tlb s) - (\<Union>v\<in>vset. {e \<in> (sat_tlb s). v \<in> range_of e}))   x = Incon \<and> lookup' (the ` {e \<in> range (pt_walk ()   (MEM s) (TTBR0 s)). \<not> is_fault e})   x = Miss"
    then have "\<exists>T. lookup' (T - (\<Union>a\<in>vset. {t::unit tlb_entry \<in> T. a \<in> range_of t})) x \<noteq> Miss"
      by (metis lookup_type.simps(3))
    then show "x \<notin> vset"
      using lookup_not_miss_varange by blast
  qed
  using lookup_incon_minus mem_Collect_eq apply blast
    apply clarsimp apply (rule conjI) prefer 2
  subgoal
  proof -
    fix x :: vaddr and xb :: vaddr
    assume "lookup' ((sat_tlb s) - (\<Union>v\<in>vset. {e \<in> (sat_tlb s). v \<in> range_of e}))   x = Incon"
    then have "\<exists>T . lookup' (T - (\<Union>a\<in>vset. {t::unit tlb_entry \<in> T. a \<in> range_of t}))  x \<noteq> Miss"
      by (metis (full_types) lookup_type.simps(3))
    then show "x \<notin> vset"
      using lookup_not_miss_varange by blast
  qed
  using lookup_incon_minus apply force
   apply (clarsimp simp: incoherrent_vaddrs_def)
    apply (subgoal_tac "lookup' ((sat_tlb s) - (\<Union>v\<in>vset. {e \<in> (sat_tlb s). v \<in> range_of e}))   x = Hit xa")
     prefer 2
     apply (simp add: lookup_miss_is_fault_intro lookup_miss_union_equal)
    apply (drule lookup_hit_incon_minus, erule disjE)
     prefer 2
     apply (clarsimp simp: inconsistent_vaddrs_def)
     apply (rule conjI)
     apply force
  subgoal
  proof -
    fix x :: vaddr and xa :: "unit tlb_entry"
    assume a1: "is_fault (pt_walk ()   (MEM s) (TTBR0 s) x)"
    assume "lookup' ((sat_tlb s) - (\<Union>v\<in>vset. {e \<in> (sat_tlb s). v \<in> range_of e}) \<union> the ` {e \<in> range (pt_walk () (MEM s) (TTBR0 s)). \<not> is_fault e})   x = Hit xa"
    then have "lookup' ((sat_tlb s) - (\<Union>a\<in>vset. {t \<in> (sat_tlb s). a \<in> range_of t}))   x = Hit xa"
      using a1 by (simp add: lookup_miss_is_fault_intro lookup_miss_union_equal)
    then have "\<exists> T. lookup' (T - (\<Union>a\<in>vset. {t::unit tlb_entry \<in> T. a \<in> range_of t}))  x \<noteq> Miss"
      by (metis lookup_type.simps(5))
    then show "x \<notin> vset"
      using lookup_not_miss_varange by blast
  qed
    apply (rule conjI) apply blast
  subgoal
  proof -
    fix x :: vaddr and xa :: "unit tlb_entry"
    assume a1: "is_fault (pt_walk ()   (MEM s) (TTBR0 s) x)"
    assume "lookup' ((sat_tlb s) - (\<Union>v\<in>vset. {e \<in> (sat_tlb s). v \<in> range_of e}) \<union> the ` {e \<in> range (pt_walk () (MEM s) (TTBR0 s)). \<not> is_fault e})   x = Hit xa"
    then have "lookup' ((sat_tlb s) - (\<Union>a\<in>vset. {t::unit tlb_entry \<in> (sat_tlb s). a \<in> range_of t}))   x = Hit xa"
      using a1 by (simp add: lookup_miss_is_fault_intro lookup_miss_union_equal)
    then show "x \<notin> vset"
      by (metis (mono_tags) lookup_not_miss_varange lookup_type.simps(5))
  qed
  by (clarsimp simp: saturated_def)

lemma  flush_sat_incon_refine:
  "\<lbrakk> flush f (s::'a sat_tlb_state_scheme) = ((), s') ;  flush f (t::'b set_tlb_state_scheme) = ((), t');
         tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t')"
  by (cases f; clarsimp simp:   flush_tlb_sat_incon_refine   flush_varange_sat_incon_refine )

end


section \<open>Generic Block Allocator --- Resoning Setup\<close>
theory Sep_Block_Allocator_RS
imports Sep_Lift "../basic/LLVM_Basic_Main"
begin

  lemma list\<alpha>_at_len: "list\<alpha> \<alpha> xs (length xs) = 0"
    by (auto simp: list\<alpha>_def)

  lemma list\<alpha>_gt_len: "i\<ge>length xs \<Longrightarrow> list\<alpha> \<alpha> xs i = 0"
    by (auto simp: list\<alpha>_def)

  lemma list\<alpha>_snoc: "list\<alpha> \<alpha> (xs@[x]) = 0(length xs := \<alpha> x) + list\<alpha> \<alpha> xs"
    apply (rule ext)
    apply (auto simp: list\<alpha>_def nth_append)
    done

  lemma list\<alpha>_in_range: "list\<alpha> \<alpha> xs i \<noteq> 0 \<Longrightarrow> i<length xs"
    by (auto simp: list\<alpha>_def split: if_splits)

  lemma list\<alpha>_in_rangeD: "list\<alpha> \<alpha> xs = x \<Longrightarrow> x i \<noteq> 0 \<Longrightarrow> i<length xs"
    by (auto simp: list\<alpha>_def split: if_splits)

  lemma list\<alpha>_splitE:
    assumes "list\<alpha> \<alpha> xs = fun_upd 0 i p + fun_upd f i 0"
    assumes "p\<noteq>0"
    obtains "i<length xs" "\<alpha> (xs!i) = p"
    using assms
    by (auto simp: list\<alpha>_def fun_eq_iff split: if_splits)

  lemma option\<alpha>_splitE:
    assumes "option\<alpha> \<alpha> v = p"
    assumes "p\<noteq>0"
    obtains x where "v=Some x" "\<alpha> x = p"
    using assms by (cases v) auto

  locale block_allocator2 = block_allocator1 static_err mem_err bload bstore bcheck_addr
    for static_err :: 'err
    and mem_err :: 'err
    and bload :: "'baddr::this_addr \<Rightarrow> ('val,_,_,'block,'err) M"
    and bstore :: "'val \<Rightarrow> 'baddr \<Rightarrow> (unit,_,_,'block,'err) M"
    and bcheck_addr :: "'baddr \<Rightarrow> (unit,_,_,'block,'err) M"

  + fixes \<alpha>b :: "'block \<Rightarrow> 'ablock::unique_zero_sep_algebra"
      and bpto :: "'val \<Rightarrow> 'baddr \<Rightarrow> 'ablock \<Rightarrow> bool"
      and tag_of :: "'block \<Rightarrow> 'tag"
      and is_complete_tag :: "'ablock \<Rightarrow> 'tag \<Rightarrow> bool"

    assumes bload_rule: "\<And>x a. notime.htriple \<alpha>b (bpto x a) (bload a) (\<lambda>r. \<up>(r=x) ** bpto x a)"
        and bstore_rule: "\<And>x xx a. notime.htriple \<alpha>b (bpto xx a) (bstore x a) (\<lambda>_. bpto x a)"
        and bload_pres_tag: "\<And>s a. wlp (bload a) (\<lambda>_ s'. tag_of s' = tag_of s) s"
        and bstore_pres_tag: "\<And>s a x. wlp (bstore a x) (\<lambda>_ s'. tag_of s' = tag_of s) s"
        and complete_tag:
          "\<And>f. \<lbrakk>is_complete_tag ablock (tag_of cblock); ablock ## f; \<alpha>b cblock = ablock + f\<rbrakk> \<Longrightarrow> f=0"
        and bpto_notZ: "\<And>x a. \<not>bpto x a 0"
  begin

    definition \<alpha>tag :: "'block \<Rightarrow> 'tag tsa_opt" where "\<alpha>tag blk \<equiv> TRIV (tag_of blk)"
    definition \<alpha> :: "'block memory \<Rightarrow> nat \<Rightarrow> 'ablock \<times> 'tag tsa_opt"
      where "\<alpha> \<equiv> \<lambda>MEMORY blocks \<Rightarrow> list\<alpha> (option\<alpha> (\<lambda>x. (\<alpha>b x, \<alpha>tag x))) blocks"
    definition pto :: "'val \<Rightarrow> 'baddr addr rptr \<Rightarrow> (nat \<Rightarrow> 'ablock \<times> 'tag tsa_opt) \<Rightarrow> bool"
      where "pto x \<equiv> \<lambda>RP_ADDR (ADDR bi ba) \<Rightarrow> \<lambda>s. \<exists>ablk. s=0(bi:=(ablk,0)) \<and> bpto x ba ablk | _ \<Rightarrow> sep_false"

    definition tag :: "'tag \<Rightarrow> 'baddr addr rptr \<Rightarrow> (nat \<Rightarrow> 'ablock \<times> 'tag tsa_opt) \<Rightarrow> bool"
      where "tag t \<equiv> \<lambda>RP_ADDR (ADDR bi ba) \<Rightarrow> EXACT (0(bi:=(0,TRIV t))) ** \<up>(ba=this_addr \<and> t\<in>range tag_of) | _ \<Rightarrow> sep_false"
    definition block :: "'ablock \<Rightarrow> 'baddr addr rptr \<Rightarrow> (nat \<Rightarrow> 'ablock \<times> 'tag tsa_opt) \<Rightarrow> bool"
      where "block b \<equiv> \<lambda>RP_ADDR (ADDR bi ba) \<Rightarrow> EXACT (0(bi:=(b,0))) ** \<up>(ba=this_addr) | _ \<Rightarrow> sep_false"

    lemma alloc_rule: "notime.htriple \<alpha> \<box> (alloc b) (\<lambda>r. block (\<alpha>b b) r ** tag (tag_of b) r)"
      apply (rule notime.htripleI')
      apply (auto simp: alloc_def wpn_def run_simps sep_algebra_simps split: option.splits)
      (* TODO/FIXME: auto followed by proof. *)
    proof -
      fix s :: "'block memory"
      obtain blocks where [simp]: "s = MEMORY blocks" by (cases s)

      show "\<exists>p'. p' ## \<alpha> s \<and>
              \<alpha> (put' memory.the_memory\<^sub>L (get' memory.the_memory\<^sub>L s @ [Some b]) s) = p' + \<alpha> s \<and>
              (block (\<alpha>b b) (RP_ADDR (ADDR (length (get' memory.the_memory\<^sub>L s)) this_addr)) \<and>*
               tag (tag_of b) (RP_ADDR (ADDR (length (get' memory.the_memory\<^sub>L s)) this_addr)))
               p'"
        apply (rule exI[where x="0(length blocks := (\<alpha>b b, TRIV (tag_of b)))"]; intro conjI)
        apply (clarsimp_all simp: \<alpha>_def block_def tag_def \<alpha>tag_def sep_algebra_simps list\<alpha>_at_len)
        subgoal by (simp add: list\<alpha>_snoc)
        subgoal
          apply (subst EXACT_split[symmetric])
          apply (auto simp: sep_algebra_simps)
          done
        done
    qed

    lemma complete_splitE:
      assumes C: "is_complete_tag blk t"
      assumes DISJ: "f i ## (blk, TRIV t)"
      assumes AEQ: "list\<alpha> (option\<alpha> (\<lambda>x. (\<alpha>b x, \<alpha>tag x))) xs = f + fun_upd 0 i (blk, TRIV t)"
      obtains cblk where
        "i<length xs" "xs!i = Some cblk" "blk = \<alpha>b cblk" "t = tag_of cblk" "f i = 0"
    proof -
      have [simp]: "i<length xs"
        apply (rule list\<alpha>_in_rangeD[OF AEQ])
        apply (auto simp: sep_algebra_simps DISJ)
        done

      obtain fib fit where [simp]: "f i = (fib,fit)"  by (cases "f i")

      from DISJ have [simp]: "blk ## fib" "fit = 0"
        by (auto simp: sep_algebra_simps)

      obtain cblk where [simp]: "xs!i = Some cblk" "\<alpha>b cblk = blk + fib" "t = tag_of cblk"
        using fun_cong[OF AEQ, of i]
        apply (cases "xs!i")
        apply (auto simp: list\<alpha>_def sep_algebra_simps if_splits \<alpha>tag_def)
        done

      from complete_tag[OF C[simplified], of fib, simplified] have [simp]: "fib=0" .

      show ?thesis
        apply (rule that[of cblk])
        apply (auto simp: sep_algebra_simps)
        done
    qed

    lemma free_rule: "notime.htriple \<alpha> (block blk a ** tag t a ** \<up>(is_complete_tag blk t)) (free a) (\<lambda>_. \<box>)"
      apply (rule notime.htripleI')
      subgoal for p s f
        apply (cases s)
        apply (auto simp: free_def wpn_def run_simps sep_algebra_simps split: option.splits addr.splits rptr.splits)
        apply (auto simp: block_def tag_def sep_algebra_simps pred_lift_extract_simps)
        apply (all \<open>subst (asm) EXACT_split[symmetric] sep_disj_fun_def; clarsimp simp: sep_algebra_simps\<close>)
        apply (auto simp: \<alpha>_def sep_algebra_simps merge_fun_singleton split_fun_upd_0)
        subgoal
          apply (erule (2) complete_splitE)
          by auto
        subgoal
          apply (erule (2) complete_splitE)
          by auto
        subgoal for xs i
          by (force simp: sep_algebra_simps dest: sep_disj_funD[where x=i] list\<alpha>_in_rangeD[where i=i])
        subgoal
          apply (erule (2) complete_splitE)
          by auto
        done
      done

    definition "block_lifter bi \<equiv> \<lparr>
      sep_lifter.lift = \<lambda>x. (0(bi:=(x,0))),
      sep_lifter.project = (\<lambda>f. fst (f bi)),
      sep_lifter.carve = (\<lambda>f. f(bi:=(0,snd (f bi)))),
      sep_lifter.splittable = (\<lambda>f. True),
      sep_lifter.L = lens_of_bi bi,
      sep_lifter.\<alpha>b = \<alpha>,
      sep_lifter.\<alpha>s = \<alpha>b,
      sep_lifter.tyb = \<lambda>_. (),
      sep_lifter.tys = tag_of
          \<rparr>"

    lemma block_lifter_simps[simp]:
      "sep_lifter.lift (block_lifter bi) = (\<lambda>x. (0(bi:=(x,0))))"
      "sep_lifter.project (block_lifter bi) = (\<lambda>f. fst (f bi))"
      "sep_lifter.carve (block_lifter bi) = (\<lambda>f. f(bi:=(0,snd (f bi))))"
      "sep_lifter.splittable (block_lifter bi) = (\<lambda>f. True)"
      "sep_lifter.L (block_lifter bi) = lens_of_bi bi"
      "sep_lifter.\<alpha>b (block_lifter bi) = \<alpha>"
      "sep_lifter.\<alpha>s (block_lifter bi) = \<alpha>b"
      "sep_lifter.tyb (block_lifter bi) = (\<lambda>_. ())"
      "sep_lifter.tys (block_lifter bi) = tag_of"
      unfolding block_lifter_def by auto

    sublocale block_lifter: sep_lifter "block_lifter bi"
    proof -

      have aux1[intro]: "a ## fst b \<Longrightarrow> b ## (a, 0)" for a b
        by (cases b) (auto simp: sep_algebra_simps )

      show "sep_lifter (block_lifter bi)"
        apply unfold_locales
        apply (auto simp: sep_algebra_simps sep_disj_funD[where x=bi])
        apply (auto
          simp: lens_of_bi_def \<alpha>_def list\<alpha>_def option\<alpha>_alt \<alpha>tag_def sep_algebra_simps
          split: memory.splits if_splits option.splits
          del: ext intro!: ext)
        done
    qed

    lemma pto_null_eq[simp]: "pto x RP_NULL = sep_false" by (auto simp: pto_def)

    lemma pto_addr_eq[simp]: "pto x (RP_ADDR (ADDR bi ba)) = block_lifter.lift_assn bi (bpto x ba)"
      unfolding pto_def block_lifter.lift_assn_def
      apply (rule ext)
      apply (auto simp: sep_algebra_simps)
      by (metis (no_types, hide_lams) fun_upd_same fun_upd_triv fun_upd_upd prod_Z_lower(1) surjective_pairing zero_fun_def)

    fun rptr_cases where "rptr_cases (RP_NULL) = ()" | "rptr_cases (RP_ADDR (ADDR _ _)) = ()"

    lemma load_rule: "notime.htriple \<alpha> (pto x a) (load a) (\<lambda>r. \<up>(x=r) ** pto x a)"
      unfolding load_def
      apply (cases a rule: rptr_cases.cases; simp)
      apply (rule notime.cons_post_rule)
      apply (rule block_lifter.lift_operation[simplified, OF _ _ bload_rule])
      apply (simp add: bpto_notZ)
      apply (rule bload_pres_tag)
      apply (auto simp: sep_algebra_simps pred_lift_extract_simps)
      done

    lemma store_rule: "notime.htriple \<alpha> (pto xx a) (store x a) (\<lambda>_. pto x a)"
      unfolding store_def
      apply (cases a rule: rptr_cases.cases; simp)
      apply (rule notime.cons_post_rule)
      apply (rule block_lifter.lift_operation[simplified, OF _ _ bstore_rule])
      apply (simp add: bpto_notZ)
      apply (rule bstore_pres_tag)
      apply (auto simp: sep_algebra_simps pred_lift_extract_simps)
      done

  end

subsection \<open>Address Arithmetic\<close>

  (*
    ptr ~ ptr :: bool   same base

    ptr - ptr :: int    if same base
    ptr + int :: ptr

    ~ is equivalence relation
    p ~ p
    p\<^sub>1 ~ p\<^sub>2 \<longleftrightarrow> p\<^sub>2 ~ p\<^sub>1
    p\<^sub>1~p\<^sub>2 \<and> p\<^sub>2~p\<^sub>3 \<longrightarrow> p\<^sub>1~p\<^sub>3

    p + i\<^sub>1 + i\<^sub>2 = p + (i\<^sub>1+i\<^sub>2)
    p + 0 = p
    p ~ p+i

    p\<^sub>1~p\<^sub>2 \<Longrightarrow> p\<^sub>2 + (p\<^sub>1-p\<^sub>2) = p\<^sub>1
  *)

  term "a+b"

  class addr_algebra =
    fixes abase :: "'a \<Rightarrow> bool"
      and acompat :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "~\<^sub>a" 50)
      and adiff :: "'a \<Rightarrow> 'a \<Rightarrow> int" (infix "-\<^sub>a" 65)
      and aidx :: "'a \<Rightarrow> int \<Rightarrow> 'a" (infixl "+\<^sub>a" 65)
    assumes
        \<comment> \<open>Compatibility is equivalence relation over base pointers\<close>
            acompat_equiv: "part_equivp acompat"
        and acompat_dom: "a\<^sub>1 ~\<^sub>a a\<^sub>2 \<Longrightarrow> abase a\<^sub>1 \<and> abase a\<^sub>2"

        \<comment> \<open>Indexing properties\<close>
        and aidx_Z[simp]: "a +\<^sub>a 0 = a" \<comment> \<open>Indexing by zero extended to non-base pointers\<close>
        and aidx_plus[simp]: "abase a \<Longrightarrow> a +\<^sub>a i\<^sub>1 +\<^sub>a i\<^sub>2 = a +\<^sub>a (i\<^sub>1 + i\<^sub>2)"
        and aidx_inj[simp]: "abase a \<Longrightarrow> a +\<^sub>a i = a +\<^sub>a j \<longleftrightarrow> i=j"
        (*and abase_idx[simp, intro!]: "abase a \<Longrightarrow> abase (a +\<^sub>a i)"*)
        and abase_idx[simp]: "abase (a +\<^sub>a i) \<longleftrightarrow> abase a"

        \<comment> \<open>Difference\<close>
        and adiff_same[simp]: "a -\<^sub>a a = 0" \<comment> \<open>Reflexive difference extended to non-base pointers\<close>
        and aidx_compat[simp]: "abase a \<Longrightarrow> a ~\<^sub>a a+\<^sub>ai"
        and adiff_idx[simp]: "a ~\<^sub>a b \<Longrightarrow> a +\<^sub>a (b -\<^sub>a a) = b"

  begin
    lemma acompat_trans[trans]: "a ~\<^sub>a b \<Longrightarrow> b ~\<^sub>a c \<Longrightarrow> a ~\<^sub>a c"
      using acompat_equiv by (meson part_equivp_transp)

    lemma acompat_sym[sym, intro]: "a ~\<^sub>a b \<Longrightarrow> b ~\<^sub>a a"
      using acompat_equiv by (meson part_equivp_symp)

    (*lemma acompat_sym_iff[simp]: "p~\<^sub>ap' \<longleftrightarrow> p'~\<^sub>ap"
      using acompat_sym by auto
    *)

    lemma acompat_refl[simp]: "a ~\<^sub>a a \<longleftrightarrow> abase a"
      using acompat_sym acompat_trans local.acompat_dom local.aidx_compat by blast

    lemma aidx_compat'[simp]:
      "abase b \<Longrightarrow> a ~\<^sub>a b +\<^sub>a i  \<longleftrightarrow> a ~\<^sub>a b"
      "abase a \<Longrightarrow> a +\<^sub>a i ~\<^sub>a b \<longleftrightarrow> a ~\<^sub>a b"
      using acompat_sym acompat_trans local.aidx_compat by blast+

    lemma diff_Z_iff_eq[simp]: "a\<^sub>1 ~\<^sub>a a\<^sub>2 \<Longrightarrow> a\<^sub>1 -\<^sub>a a\<^sub>2 = 0 \<longleftrightarrow> a\<^sub>1=a\<^sub>2"
      by (metis acompat_sym acompat_trans local.adiff_idx local.adiff_same)

    lemma diff_Z_iff_eq'[simp]: "a\<^sub>2 ~\<^sub>a a\<^sub>1 \<Longrightarrow> a\<^sub>1 -\<^sub>a a\<^sub>2 = 0 \<longleftrightarrow> a\<^sub>1=a\<^sub>2"
      by (metis acompat_sym acompat_trans local.adiff_idx local.adiff_same)

    lemma adiff_idx'[simp]: "b ~\<^sub>a a \<Longrightarrow> a +\<^sub>a (b -\<^sub>a a) = b"
      using acompat_sym local.adiff_idx by blast

    lemma idx_diff_distrib[simp]: "p~\<^sub>ap' \<Longrightarrow> (p+\<^sub>ai)-\<^sub>ap' = (p-\<^sub>ap')+i"
      by (metis acompat_dom adiff_idx' aidx_compat aidx_inj aidx_plus)
    lemma idx_diff_distrib'[simp]: "p'~\<^sub>ap \<Longrightarrow> (p+\<^sub>ai)-\<^sub>ap' = (p-\<^sub>ap')+i"
      by (metis acompat_dom adiff_idx' aidx_compat aidx_inj aidx_plus)

    lemma adiff_idx_idx[simp]:
      "p~\<^sub>ap' \<Longrightarrow> p +\<^sub>a (p' -\<^sub>a p + i) = p' +\<^sub>a i"
      "p'~\<^sub>ap \<Longrightarrow> p +\<^sub>a (p' -\<^sub>a p + i) = p' +\<^sub>a i"
      apply (metis acompat_dom adiff_idx aidx_plus)
      by (metis acompat_dom adiff_idx' aidx_plus)

    lemma acompat_dom'[simp, intro]:
      "p~\<^sub>ap' \<Longrightarrow> abase p"
      "p~\<^sub>ap' \<Longrightarrow> abase p'"
      apply (simp_all add: acompat_dom)
      done

  end

  instantiation rptr :: (addr_algebra) addr_algebra begin
    fun abase_rptr where "abase_rptr (RP_ADDR a) \<longleftrightarrow> abase a" | "abase_rptr RP_NULL \<longleftrightarrow> False"

    lemma abase_rptr_alt: "abase p \<longleftrightarrow> (case p of (RP_ADDR a) \<Rightarrow> abase a | RP_NULL \<Rightarrow> False)"
      by (cases p; simp)

    fun acompat_rptr where
      "acompat_rptr (RP_ADDR a\<^sub>1) (RP_ADDR a\<^sub>2) \<longleftrightarrow> a\<^sub>1 ~\<^sub>a a\<^sub>2"
    | "acompat_rptr _ _ \<longleftrightarrow> False"

    lemma acompat_rptr_alt: "p\<^sub>1 ~\<^sub>a p\<^sub>2 \<longleftrightarrow> (case (p\<^sub>1,p\<^sub>2) of (RP_ADDR a\<^sub>1, RP_ADDR a\<^sub>2) \<Rightarrow> a\<^sub>1 ~\<^sub>a a\<^sub>2 | _ \<Rightarrow> False)"
      by (cases p\<^sub>1; cases p\<^sub>2; simp)

    fun adiff_rptr where
      "adiff_rptr (RP_ADDR a\<^sub>1) (RP_ADDR a\<^sub>2) = (a\<^sub>1 -\<^sub>a a\<^sub>2)"
    | "adiff_rptr (RP_NULL) (RP_NULL) = 0"
    | "adiff_rptr _ _ = undefined"

    lemma adiff_rptr_alt: "p\<^sub>1 -\<^sub>a p\<^sub>2 = (case (p\<^sub>1,p\<^sub>2) of (RP_ADDR a\<^sub>1, RP_ADDR a\<^sub>2) \<Rightarrow> a\<^sub>1 -\<^sub>a a\<^sub>2 | (RP_NULL,RP_NULL) \<Rightarrow> 0 | _ \<Rightarrow> undefined)"
      by (cases p\<^sub>1; cases p\<^sub>2; simp)

    fun aidx_rptr where
      "aidx_rptr (RP_ADDR a) i = RP_ADDR (a +\<^sub>a i)"
    | "aidx_rptr RP_NULL _ = RP_NULL"

    lemma aidx_rptr_alt: "p\<^sub>1 +\<^sub>a i = (case p\<^sub>1 of RP_ADDR a\<^sub>1 \<Rightarrow> RP_ADDR (a\<^sub>1 +\<^sub>a i) | _ \<Rightarrow> RP_NULL)"
      by (cases p\<^sub>1; simp)

    lemma ptr_neq_null_conv: "p\<noteq>RP_NULL \<longleftrightarrow> (\<exists>a. p=RP_ADDR a)" by (cases p) (auto)

    instance
      apply standard
      apply (intro part_equivpI sympI transpI)
      apply (meson acompat_equiv acompat_rptr.simps(1) part_equivp_def)
      apply (auto
        simp: acompat_rptr_alt aidx_rptr_alt adiff_rptr_alt acompat_dom
        split: rptr.splits
        intro!: sympI transpI reflpI
        intro: acompat_sym acompat_trans)
      done

  end

  fun rptr_the_block_index where
    "rptr_the_block_index (RP_ADDR (ADDR bi _)) = bi" | "rptr_the_block_index _ = undefined"

  instantiation addr :: (addr_algebra) addr_algebra begin
    fun abase_addr where "abase_addr (ADDR bi ba) \<longleftrightarrow> abase ba"
    fun acompat_addr where "ADDR bi\<^sub>1 ba\<^sub>1 ~\<^sub>a ADDR bi\<^sub>2 ba\<^sub>2 \<longleftrightarrow> bi\<^sub>1=bi\<^sub>2 \<and> ba\<^sub>1~\<^sub>aba\<^sub>2"
    fun aidx_addr where "ADDR bi ba +\<^sub>a i = ADDR bi (ba +\<^sub>a i)"
    fun adiff_addr where "ADDR bi\<^sub>1 ba\<^sub>1 -\<^sub>a ADDR bi\<^sub>2 ba\<^sub>2 = ba\<^sub>1 -\<^sub>a ba\<^sub>2"

    lemma abase_addr_alt: "abase = (\<lambda>(ADDR bi ba) \<Rightarrow> abase ba)" by (intro ext) (auto split: addr.splits)
    lemma acomp_addr_alt: "(~\<^sub>a) = (\<lambda>ADDR bi\<^sub>1 ba\<^sub>1 \<Rightarrow> \<lambda>ADDR bi\<^sub>2 ba\<^sub>2 \<Rightarrow> bi\<^sub>1=bi\<^sub>2 \<and> ba\<^sub>1~\<^sub>aba\<^sub>2)" by (intro ext) (auto split: addr.splits)
    lemma aidx_addr_alt: "(+\<^sub>a) = (\<lambda>ADDR bi ba \<Rightarrow> \<lambda>i. ADDR bi (ba +\<^sub>a i))" by (intro ext) (auto split: addr.splits)
    lemma adiff_addr_alt: "(-\<^sub>a) = (\<lambda>ADDR bi\<^sub>1 ba\<^sub>1 \<Rightarrow> \<lambda>ADDR bi\<^sub>2 ba\<^sub>2 \<Rightarrow> ba\<^sub>1 -\<^sub>a ba\<^sub>2)" by (intro ext) (auto split: addr.splits)

    instance
      apply standard
      apply (intro part_equivpI sympI transpI)
      apply (meson acompat_equiv acompat_addr.simps(1) part_equivp_def)
      apply (auto
        simp: abase_addr_alt acomp_addr_alt aidx_addr_alt adiff_addr_alt acompat_dom
        split: addr.splits
        intro: acompat_sym acompat_trans)
      done

  end

end


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

theory ExecConcrete
imports CorresXF
begin

definition "exec_transformed (sr :: ('s \<times> 't) set) (M :: ('t, 'r) nondet_monad) \<equiv>
    \<lambda>s. (\<Union> ((\<lambda>(r', t'). {(r, t). r = r' \<and> (t, t') \<in> sr}) ` (\<Union> (fst ` M ` {s'. (s, s') \<in> sr}))),
            True \<in> snd ` M ` {s'. (s, s') \<in> sr})"

lemma in_exec_transformed:
  "((r, s') \<in> fst (exec_transformed sr A s)) = (\<exists>t t'. (s, t) \<in> sr \<and>  (s', t') \<in> sr \<and> (r, t') \<in> fst (A t))"
  apply (clarsimp simp: exec_transformed_def)
  apply force
  done

lemma snd_exec_transformed:
  "snd (exec_transformed sr M s) = (\<exists>x. (s, x) \<in> sr \<and> snd (M x))"
  by (clarsimp simp: exec_transformed_def)

lemma exec_transformed_Id [simp]:
    "exec_transformed Id M = M"
  apply (auto simp: exec_transformed_def)
  done

lemma exec_transformed_valid_def:
    "\<lbrace> P \<rbrace> exec_transformed sr M \<lbrace> Q \<rbrace> = \<lbrace> \<lambda>s. \<exists>s'. (s', s) \<in> sr \<and> P s' \<rbrace> M \<lbrace> \<lambda>r s. \<forall>s'. (s', s) \<in> sr \<longrightarrow> Q r s' \<rbrace>"
  apply (rule iffI [rotated])
   apply (clarsimp simp: image_def split_def valid_def in_exec_transformed)
   apply force
  apply (clarsimp simp: image_def split_def valid_def exec_transformed_def)
  apply (erule allE, erule (1) impE)
  apply (case_tac "M s")
  apply (erule_tac allE, erule impE)
   by (auto intro!: exI)

lemma exec_transformed_wp [wp]:
    "\<lbrace> \<lambda>s. \<exists>s'. (s', s) \<in> sr \<and> P s' \<rbrace> M \<lbrace> \<lambda>r s. \<forall>s'. (s', s) \<in> sr \<longrightarrow> Q r s' \<rbrace> \<Longrightarrow> \<lbrace> P \<rbrace> exec_transformed sr M \<lbrace> Q \<rbrace>"
  apply (subst exec_transformed_valid_def)
  apply simp
  done

lemma exec_transformedE_wp [wp]:
  "\<lbrace> \<lambda>s. \<exists>s'. (s', s) \<in> sr \<and> P s' \<rbrace> M \<lbrace> \<lambda>r s. \<forall>s'. (s', s) \<in> sr \<longrightarrow> Q r s' \<rbrace>,\<lbrace> \<lambda>r s. \<forall>s'. (s', s) \<in> sr \<longrightarrow> E r s' \<rbrace>
      \<Longrightarrow> \<lbrace> P \<rbrace> exec_transformed sr M \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  apply (clarsimp simp: validE_def)
  apply (rule exec_transformed_wp)
  apply (clarsimp simp: valid_def split: sum.splits)
  apply force
  done

lemma exec_transformed_no_fail [wp]:
  "no_fail (\<lambda>s. \<exists>s'. (s', s) \<in> sr \<and> P s') M \<Longrightarrow> no_fail P (exec_transformed sr M)"
  apply (clarsimp simp: no_fail_def snd_exec_transformed)
  apply force
  done

lemmas exec_transformed_wp_nf [wp] =
  validNF [OF exec_transformed_wp exec_transformed_no_fail]

lemma exec_transformed_return_wp [wp]:
    "\<lbrace> \<lambda>s. \<forall>s''. (\<exists>s'. (s, s') \<in> sr \<and> (s'', s') \<in> sr) \<longrightarrow> P a s'' \<rbrace> exec_transformed sr (return a) \<lbrace> P \<rbrace>"
  apply (rule exec_transformed_wp, wp)
  apply clarsimp
  apply force
  done

lemma exec_transformed_returnOk_wp [wp]:
    "\<lbrace> \<lambda>s. \<forall>s''. (\<exists>s'. (s, s') \<in> sr \<and> (s'', s') \<in> sr) \<longrightarrow> P a s'' \<rbrace> exec_transformed sr (returnOk a) \<lbrace> P \<rbrace>,\<lbrace> E \<rbrace>"
  apply (rule exec_transformedE_wp, wp)
  apply clarsimp
  apply force
  done

lemma exec_transformed_fail_wp_nf [wp]:
    "\<lbrace> \<lambda>s. \<not> (\<exists>s'. (s, s') \<in> sr) \<rbrace> exec_transformed sr fail \<lbrace> P \<rbrace>!"
  apply (rule exec_transformed_wp_nf, wp)
  apply (clarsimp simp: fail_def no_fail_def)
  apply force
  done

lemma exec_transformed_fail_wp [wp]:
    "\<lbrace> \<lambda>_. True \<rbrace> exec_transformed st fail \<lbrace> P \<rbrace>"
  by (rule exec_transformed_wp, wp)

(*
 * Execute the given monad with a concrete state.
 *
 * In particular, we non-determinstically select a concrete state that maps
 * to the current abstract state, execute @{term M}, and then map the resulting
 * states back into the abstract universe.
 *)
definition "exec_concrete (st :: 't \<Rightarrow> 's)  (M :: ('t, 'r) nondet_monad) \<equiv>
       \<lambda>s. ({(r, t). \<exists>s' t'. s = st s' \<and> t = st t' \<and> (r, t') \<in> fst (M s')},
            \<exists>s'. s = st s' \<and> snd (M s'))"

lemma "exec_concrete st M = exec_transformed {(s, t). st t = s} M"
  apply (rule ext)
  apply (clarsimp simp: exec_concrete_def exec_transformed_def)
  apply force
  done

lemma in_exec_concrete [monad_eq]:
  "((r, s') \<in> fst (exec_concrete st A s)) = (\<exists>t t'. st t = s \<and> st t' = s' \<and> (r, t') \<in> fst (A t))"
  apply (clarsimp simp: exec_concrete_def split_def image_def)
  apply force
  done

lemma snd_exec_concrete [monad_eq]:
  "snd (exec_concrete st M s) = (\<exists>x. st x = s \<and> snd (M x))"
  by (fastforce simp: exec_concrete_def)

lemma exec_concrete_id [simp]:
    "exec_concrete id M = M"
    "exec_concrete (\<lambda>a. a) M = M"
  apply (auto simp: exec_concrete_def)
  done

lemma exec_concrete_wp [wp]:
    "\<lbrace> \<lambda>s. P (st s) \<rbrace> M \<lbrace> \<lambda>r s. Q r (st s) \<rbrace> \<Longrightarrow> \<lbrace> P \<rbrace> exec_concrete st M \<lbrace> Q \<rbrace>"
  apply (clarsimp simp: image_def split_def valid_def in_exec_concrete)
  apply force
  done

lemma exec_concreteE_wp [wp]:
  "\<lbrace> \<lambda>s. P (st s) \<rbrace> M \<lbrace> \<lambda>r s. Q r (st s) \<rbrace>,\<lbrace> \<lambda>r s. E r (st s) \<rbrace>
      \<Longrightarrow> \<lbrace> P \<rbrace> exec_concrete st M \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  apply (clarsimp simp: validE_def)
  apply (rule exec_concrete_wp)
  apply simp
  done

lemma exec_concrete_no_fail [wp]:
  "no_fail (\<lambda>s. P (st s)) M \<Longrightarrow> no_fail P (exec_concrete st M)"
  apply (clarsimp simp: no_fail_def snd_exec_concrete)
  done

lemma exec_concrete_wp_nf [wp]:
    "\<lbrace> \<lambda>s. P (st s) \<rbrace> M \<lbrace> \<lambda>r s. Q r (st s) \<rbrace>! \<Longrightarrow> \<lbrace> P \<rbrace> exec_concrete st M \<lbrace> Q \<rbrace>!"
  apply rule
   apply (rule exec_concrete_wp)
   apply (erule validNF_valid)
  including no_pre
  apply wp
  apply (erule validNF_no_fail)
  done

lemma exec_concrete_return_wp [wp]:
    "\<lbrace> P a \<rbrace> exec_concrete st (return a) \<lbrace> P \<rbrace>"
  by wp

lemma exec_concrete_returnOk_wp [wp]:
    "\<lbrace> P a \<rbrace> exec_concrete st (returnOk a) \<lbrace> P \<rbrace>,\<lbrace> E \<rbrace>"
  by wp

lemma exec_concrete_return_wp_nf [wp]:
    "\<lbrace> P a \<rbrace> exec_concrete st (return a) \<lbrace> P \<rbrace>!"
  by wp

lemma exec_concrete_fail_wp_nf [wp]:
    "\<lbrace> \<lambda>s. False \<rbrace> exec_concrete st fail \<lbrace> P \<rbrace>!"
  by wp

lemma exec_concrete_fail_wp [wp]:
    "\<lbrace> \<lambda>_. True \<rbrace> exec_concrete st fail \<lbrace> P \<rbrace>"
  by wp

lemma corresXF_simple_exec_concrete:
    "corresXF_simple st (\<lambda>r s. r) P (exec_concrete st M) M"
  apply (clarsimp simp: corresXF_simple_def  image_def split_def
      snd_exec_concrete in_exec_concrete)
  apply force
  done

lemma corresXF_exec_concrete_self:
    "corresXF st (\<lambda>r s. r) (\<lambda>r s. r) P (exec_concrete st M) M"
  apply (subst corresXF_simple_corresXF [symmetric])
  apply (simp add: surjective_sum[where f=id, simplified])
  apply (rule corresXF_simple_exec_concrete)+
  done

lemma corresXF_exec_concrete [intro?]:
  "corresXF id ret_xf ex_xf P A C \<Longrightarrow> corresXF st ret_xf ex_xf P (exec_concrete st A) C"
  apply (clarsimp simp: corresXF_def exec_concrete_def split: sum.splits)
  apply safe
    apply (clarsimp simp: image_def split_def)
    apply force
   apply (clarsimp simp: image_def split_def)
   apply force
  done

lemma exec_concrete_empty_fail [wp]:
  "\<lbrakk> empty_fail M; \<forall>s. \<exists>x. st x = s \<rbrakk> \<Longrightarrow> empty_fail (exec_concrete st M)"
  apply (subst empty_fail_def)
  apply (clarsimp simp: exec_concrete_def)
  apply (metis empty_failD2  surjective_pairing)
  done

(*
 * Execute the given monad in a modified state.
 *)
definition "exec_abstract st M \<equiv>
       \<lambda>s'. ({(r', t'). \<exists>t. t = st t' \<and> (r', t) \<in> fst (M (st s'))},
            \<exists>s. s = st s' \<and> snd (M (st s')))"

lemma exec_abstract_transformed:
    "exec_abstract st M = exec_transformed {(s, t). t = st s} M"
  apply (rule ext)
  apply (clarsimp simp: exec_transformed_def exec_abstract_def)
  apply blast
  done

lemma in_exec_abstract [monad_eq]:
  "((r, t) \<in> fst (exec_abstract st A s)) = (\<exists>t'. st t = t' \<and> (r, t') \<in> fst (A (st s)))"
  by (clarsimp simp: exec_abstract_def split_def image_def)

lemma snd_exec_abstract [monad_eq]:
  "snd (exec_abstract st M s) = (snd (M (st s)))"
  by (clarsimp simp: exec_abstract_def)

lemma exec_abstract_id [simp]:
    "exec_abstract id M = M"
    "exec_abstract (\<lambda>a. a) M = M"
  apply (auto simp: exec_abstract_def)
  done

lemma exec_abstract_valid_def:
    "\<lbrace> P \<rbrace> exec_abstract st M \<lbrace> Q \<rbrace> = \<lbrace> \<lambda>s. \<exists>s'. st s' = s \<and> P s' \<rbrace> M \<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> Q r t \<rbrace>"
  apply (subst exec_abstract_transformed)
  apply (subst exec_transformed_valid_def)
  apply (fastforce simp: valid_def)
  done

lemma exec_abstract_wp [wp]:
    "\<lbrakk> \<lbrace> P \<rbrace> M \<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> Q r t \<rbrace>  \<rbrakk>
              \<Longrightarrow> \<lbrace> \<lambda>s. P (st s) \<rbrace> exec_abstract st M \<lbrace> Q \<rbrace>"
  apply (subst exec_abstract_valid_def)
  apply (clarsimp simp: valid_def)
  apply force
  done

lemma exec_abstractE_wp [wp]:
    "\<lbrakk> \<lbrace> P \<rbrace> M \<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> Q r t \<rbrace>,\<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> E r t \<rbrace>  \<rbrakk>
              \<Longrightarrow> \<lbrace> \<lambda>s. P (st s) \<rbrace> exec_abstract st M \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  apply (clarsimp simp: validE_def)
  apply (rule exec_abstract_wp)
  apply (clarsimp simp: valid_def split: sum.splits)
  apply force
  done

lemma exec_abstract_no_fail [wp]:
  "no_fail (\<lambda>s. \<exists>t. st t = s \<and> P t) M \<Longrightarrow> no_fail P (exec_abstract st M)"
  apply (clarsimp simp: no_fail_def snd_exec_abstract)
  apply force
  done

lemma exec_abstract_wp_nf [wp]:
    "\<lbrakk> \<lbrace> P \<rbrace> M \<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> Q r t \<rbrace>!  \<rbrakk>
              \<Longrightarrow> \<lbrace> \<lambda>s. P (st s) \<rbrace> exec_abstract st M \<lbrace> Q \<rbrace>!"
  apply rule
   apply (rule exec_abstract_wp)
   apply (erule validNF_valid)
  apply (rule exec_abstract_no_fail)
  apply (rule validNF_no_fail)
  apply (erule validNF_weaken_pre)
  apply force
  done

lemma exec_abstract_return_wp [wp]:
    "\<lbrace> \<lambda>s. \<forall>t. st s = st t \<longrightarrow> P a t \<rbrace> exec_abstract st (return a) \<lbrace> P \<rbrace>"
  apply wp
  apply clarsimp
  done

lemma exec_abstract_returnOk_wp [wp]:
    "\<lbrace> \<lambda>s. \<forall>t. st s = st t \<longrightarrow> P a t \<rbrace> exec_abstract st (returnOk a) \<lbrace> P \<rbrace>,\<lbrace> E \<rbrace>"
  apply wp
  apply clarsimp
  done

lemma exec_abstract_return_wp_nf [wp]:
    "\<lbrace> \<lambda>s. \<forall>t. st s = st t \<longrightarrow> P a t \<rbrace> exec_abstract st (return a) \<lbrace> P \<rbrace>!"
  apply wp
  apply clarsimp
  done

lemma exec_abstract_fail_wp_nf [wp]:
    "\<lbrace> \<lambda>s. False \<rbrace> exec_abstract st fail \<lbrace> P \<rbrace>!"
  apply wp
  apply clarsimp?
  done

lemma exec_abstract_fail_wp [wp]:
    "\<lbrace> \<lambda>_. True \<rbrace> exec_abstract st fail \<lbrace> P \<rbrace>"
  by wp

lemma corresXF_simple_exec_abstract:
    "corresXF_simple st (\<lambda>r s. r) P M (exec_abstract st M)"
  apply (clarsimp simp: corresXF_simple_def  image_def split_def
      snd_exec_abstract in_exec_abstract)
  done

lemma corresXF_exec_abstract_self:
    "corresXF st (\<lambda>r s. r) (\<lambda>r s. r) P M (exec_abstract st M)"
  apply (subst corresXF_simple_corresXF [symmetric])
  apply (simp add: surjective_sum[where f=id, simplified])
  apply (rule corresXF_simple_exec_abstract)
  done

lemma corresXF_exec_abstract [intro?]:
  "corresXF st ret_xf ex_xf P A C \<Longrightarrow> corresXF id ret_xf ex_xf P (exec_abstract st A) C"
  apply (clarsimp simp: corresXF_def exec_abstract_def split: sum.splits)
  done

lemma exec_abstract_empty_fail [wp]:
  "\<lbrakk> empty_fail M; \<forall>s. \<exists>x. st x = s \<rbrakk> \<Longrightarrow> empty_fail (exec_abstract st M)"
  apply (clarsimp simp: empty_fail_def exec_abstract_def)
  apply (metis nonemptyE surjective_pairing)
  done

end


(*****************************************************************************
 * Copyright (c) 2005-2010 ETH Zurich, Switzerland
 *               2008-2015 Achim D. Brucker, Germany
 *               2009-2016 Université Paris-Sud, France
 *               2015-2016 The University of Sheffield, UK
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *****************************************************************************)

subsection\<open>Network Address Translation\<close>
theory
  NAT
  imports
    "../PacketFilter/PacketFilter"
begin

definition src2pool :: "'\<alpha> set \<Rightarrow> ('\<alpha>::adr,'\<beta>) packet \<Rightarrow> ('\<alpha>,'\<beta>) packet set" where
  "src2pool t = (\<lambda> p. ({(i,s,d,da). (i = id p \<and> s \<in> t \<and> d = dest p \<and> da = content p)}))"

definition src2poolAP where
  "src2poolAP t = A\<^sub>f (src2pool t)"

definition srcNat2pool :: "'\<alpha> set \<Rightarrow> '\<alpha> set \<Rightarrow> ('\<alpha>::adr,'\<beta>) packet \<mapsto> ('\<alpha>,'\<beta>) packet set" where
  "srcNat2pool srcs transl = {x. src x \<in> srcs} \<triangleleft> (src2poolAP transl)"

definition src2poolPort :: "int set \<Rightarrow> (adr\<^sub>i\<^sub>p,'\<beta>) packet \<Rightarrow> (adr\<^sub>i\<^sub>p,'\<beta>) packet set" where
  "src2poolPort t = (\<lambda> p. ({(i,(s1,s2),(d1,d2),da).
          (i = id p \<and> s1 \<in> t \<and> s2 = (snd (src p)) \<and> d1 = (fst (dest p)) \<and>
                d2 = snd (dest p) \<and> da = content p)}))"

definition src2poolPort_Protocol :: "int set \<Rightarrow> (adr\<^sub>i\<^sub>p\<^sub>p,'\<beta>) packet \<Rightarrow> (adr\<^sub>i\<^sub>p\<^sub>p,'\<beta>) packet set" where
  "src2poolPort_Protocol t = (\<lambda> p. ({(i,(s1,s2,s3),(d1,d2,d3), da).
  (i = id p \<and> s1 \<in> t \<and> s2 = (fst (snd (src p))) \<and> s3 = snd (snd (src p)) \<and>
                   (d1,d2,d3) = dest p \<and> da = content p)}))"

definition srcNat2pool_IntPort :: "address set \<Rightarrow> address set \<Rightarrow>
 (adr\<^sub>i\<^sub>p,'\<beta>) packet \<mapsto> (adr\<^sub>i\<^sub>p,'\<beta>) packet set" where
  "srcNat2pool_IntPort srcs transl =
      {x. fst (src x) \<in> srcs} \<triangleleft> (A\<^sub>f (src2poolPort transl))"

definition srcNat2pool_IntProtocolPort :: "int set \<Rightarrow> int set \<Rightarrow>
 (adr\<^sub>i\<^sub>p\<^sub>p,'\<beta>) packet \<mapsto> (adr\<^sub>i\<^sub>p\<^sub>p,'\<beta>) packet set" where
  "srcNat2pool_IntProtocolPort srcs transl =
      {x. (fst ( (src x))) \<in> srcs} \<triangleleft> (A\<^sub>f (src2poolPort_Protocol transl))"

definition srcPat2poolPort_t :: "int set \<Rightarrow> (adr\<^sub>i\<^sub>p,'\<beta>) packet \<Rightarrow> (adr\<^sub>i\<^sub>p,'\<beta>) packet set" where
  "srcPat2poolPort_t t = (\<lambda> p. ({(i,(s1,s2),(d1,d2),da).
           (i = id p \<and> s1 \<in> t \<and> d1 = (fst (dest p)) \<and> d2 = snd (dest p)\<and> da = content p)}))"

definition srcPat2poolPort_Protocol_t :: "int set \<Rightarrow> (adr\<^sub>i\<^sub>p\<^sub>p,'\<beta>) packet \<Rightarrow> (adr\<^sub>i\<^sub>p\<^sub>p,'\<beta>) packet set" where
  "srcPat2poolPort_Protocol_t t = (\<lambda> p. ({(i,(s1,s2,s3),(d1,d2,d3),da).
  (i = id p \<and> s1 \<in> t \<and> s3 = src_protocol p \<and> (d1,d2,d3) = dest p \<and> da = content p)}))"

definition srcPat2pool_IntPort :: "int set \<Rightarrow> int set \<Rightarrow> (adr\<^sub>i\<^sub>p,'\<beta>) packet \<mapsto>
                                            (adr\<^sub>i\<^sub>p,'\<beta>) packet set" where
  "srcPat2pool_IntPort srcs transl =
  {x. (fst (src x)) \<in> srcs} \<triangleleft> (A\<^sub>f (srcPat2poolPort_t transl))"

definition srcPat2pool_IntProtocol ::
  "int set \<Rightarrow> int set \<Rightarrow> (adr\<^sub>i\<^sub>p\<^sub>p,'\<beta>) packet \<mapsto> (adr\<^sub>i\<^sub>p\<^sub>p,'\<beta>) packet set" where

  "srcPat2pool_IntProtocol srcs transl =
  {x. (fst (src x)) \<in> srcs} \<triangleleft> (A\<^sub>f (srcPat2poolPort_Protocol_t transl))"

text\<open>
  The following lemmas are used for achieving a normalized output format of packages after
  applying NAT. This is used, e.g., by our firewall execution tool.
\<close>

lemma datasimp: "{(i, (s1, s2, s3), aba).
                    \<forall>a aa b ba. aba = ((a, aa, b), ba) \<longrightarrow> i = i1 \<and> s1 = i101 \<and>
                               s3 = iudp \<and> a = i110 \<and> aa = X606X3 \<and> b = X607X4 \<and> ba = data}
                 = {(i, (s1, s2, s3), aba).
                    i = i1 \<and> s1 = i101 \<and> s3 = iudp \<and> (\<lambda> ((a,aa,b),ba). a = i110 \<and> aa = X606X3 \<and>
                    b = X607X4 \<and> ba = data) aba}"
  by auto

lemma datasimp2: "{(i, (s1, s2, s3), aba).
                    \<forall>a aa b ba. aba = ((a, aa, b), ba) \<longrightarrow> i = i1 \<and> s1 = i132 \<and> s3 = iudp \<and>
                        s2 = i1 \<and> a = i110 \<and> aa = i4 \<and> b = iudp \<and> ba = data}
                = {(i, (s1, s2, s3), aba).
                       i = i1 \<and> s1 = i132 \<and> s3 = iudp \<and> s2 = i1 \<and> (\<lambda> ((a,aa,b),ba). a = i110 \<and>
                       aa = i4 \<and> b = iudp \<and> ba = data) aba}"
  by auto

lemma datasimp3: "{(i, (s1, s2, s3), aba).
                     \<forall> a aa b ba. aba = ((a, aa, b), ba) \<longrightarrow> i = i1 \<and> i115 < s1 \<and> s1 < i124 \<and>
                         s3 = iudp \<and> s2 = ii1 \<and> a = i110 \<and> aa = i3 \<and> b = itcp \<and> ba = data}
                = {(i, (s1, s2, s3), aba).
                         i = i1 \<and> i115 < s1 \<and> s1 < i124 \<and> s3 = iudp \<and> s2 = ii1 \<and>
                       (\<lambda> ((a,aa,b),ba). a = i110 & aa = i3 & b = itcp & ba = data) aba}"
  by auto

lemma datasimp4: "{(i, (s1, s2, s3), aba).
                    \<forall>a aa b ba. aba = ((a, aa, b), ba) \<longrightarrow> i = i1 \<and> s1 = i132 \<and> s3 = iudp \<and>
                        s2 = ii1 \<and> a = i110 \<and> aa = i7 \<and> b = itcp \<and> ba = data}
                = {(i, (s1, s2, s3), aba).
                        i = i1 \<and> s1 = i132 \<and> s3 = iudp \<and> s2 = ii1 \<and>
                        (\<lambda> ((a,aa,b),ba). a = i110 \<and> aa = i7 \<and> b = itcp \<and> ba = data) aba}"
  by auto

lemma datasimp5: " {(i, (s1, s2, s3), aba).
                     i = i1 \<and> s1 = i101 \<and> s3 = iudp \<and> (\<lambda> ((a,aa,b),ba). a = i110 \<and> aa = X606X3 \<and>
                       b = X607X4 \<and> ba = data) aba}
                 = {(i, (s1, s2, s3), (a,aa,b),ba).
                       i = i1 \<and> s1 = i101 \<and> s3 = iudp \<and>  a = i110 \<and> aa = X606X3 \<and>
                       b = X607X4 \<and> ba = data}"
  by auto

lemma datasimp6: "{(i, (s1, s2, s3), aba).
                     i = i1 \<and> s1 = i132 \<and> s3 = iudp \<and> s2 = i1 \<and>
                     (\<lambda> ((a,aa,b),ba). a = i110 \<and>  aa = i4 \<and> b = iudp \<and> ba = data) aba}
                 = {(i, (s1, s2, s3), (a,aa,b),ba).
                       i = i1 \<and> s1 = i132 \<and> s3 = iudp \<and> s2 = i1 \<and> a = i110 \<and>
                       aa = i4 \<and> b = iudp \<and> ba = data}"
  by auto

lemma datasimp7: "{(i, (s1, s2, s3), aba).
                     i = i1 \<and> i115 < s1 \<and> s1 < i124 \<and> s3 = iudp \<and> s2 = ii1 \<and>
                     (\<lambda> ((a,aa,b),ba). a = i110 \<and> aa = i3 \<and> b = itcp \<and> ba = data) aba}
                = {(i, (s1, s2, s3), (a,aa,b),ba).
                     i = i1 \<and> i115 < s1 \<and> s1 < i124 \<and> s3 = iudp \<and> s2 = ii1
                     \<and> a = i110 \<and> aa = i3 \<and> b = itcp \<and> ba = data}"
  by auto

lemma datasimp8: "{(i, (s1, s2, s3), aba). i = i1 \<and> s1 = i132 \<and> s3 = iudp \<and> s2 = ii1 \<and>
                   (\<lambda> ((a,aa,b),ba). a = i110 \<and> aa = i7 \<and> b = itcp \<and> ba = data) aba}
                = {(i, (s1, s2, s3), (a,aa,b),ba). i = i1 \<and> s1 = i132 \<and> s3 = iudp
                                   \<and> s2 = ii1 \<and>  a = i110 \<and> aa = i7 \<and> b = itcp \<and> ba = data}"
  by auto

lemmas datasimps = datasimp datasimp2 datasimp3 datasimp4
                   datasimp5 datasimp6 datasimp7 datasimp8

lemmas NATLemmas = src2pool_def src2poolPort_def
                   src2poolPort_Protocol_def src2poolAP_def srcNat2pool_def
                   srcNat2pool_IntProtocolPort_def srcNat2pool_IntPort_def
                   srcPat2poolPort_t_def srcPat2poolPort_Protocol_t_def
                   srcPat2pool_IntPort_def srcPat2pool_IntProtocol_def
end


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

theory n_german_lemma_inv__4_on_rules imports n_german_lemma_on_inv__4
begin
section{*All lemmas on causal relation between inv__4*}
lemma lemma_inv__4_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__4  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  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)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__4) done
    }

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

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

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

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

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvSVsinv__4) 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__4) 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__4) 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__4) 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__4) 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__4) 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__4) 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__4) done
    }

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

end


theory func_cor_OSMemPut
  imports func_cor_other
begin

lemma OSMemPut_satRG1: " \<turnstile>\<^sub>I (W\<acute>OS_MEM_info := \<acute>OS_MEM_info(pmem := \<acute>OS_MEM_info pmem\<lparr>OSMemFreeList := pblk # OSMemFreeList (\<acute>OS_MEM_info pmem)\<rparr>);;
              \<acute>OS_MEM_info := \<acute>OS_MEM_info(pmem := \<acute>OS_MEM_info pmem\<lparr>OSMemNFree := OSMemNFree (\<acute>OS_MEM_info pmem) + 1\<rparr>);;
              \<acute>ret := \<acute>ret
              (t := OS_ERR_NONE)) sat\<^sub>p [OSMemPut_pre t \<inter> \<lbrace>pmem \<in> \<acute>OS_MEMs\<rbrace> \<inter> \<lbrace>\<acute>cur = Some t\<rbrace> \<inter> {V} \<inter> {Va} \<inter>
                                         - \<lbrace>OSMemNBlks (\<acute>OS_MEM_info pmem)
                                            \<le> OSMemNFree
                                                (\<acute>OS_MEM_info pmem)\<rbrace>, {(s, t). s = t}, UNIV, \<lbrace>\<acute>(Pair V) \<in> OSMemPut_guar t\<rbrace> \<inter> OSMemPut_post t]"
  apply (case_tac "OSMemPut_pre t \<inter> \<lbrace>pmem \<in> \<acute>OS_MEMs\<rbrace> \<inter> \<lbrace>\<acute>cur = Some t\<rbrace> \<inter> {V} \<inter> {Va} \<inter>
                                         - \<lbrace>OSMemNBlks (\<acute>OS_MEM_info pmem)
                                            \<le> OSMemNFree
                                                (\<acute>OS_MEM_info pmem)\<rbrace> = {}")
  using Emptyprecond apply auto[1]
   apply (simp add: Emptyprecond)
  apply (rule Seq[where mid = "{V\<lparr>OS_MEM_info := (OS_MEM_info V)(pmem := OS_MEM_info V
                                  pmem \<lparr>OSMemFreeList := pblk # OSMemFreeList (OS_MEM_info V pmem),
                                  OSMemNFree := OSMemNFree (OS_MEM_info V pmem) + 1\<rparr>)\<rparr>}"])
   apply (rule Seq[where mid = " {V\<lparr>OS_MEM_info := (OS_MEM_info V)(pmem := OS_MEM_info V
                                  pmem\<lparr>OSMemFreeList := pblk # OSMemFreeList (OS_MEM_info V pmem)\<rparr>)\<rparr>}"])
    apply (rule Basic)
        apply(simp add:OSMemPut_pre_def inv_def)
       apply (simp add: inv_cur_def)
       apply (simp add:inv_OS_Mem_info_def inv_OS_Mem_info_mp_def)
  apply clarify
     apply (simp add: stable_id2)
     apply (simp add: stable_id2)
  using stable_id2 apply blast
   apply (rule Basic)
        apply(simp add:OSMemPut_pre_def inv_def)
     apply (simp add: inv_cur_def)
  using stable_id2 apply blast
  using stable_id2 apply blast
  apply (rule Basic)
     apply (simp add: OSMemPut_guar_def)
     apply (case_tac "cur V \<noteq> Some t")
      apply auto
       apply (simp add: gvars_conf_stable_def gvars_conf_def)
       apply (simp add: inv_def inv_cur_def  inv_OS_Mem_info_def inv_OS_Mem_info_mp_def inv_thd_waitq_def)
      apply auto
        apply meson
       apply smt
      apply meson
     apply (simp add: lvars_nochange_def)
    apply (simp add: OSMemPut_pre_def OSMemPut_post_def)
    apply (simp add: inv_def  inv_cur_def inv_OS_Mem_info_def inv_OS_Mem_info_mp_def inv_thd_waitq_def)
    apply auto
      apply meson
     apply smt
     apply meson
   apply (simp add: stable_id2)
  by (simp add: stable_id2)

lemma OSMemPut_satRG: "\<Gamma> (OSMemPut t pmem pblk) \<turnstile> OSMemPut_RGCond t"
  apply (simp add:Evt_sat_RG_def)
  apply (simp add:OSMemPut_def OSMemPut_RGCond_def)
  apply (rule BasicEvt)
  apply(simp add:body_def Pre\<^sub>f_def Post\<^sub>f_def guard_def
                 Rely\<^sub>f_def Guar\<^sub>f_def getrgformula_def)
    apply(unfold stm_def)[1]
    apply(rule Await)
      apply (simp add: OSMemPut_pre_def OSMemPut_rely_def gvars_conf_def gvars_conf_stable_def stable_def)
     apply (simp add: OSMemPut_post_def stable_inv_free_rely1)
    apply (rule allI)
    apply(rule Await)
      apply (simp add: stable_id2)
     apply (simp add: stable_id2)
    apply (rule allI)
    apply (rule Cond)
  using stable_id2 apply blast
  apply (rule Basic)
     apply (simp add: OSMemPut_post_def OSMemPut_guar_def)
     apply(simp add:gvars_nochange_def lvars_nochange_def)
     apply(simp add:inv_def inv_cur_def gvars_conf_stable_def)
     apply(simp add:inv_OS_Mem_info_def inv_OS_Mem_info_mp_def inv_thd_waitq_def)
     apply auto
       apply (simp add: gvars_conf_def)
  using OSMemPut_pre_def inv_cur_def invariant.inv_def apply blast
     apply (simp add: OSMemPut_pre_def inv_cur_def inv_def)
           apply (simp add: OSMemPut_pre_def inv_OS_Mem_info_def inv_OS_Mem_info_mp_def inv_def inv_thd_waitq_def)
  using OSMemPut_pre_def inv_thd_waitq_def invariant.inv_def apply blast
         apply (simp add: OSMemPut_pre_def inv_thd_waitq_def invariant.inv_def)
  using OSMemPut_pre_def inv_thd_waitq_def invariant.inv_def apply blast
  using OSMemPut_pre_def inv_thd_waitq_def invariant.inv_def apply blast
  using stable_id2 apply blast
     apply (simp add: stable_id2)
  using OSMemPut_satRG1 apply simp
  apply(simp add:body_def Pre\<^sub>f_def Post\<^sub>f_def guard_def
                  Rely\<^sub>f_def Guar\<^sub>f_def getrgformula_def)
  using OSMemPut_pre_stb apply simp
  apply (simp add:getrgformula_def OSMemPut_guar_def)
  apply(simp add:body_def Pre\<^sub>f_def Post\<^sub>f_def guard_def
                  Rely\<^sub>f_def Guar\<^sub>f_def getrgformula_def)
  done

end


theory "Env-Set-Cpo"
imports "../Launchbury/Env" "Set-Cpo"
begin

lemma cont_edom[THEN cont_compose, simp, cont2cont]:
  "cont (\<lambda> f. edom f)"
  apply (rule set_contI)
  apply (auto simp add: edom_def)
  apply (metis ch2ch_fun lub_eq_bottom_iff lub_fun)
  apply (metis ch2ch_fun lub_eq_bottom_iff lub_fun)
  done

end


(*  Title:      HOL/Auth/n_german_lemma_on_inv__5.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_german Protocol Case Study*}*)

theory n_german_lemma_on_inv__5 imports n_german_base
begin
section{*All lemmas on causal relation between inv__5 and some rule r*}
lemma n_SendInv__part__0Vsinv__5:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__0  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__1Vsinv__5:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__1  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvAckVsinv__5:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__5:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv0) ''State'')) (Const E)) (eqn (IVar (Ident ''ExGntd'')) (Const false))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__5:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__5:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__5:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv0) ''Cmd'')) (Const GntE)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const GntS))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendReqE__part__1Vsinv__5:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_StoreVsinv__5:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvInvAckVsinv__5:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqEVsinv__5:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqE N i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqE__part__0Vsinv__5:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqSVsinv__5:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqS  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqSVsinv__5:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqS N i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__5  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


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

theory Sep_Provers_Example
imports Sep_Provers
begin

axiomatization
  Moo :: "'a :: stronger_sep_algebra => bool" and
  Bar :: "'a :: stronger_sep_algebra => bool"
where  Moo_Bar : "Moo s \<Longrightarrow> Bar s"

(* sep_rule is 'rule' with rotations of the conjuncts in the conclusions *)
lemma "(A \<and>* B \<and>* C \<and>* Bar) s"
  apply (sep_rule Moo_Bar)
  oops

(* sep_drule is 'drule' with rotations of the conjuncts in the assumptions *)
lemma "(A \<and>* B \<and>* C \<and>* Moo) s \<Longrightarrow> R"
  apply (sep_drule Moo_Bar)
  oops

(* sep_erule is 'erule' with rotations of the conjuncts in either the assumptions,
   the conclusions, or both. These are sep_erule, sep_erule_concl, and sep_erule_full respectively
    *)
lemma "(A \<and>* B \<and>* C \<and>* Moo) s \<Longrightarrow> (A \<and>* B \<and>* C \<and>* Bar) s"
   (* In this case we need to rotate both, so we use sep_erule_full *)
  apply (sep_erule_full Moo_Bar)
  apply (assumption)
  done

axiomatization where Moo_Bar_R: "(Moo \<and>* R) s \<Longrightarrow> (Bar \<and>* R) s"

(* When we have theorems with the frame explicitly mentioned, we have to invoke our tactics with
   (direct) option *)

lemma "(A \<and>* B \<and>* C \<and>* Moo) s \<Longrightarrow> (A \<and>* B \<and>* C \<and>* Bar) s"
  apply (sep_erule_full (direct) Moo_Bar_R)
  done

end