section \<open>Application example from IoT healthcare\<close>
text \<open>The  example of an IoT healthcare systems is taken from the context of the CHIST-ERA project
   by (simp add: corona_scenario'_def ex_graph'_def pub_def shop_def atI_def ex_loc_ass_def)
SUCCESS \cite{suc:16}.  In this system architecture, data is collected by sensors
in the home or via a smart phone helping to monitor bio markers of the patient. The data
collection is in a cloud based server to enable hospitals (or scientific institutions)
to access the data which is controlled via the smart phone.
The identities Patient and Doctor represent patients
and their doctors; double quotes ''s'' indicate strings
in Isabelle/HOL.
The global policy is `only the patient and the doctor can access the data in the cloud'.\<close>
theory CoronaApp
imports Infrastructure
begin
text \<open>Local policies are represented as a function over an @{text \<open>igraph G\<close>}
      that additionally assigns each location of a scenario to its local policy
      given as a pair of requirements to an actor (first element of the pair) in
      order to grant him actions in the location (second element of the pair).
      The predicate @{text \<open>@G\<close>} checks whether an actor is at a given location
       in the @{text \<open>igraph G\<close>}.\<close>
locale scenarioCorona =

fixes corona_actors :: "identity set"
defines corona_actors_def: "corona_actors \<equiv> {''Alice'', ''Bob'', ''Charly'', ''David'', ''Eve''}"

fixes corona_locations :: "location set"
defines corona_locations_def: "corona_locations \<equiv> {Location 0, Location 1}"
fixes pub :: "location"
defines pub_def: "pub \<equiv> Location 0"
fixes shop :: "location"
defines shop_def: "shop \<equiv> Location 1"

(* not relevant any more. It was made for earlier versions where the intersection happened
   implicitly in the semantics.
fixes identifiable :: "[infrastructure,actor,efid, location] \<Rightarrow> bool"
defines identifiable_def: "identifiable I a eid l\<equiv> is_singleton{(Id,Eid). (Id, Eid) \<in> kgra (graphI I) a l \<and> Eid = eid}"
fixes global_policy :: "[infrastructure, efid] \<Rightarrow> bool"
defines global_policy_def: "global_policy I eid \<equiv>  (\<exists> l. \<not>(identifiable I (Actor ''Eve'') eid l))"
*)

fixes identifiable' :: "[efid, (identity * efid)set] \<Rightarrow> bool"
defines identifiable'_def: "identifiable' eid A \<equiv> is_singleton{(Id,Eid). (Id, Eid) \<in> A \<and> Eid = eid}"

(* This version is apparently different from the below global_policy'' where we use the image operator
fixes global_policy' :: "[infrastructure, efid] \<Rightarrow> bool"
defines global_policy'_def: "global_policy' I eid \<equiv>
             \<not>(identifiable' eid
                ((\<Inter> {A. (\<exists> l \<in> nodes(graphI I). (A = (kgra(graphI I)(Actor ''Eve'') l)))})
                 - {(x,y). x = ''Eve''}))"
*)

fixes global_policy'' :: "[infrastructure, efid] \<Rightarrow> bool"
defines global_policy''_def: "global_policy'' I eid \<equiv>
             \<not>(identifiable' eid
                ((\<Inter> (kgra(graphI I)(''Eve'')`(nodes(graphI I))))
                 - {(x,y). x = ''Eve''}))"

fixes global_policy :: "[infrastructure, efid] \<Rightarrow> bool"
defines global_policy_def: "global_policy I eid \<equiv>
             \<forall> L. L \<subseteq> nodes(graphI I) \<longrightarrow> (\<not>(identifiable' eid
               ((\<Inter> (kgra(graphI I)(''Eve'')`L))
                          - {(x,y). x = ''Eve''})))"

fixes ex_creds :: "identity \<Rightarrow> efid"
defines ex_creds_def:
          "ex_creds \<equiv> (\<lambda> x. if x = ''Alice'' then Efid 1 else
                            (if x = ''Bob'' then  Efid 2 else
                            (if x = ''Charly'' then Efid 3 else
                            (if x = ''David'' then Efid 4 else
                            (if x = ''Eve'' then Efid 5 else
                            (if x = ''Flo'' then Efid 6 else Efid 0))))))"

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

fixes ex_loc_ass :: "location \<Rightarrow> identity set"
defines ex_loc_ass_def: "ex_loc_ass \<equiv>
          (\<lambda> x. if x = pub then {''Alice'', ''Bob'', ''Eve''}
                 else (if x = shop then {''Charly'', ''David'', ''Flo''}
                       else {}))"
fixes ex_loc_ass' :: "location \<Rightarrow> identity set"
defines ex_loc_ass'_def: "ex_loc_ass' \<equiv>
          (\<lambda> x. if x = pub then {''Alice'', ''Eve''}
                 else (if x = shop then { ''Bob'', ''Charly'', ''David'', ''Flo''}
                       else {}))"
fixes ex_loc_ass'' :: "location \<Rightarrow> identity set"
defines ex_loc_ass''_def: "ex_loc_ass'' \<equiv>
          (\<lambda> x. if x = pub then {''Alice''}
                 else (if x = shop then {''Eve'', ''Bob'', ''Charly'', ''David'', ''Flo''}
                       else {}))"

fixes ex_efids :: "location \<Rightarrow> efid set"
defines ex_efids_def: "ex_efids \<equiv>
          (\<lambda> x. if x = pub then {Efid 1, Efid 2, Efid 5}
                else (if x = shop then {Efid 3, Efid 4, Efid 6}
                      else {}))"

fixes ex_efids' :: "location \<Rightarrow> efid set"
defines ex_efids'_def: "ex_efids' \<equiv>
          (\<lambda> x. if x = pub then {Efid 1, Efid 5}
                else (if x = shop then {Efid 2, Efid 3, Efid 4, Efid 6}
                      else {}))"

fixes ex_efids'' :: "location \<Rightarrow> efid set"
defines ex_efids''_def: "ex_efids'' \<equiv>
          (\<lambda> x. if x = pub then {Efid 1}
                else (if x = shop then {Efid 5, Efid 2, Efid 3, Efid 4, Efid 6}
                      else {}))"

fixes ex_knos :: "identity \<Rightarrow> location \<Rightarrow> (identity * efid) set"
defines ex_knos_def: "ex_knos \<equiv> (\<lambda> x :: identity.
                  (if x = ''Eve'' then (\<lambda> l :: location. {} :: (identity * efid) set)
                   else (\<lambda> l :: location. {} :: (identity * efid) set)))"

fixes ex_knos' :: "identity \<Rightarrow> location \<Rightarrow> (identity * efid) set"
defines ex_knos'_def: "ex_knos' \<equiv> (\<lambda> x :: identity.
                  (if x = ''Eve'' then
                     (\<lambda> l :: location.
                        (if l = pub then
                                  ({(''Alice'', Efid 1),(''Alice'', Efid 2),(''Alice'', Efid 5),
                                    (''Bob'', Efid 1),(''Bob'', Efid 2),(''Bob'', Efid 5),
                                    (''Eve'', Efid 1),(''Eve'', Efid 2),(''Eve'', Efid 5)})
                         else {}))
                   else (\<lambda> l :: location. {} :: (identity * efid) set)))"

fixes ex_knos'' :: "identity \<Rightarrow> location \<Rightarrow> (identity * efid) set"
defines ex_knos''_def: "ex_knos'' \<equiv> (\<lambda> x :: identity.
                  (if x = ''Eve'' then
                      (\<lambda> l :: location.
                           (if l = pub then
                                  ({(''Alice'', Efid 1),(''Alice'', Efid 2),(''Alice'', Efid 5),
                                    (''Bob'', Efid 1),(''Bob'', Efid 2),(''Bob'', Efid 5),
                                    (''Eve'', Efid 1),(''Eve'', Efid 2),(''Eve'', Efid 5)})
                            else (if l = shop then
                                     ({(''Eve'', Efid 5),(''Eve'', Efid 2),(''Eve'', Efid 3),(''Eve'', Efid 4),(''Eve'', Efid 6),
                                       (''Bob'', Efid 5),(''Bob'', Efid 2),(''Bob'', Efid 3),(''Bob'', Efid 4),(''Bob'', Efid 6),
                                       (''Charly'', Efid 5),(''Charly'', Efid 2),(''Charly'', Efid 3),(''Charly'', Efid 4),(''Charly'', Efid 6),
                                       (''David'', Efid 5),(''David'', Efid 2),(''David'', Efid 3),(''David'', Efid 4),(''David'', Efid 6),
                                       (''Flo'', Efid 5),(''Flo'', Efid 2),(''Flo'', Efid 3),(''Flo'', Efid 4),(''Flo'', Efid 6)})
                                   else {})))
                   else (\<lambda> l :: location. {} :: (identity * efid) set)))"

(* The nicer representation with case suffers from
   not so nice presentation in the cases (need to unfold the syntax)
fixes ex_loc_ass_alt :: "location \<Rightarrow> identity set"
defines ex_loc_ass_alt_def: "ex_loc_ass_alt \<equiv>
          (\<lambda> x.  (case x of
             Location (Suc 0) \<Rightarrow> {''Alice'', ''Bob'', ''Eve''}
           | Location (Suc (Suc 0)) \<Rightarrow> {''Charly'', ''David''}
           |  _ \<Rightarrow> {}))"
*)

(* initial *)
fixes ex_graph :: "igraph"
defines ex_graph_def: "ex_graph \<equiv> Lgraph {(pub, shop)} ex_loc_ass ex_creds ex_locs ex_efids ex_knos"

(* Eve gets the ex_knos *)
fixes ex_graph' :: "igraph"
defines ex_graph'_def: "ex_graph' \<equiv> Lgraph {(pub, shop)} ex_loc_ass ex_creds ex_locs ex_efids ex_knos'"

(* Bob goes to shop *)
fixes ex_graph'' :: "igraph"
defines ex_graph''_def: "ex_graph'' \<equiv> Lgraph {(pub, shop)} ex_loc_ass' ex_creds ex_locs ex_efids' ex_knos'"

(* Eve goes to shop *)
fixes ex_graph''' :: "igraph"
defines ex_graph'''_def: "ex_graph''' \<equiv> Lgraph {(pub, shop)} ex_loc_ass'' ex_creds ex_locs ex_efids'' ex_knos'"

(* Eve gets ex_knos at shop *)
fixes ex_graph'''' :: "igraph"
defines ex_graph''''_def: "ex_graph'''' \<equiv> Lgraph {(pub, shop)} ex_loc_ass'' ex_creds ex_locs ex_efids'' ex_knos''"

(* Same as above: the nicer representation with case suffers from
   not so nice presentation in the cases (need to unfold the syntax)
fixes local_policies_alt :: "[igraph, location] \<Rightarrow> policy set"
defines local_policies_alt_def: "local_policies_alt G \<equiv>
    (\<lambda> x. case x of
         Location (Suc 0) \<Rightarrow> {(\<lambda> y. True, {put,get,move,eval})}
       | Location 0 \<Rightarrow> {((\<lambda> y. has G (y, ''PIN'')), {put,get,move,eval})}
       | Location (Suc (Suc (Suc 0))) \<Rightarrow> {(\<lambda> y. True, {put,get,move,eval})}
       | Location (Suc (Suc 0)) \<Rightarrow>
                {((\<lambda> y. (\<exists> n. (n  @\<^bsub>G\<^esub> hospital) \<and> Actor n = y \<and>
                           has G (y, ''skey''))), {put,get,move,eval})}
       | _ \<Rightarrow>  {})"
*)

fixes local_policies :: "[igraph, location] \<Rightarrow> policy set"
defines local_policies_def: "local_policies G \<equiv>
    (\<lambda> x. if x = pub then  {(\<lambda> y. True, {get,move,put})}
          else (if x = shop then {(\<lambda> y. True, {get,move,put})}
                else {}))"

(* problems with case in locales?
defines local_policies_def: "local_policies G x \<equiv>
     (case x of
       home \<Rightarrow> {(\<lambda> y. True, {put,get,move,eval})}
     | sphone \<Rightarrow> {((\<lambda> y. has G (y, ''PIN'')), {put,get,move,eval})}
     | cloud \<Rightarrow> {(\<lambda> y. True, {put,get,move,eval})}
     | hospital \<Rightarrow> {((\<lambda> y. (\<exists> n. (n  @\<^bsub>G\<^esub> hospital) \<and> Actor n = y \<and>
                           has G (y, ''skey''))), {put,get,move,eval})}
     | _ \<Rightarrow>  {})"
*)

fixes corona_scenario :: "infrastructure"
defines corona_scenario_def:
"corona_scenario \<equiv> Infrastructure ex_graph local_policies"
fixes Icorona :: "infrastructure set"
defines Icorona_def:
  "Icorona \<equiv> {corona_scenario}"

(* other states of scenario *)
(* First step: Bob goes to shop *)

fixes corona_scenario' :: "infrastructure"
defines corona_scenario'_def: "corona_scenario' \<equiv> Infrastructure ex_graph' local_policies"
fixes Corona' :: "infrastructure set"
defines Corona'_def: "Corona' \<equiv> {corona_scenario'}"
fixes corona_scenario'' :: "infrastructure"
defines corona_scenario''_def: "corona_scenario'' \<equiv> Infrastructure ex_graph'' local_policies"
fixes Corona'' :: "infrastructure set"
defines Corona''_def: "Corona'' \<equiv> {corona_scenario''}"
fixes corona_scenario''' :: "infrastructure"
defines corona_scenario'''_def: "corona_scenario''' \<equiv> Infrastructure ex_graph''' local_policies"
fixes Corona''' :: "infrastructure set"
defines Corona'''_def: "Corona''' \<equiv> {corona_scenario'''}"
fixes corona_scenario'''' :: "infrastructure"
defines corona_scenario''''_def: "corona_scenario'''' \<equiv> Infrastructure ex_graph'''' local_policies"
fixes Corona'''' :: "infrastructure set"
defines Corona''''_def: "Corona'''' \<equiv> {corona_scenario''''}"

fixes corona_states
defines corona_states_def: "corona_states \<equiv> { I. corona_scenario \<rightarrow>\<^sub>i* I }"
fixes corona_Kripke
defines "corona_Kripke \<equiv> Kripke corona_states Icorona"
fixes scorona
defines "scorona \<equiv> {x. \<exists> n. \<not> global_policy'' x (Efid n)}"
fixes scorona'
defines "scorona' \<equiv> {x. \<exists> n. \<not> global_policy x (Efid n)}"

  (*  We assume the Insider assumption for Eve being able to impersonate Charly but
     we only need it in a positive sense to ensure that other actors can be assumed to
     be unique, that is, that the function Actor is injective on their identities. This
     is needed only to evaluate the credentials function that ranges over type actor.

fixes astate:: "identity \<Rightarrow> actor_state"
defines astate_def: "astate x \<equiv>  (case x of
           ''Eve'' \<Rightarrow> Actor_state depressed {revenge, peer_recognition}
          | _ \<Rightarrow> Actor_state happy {})"
assumes Eve_precipitating_event: "tipping_point (astate ''Eve'')"
assumes Insider_Eve: "Insider ''Eve'' {''Charly''} astate" *)

begin
subsection \<open>Using Attack Tree Calculus\<close>
text \<open>Since we consider a predicate transformer semantics, we use sets of states
     to represent properties. For example, the attack property is given by the above
     @{text \<open>set scorona\<close>}.

The attack we are interested in is to see whether for the scenario

@{text \<open>corona scenario \<equiv> Infrastructure ex_graph local_policies\<close>}

from the initial state

@{text \<open>Icorona \<equiv>{corona scenario}\<close>},

the critical state
@{text \<open>scorona\<close>} can be reached, i.e., is there a valid attack @{text \<open>(Icorona,scorona)\<close>}?

We first present a number of lemmas showing single and multi-step state transitions
for relevant states reachable from our @{text \<open>corona_scenario\<close>}.\<close>

(*
lemma "Actor ''Eve'' = Actor ''Charly''"
  using Eve_precipitating_event Insider_Eve Insider_def UasI_def by blast

lemma Alice_Bob_neq: "Actor ''Bob'' \<noteq> Actor ''Alice''"
  apply (insert Eve_precipitating_event Insider_Eve)
  apply (simp add: Insider_def UasI_def tipping_point_def astate_def)
  apply (subgoal_tac "''Bob'' \<noteq> ''Alice''")
  apply (smt char.inject list.inject)
  by blast

lemma Alice_David_neq: \<open>Actor ''Eve'' \<noteq> Actor ''David''\<close>
  by (smt Eve_precipitating_event Insider_Eve Insider_def UasI_def char.inject list.inject singletonI)

lemma Charly_Bob_neq: \<open>Actor ''Charly'' \<noteq> Actor ''Bob''\<close>
  by (smt Eve_precipitating_event Insider_Eve Insider_def UasI_def char.inject list.inject singletonI)

lemma Charly_Alice_neq: \<open>Actor ''Charly'' \<noteq> Actor ''Alice''\<close>
  by (smt Eve_precipitating_event Insider_Eve Insider_def UasI_def char.inject list.inject singletonI)
*)

lemma step1: "corona_scenario  \<rightarrow>\<^sub>n corona_scenario'"
proof (rule_tac l = pub and a = "''Eve''" and l = pub in get)
  show "graphI corona_scenario = graphI corona_scenario" by (rule refl)
next show "''Eve'' @\<^bsub>graphI corona_scenario\<^esub> pub"
    by (simp add: corona_scenario_def ex_graph_def ex_loc_ass_def atI_def nodes_def)
next show "enables corona_scenario pub (Actor ''Eve'') get"
    by (simp add: enables_def corona_scenario_def ex_graph_def local_policies_def
                    ex_creds_def ex_locs_def)
next show "pub \<in> nodes (graphI corona_scenario)"
    using corona_scenario_def ex_graph_def nodes_def by auto
next show "corona_scenario' =
    Infrastructure
     (Lgraph (gra (graphI corona_scenario)) (agra (graphI corona_scenario)) (cgra (graphI corona_scenario))
       (lgra (graphI corona_scenario)) (egra (graphI corona_scenario))
       ((kgra (graphI corona_scenario))
        (''Eve'' := (kgra (graphI corona_scenario) (''Eve''))
           (pub := {(x, y). x \<in> agra (graphI corona_scenario) pub \<and> y \<in> egra (graphI corona_scenario) pub}))))
     (delta corona_scenario)"
    apply (simp add: corona_scenario'_def ex_graph'_def move_graph_a_def
                     corona_scenario_def ex_graph_def pub_def shop_def
                     ex_loc_ass'_def ex_loc_ass_def ex_efids'_def ex_efids_def
                     ex_knos_def ex_knos'_def ex_creds_def)
    apply (rule ext, simp add: insert_Diff_if shop_def pub_def)
      apply (rule impI, rule ext)
by auto[1]
qed

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

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

lemma step3: "corona_scenario''  \<rightarrow>\<^sub>n corona_scenario'''"
proof (rule_tac l' = shop and l = pub and a = "''Eve''" in move, rule refl)
  show "''Eve'' @\<^bsub>graphI corona_scenario''\<^esub> pub"
   by (simp add: corona_scenario''_def ex_graph''_def pub_def shop_def atI_def ex_loc_ass'_def)
next show \<open>pub \<in> nodes (graphI corona_scenario'')\<close>
    by (simp add: corona_scenario''_def pub_def ex_graph''_def nodes_def, blast)
next show \<open>shop \<in> nodes (graphI corona_scenario'')\<close>
    by (simp add: corona_scenario''_def pub_def ex_graph''_def nodes_def, blast)
next show \<open>''Eve'' \<in> actors_graph (graphI corona_scenario'')\<close>
    by (simp add: actors_graph_def corona_scenario''_def ex_graph''_def nodes_def ex_loc_ass'_def
                  shop_def pub_def, blast)
next show \<open>enables corona_scenario'' shop (Actor ''Eve'') move\<close>
    by (simp add: enables_def corona_scenario''_def local_policies_def)
next show \<open>corona_scenario''' =
    Infrastructure (move_graph_a ''Eve'' pub shop (graphI corona_scenario'')) (delta corona_scenario'')\<close>
    apply (simp add: corona_scenario'''_def ex_graph'''_def move_graph_a_def pub_def shop_def
                     corona_scenario''_def ex_graph''_def ex_loc_ass''_def ex_loc_ass'_def)
    apply (rule conjI)
     apply (rule ext, simp add: insert_Diff_if shop_def pub_def)+
    apply (simp add: ex_efids'_def ex_efids''_def shop_def pub_def ex_creds_def)
    by (simp add: insert_Diff_if shop_def pub_def)
qed

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

lemma step4: "corona_scenario'''  \<rightarrow>\<^sub>n corona_scenario''''"
proof (rule_tac l = shop and a = "''Eve''" in get, rule refl)
  show \<open>''Eve'' @\<^bsub>graphI corona_scenario'''\<^esub> shop\<close>
   by (simp add: corona_scenario'''_def ex_graph'''_def pub_def shop_def atI_def ex_loc_ass''_def)
next show \<open>enables corona_scenario''' shop (Actor ''Eve'') get\<close>
    by (simp add: enables_def corona_scenario'''_def local_policies_def)
next show "shop \<in> nodes (graphI corona_scenario''')"
    using corona_scenario'''_def ex_graph'''_def nodes_def by auto
next show \<open>corona_scenario'''' =
    Infrastructure
     (Lgraph (gra (graphI corona_scenario''')) (agra (graphI corona_scenario''')) (cgra (graphI corona_scenario'''))
       (lgra (graphI corona_scenario''')) (egra (graphI corona_scenario'''))
       ((kgra (graphI corona_scenario'''))
        (''Eve'' := (kgra (graphI corona_scenario''') (''Eve''))
           (shop := {(x, y). x \<in> agra (graphI corona_scenario''') shop \<and> y \<in> egra (graphI corona_scenario''') shop}))))
     (delta corona_scenario''') \<close>
    apply (simp add: corona_scenario'''_def ex_graph'''_def move_graph_a_def pub_def shop_def
                     corona_scenario''''_def ex_graph''''_def ex_loc_ass''_def ex_loc_ass'_def)
     apply (rule ext, simp add: insert_Diff_if shop_def pub_def)+
    apply (simp add: ex_efids''_def shop_def pub_def ex_knos'_def ex_knos''_def)
    apply (rule impI, rule ext)
    apply (simp add: insert_Diff_if shop_def pub_def)
    apply (rule impI)+
    apply (rule equalityI)
     apply (rule subsetI)
     apply (case_tac xa)
    apply simp
    apply linarith
     apply (rule subsetI)
     apply (case_tac xa)
    apply simp
    by metis
qed

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

text \<open>For the Kripke structure

@{text \<open>corona_Kripke \<equiv> Kripke { I. corona_scenario \<rightarrow>\<^sub>i* I } {corona_scenario}\<close>}

we first derive a valid and-attack using the attack tree proof calculus.

@{text \<open>"\<turnstile>[\<N>\<^bsub>(Icorona,Corona')\<^esub>, \<N>\<^bsub>(Corona',Corona'')\<^esub>,  \<N>\<^bsub>(Corona'',Corona''')\<^esub>, \<N>\<^bsub>(Corona''',scorona)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona,scorona)\<^esup>\<close>}

The sets @{text \<open>Corona'-'''\<close>} (see above) are intermediate states where Eve gets Bob's connection data by
following him from pub to shop and interfering.\<close>

lemma corona_ref: "[\<N>\<^bsub>(Icorona,scorona)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona,scorona)\<^esup> \<sqsubseteq>
                  ([\<N>\<^bsub>(Icorona,Corona')\<^esub>, \<N>\<^bsub>(Corona',Corona'')\<^esub>,  \<N>\<^bsub>(Corona'',Corona''')\<^esub>, \<N>\<^bsub>(Corona''',scorona)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona,scorona)\<^esup>)"
  by (metis append_Cons append_Nil refI)

lemma corona_ref': "[\<N>\<^bsub>(Icorona,scorona')\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona,scorona')\<^esup> \<sqsubseteq>
                  ([\<N>\<^bsub>(Icorona,Corona')\<^esub>, \<N>\<^bsub>(Corona',Corona'')\<^esub>,  \<N>\<^bsub>(Corona'',Corona''')\<^esub>, \<N>\<^bsub>(Corona''',scorona')\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona,scorona')\<^esup>)"
  by (metis append_Cons append_Nil refI)

lemma att_corona: "\<turnstile>([\<N>\<^bsub>(Icorona,Corona')\<^esub>, \<N>\<^bsub>(Corona',Corona'')\<^esub>,  \<N>\<^bsub>(Corona'',Corona''')\<^esub>, \<N>\<^bsub>(Corona''',scorona)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona,scorona)\<^esup>)"
proof (subst att_and, simp, rule conjI)
  show " \<turnstile>\<N>\<^bsub>(Icorona, Corona')\<^esub>"
    apply (simp add: Icorona_def Corona'_def att_base)
    using state_transition_infra_def step1 by blast
next show \<open> \<turnstile>[\<N>\<^bsub>(Corona', Corona'')\<^esub>, \<N>\<^bsub>(Corona'', Corona''')\<^esub>, \<N>\<^bsub>(Corona''', scorona)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Corona', scorona)\<^esup>\<close>
    apply (subst att_and, simp)
    apply (rule conjI)
     apply (simp add: Corona'_def Corona''_def att_base state_transition_infra_def step2)
    apply (subst att_and, simp, rule conjI)
     apply (simp add: Corona''_def Corona'''_def att_base state_transition_infra_def step3)
    apply (subst att_and, simp)
    apply (simp add: Corona'''_def scorona_def att_base state_transition_infra_def step4)
    apply (rule_tac x = "corona_scenario''''" in exI)
    apply (rule conjI)
     prefer 2
    apply (rule step4)
     apply (unfold corona_scenario''''_def global_policy''_def)
     apply (unfold global_policy''_def identifiable'_def ex_graph''''_def ex_loc_ass''_def nodes_def is_singleton_def
                  ex_efids''_def pub_def shop_def ex_creds_def ex_locs_def ex_knos''_def local_policies_def)
     apply (rule_tac x = 2 in exI, simp)
     apply (rule conjI)
    apply (rule impI)
     apply (rule_tac x = "''Bob''" in exI)
      apply (rule_tac  x = "Efid 2" in exI)
      apply (rule equalityI)
       apply auto[1]
      apply simp
by blast
qed

thm bspec
thm ballI
thm bexE bexI

lemma set_spec: "\<forall> L\<subseteq> S. P L \<Longrightarrow> L' \<subseteq> S \<Longrightarrow> P L'"
  by simp

lemma set_allI:  "(\<And> L'. L' \<subseteq> S \<Longrightarrow> P L') \<Longrightarrow> \<forall> L\<subseteq> S. P L "
  by simp

lemma set_exI:  "P x \<Longrightarrow> x \<subseteq> A \<Longrightarrow> \<exists>x \<subseteq> A. P x"
  by blast

lemma set_exE: "\<exists>x \<subseteq> A. P x \<Longrightarrow>  (\<And>x. x \<subseteq> A \<Longrightarrow> P x \<Longrightarrow> Q) \<Longrightarrow> Q"
  by blast

lemma att_corona': "\<turnstile>([\<N>\<^bsub>(Icorona,Corona')\<^esub>, \<N>\<^bsub>(Corona',Corona'')\<^esub>,  \<N>\<^bsub>(Corona'',Corona''')\<^esub>, \<N>\<^bsub>(Corona''',scorona')\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona,scorona')\<^esup>)"
proof (subst att_and, simp, rule conjI)
  show " \<turnstile>\<N>\<^bsub>(Icorona, Corona')\<^esub>"
    apply (simp add: Icorona_def Corona'_def att_base)
    using state_transition_infra_def step1 by blast
next show \<open> \<turnstile>[\<N>\<^bsub>(Corona', Corona'')\<^esub>, \<N>\<^bsub>(Corona'', Corona''')\<^esub>, \<N>\<^bsub>(Corona''', scorona')\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Corona', scorona')\<^esup>\<close>
    apply (subst att_and, simp)
    apply (rule conjI)
     apply (simp add: Corona'_def Corona''_def att_base state_transition_infra_def step2)
    apply (subst att_and, simp, rule conjI)
     apply (simp add: Corona''_def Corona'''_def att_base state_transition_infra_def step3)
    apply (subst att_and, simp)
    apply (simp add: Corona'''_def scorona'_def att_base state_transition_infra_def step4)
    apply (rule_tac x = "corona_scenario''''" in exI)
    apply (rule conjI)
     prefer 2
    apply (rule step4)
     apply (unfold corona_scenario''''_def global_policy_def)
     apply (unfold global_policy_def identifiable'_def ex_graph''''_def ex_loc_ass''_def nodes_def is_singleton_def
                  ex_efids''_def pub_def shop_def ex_creds_def ex_locs_def ex_knos''_def local_policies_def)
    apply (rule_tac x = 2 in exI, simp)
    apply (rule set_exI)
     prefer 2
    apply (subgoal_tac
    "{Location 0, Location 1} \<subseteq> {x. \<exists>y. x = Location 0 \<and> y = Location (Suc 0) \<or> y = Location 0 \<and> x = Location (Suc 0)}")
      apply assumption
    apply simp
     apply (rule_tac x = "''Bob''" in exI)
      apply (rule_tac  x = "Efid 2" in exI)
      apply (rule equalityI)
     apply simp
     apply auto[1]
    apply (rule subsetI)
    apply (rule CollectI)
      apply (case_tac x)
by simp
qed

(* here *)
lemma corona_abs_att: "\<turnstile>\<^sub>V([\<N>\<^bsub>(Icorona,scorona)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona,scorona)\<^esup>)"
  by (rule ref_valI, rule corona_ref, rule att_corona)

lemma corona_abs_att': "\<turnstile>\<^sub>V([\<N>\<^bsub>(Icorona,scorona')\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona,scorona')\<^esup>)"
  by (rule ref_valI, rule corona_ref', rule att_corona')

text \<open>We can then simply apply the Correctness theorem @{text \<open>AT EF\<close>} to immediately
      prove the following CTL statement.

      @{text \<open>corona_Kripke \<turnstile> EF scorona\<close>}

This application of the meta-theorem of Correctness of attack trees saves us
proving the CTL formula tediously by exploring the state space.\<close>
lemma corona_att: "corona_Kripke \<turnstile> EF {x. \<exists> n. \<not>(global_policy'' x (Efid n))}"
proof -
  have a: " \<turnstile>([\<N>\<^bsub>(Icorona,Corona')\<^esub>, \<N>\<^bsub>(Corona',Corona'')\<^esub>,  \<N>\<^bsub>(Corona'',Corona''')\<^esub>, \<N>\<^bsub>(Corona''',scorona)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona, scorona)\<^esup>)"
    by (rule att_corona)
  hence "(Icorona,scorona) = attack ([\<N>\<^bsub>(Icorona,Corona')\<^esub>, \<N>\<^bsub>(Corona',Corona'')\<^esub>,  \<N>\<^bsub>(Corona'',Corona''')\<^esub>, \<N>\<^bsub>(Corona''',scorona)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona, scorona)\<^esup>)"
    by simp
  hence "Kripke {s::infrastructure. \<exists>i::infrastructure\<in>Icorona. i \<rightarrow>\<^sub>i* s} Icorona \<turnstile> EF scorona"
    using ATV_EF corona_abs_att by fastforce
  thus "corona_Kripke \<turnstile> EF {x::infrastructure.  \<exists> n. \<not> global_policy'' x (Efid n)}"
    by (simp add: corona_Kripke_def corona_states_def Icorona_def scorona_def)
qed

lemma corona_att': "corona_Kripke \<turnstile> EF {x. \<exists> n. \<not>(global_policy x (Efid n))}"
proof -
  have a: " \<turnstile>([\<N>\<^bsub>(Icorona,Corona')\<^esub>, \<N>\<^bsub>(Corona',Corona'')\<^esub>,  \<N>\<^bsub>(Corona'',Corona''')\<^esub>, \<N>\<^bsub>(Corona''',scorona')\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona, scorona')\<^esup>)"
    by (rule att_corona')
  hence "(Icorona,scorona') = attack ([\<N>\<^bsub>(Icorona,Corona')\<^esub>, \<N>\<^bsub>(Corona',Corona'')\<^esub>,  \<N>\<^bsub>(Corona'',Corona''')\<^esub>, \<N>\<^bsub>(Corona''',scorona')\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Icorona, scorona')\<^esup>)"
    by simp
  hence "Kripke {s::infrastructure. \<exists>i::infrastructure\<in>Icorona. i \<rightarrow>\<^sub>i* s} Icorona \<turnstile> EF scorona'"
    using ATV_EF corona_abs_att' by fastforce
  thus "corona_Kripke \<turnstile> EF {x::infrastructure.  \<exists> n. \<not> global_policy x (Efid n)}"
    by (simp add: corona_Kripke_def corona_states_def Icorona_def scorona'_def)
qed

theorem corona_EF: "corona_Kripke \<turnstile> EF scorona"
  using corona_att scorona_def by blast

theorem corona_EF': "corona_Kripke \<turnstile> EF scorona'"
  using corona_att' scorona'_def by blast

text \<open>Similarly, vice-versa, the CTL statement proved in @{text \<open>corona_EF\<close>}
    can now be directly translated into Attack Trees using the Completeness
    Theorem\footnote{This theorem could easily
    be proved as a direct instance of @{text \<open>att_corona\<close>} above but we want to illustrate
    an alternative proof method using Completeness here.}.\<close>
theorem corona_AT: "\<exists> A. \<turnstile> A \<and> attack A = (Icorona,scorona)"
  using att_corona attack.simps(2) by blast
(* old proof that uses Completeness and does not use att_corona:
theorem corona_AT: "\<exists> A. \<turnstile> A \<and> attack A = (Icorona,scorona)"
proof -
  have a: "corona_Kripke \<turnstile> EF scorona " by (rule corona_EF)
  have b: "Icorona \<noteq> {}" by (simp add: Icorona_def)
  thus "\<exists>A::infrastructure attree. \<turnstile>A \<and> attack A = (Icorona, scorona)"
    apply (rule Completeness)
     apply (simp add: Icorona_def)
    apply (insert a)
    by (simp add: corona_Kripke_def Icorona_def corona_states_def)
qed
*)
theorem corona_AT': "\<exists> A. \<turnstile> A \<and> attack A = (Icorona,scorona')"
  using att_corona' attack.simps(2) by blast

text \<open>Conversely, since we have an attack given by rule @{text \<open>corona_AT\<close>}, we can immediately
   infer @{text \<open>EF s\<close>} using Correctness @{text \<open>AT_EF\<close>}\footnote{Clearly, this theorem is identical
   to @{text \<open>corona_EF\<close>} and could thus be inferred from that one but we want to show here an
   alternative way of proving it using the Correctness theorem @{text \<open>AT_EF\<close>}.}.\<close>
theorem corona_EF'': "corona_Kripke \<turnstile> EF scorona"
  using corona_EF by auto
(* older version of  proof that uses AT_EF and does not use corona_EF:
    by (auto simp: corona_Kripke_def corona_states_def Icorona_def dest: AT_EF) *)
theorem corona_EF''': "corona_Kripke \<turnstile> EF scorona'"
  using corona_EF' by auto

(* CoronaApp: The remainder is probably not relevant in this application (FK 26.6.2020)
(* However, when integrating DLM into the model and hence labeling
   information becomes part of the conditions of the get_data rule this isn't
   possible any more: corona_EF is not true any more *)
(** GDPR properties  for the illustration of the DLM labeling **)
section \<open>Data Protection by Design for GDPR compliance\<close>
subsection \<open>General Data Protection Regulation (GDPR)\<close>
text \<open>Since 26th May 2018, the GDPR has become mandatory within the European Union and hence
also for any supplier of IT products. Breaches of the regulation will be fined with penalties
of 20 Million EUR. Despite the relatively large size of the document of 209 pages, the technically
relevant portion for us is only about 30 pages (Pages 81–111, Chapters I to Chapter III, Section 3).
In summary, Chapter III specifies that the controller must give the data subject read access (1)
to any information, communications, and “meta-data” of the data, e.g., retention time and purpose.
In addition, the system must enable deletion of data (2) and restriction of processing.
An invariant condition for data processing resulting from these Articles is that the system functions
must preserve any of the access rights of personal data (3).

Using labeled data, we can now express the essence of Article 4 Paragraph (1):
’personal data’ means any information relating to an identified or identifiable natural
person (’data subject’).

The labels of data must not be changed by processing: we have identified this  as
an invariant (3) resulting from the GDPR above. This invariant is formalized in
our Isabelle model by the type definition of functions on labeled data @{text \<open>label_fun\<close>}
(see Section 4.2) that preserve the data labels.\<close>

subsection \<open>Policy enforcement and privacy preservation\<close>
text \<open>We can now use the labeled data to encode the privacy constraints of the
    GDPR in the rules. For example, the get data rule (see Section 4.3) has labelled data
    @{text \<open>((Actor a’, as), n)\<close>} and uses the labeling in the precondition to guarantee
    that only entitled users can get data.

We can prove that processing preserves ownership as defined in the initial state for all paths
globally (AG) within the Kripke structure and in all locations of the graph.\<close>
(* GDPR three: Processing preserves ownership in any location *)
lemma corona_three: "h \<in> corona_actors \<Longrightarrow> l \<in> corona_locations \<Longrightarrow>
         owns (Igraph corona_scenario) l (Actor h) d \<Longrightarrow>
         corona_Kripke \<turnstile> AG {x. \<forall> l \<in> corona_locations. owns (Igraph x) l (Actor h) d }"
proof (simp add: corona_Kripke_def check_def, rule conjI)
  show "corona_scenario \<in> corona_states" by (simp add: corona_states_def state_transition_refl_def)
next show "h \<in> corona_actors \<Longrightarrow>
    l \<in> corona_locations \<Longrightarrow>
    owns (Igraph corona_scenario) l (Actor h) d \<Longrightarrow>
    corona_scenario \<in> AG {x::infrastructure. \<forall>l::location\<in>corona_locations. owns (Igraph x) l (Actor h) d}"
    apply (simp add: AG_def gfp_def)
    apply (rule_tac x = "{x::infrastructure. \<forall>l::location\<in>corona_locations. owns (Igraph x) l (Actor h) d}" in exI)
    by (auto simp: AX_def corona_scenario_def owns_def)
qed

text \<open>The final application example of Correctness contraposition
   shows that there is no attack to ownership possible.
The proved meta-theory for attack trees can be applied to facilitate the proof.
The contraposition of the Correctness property grants that if there is no attack on
@{text \<open>(I,\<not>f)\<close>}, then @{text \<open>(EF \<not>f)\<close>} does not hold in the Kripke structure. This
yields the theorem since the @{text \<open>AG f\<close>} statement corresponds to @{text \<open>\<not>(EF \<not>f)\<close>}.
\<close>
theorem no_attack_corona_three:
"h \<in> corona_actors \<Longrightarrow> l \<in> corona_locations \<Longrightarrow>
 owns (Igraph corona_scenario) l (Actor h) d \<Longrightarrow>
attack A = (Icorona, -{x. \<forall> l \<in> corona_locations. owns (Igraph x) l (Actor h) d })
\<Longrightarrow> \<not> (\<turnstile> A)"
proof (rule_tac I = Icorona and
           s = "-{x::infrastructure. \<forall>l::location\<in>corona_locations. owns (Igraph x) l (Actor h) d}"
       in contrapos_corr)
  show "h \<in> corona_actors \<Longrightarrow>
    l \<in> corona_locations \<Longrightarrow>
    owns (Igraph corona_scenario) l (Actor h) d \<Longrightarrow>
    attack A = (Icorona, - {x::infrastructure. \<forall>l::location\<in>corona_locations. owns (Igraph x) l (Actor h) d}) \<Longrightarrow>
    \<not> (Kripke {s::infrastructure. \<exists>i::infrastructure\<in>Icorona. i \<rightarrow>\<^sub>i* s}
        Icorona \<turnstile> EF (- {x::infrastructure. \<forall>l::location\<in>corona_locations. owns (Igraph x) l (Actor h) d}))"
    apply (rule AG_imp_notnotEF)
     apply (simp add: corona_Kripke_def Icorona_def corona_states_def)
    apply (drule corona_three, assumption, assumption)
    by (simp add: corona_Kripke_def Icorona_def corona_states_def)
qed
*)

end
end


theory RFC2544
imports
  "../../../Iptables_Semantics/Primitive_Matchers/Parser"
  "../../../Routing/IpRoute_Parser"
  "../../LinuxRouter_OpenFlow_Translation"
  "../../OpenFlow_Serialize"
begin

(*section\<open>Example: Simple Test for Translation to OpenFlow\<close>*)

parse_iptables_save SQRL_fw="iptables-save"

term SQRL_fw
thm SQRL_fw_def
thm SQRL_fw_FORWARD_default_policy_def

value[code] "map (\<lambda>(c,rs). (c, map (quote_rewrite \<circ> common_primitive_rule_toString) rs)) SQRL_fw"
definition "unfolded = unfold_ruleset_FORWARD SQRL_fw_FORWARD_default_policy (map_of_string_ipv4 SQRL_fw)"

lemma "length unfolded = 26" by eval

value[code] "unfolded"
value[code] "(upper_closure unfolded)"
value[code] "map (quote_rewrite \<circ> common_primitive_rule_toString) (upper_closure unfolded)"
lemma "length (upper_closure unfolded) = 26" by eval

value[code] "upper_closure (packet_assume_new unfolded)"

lemma "length (lower_closure unfolded) = 26" by eval

lemma "check_simple_fw_preconditions (upper_closure unfolded)" by eval
lemma "\<forall>m \<in> get_match`set (upper_closure (packet_assume_new unfolded)). normalized_nnf_match m" by eval
lemma "\<forall>m \<in> get_match`set (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new unfolded))). normalized_nnf_match m" by eval
lemma "check_simple_fw_preconditions (upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new unfolded))))" by eval
lemma "length (to_simple_firewall (upper_closure (packet_assume_new unfolded))) = 26" by eval

lemma "(lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new unfolded)))) = lower_closure unfolded"
      "lower_closure unfolded = upper_closure unfolded"
      "(upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new unfolded)))) = upper_closure unfolded" by eval+

value[code] "(getParts (to_simple_firewall (lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new unfolded))))))"

definition "SQRL_fw_simple \<equiv> remdups_rev (to_simple_firewall (upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new unfolded)))))"
value[code] "SQRL_fw_simple"
lemma "simple_fw_valid SQRL_fw_simple" by eval

parse_ip_route SQRL_rtbl_main = "ip-route"
value SQRL_rtbl_main
lemma "SQRL_rtbl_main = [\<lparr>routing_match = PrefixMatch 0xC6120100 24, metric = 0, routing_action = \<lparr>output_iface = ''ip1'', next_hop = None\<rparr>\<rparr>,
  \<lparr>routing_match = PrefixMatch 0xC6130100 24, metric = 0, routing_action = \<lparr>output_iface = ''op1'', next_hop = None\<rparr>\<rparr>,
  \<lparr>routing_match = PrefixMatch 0 0, metric = 0, routing_action = \<lparr>output_iface = ''op1'', next_hop = Some 0xC6130102\<rparr>\<rparr>]" by eval
lemma "SQRL_rtbl_main = [
	rr_ctor (198,18,1,0) 24 ''ip1'' None 0,
	rr_ctor (198,19,1,0) 24 ''op1'' None 0,
	rr_ctor (0,0,0,0) 0 ''op1'' (Some (198,19,1,2)) 0
	]"
by eval

definition "SQRL_ports \<equiv> [
	(''ip1'', ''1''),
	(''op1'', ''2'')
]"

definition "ofi \<equiv>
    case (lr_of_tran SQRL_rtbl_main SQRL_fw_simple (map fst SQRL_ports))
    of (Inr openflow_rules) \<Rightarrow> map (serialize_of_entry (the \<circ> map_of SQRL_ports)) openflow_rules"
lemma "ofi =
[''priority=27,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_dst=198.18.1.0/24,action=drop'',
  ''priority=26,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_dst=198.19.1.0/24,action=drop'',
  ''priority=25,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.1.1/32,nw_dst=192.18.101.1/32,action=drop'',
  ''priority=24,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.2.2/32,nw_dst=192.18.102.2/32,action=drop'',
  ''priority=23,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.3.3/32,nw_dst=192.18.103.3/32,action=drop'',
  ''priority=22,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.4.4/32,nw_dst=192.18.104.4/32,action=drop'',
  ''priority=21,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.5.5/32,nw_dst=192.18.105.5/32,action=drop'',
  ''priority=20,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.6.6/32,nw_dst=192.18.106.6/32,action=drop'',
  ''priority=19,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.7.7/32,nw_dst=192.18.107.7/32,action=drop'',
  ''priority=18,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.8.8/32,nw_dst=192.18.108.8/32,action=drop'',
  ''priority=17,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.9.9/32,nw_dst=192.18.109.9/32,action=drop'',
  ''priority=16,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.10.10/32,nw_dst=192.18.110.10/32,action=drop'',
  ''priority=15,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.11.11/32,nw_dst=192.18.111.11/32,action=drop'',
  ''priority=14,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.12.12/32,nw_dst=192.18.112.12/32,action=drop'',
  ''priority=13,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.19.1.2/32,nw_dst=192.19.65.1/32,action=output:2'',
  ''priority=12,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.13.13/32,nw_dst=192.18.113.13/32,action=drop'',
  ''priority=11,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.14.14/32,nw_dst=192.18.114.14/32,action=drop'',
  ''priority=10,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.15.15/32,nw_dst=192.18.115.15/32,action=drop'',
  ''priority=9,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.16.16/32,nw_dst=192.18.116.16/32,action=drop'',
  ''priority=8,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.17.17/32,nw_dst=192.18.117.17/32,action=drop'',
  ''priority=7,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.18.18/32,nw_dst=192.18.118.18/32,action=drop'',
  ''priority=6,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.19.19/32,nw_dst=192.18.119.19/32,action=drop'',
  ''priority=5,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.20.20/32,nw_dst=192.18.120.20/32,action=drop'',
  ''priority=4,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.21.21/32,nw_dst=192.18.121.21/32,action=drop'',
  ''priority=3,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.22.22/32,nw_dst=192.18.122.22/32,action=drop'',
  ''priority=2,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.23.23/32,nw_dst=192.18.123.23/32,action=drop'',
  ''priority=1,hard_timeout=0,idle_timeout=0,dl_type=0x800,nw_src=192.18.24.24/32,nw_dst=192.18.124.24/32,action=drop'',
  ''priority=0,hard_timeout=0,idle_timeout=0,dl_type=0x800,action=drop'']" by eval
value[code] "length ofi"

(* TODO: Well, that's something\<dots> I'd really like to have a proper file with newlines though\<dots> *)
(*ML\<open>
	val evterm = the (Code_Evaluation.dynamic_value @{context} @{term "intersperse (Char Nibble0 NibbleA) ofi"});
	val opstr = Syntax.string_of_term (Config.put show_markup false @{context}) evterm;
	File.write (Path.explode (File.platform_path(Resources.master_directory @{theory}) ^ "/pretty_str.txt")) opstr;
\<close>*)

end


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

(* Author: Andrew Boyton, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Instantiating capDL as a separation algebra."

theory Abstract_Separation_D
imports
  Sep_Tactics
  Types_D
  Map_Extra
begin

(**************************************
 * Start of lemmas to move elsewhere. *
 **************************************)

lemma inter_empty_not_both:
"\<lbrakk>x \<in> A; A \<inter> B = {}\<rbrakk> \<Longrightarrow> x \<notin> B"
  by fastforce

lemma union_intersection:
  "A \<inter> (A \<union> B) = A"
  "B \<inter> (A \<union> B) = B"
  "(A \<union> B) \<inter> A = A"
  "(A \<union> B) \<inter> B = B"
  by fastforce+

lemma union_intersection1: "A \<inter> (A \<union> B) = A"
  by (rule inf_sup_absorb)
lemma union_intersection2: "B \<inter> (A \<union> B) = B"
  by fastforce

(* This lemma is strictly weaker than restrict_map_disj. *)
lemma restrict_map_disj':
  "S \<inter> T = {} \<Longrightarrow> h |` S \<bottom> h' |` T"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_add_restrict_comm:
  "S \<inter> T = {} \<Longrightarrow> h |` S ++ h' |` T = h' |` T ++ h |` S"
  apply (drule restrict_map_disj')
  apply (erule map_add_com)
  done

(************************************
 * End of lemmas to move elsewhere. *
 ************************************)

(* The state for separation logic has:
   * The memory heap.
   * A function for which objects own which fields.
     In capDL, we say that an object either owns all of its fields, or none of them.
   These are both taken from the cdl_state.
 *)

datatype sep_state = SepState cdl_heap cdl_ghost_state

(* Functions to get the heap and the ghost_state from the sep_state. *)
primrec sep_heap :: "sep_state \<Rightarrow> cdl_heap"
where  "sep_heap (SepState h gs) = h"

primrec sep_ghost_state :: "sep_state \<Rightarrow> cdl_ghost_state"
where  "sep_ghost_state (SepState h gs) = gs"

definition
  the_set :: "'a option set \<Rightarrow> 'a set"
where
  "the_set xs = {x. Some x \<in> xs}"

lemma the_set_union [simp]:
  "the_set (A \<union> B) = the_set A \<union> the_set B"
  by (fastforce simp: the_set_def)

lemma the_set_inter [simp]:
  "the_set (A \<inter> B) = the_set A \<inter> the_set B"
  by (fastforce simp: the_set_def)

lemma the_set_inter_empty:
  "A \<inter> B = {} \<Longrightarrow> the_set A \<inter> the_set B = {}"
  by (fastforce simp: the_set_def)

(* As the capDL operations mostly take the state (rather than the heap)
 * we need to redefine some of them again to take just the heap.
 *)
definition
  slots_of_heap :: "cdl_heap \<Rightarrow> cdl_object_id \<Rightarrow> cdl_cap_map"
where
  "slots_of_heap h \<equiv> \<lambda>obj_id.
  case h obj_id of
    None \<Rightarrow> Map.empty
  | Some obj \<Rightarrow> object_slots obj"

(* Adds new caps to an object. It won't overwrite on a collision. *)
definition
  add_to_slots :: "cdl_cap_map \<Rightarrow> cdl_object \<Rightarrow> cdl_object"
where
  "add_to_slots new_val obj \<equiv> update_slots (new_val ++ (object_slots obj)) obj"

lemma add_to_slots_assoc:
  "add_to_slots x (add_to_slots (y ++ z) obj) =
   add_to_slots (x ++ y) (add_to_slots z obj)"
  apply (clarsimp simp: add_to_slots_def update_slots_def object_slots_def)
  apply (fastforce simp: cdl_tcb.splits cdl_cnode.splits
                 split: cdl_object.splits)
  done

(* Lemmas about add_to_slots, update_slots and object_slots. *)
lemma add_to_slots_twice [simp]:
  "add_to_slots x (add_to_slots y a) = add_to_slots (x ++ y) a"
  by (fastforce simp: add_to_slots_def update_slots_def object_slots_def
              split: cdl_object.splits)

lemma slots_of_heap_empty [simp]: "slots_of_heap Map.empty object_id = Map.empty"
  by (simp add: slots_of_heap_def)

lemma slots_of_heap_empty2 [simp]:
  "h obj_id = None \<Longrightarrow> slots_of_heap h obj_id = Map.empty"
  by (simp add: slots_of_heap_def)

lemma update_slots_add_to_slots_empty [simp]:
  "update_slots Map.empty (add_to_slots new obj) = update_slots Map.empty obj"
  by (clarsimp simp: update_slots_def add_to_slots_def split:cdl_object.splits)

lemma update_object_slots_id [simp]: "update_slots (object_slots a) a = a"
  by (clarsimp simp: update_slots_def object_slots_def
              split: cdl_object.splits)

lemma update_slots_of_heap_id [simp]:
  "h obj_id = Some obj \<Longrightarrow> update_slots (slots_of_heap h obj_id) obj = obj"
  by (clarsimp simp: update_slots_def slots_of_heap_def object_slots_def
              split: cdl_object.splits)

lemma add_to_slots_empty [simp]: "add_to_slots Map.empty h = h"
  by (simp add: add_to_slots_def)

lemma update_slots_eq:
  "update_slots a o1 = update_slots a o2 \<Longrightarrow> update_slots b o1 = update_slots b o2"
  by (fastforce simp: update_slots_def cdl_tcb.splits cdl_cnode.splits
              split: cdl_object.splits)

(* If there are not two conflicting objects at a position in two states.
 * Objects conflict if their types are different or their ghost_states collide.
 *)
definition
  not_conflicting_objects :: "sep_state \<Rightarrow> sep_state \<Rightarrow> cdl_object_id \<Rightarrow> bool"
where
  "not_conflicting_objects state_a state_b = (\<lambda>obj_id.
 let heap_a = sep_heap state_a;
     heap_b = sep_heap state_b;
     gs_a = sep_ghost_state state_a;
     gs_b = sep_ghost_state state_b
 in case (heap_a obj_id, heap_b obj_id) of
    (Some o1, Some o2) \<Rightarrow> object_type o1 = object_type o2 \<and> gs_a obj_id \<inter> gs_b obj_id = {}
   | _ \<Rightarrow> True)"

(* "Cleans" slots to conform with the components. *)
definition
  clean_slots :: "cdl_cap_map \<Rightarrow> cdl_components \<Rightarrow> cdl_cap_map"
where
  "clean_slots slots cmp \<equiv> slots |` the_set cmp"

(* Sets the fields of an object to a "clean" state.
   Because a frame's size is part of it's type, we don't reset it. *)
definition
  object_clean_fields :: "cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_clean_fields obj cmp \<equiv> if None \<in> cmp then obj else case obj of
    Tcb x \<Rightarrow> Tcb (x\<lparr>cdl_tcb_fault_endpoint := undefined\<rparr>)
  | CNode x \<Rightarrow> CNode (x\<lparr>cdl_cnode_size_bits := undefined \<rparr>)
  | _ \<Rightarrow> obj"

(* Sets the slots of an object to a "clean" state. *)
definition
  object_clean_slots :: "cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_clean_slots obj cmp \<equiv> update_slots (clean_slots (object_slots obj) cmp) obj"

(* Sets an object to a "clean" state. *)
definition
  object_clean :: "cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_clean obj gs \<equiv> object_clean_slots (object_clean_fields obj gs) gs"

(* Overrides the left object with the attributes of the right, as specified by the ghost state.
   If the components for an object are empty, then this object is treated as empty, and thus ignored.
 *)
definition
  object_add :: "cdl_object \<Rightarrow> cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_add obj_a obj_b cmps_a cmps_b \<equiv>
  let clean_obj_a = object_clean obj_a cmps_a;
      clean_obj_b = object_clean obj_b cmps_b
  in if (cmps_a = {})
     then clean_obj_b
     else if (cmps_b = {})
     then clean_obj_a
     else if (None \<in> cmps_b)
     then (update_slots (object_slots clean_obj_a ++ object_slots clean_obj_b) clean_obj_b)
     else (update_slots (object_slots clean_obj_a ++ object_slots clean_obj_b) clean_obj_a)"

(* Heaps are added by adding their respective objects.
 * The ghost state tells us which object's fields should be taken.
 * Adding objects of the same type adds their caps
 *   (overwrites the left with the right).
 *)
definition
  cdl_heap_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> cdl_heap"
where
  "cdl_heap_add state_a state_b \<equiv> \<lambda>obj_id.
  let
    heap_a = sep_heap state_a;
    heap_b = sep_heap state_b;
    gs_a = sep_ghost_state state_a;
    gs_b = sep_ghost_state state_b
  in
    case heap_b obj_id of
      None \<Rightarrow> heap_a obj_id
    | Some obj_b \<Rightarrow>
        (case heap_a obj_id of
           None \<Rightarrow> heap_b obj_id
         | Some obj_a \<Rightarrow> Some (object_add obj_a obj_b (gs_a obj_id) (gs_b obj_id)))"

(* Heaps are added by adding their repsective objects.
 * The ghost state tells us which object's fields should be taken.
 * Adding objects of the same type adds their caps
 *   (overwrites the left with the right).
 *)
definition
  cdl_ghost_state_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> cdl_ghost_state"
where
  "cdl_ghost_state_add state_a state_b \<equiv> \<lambda>obj_id.
 let heap_a = sep_heap state_a;
     heap_b = sep_heap state_b;
     gs_a = sep_ghost_state state_a;
     gs_b = sep_ghost_state state_b
 in      if heap_a obj_id = None \<and> heap_b obj_id \<noteq> None then gs_b obj_id
    else if heap_b obj_id = None \<and> heap_a obj_id \<noteq> None then gs_a obj_id
    else gs_a obj_id \<union> gs_b obj_id"

(* Adding states adds their heaps,
 *  and each objects owns whichever fields it owned in either heap.
 *)
definition
  sep_state_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> sep_state"
where
  "sep_state_add state_a state_b \<equiv>
  let
    heap_a = sep_heap state_a;
    heap_b = sep_heap state_b;
    gs_a = sep_ghost_state state_a;
    gs_b = sep_ghost_state state_b
  in
    SepState (cdl_heap_add state_a state_b) (cdl_ghost_state_add state_a state_b)"

(* Heaps are disjoint if for all of their objects:
   * the caps of their respective objects are disjoint,
   * their respective objects don't conflict,
   * they don't both own any of the same fields.
*)
definition
  sep_state_disj :: "sep_state \<Rightarrow> sep_state \<Rightarrow> bool"
where
  "sep_state_disj state_a state_b \<equiv>
  let
    heap_a = sep_heap state_a;
    heap_b = sep_heap state_b;
    gs_a = sep_ghost_state state_a;
    gs_b = sep_ghost_state state_b
  in
    \<forall>obj_id. not_conflicting_objects state_a state_b obj_id"

lemma not_conflicting_objects_comm:
  "not_conflicting_objects h1 h2 obj = not_conflicting_objects h2 h1 obj"
  apply (clarsimp simp: not_conflicting_objects_def split:option.splits)
  apply (fastforce simp: update_slots_def cdl_tcb.splits cdl_cnode.splits
              split: cdl_object.splits)
  done

lemma object_clean_comm:
  "\<lbrakk>object_type obj_a = object_type obj_b;
    object_slots obj_a ++ object_slots obj_b = object_slots obj_b ++ object_slots obj_a; None \<notin> cmp\<rbrakk>
  \<Longrightarrow> object_clean (add_to_slots (object_slots obj_a) obj_b) cmp =
      object_clean (add_to_slots (object_slots obj_b) obj_a) cmp"
  apply (clarsimp simp: object_type_def split: cdl_object.splits)
  apply (clarsimp simp: object_clean_def object_clean_slots_def object_clean_fields_def
                        add_to_slots_def object_slots_def update_slots_def
                        cdl_tcb.splits cdl_cnode.splits
                 split: cdl_object.splits)+
  done

lemma add_to_slots_object_slots:
  "object_type y = object_type z
 \<Longrightarrow> add_to_slots (object_slots (add_to_slots (x) y)) z =
     add_to_slots (x ++ object_slots y) z"
  apply (clarsimp simp: add_to_slots_def update_slots_def object_slots_def)
  apply (fastforce simp: object_type_def cdl_tcb.splits cdl_cnode.splits
                 split: cdl_object.splits)
  done

lemma not_conflicting_objects_empty [simp]:
  "not_conflicting_objects s (SepState Map.empty (\<lambda>obj_id. {})) obj_id"
  by (clarsimp simp: not_conflicting_objects_def split:option.splits)

lemma empty_not_conflicting_objects [simp]:
  "not_conflicting_objects (SepState Map.empty (\<lambda>obj_id. {})) s obj_id"
  by (clarsimp simp: not_conflicting_objects_def split:option.splits)

lemma not_conflicting_objects_empty_object [elim!]:
  "(sep_heap x) obj_id = None \<Longrightarrow> not_conflicting_objects x y obj_id"
  by (clarsimp simp: not_conflicting_objects_def)

lemma empty_object_not_conflicting_objects [elim!]:
  "(sep_heap y) obj_id = None \<Longrightarrow> not_conflicting_objects x y obj_id"
  apply (drule not_conflicting_objects_empty_object [where y=x])
  apply (clarsimp simp: not_conflicting_objects_comm)
  done

lemma cdl_heap_add_empty [simp]:
 "cdl_heap_add (SepState h gs) (SepState Map.empty (\<lambda>obj_id. {})) = h"
  by (simp add: cdl_heap_add_def)

lemma empty_cdl_heap_add [simp]:
  "cdl_heap_add (SepState Map.empty (\<lambda>obj_id. {})) (SepState h gs)= h"
  apply (simp add: cdl_heap_add_def)
  apply (rule ext)
  apply (clarsimp split: option.splits)
  done

lemma map_add_result_empty1: "a ++ b = Map.empty \<Longrightarrow> a = Map.empty"
  apply (subgoal_tac "dom (a++b) = {}")
   apply (subgoal_tac "dom (a) = {}")
    apply clarsimp
   apply (unfold dom_map_add)[1]
   apply clarsimp
  apply clarsimp
  done

lemma map_add_result_empty2: "a ++ b = Map.empty \<Longrightarrow> b = Map.empty"
  apply (subgoal_tac "dom (a++b) = {}")
   apply (subgoal_tac "dom (a) = {}")
    apply clarsimp
   apply (unfold dom_map_add)[1]
   apply clarsimp
  apply clarsimp
  done

lemma map_add_emptyE [elim!]: "\<lbrakk>a ++ b = Map.empty; \<lbrakk>a = Map.empty; b = Map.empty\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  apply (frule map_add_result_empty1)
  apply (frule map_add_result_empty2)
  apply clarsimp
  done

lemma clean_slots_empty [simp]:
  "clean_slots Map.empty cmp = Map.empty"
  by (clarsimp simp: clean_slots_def)

lemma object_type_update_slots [simp]:
  "object_type (update_slots slots x) = object_type x"
  by (clarsimp simp: object_type_def update_slots_def split: cdl_object.splits)

lemma object_type_object_clean_slots [simp]:
  "object_type (object_clean_slots x cmp) = object_type x"
  by (clarsimp simp: object_clean_slots_def)

lemma object_type_object_clean_fields [simp]:
  "object_type (object_clean_fields x cmp) = object_type x"
  by (clarsimp simp: object_clean_fields_def object_type_def split: cdl_object.splits)

lemma object_type_object_clean [simp]:
  "object_type (object_clean x cmp) = object_type x"
  by (clarsimp simp: object_clean_def)

lemma object_type_add_to_slots [simp]:
  "object_type (add_to_slots slots x) = object_type x"
  by (clarsimp simp: object_type_def add_to_slots_def update_slots_def split: cdl_object.splits)

lemma object_slots_update_slots [simp]:
  "has_slots obj \<Longrightarrow> object_slots (update_slots slots obj) = slots"
  by (clarsimp simp: object_slots_def update_slots_def has_slots_def
              split: cdl_object.splits)

lemma object_slots_update_slots_empty [simp]:
  "\<not>has_slots obj \<Longrightarrow> object_slots (update_slots slots obj) = Map.empty"
  by (clarsimp simp: object_slots_def update_slots_def has_slots_def
                 split: cdl_object.splits)

lemma update_slots_no_slots [simp]:
  "\<not>has_slots obj \<Longrightarrow> update_slots slots obj = obj"
  by (clarsimp simp: update_slots_def has_slots_def split: cdl_object.splits)

lemma update_slots_update_slots [simp]:
  "update_slots slots (update_slots slots' obj) = update_slots slots obj"
  by (clarsimp simp: update_slots_def split: cdl_object.splits)

lemma update_slots_same_object:
  "a = b \<Longrightarrow> update_slots a obj = update_slots b obj"
  by (erule arg_cong)

lemma object_type_has_slots:
  "\<lbrakk>has_slots x; object_type x = object_type y\<rbrakk> \<Longrightarrow> has_slots y"
  by (clarsimp simp: object_type_def has_slots_def split: cdl_object.splits)

lemma object_slots_object_clean_fields [simp]:
  "object_slots (object_clean_fields obj cmp) = object_slots obj"
  by (clarsimp simp: object_slots_def object_clean_fields_def split: cdl_object.splits)

lemma object_slots_object_clean_slots [simp]:
  "object_slots (object_clean_slots obj cmp) = clean_slots (object_slots obj) cmp"
  by (clarsimp simp: object_clean_slots_def object_slots_def update_slots_def split: cdl_object.splits)

lemma object_slots_object_clean [simp]:
  "object_slots (object_clean obj cmp) = clean_slots (object_slots obj) cmp"
  by (clarsimp simp: object_clean_def)

lemma object_slots_add_to_slots [simp]:
  "object_type y = object_type z \<Longrightarrow> object_slots (add_to_slots (object_slots y) z) = object_slots y ++ object_slots z"
  by (clarsimp simp: object_slots_def add_to_slots_def update_slots_def object_type_def split: cdl_object.splits)

lemma update_slots_object_clean_slots [simp]:
  "update_slots slots (object_clean_slots obj cmp) = update_slots slots obj"
  by (clarsimp simp: object_clean_slots_def)

lemma object_clean_fields_idem [simp]:
  "object_clean_fields (object_clean_fields obj cmp) cmp = object_clean_fields obj cmp"
  by (clarsimp simp: object_clean_fields_def split: cdl_object.splits)

lemma object_clean_slots_idem [simp]:
  "object_clean_slots (object_clean_slots obj cmp) cmp = object_clean_slots obj cmp"
  apply (case_tac  "has_slots obj")
  apply (clarsimp simp: object_clean_slots_def clean_slots_def)+
  done

lemma object_clean_fields_object_clean_slots [simp]:
  "object_clean_fields (object_clean_slots obj gs) gs = object_clean_slots (object_clean_fields obj gs) gs"
  by (clarsimp simp: object_clean_fields_def object_clean_slots_def
                     clean_slots_def object_slots_def update_slots_def
              split: cdl_object.splits)

lemma object_clean_idem [simp]:
  "object_clean (object_clean obj cmp) cmp = object_clean obj cmp"
  by (clarsimp simp: object_clean_def)

lemma has_slots_object_clean_slots:
 "has_slots (object_clean_slots obj cmp) = has_slots obj"
  by (clarsimp simp: has_slots_def object_clean_slots_def update_slots_def split: cdl_object.splits)

lemma has_slots_object_clean_fields:
 "has_slots (object_clean_fields obj cmp) = has_slots obj"
  by (clarsimp simp: has_slots_def object_clean_fields_def split: cdl_object.splits)

lemma has_slots_object_clean:
 "has_slots (object_clean obj cmp) = has_slots obj"
  by (clarsimp simp: object_clean_def has_slots_object_clean_slots has_slots_object_clean_fields)

lemma object_slots_update_slots_object_clean_fields [simp]:
  "object_slots (update_slots slots (object_clean_fields obj cmp)) = object_slots (update_slots slots obj)"
  apply (case_tac "has_slots obj")
   apply (clarsimp simp: has_slots_object_clean_fields)+
  done

lemma object_clean_fields_update_slots [simp]:
 "object_clean_fields (update_slots slots obj) cmp = update_slots slots (object_clean_fields obj cmp)"
  by (clarsimp simp: object_clean_fields_def update_slots_def split: cdl_object.splits)

lemma object_clean_fields_twice [simp]:
  "(object_clean_fields (object_clean_fields obj cmp') cmp) = object_clean_fields obj (cmp \<inter> cmp')"
  by (clarsimp simp: object_clean_fields_def split: cdl_object.splits)

lemma update_slots_object_clean_fields:
  "\<lbrakk>None \<notin> cmps; None \<notin> cmps'; object_type obj = object_type obj'\<rbrakk>
    \<Longrightarrow> update_slots slots (object_clean_fields obj cmps) =
        update_slots slots (object_clean_fields obj' cmps')"
  by (fastforce simp: update_slots_def object_clean_fields_def object_type_def split: cdl_object.splits)

lemma object_clean_fields_no_slots:
  "\<lbrakk>None \<notin> cmps; None \<notin> cmps'; object_type obj = object_type obj'; \<not> has_slots obj; \<not> has_slots obj'\<rbrakk>
    \<Longrightarrow> object_clean_fields obj cmps = object_clean_fields obj' cmps'"
  by (fastforce simp: object_clean_fields_def object_type_def has_slots_def split: cdl_object.splits)

lemma update_slots_object_clean:
  "\<lbrakk>None \<notin> cmps; None \<notin> cmps'; object_type obj = object_type obj'\<rbrakk>
   \<Longrightarrow> update_slots slots (object_clean obj cmps) = update_slots slots (object_clean obj' cmps')"
  apply (clarsimp simp: object_clean_def object_clean_slots_def)
  apply (erule (2) update_slots_object_clean_fields)
  done

lemma cdl_heap_add_assoc':
  "\<forall>obj_id. not_conflicting_objects x z obj_id \<and>
            not_conflicting_objects y z obj_id \<and>
            not_conflicting_objects x z obj_id \<Longrightarrow>
   cdl_heap_add (SepState (cdl_heap_add x y) (cdl_ghost_state_add x y)) z =
   cdl_heap_add x (SepState (cdl_heap_add y z) (cdl_ghost_state_add y z))"
  apply (rule ext)
  apply (rename_tac obj_id)
  apply (erule_tac x=obj_id in allE)
  apply (clarsimp simp: cdl_heap_add_def cdl_ghost_state_add_def not_conflicting_objects_def)
  apply (simp add: Let_unfold split: option.splits)
  apply (rename_tac obj_y obj_x obj_z)
  apply (clarsimp simp: object_add_def clean_slots_def object_clean_def object_clean_slots_def Let_unfold)
  apply (case_tac "has_slots obj_z")
   apply (subgoal_tac "has_slots obj_y")
    apply (subgoal_tac "has_slots obj_x")
     apply ((clarsimp simp: has_slots_object_clean_fields has_slots_object_clean_slots has_slots_object_clean
                           map_add_restrict union_intersection |
            drule inter_empty_not_both |
            erule update_slots_object_clean_fields |
            erule object_type_has_slots, simp |
            simp | safe)+)[3]
   apply (subgoal_tac "\<not> has_slots obj_y")
    apply (subgoal_tac "\<not> has_slots obj_x")
     apply ((clarsimp simp: has_slots_object_clean_fields has_slots_object_clean_slots has_slots_object_clean
                           map_add_restrict union_intersection |
            drule inter_empty_not_both |
            erule object_clean_fields_no_slots |
            erule object_type_has_slots, simp |
            simp | safe)+)
   apply (fastforce simp: object_type_has_slots)+
  done

lemma cdl_heap_add_assoc:
  "\<lbrakk>sep_state_disj x y; sep_state_disj y z; sep_state_disj x z\<rbrakk>
  \<Longrightarrow> cdl_heap_add (SepState (cdl_heap_add x y) (cdl_ghost_state_add x y)) z =
      cdl_heap_add x (SepState (cdl_heap_add y z) (cdl_ghost_state_add y z))"
  apply (clarsimp simp: sep_state_disj_def)
  apply (cut_tac cdl_heap_add_assoc')
   apply fast
  apply fastforce
  done

lemma cdl_ghost_state_add_assoc:
  "cdl_ghost_state_add (SepState (cdl_heap_add x y) (cdl_ghost_state_add x y)) z =
   cdl_ghost_state_add x (SepState (cdl_heap_add y z) (cdl_ghost_state_add y z))"
  apply (rule ext)
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def Let_unfold)
  done

lemma clean_slots_map_add_comm:
  "cmps_a \<inter> cmps_b = {}
  \<Longrightarrow> clean_slots slots_a cmps_a ++ clean_slots slots_b cmps_b =
      clean_slots slots_b cmps_b ++ clean_slots slots_a cmps_a"
  apply (clarsimp simp: clean_slots_def)
  apply (drule the_set_inter_empty)
  apply (erule map_add_restrict_comm)
  done

lemma object_clean_all:
  "object_type obj_a = object_type obj_b \<Longrightarrow> object_clean obj_b {} = object_clean obj_a {}"
  apply (clarsimp simp: object_clean_def object_clean_slots_def clean_slots_def the_set_def)
  apply (rule_tac cmps'1="{}" and obj'1="obj_a" in trans [OF update_slots_object_clean_fields], fastforce+)
  done

lemma object_add_comm:
  "\<lbrakk>object_type obj_a = object_type obj_b; cmps_a \<inter> cmps_b = {}\<rbrakk>
  \<Longrightarrow> object_add obj_a obj_b cmps_a cmps_b = object_add obj_b obj_a cmps_b cmps_a"
  apply (clarsimp simp: object_add_def Let_unfold)
  apply (rule conjI | clarsimp)+
    apply fastforce
  apply (rule conjI | clarsimp)+
   apply (drule_tac slots_a = "object_slots obj_a" and slots_b = "object_slots obj_b" in clean_slots_map_add_comm)
   apply fastforce
  apply (rule conjI | clarsimp)+
   apply (drule_tac slots_a = "object_slots obj_a" and slots_b = "object_slots obj_b" in clean_slots_map_add_comm)
   apply fastforce
  apply (rule conjI | clarsimp)+
   apply (erule object_clean_all)
  apply (clarsimp)
  apply (rule_tac cmps'1=cmps_b and obj'1=obj_b in trans [OF update_slots_object_clean], assumption+)
  apply (drule_tac slots_a = "object_slots obj_a" and slots_b = "object_slots obj_b" in clean_slots_map_add_comm)
  apply fastforce
  done

lemma sep_state_add_comm:
  "sep_state_disj x y \<Longrightarrow> sep_state_add x y = sep_state_add y x"
  apply (clarsimp simp: sep_state_add_def sep_state_disj_def)
  apply (rule conjI)
   apply (case_tac x, case_tac y, clarsimp)
   apply (rename_tac heap_a gs_a heap_b gs_b)
   apply (clarsimp simp: cdl_heap_add_def Let_unfold)
   apply (rule ext)
   apply (case_tac "heap_a obj_id")
    apply (case_tac "heap_b obj_id", simp_all add: slots_of_heap_def)
   apply (case_tac "heap_b obj_id", simp_all add: slots_of_heap_def)
   apply (rename_tac obj_a obj_b)
   apply (erule_tac x=obj_id in allE)
   apply (rule object_add_comm)
    apply (clarsimp simp: not_conflicting_objects_def)
   apply (clarsimp simp: not_conflicting_objects_def)
  apply (rule ext, fastforce simp: cdl_ghost_state_add_def Let_unfold Un_commute)
  done

lemma add_to_slots_comm:
  "\<lbrakk>object_slots y_obj \<bottom> object_slots z_obj; update_slots Map.empty y_obj = update_slots Map.empty z_obj \<rbrakk>
  \<Longrightarrow> add_to_slots (object_slots z_obj) y_obj = add_to_slots (object_slots y_obj) z_obj"
  by (fastforce simp: add_to_slots_def update_slots_def object_slots_def
                     cdl_tcb.splits cdl_cnode.splits
              dest!: map_add_com
              split: cdl_object.splits)

lemma cdl_heap_add_none1:
  "cdl_heap_add x y obj_id = None \<Longrightarrow> (sep_heap x) obj_id = None"
  by (clarsimp simp: cdl_heap_add_def Let_unfold split:option.splits if_split_asm)

lemma cdl_heap_add_none2:
  "cdl_heap_add x y obj_id = None \<Longrightarrow> (sep_heap y) obj_id = None"
  by (clarsimp simp: cdl_heap_add_def Let_unfold split:option.splits if_split_asm)

lemma object_type_object_addL:
  "object_type obj = object_type obj'
  \<Longrightarrow> object_type (object_add obj obj' cmp cmp') = object_type obj"
  by (clarsimp simp: object_add_def Let_unfold)

lemma object_type_object_addR:
  "object_type obj = object_type obj'
  \<Longrightarrow> object_type (object_add obj obj' cmp cmp') = object_type obj'"
  by (clarsimp simp: object_add_def Let_unfold)

lemma sep_state_add_disjL:
  "\<lbrakk>sep_state_disj y z; sep_state_disj x (sep_state_add y z)\<rbrakk> \<Longrightarrow> sep_state_disj x y"
  apply (clarsimp simp: sep_state_disj_def sep_state_add_def)
  apply (rename_tac obj_id)
  apply (clarsimp simp: not_conflicting_objects_def)
  apply (erule_tac x=obj_id in allE)+
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def object_type_object_addR
                 split: option.splits)
  done

lemma sep_state_add_disjR:
  "\<lbrakk>sep_state_disj y z; sep_state_disj x (sep_state_add y z)\<rbrakk> \<Longrightarrow> sep_state_disj x z"
  apply (clarsimp simp: sep_state_disj_def sep_state_add_def)
  apply (rename_tac obj_id)
  apply (clarsimp simp: not_conflicting_objects_def)
  apply (erule_tac x=obj_id in allE)+
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def object_type_object_addR
                 split: option.splits)
  done

lemma sep_state_add_disj:
  "\<lbrakk>sep_state_disj y z; sep_state_disj x y; sep_state_disj x z\<rbrakk> \<Longrightarrow> sep_state_disj x (sep_state_add y z)"
  apply (clarsimp simp: sep_state_disj_def sep_state_add_def)
  apply (rename_tac obj_id)
  apply (clarsimp simp: not_conflicting_objects_def)
  apply (erule_tac x=obj_id in allE)+
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def object_type_object_addR
                 split: option.splits)
  done

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

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

instantiation "sep_state" :: stronger_sep_algebra
begin

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

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

instance
  apply intro_classes
(* x ## 0 *)
       apply (simp add: sep_disj_sep_state_def sep_state_disj_def zero_sep_state_def)
(* x ## y \<Longrightarrow> y ## x *)
      apply (clarsimp simp: not_conflicting_objects_comm sep_disj_sep_state_def sep_state_disj_def Let_unfold
                            map_disj_com Int_commute)
(* x + 0 = x *)
     apply (simp add: plus_sep_state_def sep_state_add_def zero_sep_state_def)
     apply (case_tac x)
     apply (clarsimp simp: cdl_heap_add_def)
     apply (rule ext)
     apply (clarsimp simp: cdl_ghost_state_add_def split:if_split_asm)
(* x ## y \<Longrightarrow> x + y = y + x *)
    apply (clarsimp simp: plus_sep_state_def sep_disj_sep_state_def)
    apply (erule sep_state_add_comm)
(* (x + y) + z = x + (y + z) *)
   apply (simp add: plus_sep_state_def sep_state_add_def)
   apply (rule conjI)
   apply (clarsimp simp: sep_disj_sep_state_def)
    apply (erule (2) cdl_heap_add_assoc)
   apply (rule cdl_ghost_state_add_assoc)
(* x ## y + z = (x ## y \<and> x ## z) *)
  apply (clarsimp simp: plus_sep_state_def sep_disj_sep_state_def)
  apply (rule iffI)
   (* x ## y + z \<Longrightarrow> (x ## y \<and> x ## z) *)
   apply (rule conjI)
    (* x ## y + z \<Longrightarrow> (x ## y) *)
    apply (erule (1) sep_state_add_disjL)
   (* x ## y + z \<Longrightarrow> (x ## z) *)
   apply (erule (1) sep_state_add_disjR)
  (* x ## y + z \<Longleftarrow> (x ## y \<and> x ## z) *)
  apply clarsimp
  apply (erule (2) sep_state_add_disj)
  done

end

end


theory S_R_Spark_User
imports
  S_R_Spark_Specification
  S_R_Spark_Declaration
  Global_User
begin

lemma goal2'1:
  assumes "0 <= j''"
  assumes "j'' <= 79"
  shows "(rotate_definition___default_arr''
     (0 := 8, 1 := 9, 2 := 9, 3 := 11, 4 := 13, 5 := 15, 6 := 15, 7 := 5,
      8 := 7, 9 := 7, 10 := 8, 11 := 11, 12 := 14, 13 := 14, 14 := 12,
      15 := 6, 16 := 9, 17 := 13, 18 := 15, 19 := 7, 20 := 12, 21 := 8,
      22 := 9, 23 := 11, 24 := 7, 25 := 7, 26 := 12, 27 := 7, 28 := 6,
      29 := 15, 30 := 13, 31 := 11, 32 := 9, 33 := 7, 34 := 15, 35 := 11,
      36 := 8, 37 := 6, 38 := 6, 39 := 14, 40 := 12, 41 := 13, 42 := 5,
      43 := 14, 44 := 13, 45 := 13, 46 := 7, 47 := 5, 48 := 15, 49 := 5,
      50 := 8, 51 := 11, 52 := 14, 53 := 14, 54 := 6, 55 := 14, 56 := 6,
      57 := 9, 58 := 12, 59 := 9, 60 := 12, 61 := 5, 62 := 15, 63 := 8,
      64 := 8, 65 := 5, 66 := 12, 67 := 9, 68 := 12, 69 := 5, 70 := 14,
      71 := 6, 72 := 8, 73 := 13, 74 := 6, 75 := 5, 76 := 15, 77 := 13,
      78 := 11, 79 := 11))
     j'' =
    S_R_Spark_Specification.s_r' j''"
proof -
  note nth_list_to_fun_eff_eq
  moreover have "0 <= nat j''" by simp
  moreover from `j'' <= 79` have "nat j'' < length s'_list"
    unfolding s'_list_def by simp
  ultimately have conversion:
    "int (s'_list ! nat j'') =
      list_to_fun_eff
        s'_list 0 rotate_definition___default_arr'' (int (nat j''))" .
  show ?thesis unfolding s'_def conversion
    unfolding s'_list_def using `0 <= j''` `j'' <= 79`
    by simp
qed

lemma goal2'2:
  assumes "0 <= j''"
  assumes "j'' <= 79"
  shows "0 <= (rotate_definition___default_arr''
     (0 := 8, 1 := 9, 2 := 9, 3 := 11, 4 := 13, 5 := 15, 6 := 15, 7 := 5,
      8 := 7, 9 := 7, 10 := 8, 11 := 11, 12 := 14, 13 := 14, 14 := 12,
      15 := 6, 16 := 9, 17 := 13, 18 := 15, 19 := 7, 20 := 12, 21 := 8,
      22 := 9, 23 := 11, 24 := 7, 25 := 7, 26 := 12, 27 := 7, 28 := 6,
      29 := 15, 30 := 13, 31 := 11, 32 := 9, 33 := 7, 34 := 15, 35 := 11,
      36 := 8, 37 := 6, 38 := 6, 39 := 14, 40 := 12, 41 := 13, 42 := 5,
      43 := 14, 44 := 13, 45 := 13, 46 := 7, 47 := 5, 48 := 15, 49 := 5,
      50 := 8, 51 := 11, 52 := 14, 53 := 14, 54 := 6, 55 := 14, 56 := 6,
      57 := 9, 58 := 12, 59 := 9, 60 := 12, 61 := 5, 62 := 15, 63 := 8,
      64 := 8, 65 := 5, 66 := 12, 67 := 9, 68 := 12, 69 := 5, 70 := 14,
      71 := 6, 72 := 8, 73 := 13, 74 := 6, 75 := 5, 76 := 15, 77 := 13,
      78 := 11, 79 := 11))
     j''"
unfolding goal2'1[OF assms]
by simp

lemma goal2'3:
  assumes "0 <= j''"
  assumes "j'' <= 79"
  shows "(rotate_definition___default_arr''
     (0 := 8, 1 := 9, 2 := 9, 3 := 11, 4 := 13, 5 := 15, 6 := 15, 7 := 5,
      8 := 7, 9 := 7, 10 := 8, 11 := 11, 12 := 14, 13 := 14, 14 := 12,
      15 := 6, 16 := 9, 17 := 13, 18 := 15, 19 := 7, 20 := 12, 21 := 8,
      22 := 9, 23 := 11, 24 := 7, 25 := 7, 26 := 12, 27 := 7, 28 := 6,
      29 := 15, 30 := 13, 31 := 11, 32 := 9, 33 := 7, 34 := 15, 35 := 11,
      36 := 8, 37 := 6, 38 := 6, 39 := 14, 40 := 12, 41 := 13, 42 := 5,
      43 := 14, 44 := 13, 45 := 13, 46 := 7, 47 := 5, 48 := 15, 49 := 5,
      50 := 8, 51 := 11, 52 := 14, 53 := 14, 54 := 6, 55 := 14, 56 := 6,
      57 := 9, 58 := 12, 59 := 9, 60 := 12, 61 := 5, 62 := 15, 63 := 8,
      64 := 8, 65 := 5, 66 := 12, 67 := 9, 68 := 12, 69 := 5, 70 := 14,
      71 := 6, 72 := 8, 73 := 13, 74 := 6, 75 := 5, 76 := 15, 77 := 13,
      78 := 11, 79 := 11))
     j''
    \<le> 15"
proof -
  have "s'_list ! nat j'' \<le> foldl max 0 s'_list"
    by (insert assms, rule list_max) (simp_all add: s'_list_def)
  thus ?thesis unfolding goal2'1[OF assms] s'_def
    by (rule list_max_int) (simp_all add: assms s'_list_def)
qed

lemmas userlemmas = goal2'2 goal2'3 goal2'1

end


(*  Title:      HOL/Auth/n_german_lemma_inv__34_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__34_on_rules imports n_german_lemma_on_inv__34
begin
section{*All lemmas on causal relation between inv__34*}
lemma lemma_inv__34_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__34  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__34) 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__34) 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__34) 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__34) 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__34) 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__34) 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__34) 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__34) 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__34) 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__34) 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__34) 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__34) 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__34) 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__34) done
    }

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

end


(*  Title:      HOL/Auth/n_german_lemma_inv__44_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__44_on_rules imports n_german_lemma_on_inv__44
begin
section{*All lemmas on causal relation between inv__44*}
lemma lemma_inv__44_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__44  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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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
 *)

theory SubMonad_AI
imports KHeap_AI
begin

(* SubMonadLib *)
lemma submonad_do_machine_op:
  "submonad machine_state (machine_state_update \<circ> K) \<top> do_machine_op"
  apply unfold_locales
       apply (clarsimp simp: ext stateAssert_def do_machine_op_def o_def gets_def
                             get_def bind_def return_def submonad_fn_def)+
  done

interpretation submonad_do_machine_op:
  submonad machine_state "(machine_state_update \<circ> K)" \<top> do_machine_op
  by (rule submonad_do_machine_op)

lemma submonad_args_pspace:
  "submonad_args kheap (kheap_update o (\<lambda>x _. x)) \<top>"
  by (simp add: submonad_args_def)

schematic_goal assert_get_tcb_pspace:
  "gets_the (get_tcb t) = submonad_fn kheap (kheap_update o (\<lambda>x _. x)) \<top> ?f"
  apply (unfold gets_the_def)
  apply (rule submonad_bind_alt [OF submonad_args_pspace])
     apply (rule gets_submonad [OF submonad_args_pspace _ refl])
     apply (simp add: get_tcb_def)
    apply (rule assert_opt_submonad [OF submonad_args_pspace])
   apply simp
  apply (rule empty_fail_assert_opt)
  done

lemma assert_get_thread_do_machine_op_comm:
  "empty_fail m' \<Longrightarrow>
   do x \<leftarrow> gets_the (get_tcb t); y \<leftarrow> do_machine_op m'; n x y od =
   do y \<leftarrow> do_machine_op m'; x \<leftarrow> gets_the (get_tcb t); n x y od"
  apply (rule submonad_comm2 [OF _ _ submonad_do_machine_op])
        apply (rule submonad_args_pspace)
       apply (rule assert_get_tcb_pspace)
      apply simp+
  done

end


(*  Title:       variants/c_gtobcast/Aodv_Message.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "AODV protocol messages"

theory C_Aodv_Message
imports C_Gtobcast
begin

datatype msg =
    Rreq nat rreqid ip sqn k ip sqn ip
  | Rrep nat ip sqn ip ip
  | Rerr "ip \<rightharpoonup> sqn" ip
  | Newpkt data ip
  | Pkt data ip ip

instantiation msg :: msg
begin
  definition newpkt_def [simp]: "newpkt \<equiv> \<lambda>(d, dip). Newpkt d dip"
  definition eq_newpkt_def: "eq_newpkt m \<equiv> case m of Newpkt d dip \<Rightarrow> True | _ \<Rightarrow> False"

  instance by intro_classes (simp add: eq_newpkt_def)
end

text \<open>The @{type msg} type models the different messages used within AODV.
      The instantiation as a @{class msg} is a technicality due to the special
      treatment of @{term newpkt} messages in the AWN SOS rules.
      This use of classes allows a clean separation of the AWN-specific definitions
      and these AODV-specific definitions.\<close>

definition rreq :: "nat \<times> rreqid \<times> ip \<times> sqn \<times> k \<times> ip \<times> sqn \<times> ip \<Rightarrow> msg"
  where "rreq \<equiv> \<lambda>(hops, rreqid, dip, dsn, dsk, oip, osn, sip).
                    Rreq hops rreqid dip dsn dsk oip osn sip"

lemma rreq_simp [simp]:
  "rreq(hops, rreqid, dip, dsn, dsk, oip, osn, sip) =  Rreq hops rreqid dip dsn dsk oip osn sip"
  unfolding rreq_def by simp

definition rrep :: "nat \<times> ip \<times> sqn \<times> ip \<times> ip \<Rightarrow> msg"
  where "rrep \<equiv> \<lambda>(hops, dip, dsn, oip, sip). Rrep hops dip dsn oip sip"

lemma rrep_simp [simp]:
  "rrep(hops, dip, dsn, oip, sip) = Rrep hops dip dsn oip sip"
  unfolding rrep_def by simp

definition rerr :: "(ip \<rightharpoonup> sqn) \<times> ip \<Rightarrow> msg"
  where "rerr \<equiv> \<lambda>(dests, sip). Rerr dests sip"

lemma rerr_simp [simp]:
  "rerr(dests, sip) = Rerr dests sip"
  unfolding rerr_def by simp

lemma not_eq_newpkt_rreq [simp]: "\<not>eq_newpkt (Rreq hops rreqid dip dsn dsk oip osn sip)"
  unfolding eq_newpkt_def by simp

lemma not_eq_newpkt_rrep [simp]: "\<not>eq_newpkt (Rrep hops dip dsn oip sip)"
  unfolding eq_newpkt_def by simp

lemma not_eq_newpkt_rerr [simp]: "\<not>eq_newpkt (Rerr dests sip)"
  unfolding eq_newpkt_def by simp

lemma not_eq_newpkt_pkt [simp]: "\<not>eq_newpkt (Pkt d dip sip)"
  unfolding eq_newpkt_def by simp

definition pkt :: "data \<times> ip \<times> ip \<Rightarrow> msg"
  where "pkt \<equiv> \<lambda>(d, dip, sip). Pkt d dip sip"

lemma pkt_simp [simp]:
  "pkt(d, dip, sip) = Pkt d dip sip"
  unfolding pkt_def by simp

end


theory Friend_Request_Network
  imports
    "../API_Network"
    "Friend_Request"
    "BD_Security_Compositional.Composing_Security_Network"
begin

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

locale FriendRequestNetwork = Network + FriendNetworkObservationSetup +
fixes
  AID :: apiID
and
  UID1 :: userID
and
  UID2 :: userID
assumes
  UID1_UID2_UIDs: "{UID1,UID2} \<inter> (UIDs AID) = {}"
and
  UID1_UID2: "UID1 \<noteq> UID2"
and
  AID_AIDs: "AID \<in> AIDs"
begin

sublocale Issuer: Friend "UIDs AID" UID1 UID2 using UID1_UID2_UIDs UID1_UID2 by unfold_locales

abbreviation \<phi> :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> bool"
where "\<phi> aid trn \<equiv> (Issuer.\<phi> trn \<and> aid = AID)"

abbreviation f :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> Friend.value"
where "f aid trn \<equiv> Friend.f UID1 UID2 trn"

abbreviation T :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> bool"
where "T aid trn \<equiv> False"

abbreviation B :: "apiID \<Rightarrow> Friend.value list \<Rightarrow> Friend.value list \<Rightarrow> bool"
where "B aid vl vl1 \<equiv> (if aid = AID then Issuer.B vl vl1 else (vl = [] \<and> vl1 = []))"

abbreviation "comOfV aid vl \<equiv> Internal"
abbreviation "tgtNodeOfV aid vl \<equiv> undefined"
abbreviation "syncV aid1 vl1 aid2 vl2 \<equiv> False"

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 srcNodeOf = srcNodeOf*) 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 = id
proof (unfold_locales, goal_cases)
  case (1 aid trn) then show ?case by auto next
  case (2 aid trn) then show ?case by auto next
  case (3 aid trn) then show ?case by (cases trn) auto next
  case (4 aid trn) then show ?case by (cases "(aid,trn)" rule: tgtNodeOf.cases) auto next
  case (5 aid1 trn1 aid2 trn2) then show ?case by auto next
  case (6 aid1 trn1 aid2 trn2) then show ?case by (cases trn1; cases trn2; auto) next
  case (7 aid1 trn1 aid2 trn2) then show ?case by auto next
  case (8 aid1 trn1 aid2 trn2) then show ?case by (cases trn1; cases trn2; auto) next
  case (9 aid trn) then show ?case by (cases "(aid,trn)" rule: tgtNodeOf.cases) (auto simp: FriendObservationSetup.\<gamma>.simps) next
  case (10 aid trn) then show ?case by auto
qed 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 = id
using AID_AIDs Issuer.secure
by unfold_locales auto

theorem secure: "secure"
proof (intro preserve_source_secure ballI)
  fix aid
  assume "aid \<in> AIDs - {AID}"
  then show "Net.lsecure aid" by (intro Abstract_BD_Security.B_id_secure) (auto simp: B_id_def)
qed

end

end