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

theory Memcpy
imports
  "../../../c-parser/CTranslation"
  "../../AutoCorres"
begin

lemma byte_ptr_guarded:
    "ptr_val (x::8 word ptr) \<noteq> 0 \<Longrightarrow> c_guard x"
  unfolding c_guard_def c_null_guard_def ptr_aligned_def
  by (clarsimp simp: intvl_Suc)

(* FIXME: MOVE *)
lemma ptr_add_coerce: "ptr_val (((ptr_coerce x)::('a::{c_type}) ptr) +\<^sub>p a) = (ptr_val x) + (of_int a * of_nat (size_of TYPE('a)))"
  apply (case_tac x)
  apply (clarsimp simp: CTypesDefs.ptr_add_def)
  done

(* FIXME: MOVE *)
(* Casting a valid pointer to char* and incrementing it by a value less than
 * the size of the underlying type does not give us NULL.
 *)
lemma ptr_contained:"\<lbrakk> c_guard (x::('a::c_type) ptr); size_of TYPE('a) = sz;
                       0 \<le> i; i < int sz; (y::8 word ptr) = ptr_coerce x\<rbrakk> \<Longrightarrow> c_guard (y +\<^sub>p i)"
  apply (rule byte_ptr_guarded)
  unfolding c_guard_def c_null_guard_def ptr_add_def
  apply simp
  apply (clarsimp simp: CTypesDefs.ptr_add_def intvl_def)
  apply (erule allE [where x="nat i"])
  apply (clarsimp simp: nat_less_iff of_nat_nat)
  done

install_C_file "memcpy.c"

(* FIXME: MOVE *)
lemma squash_auxupd_id[polish]:
  "modify (t_hrs_'_update (hrs_htd_update id)) = skip"
  by (monad_eq simp: skip_def id_def hrs_htd_update_def)

autocorres "memcpy.c"

(* Dereference a pointer *)
abbreviation "deref s x \<equiv> h_val (hrs_mem (t_hrs_' s)) x"

(* char* cast *)
abbreviation "byte_cast x \<equiv> ((ptr_coerce x)::8 word ptr)"

context memcpy begin

lemma memcpy_char:
  "\<lbrace> \<lambda>s. c_guard (x::8 word ptr) \<and>
         c_guard (y::8 word ptr) \<and>
         unat sz = size_of TYPE(8 word) \<and>
         P (deref s x) \<and>
         x \<noteq> y\<rbrace>
      memcpy' (ptr_coerce y) (ptr_coerce x) sz
   \<lbrace>\<lambda> _ s. P (deref s y) \<rbrace>!"
  (* Evaluate sz *)
  apply clarsimp

  unfolding memcpy'_def
  apply (clarsimp simp:skip_def)
  apply wp

  (* Unroll the loop twice *)
  apply (subst whileLoop_unroll, wp)
     apply (subst whileLoop_unroll, wp)

  (* The remaining loop is never encountered *)
       apply (rule validNF_false_pre)
      apply wp

  (* Finally we're left with the single assignment *)
  apply (clarsimp simp:hrs_mem_update h_val_heap_update)
  apply unat_arith
 done

lemma is_aligned_add_not_aligned:
    "\<lbrakk>is_aligned (p::word32) n; \<not> is_aligned (q::word32) n\<rbrakk> \<Longrightarrow>
          \<not> is_aligned (p + q) n"
  by (metis is_aligned_addD1)

(* Possibly useful for something later *)
lemma "\<lbrakk> 2 ^ n dvd (p::nat); n > 0; i > 0; i < 2 ^ n; p + i > p; n < 32\<rbrakk> \<Longrightarrow>
          \<not> (2 ^ n dvd (p + i))"
  by (metis dvd_def dvd_reduce_multiple nat_dvd_not_less)

(* FIXME: MOVE *)
lemma word32_gr0_conv_Suc:"(m::word32) > 0 \<Longrightarrow> \<exists>n. m = n + 1"
  by (metis comm_semiring_1_class.normalizing_semiring_rules(24) zadd_diff_inverse)

(* FIXME: MOVE *)
lemma offset_not_aligned:
  "\<lbrakk> is_aligned (p::word32) n; i > 0; i < 2 ^ n; n < 32\<rbrakk>
     \<Longrightarrow> \<not> is_aligned (p + of_nat i) n"
  apply (erule is_aligned_add_not_aligned)
  unfolding is_aligned_def apply clarsimp
  apply (subst (asm) unat_of_nat_len)
   apply (metis len32 unat_less_word_bits unat_power_lower32 word_bits_conv)
  apply (metis nat_dvd_not_less)
  done

lemma of_nat_prop_exp: "n < 32 \<Longrightarrow> of_nat (2 ^ n) = 2 ^ (of_nat n)"
  by clarsimp

lemma neg_mask_add_aligned:
  "\<lbrakk> is_aligned p n; q < 2 ^ n \<rbrakk>
     \<Longrightarrow> (p + q) && ~~ mask n = p && ~~ mask n"
  by (metis is_aligned_add_helper is_aligned_neg_mask_eq)

lemma neq_imp_bytes_disjoint:
  "\<lbrakk> c_guard (x::'a::c_type ptr); c_guard y; unat j < align_of TYPE('a);
        unat i < align_of TYPE('a); x \<noteq> y; 2 ^ n = align_of TYPE('a); n < 32\<rbrakk> \<Longrightarrow>
    ptr_val x + j \<noteq> ptr_val y + i"
  apply (rule ccontr)
  apply (subgoal_tac "is_aligned (ptr_val x) n")
   apply (subgoal_tac "is_aligned (ptr_val y) n")
    apply (subgoal_tac "(ptr_val x + j && ~~ mask n) = (ptr_val y + i && ~~ mask n)")
     apply (subst (asm) neg_mask_add_aligned, simp, simp add: word_less_nat_alt)
     apply (subst (asm) neg_mask_add_aligned, simp, simp add: word_less_nat_alt)
     apply (clarsimp simp: is_aligned_neg_mask_eq)
    apply simp
   apply (clarsimp simp: c_guard_def ptr_aligned_def is_aligned_def)
  apply (clarsimp simp: c_guard_def ptr_aligned_def is_aligned_def)
  done

lemma from_bytes_eq [simp]:
  "from_bytes [x] = x"
  apply (clarsimp simp:from_bytes_def update_ti_t_def typ_info_word)
  apply (simp add:word_rcat_def)
  apply (simp add:bin_rcat_def)
  by (metis len8 word_of_int_uint word_ubin.Abs_norm)

lemma memcpy_word:
  "\<lbrace> \<lambda>s. c_guard (x::32 word ptr) \<and>
         c_guard (y::32 word ptr) \<and>
         unat sz = size_of TYPE(32 word) \<and>
         P (deref s x) \<and>
         x \<noteq> y \<rbrace>
      memcpy' (ptr_coerce y) (ptr_coerce x) sz
   \<lbrace> \<lambda>_ s. P (deref s y) \<rbrace>!"
  apply clarsimp
  unfolding memcpy'_def apply (clarsimp simp:skip_def)
  apply (rule validNF_assume_pre)
  apply (subgoal_tac "{ptr_val x ..+ unat sz} \<inter> {ptr_val y ..+ unat sz} = {}")
   apply (subst whileLoop_add_inv [where
     I="\<lambda>i s.  unat i \<le> unat sz \<and>
                (\<forall>a < i. deref s (byte_cast x +\<^sub>p uint a) = deref s (byte_cast y +\<^sub>p uint a)) \<and>
                P (deref s x)" and
     M="\<lambda>(i, s). unat sz - unat i"])
   apply (wp validNF_whileLoop_inv_measure_twosteps)
      apply clarsimp
      apply (rule conjI, unat_arith)
      apply (rule conjI, clarsimp)
       apply (case_tac "a = i")
        apply (clarsimp)
        apply (erule_tac x=i in allE)
        apply (clarsimp simp:hrs_mem_update h_val_heap_update)
        apply (subst h_val_heap_same)
            apply (rule ptr_retyp_h_t_valid)
            apply simp
           apply (rule ptr_retyp_disjoint)
            apply (rule ptr_retyp_h_t_valid)
            apply simp
           apply (clarsimp simp:ptr_add_def intvl_def CTypesDefs.ptr_add_def)
          apply simp
         apply (clarsimp simp: CTypesDefs.ptr_add_def field_of_t_simple)
         apply (drule field_of_t_simple)
         apply clarsimp
        apply simp
       apply (subgoal_tac "a < i")
        apply (clarsimp simp:hrs_mem_update)
        apply (subst h_val_heap_update_disjoint)

         (* The current goal should be obvious to unat_arith, but for some reason isn't *)
         apply (clarsimp simp:ptr_add_def intvl_def ptr_val_def disjoint_iff_not_equal)
         apply (erule_tac x="ptr_val x + a" in allE, clarsimp)
         apply (erule impE)
          apply (rule_tac x="unat a" in exI, clarsimp)
          apply unat_arith

         apply (erule_tac x="ptr_val y + i" and
                          P="\<lambda>ya. (\<exists>k. ya = ptr_val y + of_nat k \<and> k < 4) \<longrightarrow> ptr_val y + i \<noteq> ya" in allE, clarsimp)
         apply (erule_tac x="unat i" in allE, clarsimp)
          apply unat_arith
         apply (clarsimp simp:CTypesDefs.ptr_add_def)
        apply (subst h_val_heap_update_disjoint)
         (* Similar goal to the previous irritation, but this time Isabelle decides to play ball *)
         apply (clarsimp simp:ptr_add_def intvl_def ptr_val_def disjoint_iff_not_equal)
        apply (clarsimp simp:CTypesDefs.ptr_add_def)
       apply (clarsimp simp:CTypesDefs.ptr_add_def)
      apply unat_arith

      apply (rule conjI)
       apply (subst hrs_mem_update)+
       apply (subst h_val_heap_update_disjoint)
        apply (clarsimp simp: disjoint_iff_not_equal)
        apply (clarsimp simp:CTypesDefs.ptr_add_def intvl_def)
        apply (erule_tac x="ptr_val x + of_nat k" in allE)
        apply (erule impE)
         apply (rule_tac x="k" in exI)
         apply simp
        apply (erule_tac x="ptr_val y + i" and
                         P="\<lambda>ya. (\<exists>k. ya = ptr_val y + of_nat k \<and> k < 4) \<longrightarrow> ptr_val x + of_nat k \<noteq> ya" in allE)
        apply (erule impE)
         apply (rule_tac x="unat i" in exI)
         apply simp
         apply unat_arith
        apply simp
       apply simp

      (* Yet more tedium that unat_arith doesn't like *)
      apply (rule conjI)
       apply (rule byte_ptr_guarded,
              clarsimp simp:CTypesDefs.ptr_add_def c_guard_def c_null_guard_def intvl_def,
              (erule_tac x="unat i" in allE)+,
              clarsimp,
              unat_arith)+

     apply wp
     apply unat_arith
    apply clarsimp
    apply (subgoal_tac "deref sa x = deref sa y")
     apply clarsimp
    apply (clarsimp simp: h_val_def)[1]
    apply (rule arg_cong[where f=from_bytes])
    apply (subst numeral_eqs(3))+
    apply simp
    apply (rule_tac x=0 in allE, assumption, erule impE, unat_arith)
    apply (rule_tac x=1 in allE, assumption, erule impE, unat_arith)
    apply (rule_tac x=2 in allE, assumption, erule impE, unat_arith)
    apply (rule_tac x=3 in allE, assumption, erule impE, unat_arith)
    apply (simp add:CTypesDefs.ptr_add_def)
    apply (metis comm_semiring_1_class.normalizing_semiring_rules(24))
   apply clarsimp
   apply wp
   apply clarsimp
  apply (clarsimp simp:intvl_def disjoint_iff_not_equal)
  apply (drule_tac x=x and y=y and j="of_nat k" and i="of_nat ka" and n=2 in neq_imp_bytes_disjoint)
        apply assumption
       apply (case_tac "k = 0", clarsimp) (* insert "k > 0" *)
       apply (clarsimp simp:unat_of_nat_len)
      apply (case_tac "ka = 0", clarsimp)
      apply (clarsimp simp:unat_of_nat_len)
     apply assumption
    apply clarsimp+
  done

end

end


(*<*)

(* Author: Kyndylan Nienhuis *)

theory LoadCap

imports
  "UnpredictableBehaviour"
  "ExceptionFlag"
  "ExecutionStep"
begin

(*>*)
section \<open>Semantics of @{const LoadCapAction}\<close>

named_theorems SemanticsLoadCapI

method SemanticsLoadCap uses intro =
  HoareTriple intro: intro SemanticsLoadCapI[THEN HoareTriple_post_weakening]

declare nonExceptionCase_exceptions [SemanticsLoadCapI]

definition AddressIsCapReadable ::
  "Capability \<Rightarrow> PhysicalCapAddress \<Rightarrow>
   (VirtualAddress \<times> AccessType \<Rightarrow> PhysicalAddress option) \<Rightarrow> bool"
where
  "AddressIsCapReadable authCap a addrTrans \<equiv>
   Permit_Load (getPerms authCap) \<and>
   getTag authCap \<and>
   \<not> getSealed authCap \<and>
   (\<forall>a'\<in>Region (ExtendCapAddress a) 32.
    \<exists>vAddr\<in>RegionOfCap authCap.
    addrTrans (vAddr, LOAD) = Some a')"

lemma AddressIsCapReadableI:
  assumes v_upper: "ucast vAddr + (32::65 word) \<le>
                    ucast (getBase authCap) + ucast (getLength authCap)"
      and v_lower: "getBase authCap \<le> vAddr"
      and alignment: "isCapAligned vAddr"
      and pAddr: "getTranslateAddr (vAddr, LOAD) s = Some pAddr"
      and a: "a = GetCapAddress pAddr"
      and trans: "addrTrans = getTranslateAddrFunc s"
      and "Permit_Load (getPerms authCap)"
      and "getTag authCap"
      and "\<not> getSealed authCap"
  shows "AddressIsCapReadable authCap a addrTrans"
proof -
  have "(ucast vAddr::5 word) = 0"
    using alignment
    unfolding isCapAligned_def
    by simp
  have "(ucast pAddr::5 word) = 0"
    using arg_cong[where f="\<lambda>x. (ucast x::5 word)",
                   OF getTranslateAddr_ucast12[OF pAddr]]
    using `(ucast vAddr::5 word) = 0`
    by simp
  hence [simp]: "pAddr AND mask 5 = 0"
    using eq_ucast_eq_and_mask[where x=pAddr and y=0 and n=5 and 'b=5]
    by simp
  have [simp]: "pAddr AND NOT mask 5 = pAddr"
    unfolding word_minus_word_and_mask[THEN sym]
    by (simp del: word_minus_word_and_mask)
  note TranslateNearbyAddress_CapAligned2 =
       TranslateNearbyAddress_CapAligned
            [where cap=authCap and vAddr=vAddr and
                   pAddr=pAddr and s=s and accessType=LOAD]
  show ?thesis
    using assms
    unfolding AddressIsCapReadable_def
    unfolding getTranslateAddrFunc_def
    unfolding ExtendCapAddress_def GetCapAddress_def
    by (auto elim!: TranslateNearbyAddress_CapAligned2)
qed

definition SemanticsLoadCapPost where
  "SemanticsLoadCapPost authCap cap a cd addrTrans \<equiv>
   return (AddressIsCapReadable authCap a addrTrans) \<and>\<^sub>b
   bind (read_state (getCAPR cd))
        (\<lambda>x. return (Permit_Load_Capability (getPerms authCap) \<and> x \<le> cap))"

lemma Commute_SemanticsLoadCapPost [Commute_compositeI]:
  assumes "Commute (read_state (getCAPR cd)) m"
  shows "Commute (SemanticsLoadCapPost authCap cap a cd addrTrans) m"
unfolding SemanticsLoadCapPost_def
by (Commute intro: assms)

lemma SemanticsLoadCapability_write'CAPR:
  shows "HoareTriple (return (cb = cd) \<and>\<^sub>b
                  return (if cd = 0 then f nullCap else f cap))
                 (write'CAPR (cap, cb))
                 (\<lambda>_. bind (read_state (getCAPR cd)) (\<lambda>x. return (f x)))"
unfolding HoareTriple_def
by (auto simp: ValueAndStatePart_simp)

lemmas SemanticsLoadCapability_AddressTranslation =
  HoareTriple_DefinedAddressTranslation
    [where p="\<lambda>x. return (AddressIsCapReadable authCap a addrTrans \<and> extra) \<and>\<^sub>b
                  (return authCap =\<^sub>b read_state (getCAPR cb)) \<and>\<^sub>b
                  bind (read_state (getMemCap (slice 5 x)))
                       (\<lambda>y. return (y \<le> cap))"]
  for a authCap cap addrTrans extra cb

lemma SemanticsLoadCapability_LoadCap:
  shows "HoareTriple (read_state getExceptionSignalled \<or>\<^sub>b
                  read_state isUnpredictable \<or>\<^sub>b
                  bind (read_state (getTranslateAddr (fst v, LOAD)))
                       (\<lambda>z. case z of None \<Rightarrow> return True
                                    | Some x \<Rightarrow>
                             return (AddressIsCapReadable authCap a addrTrans \<and> extra) \<and>\<^sub>b
                             (return authCap =\<^sub>b read_state (getCAPR cb)) \<and>\<^sub>b
                             bind (read_state (getMemCap (GetCapAddress x)))
                                  (\<lambda>y. return (y \<le> cap))))
                 (LoadCap v)
                 (\<lambda>x. read_state getExceptionSignalled \<or>\<^sub>b
                      read_state isUnpredictable \<or>\<^sub>b
                      return (AddressIsCapReadable authCap a addrTrans \<and> extra) \<and>\<^sub>b
                      (return authCap =\<^sub>b read_state (getCAPR cb)) \<and>\<^sub>b
                      return (x \<le> cap))"
proof -
  note [SemanticsLoadCapI] =
     SemanticsLoadCapability_AddressTranslation[where extra=extra]
  show ?thesis
    unfolding LoadCap_alt_def GetCapAddress_def
    by SemanticsLoadCap
qed

lemma SemanticsLoadCapability_CLC [SemanticsLoadCapI]:
  shows "HoareTriple ((return cap =\<^sub>b read_state (getMemCap a)) \<and>\<^sub>b
                  (return authCap =\<^sub>b read_state (getCapReg auth)) \<and>\<^sub>b
                  (return addrTrans =\<^sub>b read_state getTranslateAddrFunc) \<and>\<^sub>b
                  (return authAccessible =\<^sub>b read_state (getRegisterIsAccessible auth)) \<and>\<^sub>b
                  bind (CLCActions v) (\<lambda>prov. return (LoadCapAction auth a cd \<in> prov)))
                 (dfn'CLC v)
                 (\<lambda>_. read_state getExceptionSignalled \<or>\<^sub>b
                      read_state isUnpredictable \<or>\<^sub>b
                      SemanticsLoadCapPost authCap cap a cd addrTrans \<and>\<^sub>b
                      return authAccessible)"
proof -
  note [SemanticsLoadCapI] =
    SemanticsLoadCapability_LoadCap
      [where extra="(_ = cd) \<and> authAccessible \<and>
                    Permit_Load_Capability (getPerms authCap)"]
  show ?thesis
    unfolding dfn'CLC_alt_def CLCActions_def
    unfolding CLCPhysicalAddress_def CLCVirtualAddress_def
    unfolding SemanticsLoadCapPost_def
    by (SemanticsLoadCap intro: SemanticsLoadCapability_write'CAPR)
       (auto simp: not_le not_less
                   GetCapAddress_def ExtendCapAddress_def
             split: if_splits
             intro!: AddressIsCapReadableI)
qed

lemma SemanticsLoadCapability_CLLC [SemanticsLoadCapI]:
  shows "HoareTriple ((return cap =\<^sub>b read_state (getMemCap a)) \<and>\<^sub>b
                  (return authCap =\<^sub>b read_state (getCapReg auth)) \<and>\<^sub>b
                  (return addrTrans =\<^sub>b read_state getTranslateAddrFunc) \<and>\<^sub>b
                  (return authAccessible =\<^sub>b read_state (getRegisterIsAccessible auth)) \<and>\<^sub>b
                  bind (CLLCActions v) (\<lambda>prov. return (LoadCapAction auth a cd \<in> prov)))
                 (dfn'CLLC v)
                 (\<lambda>_. read_state getExceptionSignalled \<or>\<^sub>b
                      read_state isUnpredictable \<or>\<^sub>b
                      SemanticsLoadCapPost authCap cap a cd addrTrans \<and>\<^sub>b
                      return authAccessible)"
proof -
  note [SemanticsLoadCapI] =
    SemanticsLoadCapability_LoadCap
      [where extra="(_ = cd) \<and> authAccessible \<and>
                    Permit_Load_Capability (getPerms authCap)"]
  show ?thesis
    unfolding dfn'CLLC_alt_def CLLCActions_def
    unfolding CLLCPhysicalAddress_def CLLCVirtualAddress_def
    unfolding SemanticsLoadCapPost_def
    by (SemanticsLoadCap intro: SemanticsLoadCapability_write'CAPR)
       (auto simp: not_le not_less
                   GetCapAddress_def ExtendCapAddress_def
             split: if_splits
             intro!: AddressIsCapReadableI)
qed

lemma SemanticsLoadCapability_Run_aux:
  shows "HoareTriple ((return cap =\<^sub>b read_state (getMemCap a)) \<and>\<^sub>b
                  (return authCap =\<^sub>b read_state (getCapReg auth)) \<and>\<^sub>b
                  (return addrTrans =\<^sub>b read_state getTranslateAddrFunc) \<and>\<^sub>b
                  (return authAccessible =\<^sub>b read_state (getRegisterIsAccessible auth)) \<and>\<^sub>b
                  bind (RunActions v) (\<lambda>prov. return (LoadCapAction auth a cd \<in> prov)))
                 (Run v)
                 (\<lambda>_. read_state getExceptionSignalled \<or>\<^sub>b
                      read_state isUnpredictable \<or>\<^sub>b
                      SemanticsLoadCapPost authCap cap a cd addrTrans \<and>\<^sub>b
                      return authAccessible)"
unfolding Run_alt_def RunActions_def
by (HoareTriple_cases;
    rule HoareTriple_pre_strengthening,
    rule SemanticsLoadCapability_CLC
         SemanticsLoadCapability_CLLC
         HoareTriple_weakest_pre_any,
    solves \<open>auto simp: ValueAndStatePart_simp\<close>)

lemmas SemanticsLoadCapability_Run =
  HoareTriple_weakest_pre_disj[OF SemanticsLoadCapability_Run_aux
                              UndefinedCase_Run]

lemma SemanticsLoadCapability_Fetch:
  fixes auth a a' cd authCap cap addrTrans cdAccessible authAccessible
  defines "p \<equiv> \<lambda>w. (return cap =\<^sub>b read_state (getMemCap a)) \<and>\<^sub>b
                    (return authCap =\<^sub>b read_state (getCapReg auth)) \<and>\<^sub>b
                    (return addrTrans =\<^sub>b read_state getTranslateAddrFunc) \<and>\<^sub>b
                    (return authAccessible =\<^sub>b read_state (getRegisterIsAccessible auth)) \<and>\<^sub>b
                    bind (RunActions (Decode w)) (\<lambda>prov. return (LoadCapAction auth a cd \<in> prov))"
  shows "HoareTriple (bind NextInstruction (case_option (return True) p))
                  Fetch
                  (\<lambda>b. case b of None \<Rightarrow> read_state getExceptionSignalled
                               | Some y \<Rightarrow> read_state isUnpredictable \<or>\<^sub>b p y)"
unfolding p_def
by (intro HoareTriple_Fetch) Commute+

lemma SemanticsLoadCapability_NextWithGhostState:
  shows "HoareTriple ((return cap =\<^sub>b read_state (getMemCap a)) \<and>\<^sub>b
                  (return authCap =\<^sub>b read_state (getCapReg auth)) \<and>\<^sub>b
                  (return addrTrans =\<^sub>b read_state getTranslateAddrFunc) \<and>\<^sub>b
                  (return authAccessible =\<^sub>b read_state (getRegisterIsAccessible auth)) \<and>\<^sub>b
                  bind DomainActions (\<lambda>ac. return (LoadCapAction auth a cd \<in> ac)))
                 NextWithGhostState
                 (\<lambda>_. read_state getExceptionSignalled \<or>\<^sub>b
                      read_state isUnpredictable \<or>\<^sub>b
                      SemanticsLoadCapPost authCap cap a cd addrTrans \<and>\<^sub>b
                      return authAccessible)"
proof -
  note [SemanticsLoadCapI] =
    SemanticsLoadCapability_Run[where auth=auth and
                                      authAccessible=authAccessible]
  note [SemanticsLoadCapI] =
    SemanticsLoadCapability_Fetch[where auth=auth and a=a and cd=cd and
                                        cap=cap and authCap=authCap and
                                        addrTrans=addrTrans and
                                        authAccessible=authAccessible]
  show ?thesis
    unfolding NextWithGhostState_def DomainActions_def
    by (SemanticsLoadCap intro: UndefinedCase_TakeBranch)
       (auto split: option.splits)
qed

theorem SemanticsLoadCap:
  assumes prov: "LoadCapAction auth a cd \<in> actions"
      and suc: "(PreserveDomain actions, s') \<in> SemanticsCheriMips s"
  shows "Permit_Load (getPerms (getCapReg auth s))"
        "Permit_Load_Capability (getPerms (getCapReg auth s))"
        "getTag (getCapReg auth s)"
        "\<not> getSealed (getCapReg auth s)"
        "Region (ExtendCapAddress a) 32 \<subseteq>
         getTranslateAddresses (RegionOfCap (getCapReg auth s)) LOAD s"
        "getRegisterIsAccessible auth s"
        "getCAPR cd s' \<le> getMemCap a s"
using assms
using SemanticsLoadCapability_NextWithGhostState
         [where cap="getMemCap a s" and cd=cd and a=a and auth=auth and
                authCap="getCapReg auth s" and addrTrans="getTranslateAddrFunc s" and
                authAccessible="getRegisterIsAccessible auth s",
          THEN HoareTripleE[where s=s]]
unfolding SemanticsLoadCapPost_def
unfolding AddressIsCapReadable_def
unfolding getTranslateAddrFunc_def getTranslateAddresses_def
unfolding SemanticsCheriMips_def Next_NextWithGhostState NextNonExceptionStep_def
by (auto simp: ValueAndStatePart_simp split: if_splits option.splits)

corollary LoadCapInstantiation:
  assumes "(lbl, s') \<in> SemanticsCheriMips s"
  shows "LoadCapProp s lbl s'"
unfolding LoadCapProp_def
using assms SemanticsLoadCap
by metis

(*<*)
end
(*>*)


theory Instagram
  imports UnintentionalInsider
begin

locale scenarioSN =
fixes friends :: "identity set"
defines friends_def: "friends \<equiv> {''Alice'', ''Bob''}"
fixes sn_locations :: "location set"
defines sn_locations_def: "sn_locations \<equiv>
          {Location 0, Location 1, Location 2}"

fixes aphone :: "location"
defines aphone_def: "aphone \<equiv> Location 0"
fixes bphone :: "location"
defines bphone_def: "bphone \<equiv> Location 1"
fixes instagram :: "location"
defines instagram_def: "instagram \<equiv> Location 2"

fixes global_policy :: "[infrastructure, identity] \<Rightarrow> bool"
defines global_policy_def: "global_policy I a \<equiv> a \<notin> friends
                 \<longrightarrow> \<not>(enables I instagram (Actor a) get)"

fixes ex_creds :: "actor \<Rightarrow> (string set * string set)"
defines ex_creds_def: "ex_creds \<equiv> (\<lambda> x. if x = Actor ''Alice'' then
                         ({''aPIN''}, {}) else
                            (if x = Actor ''Bob'' then
                                ({''bPIN''},{}) else ({},{})))"

fixes ex_psys :: "identity \<Rightarrow> actor_state"
defines "ex_psys \<equiv> (\<lambda> x. Actor_state happy {approval_hungry})"

fixes ex_locs :: "location \<Rightarrow>  (dlm * data)set"
defines "ex_locs \<equiv>  (\<lambda> x. {})"

fixes ex_locs' :: "location \<Rightarrow>  (dlm * data)set"
defines "ex_locs' \<equiv>  (\<lambda> x.  if x = instagram then
             ({((Actor ''Alice'',{Actor ''Bob''}),''Alice's_diary'')})
             else ({}))"

fixes ex_locs'' :: "location \<Rightarrow>  (dlm * data)set"
defines "ex_locs'' \<equiv>  (\<lambda> x.  if x = instagram then
             ({((Actor ''Alice'',{Actor ''Bob''}),''Alice's_diary'')})
             else (if x = bphone then ({((Actor ''Alice'',{Actor ''Bob''}),''Alice's_diary'')})  else {}))"

fixes ex_loc_ass :: "location \<Rightarrow> identity set"
defines ex_loc_ass_def: "ex_loc_ass \<equiv>
          (\<lambda> x.  if x = aphone then {''Alice''}
                 else (if x = bphone then {''Bob''}
                       else (if x = instagram then {''Eve''}
                             else {})))"

fixes ex_graph :: "igraph"
defines ex_graph_def: "ex_graph \<equiv> Lgraph
     {(aphone, instagram), (bphone, instagram)}
     ex_loc_ass
     ex_creds ex_psys ex_locs"

fixes ex_graph' :: "igraph"
defines ex_graph'_def: "ex_graph' \<equiv> Lgraph
     {(aphone, instagram), (bphone, instagram)}
       (\<lambda> x. if x = instagram then {''Alice'',''Eve''} else
           (if x = bphone then {''Bob''} else {}))
     ex_creds ex_psys ex_locs"

fixes ex_graph'' :: "igraph"
defines ex_graph''_def: "ex_graph'' \<equiv> Lgraph
     {(aphone, instagram), (bphone, instagram)}
       (\<lambda> x. if x = instagram then {''Alice'',''Eve''} else
           (if x = bphone then {''Bob''} else {}))
     ex_creds ex_psys ex_locs'"

fixes ex_graph''' :: "igraph"
defines ex_graph'''_def: "ex_graph''' \<equiv> Lgraph
     {(aphone, instagram), (bphone, instagram)}
       (\<lambda> x. if x = instagram then {''Alice'',''Eve''} else
           (if x = bphone then {''Bob''} else {}))
     ex_creds ex_psys ex_locs''"

fixes local_policies :: "[igraph, location] \<Rightarrow> apolicy set"
defines local_policies_def: "local_policies G \<equiv>
    (\<lambda> x. if x = aphone then
        {((\<lambda> y. has G (y, ''aPIN'')), {put,get,move,eval})}
          else (if x = bphone then
                {((\<lambda> y. has G (y, ''bPIN'')), {put,get,move,eval})}
                else (if x = instagram then
                {(\<lambda> y. y \<in> {Actor ''Alice'', Actor ''Bob''}, {put,get,move,eval})}
                       else  {})))"

fixes sn_scenario :: "infrastructure"
defines sn_scenario_def:
"sn_scenario \<equiv> Infrastructure ex_graph local_policies"

fixes Isn :: "infrastructure set"
defines Isn_def:
  "Isn \<equiv> {sn_scenario}"

fixes sn_scenario' :: "infrastructure"
defines sn_scenario'_def:
"sn_scenario' \<equiv> Infrastructure ex_graph' local_policies"

fixes SN' :: "infrastructure set"
defines SN'_def:
  "SN' \<equiv> {sn_scenario'}"

fixes sn_scenario'' :: "infrastructure"
defines sn_scenario''_def:
"sn_scenario'' \<equiv> Infrastructure ex_graph'' local_policies"

fixes SN'' :: "infrastructure set"
defines SN''_def:
  "SN'' \<equiv> {sn_scenario''}"

fixes sn_scenario''' :: "infrastructure"
defines sn_scenario'''_def:
"sn_scenario''' \<equiv> Infrastructure ex_graph''' local_policies"

fixes SN''' :: "infrastructure set"
defines SN'''_def:
  "SN''' \<equiv> {sn_scenario'''}"

fixes sn_states
defines sn_states_def: "sn_states \<equiv> { I. sn_scenario \<rightarrow>\<^sub>i* I }"

fixes sn_Kripke
defines "sn_Kripke \<equiv> Kripke sn_states {sn_scenario}"

fixes bsn
defines "bsn \<equiv> {x. enables x instagram (Actor ''Bob'') get}"

fixes ssn
defines "ssn \<equiv> {x. \<not> (global_policy x ''Eve'')}"

(* If we want to show without Insider: Assumption that there is no insider
assumes no_insider: "inj Actor" *)
assumes insider_Alice: "Insider ''Alice'' {''Eve''} ex_psys"

begin
lemma step1: "sn_scenario \<rightarrow>\<^sub>n sn_scenario'"
proof (rule_tac l = aphone and a = "''Alice''" and l' = instagram in move)
  show "graphI sn_scenario = graphI sn_scenario" by (rule refl)
next show "''Alice'' @\<^bsub>graphI sn_scenario\<^esub> aphone"
by (simp add: sn_scenario_def ex_graph_def ex_loc_ass_def atI_def nodes_def)
next show "aphone \<in> nodes (graphI sn_scenario)"
    by (simp add: sn_scenario_def ex_graph_def ex_loc_ass_def atI_def nodes_def, blast)
next show "instagram \<in> nodes (graphI sn_scenario)"
    by (simp add: sn_scenario_def nodes_def ex_graph_def, blast)
next show "''Alice'' \<in> actors_graph (graphI sn_scenario)"
    by (simp add: actors_graph_def sn_scenario_def ex_graph_def ex_loc_ass_def nodes_def, auto)
next show "enables sn_scenario instagram (Actor ''Alice'') move"
    by (simp add: enables_def sn_scenario_def ex_graph_def local_policies_def
                    ex_creds_def ex_locs_def has_def credentials_def instagram_def bphone_def)
next show "sn_scenario' =
    Infrastructure (move_graph_a ''Alice'' aphone instagram (graphI sn_scenario)) (delta sn_scenario)"
    apply (simp add: sn_scenario'_def ex_graph'_def move_graph_a_def
                   sn_scenario_def ex_graph_def aphone_def instagram_def bphone_def
                    ex_loc_ass_def ex_creds_def)
    apply (rule ext)
    by (simp add: bphone_def instagram_def)
qed

lemma step1r: "sn_scenario  \<rightarrow>\<^sub>n* sn_scenario'"
proof (simp add: state_transition_in_refl_def)
  show " (sn_scenario, sn_scenario') \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*"
  by (insert step1, auto)
qed

lemma step2r: "sn_scenario'  \<rightarrow>\<^sub>n* sn_scenario''"
proof (simp add: state_transition_in_refl_def)
  show "(sn_scenario', sn_scenario'') \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*"
    by (insert step2, auto)
qed

lemma step3: "sn_scenario''  \<rightarrow>\<^sub>n sn_scenario'''"
proof (rule_tac l = bphone and l' = instagram and h' = "''Alice''" and h = "''Bob''" and hs = "{Actor ''Bob''}" and
        n = "''Alice's_diary''" in get_data, rule refl)
  show "''Bob'' @\<^bsub>graphI sn_scenario''\<^esub> bphone"
   by (simp add: sn_scenario''_def ex_graph''_def instagram_def bphone_def atI_def nodes_def)
next show "bphone \<in> nodes (graphI sn_scenario'')"
    by (simp add: sn_scenario''_def ex_graph''_def bphone_def instagram_def atI_def nodes_def, blast)
next show "instagram \<in> nodes (graphI sn_scenario'')"
    by (simp add: sn_scenario''_def ex_graph''_def bphone_def instagram_def atI_def nodes_def, blast)
next show "enables sn_scenario'' instagram (Actor ''Bob'') get"
    by (simp add: enables_def sn_scenario''_def ex_graph_def local_policies_def
           ex_creds_def ex_locs_def has_def credentials_def instagram_def aphone_def bphone_def)
next show "((Actor ''Alice'',{Actor ''Bob''}),''Alice's_diary'') \<in> lgra (graphI sn_scenario'') instagram"
    by (simp add: sn_scenario''_def instagram_def ex_graph''_def ex_locs'_def)
next show "Actor ''Bob'' \<in> {Actor ''Bob''} \<or> ''Bob'' = ''Alice''" by simp
next show "sn_scenario''' =
    Infrastructure
     (Lgraph (gra (graphI sn_scenario'')) (agra (graphI sn_scenario'')) (cgra (graphI sn_scenario''))
       (pgra (graphI sn_scenario''))
       ((lgra (graphI sn_scenario''))
        (bphone :=
           lgra (graphI sn_scenario'') bphone \<union>
           {((Actor ''Alice'', {Actor ''Bob''}),
             [CHR ''A'', CHR ''l'', CHR ''i'', CHR ''c'', CHR ''e'', CHR 0x27, CHR ''s'', CHR ''_'', CHR ''d'', CHR ''i'',
              CHR ''a'', CHR ''r'', CHR ''y''])})))
     (delta sn_scenario'')"
    apply (simp add: sn_scenario''_def ex_graph'''_def move_graph_a_def sn_scenario'''_def
                     ex_graph''_def instagram_def aphone_def bphone_def ex_creds_def ex_locs''_def
                     ex_locs'_def)
    apply (rule ext)
    by (simp add: bphone_def)
qed

lemma step3r: "sn_scenario''  \<rightarrow>\<^sub>n* sn_scenario'''"
proof (simp add: state_transition_in_refl_def)
  show "(sn_scenario'', sn_scenario''') \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*"
    by (insert step3, auto)
qed

(* Simple without insider possible: if Alice is unaware, she'll upload her data
   and her friend Bob can read it *)

(* TODO *)
lemma bsn_ref: "[\<N>\<^bsub>(Isn,bsn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,bsn)\<^esup> \<sqsubseteq>
                  [\<N>\<^bsub>(Isn,SN')\<^esub>, \<N>\<^bsub>(SN',SN'')\<^esub>, \<N>\<^bsub>(SN'',bsn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,bsn)\<^esup>"
by (metis append_Cons append_Nil refI)

lemma att_bsn: "\<turnstile> [\<N>\<^bsub>(Isn,SN')\<^esub>, \<N>\<^bsub>(SN',SN'')\<^esub>, \<N>\<^bsub>(SN'',bsn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,bsn)\<^esup>"
proof (subst att_and, simp, rule conjI)
  show " \<turnstile>\<N>\<^bsub>(Isn, SN')\<^esub>"
   apply (simp add: Isn_def SN'_def att_base)
   apply (subst state_transition_infra_def)
   by (rule step1)
next show "\<turnstile>[\<N>\<^bsub>(SN', SN'')\<^esub>, \<N>\<^bsub>(SN'', bsn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(SN', bsn)\<^esup>"
    apply (subst att_and, simp)
    apply (rule conjI)
     apply (simp add: SN'_def SN''_def att_base)
     apply (subst state_transition_infra_def, rule step2)
    apply (subst att_and, simp)
    apply (simp add: SN''_def bsn_def att_base)
    apply (rule_tac x = sn_scenario''' in exI)
    apply (rule conjI)
     apply (simp add: sn_scenario'''_def friends_def
                    enables_def local_policies_def instagram_def bphone_def aphone_def)
    by (subst state_transition_infra_def, rule step3)
qed

lemma bsn_abs_att: "\<turnstile>\<^sub>V [\<N>\<^bsub>(Isn,bsn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,bsn)\<^esup>"
proof (rule ref_valI, rule bsn_ref, rule att_bsn)
qed

lemma bsn_att: "sn_Kripke \<turnstile> EF bsn"
proof -
  have a: "\<turnstile>[\<N>\<^bsub>(Isn,SN')\<^esub>, \<N>\<^bsub>(SN',SN'')\<^esub>, \<N>\<^bsub>(SN'',bsn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,bsn)\<^esup>"
    by (rule att_bsn)
  hence "(Isn,bsn) = attack([\<N>\<^bsub>(Isn,SN')\<^esub>, \<N>\<^bsub>(SN',SN'')\<^esub>, \<N>\<^bsub>(SN'',ssn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,bsn)\<^esup>)"
    by simp
  hence "Kripke {s::infrastructure. \<exists>i::infrastructure\<in>Isn. i \<rightarrow>\<^sub>i* s} Isn \<turnstile> EF bsn"
    apply (insert a)
    apply (erule AT_EF)
    by simp
  thus  "sn_Kripke \<turnstile> EF bsn"
    by (simp add: sn_Kripke_def sn_states_def Isn_def bsn_def)
qed

theorem bsn_EF: "sn_Kripke \<turnstile> EF bsn"
proof (rule bsn_att)
qed

(* The CTL statement can now be directly translated into Attack Trees using
   the meta-theory, i.e. Correctness and Completeness theorems. *)
theorem bsn_AT: "\<exists> A. \<turnstile> A \<and> attack A = (Isn,bsn)"
proof -
  have a: "sn_Kripke \<turnstile> EF bsn" by (rule bsn_EF)
  have b: "Isn \<noteq> {}" by (simp add: Isn_def)
  thus "\<exists>A::infrastructure attree. \<turnstile>A \<and> attack A = (Isn, bsn)"
    apply (rule Completeness)
    apply (simp add: Isn_def)
    apply (insert a)
    by (simp add: sn_Kripke_def Isn_def sn_states_def)
qed

(* So far this has just shown that Bob - who is a friend of Alice -- can get
   her data from instagram because she labeled it with him as a reader. The
   reason is her unawareness which is a condition to the put rule.
   Now, if Bob is an insider he could be impersonated by Eve and Eve could
   thus get it. This is already possible in the "old" malicious insider model.
   However, now with the Unintentional Insiders, Eve can already impersonate Alice and
   can thus get the information straight from her, without the need to go via Bob!*)

(* The global policy is broken because it is also possible for Eve to
   access Alice's diary. For this we need that the Insider assumption holds.
   Now, we can prove this without Bob being malicious but because Alice is unaware
   and thus is an unintentional insider. *)
lemma Alice_unintentional_insider: "UasI ''Alice'' ''Eve''"
  using Insider_def ex_psys_def insider_Alice unaware_def by auto

lemma sn_ref: "[\<N>\<^bsub>(Isn,ssn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,ssn)\<^esup> \<sqsubseteq>
                  [\<N>\<^bsub>(Isn,SN')\<^esub>, \<N>\<^bsub>(SN',SN'')\<^esub>, \<N>\<^bsub>(SN'',ssn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,ssn)\<^esup>"
by (metis append_Cons append_Nil refI)

lemma att_sn: "\<turnstile> [\<N>\<^bsub>(Isn,SN')\<^esub>, \<N>\<^bsub>(SN',SN'')\<^esub>, \<N>\<^bsub>(SN'',ssn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,ssn)\<^esup>"
proof (subst att_and, simp, rule conjI)
  show " \<turnstile>\<N>\<^bsub>(Isn, SN')\<^esub>"
   apply (simp add: Isn_def SN'_def att_base)
   apply (subst state_transition_infra_def)
   by (rule step1)
next show "\<turnstile>[\<N>\<^bsub>(SN', SN'')\<^esub>, \<N>\<^bsub>(SN'', ssn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(SN', ssn)\<^esup>"
    apply (subst att_and, simp)
    apply (rule conjI)
     apply (simp add: SN'_def SN''_def att_base)
     apply (subst state_transition_infra_def, rule step2)
    apply (subst att_and, simp)
    apply (simp add: SN''_def ssn_def att_base)
    apply (rule_tac x = sn_scenario''' in exI)
    apply (rule conjI)
    apply (simp add: global_policy_def)
     apply (simp add: global_policy_def sn_scenario'''_def friends_def
                    enables_def local_policies_def instagram_def bphone_def aphone_def)
    using Alice_unintentional_insider UasI_def apply auto[1]
    by (subst state_transition_infra_def, rule step3)
qed

lemma sn_abs_att: "\<turnstile>\<^sub>V [\<N>\<^bsub>(Isn,ssn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,ssn)\<^esup>"
proof (rule ref_valI, rule sn_ref, rule att_sn)
qed

lemma sn_att: "sn_Kripke \<turnstile> EF {x. \<not>(global_policy x ''Eve'')}"
proof -
  have a: "\<turnstile>[\<N>\<^bsub>(Isn,SN')\<^esub>, \<N>\<^bsub>(SN',SN'')\<^esub>, \<N>\<^bsub>(SN'',ssn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,ssn)\<^esup>"
    by (rule att_sn)
  hence "(Isn,ssn) = attack([\<N>\<^bsub>(Isn,SN')\<^esub>, \<N>\<^bsub>(SN',SN'')\<^esub>, \<N>\<^bsub>(SN'',ssn)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Isn,ssn)\<^esup>)"
    by simp
  hence "Kripke {s::infrastructure. \<exists>i::infrastructure\<in>Isn. i \<rightarrow>\<^sub>i* s} Isn \<turnstile> EF ssn"
    apply (insert a)
    apply (erule AT_EF)
    by simp
  thus  "sn_Kripke \<turnstile> EF {x::infrastructure. \<not> global_policy x ''Eve''}"
    by (simp add: sn_Kripke_def sn_states_def Isn_def ssn_def)
qed

theorem sn_EF: "sn_Kripke \<turnstile> EF ssn"
proof (insert sn_att, simp add: ssn_def)
qed

(* The CTL statement can now be directly translated into Attack Trees using
   the meta-theory, i.e. Correctness and Completeness theorems. *)
theorem sn_AT: "\<exists> A. \<turnstile> A \<and> attack A = (Isn,ssn)"
proof -
  have a: "sn_Kripke \<turnstile> EF ssn" by (rule sn_EF)
  have b: "Isn \<noteq> {}" by (simp add: Isn_def)
  thus "\<exists>A::infrastructure attree. \<turnstile>A \<and> attack A = (Isn, ssn)"
    apply (rule Completeness)
    apply (simp add: Isn_def)
    apply (insert a)
    by (simp add: sn_Kripke_def Isn_def sn_states_def)
qed

end


theory WP_Extras
imports
  "nicta_lib/Monad_WP/wp/WPEx"
begin

lemma exs_valid_modify[wp]: "\<lbrace>\<lambda>s. Q () (f s)\<rbrace> modify f \<exists>\<lbrace>Q\<rbrace>"
  unfolding modify_def
  apply (rule exs_valid_bind [where B = "\<lambda>s _. Q () (f s)"])
  apply (auto simp add: exs_valid_def get_def put_def)
done

lemma non_fail_select': "no_fail P (select S)"
unfolding no_fail_def select_def by auto

end


(*  Title:      MultiASP.thy
    Author:     Ludovic Henrio and Florian Kammuller
                2014

    Note:       Multi-active object formalisation
                For the moment methods and parameter bindings are done statically,
                  without inheritance but with interfaces
                  this could be improved
*)
(*Conventions:
  l = location in store
  x,y=varname
  locs = local variables
  l_\<alpha> = location in the local store of the active object of \<alpha>
 Stl = statement list
 EContext is an execution context, ie a thread
 EcL = EContext list*)

header {* Syntax and Semantics *}

theory MultiASP imports Main AuxiliaryFunctions begin

subsection {* Syntax *}
type_synonym ItfName = string
type_synonym VarName =  string
datatype VarOrThis = This | Id VarName
type_synonym ClassName = string
type_synonym MethodName = string

type_synonym ActName = nat
type_synonym FutName = nat
type_synonym Location = nat

datatype Signature = Method ItfName MethodName  "(ItfName * VarName) list"
  (* signature = Method returnType MethodName (list of parameters)*)

datatype Value = null | ASPInt nat | ASPBool bool (* static values *)
                | ActRef ActName (* runtime values *)
                | ObjRef Location
type_synonym  Object = "(VarName~=>Value) * ClassName"
abbreviation GetObject:: "Object \<Rightarrow>VarName=>Value option" ("_.[_]")
  where "GetObject ob x \<equiv> (fst ob) x"
abbreviation SetObject:: "Object \<Rightarrow>VarName=>Value\<Rightarrow>Object" ("_.[_]:=_")
  where "SetObject ob x v\<equiv> ((fst ob)(x\<mapsto>v),snd ob)"

datatype Storable = Obj Object | FutRef FutName | StoredVal Value

datatype Expression = Val Value
             | Var VarOrThis
             | Plus Expression Expression ("_+\<^sub>A_" [120,120] 200)
             | And Expression Expression ("_&\<^sub>A_" [100,100] 300)
             | Test Expression Expression ("_==\<^sub>A_" [100,100] 300)

datatype Rhs = Expr Expression
             | Call Expression MethodName "Expression list" ("_.\<^sub>A_'(_')" [440,0,50] 500) (*e.m(e list) *)
             | New ClassName "Expression list" ("new _'(_')" [300,0] 500) (*new C(e list) *)
             | NewActive ClassName "Expression list" ("newActive _'(_')" [300,0] 500) (*newActive C(e list) *)
             | Hole (* runtime term *)

datatype Statement =   Assign VarName Rhs  (infix "=\<^sub>A"  400) (*x=z*)
| Return Expression ("return _" [300] 300)(*return E *)
| If Expression "Statement list" "Statement list" ("IF _ THEN _ ELSE _ " [300,0,0] 300)(*if E then s else s *)
(* skip |  NB: skip and seq are not necessary thanks to the use of statement list
| Seq Statement Statement (infix ";;"  100)*)
abbreviation MakeStatementList:: "Statement \<Rightarrow>Statement list\<Rightarrow>Statement list" (infix ";;" 100)
  where "MakeStatementList s Stl\<equiv> s#Stl"
abbreviation MakeStatementList2:: "Statement \<Rightarrow>Statement\<Rightarrow>Statement list" (infix ";;;" 80)
  where "MakeStatementList2 s s'\<equiv> s#[s']"

(*primrec RedContext:: "Statement\<Rightarrow> Statement \<times>Statement" (* returns basic instruction,context , i.e. the rest of the sequence*)
where
  "RedContext Skip = (Skip,Skip)" |
  "RedContext (x=\<^sub>Az) =  ((x=\<^sub>Az),Skip)" |
  "RedContext (return e) =  (return e,Skip)" |
  "RedContext (IF e THEN s ELSE s') =  (IF e THEN s ELSE s',Skip)" |
  "RedContext ( s ;; s') =  (fst (RedContext s),(snd (RedContext s);;s'))"
*)
(*abbreviation BuildContext::"Statement\<Rightarrow>Statement\<Rightarrow> Statement \<times>Statement" ("_[[_]]" [300, 0] 300)
where "BuildContext R s \<equiv> (s,R)"
*)
record Method =
MethSignature:: Signature
LocalVariables::"(ItfName * VarName) list"
Body::"Statement list"
(*MethDefinition methodname (local variables) body*)

abbreviation Parameters::"Method \<Rightarrow>(ItfName * VarName) list"
where "Parameters m \<equiv> case (MethSignature m) of
        Method ItfName MethodName  param_list\<Rightarrow>param_list"

abbreviation MName:: "Method \<Rightarrow> MethodName"
where "MName m \<equiv> case (MethSignature m) of
        (Method returnType MethName listparameters) \<Rightarrow>MethName"

abbreviation MRType:: "Method \<Rightarrow> ItfName"
where "MRType m \<equiv> case (MethSignature m) of
        (Method returnType MethName listparameters) \<Rightarrow>returnType"

abbreviation MParams:: "Method \<Rightarrow>(ItfName * VarName) list"
where "MParams m \<equiv> case (MethSignature m) of
        (Method returnType MethName listparameters) \<Rightarrow>listparameters"

record Class =
 Name::ClassName
 Interfaces::"(ItfName list) "
 ClassParameters::"((ItfName * VarName) list)"
 StateVariables::"((ItfName * VarName) list)"
 Methods::"(Method list)"
             (*ASPclass name (classparameters) (implementedinterfaces) (statevariables) (listofmethodbodies) *)
record Interface =
  IName:: ItfName
  IMethods:: "(Signature list)"

datatype Program = Prog "Interface list" "Class list" "(ItfName * VarName) list" "Statement list"

type_synonym EContext = " Location * (VarName~=>Value) * (Statement list)"
                          (*execution context = location of this, local variables, and statements *)
type_synonym Request = "FutName * MethodName * (Value list)"
type_synonym Store = "Location~=>Storable"
abbreviation EC_location::"EContext \<Rightarrow>Location"
where "EC_location Ec \<equiv> fst Ec"
abbreviation EC_locs:: "EContext \<Rightarrow>(VarName~=>Value)"
where "EC_locs Ec \<equiv> fst (snd Ec)"
abbreviation EC_Stl:: "EContext \<Rightarrow>Statement list"
where "EC_Stl Ec \<equiv> snd (snd Ec)"
(*datatype Process = Proc Request "Context list" *)

datatype ActiveObject = AO Location Store "Request~=>(EContext list)" "Request list"
    (* active object location , store, task list, request queue*)

datatype FutValue = Undefined | FutVal Value  Store

datatype Configuration = Cn "ActName~=>ActiveObject" "FutName~=>FutValue"

subsection {*finite configuration *}

definition finite_Store :: "Store \<Rightarrow> bool"
  where
    "finite_Store \<sigma> \<equiv> (finite (dom \<sigma>) \<and> (\<forall> loc obj. (\<sigma>(loc)=Some (Obj obj)\<longrightarrow> finite (dom (fst obj)))))"

definition finite_Processes :: "(Request~=>(EContext list)) \<Rightarrow> bool"
  where
    "finite_Processes (processMap) \<equiv> finite (dom (processMap)) \<and>
       (\<forall> contList\<in>(ran(processMap)). \<forall>cont\<in> set contList. finite (dom(EC_locs(cont))))"

primrec finite_Configuration :: "Configuration => bool"
  where
 " finite_Configuration (Cn AOs Futures) =
      (finite (dom AOs) \<and> finite (dom Futures) \<and>
    (\<forall> futVal\<in>(ran Futures). \<forall> v \<sigma>. (futVal =FutVal v \<sigma> \<longrightarrow> finite_Store \<sigma>)) \<and> (*NB: Undefined futures are finite*)
    (\<forall> ao\<in>(ran AOs). \<forall> l \<sigma> P Q. ao = AO l \<sigma> P Q \<longrightarrow> finite_Store \<sigma> \<and> finite_Processes P))"
declare MultiASP.finite_Configuration.simps[simp del]

text{* Binding and fetching elements *}
definition  fetchClass
where
"fetchClass P C \<equiv>
case P of (Prog Is CL Vars Stl) \<Rightarrow> (List.find  (\<lambda>class.(Name class) = C) CL)
"
definition fetchMethodInClass
where
"fetchMethodInClass  class m \<equiv>
Option.bind
(List.find (\<lambda>method. (MName method = m)) (Methods class))
(\<lambda>method. Some (map snd (MParams method), map snd (LocalVariables method), Body method))
"

definition Bind::"Program\<Rightarrow>Location\<Rightarrow>ClassName\<Rightarrow>MethodName\<Rightarrow>Value list\<Rightarrow> EContext option"
where
 "Bind P l C m value_list\<equiv>
(case fetchClass P C of
  Some class \<Rightarrow>
    (case  fetchMethodInClass class m  of
       Some (param_list,locs,b) \<Rightarrow>
         if length param_list = length value_list then
           ( let locales=  (map_of (zip locs (replicate (length locs) null)))
                    ++ (map_of (zip param_list value_list)) in
                Some ( l, locales,b))
           else None
       | None \<Rightarrow> None)
  | _\<Rightarrow> None)"
definition  fields:: "Program\<Rightarrow>ClassName \<Rightarrow>VarName list"
where
  "fields P C \<equiv>
     case (fetchClass P C) of
  Some class \<Rightarrow>(map snd (StateVariables class))"

definition  params:: "Program\<Rightarrow>ClassName \<Rightarrow>VarName list"
where
  "params P C \<equiv>case (fetchClass P C) of
  Some class \<Rightarrow>(map snd (ClassParameters class))"

definition Interface_set_from_variable_list:: "(ItfName * VarName) list\<Rightarrow>ItfName set"
where
"Interface_set_from_variable_list VL\<equiv> set (map fst VL)"

abbreviation DefinedClassNames
where "DefinedClassNames prog \<equiv>set (case prog of Prog IL CL vl xtl \<Rightarrow>map Name CL)"

subsection {* serialization and location renaming *}

inductive serialize :: "Value \<Rightarrow> Store \<Rightarrow> Store \<Rightarrow> bool"
(*serialize v \<sigma> \<sigma>' is true if the serialization of value v is a subset of \<sigma>' (using store \<sigma>)*)
  where
    " \<sigma>'(l) = \<sigma>(l) \<and> \<sigma>(l) = Some (Obj obj) \<and> (\<forall> v\<in> ran(fst(obj)). \<exists>\<sigma>''. (serialize v \<sigma> \<sigma>''\<and> \<sigma>'' \<subseteq>\<^sub>m \<sigma>'))
     \<Longrightarrow> (serialize (ObjRef l) \<sigma> \<sigma>')" |
    " \<sigma>'(l) = \<sigma>(l) \<and> \<sigma>(l) = Some (FutRef f)  \<Longrightarrow> (serialize (ObjRef l) \<sigma> \<sigma>')" |
    " \<sigma>'(l) = \<sigma>(l) \<and> \<sigma>(l) = Some (StoredVal v)  \<Longrightarrow> (serialize (ObjRef l) \<sigma> \<sigma>')" |
     "(serialize (ActRef f) \<sigma> \<sigma>')" |
     "serialize (null) \<sigma> \<sigma>' " |
     "serialize (ASPInt n) \<sigma> \<sigma>'" |
     "serialize (ASPBool b) \<sigma> \<sigma>'"

 definition Referenced_locations_Value:: "Value \<Rightarrow> Location set"
where  "Referenced_locations_Value v \<equiv> (case v of ObjRef l \<Rightarrow>{l} | _ \<Rightarrow> {})"

axiomatization where finite_map: "finite (dom (\<sigma>::Store))"
function (sequential) serialization_filter :: "Location \<Rightarrow> Store \<Rightarrow> Location set \<Rightarrow> Location set"
(*serialize v \<sigma> \<sigma>' is true if the serialization of value v is a subset of \<sigma>' (using store \<sigma>)*)
  where
    "
    (serialization_filter l \<sigma> L) = (if l\<in>L then {} else
      (case \<sigma>(l) of
      Some (Obj obj) \<Rightarrow> listunionMap (\<lambda>x.(serialization_filter x \<sigma> (L\<union>{l})))
                (sorted_list_of_set (\<Union>(Referenced_locations_Value`ran(fst(obj))))) |
      _ \<Rightarrow> {}))"
by auto
termination
apply (relation "measure (\<lambda>(l,\<sigma>,L). card (dom \<sigma> - L))")
apply auto
apply (subgoal_tac "dom \<sigma> - insert l L = (dom \<sigma> - L) - {l}")
apply (subgoal_tac "finite ((dom \<sigma>-L))")
apply (drule_tac x=l in Finite_Set.card.remove)+
apply (insert finite_map)
apply auto
done

primrec subst_Value :: " Value \<Rightarrow> (Location\<Rightarrow>Location) \<Rightarrow> Value"
where
  "subst_Value (ObjRef l) \<psi> = ObjRef (\<psi>(l))" |
  "subst_Value (ActRef a) \<psi> = ActRef a" |
  "subst_Value (null) \<psi> = null" |
  "subst_Value (ASPInt i) \<psi> = ASPInt i" |
  "subst_Value (ASPBool b) \<psi> = ASPBool b"

definition check_subst :: "Store \<Rightarrow> (Location\<Rightarrow>Location) \<Rightarrow> Store \<Rightarrow> bool"
where
  "check_subst  \<sigma> \<psi> \<sigma>' \<equiv>
    ( inj \<psi> \<and> dom \<sigma>' =  \<psi> ` (dom(\<sigma>))
    \<and> (\<forall> obj l . (\<sigma>(l) = Some (Obj obj)
      \<longrightarrow> (\<exists> obj'. (\<sigma>'(\<psi>(l)) = Some (Obj obj') \<and> (\<forall> x  v. (obj.[x]) = Some v \<longrightarrow> (obj'.[x])=Some (subst_Value v \<psi>)))))
    \<and>   (\<forall> f l . (\<sigma>(l) = Some (FutRef f) \<longrightarrow> \<sigma>'(\<psi>(l)) =Some (FutRef f)))
    \<and>   (\<forall> v l . (\<sigma>(l) = Some (StoredVal v) \<longrightarrow>
      \<sigma>'(\<psi>(l)) = Some (StoredVal (subst_Value v \<psi>))))))"

definition rename_value_store :: " Store \<Rightarrow> Value \<Rightarrow> Store \<Rightarrow> Value \<Rightarrow> Store \<Rightarrow> bool"
 where "rename_value_store \<sigma>\<^sub>0 v \<sigma> v' \<sigma>'  \<equiv> (\<exists>\<psi> . check_subst \<sigma> \<psi> \<sigma>'\<and>v'=subst_Value v \<psi>)\<and>
                                            dom \<sigma>\<^sub>0 \<inter> dom \<sigma>' = {}"

definition serialize_and_rename_list :: " Store \<Rightarrow> Value list \<Rightarrow> Store \<Rightarrow> Value list \<Rightarrow> Store \<Rightarrow> bool"
 where "serialize_and_rename_list \<sigma>\<^sub>0 vl \<sigma> vl' \<sigma>'  \<equiv>
              length vl=length vl' \<and>
              (\<exists>\<psi> \<sigma>''. (\<forall> i<length vl. serialize  (vl!i) \<sigma> \<sigma>''\<and>vl'!i=subst_Value (vl!i) \<psi>) \<and>check_subst \<sigma>'' \<psi> \<sigma>') \<and>
              dom \<sigma>\<^sub>0 \<inter> dom \<sigma>' = {}"

(*locale Generic_Functions = *)

(*consts
  Bind:: "Program\<Rightarrow>Location\<Rightarrow>ClassName\<Rightarrow>MethodName\<Rightarrow>Value list\<Rightarrow> EContext "*)
(* consts
  params:: "Program\<Rightarrow>ClassName \<Rightarrow>VarName list"
 *)
(*consts fetch:: "Class list\<Rightarrow>ClassName\<Rightarrow>MethodName\<Rightarrow>
            ((VarName list) *(VarName list) * (Statement list)) option" *)

(* semantics parameterized by compatibility and binder function*)
axiomatization
  Compatible :: "(Request * Request) set"
where
  symmetric_compatible: "sym Compatible"

lemma COMP[rule_format]: "\<forall>x y. (x,y)\<in>Compatible\<longrightarrow>(y,x)\<in>Compatible"
apply (fold sym_def)
apply (rule symmetric_compatible)
done

section{*SOS*}

(*datatype EvaluatedExpr = Undefined | EVal Value | EObj Object | EFutRef FutName*)

inductive_set EvalValue:: "(Value \<times> Store \<times> Value) set"
where
  Valnull[simp,intro]: "(null, \<sigma>,  null)\<in>EvalValue" |
  Valint[simp,intro]: "(ASPInt i, \<sigma>,  (ASPInt i) )\<in>EvalValue" |
  valbool[simp,intro]: "(ASPBool b, \<sigma>,  (ASPBool b) )\<in>EvalValue" |
  valact[simp,intro]: "(ActRef \<alpha>, \<sigma>,  (ActRef \<alpha>) )\<in>EvalValue" |
  valfut[simp,intro]:"\<sigma>(l) = Some (FutRef f) \<Longrightarrow>(ObjRef l, \<sigma>, ObjRef l)\<in>EvalValue" |
  valobj[simp,intro]:"\<sigma>(l) = Some (Obj obj) \<Longrightarrow>(ObjRef l, \<sigma>, ObjRef l)\<in>EvalValue" |
  valstored[simp,intro]: "\<lbrakk>\<sigma>(l) = Some (StoredVal v);(v,\<sigma>,ee)\<in> EvalValue\<rbrakk> \<Longrightarrow>(ObjRef l, \<sigma>, ee)\<in>EvalValue"

lemma EvalValue_is_deterministic[rule_format,intro]: "(e,\<sigma>,v)\<in>EvalValue \<longrightarrow>(e,\<sigma>,v')\<in>EvalValue \<longrightarrow>v=v'"
apply (rule impI)
apply (erule EvalValue.induct)
apply auto
apply (erule EvalValue.cases,simp+)+
done

inductive_set EvalExpr:: "(Expression \<times> Location \<times> (VarName~=>Value)\<times>Store \<times> Value) set"
(* (e1,l,locs,\<sigma>,v) is true if e1 EVALUATES to v  in a setting where local variables are locs, store is \<sigma> and l is the location of this*)
 where
   exprval[simp,intro]: "(v,\<sigma>,ev)\<in>EvalValue \<Longrightarrow>(Val v, l, locs, \<sigma>, ev)\<in>EvalExpr" |
   exprlocs[simp,intro]: "\<lbrakk>locs(x)=Some v;(v,\<sigma>,ev)\<in>EvalValue\<rbrakk> \<Longrightarrow>(Var (Id x), l, locs, \<sigma>, ev)\<in>EvalExpr" |
   exprThis[simp,intro]: "\<lbrakk>(ObjRef l,\<sigma>,ev)\<in>EvalValue\<rbrakk> \<Longrightarrow>(Var This, l, locs, \<sigma>, ev)\<in>EvalExpr" |
   exprfield[simp,intro]:
   "\<lbrakk>locs(x)=None; \<sigma> l=Some (Obj ob); ob.[x] = Some v;(v,\<sigma>,ev)\<in>EvalValue\<rbrakk>
                      \<Longrightarrow>(Var (Id x), l, locs, \<sigma>, ev)\<in>EvalExpr" |
   expradd[simp,intro]:"\<lbrakk>(e,l,locs,\<sigma>,ASPInt i)\<in>EvalExpr;(e',l,locs,\<sigma>, ASPInt i')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e +\<^sub>A e', l, locs, \<sigma>, ASPInt (i+i'))\<in>EvalExpr" |
   exprand[simp,intro]:"\<lbrakk>(e,l,locs,\<sigma>,ASPBool b)\<in>EvalExpr;(e',l,locs,\<sigma>,ASPBool b')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e &\<^sub>A e', l, locs, \<sigma>, ASPBool (b\<and>b'))\<in>EvalExpr" |
   exprtest[simp,intro]:"\<lbrakk>(e,l,locs,\<sigma>,ASPInt i)\<in>EvalExpr;(e',l,locs,\<sigma>,ASPInt i')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e ==\<^sub>A e', l, locs, \<sigma>, ASPBool (i=i'))\<in>EvalExpr"

lemma EvalExpr_is_deterministic[rule_format]:
      " (e,l,locs,\<sigma>,v)\<in>EvalExpr \<longrightarrow> (\<forall> v'. (e,l,locs,\<sigma>,v')\<in>EvalExpr \<longrightarrow>v=v')"
apply (rule impI)
apply (erule EvalExpr.induct)
apply auto
apply (erule EvalExpr.cases,auto)
apply (erule EvalExpr.cases,auto)
apply (erule EvalExpr.cases,auto)
apply (erule EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e+\<^sub>Ae'"  in EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e&\<^sub>Ae'"  in EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e==\<^sub>Ae'"  in EvalExpr.cases,auto)
done

abbreviation Ready:: "Request\<Rightarrow>(Request~=>(EContext list))\<Rightarrow>(Request list)\<Rightarrow>bool"
  (*Ready q,p,Rq returns true if q is ready to be served*)
where
 "Ready R tasks Rq \<equiv>(\<forall> Q\<in>dom(tasks). (R,Q)\<in>Compatible)
                    \<and> (\<forall> Q\<in>set Rq. (R,Q)\<in>Compatible)"

inductive reduction :: "Program\<Rightarrow>[Configuration, Configuration] => bool"  ("_\<turnstile>_\<leadsto>_" 50)
  where
    Serve [simp, intro!]:
      "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> tasks (Rq@R#Rq')) ; R=(f,m,vl);
        Ready R tasks Rq;
         (\<sigma> l_\<alpha>) = Some (Obj (obj,C));
        Bind P l_\<alpha> C m vl = Some EC\<rbrakk>
          \<Longrightarrow> P\<turnstile>Cn Activities Futures
                \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(R\<mapsto>[EC]))) (Rq@Rq'))) Futures" |

    AssignLocal  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l,locs,(x=\<^sub>AExpr e);;Stl)#EcL);
       x\<in>dom locs ; (e,l, locs, \<sigma>,v)\<in>EvalExpr
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((l,locs(x\<mapsto>v),Stl)#EcL))) Rq)))  Futures" |

    AssignField  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(x=\<^sub>AExpr e);;Stl)#EcL);
       x\<notin>dom locs;  \<sigma>(l_this) = Some (Obj obj);     x\<in>dom(fst(obj));
       (e, l_this, locs, \<sigma>,v)\<in>EvalExpr;     \<sigma>'=\<sigma>(l_this\<mapsto>Obj (obj.[x]:=v))
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma>' (tasks(Q\<mapsto>((l_this,locs,Stl)#EcL))) Rq))) Futures" |

     New  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(x=\<^sub>Anew C(el));;Stl)#EcL);
       field_list=fields P C; param_list=params P C; field_list\<noteq>undefined;
       l\<notin>dom \<sigma>;
       length param_list = length el;length param_list = length value_list;
       \<forall> i<length value_list . (el!i,l_this,locs,\<sigma>,value_list!i)\<in>EvalExpr ;
       \<sigma>'=\<sigma>(l\<mapsto> Obj (  (map_of (zip field_list (replicate (length field_list) null)))
                    ++ (map_of (zip param_list value_list)), C ))
      \<rbrakk>
      (* new term to evaluate is artificially complex because obj ref has to be encapsulated in a value and an expression*)
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma>' (tasks(Q\<mapsto>((l_this,locs,(x=\<^sub>AExpr (Val (ObjRef l));;Stl))#EcL))) Rq)) ) Futures" |

     NewActive  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(x=\<^sub>AnewActive C(el));;Stl)#EcL);
       fields P C=field_list; params P C=param_list;
       \<gamma>\<notin>dom Activities;
       length param_list = length el;   length param_list = length value_list;
       \<forall> i<length value_list . ((el!i,l_this,locs,\<sigma>,value_list!i)\<in>EvalExpr \<and> serialize (value_list!i) \<sigma> \<sigma>\<^sub>0) ;
        l\<notin>dom \<sigma>\<^sub>0;
       \<sigma>'=\<sigma>\<^sub>0(l\<mapsto> Obj (  (map_of (zip field_list (replicate (length field_list) null)))
                    ++ (map_of (zip param_list value_list)), C ))
     \<rbrakk>
        \<Longrightarrow> P\<turnstile>Cn Activities Futures
             \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((l_this,locs,(x=\<^sub>AExpr (Val (ActRef \<gamma>)));;Stl)#EcL))) Rq))
                             (\<gamma>\<mapsto> (AO l \<sigma>' empty [])))  Futures" |
       (* new term to evaluate is artificially complex because obj ref has to be encapsulated in a value and an expression*)

   InvkActive  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       Activities \<beta> = Some (AO l\<^sub>\<beta> \<sigma>\<^sub>\<beta> tasks\<^sub>\<beta> Rq\<^sub>\<beta>);
       tasks Q = Some ((l_this,locs,x=\<^sub>A(e.\<^sub>Am(el));;Stl)#EcL);
       \<alpha>\<noteq>\<beta>;
       (e,lt,locs,\<sigma>,ActRef \<beta>)\<in>EvalExpr;
       f\<notin>dom Futures;      l\<notin>dom \<sigma>;
       length value_list = length el;
       \<forall> i<length value_list . ((el!i,l_this,locs,\<sigma>,value_list!i)\<in>EvalExpr) ;
       serialize_and_rename_list \<sigma>\<^sub>\<beta> value_list \<sigma> value_list' \<sigma>\<^sub>P;
        \<sigma>'=\<sigma>\<^sub>\<beta> ++ \<sigma>\<^sub>P
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> (\<sigma>(l\<mapsto>FutRef f)) (tasks(Q\<mapsto>((l_this,locs,x=\<^sub>AExpr (Val (ObjRef l));;Stl)#EcL))) Rq)
                             (\<beta>\<mapsto> AO l\<^sub>\<beta> \<sigma>' tasks\<^sub>\<beta> (Rq\<^sub>\<beta>@[(f,m,value_list')]) )) (Futures(f\<mapsto>Undefined))" |

   InvkActive_Self  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,x=\<^sub>A(e.\<^sub>Am(el));;Stl)#EcL);
       (e,l_this,locs,\<sigma>,ActRef \<alpha>)\<in>EvalExpr;
       f\<notin>dom Futures;
       length value_list = length el;
       \<forall> i<length value_list . ((el!i,l_this,locs,\<sigma>,value_list!i)\<in>EvalExpr) ;
       serialize_and_rename_list \<sigma> value_list \<sigma> value_list' \<sigma>\<^sub>P;
       \<sigma>'=\<sigma> ++ \<sigma>\<^sub>P; l\<notin>dom \<sigma>'
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> (\<sigma>'(l\<mapsto>FutRef f)) (tasks(Q\<mapsto>((l_this,locs,x=\<^sub>AExpr (Val (ObjRef l));;Stl)#EcL))) (Rq@[(f,m,value_list')])))
               (Futures(f\<mapsto>Undefined))" |

   InvkPassive  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(x=\<^sub>Ae.\<^sub>Am(el));;Stl) #EcL);
       (e,l_this,locs,\<sigma>,ObjRef l)\<in>EvalExpr;
         (\<sigma> l) = Some (Obj (obj,C));
       length vl = length el; \<forall> i<length vl . ((el!i,l_this,locs,\<sigma>,vl!i)\<in>EvalExpr) ;
        Bind P l C m vl = Some EC
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>(EC#(l_this,locs,x=\<^sub>AHole;;Stl)#EcL))) Rq) ) Futures" |

   ReturnLocal  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this',locs',return e;;Stl)#(l_this,locs,x=\<^sub>AHole#Stl')#EcL);
       (e,l_this',locs,\<sigma>,v)\<in>EvalExpr
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma>
                             (tasks(Q\<mapsto>((l_this,locs,x=\<^sub>AExpr (Val v)#Stl')#EcL))) Rq) ) Futures" |

   ReturnRequest [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some [(l_this,locs,return e;;Stl)];   Q=(f,m,vl);
       (e,l_this,locs,\<sigma>,v)\<in>EvalExpr;  serialize v \<sigma> \<sigma>\<^sub>f
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma> (tasks|``Q) Rq) ) (Futures(f\<mapsto>FutVal v \<sigma>\<^sub>f))" |

    UpdateFuture [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       \<sigma> l = Some (FutRef f);  Futures f = Some (FutVal v \<sigma>\<^sub>f);
       rename_value_store \<sigma> v \<sigma>\<^sub>f v' \<sigma>\<^sub>r;
       \<sigma>'=(\<sigma>++\<sigma>\<^sub>r)(l\<mapsto>StoredVal v')
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma>' tasks Rq)) Futures"   |

    IfThenElseTrue [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(IF e THEN s\<^sub>t ELSE s\<^sub>e);;Stl)#EcL);
       (e,l_this,locs,\<sigma>,ASPBool True)\<in>EvalExpr
   \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((l_this,locs,s\<^sub>t@Stl)#EcL))) Rq))) Futures"  |

    IfThenElseFalse [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(IF e THEN s\<^sub>t ELSE s\<^sub>e);;Stl)#EcL);
       (e,l_this,locs,\<sigma>,ASPBool False)\<in>EvalExpr
   \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((l_this,locs,s\<^sub>e@Stl)#EcL))) Rq))) Futures"

 (*   Skip [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((locs,S)#EcL);RedContext S = R[[Skip]];R\<noteq>Skip;
       Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((locs,R)#EcL))) Rq))
   \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures"
   *)
(*     upd  [simp, intro!]: "l : dom f \<Longrightarrow>\<leadsto>
                         Upd (Obj f T) l a \<rightarrow>\<^sub>\<beta>  Obj (f (l \<mapsto> a)) T" |
    sel  [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Call s l u \<rightarrow>\<^sub>\<beta>  Call t l u" |
    selR [simp, intro!]: "u \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Call s l u \<rightarrow>\<^sub>\<beta>  Call s l t" |
    updL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Upd s l u \<rightarrow>\<^sub>\<beta> Upd t l u" |
    updR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Upd u l s \<rightarrow>\<^sub>\<beta> Upd u l t" |
    obj [simp, intro!]: "\<lbrakk> s \<rightarrow>\<^sub>\<beta> t; l: dom f \<rbrakk> \<Longrightarrow> Obj (f (l \<mapsto> s)) T \<rightarrow>\<^sub>\<beta> Obj (f (l \<mapsto> t)) T" |
  act [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Active s \<rightarrow>\<^sub>\<beta> Active t"
abbreviation
  beta_reds :: "[dB, dB] => bool"  (infixl "->>" 50) where
  "s ->> t == beta^** s t"

notation (latex)
  beta_reds  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50)
*)

definition emptyObj :: Storable where
"emptyObj \<equiv> Obj (empty,''EmptyObjectClass'')"

definition emptyObjClass  where
"emptyObjClass \<equiv>
\<lparr>Name = ''EmptyObjectClass'',
 Interfaces=[],
 ClassParameters=[],
 StateVariables=[],
 Methods=[]
\<rparr>"

definition BuildInitialConfigurationfromVarsStl:: "(VarName list) \<Rightarrow>Statement list\<Rightarrow> Configuration"
where
  "BuildInitialConfigurationfromVarsStl vl stl \<equiv> Cn (empty(0\<mapsto>(AO 0 (empty(0\<mapsto> emptyObj))
                  (empty((0,''m'',[])\<mapsto>[(0,(map_of (zip vl (replicate (length vl) null))),stl)])) [])))
                  (empty(0\<mapsto>Undefined))"

definition InitialConfiguration:: "Program \<Rightarrow>Configuration"
where
" InitialConfiguration prog \<equiv> case prog of (Prog Is CL Vars Stl) \<Rightarrow> BuildInitialConfigurationfromVarsStl (map snd Vars) Stl"

end


(*  Title:      HOL/Auth/n_german_lemma_inv__2_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__2_on_rules imports n_german_lemma_on_inv__2
begin
section{*All lemmas on causal relation between inv__2*}
lemma lemma_inv__2_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__2  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__2) 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__2) 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__2) 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__2) 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__2) 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__2) 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__2) 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__2) 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__2) 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__2) 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__2) 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__2) 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__2) 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__2) done
    }

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

end


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

theory WordSetup (* part of non-AFP Word_Lib *)
imports
  Word_Lemmas_32_Internal
  Distinct_Prop
begin

(* Distinct_Prop lemmas that need word lemmas: *)

lemma distinct_prop_enum:
  "\<lbrakk> \<And>x y. \<lbrakk> x \<le> stop; y \<le> stop; x \<noteq> y \<rbrakk> \<Longrightarrow> P x y \<rbrakk>
     \<Longrightarrow> distinct_prop P [0 :: 'a :: len word .e. stop]"
  apply (simp add: upto_enum_def distinct_prop_map del: upt.simps)
  apply (rule distinct_prop_distinct)
   apply simp
  apply (simp add: less_Suc_eq_le del: upt.simps)
  apply (erule_tac x="of_nat x" in meta_allE)
  apply (erule_tac x="of_nat y" in meta_allE)
  apply (frule_tac y=x in unat_le)
  apply (frule_tac y=y in unat_le)
  apply (erule word_unat.Rep_cases)+
  apply (simp add: toEnum_of_nat[OF unat_lt2p]
                   word_le_nat_alt)
  done

lemma distinct_prop_enum_step:
  "\<lbrakk> \<And>x y. \<lbrakk> x \<le> stop div step; y \<le> stop div step; x \<noteq> y \<rbrakk> \<Longrightarrow> P (x * step) (y * step) \<rbrakk>
     \<Longrightarrow> distinct_prop P [0, step .e. stop]"
  apply (simp add: upto_enum_step_def distinct_prop_map)
  apply (rule distinct_prop_enum)
  apply simp
  done

end