(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)
(*<*)
theory EgTop
imports GenFilterSystem
begin
(*>*)

subsection {* \label{ssec:archprop}Architectural Properties *}

text {*
  Using the most generalised (untrusted) version of the system, we cannot show
  anything except architectural properties. These are true by construction of
  the generated system. To demonstrate this, we show a proof that the
  @{term client} and @{term store} instances cannot directly communicate.

  First we introduce some definitions to aid the statement of the property. A
  predicate specifying that a component sends on a given channel is defined as
  @{term sends_on}.
*}

fun
  sends_on :: "channel \<Rightarrow> component \<Rightarrow> bool"
where
   "sends_on c (Request f _) = (\<exists>s. \<exists>q \<in> f s. q_channel q = c)"
 | "sends_on c (a ;; b) = (sends_on c a \<or> sends_on c b)"
 | "sends_on c (IF cond THEN a ELSE b) =
     (\<forall>s. cond s \<and> sends_on c a \<or> \<not> cond s \<and> sends_on c b)"
 | "sends_on c (WHILE cond DO a) = (\<forall>s. cond s \<and> sends_on c a \<or> \<not> cond s)"
 | "sends_on c (a \<squnion> b) = (sends_on c a \<or> sends_on c b)"
 | "sends_on _ _ = False"

text {*
  The corresponding predicate for receiving on a channel is defined as
  @{term receives_on}.
*}

fun
  receives_on :: "channel \<Rightarrow> component \<Rightarrow> bool"
where
   "receives_on c (Response f) = (\<exists>q s. \<exists>a \<in> f q s. a_channel (snd a) = c)"
 | "receives_on c (a ;; b) = (receives_on c a \<or> receives_on c b)"
 | "receives_on c (IF cond THEN a ELSE b) =
     (\<forall>s. cond s \<and> receives_on c a \<or> \<not> cond s \<and> receives_on c b)"
 | "receives_on c (WHILE cond DO a) =
     (\<forall>s. cond s \<and> receives_on c a \<or> \<not> cond s)"
 | "receives_on c (a \<squnion> b) = (receives_on c a \<or> receives_on c b)"
 | "receives_on _ _ = False"

text {*
  Now whether a component communicates on a channel can be defined as the
  disjunction of these two.
*}

definition
  communicates_on :: "channel \<Rightarrow> component \<Rightarrow> bool"
where
  "communicates_on ch c \<equiv> sends_on ch c \<or> receives_on ch c"

text {*
  We can now state, and prove, the property that @{term client} and
  @{term store} never directly communicate.
*}

lemma "\<forall>c.
  \<not>(communicates_on c client_untrusted \<and> communicates_on c store_untrusted)"
  unfolding communicates_on_def client_untrusted_def Client_untrusted_def
            store_untrusted_def Store_untrusted_def
  apply clarsimp
  unfolding UserStep_def ArbitraryRequest_def ArbitraryResponse_def
  apply clarsimp
  apply (case_tac c, clarsimp+)
  done

text {*
  Were we to try reasoning about a property of the system that depended upon
  the behaviour of any component in the system, we would not be able to do it
  using the existing definitions. To show a property of this form we need to
  provide a more precise definition of the critical components. An example of
  this is shown in the next section.
*}

(*<*)
(* Whether a component ever sends a question in a given set. *)
fun
  sends :: "component \<Rightarrow> channel question set \<Rightarrow> bool"
where
   "sends (Request f _) qs = (\<exists>s. \<exists>q \<in> f s. q \<in> qs)"
 | "sends (a ;; b) qs = (sends a qs \<or> sends b qs)"
 | "sends (IF cond THEN a ELSE b) qs = (\<forall>s. cond s \<and> sends a qs \<or> \<not> cond s \<and> sends b qs)"
 | "sends (WHILE cond DO a) qs = (\<forall>s. cond s \<and> sends a qs \<or> \<not> cond s)"
 | "sends (a \<squnion> b) qs = (sends a qs \<or> sends b qs)"
 | "sends _ _ = False"

text {*
  Reasoning about a property of the system execution itself is not possible
  because we have not described what the components themselves actually do. For
  example, proving that the client never reads the secret is not possible.
*}

lemma "\<forall>p. \<exists>e s. gs\<^sub>0 p = Some (e, s) \<and>
           (e = client_untrusted \<or>
            \<not>(\<exists>c. sends e {x. q_channel x = c \<and> q_data x = Return [String ''baz'']} \<and>
              receives_on c client_untrusted))"
  oops

end
(*>*)


theory METASINVAR_SystemBoundary
imports SINVAR_BLPtrusted_impl
        SINVAR_SubnetsInGW_impl
        "../TopoS_Composition_Theory_impl"
begin

subsubsection \<open>Meta SecurityInvariant: System Boundaries\<close>

datatype system_components = SystemComponent
                           | SystemBoundaryInput
                           | SystemBoundaryOutput
                           | SystemBoundaryInputOutput

fun system_components_to_subnets :: "system_components \<Rightarrow> subnets" where
  "system_components_to_subnets SystemComponent = Member" |
  "system_components_to_subnets SystemBoundaryInput = InboundGateway" |
  "system_components_to_subnets SystemBoundaryOutput = Member" |
  "system_components_to_subnets SystemBoundaryInputOutput = InboundGateway"

fun system_components_to_blp :: "system_components \<Rightarrow> SINVAR_BLPtrusted.node_config" where
  "system_components_to_blp SystemComponent = \<lparr> security_level = 1, trusted = False \<rparr>" |
  "system_components_to_blp SystemBoundaryInput = \<lparr> security_level = 1, trusted = False \<rparr>" |
  "system_components_to_blp SystemBoundaryOutput = \<lparr> security_level = 0, trusted = True \<rparr>" |
  "system_components_to_blp SystemBoundaryInputOutput = \<lparr> security_level = 0, trusted = True \<rparr>"

definition new_meta_system_boundary :: "('v::vertex \<times> system_components) list \<Rightarrow> string \<Rightarrow> ('v SecurityInvariant) list" where
  "new_meta_system_boundary C description = [
      new_configured_list_SecurityInvariant SINVAR_LIB_SubnetsInGW \<lparr>
          node_properties = map_of (map (\<lambda>(v,c). (v, system_components_to_subnets c)) C)
          \<rparr> (description @ '' (ACS)'')
      ,
      new_configured_list_SecurityInvariant SINVAR_LIB_BLPtrusted \<lparr>
          node_properties = map_of (map (\<lambda>(v,c). (v, system_components_to_blp c)) C)
          \<rparr> (description @ '' (IFS)'')
      ]"

lemma system_components_to_subnets:
      "SINVAR_SubnetsInGW.allowed_subnet_flow
        SINVAR_SubnetsInGW.default_node_properties
        (system_components_to_subnets c) \<longleftrightarrow>
       c = SystemBoundaryInput \<or> c = SystemBoundaryInputOutput"
by(cases c)(simp_all add: SINVAR_SubnetsInGW.default_node_properties_def)

lemma system_components_to_blp:
      "(\<not> trusted SINVAR_BLPtrusted.default_node_properties \<longrightarrow>
       security_level (system_components_to_blp c) \<le> security_level SINVAR_BLPtrusted.default_node_properties)
       \<longleftrightarrow>
       c = SystemBoundaryOutput \<or> c = SystemBoundaryInputOutput"
by(cases c)(simp_all add: SINVAR_BLPtrusted.default_node_properties_def)

lemma "all_security_requirements_fulfilled (new_meta_system_boundary C description) G \<longleftrightarrow>
       (\<forall>(v\<^sub>1, v\<^sub>2) \<in> set (edgesL G). case ((map_of C) v\<^sub>1, (map_of C) v\<^sub>2)
          of
          \<comment> \<open>No restrictions outside of the component\<close>
             (None, None) \<Rightarrow> True

          \<comment> \<open>no restrictions inside the component\<close>
          |  (Some c1, Some c2) \<Rightarrow> True

          \<comment> \<open>System Boundaries Input\<close>
          |  (None, Some SystemBoundaryInputOutput) \<Rightarrow> True
          |  (None, Some SystemBoundaryInput) \<Rightarrow> True

          \<comment> \<open>System Boundaries Output\<close>
          |  (Some SystemBoundaryOutput, None) \<Rightarrow> True
          |  (Some SystemBoundaryInputOutput, None) \<Rightarrow> True

          \<comment> \<open>everything else is prohibited\<close>
          |  _ \<Rightarrow> False
       )"
apply(simp)
apply(simp add: new_meta_system_boundary_def)
apply(simp add: all_security_requirements_fulfilled_def)
apply(simp add: Let_def)
apply(simp add: SINVAR_LIB_SubnetsInGW_def SINVAR_LIB_BLPtrusted_def)
apply(simp add: SINVAR_SubnetsInGW_impl.NetModel_node_props_def SINVAR_BLPtrusted_impl.NetModel_node_props_def)
apply(rule iffI)
 apply(clarsimp)
 subgoal for a b
 apply(erule_tac x="(a,b)" in ballE)+
  apply(simp_all)
 apply(case_tac "map_of C a")
  apply(case_tac "map_of C b")
   apply(simp_all)
  apply(simp add: map_of_map)
  apply(simp split: system_components.split)
  apply(simp add: system_components_to_subnets)
  apply blast
 apply(case_tac "map_of C b")
  apply(simp add: map_of_map)
  apply(simp split: system_components.split)
  apply(simp add: system_components_to_blp)
  apply blast
 apply(simp add: map_of_map)
 apply(simp split: system_components.split; fail)
 done
apply(intro conjI)
 apply(simp add: map_of_map)
 apply(clarsimp)
 subgoal for a b
 apply(erule_tac x="(a,b)" in ballE)+
  apply(simp_all)
 apply(simp split: option.split_asm system_components.split_asm)
    by(simp_all add: SINVAR_SubnetsInGW.default_node_properties_def)
apply(clarsimp)
subgoal for a b
apply(erule_tac x="(a,b)" in ballE)+
 apply(simp_all)
apply(simp add: map_of_map)
apply(simp split: option.split_asm system_components.split_asm)
  apply(simp add: SINVAR_BLPtrusted.default_node_properties_def; fail)
 apply(rename_tac x, case_tac x, simp_all)+
done
done

value[code] "let nodes = [1,2,3,4,8,9,10];
           sinvars = new_meta_system_boundary
              [(1::int, SystemBoundaryInput),
               (2, SystemComponent),
               (3, SystemBoundaryOutput),
               (4, SystemBoundaryInputOutput)
               ] ''foobar''
       in generate_valid_topology sinvars \<lparr>nodesL = nodes, edgesL = List.product nodes nodes \<rparr>"

end


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

theory L2Opt
imports L2Defs L2Peephole
begin

(* Flow-sensitive simplification rules for L2 programs. *)
named_theorems L2flow

(*
 * The monads "A" and "B" are equivalent under precondition "P".
 * Additionally, under this precondition, they always leave the
 * postcondition "Q" (normally) or "E" (if an exception occurs).
 *)
definition
  "monad_equiv P A B Q E \<equiv> (\<forall>s. P s \<longrightarrow> A s = B s) \<and> \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace>"

lemma monad_equivI [intro]:
  "\<lbrakk> \<And>s. P s \<Longrightarrow> A s = B s; \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace> \<rbrakk> \<Longrightarrow> monad_equiv P A B Q E"
  apply (clarsimp simp: monad_equiv_def)
  done

lemma monad_equiv_eqI [intro]:
  "\<lbrakk> \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace> \<rbrakk> \<Longrightarrow> monad_equiv P A A Q E"
  apply (clarsimp simp: monad_equiv_def)
  done

lemma monad_equiv_eq:
    "monad_equiv (\<lambda>_. True) A B X Y \<Longrightarrow> A = B"
  apply (rule ext)
  apply (clarsimp simp: monad_equiv_def)
  done

lemma monad_equiv_triv [L2flow]:
    "monad_equiv P A A (\<lambda>_ _. \<exists>s. P s) (\<lambda>_ _. \<exists>s. P s)"
  apply rule
  apply wp
  apply force
  done

lemma monad_equiv_symmetric:
  "monad_equiv P A B X Y = monad_equiv P B A X Y"
  apply (clarsimp simp: monad_equiv_def validE_def2 Ball_def split: sum.splits)
  apply force
  done

lemma monad_equivD: "\<lbrakk> monad_equiv P A B R E; P s \<rbrakk> \<Longrightarrow> A s = B s"
  apply (clarsimp simp: monad_equiv_def)
  done

(*
 * Show that under condition "P", the values "A" and "B" are equal.
 *
 * We use this to simplify expressions inside our monads in a (somewhat)
 * controlled fashion.
 *)
definition "simp_expr P A B \<equiv> P \<longrightarrow> A = B"

lemma simp_expr_triv: "simp_expr P A A"
  apply (clarsimp simp: simp_expr_def)
  done

lemma simp_expr_P_cong:
  "\<lbrakk> P = P' \<rbrakk> \<Longrightarrow> simp_expr P A B = simp_expr P' A B"
  apply (clarsimp simp: simp_expr_def)
  done

lemma simp_expr_rhs_cong [cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> B = B' \<rbrakk> \<Longrightarrow> simp_expr P A B = simp_expr P' A B'"
  apply (clarsimp simp: simp_expr_def simp_implies_def)
  done

lemma simp_expr_weaken:
  "\<lbrakk> simp_expr P A B; Q \<Longrightarrow> P \<rbrakk> \<Longrightarrow> simp_expr Q A B"
  apply (clarsimp simp: simp_expr_def)
  done

(*
 * Monad simplification rules.
 *
 * When solving "monad_equiv P A B R E", the l2_opt tactics assume that P is concrete;
 * to ensure this, monad_equiv rules should result in R being instantiated.
 * See e.g. monad_equiv_unreachable where we have to constrain the rule.
 *)

lemma monad_equiv_gets [L2flow]:
    "simp_expr True v v' \<Longrightarrow> monad_equiv P (L2_gets (\<lambda>s. v s) n) (L2_gets (\<lambda>s. v' s) n)
        (\<lambda>r s. P s \<and> r = v' s) (\<lambda>_ _. False)"
  apply rule
   apply (clarsimp simp: L2_defs simp_expr_def)+
  done

lemma monad_equiv_throw [L2flow]:
    "simp_expr True v v' \<Longrightarrow>
       monad_equiv P (L2_throw v n) (L2_throw v' n) (\<lambda>_ _. False) (\<lambda>r s. P s \<and> r = v')"
  apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
  apply wp
  apply force
  done

lemma monad_equiv_guard:
    "\<lbrakk> \<And>s. simp_expr (P s) (G s) (G' s) \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_guard (\<lambda>s. G s)) (L2_guard (\<lambda>s. G' s)) (\<lambda>r s. P s \<and> G' s \<and> r = ()) (\<lambda>_ _. False)"
  apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
  apply rule
   apply (clarsimp simp: liftE_def guard_def bind_def in_return snd_return)
  apply wp
  apply force
  done

(* We use this weaker form of guard simplification to prevent bound
 * variables being expanded inside of guard statements. *)
lemma monad_equiv_guard' [L2flow]:
    "\<lbrakk> \<And>s. simp_expr True (G s) (G' s) \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_guard G) (L2_guard G') (\<lambda>r s. P s \<and> G' s \<and> r = ()) (\<lambda>_ _. False)"
  apply (rule monad_equiv_guard)
  apply (rule simp_expr_weaken)
   apply assumption
  apply simp
  done

lemma monad_equiv_guard_False [L2flow]:
    "\<lbrakk> \<And>s. simp_expr (P s) False (G s) \<rbrakk>
          \<Longrightarrow> monad_equiv P (L2_guard G) (L2_fail) (\<lambda>_ _. False) (\<lambda>_ _. False)"
  apply (monad_eq simp: L2_defs monad_equiv_def simp_expr_def validE_def2)
  done

lemma monad_equiv_guard_True [L2flow]:
    "\<lbrakk> \<And>s. simp_expr (P s) True (G s) \<rbrakk>
          \<Longrightarrow> monad_equiv P (L2_guard G) L2_skip (\<lambda>r s. P s \<and> r = ()) (\<lambda>_ _. False)"
  apply (auto simp: L2_defs simp_expr_def guard_def liftE_def return_def returnOk_def bind_def validE_def valid_def)
  done

lemma monad_equiv_guard_conj [L2flow]:
    "\<lbrakk> monad_equiv P (L2_guard G1) G1' R1 E1;
       monad_equiv (\<lambda>s. R1 () s) (L2_guard G2) G2' R2 E2 \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_guard (\<lambda>s. G1 s \<and> G2 s)) (L2_seq G1' (\<lambda>_. G2')) (\<lambda>r s. R2 () s) (\<lambda>_ _. False)"
  apply (subst (asm) (1 2) monad_equiv_symmetric)
  apply (subst monad_equiv_symmetric)
  apply rule
   apply (monad_eq simp: L2_defs monad_equiv_def validE_def2 Bex_def Ball_def split: sum.splits)
   apply fast
  apply (monad_eq simp: monad_equiv_def L2_defs validE_def2 Ball_def split: sum.splits)
  apply fast
  done

lemma monad_equiv_unknown [L2flow]:
    "monad_equiv P (L2_unknown name) (L2_unknown name) (\<lambda>r s. P s) (\<lambda>_ _. False)"
  apply (clarsimp simp: monad_equiv_def L2_defs)
  apply (wp select_wp)
  apply force
  done

lemma monad_equiv_modify [L2flow]:
    "\<lbrakk> \<And>s. simp_expr True (m s) (m' s) \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_modify (\<lambda>s. m s)) (L2_modify (\<lambda>s. m' s)) (\<lambda>r s'. \<exists>s. P s \<and> m' s = s' \<and> r = ()) (\<lambda>_ _. False)"
  apply rule
   apply (clarsimp simp: L2_defs simp_expr_def liftE_def modify_def put_def get_def bind_def)
  apply (clarsimp simp: L2_defs simp_expr_def)
  apply force
  done

lemma monad_equiv_spec [L2flow]:
    "\<lbrakk> \<And>s s'. simp_expr True ((s, s') \<in> S) (S' s s') \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_spec S) (L2_spec ({(s, s'). S' s s'})) (\<lambda>r s. \<exists>s. P s) (\<lambda>_ _. False)"
  apply rule
   apply (clarsimp simp: L2_defs simp_expr_def liftE_def spec_def bind_def)
  apply (clarsimp simp: L2_defs)
  apply wp
  apply force
  done

lemma monad_equiv_fail [L2flow]:
    "monad_equiv P L2_fail L2_fail (\<lambda>_ _. False) (\<lambda>_ _. False)"
  apply (clarsimp simp: monad_equiv_def L2_defs)
  done

lemma monad_equiv_condition [L2flow]:
  "\<lbrakk> \<And>s. simp_expr True (C s) (C' s);
     monad_equiv (\<lambda>s. P s \<and> C' s) L L' QL EL;
     monad_equiv (\<lambda>s. P s \<and> \<not> C' s) R R' QR ER \<rbrakk> \<Longrightarrow>
   monad_equiv P (L2_condition (\<lambda>s. C s) L R) (L2_condition (\<lambda>s. C' s) L' R')
      (\<lambda>r s. \<exists>s. P s) (* Deliberately weak to avoid exponential growth. *)
      (\<lambda>r s. \<exists>s. P s)"
  apply rule
   apply (monad_eq simp: L2_defs monad_equiv_def simp_expr_def split: condition_splits)
  apply (monad_eq simp: L2_defs monad_equiv_def validE_def2 split: condition_splits sum.splits)
  apply force
  done

lemma monad_equiv_condition_True [L2flow]:
  "\<lbrakk> \<And>s. simp_expr (P s) (C s) True;
     monad_equiv P L L' QL EL \<rbrakk> \<Longrightarrow>
     monad_equiv P (L2_condition C L R) L' QL EL"
  unfolding L2_defs condition_def
  apply (monad_eq simp: simp_expr_def monad_equiv_def validE_def2 Ball_def split: sum.splits)
  done

lemma monad_equiv_condition_False [L2flow]:
  "\<lbrakk> \<And>s. simp_expr (P s) (C s) False;
     monad_equiv P R R' QR ER \<rbrakk> \<Longrightarrow>
     monad_equiv P (L2_condition C L R) R' QR ER"
  unfolding L2_defs condition_def
  apply (monad_eq simp: simp_expr_def monad_equiv_def validE_def2 Ball_def split: sum.splits)
  done

(* C-parser sometimes generates boolean expressions like
     if P then (if P then 1 else 0) else Q
   This simplifies the branches. *)
lemma monad_equiv_gets_if [L2flow]:
   "\<lbrakk> \<And>s. simp_expr (P s) True (b s) \<rbrakk> \<Longrightarrow>
       monad_equiv P (L2_gets (\<lambda>s. if (b s) then L else R) f)
                     (L2_gets (\<lambda>s. L) f) (%r s. P s) (\<lambda>r s. False)"
   "\<lbrakk> \<And>s. simp_expr (P s) False (b s) \<rbrakk> \<Longrightarrow>
       monad_equiv P (L2_gets (\<lambda>s. if (b s) then L else R) f)
                     (L2_gets (\<lambda>s. R) f) (%r s. P s) (\<lambda>r s. False)"
  apply (monad_eq simp: L2_defs simp_expr_def monad_equiv_def
         validE_def valid_def split: sum.splits)+
  done

lemma monad_equiv_seq [L2flow]:
  "\<lbrakk> monad_equiv P A A' Q E;
     \<And>x. monad_equiv (Q x) (B x) (B' x) (R x) (E2 x) \<rbrakk> \<Longrightarrow>
   monad_equiv P (L2_seq A (\<lambda>x. B x)) (L2_seq A' (\<lambda>x. B' x)) (\<lambda>r s. \<exists>r'. R r' r s) (\<lambda>r s. \<exists>s. P s)"
  apply rule
   apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
   apply (rule bindE_apply_cong)
    apply simp
   apply (clarsimp simp: validE_def valid_def)
   apply force
  apply (clarsimp simp: monad_equiv_def L2_defs
               validE_def valid_def in_bindE simp_expr_def split: sum.splits)
  apply (erule allE, erule (1) impE)+
  apply fastforce
  done

lemma monad_equiv_catch [L2flow]:
  "\<lbrakk> monad_equiv P A A' Q E;
    \<And>x. monad_equiv (E x) (B x) (B' x) (Q' x) (E2 x) \<rbrakk> \<Longrightarrow>
   monad_equiv P (L2_catch A (\<lambda>x. B x)) (L2_catch A' (\<lambda>x. B' x)) (\<lambda>r s. \<exists>s. P s) (\<lambda>r s. \<exists>r'. E2 r' r s)"
  apply rule
   apply atomize
   apply (clarsimp simp: simp_expr_def L2_defs monad_equiv_def)
   apply (erule allE, erule impE, assumption)
   apply (clarsimp simp: validE_def2 split: sum.splits)
   apply (erule allE, erule impE, assumption)
   apply (rule monad_state_eqI)
     apply (clarsimp simp: in_handleE')
     apply force
    apply (clarsimp simp: in_handleE')
    apply force
   apply (fastforce simp: snd_handleE')
  apply (clarsimp simp: monad_equiv_def L2_defs
      validE_def valid_def simp_expr_def in_handleE' split: sum.splits)
  apply (erule allE, erule (1) impE)+
  apply fastforce
  done

lemma monad_equiv_cong:
  "\<lbrakk> \<And>s. P s = P' s;
     \<And>s. P s \<Longrightarrow> A s = A' s;
     \<And>s. P s \<Longrightarrow> B s = B' s;
     \<And>s s' r. P s \<Longrightarrow> Q r s' = Q' r s';
     \<And>s s' r. P s \<Longrightarrow> R r s' = R' r s' \<rbrakk> \<Longrightarrow>
   monad_equiv P A B Q R = monad_equiv P' A' B' Q' R'"
  apply atomize
  apply (clarsimp simp: monad_equiv_def validE_def valid_def split: sum.splits)
  apply (rule iffI)
   apply clarsimp
   apply fastforce
  apply clarsimp
  apply fastforce
  done

lemma monad_equiv_while [L2flow]:
  assumes cond_simp: "\<And>s r. simp_expr True (c r s) (c' r s)"
  assumes body_equiv: "\<And>r. monad_equiv (\<lambda>s. (\<exists>s'. P s') \<and> c' r s) (B r) (B' r) (Q r) (E r)"
  assumes init_simp: "\<And>s r. simp_expr True x x'"
  shows "monad_equiv P (L2_while (\<lambda>r s. c r s) B x n) (L2_while (\<lambda>r s. c' r s) B' x' n) (\<lambda>r s. \<not> c' r s \<and> (\<exists>x. P x)) (\<lambda>r s. \<exists>x. E x r s)"
  apply (insert cond_simp [unfolded simp_expr_def] init_simp [unfolded simp_expr_def])
  apply rule
   apply (clarsimp simp: L2_while_def)
   apply (rule whileLoopE_cong [THEN fun_cong, THEN fun_cong])
     apply force
    apply (cut_tac r=r in body_equiv)
    apply (clarsimp simp: monad_equiv_def)
    apply (erule allE, erule impE, auto)[1]
   apply simp
  apply (clarsimp simp: L2_while_def)
  apply (rule validE_whileLoopE [where I="\<lambda>r s. \<exists>s. P s"])
    apply force
   apply (cut_tac r=r in body_equiv)
   apply (clarsimp simp: validE_def valid_def monad_equiv_def split: sum.splits)
   apply blast
  apply simp
  done

lemma monad_equiv_recguard [L2flow]:
  "\<lbrakk> monad_equiv P B B' Q E \<rbrakk> \<Longrightarrow>
    monad_equiv P (L2_recguard a B) (L2_recguard a B') Q E"
  apply rule
   apply (clarsimp simp: L2_recguard_def monad_equiv_def valid_def validE_def
        split: sum.splits condition_splits)
  apply (clarsimp simp: L2_recguard_def monad_equiv_def valid_def validE_def in_fail
       split: sum.splits condition_splits)
  done

lemma monad_equiv_unreachable' [L2flow]:
  "monad_equiv (\<lambda>_. False) L (L2_gets (\<lambda>_. undefined) [''L2Opt_internal_var'']) Q R"
  by (simp add: monad_equiv_def)

(* avoid leaving schematic Q in goal *)
lemma monad_equiv_unreachable [L2flow]:
  "monad_equiv (\<lambda>_. False) L (L2_gets (\<lambda>_. undefined) [''L2Opt_internal_var'']) (\<lambda>_ _. False) R"
  by (rule monad_equiv_unreachable')

lemma monad_equiv_split [L2flow]:
  "\<lbrakk> \<And>a b. monad_equiv (P (a, b)) (X a b) (Y a b) (Q a b) (E a b) \<rbrakk> \<Longrightarrow>
    monad_equiv (P x) (case x of (a, b) \<Rightarrow> X a b) (case x of (a, b) \<Rightarrow> Y a b)
          (case x of (a, b) \<Rightarrow> Q a b) (case x of (a, b) \<Rightarrow> E a b)"
  apply (clarsimp simp: monad_equiv_def validE_def valid_def split_def)
  done

lemma simp_expr_solve_constant: "\<lbrakk> A \<Longrightarrow> B = C \<rbrakk> \<Longrightarrow> simp_expr A B C"
  by (clarsimp simp: simp_expr_def)

lemma monad_equiv_weaken_pre':
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; monad_equiv P L R Q E \<rbrakk> \<Longrightarrow> monad_equiv P' L R Q E"
  by (fastforce simp: monad_equiv_def validE_def valid_def)

lemma monad_equiv_weaken_pre'':
  "\<lbrakk> P' \<equiv> P; monad_equiv P L R Q E \<rbrakk> \<Longrightarrow> monad_equiv P' L R Q E"
  by (fastforce simp: monad_equiv_def validE_def valid_def)

end


section \<open>Observable Sets of Nodes\<close>

theory Observable imports ReturnAndCallNodes begin

context CFG begin

subsection \<open>Intraprocedural observable sets\<close>

inductive_set obs_intra :: "'node \<Rightarrow> 'node set \<Rightarrow> 'node set"
for n::"'node" and S::"'node set"
where obs_intra_elem:
  "\<lbrakk>n -as\<rightarrow>\<^sub>\<iota>* n'; \<forall>nx \<in> set(sourcenodes as). nx \<notin> S; n' \<in> S\<rbrakk> \<Longrightarrow> n' \<in> obs_intra n S"

lemma obs_intraE:
  assumes "n' \<in> obs_intra n S"
  obtains as where "n -as\<rightarrow>\<^sub>\<iota>* n'" and "\<forall>nx \<in> set(sourcenodes as). nx \<notin> S" and "n' \<in> S"
  using \<open>n' \<in> obs_intra n S\<close>
  by(fastforce elim:obs_intra.cases)

lemma n_in_obs_intra:
  assumes "valid_node n" and "n \<in> S" shows "obs_intra n S = {n}"
proof -
  from \<open>valid_node n\<close> have "n -[]\<rightarrow>* n" by(rule empty_path)
  hence "n -[]\<rightarrow>\<^sub>\<iota>* n" by(simp add:intra_path_def)
  with \<open>n \<in> S\<close> have "n \<in> obs_intra n S"
    by(fastforce elim:obs_intra_elem simp:sourcenodes_def)
  { fix n' assume "n' \<in> obs_intra n S"
    have "n' = n"
    proof(rule ccontr)
      assume "n' \<noteq> n"
      from \<open>n' \<in> obs_intra n S\<close> obtain as where "n -as\<rightarrow>\<^sub>\<iota>* n'"
        and "\<forall>nx \<in> set(sourcenodes as). nx \<notin> S"
        and "n' \<in> S" by(fastforce elim:obs_intra.cases)
      from \<open>n -as\<rightarrow>\<^sub>\<iota>* n'\<close> have "n -as\<rightarrow>* n'" by(simp add:intra_path_def)
      from this \<open>\<forall>nx \<in> set(sourcenodes as). nx \<notin> S\<close> \<open>n' \<noteq> n\<close> \<open>n \<in> S\<close>
      show False
      proof(induct rule:path.induct)
        case (Cons_path n'' as n' a n)
        from \<open>\<forall>nx\<in>set (sourcenodes (a#as)). nx \<notin> S\<close> \<open>sourcenode a = n\<close>
        have "n \<notin> S" by(simp add:sourcenodes_def)
        with \<open>n \<in> S\<close> show False by simp
      qed simp
    qed }
  with \<open>n \<in> obs_intra n S\<close> show ?thesis by fastforce
qed

lemma in_obs_intra_valid:
  assumes "n' \<in> obs_intra n S" shows "valid_node n" and "valid_node n'"
  using \<open>n' \<in> obs_intra n S\<close>
  by(auto elim!:obs_intraE intro:path_valid_node simp:intra_path_def)

lemma edge_obs_intra_subset:
  assumes "valid_edge a" and "intra_kind (kind a)" and "sourcenode a \<notin> S"
  shows "obs_intra (targetnode a) S \<subseteq> obs_intra (sourcenode a) S"
proof
  fix n assume "n \<in> obs_intra (targetnode a) S"
  then obtain as where "targetnode a -as\<rightarrow>\<^sub>\<iota>* n"
    and all:"\<forall>nx \<in> set(sourcenodes as). nx \<notin> S" and "n \<in> S" by(erule obs_intraE)
  from \<open>valid_edge a\<close> \<open>intra_kind (kind a)\<close> \<open>targetnode a -as\<rightarrow>\<^sub>\<iota>* n\<close>
  have "sourcenode a -[a]@as\<rightarrow>\<^sub>\<iota>* n" by(fastforce intro:Cons_path simp:intra_path_def)
  moreover
  from all \<open>sourcenode a \<notin> S\<close> have "\<forall>nx \<in> set(sourcenodes (a#as)). nx \<notin> S"
    by(simp add:sourcenodes_def)
  ultimately show "n \<in> obs_intra (sourcenode a) S" using \<open>n \<in> S\<close>
    by(fastforce intro:obs_intra_elem)
qed

lemma path_obs_intra_subset:
  assumes "n -as\<rightarrow>\<^sub>\<iota>* n'" and "\<forall>n' \<in> set(sourcenodes as). n' \<notin> S"
  shows "obs_intra n' S \<subseteq> obs_intra n S"
proof -
  from \<open>n -as\<rightarrow>\<^sub>\<iota>* n'\<close> have "n -as\<rightarrow>* n'" and "\<forall>a \<in> set as. intra_kind (kind a)"
    by(simp_all add:intra_path_def)
  from this \<open>\<forall>n' \<in> set(sourcenodes as). n' \<notin> S\<close> show ?thesis
  proof(induct rule:path.induct)
    case (Cons_path n'' as n' a n)
    note IH = \<open>\<lbrakk>\<forall>a\<in>set as. intra_kind (kind a); \<forall>n'\<in>set (sourcenodes as). n' \<notin> S\<rbrakk>
      \<Longrightarrow> obs_intra n' S \<subseteq> obs_intra n'' S\<close>
    from \<open>\<forall>n'\<in>set (sourcenodes (a#as)). n' \<notin> S\<close>
    have all:"\<forall>n'\<in>set (sourcenodes as). n' \<notin> S" and "sourcenode a \<notin> S"
      by(simp_all add:sourcenodes_def)
    from \<open>\<forall>a \<in> set (a#as). intra_kind (kind a)\<close>
    have "intra_kind (kind a)" and "\<forall>a \<in> set as. intra_kind (kind a)"
      by(simp_all add:intra_path_def)
    from IH[OF \<open>\<forall>a \<in> set as. intra_kind (kind a)\<close> all]
    have "obs_intra n' S \<subseteq> obs_intra n'' S" .
    from \<open>valid_edge a\<close> \<open>intra_kind (kind a)\<close> \<open>targetnode a = n''\<close>
      \<open>sourcenode a = n\<close> \<open>sourcenode a \<notin> S\<close>
    have "obs_intra n'' S \<subseteq> obs_intra n S" by(fastforce dest:edge_obs_intra_subset)
    with \<open>obs_intra n' S \<subseteq> obs_intra n'' S\<close> show ?case by fastforce
  qed simp
qed

lemma path_ex_obs_intra:
  assumes "n -as\<rightarrow>\<^sub>\<iota>* n'" and "n' \<in> S"
  obtains m where "m \<in> obs_intra n S"
proof(atomize_elim)
  show "\<exists>m. m \<in> obs_intra n S"
  proof(cases "\<forall>nx \<in> set(sourcenodes as). nx \<notin> S")
    case True
    with \<open>n -as\<rightarrow>\<^sub>\<iota>* n'\<close> \<open>n' \<in> S\<close> have "n' \<in> obs_intra n S" by -(rule obs_intra_elem)
    thus ?thesis by fastforce
  next
    case False
    hence "\<exists>nx \<in> set(sourcenodes as). nx \<in> S" by fastforce
    then obtain nx ns ns' where "sourcenodes as = ns@nx#ns'"
      and "nx \<in> S" and "\<forall>n' \<in> set ns. n' \<notin> S"
      by(fastforce elim!:split_list_first_propE)
    from \<open>sourcenodes as = ns@nx#ns'\<close> obtain as' a as''
      where "ns = sourcenodes as'"
      and "as = as'@a#as''" and "sourcenode a = nx"
      by(fastforce elim:map_append_append_maps simp:sourcenodes_def)
    with \<open>n -as\<rightarrow>\<^sub>\<iota>* n'\<close> have "n -as'\<rightarrow>\<^sub>\<iota>* nx"
      by(fastforce dest:path_split simp:intra_path_def)
    with \<open>nx \<in> S\<close> \<open>\<forall>n' \<in> set ns. n' \<notin> S\<close> \<open>ns = sourcenodes as'\<close>
    have "nx \<in> obs_intra n S" by(fastforce intro:obs_intra_elem)
    thus ?thesis by fastforce
  qed
qed

subsection \<open>Interprocedural observable sets restricted to the slice\<close>

fun obs :: "'node list \<Rightarrow> 'node set \<Rightarrow> 'node list set"
  where "obs [] S = {}"
  | "obs (n#ns) S = (let S' = obs_intra n S in
  (if (S' = {} \<or> (\<exists>n' \<in> set ns. \<exists>nx. call_of_return_node n' nx \<and> nx \<notin> S))
   then obs ns S else (\<lambda>nx. nx#ns) ` S'))"

lemma obsI:
  assumes "n' \<in> obs_intra n S"
  and "\<forall>nx \<in> set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S"
  shows "\<lbrakk>ns = nsx@n#nsx'; \<forall>xs x xs'. nsx = xs@x#xs' \<and> obs_intra x S \<noteq> {}
     \<longrightarrow> (\<exists>x'' \<in> set (xs'@[n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)\<rbrakk>
  \<Longrightarrow> n'#nsx' \<in> obs ns S"
proof(induct ns arbitrary:nsx)
case (Cons x xs)
  note IH = \<open>\<And>nsx. \<lbrakk>xs = nsx@n#nsx';
    \<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
    (\<exists>x''\<in>set (xs'@[n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)\<rbrakk>
    \<Longrightarrow> n'#nsx' \<in> obs xs S\<close>
  note nsx = \<open>\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
    (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)\<close>
  show ?case
  proof(cases nsx)
    case Nil
    with \<open>x#xs = nsx@n#nsx'\<close> have "n = x" and "xs = nsx'" by simp_all
    with \<open>n' \<in> obs_intra n S\<close>
      \<open>\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S\<close>
    show ?thesis by(fastforce simp:Let_def)
  next
    case (Cons z zs)
    with \<open>x#xs = nsx@n#nsx'\<close> have [simp]:"x = z" "xs = zs@n#nsx'" by simp_all
    from nsx Cons
    have "\<forall>xs x xs'. zs = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
      (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
      by clarsimp(erule_tac x="z#xs" in allE,auto)
    from IH[OF \<open>xs = zs@n#nsx'\<close> this] have "n'#nsx' \<in> obs xs S" by simp
    show ?thesis
    proof(cases "obs_intra z S = {}")
      case True
      with Cons \<open>n'#nsx' \<in> obs xs S\<close> show ?thesis by(simp add:Let_def)
    next
      case False
      from nsx Cons
      have "obs_intra z S \<noteq> {} \<longrightarrow>
        (\<exists>x''\<in>set (zs @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
        by clarsimp
      with False have "\<exists>x''\<in>set (zs @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S"
        by simp
      with \<open>xs = zs@n#nsx'\<close>
      have "\<exists>n' \<in> set xs. \<exists>nx. call_of_return_node n' nx \<and> nx \<notin> S" by fastforce
      with Cons \<open>n'#nsx' \<in> obs xs S\<close> show ?thesis by(simp add:Let_def)
    qed
  qed
qed simp

lemma obsE [consumes 2]:
  assumes "ns' \<in> obs ns S" and "\<forall>n \<in> set (tl ns). return_node n"
  obtains nsx n nsx' n' where "ns = nsx@n#nsx'" and "ns' = n'#nsx'"
  and "n' \<in> obs_intra n S"
  and "\<forall>nx \<in> set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S"
  and "\<forall>xs x xs'. nsx = xs@x#xs' \<and> obs_intra x S \<noteq> {}
  \<longrightarrow> (\<exists>x'' \<in> set (xs'@[n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
proof(atomize_elim)
  from \<open>ns' \<in> obs ns S\<close> \<open>\<forall>n \<in> set (tl ns). return_node n\<close>
  show "\<exists>nsx n nsx' n'. ns = nsx @ n # nsx' \<and> ns' = n' # nsx' \<and>
    n' \<in> obs_intra n S \<and> (\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S) \<and>
    (\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
    (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S))"
  proof(induct ns)
    case Nil thus ?case by simp
  next
    case (Cons nx ns'')
    note IH = \<open>\<lbrakk>ns' \<in> obs ns'' S; \<forall>a\<in>set (tl ns''). return_node a\<rbrakk>
      \<Longrightarrow> \<exists>nsx n nsx' n'. ns'' = nsx @ n # nsx' \<and> ns' = n' # nsx' \<and>
      n' \<in> obs_intra n S \<and>
      (\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S) \<and>
      (\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
         (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S))\<close>
    from \<open>\<forall>a\<in>set (tl (nx # ns'')). return_node a\<close> have "\<forall>n \<in> set ns''. return_node n"
      by simp
    show ?case
    proof(cases ns'')
      case Nil
      with \<open>ns' \<in> obs (nx#ns'') S\<close> obtain x where "ns' = [x]" and "x \<in> obs_intra nx S"
        by(auto simp:Let_def split:if_split_asm)
      with Nil show ?thesis by fastforce
    next
      case Cons
      with \<open>\<forall>n \<in> set ns''. return_node n\<close> have "\<forall>a\<in>set (tl ns''). return_node a"
        by simp
      show ?thesis
      proof(cases "\<exists>n' \<in> set ns''. \<exists>nx'. call_of_return_node n' nx' \<and> nx' \<notin> S")
        case True
        with \<open>ns' \<in> obs (nx#ns'') S\<close> have "ns' \<in> obs ns'' S" by simp
        from IH[OF this \<open>\<forall>a\<in>set (tl ns''). return_node a\<close>]
        obtain nsx n nsx' n' where split:"ns'' = nsx @ n # nsx'"
          "ns' = n' # nsx'" "n' \<in> obs_intra n S"
          "\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S"
          and imp:"\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
          (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
          by blast
        from True \<open>ns'' = nsx @ n # nsx'\<close>
          \<open>\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S\<close>
        have "(\<exists>nx'. call_of_return_node n nx' \<and> nx' \<notin> S) \<or>
          (\<exists>n'\<in>set nsx. \<exists>nx'. call_of_return_node n' nx' \<and> nx' \<notin> S)" by fastforce
        thus ?thesis
        proof
          assume "\<exists>nx'. call_of_return_node n nx' \<and> nx' \<notin> S"
          with split show ?thesis by clarsimp
        next
          assume "\<exists>n'\<in>set nsx. \<exists>nx'. call_of_return_node n' nx' \<and> nx' \<notin> S"
          with imp have "\<forall>xs x xs'. nx#nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
          (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
            apply clarsimp apply(case_tac xs) apply auto
            by(erule_tac x="list" in allE,auto)+
          with split Cons show ?thesis by auto
        qed
      next
        case False
        hence "\<forall>n'\<in>set ns''. \<forall>nx'. call_of_return_node n' nx' \<longrightarrow> nx' \<in> S" by simp
        show ?thesis
        proof(cases "obs_intra nx S = {}")
          case True
          with \<open>ns' \<in> obs (nx#ns'') S\<close> have "ns' \<in> obs ns'' S" by simp
          from IH[OF this \<open>\<forall>a\<in>set (tl ns''). return_node a\<close>]
          obtain nsx n nsx' n' where split:"ns'' = nsx @ n # nsx'"
            "ns' = n' # nsx'" "n' \<in> obs_intra n S"
            "\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S"
            and imp:"\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
            (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
            by blast
          from True imp Cons
          have "\<forall>xs x xs'. nx#nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
            (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
            by clarsimp (hypsubst_thin,case_tac xs,clarsimp+,erule_tac x="list" in allE,auto)
          with split Cons show ?thesis by auto
        next
          case False
          with \<open>\<forall>n'\<in>set ns''. \<forall>nx'. call_of_return_node n' nx' \<longrightarrow> nx' \<in> S\<close>
            \<open>ns' \<in> obs (nx # ns'') S\<close>
          obtain nx'' where "ns' = nx''#ns''" and "nx'' \<in> obs_intra nx S"
          by(fastforce simp:Let_def split:if_split_asm)
          { fix n' assume "n'\<in>set ns''"
            with \<open>\<forall>n \<in> set ns''. return_node n\<close> have "return_node n'" by simp
            hence "\<exists>!n''. call_of_return_node n' n''"
              by(rule return_node_call_of_return_node)
            from \<open>n'\<in>set ns''\<close>
              \<open>\<forall>n'\<in>set ns''. \<forall>nx'. call_of_return_node n' nx' \<longrightarrow> nx' \<in> S\<close>
            have "\<forall>nx'. call_of_return_node n' nx' \<longrightarrow> nx' \<in> S" by simp
            with \<open>\<exists>!n''. call_of_return_node n' n''\<close>
            have "\<exists>n''. call_of_return_node n' n'' \<and> n'' \<in> S" by fastforce }
          with \<open>ns' = nx''#ns''\<close> \<open>nx'' \<in> obs_intra nx S\<close> show ?thesis by fastforce
        qed
      qed
    qed
  qed
qed

lemma obs_split_det:
  assumes "xs@x#xs' = ys@y#ys'"
  and "obs_intra x S \<noteq> {}"
  and "\<forall>x' \<in> set xs'. \<exists>x''. call_of_return_node x' x'' \<and> x'' \<in> S"
  and "\<forall>zs z zs'. xs = zs@z#zs' \<and> obs_intra z S \<noteq> {}
  \<longrightarrow> (\<exists>z'' \<in> set (zs'@[x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S)"
  and "obs_intra y S \<noteq> {}"
  and "\<forall>y' \<in> set ys'. \<exists>y''. call_of_return_node y' y'' \<and> y'' \<in> S"
  and "\<forall>zs z zs'. ys = zs@z#zs' \<and> obs_intra z S \<noteq> {}
  \<longrightarrow> (\<exists>z'' \<in> set (zs'@[y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)"
  shows "xs = ys \<and> x = y \<and> xs' = ys'"
using assms
proof(induct xs arbitrary:ys)
  case Nil
  note impy = \<open>\<forall>zs z zs'. ys = zs@z#zs' \<and> obs_intra z S \<noteq> {}
    \<longrightarrow> (\<exists>z'' \<in> set (zs'@[y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)\<close>
  show ?case
  proof(cases "ys = []")
    case True
    with Nil \<open>[]@x#xs' = ys@y#ys'\<close> show ?thesis by simp
  next
    case False
    with \<open>[] @ x # xs' = ys @ y # ys'\<close>
    obtain zs where "x#zs = ys" and "xs' = zs@y#ys'" by(auto simp:Cons_eq_append_conv)
    from \<open>x#zs = ys\<close> \<open>obs_intra x S \<noteq> {}\<close> impy
    have "\<exists>z'' \<in> set (zs@[y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S"
      by blast
    with \<open>xs' = zs@y#ys'\<close> \<open>\<forall>x' \<in> set xs'. \<exists>x''. call_of_return_node x' x'' \<and> x'' \<in> S\<close>
    have False by fastforce
    thus ?thesis by simp
  qed
next
  case (Cons w ws)
  note IH = \<open>\<And>ys. \<lbrakk>ws @ x # xs' = ys @ y # ys'; obs_intra x S \<noteq> {};
    \<forall>x'\<in>set xs'. \<exists>x''. call_of_return_node x' x'' \<and> x'' \<in> S;
    \<forall>zs z zs'. ws = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
      (\<exists>z''\<in>set (zs' @ [x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S);
    obs_intra y S \<noteq> {}; \<forall>y'\<in>set ys'. \<exists>y''. call_of_return_node y' y'' \<and> y'' \<in> S;
    \<forall>zs z zs'. ys = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
      (\<exists>z''\<in>set (zs' @ [y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)\<rbrakk>
    \<Longrightarrow> ws = ys \<and> x = y \<and> xs' = ys'\<close>
  note impw = \<open>\<forall>zs z zs'. w # ws = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
    (\<exists>z''\<in>set (zs' @ [x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S)\<close>
  note impy = \<open>\<forall>zs z zs'. ys = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
    (\<exists>z''\<in>set (zs' @ [y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)\<close>
  show ?case
  proof(cases ys)
    case Nil
    with \<open>(w#ws) @ x # xs' = ys @ y # ys'\<close> have "y = w" and "ys' = ws @ x # xs'"
      by simp_all
    from \<open>y = w\<close> \<open>obs_intra y S \<noteq> {}\<close> impw
    have "\<exists>z''\<in>set (ws @ [x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S" by blast
    with \<open>ys' = ws @ x # xs'\<close>
      \<open>\<forall>y'\<in>set ys'. \<exists>y''. call_of_return_node y' y'' \<and> y'' \<in> S\<close>
    have False by fastforce
    thus ?thesis by simp
  next
    case (Cons w' ws')
    with \<open>(w # ws) @ x # xs' = ys @ y # ys'\<close> have "w = w'"
      and "ws @ x # xs' = ws' @ y # ys'" by simp_all
    from impw have imp1:"\<forall>zs z zs'. ws = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
      (\<exists>z''\<in>set (zs' @ [x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S)"
      by clarsimp(erule_tac x="w#zs" in allE,clarsimp)
    from Cons impy have imp2:"\<forall>zs z zs'. ws' = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
      (\<exists>z''\<in>set (zs' @ [y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)"
      by clarsimp(erule_tac x="w'#zs" in allE,clarsimp)
    from IH[OF \<open>ws @ x # xs' = ws' @ y # ys'\<close> \<open>obs_intra x S \<noteq> {}\<close>
      \<open>\<forall>x'\<in>set xs'. \<exists>x''. call_of_return_node x' x'' \<and> x'' \<in> S\<close> imp1
      \<open>obs_intra y S \<noteq> {}\<close> \<open>\<forall>y'\<in>set ys'. \<exists>y''. call_of_return_node y' y'' \<and> y'' \<in> S\<close>
      imp2]
    have "ws = ws' \<and> x = y \<and> xs' = ys'" .
    with \<open>w = w'\<close> Cons show ?thesis by simp
  qed
qed

lemma in_obs_valid:
  assumes "ns' \<in> obs ns S" and "\<forall>n \<in> set ns. valid_node n"
  shows "\<forall>n \<in> set ns'. valid_node n"
  using \<open>ns' \<in> obs ns S\<close> \<open>\<forall>n \<in> set ns. valid_node n\<close>
  by(induct ns)(auto intro:in_obs_intra_valid simp:Let_def split:if_split_asm)

end

end


theory SimpViaMetaRec
imports "../metarec/HOLMetaRec"
begin

(* simpto_const already exists in HOLMetaRec *)
(* synth  t2  from  t1,   t1 is primary *)
definition
  simpto2_const :: "'a::{} => 'a => prop" ("(_) simpto2 (_)" [30,30] 20)
where
  [MRjud 1 1]: "simpto2_const t1 t2 == (t1 == t2)"
(* synth  t2  from  t1,   t1 is primary *)
definition
  irewto_const :: "'a::{} => 'a => prop" ("(_) irewto (_)" [10,10] 10)
where
  [MRjud 1 1]: "irewto_const t1 t2 == (t1 == t2)"
(* rewto_const already exists in HOLMetaRec *)
(* synth  t2  from  t1,   t1 is primary *)
definition
  rewto2_const :: "'a::{} => 'a => prop" ("(_) rewto2 (_)" [10,10] 10)
where
  [MRjud 1 1]: "rewto2_const t1 t2 == (t1 == t2)"

(* synth  t2  from  t1,   t1 is primary *)
definition
  subsimpto_const :: "'a::{} => 'a => prop" ("(_) subsimpto (_)" [10,10] 10)
where
  [MRjud 1 1]: "subsimpto_const t1 t2 == (t1 == t2)"

(* synth  t'  from  t1,t2   t1 is primary *)
definition
  checkbeta_const :: "('a::{} => 'b::{}) => 'a => 'b => prop" ("checkbeta (_) (_) to (_)" [10,10,10] 10)
where
  [MRjud 2 1]: "checkbeta_const t1 t2 t' == ((t1 t2) == t')"

(* low prior *)
lemma id_sub[MR]:
  "  t subsimpto t  "
  unfolding subsimpto_const_def by simp

(* beachte: decompose matching auf primaere Objekte eta-expandiert diese nicht on-the-fly
     sichert hier Termination weil sonst auf t in t(x) in der Premisse wieder diese Regel
     passen wuerde *)
lemma lam_sub[MR]:
  "(!! x. (t x) simpto2 (t' x))
  ==>  (% x. t(x)) subsimpto (% x. t'(x))"
  unfolding simpto2_const_def subsimpto_const_def
  ML_prf {* Thm.axiom @{theory} "Pure.abstract_rule"  *}
  by (tactic {* rtac (Thm.axiom @{theory} "Pure.abstract_rule") 1 *})

lemma app_sub[MR]:
  "[|  t1 simpto2 t1'  ;  t2 simpto2 t2'  ;  checkbeta t1' t2' to t' |]
  ==>  (t1 t2) subsimpto t'"
  unfolding simpto2_const_def checkbeta_const_def subsimpto_const_def by simp

(* congruence rule for meta implication *)
lemma imp_sub[MR]:
  "[|  (PROP t1) simpto2 (PROP t1')  ;  PROP t1' ==> (PROP t2) simpto2 (PROP t2') |]
  ==> (PROP t1 ==> PROP t2) subsimpto (PROP t1' ==> PROP t2')"
 unfolding subsimpto_const_def simpto2_const_def by simp

(* low prior *)
lemma checkbeta_id[MR]:
  "checkbeta t1 t2 to (t1 t2)"
  unfolding checkbeta_const_def by simp

(* high priority *)
(* TODO: checks perfectly fine, but we want simpto2 to depend implicitly on rewto2,
   using what is there ATM, to avoid what is interpreted as cyclic dependencies *)
lemma checkbeta_rew[MR_unchecked]:
  "[|  try ( (t1(t2)) rewto2 t' )  ;  t' simpto2 t'' |]
  ==>  checkbeta (% x. t1(x)) t2 to t''   "
  unfolding try_const_def simpto2_const_def rewto2_const_def checkbeta_const_def by simp

lemma simpto2_rule[MR]:
 "[|  t subsimpto t'  ;  t' irewto t''  |]
 ==>  t simpto2 t''  "
 unfolding simpto2_const_def irewto_const_def subsimpto_const_def by simp

(* not always what is wanted in automation! *)
lemma simpto2_eq:  "[|  t simpto2 t'  ;  t2 simpto2 t'  |] ==>
  (t = t2) simpto2 True "
  by(simp add: simpto2_const_def)

(* low prior *)
lemma irewto_id[MR]:
  "t irewto t"
  unfolding irewto_const_def by simp

(* high prior *)
(* bottom-up *)
(* TODO: checks perfectly fine, but we want simpto2 to depend implicitly on rewto2,
   using what is there ATM, to avoid what is interpreted as cyclic dependencies *)
lemma irewto_rule[MR_unchecked]:
  "[|  try (t rewto2 t')  ;  t' simpto2 t'' |]
  ==>  t irewto t''"
 unfolding rewto2_const_def irewto_const_def try_const_def simpto2_const_def subsimpto_const_def
 by simp

lemma simpto2_prop_fconv: "  P simpto2 P' ==> PROP P' ==> PROP P  "
  by (simp add: simpto2_const_def)

ML {*
  MetaRec.fconv_metarec
*}

method_setup mrsimp = {*
  let fun solver ths =
    FIRST' [resolve_tac (reflexive_thm :: @{thm TrueI} :: @{thm refl} :: ths),
      atac, etac @{thm FalseE}, K all_tac]
  in
    Attrib.thms >> (fn thms => fn ctxt => METHOD (fn facts =>
      let
        val ths = facts @ thms
        val ctxt2 = ctxt
          |> Context.proof_map (MetaRec.add_rule 0 @{thm simpto2_eq})
          |> fold (MetaRec.add_assm true) ths
      in
        MetaRec.fconv_metarec @{thm simpto2_prop_fconv} (solver ths) ctxt2 1
      end))
  end
*} ""

(* "competing" animation methods: ares_tac tries the rules in the list, priorized from left to right *)
method_setup dfs_solve = {*
  Attrib.thms >> (fn thms => K (METHOD (fn facts =>
  (DEPTH_SOLVE (HEADGOAL (ares_tac (facts @ thms)))))))
*} ""
method_setup bfs_solve = {*
  Attrib.thms >> (fn thms => K (METHOD (fn facts =>
  (BREADTH_FIRST (has_fewer_prems 1) (HEADGOAL (ares_tac (facts @ thms)))))))
*} ""
method_setup iterdeep_solve = {*
  Attrib.thms >> (fn thms => K (METHOD (fn facts =>
  (ITER_DEEPEN 20 (has_fewer_prems 1) (ares_tac (facts @ thms))))))
*} ""

locale tests =
  fixes dummy :: 'dummy
begin

(* lets have some stupid examples *)

definition
  A ::nat
where "A = 0"
definition
  B ::nat
where "B = 0"

lemma Asimp: "A == B" by (simp add: A_def B_def)

(* some trivial fact to rewrite with *)
lemma userrewdecl[MR]:
  "A rewto2 B"
by (simp add: rewto2_const_def A_def B_def)

schematic_lemma test: "A simpto2 ?C"
(* doesnt terminate? *)
 (* by (dfs_solve tryI app_sub id_sub checkbeta_rew checkbeta_id simpto2_rule irewto_rule irewto_id userrewdecl) *)
(* manually: *)
(* apply (rule simpto2_rule)
  apply (rule id_sub)
  apply (rule irewto_rule)
  apply (rule tryI)
  apply (rule userrewdecl)
  apply (rule simpto2_rule)
  apply (rule id_sub)
  by (rule irewto_id)  *)
by (tactic {* MetaRec.metarec_tac @{context} 1 *})

schematic_lemma test2: "((!! P. A = A ==> P ==> True) ==> True) simpto2 ?C"
(* doesnt terminate?
   lam_sub Regel muss man rausnehmen sonst triviale nicht-Term wg Unif modulo eta *)
 (* by (dfs_solve tryI app_sub id_sub checkbeta_rew checkbeta_id simpto2_rule irewto_rule irewto_id userrewdecl)  *)
(* bfs_solve, iterdeep_solve use wrong execution model: don't rewrite at all *)
 (* by (bfs_solve tryI app_sub id_sub checkbeta_rew checkbeta_id simpto2_rule irewto_rule irewto_id userrewdecl) *)
 (* by (iterdeep_solve  tryI app_sub id_sub checkbeta_rew checkbeta_id simpto2_rule irewto_rule irewto_id userrewdecl)  *)
(* 38ms without optimizations, 25 ms with no_comp_rules Optimization *)
by (tactic {* MetaRec.metarec_tac @{context} 1 *})

(* 3ms *)
lemma test2': "((!! P. A = A ==> P ==> True) ==> True)"
by (simp add: userrewdecl[simplified rewto2_const_def])

ML {*
  val ct = @{term "((!! P. A = A ==> P ==> True) ==> True)"}
    |> cterm_of @{theory}
  val simpth = @{thm Asimp}
  fun runsimp () =
    let val _ = Raw_Simplifier.rewrite true [simpth] ct in () end
*}
(* 1 ms! *)
ML {*
  val _ = runsimp ()
*}

schematic_lemma test3: assumes [MRassm]: "(0::nat) rewto2 1" shows "(0::nat) simpto2 ?C"
by (tactic {* MetaRec.metarec_tac @{context} 1 *})

schematic_lemma test4: assumes [MRassm]: "(0::nat) rewto2 1" shows "Suc (0::nat) = Suc 1"
by mrsimp

definition
  foo :: "'a => 'a => bool"
where
  [MRjud 1 1]: "foo x y == True"

(* test local frules *)
schematic_lemma test5:
  assumes [MRassm]: "foo (0::nat) (1::nat)"
  and [MRassm]: "!! (x::nat) y. frule(foo x y ==> x rewto2 y)"
  shows "(0::nat) simpto2 ?C"
by (tactic {* MetaRec.metarec_tac @{context} 1 *})

(* test local brules *)
schematic_lemma test6:
  assumes [MRassm]: "foo (0::nat) (1::nat)"
  and [MRassm]: "!! (x::nat) y. foo x y ==> x rewto2 y"
  shows "(0::nat) rewto2 ?C"
by (tactic {* MetaRec.metarec_tac @{context} 1 *})

schematic_lemma
  assumes [MRassm]: "!! P1 P2. Trueprop (P1 --> P2) rewto2  (P1 ==> P2)"
  shows "Trueprop (P1 --> P2 --> P3)  simpto2 ?Q"
  by (tactic {* MetaRec.metarec_tac @{context} 1 *})

end

end


(*  Title:      HOL/Auth/n_mesi.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_mesi Protocol Case Study*}

theory n_mesi imports n_mesi_lemma_invs_on_rules n_mesi_on_inis
begin
lemma main:
assumes a1: "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
and a2: "0 < N"
shows "\<forall> f. f \<in> (invariants N) --> formEval f s"
proof (rule consistentLemma)
show "consistent (invariants N) {andList (allInitSpecs N)} (rules N)"
proof (cut_tac a1, unfold consistent_def, rule conjI)
show "\<forall> f ini s. f \<in> (invariants N) --> ini \<in> {andList (allInitSpecs N)} --> formEval ini s --> formEval f s"
proof ((rule allI)+, (rule impI)+)
  fix f ini s
  assume b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  have b4: "formEval (andList (allInitSpecs N)) s"
  apply (cut_tac b2 b3, simp) done
  show "formEval f s"
  apply (rule on_inis, cut_tac b1, assumption, cut_tac b2, assumption, cut_tac b3, assumption) done
qed
next show "\<forall> f r s. f \<in> invariants N --> r \<in> rules N --> invHoldForRule s f r (invariants N)"
proof ((rule allI)+, (rule impI)+)
  fix f r s
  assume b1: "f \<in> invariants N" and b2: "r \<in> rules N"
  show "invHoldForRule s f r (invariants N)"
  apply (rule invs_on_rules, cut_tac b1, assumption, cut_tac b2, assumption) done
qed
qed
next show "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
  apply (metis a1) done
qed
end


(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>, 2003
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

header {* Location *}

theory Location
imports AttributesIndep "../Isabelle/Value"
begin

text {* A storage location can be a field of an object, a static field,
 the length of an array, or the contents of an array.
*}

datatype Location = objLoc    CAttId ObjectId     --{* field in object *}
                  | staticLoc AttId               --{* static field in concrete class *}
                  | arrLenLoc Arraytype ObjectId   --{* length of an array *}
                  | arrLoc    Arraytype ObjectId nat --{* contents of an array *}

text {* We only directly support one-dimensional arrays. Multidimensional
arrays can be simulated by arrays of references to arrays.
*}

text {* The function @{text "ltype"} yields the content type of a location. *}
definition ltype:: "Location \<Rightarrow> Javatype" where
"ltype l = (case l of
              objLoc cf a  \<Rightarrow> rtype (att cf)
            | staticLoc f     \<Rightarrow> rtype f
            | arrLenLoc T a   \<Rightarrow> IntgT
            | arrLoc T a i \<Rightarrow> at2jt T)"

lemma ltype_simps [simp]:
"ltype (objLoc cf a)  = rtype (att cf)"
"ltype (staticLoc f)     = rtype f"
"ltype (arrLenLoc T a)   = IntgT"
"ltype (arrLoc T a i) = at2jt T"
  by (simp_all add: ltype_def)

text {* Discriminator functions to test whether a location denotes an array length
or whether it denotes a static object. Currently, the discriminator functions for
object and array locations are not specified. They can be added if they are needed.
*}

definition isArrLenLoc:: "Location \<Rightarrow> bool" where
"isArrLenLoc l = (case l of
                 objLoc cf a  \<Rightarrow> False
               | staticLoc f     \<Rightarrow> False
               | arrLenLoc T a   \<Rightarrow> True
               | arrLoc T a i \<Rightarrow> False)"

definition isStaticLoc:: "Location \<Rightarrow> bool" where
"isStaticLoc l = (case l of
                 objLoc cff a \<Rightarrow> False
               | staticLoc f     \<Rightarrow> True
               | arrLenLoc T a   \<Rightarrow> False
               | arrLoc T a i \<Rightarrow> False)"
lemma isStaticLoc_simps [simp]:
"isStaticLoc (objLoc cf a) = False"
"isStaticLoc (staticLoc f)     = True"
"isStaticLoc (arrLenLoc T a)   = False"
"isStaticLoc (arrLoc T a i) = False"
  by (simp_all add: isStaticLoc_def)

text {* The function @{text "ref"} yields the
object or array containing the location that is passed
as argument (see the function @{text "obj"} in
\cite[p. 43 f.]{Poetzsch-Heffter97specification}).
Note that for static locations
the result is @{text "nullV"} since static locations
are not associated to any object.
\label{ref_def}
*}
definition ref:: "Location \<Rightarrow> Value" where
"ref l = (case l of
            objLoc cf a  \<Rightarrow> objV (cls cf) a
          | staticLoc f     \<Rightarrow> nullV
          | arrLenLoc T a   \<Rightarrow> arrV T a
          | arrLoc T a i \<Rightarrow> arrV T a)"

lemma ref_simps [simp]:
"ref (objLoc cf a)  = objV (cls cf) a"
"ref (staticLoc f)     = nullV"
"ref (arrLenLoc T a)   = arrV T a"
"ref (arrLoc T a i) = arrV T a"
  by (simp_all add: ref_def)

text {* The function @{text "loc"} denotes the subscription of an object
reference with an attribute. *}
primrec loc:: "Value \<Rightarrow> AttId \<Rightarrow> Location"  ("_.._" [80,80] 80)
where "loc (objV c a) f = objLoc (catt c f) a"
text {* Note that we only define subscription properly for object references.
For all other values we do not provide any defining equation, so they will
internally be mapped to @{text "arbitrary"}.
*}

text {* The length of an array can be selected with the function @{text "arr_len"}. *}
primrec arr_len:: "Value \<Rightarrow> Location"
where "arr_len (arrV T a) = arrLenLoc T a"

text {* Arrays can be indexed by the function @{text "arr_loc"}. *}
primrec arr_loc:: "Value \<Rightarrow> nat \<Rightarrow> Location" ("_.[_]" [80,80] 80)
where "arr_loc (arrV T a) i = arrLoc T a i"

text {* The functions @{term "loc"}, @{term "arr_len"} and @{term "arr_loc"}
define the interface between the basic store model (based on locations) and
the programming language Java. Instance field access {\tt obj.x} is modelled as
@{term "obj..x"} or @{text "loc obj x"} (without the syntactic sugar),
array length {\tt a.length} with @{term "arr_len a"},
array indexing {\tt a[i]} with @{term "a.[i]"} or @{text "arr_loc a i"}.
The accessing of a static field
{\tt C.f} can be expressed by the location itself @{text "staticLoc C'f"}.
Of course one can build more infrastructure to make access to instance fields
and static fields more uniform. We could for example define a
function @{text "static"} which indicates whether a field is static or not and
based on that create an @{term "objLoc"} location or a @{term "staticLoc"} location. But
this will only complicate the actual proofs and we can already easily
perform the distinction whether a field is static or not in the \jive-frontend and
therefore keep the verification simpler.
*}

lemma ref_loc [simp]: "\<lbrakk>isObjV r; typeof r \<le> dtype f\<rbrakk> \<Longrightarrow> ref (r..f) = r"
  apply (case_tac r)
  apply (case_tac [!] f)
  apply (simp_all)
  done

lemma obj_arr_loc [simp]: "isArrV r \<Longrightarrow> ref (r.[i]) = r"
  by (cases r) simp_all

lemma obj_arr_len [simp]: "isArrV r \<Longrightarrow> ref (arr_len r) = r"
  by (cases r) simp_all

end


(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory WHATWHERE_Security
imports Strong_Security.Types
begin

locale WHATWHERE =
fixes SR :: "('exp, 'id, 'val, 'com) TLSteps"
and E :: "('exp, 'id, 'val) Evalfunction"
and pp :: "'com \<Rightarrow> nat"
and DA :: "('id, 'd::order) DomainAssignment"
and lH :: "('d::order, 'exp) lHatches"

begin

\<comment> \<open>define when two states are indistinguishable for an observer on domain d\<close>
definition d_equal :: "'d::order \<Rightarrow> ('id, 'val) State
  \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
where
"d_equal d m m' \<equiv> \<forall>x. ((DA x) \<le> d \<longrightarrow> (m x) = (m' x))"

abbreviation d_equal' :: "('id, 'val) State
  \<Rightarrow> 'd::order \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
( "(_ =\<^bsub>_\<^esub> _)" )
where
"m =\<^bsub>d\<^esub> m' \<equiv> d_equal d m m'"

\<comment> \<open>transitivity of d-equality\<close>
lemma d_equal_trans:
"\<lbrakk> m =\<^bsub>d\<^esub> m'; m' =\<^bsub>d\<^esub> m'' \<rbrakk> \<Longrightarrow> m =\<^bsub>d\<^esub> m''"
by (simp add: d_equal_def)

abbreviation SRabbr :: "('exp, 'id, 'val, 'com) TLSteps_curry"
("(1\<langle>_,/_\<rangle>) \<rightarrow>\<lhd>_\<rhd>/ (1\<langle>_,/_\<rangle>)" [0,0,0,0,0] 81)
where
"\<langle>c,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle> \<equiv> ((c,m),\<alpha>,(p,m')) \<in> SR"

\<comment> \<open>function for obtaining the unique memory (state) after one step for a command and a memory (state)\<close>
definition NextMem :: "'com \<Rightarrow> ('id, 'val) State \<Rightarrow> ('id, 'val) State"
( "\<lbrakk>_\<rbrakk>'(_')" )
where
"\<lbrakk>c\<rbrakk>(m) \<equiv> (THE m'. (\<exists>p \<alpha>. \<langle>c,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>))"

\<comment> \<open>function getting all escape hatches for some location\<close>
definition htchLoc :: "nat \<Rightarrow> ('d, 'exp) Hatches"
where
"htchLoc \<iota> \<equiv> {(d,e). (d,e,\<iota>) \<in> lH}"

\<comment> \<open>function for getting all escape hatches for some set of locations\<close>
definition htchLocSet :: "nat set \<Rightarrow> ('d, 'exp) Hatches"
where
"htchLocSet PP \<equiv> \<Union>{h. (\<exists>\<iota> \<in> PP. h = htchLoc \<iota>)}"

\<comment> \<open>predicate for (d,H)-equality\<close>
definition dH_equal :: "'d \<Rightarrow> ('d, 'exp) Hatches
  \<Rightarrow> ('id, 'val) State \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
where
"dH_equal d H m m' \<equiv> (m =\<^bsub>d\<^esub> m' \<and>
  (\<forall>(d',e) \<in> H. (d' \<le> d \<longrightarrow> (E e m = E e m'))))"

abbreviation dH_equal' :: "('id, 'val) State \<Rightarrow> 'd \<Rightarrow> ('d, 'exp) Hatches
  \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
( "(_ \<sim>\<^bsub>_,_\<^esub> _)" )
where
"m \<sim>\<^bsub>d,H\<^esub> m' \<equiv> dH_equal d H m m'"

\<comment> \<open>predicate indicating that a command is not a d-declassification command\<close>
definition NDC :: "'d \<Rightarrow> 'com \<Rightarrow> bool"
where
"NDC d c \<equiv> (\<forall>m m'. m =\<^bsub>d\<^esub> m' \<longrightarrow> \<lbrakk>c\<rbrakk>(m) =\<^bsub>d\<^esub> \<lbrakk>c\<rbrakk>(m'))"

\<comment> \<open>predicate indicating an 'immediate d-declassification command' for a set of escape hatches\<close>
definition IDC :: "'d \<Rightarrow> 'com \<Rightarrow> ('d, 'exp) Hatches \<Rightarrow> bool"
where
"IDC d c H \<equiv> (\<exists>m m'. m =\<^bsub>d\<^esub> m' \<and>
  (\<not> \<lbrakk>c\<rbrakk>(m) =\<^bsub>d\<^esub> \<lbrakk>c\<rbrakk>(m')))
  \<and> (\<forall>m m'. m \<sim>\<^bsub>d,H\<^esub> m' \<longrightarrow> \<lbrakk>c\<rbrakk>(m) =\<^bsub>d\<^esub> \<lbrakk>c\<rbrakk>(m') )"

definition stepResultsinR :: "'com ProgramState \<Rightarrow> 'com ProgramState
  \<Rightarrow> 'com Bisimulation_type \<Rightarrow> bool"
where
"stepResultsinR p p' R \<equiv> (p = None \<and> p' = None) \<or>
  (\<exists>c c'. (p = Some c \<and> p' = Some c' \<and> ([c],[c']) \<in> R))"

definition dhequality_alternative ::  "'d \<Rightarrow> nat set \<Rightarrow> nat
  \<Rightarrow> ('id, 'val) State \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
where
"dhequality_alternative d PP \<iota> m m' \<equiv> m \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m' \<or>
            (\<not> (htchLoc \<iota>) \<subseteq> (htchLocSet PP))"

definition Strong_dlHPP_Bisimulation :: "'d \<Rightarrow> nat set
  \<Rightarrow> 'com Bisimulation_type \<Rightarrow> bool"
where
"Strong_dlHPP_Bisimulation d PP R \<equiv>
  (sym R) \<and> (trans R) \<and>
  (\<forall>(V,V') \<in> R. length V = length V') \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V.
    ((NDC d (V!i)) \<or>
     (IDC d (V!i) (htchLoc (pp (V!i)))))) \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V. \<forall>m1 m1' m2 \<alpha> p.
    ( \<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle> \<and> m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1')
    \<longrightarrow> (\<exists>p' \<alpha>' m2'. ( \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        (stepResultsinR p p' R) \<and> (\<alpha>,\<alpha>') \<in> R \<and>
        (dhequality_alternative d PP (pp (V!i)) m2 m2'))))"

\<comment> \<open>predicate to define when a program is strongly secure\<close>
definition WHATWHERE_Secure :: "'com list \<Rightarrow> bool"
where
"WHATWHERE_Secure V \<equiv> (\<forall>d PP.
  (\<exists>R. Strong_dlHPP_Bisimulation d PP R \<and> (V,V) \<in> R))"

\<comment> \<open>auxiliary lemma to obtain central strong (d,lH,PP)-Bisimulation property as Lemma
 in meta logic (allows instantiating all the variables manually if necessary)\<close>
lemma strongdlHPPB_aux:
 "\<And>V V' m1 m1' m2 p i \<alpha>. \<lbrakk> Strong_dlHPP_Bisimulation d PP R;
  i < length V; (V,V') \<in> R;
  \<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>; m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1' \<rbrakk>
 \<Longrightarrow> (\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle>
  \<and> stepResultsinR p p' R \<and> (\<alpha>,\<alpha>') \<in> R \<and>
  (dhequality_alternative d PP (pp (V!i)) m2 m2'))"
  by (simp add: Strong_dlHPP_Bisimulation_def, fastforce)

\<comment> \<open>auxiliary lemma to obtain 'NDC or IDC' from strong (d,lH,PP)-Bisimulation as lemma
  in meta logic allowing instantiation of the variables\<close>
lemma strongdlHPPB_NDCIDCaux:
"\<And>V V' i. \<lbrakk>Strong_dlHPP_Bisimulation d PP R;
  (V,V') \<in> R; i < length V \<rbrakk>
        \<Longrightarrow> (NDC d (V!i) \<or> IDC d (V!i) (htchLoc (pp (V!i))))"
  by (simp add: Strong_dlHPP_Bisimulation_def, auto)

lemma WHATWHERE_empty:
"WHATWHERE_Secure []"
  by (simp add: WHATWHERE_Secure_def, auto,
  rule_tac x="{([],[])}" in exI,
  simp add: Strong_dlHPP_Bisimulation_def sym_def trans_def)

end

end


section \<open>Generic Scheduler\<close>
theory Gen_Scheduler
imports Main
  CAVA_Automata.Stuttering_Extension
  "../Lib/LTS" "../Lib/SOS_Misc_Add"
  "HOL-Library.Multiset"
begin

  lemmas [simp del] = union_mset_add_mset_left union_mset_add_mset_right

  text \<open>
    A generic scheduler, that is parameterized with local LTS and
    enabledness/effects of labels.
\<close>

  record ('c,'ls) local_config =
    command :: 'c
    state :: 'ls

  record ('c,'ls,'gs) global_config =
    processes :: "('c,'ls) local_config multiset"
    state :: 'gs

  locale Gen_Scheduler = cs: LTS cstep
    for cstep :: "'c \<Rightarrow> 'a+'b \<Rightarrow> 'c \<Rightarrow> bool" +
    fixes en :: "('ls\<times>'gs) \<Rightarrow> 'a \<rightharpoonup> bool"
    fixes ex :: "('ls\<times>'gs) \<Rightarrow> 'a \<rightharpoonup> ('ls\<times>'gs)"
  begin

    definition gstep_succ
      :: "('c,'ls,'gs)global_config \<Rightarrow> ('c,'ls,'gs)global_config option set"
      where
      "gstep_succ gc \<equiv> do {
        \<comment> \<open> Select process \<close>
        let lcs = global_config.processes gc;
        (lc,lcs') \<leftarrow> {(lc,lcs'). lcs = {#lc#} + lcs'};
        \<comment> \<open> Focus state \<close>
        let gs = global_config.state gc;
        let ls = local_config.state lc;

        \<comment> \<open> Select action \<close>
        let cmd = local_config.command lc;
        (a,cmd') \<leftarrow> {(a,cmd'). cstep cmd a cmd'};

        case a of
          Inl a \<Rightarrow> (
            case en (ls,gs) a of
              None \<Rightarrow> {None} \<comment> \<open> Error \<close>
            | Some False \<Rightarrow> {} \<comment> \<open> Not enabled \<close>
            | Some True \<Rightarrow> {do { \<comment> \<open> Enabled \<close>
                \<comment> \<open> Execute \<close>
                (ls,gs) \<leftarrow> ex (ls,gs) a;
                \<comment> \<open> Unfocus state. \<close>
                Some \<lparr>
                  global_config.processes = {#
                    \<lparr> local_config.command = cmd', local_config.state = ls\<rparr>
                  #} + lcs',
                  global_config.state = gs
                \<rparr>
              }}
          )
        | Inr _ \<Rightarrow> {None}
      }"

    definition gstep
      :: "(('c, 'ls, 'gs) global_config option \<times> ('c, 'ls, 'gs) global_config option) set"
      where "gstep \<equiv> {(Some c, c') |c c'. c' \<in> gstep_succ c}"

    text \<open>For the final step function, we apply stutter extension\<close>
    definition "step \<equiv> stutter_extend_edges UNIV gstep"

    lemma gstep_eq_pred_of_succ: "gstep = rel_of_succ (m2r_succ gstep_succ)"
      unfolding gstep_def by auto

    lemma gstep_eq_conv: "(c, c') \<in> gstep \<longleftrightarrow> (\<exists>cc. c=Some cc \<and> c'\<in>gstep_succ cc)"
      unfolding gstep_def by auto

    lemma [simp]: "\<not>(All Not)" by blast

    lemma ne_Some_b_conv:
      "(a\<noteq>Some b) \<longleftrightarrow> (a=Some (\<not>b) \<or> a=None)"
      by (cases a) auto

    lemma gstep_succE[cases set: gstep_succ, case_names fail_cfg fail_en fail_ex succ]:
      assumes "gc' \<in> gstep_succ gc"
      obtains
        lc lcs c' b
        where
        "processes gc = {#lc#} + lcs"
        "cstep (command lc) (Inr b) c'"
        "gc'=None"
      | lc lcs c' a
        where
        "processes gc = {#lc#} + lcs"
        "cstep (command lc) (Inl a) c'"
        "en (local_config.state lc, global_config.state gc) a = None"
        "gc' = None"
      | lc lcs c' a
        where
        "processes gc = {#lc#} + lcs"
        "cstep (command lc) (Inl a) c'"
        "en (local_config.state lc, global_config.state gc) a = Some True"
        "ex (local_config.state lc, global_config.state gc) a = None"
        "gc' = None"
      | lc lcs c' a ls' gs'
        where
        "processes gc = {#lc#} + lcs"
        "cstep (command lc) (Inl a) c'"
        "en (local_config.state lc, global_config.state gc) a = Some True"
        "ex (local_config.state lc, global_config.state gc) a = Some (ls',gs')"
        "gc' = Some \<lparr>
          global_config.processes
            = {#\<lparr> local_config.command = c', local_config.state = ls' \<rparr>#} + lcs,
          global_config.state
            = gs'
        \<rparr>"
      using assms
      unfolding gstep_succ_def
      apply (auto
        split: option.splits bool.splits Option.bind_splits sum.splits
        simp: all_conj_distrib
        elim!: neq_Some_bool_cases)
      apply (case_tac aa)
      apply (auto simp: ne_Some_b_conv)
      done

    lemma gstep_succ_fail_cmd:
      assumes "processes gc = {#lc#} + lcs"
      assumes "cstep (command lc) (Inr b) c'"
      shows "None \<in> gstep_succ gc"
      using assms unfolding gstep_succ_def
      by (fastforce)

    lemma gstep_succ_fail_en:
      assumes "processes gc = {#lc#} + lcs"
      assumes "cstep (command lc) (Inl a) c'"
      assumes "en (local_config.state lc, global_config.state gc) a = None"
      shows "None \<in> gstep_succ gc"
      using assms unfolding gstep_succ_def
      by (fastforce)

    lemma gstep_succ_fail_ex:
      assumes "processes gc = {#lc#} + lcs"
      assumes "cstep (command lc) (Inl a) c'"
      assumes "en (local_config.state lc, global_config.state gc) a = Some True"
      assumes "ex (local_config.state lc, global_config.state gc) a = None"
      shows "None \<in> gstep_succ gc"
      using assms unfolding gstep_succ_def
      by (fastforce)

    lemma gstep_succ_succ:
      assumes "processes gc = {#lc#} + lcs"
      assumes "cstep (command lc) (Inl a) c'"
      assumes "en (local_config.state lc, global_config.state gc) a = Some True"
      assumes "ex (local_config.state lc, global_config.state gc) a = Some (ls',gs')"
      shows "Some \<lparr>
          global_config.processes
            = {#\<lparr> local_config.command = c', local_config.state = ls' \<rparr>#} + lcs,
          global_config.state
            = gs'
        \<rparr> \<in> gstep_succ gc"
      using assms unfolding gstep_succ_def
      by (fastforce)

  end

  locale Gen_Scheduler_linit =
    Gen_Scheduler cstep en ex
    for cstep :: "'c \<Rightarrow> 'a+'b \<Rightarrow> 'c \<Rightarrow> bool"
    and en :: "('ls\<times>'gs) \<Rightarrow> 'a \<rightharpoonup> bool"
    and ex :: "('ls\<times>'gs) \<Rightarrow> 'a \<rightharpoonup> ('ls\<times>'gs)" +
    fixes ginit :: "('c,'ls,'gs) global_config set"
    fixes glabel :: "('c,'ls,'gs) global_config \<Rightarrow> 'l"
  begin

    definition init where "init \<equiv> Some ` ginit"
    fun label where "label None = undefined" | "label (Some gc) = glabel gc"

    lemma init_conv: "gco \<in> init \<longleftrightarrow> (\<exists>gc. gco=Some gc \<and> gc \<in> ginit)"
      unfolding init_def by auto

    definition system_automaton' :: "(('c,'ls,'gs) global_config option, 'l) sa_rec"
      where "system_automaton' \<equiv> \<lparr> g_V = UNIV, g_E = gstep, g_V0 = init, sa_L = label \<rparr>"

    lemma system_automaton'_simps[simp]:
      "g_V system_automaton' = UNIV"
      "g_E system_automaton' = gstep"
      "g_V0 system_automaton' = init"
      "sa_L system_automaton' = label"
      unfolding system_automaton'_def by simp+

    definition system_automaton :: "(('c,'ls,'gs) global_config option, 'l) sa_rec"
      where "system_automaton \<equiv> \<lparr> g_V = UNIV, g_E = step, g_V0 = init, sa_L = label \<rparr>"

    lemma system_automaton_simps[simp]:
      "g_V system_automaton = UNIV"
      "g_E system_automaton = step"
      "g_V0 system_automaton = init"
      "sa_L system_automaton = label"
      unfolding system_automaton_def by simp+

    lemma system_automaton_alt_def: "system_automaton = stutter_extend system_automaton'"
      unfolding step_def system_automaton'_def system_automaton_def stutter_extend_def by simp

    sublocale sa': sa system_automaton' by unfold_locales auto
    sublocale sa: sa system_automaton unfolding system_automaton_alt_def by (rule sa'.stutter_extend_sa)

  end

end