theory Independent_DYNAMIC_Post_Network
  imports
    "Independent_DYNAMIC_Post_ISSUER"
    "Independent_Post_RECEIVER"
    "../../API_Network"
    "BD_Security_Compositional.Composing_Security_Network"
begin

subsubsection \<open>Confidentiality for the N-ary composition\<close>

type_synonym ttrans = "(state, act, out) trans"
type_synonym obs = Post_Observation_Setup_ISSUER.obs
type_synonym "value" = "Post.value + Post_RECEIVER.value"

lemma value_cases:
fixes v :: "value"
obtains (PVal) pst where "v = Inl (Post.PVal pst)"
      | (PValS) aid pst where "v = Inl (Post.PValS aid pst)"
      | (OVal) ov where "v = Inl (Post.OVal ov)"
      | (PValR) pst where "v = Inr (Post_RECEIVER.PValR pst)"
proof (cases v)
  case (Inl vl) then show thesis using PVal PValS OVal by (cases vl rule: Post.value.exhaust) auto next
  case (Inr vr) then show thesis using PValR by (cases vr rule: Post_RECEIVER.value.exhaust) auto
qed

locale Post_Network = Network
+ fixes UIDs :: "apiID \<Rightarrow> userID set"
  and AID :: "apiID" and PID :: "postID"
  assumes AID_in_AIDs: "AID \<in> AIDs"
begin

sublocale Iss: Post "UIDs AID" PID .

abbreviation \<phi> :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> bool"
where "\<phi> aid trn \<equiv> (if aid = AID then Iss.\<phi> trn else Post_RECEIVER.\<phi> PID AID trn)"

abbreviation f :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> value"
where "f aid trn \<equiv> (if aid = AID then Inl (Iss.f trn) else Inr (Post_RECEIVER.f PID AID trn))"

abbreviation \<gamma> :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> bool"
where "\<gamma> aid trn \<equiv> (if aid = AID then Iss.\<gamma> trn else Strong_ObservationSetup_RECEIVER.\<gamma> (UIDs aid) trn)"

abbreviation g :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> obs"
where "g aid trn \<equiv> (if aid = AID then Iss.g trn else Strong_ObservationSetup_RECEIVER.g PID AID trn)"

abbreviation T :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> bool"
where "T aid trn \<equiv> (if aid = AID then Iss.T trn else Post_RECEIVER.T (UIDs aid) PID AID trn)"

abbreviation B :: "apiID \<Rightarrow> value list \<Rightarrow> value list \<Rightarrow> bool"
where "B aid vl vl1 \<equiv>
  (if aid = AID then list_all isl vl \<and> list_all isl vl1 \<and> Iss.B (map projl vl) (map projl vl1)
   else list_all (Not o isl) vl \<and> list_all (Not o isl) vl1 \<and> Post_RECEIVER.B (map projr vl) (map projr vl1))"

fun comOfV :: "apiID \<Rightarrow> value \<Rightarrow> com" where
  "comOfV aid (Inl (Post.PValS aid' pst)) = (if aid' \<noteq> aid then Send else Internal)"
| "comOfV aid (Inl (Post.PVal pst)) = Internal"
| "comOfV aid (Inl (Post.OVal ov)) = Internal"
| "comOfV aid (Inr v) = Recv"

fun tgtNodeOfV :: "apiID \<Rightarrow> value \<Rightarrow> apiID" where
  "tgtNodeOfV aid (Inl (Post.PValS aid' pst)) = aid'"
| "tgtNodeOfV aid (Inl (Post.PVal pst)) = undefined"
| "tgtNodeOfV aid (Inl (Post.OVal ov)) = undefined"
| "tgtNodeOfV aid (Inr v) = AID"

definition syncV :: "apiID \<Rightarrow> value \<Rightarrow> apiID \<Rightarrow> value \<Rightarrow> bool" where
  "syncV aid1 v1 aid2 v2 =
    (\<exists>pst. aid1 = AID \<and> v1 = Inl (Post.PValS aid2 pst) \<and> v2 = Inr (Post_RECEIVER.PValR pst))"

lemma syncVI: "syncV AID (Inl (Post.PValS aid' pst)) aid' (Inr (Post_RECEIVER.PValR pst))"
unfolding syncV_def by auto

lemma syncVE:
assumes "syncV aid1 v1 aid2 v2"
obtains pst where "aid1 = AID" "v1 = Inl (Post.PValS aid2 pst)" "v2 = Inr (Post_RECEIVER.PValR pst)"
using assms unfolding syncV_def by auto

fun getTgtV where
  "getTgtV (Inl (Post.PValS aid pst)) = Inr (Post_RECEIVER.PValR pst)"
| "getTgtV v = v"

lemma comOfV_AID:
  "comOfV AID v = Send \<longleftrightarrow> isl v \<and> Iss.isPValS (projl v) \<and> Iss.tgtAPI (projl v) \<noteq> AID"
  "comOfV AID v = Recv \<longleftrightarrow> Not (isl v)"
by (cases v rule: value_cases; auto)+

lemmas \<phi>_defs = Post_RECEIVER.\<phi>_def2 Iss.\<phi>_def3

sublocale Net: BD_Security_TS_Network_getTgtV
where istate = "\<lambda>_. istate" and validTrans = validTrans and srcOf = "\<lambda>_. srcOf" and tgtOf = "\<lambda>_. tgtOf"
  and nodes = AIDs and comOf = comOf and tgtNodeOf = tgtNodeOf
  and sync = sync and \<phi> = \<phi> and f = f and \<gamma> = \<gamma> and g = g and T = T and B = B
  and comOfV = comOfV and tgtNodeOfV = tgtNodeOfV and syncV = syncV
  and comOfO = comOfO and tgtNodeOfO = tgtNodeOfO and syncO = syncO (*and cmpO = cmpO*)
  and source = AID and getTgtV = getTgtV
using AID_in_AIDs proof (unfold_locales, goal_cases)
  case (1 nid trn) then show ?case using Iss.validTrans_isCOMact_open[of trn] by (cases trn rule: Iss.\<phi>.cases) (auto simp: \<phi>_defs split: prod.splits) next
  case (2 nid trn) then show ?case using Iss.validTrans_isCOMact_open[of trn] by (cases trn rule: Iss.\<phi>.cases) (auto simp: \<phi>_defs split: prod.splits) next
  case (3 nid trn)
    interpret Sink: Post_RECEIVER "UIDs nid" PID AID .
    show ?case using 3 by (cases "(nid,trn)" rule: tgtNodeOf.cases) (auto split: prod.splits)
next
  case (4 nid trn)
    interpret Sink: Post_RECEIVER "UIDs nid" PID AID .
    show ?case using 4 by (cases "(nid,trn)" rule: tgtNodeOf.cases) (auto split: prod.splits)
next
  case (5 nid1 trn1 nid2 trn2)
    interpret Sink1: Post_RECEIVER "UIDs nid1" PID AID .
    interpret Sink2: Post_RECEIVER "UIDs nid2" PID AID .
    show ?case using 5 by (elim sync_cases) (auto intro: syncVI)
next
  case (6 nid1 trn1 nid2 trn2)
    interpret Sink1: Post_RECEIVER "UIDs nid1" PID AID .
    interpret Sink2: Post_RECEIVER "UIDs nid2" PID AID .
    show ?case using 6 by (elim sync_cases) auto
next
  case (7 nid1 trn1 nid2 trn2)
    interpret Sink1: Post_RECEIVER "UIDs nid1" PID AID .
    interpret Sink2: Post_RECEIVER "UIDs nid2" PID AID .
    show ?case using 7(2,4,6-10)
      using Iss.validTrans_isCOMact_open[OF 7(2)] Iss.validTrans_isCOMact_open[OF 7(4)]
      by (elim sync_cases) (auto split: prod.splits, auto simp: sendPost_def)
next
  case (8 nid1 trn1 nid2 trn2)
    interpret Sink1: Post_RECEIVER "UIDs nid1" PID AID .
    interpret Sink2: Post_RECEIVER "UIDs nid2" PID AID .
    show ?case using 8(2,4,6-10,11,12,13)
      apply (elim syncO_cases; cases trn1; cases trn2)
          apply (auto simp: Iss.g_simps Strong_ObservationSetup_RECEIVER.g_simps split: prod.splits)
      apply (auto simp: sendPost_def split: prod.splits elim: syncVE)[]
      done
next
  case (9 nid trn)
    then show ?case
      by (cases "(nid,trn)" rule: tgtNodeOf.cases)
         (auto simp: Strong_ObservationSetup_RECEIVER.\<gamma>.simps)
next
  case (10 nid trn) then show ?case by (cases trn) (auto simp: \<phi>_defs)
next
  case (11 vSrc nid vn) then show ?case by (cases vSrc rule: value_cases) (auto simp: syncV_def)
next
  case (12 vSrc nid vn) then show ?case by (cases vSrc rule: value_cases) (auto simp: syncV_def)
qed

lemma list_all_Not_isl_projectSrcV: "list_all (Not o isl) (Net.projectSrcV aid vlSrc)"
proof (induction vlSrc)
  case (Cons vSrc vlSrc') then show ?case by (cases vSrc rule: value_cases) auto
qed auto

context
fixes AID' :: apiID
assumes AID': "AID' \<in> AIDs - {AID}"
begin

interpretation Recv: Post_RECEIVER "UIDs AID'" PID AID by unfold_locales

lemma Iss_BC_BO_tgtAPI:
shows "(Iss.BC vl vl1 \<longrightarrow> map Iss.tgtAPI (filter Iss.isPValS vl) =
                          map Iss.tgtAPI (filter Iss.isPValS vl1)) \<and>
       (Iss.BO vl vl1 \<longrightarrow> map Iss.tgtAPI (filter Iss.isPValS vl) =
                          map Iss.tgtAPI (filter Iss.isPValS vl1))"
by (induction rule: Iss.BC_BO.induct) auto

lemma Iss_B_Recv_B_aux:
assumes "list_all isl vl"
and "list_all isl vl1"
and "map Iss.tgtAPI (filter Iss.isPValS (map projl vl)) =
     map Iss.tgtAPI (filter Iss.isPValS (map projl vl1))"
shows "length (map projr (Net.projectSrcV AID' vl)) = length (map projr (Net.projectSrcV AID' vl1))"
using assms proof (induction vl vl1 rule: list22_induct)
  case (ConsCons v vl v1 vl1)
    consider (SendSend) aid pst pst1 where "v = Inl (Iss.PValS aid pst)" "v1 = Inl (Iss.PValS aid pst1)"
           | (Internal) "comOfV AID v = Internal" "\<not>Iss.isPValS (projl v)"
           | (Internal1) "comOfV AID v1 = Internal" "\<not>Iss.isPValS (projl v1)"
      using ConsCons(4-6) by (cases v rule: value_cases; cases v1 rule: value_cases) auto
    then show ?case proof cases
      case (SendSend) then show ?thesis using ConsCons.IH(1) ConsCons.prems by auto
    next
      case (Internal) then show ?thesis using ConsCons.IH(2)[of "v1 # vl1"] ConsCons.prems by auto
    next
      case (Internal1) then show ?thesis using ConsCons.IH(3)[of "v # vl"] ConsCons.prems by auto
    qed
qed (auto simp: comOfV_AID)

lemma Iss_B_Recv_B:
assumes "B AID vl vl1"
shows "Recv.B (map projr (Net.projectSrcV AID' vl)) (map projr (Net.projectSrcV AID' vl1))"
using assms Iss_B_Recv_B_aux Iss_BC_BO_tgtAPI by (auto simp: Iss.B_def Recv.B_def)

end

lemma map_projl_Inl: "map (projl o Inl) vl = vl"
by (induction vl) auto

lemma these_map_Inl_projl: "list_all isl vl \<Longrightarrow> these (map (Some o Inl o projl) vl) = vl"
by (induction vl) auto

lemma map_projr_Inr: "map (projr o Inr) vl = vl"
by (induction vl) auto

lemma these_map_Inr_projr: "list_all (Not o isl) vl \<Longrightarrow> these (map (Some o Inr o projr) vl) = vl"
by (induction vl) auto

sublocale BD_Security_TS_Network_Preserve_Source_Security_getTgtV
where istate = "\<lambda>_. istate" and validTrans = validTrans and srcOf = "\<lambda>_. srcOf" and tgtOf = "\<lambda>_. tgtOf"
  and nodes = AIDs and comOf = comOf and tgtNodeOf = tgtNodeOf
  and sync = sync and \<phi> = \<phi> and f = f and \<gamma> = \<gamma> and g = g and T = T and B = B
  and comOfV = comOfV and tgtNodeOfV = tgtNodeOfV and syncV = syncV
  and comOfO = comOfO and tgtNodeOfO = tgtNodeOfO and syncO = syncO (*and cmpO = cmpO*)
  and source = AID and getTgtV = getTgtV
proof (unfold_locales, goal_cases)
  case 1 show ?case using AID_in_AIDs .
next
  case 2
    interpret Iss': BD_Security_TS_Trans
      istate System_Specification.validTrans srcOf tgtOf Iss.\<phi> Iss.f Iss.\<gamma> Iss.g Iss.T Iss.B
      istate System_Specification.validTrans srcOf tgtOf Iss.\<phi> "\<lambda>trn. Inl (Iss.f trn)" Iss.\<gamma> Iss.g Iss.T "B AID"
      id id Some "Some o Inl"
    proof (unfold_locales, goal_cases)
      case (11 vl' vl1' tr) then show ?case
        by (intro exI[of _ "map projl vl1'"]) (auto simp: map_projl_Inl these_map_Inl_projl)
    qed auto
    show ?case using Iss.secure Iss'.translate_secure by auto
next
  case (3 aid tr vl' vl1)
    then show ?case
      using Iss_B_Recv_B[of aid "(Net.lV AID tr)" vl1] list_all_Not_isl_projectSrcV
      by auto
qed

theorem secure: "secure"
proof (intro preserve_source_secure ballI)
  fix aid
  assume aid: "aid \<in> AIDs - {AID}"
  interpret Node: Post_RECEIVER "UIDs aid" PID AID .
  interpret Node': BD_Security_TS_Trans
    istate System_Specification.validTrans srcOf tgtOf Node.\<phi> Node.f Node.\<gamma> Node.g Node.T Node.B
    istate System_Specification.validTrans srcOf tgtOf Node.\<phi> "\<lambda>trn. Inr (Node.f trn)" Node.\<gamma> Node.g Node.T "B aid"
    id id Some "Some o Inr"
  proof (unfold_locales, goal_cases)
    case (11 vl' vl1' tr) then show ?case using aid
      by (intro exI[of _ "map projr vl1'"]) (auto simp: map_projr_Inr these_map_Inr_projr)
  qed auto
  show "Net.lsecure aid"
    using aid Node.Post_secure Node'.translate_secure by auto
qed

end  (* context Post_Network *)

end


section \<open>Modular Formalization of Program Semantics\<close>

text \<open>Using the Virtual Datatype, Resource Space, Fiction Space, now in this section it is
  feasible to formalize the semantics of programs modularly and extensibly.

The section first presents an empty formalization (framework) of computation states
consisting of empty types, empty values, empty resources, and empty fictions.
It serves for future formalization of any specific program semantics.

Then on this empty formalization of computation states.
The framework formalizes computations using state-error-exception monad,
supporting most of control flows and therefore most of (imperative) languages.
\<close>

theory Phi_Semantics_Framework
  imports Resource_Space Virtual_Datatype.Virtual_Datatype Debt_Axiom.Debt_Axiom
  keywords "resource_space" :: thy_goal
       and "fiction_space"  :: thy_goal
  abbrevs "<throws>" = "\<t>\<h>\<r>\<o>\<w>\<s>"
    and "<proc>" = "\<p>\<r>\<o>\<c>"
begin

text \<open>The section provides the initial empty semantics of computation states
  serving as the base for any further substantial formalization.\<close>

subsection \<open>Type\<close>

(* virtual_datatype \<phi>empty_ty \<comment> \<open>base of type formalization\<close> *)

unspecified_type TY
unspecified_type TY_N
type_synonym 'T type_entry = \<open>(TY_N, TY, 'T) Virtual_Datatype.Field\<close>

consts TY_CONS_OF :: \<open>TY \<Rightarrow> TY_N\<close>

interpretation "virtual_datatype" TY_CONS_OF .

(* interpretation \<phi>empty_ty TY_CONS_OF by standard simp *)

subsection \<open>Value\<close>

(* virtual_datatype \<phi>empty_val :: sep_magma \<comment> \<open>base of value formalization\<close> *)

unspecified_type VAL
unspecified_type VAL_N
type_synonym 'T value_entry = \<open>(VAL_N, VAL, 'T) Virtual_Datatype.Field\<close>
type_synonym vassn = \<open>VAL set\<close>

consts VAL_CONS_OF :: \<open>VAL \<Rightarrow> VAL_N\<close>

instance VAL :: sep_magma ..

interpretation "virtual_datatype" VAL_CONS_OF .

text \<open>The semantic value is a separation magma. It is nothing related to the semantic
  or the specification framework themselves but just to be helpful in some situation for
  formalization of some semantics such as that in aggregate the separation can represent
  concatenation of fields.\<close>

(* interpretation \<phi>empty_val VAL_CONS_OF by standard simp *)

subsubsection \<open>Deep Representation of Aggregated Values\<close>

class VAL =
  fixes to_val   :: \<open>'a \<Rightarrow> VAL\<close>
    and from_val :: \<open>VAL \<Rightarrow> 'a\<close>
  assumes from_to_val[simp]: \<open>from_val (to_val x) = x\<close>

class VALs =
  fixes to_vals    :: \<open>'a \<Rightarrow> VAL list\<close>
    and from_vals  :: \<open>VAL list \<Rightarrow> 'a\<close>
  assumes from_to_vals[simp]: \<open>from_vals (to_vals x) = x\<close>

class FIX_ARITY_VALs = VALs +
  fixes vals_arity :: \<open>'a itself \<Rightarrow> nat\<close>
  assumes length_to_vals[simp]: \<open>length (to_vals x) = vals_arity TYPE('a)\<close>

instantiation VAL :: VAL begin
definition to_val_VAL :: \<open>VAL \<Rightarrow> VAL\<close> where \<open>to_val_VAL = id\<close>
definition from_val_VAL :: \<open>VAL \<Rightarrow> VAL\<close> where \<open>from_val_VAL = id\<close>
instance by standard (simp add: to_val_VAL_def from_val_VAL_def)
end

instantiation unit :: FIX_ARITY_VALs begin
definition to_vals_unit    :: \<open>unit \<Rightarrow> VAL list\<close>   where \<open>to_vals_unit v  = []\<close>
definition from_vals_unit  :: \<open>VAL list \<Rightarrow> unit\<close>   where \<open>from_vals_unit _ = ()\<close>
definition vals_arity_unit :: \<open>unit itself \<Rightarrow> nat\<close> where \<open>vals_arity_unit _ = 0\<close>
instance by standard (simp_all add: vals_arity_unit_def to_vals_unit_def)
end

instantiation VAL :: FIX_ARITY_VALs begin
definition to_vals_VAL    :: \<open>VAL \<Rightarrow> VAL list\<close>   where \<open>to_vals_VAL v  = [v]\<close>
definition from_vals_VAL  :: \<open>VAL list \<Rightarrow> VAL\<close>   where \<open>from_vals_VAL  = hd\<close>
definition vals_arity_VAL :: \<open>VAL itself \<Rightarrow> nat\<close> where \<open>vals_arity_VAL _ = 1\<close>
instance by standard (simp_all add: to_vals_VAL_def from_vals_VAL_def vals_arity_VAL_def)
end

instantiation prod :: (FIX_ARITY_VALs, FIX_ARITY_VALs) FIX_ARITY_VALs begin

definition to_vals_prod    :: \<open>'a \<times> 'b \<Rightarrow> VAL list\<close>
  where \<open>to_vals_prod v = (case v of (v1,v2) \<Rightarrow> to_vals v1 @ to_vals v2)\<close>
definition from_vals_prod  :: \<open>VAL list \<Rightarrow> 'a \<times> 'b\<close>
  where \<open>from_vals_prod vs = (@v. to_vals v = vs)\<close>
definition vals_arity_prod :: \<open>('a \<times> 'b) itself \<Rightarrow> nat\<close>
  where \<open>vals_arity_prod _ = vals_arity TYPE('a) + vals_arity TYPE('b)\<close>

instance apply standard
  apply (clarsimp simp add: to_vals_prod_def from_vals_prod_def)
  apply (smt (verit) Eps_case_prod_eq Eps_cong append_eq_append_conv from_to_vals length_to_vals split_def)
  by (clarsimp simp add: to_vals_prod_def vals_arity_prod_def)

end

instantiation list :: (VAL) VALs begin
definition to_vals_list :: \<open>'a list \<Rightarrow> VAL list\<close> where \<open>to_vals_list = map to_val\<close>
definition from_vals_list :: \<open>VAL list \<Rightarrow> 'a list\<close> where \<open>from_vals_list = map from_val\<close>
instance by standard (induct_tac x; simp add: to_vals_list_def from_vals_list_def)
end

subsection \<open>Resource\<close>

unspecified_type RES
unspecified_type RES_N
type_synonym resource = \<open>RES_N \<Rightarrow> RES\<close>
type_synonym rassn = \<open>resource set\<close>
type_synonym 'T resource_entry = "(RES_N, RES, 'T, 'T sep_closed_set) Resource_Space.kind"

setup \<open>Sign.mandatory_path "RES"\<close>

consts DOMAIN :: \<open>RES_N \<Rightarrow> RES sep_closed_set\<close>

debt_axiomatization sort: \<open>OFCLASS(RES, sep_algebra_class)\<close>

instance RES :: sep_algebra using RES.sort .

interpretation "resource_space" RES.DOMAIN .

setup \<open>Sign.parent_path\<close>

ML_file \<open>resource_space_more.ML\<close>

ML \<open>Resource_Space.define_command \<^command_keyword>\<open>resource_space\<close> "extend resource semantics"\<close>

(*
definition "Valid_Resource = {R. (\<forall>N. R N \<in>\<^sub>S Resource_Validator N)}"

lemma Valid_Resource_1[iff]:
  \<open>1 \<in> Valid_Resource\<close>
  unfolding Valid_Resource_def by simp

lemma Valid_Resource_mult_homo:
  \<open>A ## B \<Longrightarrow> A * B \<in> Valid_Resource \<longleftrightarrow> A \<in> Valid_Resource \<and> B \<in> Valid_Resource\<close>
  unfolding Valid_Resource_def
  by (simp add: times_fun sep_disj_fun_def; blast)*)

subsection \<open>Abnormality\<close>

virtual_datatype \<phi>empty_abnormal

unspecified_type ABNM
unspecified_type ABNM_N
type_synonym 'T abnormal_entry = \<open>(ABNM_N, ABNM, 'T) Virtual_Datatype.Field\<close>

consts ABNM_CONS_OF :: \<open>ABNM \<Rightarrow> ABNM_N\<close>

interpretation \<phi>empty_abnormal ABNM_CONS_OF by standard simp

subsection \<open>All-in-One Semantics\<close>

debt_axiomatization Well_Type :: \<open>TY \<Rightarrow> VAL set\<close>
(*  where Well_Type_disjoint: \<open>ta \<noteq> tb \<Longrightarrow> Well_Type ta \<inter> Well_Type tb = {}\<close> *)

debt_axiomatization Can_EqCompare :: \<open>resource \<Rightarrow> VAL \<Rightarrow> VAL \<Rightarrow> bool\<close>
  where can_eqcmp_sym: "Can_EqCompare res A B \<longleftrightarrow> Can_EqCompare res B A"

consts EqCompare :: \<open>VAL \<Rightarrow> VAL \<Rightarrow> bool\<close>
(*  and   eqcmp_refl:  "EqCompare A A"
    and   eqcmp_sym:   "EqCompare A B \<longleftrightarrow> EqCompare B A"
    and   eqcmp_trans: "EqCompare A B \<Longrightarrow> EqCompare B C \<Longrightarrow> EqCompare A C" *)

debt_axiomatization Zero :: \<open>TY \<Rightarrow> VAL option\<close>
  where zero_well_typ: "pred_option (\<lambda>v. v \<in> Well_Type T) (Zero T)"

(* lemma Well_Type_unique:
  \<open>v \<in> Well_Type ta \<Longrightarrow> v \<in> Well_Type tb \<Longrightarrow> ta = tb\<close>
  using Well_Type_disjoint by blast

abbreviation \<open>Valid_Type T \<equiv> Inhabited (Well_Type T)\<close>*)

subsection \<open>Fiction\<close>

unspecified_type FIC
unspecified_type FIC_N

type_synonym fiction = \<open>FIC_N \<Rightarrow> FIC\<close>
type_synonym assn = \<open>fiction set\<close>
type_synonym 'T fiction_entry = "(FIC_N, FIC, 'T, unit) Resource_Space.kind"

setup \<open>Sign.mandatory_path "FIC"\<close>

consts DOMAIN :: \<open>FIC_N \<Rightarrow> FIC sep_homo_set\<close>

debt_axiomatization sort: \<open>OFCLASS(FIC, sep_algebra_class)\<close>

setup \<open>Sign.parent_path\<close>

instance FIC :: sep_algebra using FIC.sort .

consts INTERPRET :: \<open>FIC_N \<Rightarrow> (FIC, resource) interp\<close>

interpretation FIC: fictional_space FIC.DOMAIN INTERPRET .

definition "INTERP_RES fic \<equiv> RES.SPACE \<inter> {_. fic \<in> FIC.SPACE } \<inter> \<I> FIC.INTERP fic"
  \<comment> \<open>Interpret a fiction\<close>

lemma In_INTERP_RES:
  \<open>r \<in> INTERP_RES fic \<longleftrightarrow> r \<in> RES.SPACE \<and> fic \<in> FIC.SPACE \<and> r \<in> \<I> FIC.INTERP fic\<close>
  unfolding INTERP_RES_def by simp

definition INTERP_SPEC :: \<open>assn \<Rightarrow> rassn\<close>
  \<comment> \<open>Interpret a fictional specification\<close>
  where "INTERP_SPEC T = { res. \<exists>fic. fic \<in> T \<and> res \<in> INTERP_RES fic }"

lemma INTERP_SPEC:
  \<open>res \<in> INTERP_SPEC T \<longleftrightarrow> (\<exists>fic. fic \<in> T \<and> res \<in> INTERP_RES fic)\<close>
  unfolding INTERP_SPEC_def by simp

lemma INTERP_SPEC_subset[intro, simp]: \<open>A \<subseteq> B \<Longrightarrow> INTERP_SPEC A \<subseteq> INTERP_SPEC B\<close>
  unfolding INTERP_SPEC_def subset_iff by simp blast

lemma INTERP_SPEC_plus[iff]:
  \<open>INTERP_SPEC (A + B) = INTERP_SPEC A + INTERP_SPEC B\<close>
  unfolding INTERP_SPEC_def plus_set_def by simp blast

lemma INTERP_SPEC_empty[intro, simp]:
  \<open>S = {} \<Longrightarrow> INTERP_SPEC S = {}\<close>
  unfolding INTERP_SPEC_def set_eq_iff by simp

lemma INTERP_SPEC_0[simp]:
  \<open>INTERP_SPEC 0  = 0\<close>
  \<open>INTERP_SPEC {} = {}\<close>
  unfolding INTERP_SPEC_def zero_set_def by simp+

ML_file \<open>fiction_space_more.ML\<close>

ML \<open>Fiction_Space.define_command \<^command_keyword>\<open>fiction_space\<close> "extend fictions"\<close>

(*
lemma INTERP_mult:
  \<open> Fic_Space f1
\<Longrightarrow> Fic_Space f2
\<Longrightarrow> dom1 r1 \<inter> dom1 r2 = {}
\<Longrightarrow> dom1 f1 \<inter> dom1 f2 = {}
\<Longrightarrow> r1 \<in> \<I> INTERP f1
\<Longrightarrow> r2 \<in> \<I> INTERP f2
\<Longrightarrow> f1 ## f2
\<Longrightarrow> r1 * r2 \<in> \<I> INTERP (f1 * f2) \<and> r1 ## r2\<close>
  unfolding INTERP_def Fic_Space_def
  by (simp add: dom1_sep_mult_disjoint times_fun prod.union_disjoint
                disjoint_dom1_eq_1[of f1 f2],
      meson dom1_disjoint_sep_disj times_set_I) *)

subsection \<open>Formalization of Computation\<close>

subsubsection \<open>Explicit Annotation of Semantic Arguments and Returns\<close>

text \<open>Arguments and Returns are wrapped by \<phi>arg type.
  It helps the programming framework and syntax parser to recognize which one is an argument
  or a return, among values that may be used for other purposes of specification.\<close>

datatype ('a::VALs) \<phi>arg = \<phi>arg (dest: 'a)
hide_const (open) dest

lemma \<phi>arg_forall: \<open>All P \<longleftrightarrow> (\<forall>x. P (\<phi>arg x))\<close> by (metis \<phi>arg.exhaust)
lemma \<phi>arg_exists: \<open>Ex P  \<longleftrightarrow> (\<exists>x. P (\<phi>arg x))\<close> by (metis \<phi>arg.exhaust)
lemma \<phi>arg_All: \<open>(\<And>x. PROP P x) \<equiv> (\<And>x. PROP P (\<phi>arg x))\<close>
proof
  fix x :: 'a assume A: \<open>(\<And>x. PROP P x)\<close> then show \<open>PROP P (\<phi>arg x)\<close> .
next
  fix x :: \<open>'a \<phi>arg\<close> assume A: \<open>\<And>x. PROP P (\<phi>arg x)\<close>
  from \<open>PROP P (\<phi>arg (\<phi>arg.dest x))\<close> show "PROP P x" by simp
qed

definition \<open>\<phi>V_none = \<phi>arg ()\<close>
definition \<phi>V_pair (infixr "\<^bold>," 10) where \<open>\<phi>V_pair x y = \<phi>arg (\<phi>arg.dest x, \<phi>arg.dest y)\<close>
definition \<open>\<phi>V_case_prod f x \<equiv> case x of \<phi>arg (a,b) \<Rightarrow> f (\<phi>arg a) (\<phi>arg b)\<close>
definition \<open>\<phi>V_fst x = map_\<phi>arg fst x\<close>
definition \<open>\<phi>V_snd x = map_\<phi>arg snd x\<close>
abbreviation \<open>\<phi>V_nil \<equiv> \<phi>arg []\<close>
definition \<open>\<phi>V_cons h l = \<phi>arg (\<phi>arg.dest h # \<phi>arg.dest l)\<close>
definition \<open>\<phi>V_hd l = \<phi>arg (hd (\<phi>arg.dest l))\<close>
definition \<open>\<phi>V_tl l = \<phi>arg (tl (\<phi>arg.dest l))\<close>

lemma \<phi>V_simps[simp]:
  \<open>\<phi>V_pair (\<phi>V_fst v) (\<phi>V_snd v) = v\<close>
  \<open>\<phi>V_fst (\<phi>V_pair u y) = u\<close>
  \<open>\<phi>V_snd (\<phi>V_pair x u) = u\<close>
  \<open>\<phi>V_fst (\<phi>arg (xa,xb)) = \<phi>arg xa\<close>
  \<open>\<phi>V_snd (\<phi>arg (xa,xb)) = \<phi>arg xb\<close>
  \<open>\<phi>V_cons (\<phi>arg h) (\<phi>arg l) = \<phi>arg (h#l)\<close>
  \<open>\<phi>V_hd (\<phi>V_cons hv lv) = hv\<close>
  \<open>\<phi>V_tl (\<phi>V_cons hv lv) = lv\<close>
  \<open>\<phi>V_case_prod f (\<phi>V_pair a b) = f a b\<close>
  \<open>\<phi>V_case_prod (\<lambda>a b. f2 (\<phi>V_pair a b)) = f2\<close>
  \<open>\<phi>V_case_prod (\<lambda>a. \<phi>V_case_prod (\<lambda>b c. f3 (\<phi>V_pair a (\<phi>V_pair b c)))) = f3\<close>
  \<open>\<phi>V_case_prod (\<lambda>a. \<phi>V_case_prod (\<lambda>b. \<phi>V_case_prod (\<lambda>c d. f4 (\<phi>V_pair a (\<phi>V_pair b (\<phi>V_pair c d)))))) = f4\<close>
  unfolding \<phi>V_pair_def \<phi>V_fst_def \<phi>V_snd_def \<phi>V_cons_def \<phi>V_hd_def \<phi>V_tl_def \<phi>V_case_prod_def
    apply (cases v, simp)
    apply (cases v, simp)
    apply (cases v, simp)
    apply simp apply simp apply simp
    apply simp apply simp apply simp
    apply (simp add: fun_eq_iff \<phi>arg_forall)
    apply (simp add: fun_eq_iff \<phi>arg_forall)
    apply (simp add: fun_eq_iff \<phi>arg_forall) .

definition unreachable :: \<open>'a::VALs\<close> where \<open>unreachable = undefined\<close>

paragraph \<open>More auxiliary properties\<close>

lemma split_paired_All_\<phi>arg:
  "(\<forall>x. P x) \<longleftrightarrow> (\<forall>a b. P (\<phi>V_pair a b))"
  by (metis \<phi>V_simps(1))

lemma split_paired_Ex_\<phi>arg:
  "(\<exists>x. P x) \<longleftrightarrow> (\<exists>a b. P (\<phi>V_pair a b))"
  by (metis \<phi>V_simps(1))

lemma split_paired_all_\<phi>arg:
  "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (\<phi>V_pair a b))"
  unfolding \<phi>arg_All \<phi>V_pair_def split_paired_all by simp

lemma split_paired_All_\<phi>arg_unit:
  "(\<forall>x. P x) \<longleftrightarrow> P \<phi>V_none"
  by (simp add: \<phi>arg_forall \<phi>V_none_def)

lemma split_paired_Ex_\<phi>arg_unit:
  "(\<exists>x. P x) \<longleftrightarrow> P \<phi>V_none"
  by (simp add: \<phi>arg_exists \<phi>V_none_def)

lemma split_paired_all_\<phi>arg_unit:
  "(\<And>x. PROP P x) \<equiv> PROP P \<phi>V_none"
  unfolding \<phi>arg_All \<phi>V_pair_def split_paired_all \<phi>V_none_def by simp

(* datatype unreachable = unreachable

instantiation unreachable :: VALs begin
definition to_vals_unreachable :: \<open>unreachable \<Rightarrow> VAL list\<close> where \<open>to_vals_unreachable _ = undefined\<close>
definition from_vals_unreachable :: \<open>VAL list \<Rightarrow> unreachable\<close> where \<open>from_vals_unreachable _ = unreachable\<close>
definition vals_arity_unreachable :: \<open>unreachable itself \<Rightarrow> nat\<close>
  where \<open>vals_arity_unreachable _ = length (undefined::VAL list)\<close>

instance apply standard
  apply (simp_all add: to_vals_unreachable_def from_vals_unreachable_def vals_arity_unreachable_def)
  by (metis unreachable.exhaust)
end
*)

subsubsection \<open>Monadic Formalization\<close>

text \<open>\<open>('ret,'ex,'RES_N,'RES) state\<close> represents any potential returning state of a program.

\<^item> \<open>Success v r\<close> represents a successful returning state with return value \<open>v\<close> and resulted resource
  state \<open>r\<close>.

\<^item> \<open>Abnormality v r\<close> represents the computation throws an exception of value \<open>v\<close>, at the
  moment when the state of the resources is \<open>r\<close>.

\<^item> \<open>NonTerm\<close> represents the execution does not terminate.

\<^item> \<open>Invalid\<close> represents the computation is invalid.
  It defines the domain of valid programs, which are the ones that never never generates
  an execution path that results in \<open>Invalid\<close>.

\<^item> \<open>Assumption_Violated\<close> represents the computation that results in an execution path that is not
  considered or modelled by the trust base.
  For example, the formalization of the allocation instruction may assume the size of the object
  to be allocated is always less than the size of the address space (e.g., \<open>2\<^sup>3\<^sup>2\<close> bytes).
  In another case users may assume the size of their objects is representable by \<open>size_t\<close>.
  \<open>Assumption_Violated\<close> enables an easy way for semantic assumptions, e.g., to assume \<open>P\<close>,
  \[ \<open>if P then do-something else return Assumption_Violated\<close> \]
  \<open>Assumption_Violated\<close> is admitted by any post-condition, i.e.,
  \[ {\<top>} return Assumption_Violated {\<bottom>} \]
  Computations returning \<open>Assumption_Violated\<close> are trusted by the trust base.
  This additional increment in the trust base is controllable, because whether and where to
  use the \<open>Assumption_Violated\<close>, this is determined by the formalization of instruction semantics,
  which belongs to the trust base already.
\<close>

declare [ [typedef_overloaded] ]

datatype 'ret comp =
      Success \<open>'ret::VALs \<phi>arg\<close> (resource: resource)
    | Abnormality \<open>ABNM\<close> (resource: resource)
    | Invalid
    | AssumptionBroken
    | NonTerm

declare [ [typedef_overloaded = false] ]

lemma split_comp_All:
  \<open>All P \<longleftrightarrow> (\<forall>v r. P (Success v r)) \<and> (\<forall>v r. P (Abnormality v r)) \<and> P Invalid
                \<and> P AssumptionBroken \<and> P NonTerm\<close>
  by (metis comp.exhaust)

lemma split_comp_Ex:
  \<open>Ex P \<longleftrightarrow> (\<exists>v r. P (Success v r)) \<or> (\<exists>v r. P (Abnormality v r)) \<or> P Invalid
                \<or> P AssumptionBroken \<or> P NonTerm\<close>
  by (metis comp.exhaust)

hide_const(open) resource

declare comp.split[split]

text \<open>Procedure is the basic building block of a program on the semantics formalization.
It represents a segment of a program, which is defined inductively,

\<^item> Any instruction instantiated by any arguments is a procedure
\<^item> Any lambda abstraction of a procedure is a procedure
\<^item> Sequential composition \<open>f \<bind> g\<close> is a procedure iff \<open>f, g\<close> are procedures.
\<^item> A control flow combinator combines several procedures into a procedure

Control flow combinator does not include the sequential composition combinator \<open>\<bind>\<close>.

Any function, routine, or sub-routine in high level languages is a procedure but a procedure
does not necessarily corresponds to them nor any basic block in assemble representations.

A procedure is not required to be a valid program necessarily.
Procedure is only a syntax structure and the semantics of invalid operations or programs
is expressed by returning \<open>Invalid\<close>.

%% Not Required:
% \<^bold>\<open>Normal Form of Procedures\<close> (NFP) is defined by the following BNF,
% \begin{align}
% \<open>NFP p\<close> \Coloneqq & \<open>return v\<close>
%                 | & \<open>i \<bind> p\<close>   & &\text{for \<open>i \<in> Instructions\<close>} \\
%                 | & \<open>\<lambda>x. p\<close>
%                 | & \<open>c p p \<cdots> p\<close> & &\text{\<open>c\<close> is a control flow combinator.}
% \end{align}
% It essentially says any lambda abstraction occurring in the left hand side of a sequential
% composition \<open>(\<lambda>x. f) \<bind> g\<close> can be expanded to the whole term, i.e., \<open>\<lambda>x. (f \<bind> g)\<close>.
% And any body of the control flows is also in NFP.
% It is obvious the NFP can express equivalently any procedure.
% NFP is used later in CoP to construct any procedure.

% TODO: value annotation and slightly-shallow representation.
 \<close>

type_synonym 'ret proc = "resource \<Rightarrow> 'ret comp set"
type_synonym ('arg,'ret) proc' = "'arg \<phi>arg \<Rightarrow> 'ret proc"

definition bind :: "'a::VALs proc \<Rightarrow> ('a,'b) proc' \<Rightarrow> 'b::VALs proc"  ("_ \<bind>/ _" [75,76] 75)
  where "bind f g = (\<lambda>res. \<Union>((\<lambda>y. case y of Success v x \<Rightarrow> g v x
                                           | Abnormality v x \<Rightarrow> {Abnormality v x}
                                           | Invalid \<Rightarrow> {Invalid}
                                           | NonTerm \<Rightarrow> {NonTerm}
                                           | AssumptionBroken \<Rightarrow> {AssumptionBroken}
                              ) ` f res))"

abbreviation bind' ("_ \<ggreater>/ _" [75,76] 75)
  where \<open>bind' f g \<equiv> (f \<bind> (\<lambda>_. g))\<close>

definition \<open>det_lift f x = {f x}\<close>

definition \<open>Return = det_lift o Success\<close>

definition Nondet :: \<open>'ret proc \<Rightarrow> 'ret proc \<Rightarrow> 'ret proc\<close>
  where \<open>Nondet f g = (\<lambda>res. f res \<union> g res)\<close>

lemma proc_bind_SKIP'[simp]:
  "f \<bind> Return \<equiv> f"
  "Return any \<bind> ff \<equiv> ff any"
  "(g \<ggreater> Return any) \<ggreater> f \<equiv> g \<ggreater> f"
  "(\<lambda>v. Return v \<bind> h) \<equiv> h"
  unfolding bind_def atomize_eq fun_eq_iff det_lift_def set_eq_iff Return_def
  by (clarsimp; metis comp.exhaust)+

lemma proc_bind_return_none[simp]:
  "f_nil \<ggreater> Return \<phi>V_none \<equiv> f_nil"
  for f_nil :: \<open>unit proc\<close>
  unfolding bind_def atomize_eq fun_eq_iff det_lift_def set_eq_iff Return_def \<phi>V_none_def
  apply (clarsimp)
  subgoal for x y
  apply rule
    apply clarsimp
    subgoal for z
      apply (cases z; simp add: \<phi>arg_All) .
  apply (rule bexI[where x=y]; clarsimp simp add: \<phi>arg_All) . .

lemmas proc_bind_SKIP[simp] =
  proc_bind_SKIP'[unfolded Return_def, simplified]
  proc_bind_return_none[unfolded Return_def, simplified]

lemma proc_bind_assoc[simp]:
  "((A \<bind> B) \<bind> C) = (A \<bind> (\<lambda>x. B x \<bind> C))"
  unfolding bind_def fun_eq_iff det_lift_def set_eq_iff
  by clarsimp

end


(*  Title:      HOL/Auth/Event.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Datatype of events; function "spies"; freshness

"bad" agents have been broken by the Spy; their private keys and internal
    stores are visible to him
*)

section\<open>Theory of Events for Security Protocols against Dolev-Yao\<close>

theory Event imports Message begin

consts  (*Initial states of agents -- parameter of the construction*)
  initState :: "agent => msg set"

datatype
  event = Says  agent agent msg
        | Gets  agent       msg
        | Notes agent       msg

consts
  bad    :: "agent set"                         \<comment> \<open>compromised agents\<close>

text\<open>Spy has access to his own key for spoof messages, but Server is secure\<close>
specification (bad)
  Spy_in_bad     [iff]: "Spy \<in> bad"
  Server_not_bad [iff]: "Server \<notin> bad"
    by (rule exI [of _ "{Spy}"], simp)

primrec knows :: "agent => event list => msg set"
where
  knows_Nil:   "knows A [] = initState A"
| knows_Cons:
    "knows A (ev # evs) =
       (if A = Spy then
        (case ev of
           Says A' B X => insert X (knows Spy evs)
         | Gets A' X => knows Spy evs
         | Notes A' X  =>
             if A' \<in> bad then insert X (knows Spy evs) else knows Spy evs)
        else
        (case ev of
           Says A' B X =>
             if A'=A then insert X (knows A evs) else knows A evs
         | Gets A' X    =>
             if A'=A then insert X (knows A evs) else knows A evs
         | Notes A' X    =>
             if A'=A then insert X (knows A evs) else knows A evs))"

(*
  Case A=Spy on the Gets event
  enforces the fact that if a message is received then it must have been sent,
  therefore the oops case must use Notes
*)

text\<open>The constant "spies" is retained for compatibility's sake\<close>

abbreviation (input)
  spies  :: "event list => msg set" where
  "spies == knows Spy"

(*Set of items that might be visible to somebody:
    complement of the set of fresh items*)

primrec used :: "event list => msg set"
where
  used_Nil:   "used []         = (UN B. parts (initState B))"
| used_Cons:  "used (ev # evs) =
                     (case ev of
                        Says A B X => parts {X} \<union> used evs
                      | Gets A X   => used evs
                      | Notes A X  => parts {X} \<union> used evs)"
    \<comment> \<open>The case for @{term Gets} seems anomalous, but @{term Gets} always
        follows @{term Says} in real protocols.  Seems difficult to change.
        See @{text Gets_correct} in theory @{text "Guard/Extensions.thy"}.\<close>

lemma Notes_imp_used [rule_format]: "Notes A X \<in> set evs --> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

lemma Says_imp_used [rule_format]: "Says A B X \<in> set evs --> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

subsection\<open>Function @{term knows}\<close>

(*Simplifying
 parts(insert X (knows Spy evs)) = parts{X} \<union> parts(knows Spy evs).
  This version won't loop with the simplifier.*)
lemmas parts_insert_knows_A = parts_insert [of _ "knows A evs"] for A evs

text\<open>Letting the Spy see "bad" agents' notes avoids redundant case-splits
      on whether @{term "A=Spy"} and whether @{term "A\<in>bad"}\<close>
lemma knows_Spy_Notes [simp]:
     "knows Spy (Notes A X # evs) =
          (if A:bad then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Gets [simp]: "knows Spy (Gets A X # evs) = knows Spy evs"
by simp

lemma knows_Spy_subset_knows_Spy_Says:
     "knows Spy evs \<subseteq> knows Spy (Says A B X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Notes:
     "knows Spy evs \<subseteq> knows Spy (Notes A X # evs)"
by force

lemma knows_Spy_subset_knows_Spy_Gets:
     "knows Spy evs \<subseteq> knows Spy (Gets A X # evs)"
by (simp add: subset_insertI)

text\<open>Spy sees what is sent on the traffic\<close>
lemma Says_imp_knows_Spy [rule_format]:
     "Says A B X \<in> set evs --> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Notes_imp_knows_Spy [rule_format]:
     "Notes A X \<in> set evs --> A: bad --> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

text\<open>Elimination rules: derive contradictions from old Says events containing
  items known to be fresh\<close>
lemmas Says_imp_parts_knows_Spy =
       Says_imp_knows_Spy [THEN parts.Inj, THEN revcut_rl]

lemmas knows_Spy_partsEs =
     Says_imp_parts_knows_Spy parts.Body [THEN revcut_rl]

lemmas Says_imp_analz_Spy = Says_imp_knows_Spy [THEN analz.Inj]

text\<open>Compatibility for the old "spies" function\<close>
lemmas spies_partsEs = knows_Spy_partsEs
lemmas Says_imp_spies = Says_imp_knows_Spy
lemmas parts_insert_spies = parts_insert_knows_A [of _ Spy]

subsection\<open>Knowledge of Agents\<close>

lemma knows_Says: "knows A (Says A B X # evs) = insert X (knows A evs)"
by simp

lemma knows_Notes: "knows A (Notes A X # evs) = insert X (knows A evs)"
by simp

lemma knows_Gets:
     "A \<noteq> Spy --> knows A (Gets A X # evs) = insert X (knows A evs)"
by simp

lemma knows_subset_knows_Says: "knows A evs \<subseteq> knows A (Says A' B X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Notes: "knows A evs \<subseteq> knows A (Notes A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Gets: "knows A evs \<subseteq> knows A (Gets A' X # evs)"
by (simp add: subset_insertI)

text\<open>Agents know what they say\<close>
lemma Says_imp_knows [rule_format]: "Says A B X \<in> set evs --> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>Agents know what they note\<close>
lemma Notes_imp_knows [rule_format]: "Notes A X \<in> set evs --> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>Agents know what they receive\<close>
lemma Gets_imp_knows_agents [rule_format]:
     "A \<noteq> Spy --> Gets A X \<in> set evs --> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

text\<open>What agents DIFFERENT FROM Spy know
  was either said, or noted, or got, or known initially\<close>
lemma knows_imp_Says_Gets_Notes_initState [rule_format]:
     "[| X \<in> knows A evs; A \<noteq> Spy |] ==> \<exists>B.
  Says A B X \<in> set evs | Gets A X \<in> set evs | Notes A X \<in> set evs | X \<in> initState A"
apply (erule rev_mp)
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>What the Spy knows -- for the time being --
  was either said or noted, or known initially\<close>
lemma knows_Spy_imp_Says_Notes_initState [rule_format]:
     "[| X \<in> knows Spy evs |] ==> \<exists>A B.
  Says A B X \<in> set evs | Notes A X \<in> set evs | X \<in> initState Spy"
apply (erule rev_mp)
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

lemma parts_knows_Spy_subset_used: "parts (knows Spy evs) \<subseteq> used evs"
apply (induct_tac "evs", force)
apply (simp add: parts_insert_knows_A knows_Cons add: event.split, blast)
done

lemmas usedI = parts_knows_Spy_subset_used [THEN subsetD, intro]

lemma initState_into_used: "X \<in> parts (initState B) ==> X \<in> used evs"
apply (induct_tac "evs")
apply (simp_all add: parts_insert_knows_A split: event.split, blast)
done

lemma used_Says [simp]: "used (Says A B X # evs) = parts{X} \<union> used evs"
by simp

lemma used_Notes [simp]: "used (Notes A X # evs) = parts{X} \<union> used evs"
by simp

lemma used_Gets [simp]: "used (Gets A X # evs) = used evs"
by simp

lemma used_nil_subset: "used [] \<subseteq> used evs"
apply simp
apply (blast intro: initState_into_used)
done

text\<open>NOTE REMOVAL--laws above are cleaner, as they don't involve "case"\<close>
declare knows_Cons [simp del]
        used_Nil [simp del] used_Cons [simp del]

text\<open>For proving theorems of the form @{term "X \<notin> analz (knows Spy evs) --> P"}
  New events added by induction to "evs" are discarded.  Provided
  this information isn't needed, the proof will be much shorter, since
  it will omit complicated reasoning about @{term analz}.\<close>

lemmas analz_mono_contra =
       knows_Spy_subset_knows_Spy_Says [THEN analz_mono, THEN contra_subsetD]
       knows_Spy_subset_knows_Spy_Notes [THEN analz_mono, THEN contra_subsetD]
       knows_Spy_subset_knows_Spy_Gets [THEN analz_mono, THEN contra_subsetD]

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (induct e, auto simp: knows_Cons)

lemma initState_subset_knows: "initState A \<subseteq> knows A evs"
apply (induct_tac evs, simp)
apply (blast intro: knows_subset_knows_Cons [THEN subsetD])
done

text\<open>For proving \<open>new_keys_not_used\<close>\<close>
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts (G \<union> H)) | Key (invKey K) \<in> parts H"
by (force
    dest!: parts_insert_subset_Un [THEN keysFor_mono, THEN [2] rev_subsetD]
           analz_subset_parts [THEN keysFor_mono, THEN [2] rev_subsetD]
    intro: analz_subset_parts [THEN subsetD] parts_mono [THEN [2] rev_subsetD])

lemmas analz_impI = impI [where P = "Y \<notin> analz (knows Spy evs)"] for Y evs

ML
\<open>
fun analz_mono_contra_tac ctxt =
  resolve_tac ctxt @{thms analz_impI} THEN'
  REPEAT1 o (dresolve_tac ctxt @{thms analz_mono_contra})
  THEN' mp_tac ctxt
\<close>

method_setup analz_mono_contra = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (REPEAT_FIRST (analz_mono_contra_tac ctxt)))\<close>
    "for proving theorems of the form X \<notin> analz (knows Spy evs) --> P"

text\<open>Useful for case analysis on whether a hash is a spoof or not\<close>

lemmas syan_impI = impI [where P = "Y \<notin> synth (analz (knows Spy evs))"] for Y evs

ML
\<open>
fun synth_analz_mono_contra_tac ctxt =
  resolve_tac ctxt @{thms syan_impI} THEN'
  REPEAT1 o
    (dresolve_tac ctxt
     [@{thm knows_Spy_subset_knows_Spy_Says} RS @{thm synth_analz_mono} RS @{thm contra_subsetD},
      @{thm knows_Spy_subset_knows_Spy_Notes} RS @{thm synth_analz_mono} RS @{thm contra_subsetD},
      @{thm knows_Spy_subset_knows_Spy_Gets} RS @{thm synth_analz_mono} RS @{thm contra_subsetD}])
  THEN'
  mp_tac ctxt
\<close>

method_setup synth_analz_mono_contra = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (REPEAT_FIRST (synth_analz_mono_contra_tac ctxt)))\<close>
    "for proving theorems of the form X \<notin> synth (analz (knows Spy evs)) --> P"

end