(*  Title:      HOL/Auth/n_germanSimp_lemma_inv__56_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__56_on_rules imports n_germanSimp_lemma_on_inv__56
begin
section{*All lemmas on causal relation between inv__56*}
lemma lemma_inv__56_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__56  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__56) 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__56) 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__56) 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__56) 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__56) 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__56) 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__56) 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__56) 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__56) 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__56) 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__56) 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__56) done
    }

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

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_inv__58_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__58_on_rules imports n_germanSimp_lemma_on_inv__58
begin
section{*All lemmas on causal relation between inv__58*}
lemma lemma_inv__58_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__58  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__58) 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__58) 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__58) 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__58) 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__58) 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__58) 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__58) 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__58) 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__58) 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__58) 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__58) 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__58) done
    }

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

end


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

theory n_g2kAbsAfter_lemma_inv__35_on_rules imports n_g2kAbsAfter_lemma_on_inv__35
begin
section{*All lemmas on causal relation between inv__35*}
lemma lemma_inv__35_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__35  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__35) done
    }

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

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__35) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__35) done
    }

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

end


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

(*
The main architecture independent data types and type definitions in
the abstract model.
*)

chapter "Basic Data Structures"

theory Structures_A
imports
  "./$L4V_ARCH/Arch_Structs_A"
  "ExecSpec.MachineExports"

begin

context begin interpretation Arch .

requalify_types
  aobject_type
  arch_cap
  vm_rights
  arch_kernel_obj
  arch_state
  arch_tcb
  aa_type

requalify_consts
  acap_rights
  acap_rights_update
  arch_kobj_size
  arch_obj_size
  aobj_ref
  asid_high_bits
  asid_low_bits
  arch_is_frame_type
  badge_bits
  default_arch_tcb
  arch_tcb_context_get
  arch_tcb_context_set
  arch_tcb_set_registers
  arch_tcb_get_registers
  cte_level_bits
  tcb_bits
  endpoint_bits
  ntfn_bits
  aa_type
  untyped_min_bits
  untyped_max_bits
  msg_label_bits
end

text \<open>
  User mode can request these objects to be created by retype:
\<close>
datatype apiobject_type =
    Untyped
  | TCBObject
  | EndpointObject
  | NotificationObject
  | CapTableObject
  | ArchObject aobject_type

definition
  is_frame_type :: "apiobject_type \<Rightarrow> bool"
where
  "is_frame_type obj \<equiv> case obj of
        ArchObject aobj \<Rightarrow> arch_is_frame_type aobj
      | _ \<Rightarrow> False"

text \<open>These allow more informative type signatures for IPC operations.\<close>
type_synonym badge = data
type_synonym msg_label = data
type_synonym message = data

text \<open>This type models refences to capability slots. The first element
  of the tuple points to the object the capability is contained in. The second
  element is the index of the slot inside a slot-containing object. The default
  slot-containing object is a cnode, thus the name @{text cnode_index}.
\<close>
type_synonym cnode_index = "bool list"
type_synonym cslot_ptr = "obj_ref \<times> cnode_index"

text \<open>Capabilities. Capabilities represent explicit authority to perform some
action and are required for all system calls. Capabilities to Endpoint,
Notification, Thread and CNode objects allow manipulation of standard kernel
objects. Untyped capabilities allow the creation and removal of kernel objects
from a memory region. Reply capabilities allow sending a one-off message to
a thread waiting for a reply. IRQHandler and IRQControl caps allow a user to
configure the way interrupts on one or all IRQs are handled. Capabilities to
architecture-specific facilities are provided through the @{text arch_cap} type.
Null capabilities are the contents of empty capability slots; they confer no
authority and can be freely replaced. Zombie capabilities are stored when
the deletion of CNode and Thread objects is partially completed; they confer no
authority but cannot be replaced until the deletion is finished.
\<close>

datatype cap
         = NullCap
         | UntypedCap bool obj_ref nat nat
           \<comment> \<open>device flag, pointer, size in bits (i.e. @{text "size = 2^bits"}) and freeIndex (i.e. @{text "freeRef = obj_ref + (freeIndex * 2^4)"})\<close>
         | EndpointCap obj_ref badge cap_rights
         | NotificationCap obj_ref badge cap_rights
         | ReplyCap obj_ref bool cap_rights
         | CNodeCap obj_ref nat "bool list"
           \<comment> \<open>CNode ptr, number of bits translated, guard\<close>
         | ThreadCap obj_ref
         | DomainCap
         | IRQControlCap
         | IRQHandlerCap irq
         | Zombie obj_ref "nat option" nat
           \<comment> \<open>@{text "cnode ptr * nat + tcb or cspace ptr"}\<close>
         | ArchObjectCap (the_arch_cap: arch_cap)

lemmas cap_cases =
  cap.induct[where cap=cap and P="\<lambda>cap'. cap' = cap \<longrightarrow> P cap'" for cap P, simplified, rule_format]

lemmas cap_cases_asm =
cap.induct[where cap=cap and P="\<lambda>cap'. cap = cap' \<longrightarrow> P cap' \<longrightarrow> R" for P R cap,
  simplified, rule_format, rotated -1]

text \<open>The CNode object is an array of capability slots. The domain of the
function will always be the set of boolean lists of some specific length.
Empty slots contain a Null capability.
\<close>
type_synonym cnode_contents = "cnode_index \<Rightarrow> cap option"

text \<open>Various access functions for the cap type are defined for
convenience.\<close>
definition
  the_cnode_cap :: "cap \<Rightarrow> obj_ref \<times> nat \<times> bool list" where
  "the_cnode_cap cap \<equiv>
  case cap of
    CNodeCap oref bits guard \<Rightarrow> (oref, bits, guard)"

definition
  the_arch_cap :: "cap \<Rightarrow> arch_cap" where
  "the_arch_cap cap \<equiv> case cap of ArchObjectCap a \<Rightarrow> a"

primrec (nonexhaustive)
  cap_ep_badge :: "cap \<Rightarrow> badge"
where
  "cap_ep_badge (EndpointCap _ badge _) = badge"
| "cap_ep_badge (NotificationCap _ badge _) = badge"

primrec (nonexhaustive)
  cap_ep_ptr :: "cap \<Rightarrow> badge"
where
  "cap_ep_ptr (EndpointCap obj_ref _ _) = obj_ref"
| "cap_ep_ptr (NotificationCap obj_ref _ _) = obj_ref"

definition
  bits_of :: "cap \<Rightarrow> nat" where
  "bits_of cap \<equiv> case cap of
    UntypedCap _ _ bits _ \<Rightarrow> bits
  | CNodeCap _ radix_bits _ \<Rightarrow> radix_bits"

definition
  free_index_of :: "cap \<Rightarrow> nat" where
  "free_index_of cap \<equiv> case cap of
    UntypedCap _ _ _ free_index \<Rightarrow> free_index"

definition
  is_reply_cap :: "cap \<Rightarrow> bool" where
  "is_reply_cap cap \<equiv> case cap of ReplyCap _ m _ \<Rightarrow> \<not> m | _ \<Rightarrow> False"
definition
  is_master_reply_cap :: "cap \<Rightarrow> bool" where
  "is_master_reply_cap cap \<equiv> case cap of ReplyCap _ m _ \<Rightarrow> m | _ \<Rightarrow> False"
definition
  is_zombie :: "cap \<Rightarrow> bool" where
  "is_zombie cap \<equiv> case cap of Zombie _ _ _ \<Rightarrow> True | _ \<Rightarrow> False"
definition
  is_arch_cap :: "cap \<Rightarrow> bool" where
  "is_arch_cap cap \<equiv> case cap of ArchObjectCap _ \<Rightarrow> True | _ \<Rightarrow> False"

context
notes [[function_internals =true]]
begin

fun is_cnode_cap :: "cap \<Rightarrow> bool"
where
  "is_cnode_cap (CNodeCap _ _ _) = True"
| "is_cnode_cap _                = False"

fun is_thread_cap :: "cap \<Rightarrow> bool"
where
  "is_thread_cap (ThreadCap _) = True"
| "is_thread_cap _             = False"

fun is_domain_cap :: "cap \<Rightarrow> bool"
where
  "is_domain_cap DomainCap = True"
| "is_domain_cap _ = False"

fun is_untyped_cap :: "cap \<Rightarrow> bool"
where
  "is_untyped_cap (UntypedCap _ _ _ _) = True"
| "is_untyped_cap _                  = False"

fun is_ep_cap :: "cap \<Rightarrow> bool"
where
  "is_ep_cap (EndpointCap _ _ _) = True"
| "is_ep_cap _                   = False"

fun is_ntfn_cap :: "cap \<Rightarrow> bool"
where
  "is_ntfn_cap (NotificationCap _ _ _) = True"
| "is_ntfn_cap _                        = False"

primrec (nonexhaustive)
  cap_rights :: "cap \<Rightarrow> cap_rights"
where
  "cap_rights (EndpointCap _ _ cr) = cr"
| "cap_rights (NotificationCap _ _ cr) = cr"
| "cap_rights (ReplyCap _ _ cr) = cr"
| "cap_rights (ArchObjectCap acap) = acap_rights acap"
end

text \<open>Various update functions for cap data common to various kinds of
cap are defined here.\<close>
definition
  cap_rights_update :: "cap_rights \<Rightarrow> cap \<Rightarrow> cap" where
  "cap_rights_update cr' cap \<equiv>
   case cap of
     EndpointCap oref badge cr \<Rightarrow> EndpointCap oref badge cr'
   | NotificationCap oref badge cr
     \<Rightarrow> NotificationCap oref badge (cr' - {AllowGrant, AllowGrantReply})
   | ReplyCap t m cr \<Rightarrow> ReplyCap t m (cr' - {AllowRead, AllowGrantReply} \<union> {AllowWrite})
   | ArchObjectCap acap \<Rightarrow> ArchObjectCap (acap_rights_update cr' acap)
   | _ \<Rightarrow> cap"

definition
  badge_update :: "badge \<Rightarrow> cap \<Rightarrow> cap" where
  "badge_update data cap \<equiv>
   case cap of
     EndpointCap oref badge cr \<Rightarrow> EndpointCap oref (data && mask badge_bits) cr
   | NotificationCap oref badge cr \<Rightarrow> NotificationCap oref (data && mask badge_bits) cr
   | _ \<Rightarrow> cap"

definition
  mask_cap :: "cap_rights \<Rightarrow> cap \<Rightarrow> cap" where
  "mask_cap rights cap \<equiv> cap_rights_update (cap_rights cap \<inter> rights) cap"

section \<open>Message Info\<close>

text \<open>The message info is the first thing interpreted on a user system call
and determines the structure of the message the user thread is sending either to
another user or to a system service. It is also passed to user threads receiving
a message to indicate the structure of the message they have received. The
@{text mi_length} parameter is the number of data words in the body of the
message. The @{text mi_extra_caps} parameter is the number of caps to be passed
together with the message. The @{text mi_caps_unwrapped} parameter is a bitmask
allowing threads receiving a message to determine how extra capabilities were
transferred. The @{text mi_label} parameter is transferred directly from sender
to receiver as part of the message.
\<close>

datatype message_info =
  MI (mi_length: length_type)
     (mi_extra_caps: length_type)
     (mi_caps_unwrapped: data)
     (mi_label: msg_label)

text \<open>Message infos are encoded to or decoded from a data word.\<close>
primrec
  message_info_to_data :: "message_info \<Rightarrow> data"
where
  "message_info_to_data (MI len exc unw mlabel) =
   (let
        extra = exc << 7;
        unwrapped = unw << 9;
        label = mlabel << 12
    in
       label || extra || unwrapped || len)"

definition
  data_to_message_info :: "data \<Rightarrow> message_info"
where
  "data_to_message_info w \<equiv>
   MI (let v = w && mask 7 in if v > 120 then 120 else v)
      ((w >> 7) && mask 2)
      ((w >> 9) && mask 3)
      ((w >> 12) && mask msg_label_bits)"

section \<open>Kernel Objects\<close>

text \<open>Endpoints are synchronous points of communication for threads. At any
time an endpoint may contain a queue of threads waiting to send, a queue of
threads waiting to receive or be idle. Whenever threads would be waiting to
send and receive simultaneously messages are transferred immediately.
\<close>

datatype endpoint
           = IdleEP
           | SendEP "obj_ref list"
           | RecvEP "obj_ref list"

text \<open>Notifications are sets of binary semaphores (stored in the
\emph{badge word}). Unlike endpoints, threads may choose to block waiting to
receive, but not to send.\<close>

datatype ntfn
           = IdleNtfn
           | WaitingNtfn "obj_ref list"
           | ActiveNtfn badge

record notification =
  ntfn_obj :: ntfn
  ntfn_bound_tcb :: "obj_ref option"

definition
  default_ep :: endpoint where
  "default_ep \<equiv> IdleEP"

definition
  default_ntfn :: ntfn where
  "default_ntfn \<equiv> IdleNtfn"

definition
  default_notification :: notification where
  "default_notification \<equiv> \<lparr>
     ntfn_obj = default_ntfn,
     ntfn_bound_tcb = None \<rparr>"

text \<open>Thread Control Blocks are the in-kernel representation of a thread.

Threads which can execute are either in the Running state for normal execution,
in the Restart state if their last operation has not completed yet or in the
IdleThreadState for the unique system idle thread. Threads can also be blocked
waiting for any of the different kinds of system messages. The Inactive state
indicates that the TCB is not currently used by a running thread.

TCBs also contain some special-purpose capability slots. The CTable slot is a
capability to a CNode through which the thread accesses capabilities with which
to perform system calls. The VTable slot is a capability to a virtual address
space (an architecture-specific capability type) in which the thread runs. If
the thread has issued a Reply cap to another thread and is awaiting a reply,
that cap will have a "master" Reply cap as its parent in the Reply slot. The
Caller slot is used to initially store any Reply cap issued to this thread. The
IPCFrame slot stores a capability to a memory frame (an architecture-specific
capability type) through which messages will be sent and received.

If the thread has encountered a fault and is waiting to send it to its
supervisor the fault is stored in @{text tcb_fault}. The user register file is
stored in @{text tcb_context}, the pointer to the cap in the IPCFrame slot in
@{text tcb_ipc_buffer} and the identity of the Endpoint cap through which faults
are to be sent in @{text tcb_fault_handler}.
\<close>

record sender_payload =
 sender_badge           :: badge
 sender_can_grant       :: bool
 sender_can_grant_reply :: bool
 sender_is_call         :: bool

record receiver_payload =
 receiver_can_grant :: bool

datatype thread_state
  = Running
  | Inactive
  | Restart
  | BlockedOnReceive obj_ref receiver_payload
  | BlockedOnSend obj_ref sender_payload
  | BlockedOnReply
  | BlockedOnNotification obj_ref
  | IdleThreadState

type_synonym priority = word8

record tcb =
 tcb_ctable        :: cap
 tcb_vtable        :: cap
 tcb_reply         :: cap
 tcb_caller        :: cap
 tcb_ipcframe      :: cap
 tcb_state         :: thread_state
 tcb_fault_handler :: cap_ref
 tcb_ipc_buffer    :: vspace_ref
 tcb_fault         :: "fault option"
 tcb_bound_notification     :: "obj_ref option"
 tcb_mcpriority    :: priority
 tcb_arch          :: arch_tcb (* arch_tcb must have a field for user context *)

text \<open>Determines whether a thread in a given state may be scheduled.\<close>
primrec
  runnable :: "Structures_A.thread_state \<Rightarrow> bool"
where
  "runnable (Running)               = True"
| "runnable (Inactive)              = False"
| "runnable (Restart)               = True"
| "runnable (BlockedOnReceive x y)  = False"
| "runnable (BlockedOnSend x y)     = False"
| "runnable (BlockedOnNotification x) = False"
| "runnable (IdleThreadState)       = False"
| "runnable (BlockedOnReply)        = False"

definition
  default_tcb :: tcb where
  "default_tcb \<equiv> \<lparr>
      tcb_ctable   = NullCap,
      tcb_vtable   = NullCap,
      tcb_reply    = NullCap,
      tcb_caller   = NullCap,
      tcb_ipcframe = NullCap,
      tcb_state    = Inactive,
      tcb_fault_handler = to_bl (0::machine_word),
      tcb_ipc_buffer = 0,
      tcb_fault      = None,
      tcb_bound_notification  = None,
      tcb_mcpriority = minBound,
      tcb_arch       = default_arch_tcb\<rparr>"

text \<open>
All kernel objects are CNodes, TCBs, Endpoints, Notifications or architecture
specific.
\<close>
datatype kernel_object
         = CNode nat cnode_contents \<comment> \<open>size in bits, and contents\<close>
         | TCB tcb
         | Endpoint endpoint
         | Notification notification
         | ArchObj (the_arch_obj: arch_kernel_obj)

lemmas kernel_object_cases =
  kernel_object.induct[where kernel_object=x and P="\<lambda>x'. x = x' \<longrightarrow> P x'" for x P, simplified, rule_format]

lemmas kernel_object_cases_asm =
kernel_object.induct[where kernel_object=x and P="\<lambda>x'. x = x' \<longrightarrow> P x' \<longrightarrow> R" for P R x,
  simplified, rule_format, rotated -1]

definition aobj_of :: "kernel_object \<Rightarrow> arch_kernel_obj option"
  where
  "aobj_of ko \<equiv> case ko of ArchObj aobj \<Rightarrow> Some aobj | _ \<Rightarrow> None"

text \<open>Checks whether a cnode's contents are well-formed.\<close>

definition
  well_formed_cnode_n :: "nat \<Rightarrow> cnode_contents \<Rightarrow> bool" where
 "well_formed_cnode_n n \<equiv> \<lambda>cs. dom cs = {x. length x = n}"

primrec
  obj_bits :: "kernel_object \<Rightarrow> nat"
where
  "obj_bits (CNode sz cs) = cte_level_bits + sz"
| "obj_bits (TCB t) = tcb_bits"
| "obj_bits (Endpoint ep) = endpoint_bits"
| "obj_bits (Notification ntfn) = ntfn_bits"
| "obj_bits (ArchObj ao) = arch_kobj_size ao"

primrec (nonexhaustive)
  obj_size :: "cap \<Rightarrow> machine_word"
where
  "obj_size NullCap = 0"
| "obj_size (UntypedCap dev r bits f) = 1 << bits"
| "obj_size (EndpointCap r b R) = 1 << obj_bits (Endpoint undefined)"
| "obj_size (NotificationCap r b R) = 1 << obj_bits (Notification undefined)"
| "obj_size (CNodeCap r bits g) = 1 << (cte_level_bits + bits)"
| "obj_size (ThreadCap r) = 1 << obj_bits (TCB undefined)"
| "obj_size (Zombie r zb n) = (case zb of None \<Rightarrow> 1 << obj_bits (TCB undefined)
                                        | Some n \<Rightarrow> 1 << (cte_level_bits + n))"
| "obj_size (ArchObjectCap a) = 1 << arch_obj_size a"

text \<open>Object types:\<close>

datatype a_type =
    ATCB
  | AEndpoint
  | ANTFN
  | ACapTable nat
  | AGarbage nat \<comment> \<open>number of bytes of garbage\<close>
  | AArch aa_type

definition
  a_type :: "kernel_object \<Rightarrow> a_type"
where
 "a_type ob \<equiv> case ob of
           CNode sz cspace           \<Rightarrow> if well_formed_cnode_n sz cspace
                                        then ACapTable sz else AGarbage (cte_level_bits + sz)
         | TCB tcb                   \<Rightarrow> ATCB
         | Endpoint endpoint         \<Rightarrow> AEndpoint
         | Notification notification \<Rightarrow> ANTFN
         | ArchObj ao                \<Rightarrow> AArch (aa_type ao)"

section \<open>Kernel State\<close>

text \<open>The kernel's heap is a partial function containing kernel objects.\<close>
type_synonym kheap = "obj_ref \<Rightarrow> kernel_object option"

text \<open>
Capabilities are created either by cloning an existing capability or by creating
a subordinate capability from it. This results in a capability derivation tree
or CDT. The kernel provides a Revoke operation which deletes all capabilities
derived from one particular capability. To support this, the kernel stores the
CDT explicitly. It is here stored as a tree, a partial mapping from
capability slots to parent capability slots.
\<close>
type_synonym cdt = "cslot_ptr \<Rightarrow> cslot_ptr option"

datatype irq_state =
   IRQInactive
 | IRQSignal
 | IRQTimer
 | IRQReserved

text \<open>The kernel state includes a heap, a capability derivation tree
(CDT), a bitmap used to determine if a capability is the original
capability to that object, a pointer to the current thread, a pointer
to the system idle thread, the state of the underlying machine,
per-irq pointers to cnodes (each containing one notification through which
interrupts are delivered), an array recording which
interrupts are used for which purpose, and the state of the
architecture-specific kernel module.

Note: for each irq, @{text "interrupt_irq_node irq"} points to a cnode which
can contain the notification cap through which interrupts are delivered. In
C, this all lives in a single array. In the abstract spec though, to prove
security, we can't have a single object accessible by everyone. Hence the need
to separate irq handlers.
\<close>
record abstract_state =
  kheap              :: kheap
  cdt                :: cdt
  is_original_cap    :: "cslot_ptr \<Rightarrow> bool"
  cur_thread         :: obj_ref
  idle_thread        :: obj_ref
  machine_state      :: machine_state
  interrupt_irq_node :: "irq \<Rightarrow> obj_ref"
  interrupt_states   :: "irq \<Rightarrow> irq_state"
  arch_state         :: arch_state

text \<open>The following record extends the abstract kernel state with extra
state of type @{typ "'a"}. The specification operates over states of
this extended type. By choosing an appropriate concrete type for @{typ "'a"}
we may obtain different \emph{instantiations} of the kernel specifications
at differing levels of abstraction. See \autoref{c:ext-spec} for further
information.
\<close>
record 'a state = abstract_state + exst :: 'a

section \<open>Helper functions\<close>

text \<open>This wrapper lifts monadic operations on the underlying machine state to
monadic operations on the kernel state.\<close>
definition
  do_machine_op :: "(machine_state, 'a) nondet_monad \<Rightarrow> ('z state, 'a) nondet_monad"
where
 "do_machine_op mop \<equiv> do
    ms \<leftarrow> gets machine_state;
    (r, ms') \<leftarrow> select_f (mop ms);
    modify (\<lambda>state. state \<lparr> machine_state := ms' \<rparr>);
    return r
  od"

text \<open>This function generates the cnode indices used when addressing the
capability slots within a TCB.
\<close>
definition
  tcb_cnode_index :: "nat \<Rightarrow> cnode_index" where
  "tcb_cnode_index n \<equiv> to_bl (of_nat n :: 3 word)"

text \<open>Zombie capabilities store the bit size of the CNode cap they were
created from or None if they were created from a TCB cap. This function
decodes the bit-length of cnode indices into the relevant kernel objects.
\<close>
definition
  zombie_cte_bits :: "nat option \<Rightarrow> nat" where
 "zombie_cte_bits N \<equiv> case N of Some n \<Rightarrow> n | None \<Rightarrow> 3"

lemma zombie_cte_bits_simps[simp]:
 "zombie_cte_bits (Some n) = n"
 "zombie_cte_bits None     = 3"
  by (simp add: zombie_cte_bits_def)+

text \<open>The first capability slot of the relevant kernel object.\<close>
primrec (nonexhaustive)
  first_cslot_of :: "cap \<Rightarrow> cslot_ptr"
where
  "first_cslot_of (ThreadCap oref) = (oref, tcb_cnode_index 0)"
| "first_cslot_of (CNodeCap oref bits g) = (oref, replicate bits False)"
| "first_cslot_of (Zombie oref bits n) = (oref, replicate (zombie_cte_bits bits) False)"

text \<open>The set of all objects referenced by a capability.\<close>
primrec
  obj_refs :: "cap \<Rightarrow> obj_ref set"
where
  "obj_refs NullCap = {}"
| "obj_refs (ReplyCap r m cr) = {}"
| "obj_refs IRQControlCap = {}"
| "obj_refs (IRQHandlerCap irq) = {}"
| "obj_refs (UntypedCap dev r s f) = {}"
| "obj_refs (CNodeCap r bits guard) = {r}"
| "obj_refs (EndpointCap r b cr) = {r}"
| "obj_refs (NotificationCap r b cr) = {r}"
| "obj_refs (ThreadCap r) = {r}"
| "obj_refs DomainCap = {}"
| "obj_refs (Zombie ptr b n) = {ptr}"
| "obj_refs (ArchObjectCap x) = set_option (aobj_ref x)"

text \<open>
  The partial definition below is sometimes easier to work with.
  It also provides cases for UntypedCap and ReplyCap which are not
  true object references in the sense of the other caps.
\<close>
primrec (nonexhaustive)
  obj_ref_of :: "cap \<Rightarrow> obj_ref"
where
  "obj_ref_of (UntypedCap dev r s f) = r"
| "obj_ref_of (ReplyCap r m cr) = r"
| "obj_ref_of (CNodeCap r bits guard) = r"
| "obj_ref_of (EndpointCap r b cr) = r"
| "obj_ref_of (NotificationCap r b cr) = r"
| "obj_ref_of (ThreadCap r) = r"
| "obj_ref_of (Zombie ptr b n) = ptr"
| "obj_ref_of (ArchObjectCap x) = the (aobj_ref x)"

primrec (nonexhaustive)
  cap_bits_untyped :: "cap \<Rightarrow> nat"
where
  "cap_bits_untyped (UntypedCap dev r s f) = s"

definition tcb_cnode_map :: "tcb \<Rightarrow> cnode_index \<Rightarrow> cap option"
  where
  "tcb_cnode_map tcb \<equiv>
   [tcb_cnode_index 0 \<mapsto> tcb_ctable tcb,
    tcb_cnode_index 1 \<mapsto> tcb_vtable tcb,
    tcb_cnode_index 2 \<mapsto> tcb_reply tcb,
    tcb_cnode_index 3 \<mapsto> tcb_caller tcb,
    tcb_cnode_index 4 \<mapsto> tcb_ipcframe tcb]"

definition cap_of :: "kernel_object \<Rightarrow> cnode_index \<Rightarrow> cap option"
  where
  "cap_of kobj \<equiv> case kobj of CNode _ cs \<Rightarrow> cs | TCB tcb \<Rightarrow> tcb_cnode_map tcb | _ \<Rightarrow> Map.empty"

text \<open>The set of all caps contained in a kernel object.\<close>

definition
  caps_of :: "kernel_object \<Rightarrow> cap set" where
  "caps_of kobj \<equiv> ran (cap_of kobj)"

section "Cap transfers"

record captransfer =
  ct_receive_root :: cap_ref
  ct_receive_index :: cap_ref
  ct_receive_depth :: data

text \<open>A thread's IPC buffer capability must be to a page that is capable of
containing the IPC buffer without the end of the buffer spilling into another
page.\<close>
definition cap_transfer_data_size :: nat
  where
  "cap_transfer_data_size \<equiv> 3"

definition msg_max_length :: nat
  where
  "msg_max_length \<equiv> 120"

definition msg_max_extra_caps :: nat
  where
  "msg_max_extra_caps \<equiv> 3"

definition max_ipc_length :: nat
  where
  "max_ipc_length \<equiv> cap_transfer_data_size + msg_max_length + msg_max_extra_caps + 2"

definition msg_align_bits :: nat
  where
  "msg_align_bits \<equiv> word_size_bits + (LEAST n. max_ipc_length \<le> 2 ^ n)"

lemma msg_align_bits':
  "msg_align_bits = word_size_bits + 7"
proof -
  have "(LEAST n. (cap_transfer_data_size + msg_max_length + msg_max_extra_caps + 2) \<le> 2 ^ n) = 7"
  proof (rule Least_equality)
    show "(cap_transfer_data_size + msg_max_length + msg_max_extra_caps + 2)  \<le> 2 ^ 7"
      by (simp add: cap_transfer_data_size_def msg_max_length_def msg_max_extra_caps_def)
  next
    fix y
    assume "(cap_transfer_data_size + msg_max_length + msg_max_extra_caps + 2) \<le> 2 ^ y"
    hence "(2 :: nat) ^ 7 \<le> 2 ^ y"
      by (simp add: cap_transfer_data_size_def msg_max_length_def msg_max_extra_caps_def)
    thus "7 \<le> y"
      by (rule power_le_imp_le_exp [rotated], simp)
  qed
  thus ?thesis unfolding msg_align_bits_def max_ipc_length_def by simp
qed

end


theory DriverProof
  imports Main "HOL-Word.Word" "Word_Lib.Word_Lib" "DriverSpec"
 "generated/Driver_Shallow_Desugar"
begin

(* 12:55  *)
fun curry_triple :: "(('a, 'b, 'c) TimeoutInput \<Rightarrow> 'z) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'z)" where
  "curry_triple f a b c = f (\<lparr> TimeoutInput.p1\<^sub>f = a, p2\<^sub>f = b, p3\<^sub>f = c \<rparr>)"

type_synonym concr_device_state = "Meson_timer_reg\<^sub>T"
type_synonym concr_state = "Meson_timer\<^sub>T"

definition concr_driver :: "(concr_state, 64 word, 16 word, bool) driver"
  where
  "concr_driver =
\<lparr>
  get_time = meson_get_time_cogent,
  initialize = meson_init_cogent,
  stop_timer = meson_stop_timer_cogent,
  set_timeout = curry_triple meson_set_timeout_cogent,
\<comment> \<open>we are going to multiply it by 1000 (\<approx> 1024 = 2^10) \<close>
    stateInv = (\<lambda>s. timer_e_hi\<^sub>f (regs\<^sub>f s) < 2^(32-10)
             \<and>  disable\<^sub>f s = Not (timer_a_en\<^sub>f (regs\<^sub>f s)) ),
iniDeviceInv = (\<lambda>s. (disable\<^sub>f s = True \<and> Not (timer_a_en\<^sub>f (regs\<^sub>f s))))

\<rparr>
"

locale concr_is_refinement =
  is_refinement concr_driver mor
  for mor :: "(concr_state, 64 word, 16 word, bool) driver_abstr"

fun \<alpha>timeout_timebase :: "Timeout_timebase\<^sub>T \<Rightarrow> DriverSpec.timeout_timebase"
  where
   "\<alpha>timeout_timebase (COGENT_TIMEOUT_TIMEBASE_100_US _) = DriverSpec.TIMEOUT_TIMEBASE_1_US"
|  "\<alpha>timeout_timebase (COGENT_TIMEOUT_TIMEBASE_10_US _)  = DriverSpec.TIMEOUT_TIMEBASE_10_US"
|  "\<alpha>timeout_timebase (COGENT_TIMEOUT_TIMEBASE_1_MS _)   = DriverSpec.TIMEOUT_TIMEBASE_1_MS"
|  "\<alpha>timeout_timebase (COGENT_TIMEOUT_TIMEBASE_1_US _)   = DriverSpec.TIMEOUT_TIMEBASE_1_US"

fun \<alpha>timestamp_timebase :: "Timestamp_timebase\<^sub>T \<Rightarrow> DriverSpec.timestamp_timebase"
  where
   "\<alpha>timestamp_timebase (COGENT_TIMESTAMP_TIMEBASE_100_US _) = DriverSpec.TIMESTAMP_TIMEBASE_100_US"
|  "\<alpha>timestamp_timebase (COGENT_TIMESTAMP_TIMEBASE_10_US _)  = DriverSpec.TIMESTAMP_TIMEBASE_10_US"
|  "\<alpha>timestamp_timebase (COGENT_TIMESTAMP_TIMEBASE_1_MS _)   = DriverSpec.TIMESTAMP_TIMEBASE_1_MS"
|  "\<alpha>timestamp_timebase (COGENT_TIMESTAMP_TIMEBASE_1_US _)   = DriverSpec.TIMESTAMP_TIMEBASE_1_US"
|  "\<alpha>timestamp_timebase (COGENT_TIMESTAMP_TIMEBASE_SYSTEM _) = DriverSpec.TIMESTAMP_TIMEBASE_SYSTEM"

definition \<alpha>_timer_mode :: "bool \<Rightarrow> timer_mode"
  where "\<alpha>_timer_mode b = (if b then Periodic else NotPeriodic)"

definition \<alpha>_reg :: "concr_device_state \<Rightarrow> device_state" where
"\<alpha>_reg ds =
    \<lparr> timer_a_mode = \<alpha>_timer_mode (timer_a_mode\<^sub>f ds) ,
     timer_a_en = timer_a_en\<^sub>f ds,
timer_a = unat (timer_a\<^sub>f ds),
timer_a_input_clk = \<alpha>timeout_timebase (timer_a_input_clk\<^sub>f ds),
timer_e_input_clk = \<alpha>timestamp_timebase (timer_e_input_clk\<^sub>f ds),
timer_e_low_hi = unat (word_cat (timer_e_hi\<^sub>f ds) (timer_e\<^sub>f ds) :: 64 word)

 \<rparr> "

definition \<alpha>_state :: "concr_state \<Rightarrow> abstr_state" where
"\<alpha>_state s =
  \<lparr>
    driverState = \<lparr> disable = disable\<^sub>f s \<rparr>,
    deviceState = \<alpha>_reg (regs\<^sub>f s)
  \<rparr>"

definition abstraction :: "(concr_state, 64 word, 16 word, bool) driver_abstr"
  where "abstraction =
  \<lparr>
   mor_state = \<alpha>_state,
   mor_time = unat,
   mor_timeout = unat,
   mor_timer_mode = \<alpha>_timer_mode
  \<rparr>"

lemmas driver_defs = concr_driver_def abs_driver_def abstraction_def
lemmas simp_defs = driver_defs \<alpha>_state_def \<alpha>_reg_def (* \<alpha>timeout_timebase_def
 \<alpha>timestamp_timebase_def *)

lemma unat_ucast_up :
 " LENGTH('a :: len0) \<le> LENGTH('b ::len0) \<Longrightarrow>
unat (UCAST('a \<rightarrow> 'b) w) = unat w"
  by (simp add: unat_def uint_up_ucast is_up)

lemma helper1 : "
((UCAST(32 \<rightarrow> 64) x << 32) || UCAST(32 \<rightarrow> 64) y)
= word_cat x y"
  by word_bitwise

lemma helper2 : "
(h :: int) < 4194304 \<Longrightarrow> l < 2^32 \<Longrightarrow> 536870912000 * h + 125 * l < 2305843009213693952
"

  apply(rule less_le_trans)
   apply(rule add_strict_mono)
    apply(erule mult_strict_left_mono)
    apply simp
   apply(erule mult_strict_left_mono)
   apply simp
  apply simp
  done

interpretation concr_implementation:
  concr_is_refinement abstraction
  apply unfold_locales
     apply (simp add:simp_defs meson_get_time_cogent_def ns_in_us_def)

     apply(case_tac s, rename_tac regs disable, case_tac regs)
     apply clarsimp
     apply(simp add:helper1)
     apply(simp add:unat_def)
     apply (subst uint_mult_lem[THEN HOL.iffD1])
      apply simp
      apply(simp add:word_cat_def )
      apply(subst word_ubin.eq_norm)

      apply simp
      apply(simp add:bintr_cat)
      apply(subst word_ubin.norm_norm(2)[THEN fun_cong, simplified comp_def, of "_ :: 32 word", simplified])
      apply(simp add:bin_cat_num)
      apply(subst word_ubin.norm_norm(2)[THEN fun_cong, simplified comp_def, of "_ :: 32 word", simplified])
      apply(simp add:word_less_alt)
      apply(erule helper2)

      apply(uint_arith, simp)
     apply simp

    apply (simp add:simp_defs meson_init_cogent_def meson_get_time_cogent_def ns_in_us_def
  reset_timer_e_def)
     apply(case_tac s, rename_tac regs disable, case_tac regs)
    apply(simp add: take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def)
     (* hmm *)
    apply clarsimp
  apply(simp add:word_cat_def)

(* yeah! *)
     apply (simp add:simp_defs meson_stop_timer_cogent_def  ns_in_us_def take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def)

    apply(simp add:simp_defs  meson_set_timeout_cogent_def  take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def Let\<^sub>d\<^sub>s_def)
     apply(simp add:unat_ucast_up)

(* invariants *)
    apply(simp add:simp_defs meson_init_cogent_def take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def Let\<^sub>d\<^sub>s_def reset_timer_e_def)
     apply(simp add:simp_defs  meson_stop_timer_cogent_def  ns_in_us_def take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def)

    apply(simp add:simp_defs meson_init_cogent_def take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def Let\<^sub>d\<^sub>s_def reset_timer_e_def)
   apply(simp add:simp_defs  meson_stop_timer_cogent_def  ns_in_us_def take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def)

  apply(simp add:simp_defs  meson_set_timeout_cogent_def  take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def Let\<^sub>d\<^sub>s_def)

  by(simp add: HOL.Let_def )

end


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

theory n_g2kAbsAfter_lemma_inv__56_on_rules imports n_g2kAbsAfter_lemma_on_inv__56
begin
section{*All lemmas on causal relation between inv__56*}
lemma lemma_inv__56_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__56  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__56) done
    }

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

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__56) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__56) done
    }

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

end


(*  Title:      HOL/Auth/n_german_lemma_inv__12_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__12_on_rules imports n_german_lemma_on_inv__12
begin
section{*All lemmas on causal relation between inv__12*}
lemma lemma_inv__12_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__12  p__Inv0 p__Inv2)"
  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__12) 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__12) 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__12) 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__12) 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__12) 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__12) 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__12) 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__12) 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__12) 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__12) 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__12) 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__12) 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__12) 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__12) done
    }

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

end


(*  Title:      HOL/Auth/n_german_lemma_inv__25_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__25_on_rules imports n_german_lemma_on_inv__25
begin
section{*All lemmas on causal relation between inv__25*}
lemma lemma_inv__25_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__25  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__25) 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__25) 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__25) 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__25) 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__25) 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__25) 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__25) 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__25) 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__25) 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__25) 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__25) 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__25) 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__25) 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__25) done
    }

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

end


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

header{*The n_g2kAbsAfter Protocol Case Study*}

theory n_g2kAbsAfter_lemma_inv__6_on_rules imports n_g2kAbsAfter_lemma_on_inv__6
begin
section{*All lemmas on causal relation between inv__6*}
lemma lemma_inv__6_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__6  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__6) done
    }

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

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__6) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__6) done
    }

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

end


theory javacap_security_static
imports
  Main
  javacap_syntax
  javacap_auxiliary
  javacap_static
  javacap_runtime_representation
  javacap_operational
begin

inductive allowed_transition :: "prog \<Rightarrow> label \<Rightarrow> State \<Rightarrow> State \<Rightarrow> bool" ("_ _ \<turnstile> \<langle>_\<rangle> \<rightarrow>\<^sub>A \<langle>_\<rangle>" 50)
  for P :: "prog"
  where
    at_reflexive: "P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S\<rangle>" |
    at_trans: "\<lbrakk> P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S1\<rangle>; P \<gamma> \<turnstile> \<langle>S1\<rangle> \<rightarrow>\<^sub>A \<langle>S2\<rangle>  \<rbrakk> \<Longrightarrow> P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S2\<rangle>" |
    at_cap_call: "\<lbrakk>  (* any state change by a type-correct call to a capability of a type in \<gamma>
                        is allowed *)
                      P M \<Gamma> \<^bold>\<turnstile> S; P M \<Gamma> \<turnstile> (calli x mname args) : T; P \<turnstile> \<langle>(calli x mname args) | S\<rangle> \<rightarrow>\<^sub>e \<langle>v | S'\<rangle>;
                       \<Gamma>\<lbrakk>x\<rbrakk>\<^sub>v = Some (tcap,\<gamma>cap); tcap = IfaceT cbname; is_cap P cbname; cbname \<in> \<gamma> \<rbrakk> \<Longrightarrow> P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S'\<rangle>" |
    at_stack_update: "\<lbrakk> (* no restrictions on stack updates beyond standard type-correctness
                           and integrity of labels *)
                          S' = S\<lparr>stack := s'\<rparr> \<rbrakk> \<Longrightarrow> P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S'\<rangle>"  |
    at_except_update: "\<lbrakk> (* no restrictions on exception raising beyond standard type-correctness
                           and integrity of labels *)
                          S' = S\<lparr>except := e'\<rparr> \<rbrakk> \<Longrightarrow> P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S'\<rangle>"  |
    at_retval_update: "\<lbrakk> (* no restrictions on returning beyond standard type-correctness
                           and integrity of labels *)
                          S' = S\<lparr>retval := r'\<rparr> \<rbrakk> \<Longrightarrow> P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S'\<rangle>"  |
    at_heap_update: "\<lbrakk> (* the new object must have a label less than gamma
                          N.B. heap extension property of preservation proof already guarantees that
                               if we are updating an existing object, the updated object will have
                               the same label as the original label  *)
                          (HLabel obj') \<subseteq> \<gamma>;
                          S' = S\<lparr>heap := (heap S)(l\<mapsto>obj')\<rparr>
                       \<rbrakk> \<Longrightarrow> P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S'\<rangle>" |
    at_globals_update: "\<lbrakk> is_class P c; field P c f = Some fdecl; tlabel (ftype fdecl) \<subseteq> \<gamma>;
                          classStatics = the ((globals S) c);
                          S' = S\<lparr>globals := (globals S)(c\<mapsto>(classStatics(f\<mapsto>v)))\<rparr>
                       \<rbrakk> \<Longrightarrow> P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S'\<rangle>" |
    at_privs_update: "\<lbrakk> (* We don't really need to show this is true, but provides
                          some confidence. *)
                         S' = S\<lparr>privs:= \<gamma>'\<rparr>; \<gamma>' \<subseteq> \<gamma> \<rbrakk> \<Longrightarrow> P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S'\<rangle>"

lemma allowed_transition_expr_new:
  assumes op1: "v = href l"
  assumes op2: "l \<notin> dom (heap S)"
  assumes op3: "S' = S\<lparr>heap := (heap S)(l \<mapsto> new_object P cname (lbl \<inter> privs S))\<rparr>"
  assumes corr: "P M \<Gamma> \<^bold>\<turnstile> S"
  assumes wf: "P M \<Gamma> \<turnstile> new lbl cname : T"
  assumes wfp: "wf_prog P"
  assumes gamma: "(privs S) \<subseteq> \<gamma>"
  shows "allowed_transition P \<gamma> S S'"
proof -
  (* presently unused *)
  have "(P M \<Gamma> \<^bold>\<turnstile> S') \<and> (transition_ok S S') \<and> (is_expr_value_ok P S' T v)"
    using preservation_expr_new assms by simp

  have "HLabel (new_object P cname (lbl \<inter> privs S)) \<subseteq> \<gamma>"
    using gamma unfolding new_object_def by auto
  then show "allowed_transition P \<gamma> S S'"
    using op3 at_heap_update by simp
qed

lemma allowed_transition_expr_calli:
  assumes op1: "a = the (stack S x)"
  assumes op2: "l = the_href a"
  assumes op3: "a \<noteq> v.null"
  assumes op4: "obj = the (heap S l)"
  assumes op5: "(d, m) = the (cmethod P (HClass obj) mname)"
  assumes op6: "s = the (mstmt m)"
  assumes s0: "S0 = S\<lparr>stack := (stack S \<circ>\<^sub>m map_formalpar_to_args (mdecl m) args)(This \<mapsto> a), retval := None, privs := (HLabel obj)\<rparr>"
  assumes s': "S' = S1\<lparr>stack := stack S, retval := retval S, privs := privs S\<rparr>"
  assumes retval_if_noexcept: "except S1 = None \<longrightarrow> retval S1 \<noteq> None"
  assumes v: "v = the (retval S1)"
  assumes "P \<turnstile> \<langle>s | S0\<rangle> \<rightarrow>\<^sub>s \<langle>S1\<rangle>"
  (* induction hypothesis *)
  assumes hyp: "(\<forall>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S0) \<and> (P M \<Gamma> \<turnstile> s \<bullet>) \<and> privs S0 \<subseteq> \<gamma> \<longrightarrow> (P \<gamma> \<turnstile> \<langle>S0\<rangle> \<rightarrow>\<^sub>A \<langle>S1\<rangle>))"
  assumes corr: "P M \<Gamma> \<^bold>\<turnstile> S"
  assumes wfp: "wf_prog P"
  assumes wf: "P M \<Gamma> \<turnstile> calli x mname args : T"
  assumes gamma: "(privs S) \<subseteq> \<gamma>"
  shows "allowed_transition P \<gamma> S S'"
proof -
  (* Bits of this proof have been taken from the preservation proof. *)
  define M0 where "M0 = call_menv d m"
  moreover define \<Gamma>0 where "\<Gamma>0 = call_lenvi P d (mdecl m)"
  ultimately have a1: "(P M0 \<Gamma>0 \<^bold>\<turnstile> S0) \<and> (P M0 \<Gamma>0 \<turnstile> s \<bullet>)" using calli_prems assms by metis

  obtain t0 \<gamma>0 decl t' where a2: "(\<Gamma>\<lbrakk>x\<rbrakk>\<^sub>v = Some (t0,\<gamma>0)) \<and> methoddecl P t0 mname = Some decl \<and>
                        is_type P t0 \<and> (\<forall>t. t0 \<noteq> (ValT t)) \<and> \<not>mstatic decl \<and>
                        wf_method_call P \<Gamma> decl args \<gamma>0 (t',(tlabel T)) \<and> (subsumption P t' (ttype T))"
    using wf wf_expr_calli_intro by (metis prod.collapse)

  (* Infer the the object pointed to by x exists, and has a runtime type compatible with the static type t0. *)
  have a3: "a = (href l) \<and> heap S l = Some obj \<and> (P \<turnstile> (ClassT (HClass obj)) <: t0) \<and> is_obj_label_ok P obj (intersect_label (t0,\<gamma>0) (privs S))"
    using object_correspondence a2 op1 op2 op3 op4 corr by (metis fst_conv)

  show ?thesis proof (cases "is_cap_type P t0")
    case True
    then obtain cbname where b1: "t0 = IfaceT cbname \<and> is_cap P cbname"
      by (metis \<tau>.exhaust a2 is_cap_type.simps(2) is_cap_type.simps(3))
    then have b2: "\<gamma>0 \<inter> (privs S) = (cap_label P cbname) \<inter> (HLabel obj) \<and>
                (* This gives some 'meaning' to the labels. *)
                (superinterface_set P cbname) \<subseteq> \<gamma>0 \<inter> (privs S)"
      using a3 intersect_label_label intersect_label_type unfolding is_obj_label_ok_def by auto
    then have b3: "cbname \<in> \<gamma>"
      unfolding superinterface_set_def using gamma by auto
    moreover have "(\<Gamma>\<lbrakk>x\<rbrakk>\<^sub>v = Some (t0,\<gamma>0))" using a2 by simp
    moreover have "P \<turnstile> \<langle>(calli x mname args) | S\<rangle> \<rightarrow>\<^sub>e \<langle>v | S'\<rangle>" using assms op_expr_calli by simp
    ultimately show "allowed_transition P \<gamma> S S'"
      using at_cap_call corr wf b1 by simp
  next
    case False
    then have "(HLabel obj) = \<gamma>0 \<inter> (privs S)"
      using a3 intersect_label_label intersect_label_type unfolding is_obj_label_ok_def by auto
    then have b1: "(HLabel obj) \<subseteq> \<gamma>" using gamma by auto
    then have "allowed_transition P \<gamma> S S0"
      using at_stack_update at_retval_update at_privs_update at_trans s0 by metis
    moreover have "allowed_transition P \<gamma> S0 S1"
      using hyp a1 s0 b1 by fastforce
    moreover have "allowed_transition P \<gamma> S1 S'"
      using at_stack_update at_retval_update at_privs_update at_trans s' gamma by metis
    ultimately show ?thesis
      using at_trans by metis
  qed
qed

lemma allowed_transition_expr_calls:
  assumes op5: "(d, m) = the (cmethod P c mname)"
  assumes "P \<turnstile> \<langle>s | S0\<rangle> \<rightarrow>\<^sub>s \<langle>S1\<rangle>"
  assumes hyp: "\<forall>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S0) \<and> (P M \<Gamma> \<turnstile> s \<bullet>) \<and> privs S0 \<subseteq> \<gamma> \<longrightarrow> (P \<gamma> \<turnstile> \<langle>S0\<rangle> \<rightarrow>\<^sub>A \<langle>S1\<rangle>)"
  assumes "s = the (mstmt m)"
  assumes s0: "S0 = S\<lparr>stack := stack S \<circ>\<^sub>m map_formalpar_to_args (mdecl m) args, retval := None, privs := (privs S) \<inter> lbl\<rparr>"
  assumes s': "S' = S1\<lparr>stack := stack S, retval := retval S, privs := privs S\<rparr>"
  assumes retval_if_noexcept: "except S1 = None \<longrightarrow> retval S1 \<noteq> None"
  assumes v: "v = the (retval S1)"
  assumes corr: "P M \<Gamma> \<^bold>\<turnstile> S"
  assumes wfp: "wf_prog P"
  assumes wf: "P M \<Gamma> \<turnstile> calls c mname lbl args : T"
  assumes gamma: "(privs S) \<subseteq> \<gamma>"
  shows "allowed_transition P \<gamma> S S'"
proof -
  have "privs S \<inter> lbl \<subseteq> \<gamma>"
    using gamma by auto
  then have "allowed_transition P \<gamma> S S0"
    using at_stack_update at_retval_update at_privs_update at_trans s0 by metis
  moreover have "allowed_transition P \<gamma> S0 S1"
  proof -
    define M0 where "M0 = call_menv d m"
    moreover define \<Gamma>0 where "\<Gamma>0 = call_lenvs P (mdecl m)"
    ultimately have "(P M0 \<Gamma>0 \<^bold>\<turnstile> S0) \<and> (P M0 \<Gamma>0 \<turnstile> s \<bullet>)" using calls_prems assms by metis
    moreover have "privs S0 \<subseteq> \<gamma>"
      using gamma s0 by auto
    ultimately show ?thesis using hyp by blast
  qed
  moreover have "allowed_transition P \<gamma> S1 S'"
    using at_stack_update at_retval_update at_privs_update at_trans s' gamma by metis
  ultimately show ?thesis
    using at_trans by metis
qed

lemma allowed_transition_stmt_assignfi:
  assumes op1: "no_exception_or_return S" (* unused *)
  assumes op2: "a = the (stack S1 x)"
  assumes op3: "a \<noteq> v.null"
  assumes op4: "l = the_href a"
  assumes op5: "obj = the (heap S1 l)"
  assumes op6: "S' = (if except S1 = None then S1\<lparr>heap := heap S1(l \<mapsto> obj\<lparr>HFields := HFields obj(f \<mapsto> v)\<rparr>)\<rparr> else S1)"
  assumes op7: "P \<turnstile> \<langle>e | S\<rangle> \<rightarrow>\<^sub>e \<langle>v | S1\<rangle>" (* unused *)
  assumes hyp: "\<And>M \<Gamma> T. (P M \<Gamma> \<^bold>\<turnstile> S) \<and> (P M \<Gamma> \<turnstile> e : T) \<and> (privs S \<subseteq> \<gamma>)  \<longrightarrow> allowed_transition P \<gamma> S S1"
  assumes corr: "P M \<Gamma> \<^bold>\<turnstile> S"
  assumes wf: "P M \<Gamma> \<turnstile> assignfi x f e \<bullet>"
  assumes wfp: "wf_prog P"
  assumes gamma: "(privs S) \<subseteq> \<gamma>"
  shows "allowed_transition P \<gamma> S S'"
proof -
  obtain T where a1: "wf_fieldi_access P \<Gamma> x f T \<and> (P M \<Gamma> \<turnstile> e : T)"
    using wf wf_stmt_assignfi_intro by blast
  obtain c \<gamma>0 fdecl where a2: "(\<Gamma>\<lbrakk>x\<rbrakk>\<^sub>v = Some ((ClassT c),\<gamma>0)) \<and> field P c f = Some fdecl \<and>
                                    \<not>fstatic fdecl \<and> T = intersect_label (ftype fdecl) \<gamma>0"
    using a1 unfolding wf_fieldi_access_def by blast
  have a3: "(P M \<Gamma> \<^bold>\<turnstile> S1) \<and> transition_ok S S1 \<and> is_expr_value_ok P S1 T v"
    using preservation op7 wfp corr a1 by metis

  have "allowed_transition P \<gamma> S S1"
    using a1 corr gamma hyp by blast
  moreover have "allowed_transition P \<gamma> S1 S'" proof (cases "except S1")
    case None
    have "heap S1 l = Some obj \<and> (P \<turnstile> (ClassT (HClass obj)) <: (ClassT c)) \<and>
            is_obj_label_ok P obj (intersect_label ((ClassT c),\<gamma>0) (privs S1))"
      using object_correspondence a2 a3 op2 op3 op4 op5 by (metis \<tau>.simps(5) fst_conv)
    then have "HLabel obj \<subseteq> (privs S1)"
      unfolding is_obj_label_ok_def by (simp add: intersect_label_label intersect_label_type)
    then have "HLabel obj \<subseteq> \<gamma>"
      using a3 gamma unfolding transition_ok_def by simp
    then show ?thesis using  at_heap_update op6 None by simp
  next
    case (Some a)
    then have "S' = S1" using op6 by simp
    then show ?thesis using at_reflexive by simp
  qed
  ultimately show ?thesis using at_trans by metis
qed

lemma allowed_transition_stmt_assignfs:
  assumes op1: "no_exception_or_return S"
  assumes op2: "classStatics = the (globals S1 c)"
  assumes op3: "S' = (if except S1 = None then S1\<lparr>globals := globals S1(c \<mapsto> classStatics(f \<mapsto> v))\<rparr> else S1)"
  assumes op4: "P \<turnstile> \<langle>e | S\<rangle> \<rightarrow>\<^sub>e \<langle>v | S1\<rangle>"
  assumes hyp: "\<And>M \<Gamma> T. (P M \<Gamma> \<^bold>\<turnstile> S) \<and> (P M \<Gamma> \<turnstile> e : T) \<and> (privs S \<subseteq> \<gamma>)  \<longrightarrow> allowed_transition P \<gamma> S S1"
  assumes corr: "P M \<Gamma> \<^bold>\<turnstile> S"
  assumes wf: "P M \<Gamma> \<turnstile> assignfs c f e \<bullet>"
  assumes wfp: "wf_prog P"
  assumes gamma: "(privs S) \<subseteq> \<gamma>"
  shows "allowed_transition P \<gamma> S S'"
proof -
  obtain T where a1: "wf_fields_access P M c f T \<and> (P M \<Gamma> \<turnstile> e : T)"
    using wf wf_stmt_assignfs_intro by blast
  then obtain fdecl where a2: "is_class P c \<and> field P c f = Some fdecl \<and> fstatic fdecl \<and>
                                  (T = (ftype fdecl) \<and> (tlabel (ftype fdecl)) \<subseteq> (msreq M))"
    using wf_fields_access_def by auto
  have a3: "(P M \<Gamma> \<^bold>\<turnstile> S1) \<and> transition_ok S S1 \<and> is_expr_value_ok P S1 T v"
    using preservation op4 wfp a1 corr by blast

  have "allowed_transition P \<gamma> S S1"
    using a1 corr gamma hyp by blast
  moreover have "allowed_transition P \<gamma> S1 S'" proof (cases "except S1")
    case None
    have "(tlabel (ftype fdecl)) \<subseteq> \<gamma>"
      using a2 corr gamma unfolding corr_def by auto
    then show ?thesis using a2 at_globals_update op2 op3 None by metis
  next
    case (Some a)
    then show ?thesis using op3 at_reflexive by simp
  qed
  ultimately show ?thesis using at_trans by metis
qed

lemma allowed_transition_stmt_letin:
  assumes op1: "no_exception_or_return S"
  assumes op2: "P \<turnstile> \<langle>e | S\<rangle> \<rightarrow>\<^sub>e \<langle>v | S1\<rangle>"
  assumes op3: "S2 = (if except S1 = None then S1\<lparr>stack := stack S1(x \<mapsto> v)\<rparr> else S1)"
  assumes op4: "P \<turnstile> \<langle>s | S2\<rangle> \<rightarrow>\<^sub>s \<langle>S3\<rangle>"
  assumes op5: "S' = S3\<lparr>stack := (stack S3)(x := stack S x)\<rparr>"
  assumes hype: "\<And>M \<Gamma> T. (P M \<Gamma> \<^bold>\<turnstile> S) \<and> (P M \<Gamma> \<turnstile> e : T) \<and> (privs S) \<subseteq> \<gamma> \<longrightarrow> allowed_transition P \<gamma> S S1"
  assumes hyps: "\<And>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S2) \<and> (P M \<Gamma> \<turnstile> s \<bullet>)  \<and> (privs S2) \<subseteq> \<gamma> \<longrightarrow> allowed_transition P \<gamma> S2 S3"
  assumes corr: "P M \<Gamma> \<^bold>\<turnstile> S"
  assumes wf: "P M \<Gamma> \<turnstile> letin T x e s \<bullet>"
  assumes wfp: "wf_prog P"
  assumes gamma: "(privs S) \<subseteq> \<gamma>"
  shows "allowed_transition P \<gamma> S S'"
proof -
  have wfi: "(P M \<Gamma> \<turnstile> e : T) \<and> (P M \<Gamma>(x\<mapsto>T) \<turnstile> s \<bullet>)"
    using wf wf_stmt_letin_intro by simp
  then have "(P M \<Gamma> \<^bold>\<turnstile> S1) \<and> transition_ok S S1 \<and> is_expr_value_ok P S1 T v"
    using wfp preservation op2 corr by metis
  (* If the exception did not throw an exception during evaluation, the assignment occurs
     and S2 is type-correct to \<Gamma>(x\<mapsto>T). Otherwise the assignment does not occur and we
     end-up correct to \<Gamma> only. We rely on the fact that the let-in body will not be executed
     in this case (due to an unhandled exception.)  *)
  then have a2: "(except S2 = None \<longrightarrow> (P M \<Gamma>(x\<mapsto>T) \<^bold>\<turnstile> S2)) \<and>
                 (except S2 \<noteq> None \<longrightarrow> (P M \<Gamma> \<^bold>\<turnstile> S2)) \<and> transition_ok S S2"
    using preservation_stmt_assign_base op3 by metis

  have a1: "allowed_transition P \<gamma> S S1"
    using wfi hype corr gamma by blast
  moreover have "allowed_transition P \<gamma> S1 S2"
    using op3 at_stack_update at_reflexive by simp
  moreover have "allowed_transition P \<gamma> S2 S3"
  proof (cases "except S2")
    case None
    then have "(P M \<Gamma>(x \<mapsto> T) \<^bold>\<turnstile> S2) \<and> (privs S2 \<subseteq> \<gamma>)"
      using a2 gamma unfolding transition_ok_def by simp
    then show "allowed_transition P \<gamma> S2 S3"
      using hyps wfi by metis
  next
    case (Some a)
    then have "S2 = S3"
      using exception_or_return_skips op4 unfolding no_exception_or_return_def by simp
    then show "allowed_transition P \<gamma> S2 S3"
      using at_reflexive by simp
  qed
  moreover have "allowed_transition P \<gamma> S3 S'"
    using op5 at_stack_update at_reflexive by simp
  ultimately show ?thesis
    using at_trans by metis
qed

lemma allowed_transition_stmt_seq:
  assumes op1: "no_exception_or_return S"
  assumes op2: "P \<turnstile> \<langle>s1 | S\<rangle> \<rightarrow>\<^sub>s \<langle>S1\<rangle>"
  assumes op3: "\<forall>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S) \<and> (P M \<Gamma> \<turnstile> s1 \<bullet>) \<and> privs S \<subseteq> \<gamma> \<longrightarrow> (P \<gamma> \<turnstile> \<langle>S\<rangle> \<rightarrow>\<^sub>A \<langle>S1\<rangle>)"
  assumes op4: "P \<turnstile> \<langle>s2 | S1\<rangle> \<rightarrow>\<^sub>s \<langle>S2\<rangle>"
  assumes op5: "\<forall>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S1) \<and> (P M \<Gamma> \<turnstile> s2 \<bullet>) \<and> privs S1 \<subseteq> \<gamma> \<longrightarrow> (P \<gamma> \<turnstile> \<langle>S1\<rangle> \<rightarrow>\<^sub>A \<langle>S2\<rangle>)"
  assumes corr: "P M \<Gamma> \<^bold>\<turnstile> S"
  assumes wf: "P M \<Gamma> \<turnstile> seq s1 s2 \<bullet>"
  assumes wfp: "wf_prog P"
  assumes gamma: "(privs S) \<subseteq> \<gamma>"
  shows "allowed_transition P \<gamma> S S2"
proof -
  have a1: "(P M \<Gamma> \<turnstile> s1 \<bullet>) \<and> (P M \<Gamma> \<turnstile> s2 \<bullet>)"
    using wf wf_stmt_seq_intro by metis
  have a2: "(P M \<Gamma> \<^bold>\<turnstile> S1) \<and> transition_ok S S1"
    using wfp preservation op2 corr a1 by metis

  have "allowed_transition P \<gamma> S S1"
    using op3 corr a1 gamma by metis
  moreover have "allowed_transition P \<gamma> S1 S2"
    using op5 a1 a2 gamma unfolding transition_ok_def by metis
  ultimately show ?thesis using at_trans by metis
qed

lemma allowed_transition_stmt_trycatch_ex:
  assumes op1: "no_exception_or_return S"
  assumes op2: "except S1 = Some ex"
  assumes op3: "a = the_href ex"
  assumes op4: "exObj = the (heap S1 a)"
  assumes op5: "P \<turnstile> \<langle>s | S\<rangle> \<rightarrow>\<^sub>s \<langle>S1\<rangle>"
  assumes op6: "i = Min {j::nat. (j = length ch) \<or> ((j < length ch) \<and> (P \<turnstile> (ClassT (HClass exObj)) <: (chtype (ch !j)))) }"
  assumes op7: "if i < length ch
                then h = ch ! i \<and>
                     var = chvar h \<and>
                     S2 = S1\<lparr>except := None, stack := (stack S1)(var \<mapsto> ex)\<rparr> \<and>
                     ((P \<turnstile> \<langle>chstmt h | S2\<rangle> \<rightarrow>\<^sub>s \<langle>S3\<rangle>) \<and> (\<forall>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S2) \<and> (P M \<Gamma> \<turnstile> chstmt h \<bullet>) \<and> (privs S2) \<subseteq> \<gamma>
                           \<longrightarrow> allowed_transition P \<gamma> S2 S3)) \<and>
                     S' = S3\<lparr>stack := (stack S3)(var := stack S1 var)\<rparr>
                else S' = S1"
  assumes hyp: "\<And>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S) \<and> (P M \<Gamma> \<turnstile> s \<bullet>) \<and> (privs S) \<subseteq> \<gamma> \<longrightarrow>allowed_transition P \<gamma> S S1"
  assumes corr: "P M \<Gamma> \<^bold>\<turnstile> S"
  assumes wf: "P M \<Gamma> \<turnstile> trycatch s ch \<bullet>"
  assumes wfp: "wf_prog P"
  assumes gamma: "(privs S) \<subseteq> \<gamma>"
  shows "allowed_transition P \<gamma> S S'"
proof -
  (* Need to statisfy induction hypothesis of existing proof *)
  have "if i < length ch
                then h = ch ! i \<and>
                     var = chvar h \<and>
                     S2 = S1\<lparr>except := None, stack := (stack S1)(var \<mapsto> ex)\<rparr> \<and>
                     ((P \<turnstile> \<langle>chstmt h | S2\<rangle> \<rightarrow>\<^sub>s \<langle>S3\<rangle>) \<and> (\<forall>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S2) \<and> (P M \<Gamma> \<turnstile> chstmt h \<bullet>)
                           \<longrightarrow> (P M \<Gamma> \<^bold>\<turnstile> S3) \<and> transition_ok S2 S3)) \<and>
                     S' = S3\<lparr>stack := (stack S3)(var := stack S1 var)\<rparr>
                else S' = S1"
    using op7 preservation wfp  by meson
  moreover have  "\<And>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S) \<and> (P M \<Gamma> \<turnstile> s \<bullet>) \<longrightarrow> (P M \<Gamma> \<^bold>\<turnstile> S1) \<and> transition_ok S S1"
    using preservation op5 wfp by meson
  moreover define \<Gamma>' where "\<Gamma>' = \<Gamma>(var \<mapsto> ((chtype h),{}))"
  ultimately have a1: "(P M \<Gamma> \<^bold>\<turnstile> S1) \<and> transition_ok S S1 \<and>
          (i < length ch \<longrightarrow> (P M \<Gamma>' \<^bold>\<turnstile> S2) \<and> (P M \<Gamma>' \<turnstile> chstmt h \<bullet>) \<and> transition_ok S1 S2 \<and>
                             (P M \<Gamma>' \<^bold>\<turnstile> S3) \<and> transition_ok S2 S3 \<and> transition_ok S3 S') \<and>
          (P M \<Gamma> \<^bold>\<turnstile> S') \<and> transition_ok S1 S'"
    using preservation_stmt_trycatch_ex_helper assms by blast

  have a2: "(P M \<Gamma> \<turnstile> s \<bullet>) \<and> (\<forall>(t,x,s')\<in>(set ch). (P M \<Gamma>(x\<mapsto>(t,{})) \<turnstile> s' \<bullet>) \<and> \<not>is_cap_type P t)"
    using wf wf_stmt_trycatch_intro by simp

  have "allowed_transition P \<gamma> S S1" using corr hyp a2 gamma by metis
  moreover have "allowed_transition P \<gamma> S1 S'"
  proof (cases "i < length ch")
    case True
    then have "allowed_transition P \<gamma> S1 S2"
      using op7 at_stack_update at_except_update at_trans by metis
    moreover have "allowed_transition P \<gamma> S2 S3"
    proof -
      have "privs S2 \<subseteq> \<gamma>" using a1 True gamma unfolding transition_ok_def by simp
      then show ?thesis using op7 a1 True by metis
    qed
    moreover have "allowed_transition P \<gamma> S3 S'"
      using op7 True at_stack_update by metis
    ultimately show ?thesis using at_trans by metis
  next
    case False
    then show ?thesis using op7 at_reflexive by metis
  qed
  ultimately show ?thesis using at_trans by metis
qed

lemma security_proof_state:
  assumes wfp: "wf_prog P"
  shows "((P \<turnstile> \<langle>e | S\<rangle> \<rightarrow>\<^sub>e \<langle>v | S'\<rangle>) \<longrightarrow> (\<forall>M \<Gamma> T. (P M \<Gamma> \<^bold>\<turnstile> S) \<and> (P M \<Gamma> \<turnstile> e : T) \<and> (privs S) \<subseteq> \<gamma> \<longrightarrow> (allowed_transition P \<gamma> S S')))
       \<and> ((P \<turnstile> \<langle>s | S\<rangle> \<rightarrow>\<^sub>s \<langle>S'\<rangle>) \<longrightarrow> (\<forall>M \<Gamma>. (P M \<Gamma> \<^bold>\<turnstile> S) \<and> (P M \<Gamma> \<turnstile> s \<bullet>) \<and> (privs S) \<subseteq> \<gamma> \<longrightarrow> (allowed_transition P \<gamma> S S')))"
proof (induction S S' rule: op_expr_op_stmt.induct)
  case (op_expr_ref v S x)
  then show ?case using at_reflexive by simp
next
  case (op_expr_new v l S S' cname lbl)
  then show ?case using allowed_transition_expr_new wfp by blast
next
  case (op_expr_calli a S x l obj d m mname s S0 args S1 S' v)
  then show ?case using allowed_transition_expr_calli wfp by force
next
  case (op_expr_calls d m c mname s S0 S lbl args S1 S' v)
  then show ?case using allowed_transition_expr_calls wfp by force
next
  case (op_expr_cast e S v S' hobj t)
  then show ?case using wf_expr_cast_intro by (metis prod.exhaust_sel)
next
  case (op_expr_const k v S)
  then show ?case using at_reflexive by simp
next
  case (op_expr_fieldacci a S x l obj v f)
  then show ?case using at_reflexive by simp
next
  case (op_expr_fieldaccs classStatics S c v f)
  then show ?case using at_reflexive by simp
next
  case (op_expr_wrap e S v S' cbname)
  then show ?case using wf_expr_wrap_intro by (metis prod.exhaust_sel)
next
  case (op_stmt_assign S e v S1 S' x)
  then show ?case using wf_stmt_assign_intro at_trans at_stack_update by metis
next
  case (op_stmt_assignfi S e v S1 a x l obj S' f)
  then show ?case using allowed_transition_stmt_assignfi wfp by blast
next
  case (op_stmt_assignfs S e v S1 classStatics c S' f)
  then show ?case using allowed_transition_stmt_assignfs wfp by blast
next
  case (op_stmt_expr S e v S')
  then show ?case using wf_stmt_expr_intro by metis
next
  case (op_stmt_then S v x s1 S1 s2)
  then show ?case using wf_stmt_ifelse_intro by metis
next
  case (op_stmt_else S v x s2 S2 s1)
  then show ?case using wf_stmt_ifelse_intro by metis
next
  case (op_stmt_letin S e v S1 S2 x s S3 S' T)
  then show ?case using allowed_transition_stmt_letin wfp by blast
next
  case (op_stmt_return S e v S1 S')
  then show ?case using wf_stmt_return_intro at_trans at_retval_update by metis
next
  case (op_stmt_seq S s1 S1 s2 S2)
  then show ?case using allowed_transition_stmt_seq wfp by blast
next
  case (op_stmt_throw S e v S1 S')
  then show ?case using wf_stmt_throw_intro at_trans at_except_update by metis
next
  case (op_stmt_trycatch_ok S s S1 S' catchhandlers)
  then show ?case using wf_stmt_trycatch_intro by metis
next
  case (op_stmt_trycatch_ex S s S1 ex a exObj i ch h var S2 S3 S')
  then show ?case using allowed_transition_stmt_trycatch_ex wfp by blast
next
  case (op_stmt_exception_or_return S s)
  then show ?case using at_reflexive by simp
qed

end