(******************************************************************************
 * Orca: A Functional Correctness Verifier for Imperative Programs
 *       Based on Isabelle/UTP
 *
 * Copyright (c) 2016-2018 Virginia Tech, USA
 *               2016-2018 Technische Universität München, Germany
 *               2016-2018 University of York, UK
 *               2016-2018 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * This software may be distributed and modified according to the terms of
 * the GNU Lesser General Public License version 3.0 or any later version.
 * Note that NO WARRANTY is provided.
 *
 * See CONTRIBUTORS, LICENSE and CITATION files for details.
 ******************************************************************************)

theory utp_heap_scratch
imports   "../../../Isabelle-UTP/utp/utp"
          "../../../Isabelle-UTP/theories/utp_designs"
          "../../AlgebraicLaws/Algebraic_Laws_aux"
begin
subsection {*UTP heap alphabet*}

text {*
*}

alphabet ('hval, 'haddr) hp_vars = des_vars +
  heap_raw:: "'haddr \<rightharpoonup> 'hval"

declare hp_vars.splits [alpha_splits]

subsubsection {*Alphabet proofs*}
text {*
  The two locale interpretations below are a technicality to improve automatic
  proof support via the predicate and relational tactics. This is to enable the
  (re-)interpretation of state spaces to remove any occurrences of lens types
  after the proof tactics @{method pred_simp} and @{method rel_simp}, or any
  of their derivatives have been applied. Eventually, it would be desirable to
  automate both interpretations as part of a custom outer command for defining
  alphabets.
*}

interpretation cp_hp:
  lens_interp "\<lambda> (ok, r) . (ok, heap_raw\<^sub>v r, more r)"
  apply (unfold_locales)
  apply (rule injI)
  apply (clarsimp)
  done

interpretation cp_hp_rel: lens_interp "\<lambda>(ok, ok', r, r').
  (ok, ok', heap_raw\<^sub>v r, heap_raw\<^sub>v r', more r, more r')"
  apply (unfold_locales)
  apply (rule injI)
  apply (clarsimp)
  done

subsubsection {*Type lifting*}

type_synonym  ('hval, 'haddr, '\<alpha>) cphp = "('hval, 'haddr, '\<alpha>) hp_vars_scheme des"
type_synonym ('hval, 'haddr, '\<alpha>,'\<beta>) rel_cphp  = "(('hval, 'haddr,'\<alpha>) cphp, ('hval, 'haddr,'\<beta>) cphp) rel"
type_synonym ('hval, 'haddr, '\<alpha>) hrel_cphp  = "(('hval, 'haddr, '\<alpha>) cphp) hrel"

subsubsection {*Syntactic type setup*}

translations
  (type) "('hval, 'haddr, '\<alpha>) cphp" <= (type) " ('hval, 'haddr, '\<alpha>) hp_vars_scheme des"
  (type) "('hval, 'haddr, '\<alpha>) cphp" <= (type) "('hval, 'haddr, '\<alpha>) hp_vars_ext des"
  (type) "('hval, 'haddr, '\<alpha>,'\<beta>) rel_cphp" <=
         (type) "(('hval, 'haddr,'\<alpha>) cphp, (_, _,'\<beta>) cphp) rel"

notation hp_vars_child_lens\<^sub>a ("\<Sigma>\<^sub>h\<^sub>p")
notation hp_vars_child_lens ("\<Sigma>\<^sub>H\<^sub>P")

syntax
  "_svid_st_alpha"  :: "svid" ("\<Sigma>\<^sub>H\<^sub>P")
  "_svid_st_a"  :: "svid" ("\<Sigma>\<^sub>h\<^sub>p")
translations
  "_svid_st_alpha" => "CONST hp_vars_child_lens"
   "_svid_st_a" => "CONST hp_vars_child_lens\<^sub>a"

syntax
  "_top_abr" :: "logic" ("\<top>\<^sub>H\<^sub>P")
  "_bot_abr" :: "logic" ("\<bottom>\<^sub>H\<^sub>P")

translations
  "\<top>\<^sub>H\<^sub>P" => "(CONST not_upred (CONST utp_expr.var (CONST ivar CONST ok)))"
  "\<bottom>\<^sub>H\<^sub>P" => "true"

subsection {*Substitution lift and drop*}

abbreviation lift_rel_usubst_cpa ("\<lceil>_\<rceil>\<^sub>S\<^sub>H\<^sub>P")
where "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>H\<^sub>P \<equiv> \<sigma> \<oplus>\<^sub>s (\<Sigma>\<^sub>H\<^sub>P \<times>\<^sub>L \<Sigma>\<^sub>H\<^sub>P)"

abbreviation lift_usubst_cpa ("\<lceil>_\<rceil>\<^sub>s\<^sub>H\<^sub>P")
where "\<lceil>\<sigma>\<rceil>\<^sub>s\<^sub>H\<^sub>P \<equiv> \<lceil>\<lceil>\<sigma>\<rceil>\<^sub>s\<rceil>\<^sub>S\<^sub>H\<^sub>P"

abbreviation drop_cpa_rel_usubst ("\<lfloor>_\<rfloor>\<^sub>S\<^sub>H\<^sub>P")
where "\<lfloor>\<sigma>\<rfloor>\<^sub>S\<^sub>H\<^sub>P \<equiv> \<sigma> \<restriction>\<^sub>s (\<Sigma>\<^sub>H\<^sub>P \<times>\<^sub>L \<Sigma>\<^sub>H\<^sub>P)"

abbreviation drop_cpa_usubst ("\<lfloor>_\<rfloor>\<^sub>s\<^sub>H\<^sub>P")
where "\<lfloor>\<sigma>\<rfloor>\<^sub>s\<^sub>H\<^sub>P \<equiv> \<lfloor>\<lfloor>\<sigma>\<rfloor>\<^sub>S\<^sub>H\<^sub>P\<rfloor>\<^sub>s"

subsection {*UTP-Relations lift and drop*}

abbreviation lift_rel_uexpr_cpa ("\<lceil>_\<rceil>\<^sub>H\<^sub>P")
where "\<lceil>P\<rceil>\<^sub>H\<^sub>P \<equiv> P \<oplus>\<^sub>p (\<Sigma>\<^sub>H\<^sub>P \<times>\<^sub>L \<Sigma>\<^sub>H\<^sub>P)"

abbreviation lift_pre_uexpr_cpa ("\<lceil>_\<rceil>\<^sub>H\<^sub>P\<^sub><")
where "\<lceil>p\<rceil>\<^sub>H\<^sub>P\<^sub>< \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub><\<rceil>\<^sub>H\<^sub>P"

abbreviation lift_post_uexpr_cpa ("\<lceil>_\<rceil>\<^sub>H\<^sub>P\<^sub>>")
where "\<lceil>p\<rceil>\<^sub>H\<^sub>P\<^sub>> \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub>>\<rceil>\<^sub>H\<^sub>P"

abbreviation drop_cpa_rel_uexpr ("\<lfloor>_\<rfloor>\<^sub>H\<^sub>P")
where "\<lfloor>P\<rfloor>\<^sub>H\<^sub>P \<equiv> P \<restriction>\<^sub>p (\<Sigma>\<^sub>H\<^sub>P \<times>\<^sub>L \<Sigma>\<^sub>H\<^sub>P)"

abbreviation drop_cpa_pre_uexpr ("\<lfloor>_\<rfloor>\<^sub><\<^sub>H\<^sub>P")
where "\<lfloor>P\<rfloor>\<^sub><\<^sub>H\<^sub>P \<equiv> \<lfloor>\<lfloor>P\<rfloor>\<^sub>H\<^sub>P\<rfloor>\<^sub><"

abbreviation drop_cpa_post_uexpr ("\<lfloor>_\<rfloor>\<^sub>>\<^sub>H\<^sub>P")
where "\<lfloor>P\<rfloor>\<^sub>>\<^sub>H\<^sub>P \<equiv> \<lfloor>\<lfloor>P\<rfloor>\<^sub>H\<^sub>P\<rfloor>\<^sub>>"

subsection{*Healthiness conditions*}

subsection{*Control flow statements*}
text {**}
subsection{*Loops*}
subsection{*Experiments*}
term "map_lens k"

term "&heap_raw"
term "fun_upd f 0 (Some 1)"
term "(trop fun_upd (&heap_raw) \<guillemotleft>add::nat\<guillemotright> (uop Some \<guillemotleft>v::int\<guillemotright>))"
term "\<lbrakk>trop fun_upd (&heap_raw) \<guillemotleft>add\<guillemotright> (uop Some \<guillemotleft>v\<guillemotright>)\<rbrakk>\<^sub>e s add = Some v"

lemma "(trop fun_upd (&heap_raw) \<guillemotleft>add::nat\<guillemotright> (uop Some \<guillemotleft>v::int\<guillemotright>)) = mem \<Longrightarrow>
      \<exists>s. \<lbrakk>mem\<rbrakk>\<^sub>e s add =  Some v"
  apply rel_simp
  apply (auto  split: if_splits)
  done
term "store ptr v = (trop fun_upd (&heap_raw) ptr (uop Some v))"
 term "(trop fun_upd (&heap_raw) ptr (uop Some v))"

term "restricted_load ptr = utp_expr.var (map_lens ptr ;\<^sub>L heap_raw)"
term "uop (\<lambda>ptr. get\<^bsub>map_lens ptr ;\<^sub>L heap_raw\<^esub>)"

term "load ptru = (\<lambda>ptr \<bullet> utp_expr.var (map_lens ptr ;\<^sub>L heap_raw))(ptru)\<^sub>a"
term "\<lambda>ptru. (\<lambda>ptr \<bullet> utp_expr.var (map_lens ptr ;\<^sub>L heap_raw))(ptru)\<^sub>a"

datatype block =  available| freed
term "(utp_expr.var (map_lens ptr ;\<^sub>L heap_raw))"
term "get\<^bsub>(heap_raw)\<^esub> s"
term "&heap_raw"
term "ulambda"
lift_definition ulambda_rev :: "('a \<Rightarrow> 'b, '\<alpha>) uexpr \<Rightarrow> ('a \<Rightarrow> ('b, '\<alpha>) uexpr)"
is "\<lambda> f x A. f A x" .
term "ulambda_rev (utp_expr.var (map_lens ptr ;\<^sub>L heap_raw))"

term "uop (ulambda_rev (&heap_raw)) p "
term "((&heap_raw) s)"
term "(&heap_raw)"
term "utp_expr.var ( map_lens ptr ;\<^sub>L heap_raw)"
term "(map_lens ptr ;\<^sub>L heap_raw)"
find_consts  "('a \<Rightarrow> 'b, 'c) uexpr \<Rightarrow> ('a \<Rightarrow> ('b, 'c) uexpr) "
term "\<lambda>x\<bullet> \<guillemotleft>(x::int)\<guillemotright>"
datatype ('n,'a) Ptr = pt:ptr | nm: Numeral (selctn:'n)
find_theorems name:".Ptr."
term "ptr"
term "pt"
term "\<lparr> lens_get = (\<lambda>s. None),
        lens_put = (\<lambda>s v. ptr) \<rparr>"

term " (case s of Numeral n \<Rightarrow> Some (Numeral v) | _ \<Rightarrow> None)"
term "Numeral "
term "\<lparr> lens_get = (\<lambda>s. (case s of Numeral n \<Rightarrow> Some n | _ \<Rightarrow> None)),
        lens_put = (\<lambda>s v. Numeral (the v)) \<rparr>"
term "\<lparr>lens_get = the, lens_put = \<lambda>s. Some\<rparr>"

 term "path P ;\<^sub>L the\<^sub>L ;\<^sub>L indx B"
 term "path P ;\<^sub>L
       \<lparr>lens_get = the, lens_put = \<lambda>_. Some\<rparr> ;\<^sub>L
       indx B"

term "\<lambda>(N) v . undefined"
term "Pair s s"
term "\<lambda>(s, s') v . undefined"
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory AbstractSeparation_SD
imports
  AbstractSeparationHelpers_SD
  "Sep_Algebra.Map_Extra"
  "DSpec.Types_D"
begin

datatype cdl_component_id = Fields | Slot nat
type_synonym cdl_component_ids = "cdl_component_id set"

translations
  (type) "cdl_component_ids" <=(type) "cdl_component_id set"

(* The cdl_component are the pieces of capDL objects that we are interested in our lifted heap.
 * These components are either objects without capabilities or capabilities.
 *)
datatype cdl_component = CDL_Object cdl_object | CDL_Cap "cdl_cap option"

(* The state for separation logic is an option map
 * from (obj_id,component) to sep_entities
 *)
type_synonym sep_state_heap = "(cdl_object_id \<times> cdl_component_id) \<Rightarrow> cdl_component option"
type_synonym sep_state_irq_map = "cdl_irq \<Rightarrow> cdl_object_id option"

translations
  (type) "sep_state_heap" <=(type) "32 word \<times> cdl_component_id \<Rightarrow> cdl_component option"

(* Our lifted state contains sep_entities and the IRQ table.
 *)
datatype sep_state =
  SepState "(cdl_object_id \<times> cdl_component_id) \<Rightarrow> cdl_component option"
           "cdl_irq \<Rightarrow> cdl_object_id option"

(* Functions to get the object heap and the irq table from the sep_state. *)
primrec sep_heap :: "sep_state \<Rightarrow> sep_state_heap"
where "sep_heap (SepState heap irqs) = heap"

primrec sep_irq_node :: "sep_state \<Rightarrow> sep_state_irq_map"
where "sep_irq_node (SepState heap irqs) = irqs"

(* Adding states adds the separation entity heap and the IRQ table.
 *)
definition
  sep_state_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> sep_state"
where
  "sep_state_add state_a state_b \<equiv>
  SepState ((sep_heap state_a) ++ (sep_heap state_b))
           ((sep_irq_node state_a) ++ sep_irq_node state_b)"

(* State are disjoint the separation entity heaps and the IRQ tables are dijoint.
 *)
definition
  sep_state_disj :: "sep_state \<Rightarrow> sep_state \<Rightarrow> bool"
where
  "sep_state_disj state_a state_b \<equiv>
   (sep_heap state_a) \<bottom> (sep_heap state_b) \<and>
   (sep_irq_node state_a) \<bottom> (sep_irq_node state_b)"

lemma sep_state_add_comm:
  "sep_state_disj x y \<Longrightarrow> sep_state_add x y = sep_state_add y x"
  by (fastforce simp: sep_state_add_def sep_state_disj_def intro!:map_add_com)

(*********************************************)
(* Definition of separation logic for capDL. *)
(*********************************************)

instantiation "sep_state" :: zero
begin
  definition "0 \<equiv> SepState (\<lambda>p. None) Map.empty"
  instance ..
end

instantiation "sep_state" :: stronger_sep_algebra
begin

definition "(##) \<equiv> sep_state_disj"
definition "(+) \<equiv> sep_state_add"

(************************************************
 * The proof that this is a separation algebra. *
 ************************************************)

instance
  apply standard
(* x ## 0 *)
       apply (simp add: sep_disj_sep_state_def sep_state_disj_def zero_sep_state_def)
(* x ## y \<Longrightarrow> y ## x *)
      apply (clarsimp simp: sep_disj_sep_state_def sep_state_disj_def Let_unfold
                            map_disj_com Int_commute)
(* x + 0 = x *)
     apply (simp add: plus_sep_state_def sep_state_add_def zero_sep_state_def)
     apply (case_tac x,simp)
(* x ## y \<Longrightarrow> x + y = y + x *)
    apply (clarsimp simp: plus_sep_state_def sep_disj_sep_state_def)
    apply (erule sep_state_add_comm)
(* (x + y) + z = x + (y + z) *)
   apply (simp add: plus_sep_state_def sep_state_add_def)+
(* x ## y + z = (x ## y \<and> x ## z) *)
   apply (clarsimp simp: sep_disj_sep_state_def)
   apply (auto simp: map_disj_def sep_state_disj_def)
  done
end

(*************************************************************
 * The proof that this is a cancellative separation algebra. *
 *************************************************************)

instantiation "sep_state" :: cancellative_sep_algebra
begin

instance
  apply (standard; simp add: sep_disj_sep_state_def sep_state_disj_def zero_sep_state_def
                   plus_sep_state_def sep_state_add_def)
  apply (metis map_add_subsumed1 map_le_refl sep_heap.simps sep_irq_node.simps sep_state.exhaust)
  by (metis map_add_left_eq sep_heap.simps sep_irq_node.simps sep_state.exhaust)
end

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_inv__54_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__54_on_rules imports n_germanSimp_lemma_on_inv__54
begin
section{*All lemmas on causal relation between inv__54*}
lemma lemma_inv__54_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__54  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__54) 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__54) 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__54) 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__54) 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__54) 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__54) 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__54) 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__54) 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__54) 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__54) 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__54) 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__54) done
    }

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

end


(*  Title:      HOL/Auth/n_german_lemma_inv__13_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__13_on_rules imports n_german_lemma_on_inv__13
begin
section{*All lemmas on causal relation between inv__13*}
lemma lemma_inv__13_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__13  p__Inv1 p__Inv2)"
  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_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE 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__13) done
    }

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

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

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

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

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

end


theory Kernel_Execution

imports Memory_Model

begin

lemma [simp]:
  "con_set S (s\<lparr>heap := hp ,  incon_set := IS, global_set := GS\<rparr>) =  con_set S (s\<lparr>incon_set := IS\<rparr>) "
  by (clarsimp simp: con_set_def)

lemma [simp]:
  "kernel_data_area (s\<lparr>heap := hp', global_set := GS\<rparr>) = kernel_data_area (s\<lparr>heap := hp'\<rparr>)"
  by (clarsimp simp: kernel_data_area_def kernel_data_def ptable_footprint_def)

lemma [simp]:
  "kernel_data (s\<lparr>heap := hp', global_set := GS\<rparr>)  = kernel_data (s\<lparr>heap := hp'\<rparr>) "
  by (clarsimp simp: kernel_data_def ptable_footprint_def)

lemma [simp]:
  "kernel_mappings (s\<lparr>heap := hp', global_set := GS\<rparr>)  = kernel_mappings (s\<lparr>heap := hp'\<rparr>) "
  by (clarsimp simp: kernel_mappings_def global_mappings_def global_mappings'_def hptable_eq_def)

 lemma [simp]:
  "kernel_safe (s\<lparr>heap := hp',  global_set := GS \<rparr>) =
         kernel_safe (s\<lparr>heap := hp' \<rparr>) "
   by (clarsimp simp: kernel_safe_def vas_of_current_state_mapped_to_global_mappings_of_all_processes_def)

 lemma [simp]:
  "ptrace_set V (s\<lparr>heap := hp',  global_set := GS \<rparr>) =
         ptrace_set V (s\<lparr>heap := hp' \<rparr>) "
   by (clarsimp simp: ptrace_set_def)

 lemma [simp]:
  "root_map  (s\<lparr>heap := hp',  global_set := GS \<rparr>) =
         root_map  (s\<lparr>heap := hp' \<rparr>) "
 by (clarsimp simp: root_map_def  map_of_set_def  root_set_def)

lemma root_map_rootsD:
  "root_map s r = Some a \<Longrightarrow> r \<in> roots s"
  by (simp add: roots_def')

lemma kernel_region_offset':
  " mmu_layout s \<and> mode s = Kernel   \<Longrightarrow>
        \<forall>va\<in>kernel_safe s.  ptable_lift' (heap s) (root s) va =
      Some (Addr (addr_val va) r- global_offset)"
  by (clarsimp simp: mmu_layout_def dest!: root_map_rootsD)

lemma mmu_layout_ptable_comp':
  "\<lbrakk> mmu_layout s; p \<notin> kernel_data_area s \<rbrakk> \<Longrightarrow>
        incon_comp (asid s) (asid s) (heap s) (heap s(p \<mapsto> v)) (root s) (root s) = {}"
  apply (simp add: incon_comp_def ptable_comp_def)
  apply (subgoal_tac "root s \<in> roots s")
   apply (simp add: mmu_layout_pt_walk_pair')
  by (clarsimp simp: mmu_layout_def rootsI)

lemma global_mappings_decode_mmu:
  "\<lbrakk>mmu_layout s ; mode s = Kernel  ; va \<in> kernel_safe s\<rbrakk> \<Longrightarrow>
         \<exists>p perm. decode_pde (the ((heap s)
          (root s r+ (vaddr_pd_index (addr_val va) << 2)))) =  SectionPDE p perm"
  apply (clarsimp simp: kernel_safe_def vas_mapped_by_global_mappings_def
                         kernel_mappings_def global_mappings_def global_mappings'_def  mmu_layout_def dest!: root_map_rootsD)
  apply (drule_tac x = "root s" in bspec)
   apply clarsimp
  apply clarsimp
  apply (drule_tac x = "x" in spec)
  by (clarsimp simp: get_pde'_def decode_heap_pde'_def)

lemma global_high_ptable:
  "\<lbrakk> mmu_layout s ; mode s = Kernel ; Addr vp \<in> (kernel_safe s) ;
        x \<in> ptable_trace' (heap s) (root s) (Addr vp)\<rbrakk>
           \<Longrightarrow> x \<in> high_ptable (root s)"
  apply (frule_tac va = "Addr vp" in global_mappings_decode_mmu ; clarsimp )
  apply (clarsimp simp: ptable_trace'_def Let_def)
  apply (clarsimp simp: mmu_layout_def kernel_safe_def vas_mapped_by_global_mappings_def
  vas_of_current_state_mapped_to_global_mappings_of_all_processes_def dest!: root_map_rootsD)
  apply (subgoal_tac "xa = root s r+ (vaddr_pd_index vp << 2)")
   apply (rule_tac x = "root s" in bexI)
    apply (clarsimp simp: pd_idx_offset_def)
   apply clarsimp
  by (clarsimp simp: ptable_trace'_def)

lemma global_high_ptable':
  "\<lbrakk> mmu_layout s ; mode s = Kernel ; Addr vp \<in> (kernel_safe s) \<rbrakk> \<Longrightarrow>
        \<forall>x\<in>ptable_trace' (heap s) (root s) (Addr vp).
           x \<in> high_ptable (root s)"
   by (clarsimp simp: global_high_ptable)

lemma  kernel_safe_region_ptable_trace'' [simp]:
  " \<lbrakk> mmu_layout s ; mode s = Kernel ; Addr vp' \<in> kernel_safe s;
     vp \<in> kernel_safe s\<rbrakk> \<Longrightarrow>
     Addr (vp' - global_offset) \<notin> ptable_trace' (heap s) (root s) vp"
  apply (frule_tac va = vp in  global_mappings_decode_mmu)
    apply (clarsimp simp: mmu_layout_def)
   apply clarsimp
  apply (clarsimp simp:  mmu_layout_def ptable_trace'_def kernel_safe_def Let_def
      vas_mapped_by_global_mappings_def
        vas_of_current_state_mapped_to_global_mappings_of_all_processes_def
        pd_idx_offset_def dest!: root_map_rootsD)
  done

lemma mmu_layout_pt_comp_heap_same[simp]:
  "\<lbrakk> mmu_layout s; p \<notin> kernel_data_area s ; r \<in> roots s\<rbrakk>
       \<Longrightarrow> ptable_comp (snd (ptable_snapshot s a)) (pt_walk_pair a (heap s) r) =
         ptable_comp (snd (ptable_snapshot s a)) (pt_walk_pair a (heap s(p \<mapsto> v)) r)"
  apply (subgoal_tac "pt_walk_pair a (heap s(p \<mapsto> v)) r = pt_walk_pair a (heap s) r")
   apply clarsimp
  by (rule mmu_layout_pt_walk_pair'; simp)

lemma mmu_layout_global_heap_upd:
  "\<lbrakk>mmu_layout s; p \<notin> kernel_data_area s\<rbrakk>
         \<Longrightarrow> global_entries (ran (pt_walk (asid s) (heap s(p \<mapsto> v)) (root s))) = global_entries (ran (pt_walk (asid s) (heap s) (root s)))"
  apply (subgoal_tac "pt_walk (asid s) (heap s(p \<mapsto> v)) (root s) = pt_walk (asid s)  (heap s) (root s)")
   apply (clarsimp)
  apply (subst mmu_layout_pt_walk'; simp?)
  apply (clarsimp simp: mmu_layout_def roots_def)
  using rootsI roots_def by blast

lemma mmu_layout_global_set_subset':
  "\<lbrakk>mmu_layout s ; rt \<in> roots s \<rbrakk> \<Longrightarrow>   (\<Union>x\<in>global_entries (ran (pt_walk a (heap s) rt)). range_of x) =
           {va::vaddr. rt r+ pd_idx_offset (addr_val va) \<in> high_ptable rt}"
  apply safe
   apply (rename_tac va e)
   apply (subgoal_tac "global (heap s) rt va \<and> (\<exists>e. pt_walk a (heap s) rt va = Some e)")
    apply (clarsimp simp: mmu_layout_def kernel_mappings_def global_mappings_def global_mappings'_def)
    apply (drule_tac x = rt in bspec, simp, clarsimp)
    apply (drule_tac x = "addr_val va" in spec, drule_tac x = "addr_val va" in spec)
    apply (case_tac " rt r+ pd_idx_offset (addr_val va) \<in> high_ptable rt"; clarsimp)
    apply (clarsimp simp: global_def non_global_def is_fault_def pt_walk_def map_opt_def pdc_walk_def  pte_tlb_entry_def
      split: option.splits pde.splits pte.splits)
   apply (subgoal_tac "\<exists>v'. e = the (pt_walk a (heap s) rt v') \<and>(\<exists>e. pt_walk a (heap s) rt v' = Some e)")
    prefer 2
    apply (clarsimp simp:  global_entries_def ran_def is_fault_def)
    apply force
   apply clarsimp
   apply (subgoal_tac "(\<exists>e. pt_walk a (heap s) rt v' = Some e)")
    prefer 2
    apply (clarsimp simp: global_entries_def  ran_def)
   apply (subgoal_tac "pt_walk a (heap s) rt v' = pt_walk a (heap s) rt va")
    apply clarsimp
    apply (subgoal_tac "asid_of (the (pt_walk a (heap s) rt va)) = None")
     prefer 2
     apply (clarsimp simp: global_entries_def)
    apply (clarsimp simp: mmu_layout_def kernel_mappings_def global_mappings_def global_mappings'_def)
    apply (drule_tac x = rt in bspec, simp, clarsimp)
    apply (drule_tac x = "addr_val va" in spec, drule_tac x = "addr_val va" in spec)
    apply (case_tac " rt r+ pd_idx_offset (addr_val va) \<in> high_ptable rt"; clarsimp)
     apply (clarsimp simp: global_def non_global_def is_fault_def pt_walk_def map_opt_def pdc_walk_def  pte_tlb_entry_def
      split: option.splits pde.splits pte.splits)
    apply (clarsimp simp: global_def non_global_def is_fault_def pt_walk_def map_opt_def pdc_walk_def  global_entries_def tag_conv_def
      pte_tlb_entry_def to_tlb_flags_def split: option.splits pde.splits pte.splits)
   apply (rule va_entry_set_pt_palk_same', simp add: is_fault_def, simp)
  apply clarsimp
  apply (rename_tac va)
  apply (subgoal_tac "global (heap s) rt va \<and> \<not>is_fault (pt_walk a (heap s) rt va)")
   apply (rule_tac x = "the (pt_walk a (heap s) rt va)" in bexI, clarsimp)
    apply (simp add: pt_walk'_pt_walk [symmetric])
    apply (frule asid_va_entry_range_pt_entry, simp)
   apply (subgoal_tac "asid_of (the (pt_walk a (heap s) rt va)) = None")
    apply (clarsimp simp: global_entries_def is_fault_def ran_def) apply force
   apply (clarsimp simp: global_def  is_fault_def pt_walk_def map_opt_def pdc_walk_def  pte_tlb_entry_def tag_conv_def to_tlb_flags_def
      split: option.splits pde.splits pte.splits)
  apply (clarsimp simp: mmu_layout_def kernel_mappings_def global_mappings_def global_mappings'_def)
  apply (drule_tac x = rt in bspec, simp, clarsimp)
  apply (drule_tac x = "addr_val va" in spec, drule_tac x = "addr_val va" in spec)
  by (clarsimp simp: global_def non_global_def is_fault_def pt_walk_def map_opt_def pdc_walk_def  pte_tlb_entry_def
      split: option.splits pde.splits pte.splits)

lemma mmu_layout_global_set_subset:
  "mmu_layout s \<Longrightarrow>   (\<Union>x\<in>global_entries (ran (pt_walk (asid s) (heap s) (root s))). range_of x) = global_set s "
  apply (frule_tac rt = "root s"  and a = "asid s" in mmu_layout_global_set_subset')
  using mmu_layout_def rootsI apply force
  by (clarsimp simp: mmu_layout_def  global_set_eq_def)

lemma kernel_safe_assignment:
  "\<Turnstile> \<lbrace>\<lambda>s. mmu_layout s \<and> mode s = Kernel \<and> safe_set (kernel_safe s) s \<and>
           asids_consistent {} s \<and>
           aval lval s = Some vp \<and> aval rval s = Some v \<and>
           Addr vp \<in> (kernel_safe s) \<and> k_phy_ad vp \<notin> kernel_data_area s \<rbrace>
        lval ::= rval
      \<lbrace>\<lambda>s. mmu_layout s \<and> mode s = Kernel \<and> safe_set (kernel_safe s) s \<and>
           asids_consistent {} s \<and> heap s (k_phy_ad vp) = Some v\<rbrace>"
  apply (vcgm vcg: weak_pre_write')
  apply (rule conjI)
   apply (clarsimp simp: asids_consistent_def safe_set_def con_set_def)
  apply (subgoal_tac " ptable_lift' (heap s) (root s) (Addr vp) = Some (Addr vp r-  global_offset)")
   prefer 2
   apply (clarsimp simp: kernel_region_offset')
  apply (clarsimp simp: k_phy_ad_def mmu_layout_ptable_comp' mmu_layout_upd')
  apply (rule conjI)
   apply (clarsimp simp: mmu_layout_global_heap_upd)
   apply (frule_tac mmu_layout_global_set_subset, simp)
   apply (clarsimp simp: k_phy_ad_def mmu_layout_ptable_comp' mmu_layout_upd')
  apply (rule conjI)
   apply (subgoal_tac  "kernel_safe (s\<lparr> heap := heap s(Addr (vp - global_offset) \<mapsto> v)\<rparr>) =
                        kernel_safe s")
    apply (clarsimp simp: safe_set_def safe_memory_def con_set_def)
    apply (drule_tac x = va in bspec; clarsimp)
    apply (rule_tac x = p in exI)
    apply (subgoal_tac "ptable_lift' (heap s) (root s) va =
                      ptable_lift' (heap s(Addr (vp -  global_offset) \<mapsto> v)) (root s) va")
     apply (rule conjI, clarsimp)
     apply (subgoal_tac  "ptrace_set (kernel_safe s) (s\<lparr> heap := heap s(Addr (vp - global_offset) \<mapsto> v)\<rparr>) =
                           ptrace_set (kernel_safe s) s", clarsimp)
     prefer 3
     apply (frule_tac vp = vp in global_high_ptable', clarsimp, clarsimp)
     apply (clarsimp simp: kernel_safe_def  vas_of_current_state_mapped_to_global_mappings_of_all_processes_def)
     apply (rule_tac x = "root s" in bexI, force)
     apply (clarsimp simp: mmu_layout_def dest!: root_map_rootsD)
    prefer 2 apply (rule pt_table_lift_trace_upd', clarsimp)
   apply (clarsimp simp: ptrace_set_def)
   apply safe
    apply (rule_tac a = xa in UN_I, clarsimp)
    prefer 2 apply (rule_tac a = xa in UN_I, clarsimp)
    apply (subgoal_tac "ptable_trace' (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s) xa =
                       ptable_trace' (heap s) (root s) xa", clarsimp)
    prefer 2
    apply (subgoal_tac "ptable_trace' (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s) xa =
                       ptable_trace' (heap s) (root s) xa" , clarsimp)
    apply (rule pt_trace_upd, clarsimp)
   apply (subgoal_tac "ptable_trace' (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s) xa =
                      ptable_trace' (heap s) (root s) xa" , clarsimp)
   apply (rule pt_trace_upd, clarsimp)
  apply (frule_tac mmu_layout_global_set_subset)
  apply (subgoal_tac "(s\<lparr>heap := heap s(Addr (vp - global_offset) \<mapsto> v),
                   global_set := global_set s \<union> (\<Union>x\<in>global_entries (ran (pt_walk (asid s) (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s))). range_of x)\<rparr>) =
   s\<lparr>heap := heap s(Addr (vp - global_offset) \<mapsto> v)\<rparr>")
   apply simp
   apply (clarsimp simp: asids_consistent_def)
   apply (rule)
    apply clarsimp
    apply (subgoal_tac "pt_walk_pair a (heap s(Addr (vp - global_offset) \<mapsto> v)) r = pt_walk_pair a (heap s) r")
     apply force
    apply (rule mmu_layout_pt_walk_pair', simp, simp, simp add: roots_def)
  using root_map_rootsD roots_def apply force
   apply clarsimp
   apply (subgoal_tac "pt_walk_pair a (heap s(Addr (vp - global_offset) \<mapsto> v)) r = pt_walk_pair a (heap s) r")
    apply force
   apply (rule mmu_layout_pt_walk_pair'; simp add: roots_def)
  apply (subgoal_tac "pt_walk (asid s) (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s) = pt_walk (asid s) (heap s) (root s)")
   apply clarsimp
  apply (rule mmu_layout_pt_walk'; simp add: roots_def)
  using mmu_layout_def rootsI roots_def by auto

end