theory TopoS_Stateful_Policy
imports TopoS_Composition_Theory
begin

section{*Stateful Policy*}

text{*Details described in \cite{diekmann2014esss}. *}

text{* Algorithm *}
term TopoS_Composition_Theory.generate_valid_topology
text{* generates a valid high-level topology. Now we discuss how to turn this into
       a stateful policy. *}

text{*
Example:
  SensorNode produces data and has no security clearance.
  SensorSink has high security clearance
  SensorNode -> SensorSink, but not the other way round.
  Implementation: UDP in one direction

  Alice is in internal protected subnet. Google can not arbitrarily access Alice.
  Alice sends requests to google.
  It is desirable that Alice gets the response back
  Implementation: TCP and stateful packet filter that allows, once Alice establishes a connection, to get a response back via this connection.

Result:
  IFS violations undesirable.
  ACS violations may be okay under certain conditions.
*}

term all_security_requirements_fulfilled

text{* @{term "G = (V, E\<^sub>f\<^sub>i\<^sub>x, E\<^sub>s\<^sub>t\<^sub>a\<^sub>t\<^sub>e)"} *}
record 'v stateful_policy =
    hosts :: "'v set" --"nodes, vertices"
    flows_fix :: "('v \<times>'v) set" --"edges in high-level policy"
    flows_state :: "('v \<times>'v) set" --"edges that can have stateful flows, i.e. backflows"

text{* All the possible ways packets can travel in a @{typ "'v stateful_policy"}.
        They can either choose the fixed links;
        Or use a stateful link, i.e. establish state.
        Once state is established, packets can flow back via the established link.*}
definition all_flows :: "'v stateful_policy \<Rightarrow> ('v \<times> 'v) set" where
  "all_flows \<T> \<equiv> flows_fix \<T> \<union> flows_state \<T> \<union> backflows (flows_state \<T>)"

definition stateful_policy_to_network_graph :: "'v stateful_policy \<Rightarrow> 'v graph" where
  "stateful_policy_to_network_graph \<T> = \<lparr> nodes = hosts \<T>, edges = all_flows \<T> \<rparr>"

text{* @{typ "'v stateful_policy"} syntactically valid *}
locale valid_stateful_policy =
  fixes \<T> :: "'v stateful_policy"
  assumes E_valid: "fst ` (flows_fix \<T>) \<subseteq> (hosts \<T>)"
                   "snd ` (flows_fix \<T>) \<subseteq> (hosts \<T>)"
  and E_state_fix: "flows_state \<T> \<subseteq> flows_fix \<T>"
  and finite_Hosts: "finite (hosts \<T>)"
begin

  lemma E_validD: assumes "(v,v') \<in> flows_fix \<T>"
    shows "v \<in> hosts \<T>" "v' \<in> hosts \<T>"
    apply -
     apply (rule set_mp[OF E_valid(1)])
     using assms apply force
    apply (rule set_mp[OF E_valid(2)])
    using assms apply force
    done

  lemma E_state_valid: "fst ` (flows_state \<T>) \<subseteq> (hosts \<T>)"
                       "snd ` (flows_state \<T>) \<subseteq> (hosts \<T>)"
   apply -
   using E_valid(1) E_state_fix apply(blast)
   using E_valid(2) E_state_fix apply(blast)
   done

  lemma finite_fix: "finite (flows_fix \<T>)"
  proof -
    from finite_subset[OF E_valid(1) finite_Hosts] have 1: "finite (fst ` flows_fix \<T>)" .
    from finite_subset[OF E_valid(2) finite_Hosts] have 2: "finite (snd ` flows_fix \<T>)" .
    have s: "flows_fix \<T> \<subseteq> (fst ` flows_fix \<T> \<times> snd ` flows_fix \<T>)" by force
    from finite_cartesian_product[OF 1 2] have "finite (fst ` flows_fix \<T> \<times> snd ` flows_fix \<T>)" .
    from finite_subset[OF s this] show ?thesis .
  qed

  lemma finite_state: "finite (flows_state \<T>)"
    using finite_subset[OF E_state_fix finite_fix] by assumption

  lemma finite_backflows_state: "finite (backflows (flows_state \<T>))"
    using [[simproc add: finite_Collect]] by(simp add: backflows_def finite_state)

  lemma E_state_backflows_valid: "fst ` backflows (flows_state \<T>) \<subseteq> (hosts \<T>)"
                         "snd ` backflows (flows_state \<T>) \<subseteq> (hosts \<T>)"
    by(auto simp add: backflows_def E_state_valid E_state_validD)

end

text{*Minimizing stateful flows such that only newly added backflows remain*}
  definition filternew_flows_state :: "'v stateful_policy \<Rightarrow> ('v \<times> 'v) set" where
    "filternew_flows_state \<T> \<equiv> {(s, r) \<in> flows_state \<T>. (r, s) \<notin> flows_fix \<T>}"

  lemma filternew_subseteq_flows_state: "filternew_flows_state \<T> \<subseteq> flows_state \<T>"
    by(auto simp add: filternew_flows_state_def)

  --"alternative definitions, all are equal"
  lemma filternew_flows_state_alt: "filternew_flows_state \<T>  = flows_state \<T> - (backflows (flows_fix \<T>))"
    apply(simp add: backflows_def filternew_flows_state_def)
    apply(rule)
     apply blast+
    done

  lemma stateful_policy_to_network_graph_filternew: "\<lbrakk> valid_stateful_policy \<T> \<rbrakk> \<Longrightarrow>
    stateful_policy_to_network_graph \<T> =
    stateful_policy_to_network_graph \<lparr>hosts = hosts \<T>, flows_fix = flows_fix \<T>, flows_state = filternew_flows_state \<T> \<rparr>"
    apply(drule valid_stateful_policy.E_state_fix)
    apply(simp add: stateful_policy_to_network_graph_def all_flows_def)
    apply(rule Set.equalityI)
     apply(simp add: filternew_flows_state_def backflows_def)
     apply(rule, blast)+
    apply(simp add: filternew_flows_state_def backflows_def)
    apply fastforce
    done

  lemma backflows_filternew_disjunct_flows_fix:
    "\<forall> b \<in> (backflows (filternew_flows_state \<T>)). b \<notin> flows_fix \<T>"
    by(simp add: filternew_flows_state_def backflows_def)

text{* Given a high-level policy, we can construct a pretty large syntactically valid low level policy. However, the stateful policy will
       almost certainly violate security requirements! *}
  lemma "valid_graph G \<Longrightarrow> valid_stateful_policy \<lparr> hosts = nodes G, flows_fix = nodes G \<times> nodes G, flows_state = nodes G \<times> nodes G \<rparr>"
    by(simp add: valid_stateful_policy_def valid_graph_def)

text{* @{term valid_stateful_policy} implies @{term valid_graph} *}
  lemma valid_stateful_policy_is_valid_graph: "valid_stateful_policy \<T> \<Longrightarrow> valid_graph \<lparr>nodes = hosts \<T>, edges = all_flows \<T>\<rparr>"
    apply(frule valid_stateful_policy.E_state_backflows_valid)
    apply(frule valid_stateful_policy.E_state_backflows_valid(2))
    apply(frule valid_stateful_policy.E_state_valid)
    apply(frule valid_stateful_policy.E_state_valid(2))
    apply(frule valid_stateful_policy.E_valid)
    apply(frule valid_stateful_policy.E_valid(2))
    apply(simp add: all_flows_def valid_graph_def valid_stateful_policy_def
          valid_stateful_policy.finite_fix valid_stateful_policy.finite_state valid_stateful_policy.finite_backflows_state)
    apply(rule conjI)
     apply (metis image_Un sup.bounded_iff)+
    done

(*we use the second way of writing it in the paper*)
lemma "(\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T> ). F \<subseteq> backflows (filternew_flows_state \<T>)) <->
    \<Union> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T> ) \<subseteq> (backflows (flows_state \<T>)) - (flows_fix \<T>)"
    by(simp add: filternew_flows_state_alt backflows_minus_backflows, blast)

text{* When is a stateful policy @{term "\<T>"} compliant with a high-level policy @{term "G"} and the security requirements @{term "M"}? *}
locale stateful_policy_compliance =
  fixes \<T> :: "('v::vertex) stateful_policy"
  fixes G :: "'v graph"
  fixes M :: "('v) SecurityInvariant_configured list"
  assumes
    -- "the graph must be syntactically valid"
    validG: "valid_graph G"
    and
    -- "security requirements must be valid"
    validReqs: "valid_reqs M"
    and
    -- "the high-level policy must be valid"
    high_level_policy_valid: "all_security_requirements_fulfilled M G"
    and
    -- "the stateful policy must be syntactically valid"
    stateful_policy_valid:
    "valid_stateful_policy \<T>"
    and
    -- "the stateful policy must talk about the same nodes as the high-level policy"
    hosts_nodes:
    "hosts \<T> = nodes G"
    and
    -- "only flows that are allowed in the high-level policy are allowed in the stateful policy"
    flows_edges:
    "flows_fix \<T> \<subseteq> edges G"
    and
    -- "the low level policy must comply with the high-level policy"
      -- "all information flow strategy requirements must be fulfilled, i.e. no leaks!"
      compliant_stateful_IFS:
        "all_security_requirements_fulfilled (get_IFS M) (stateful_policy_to_network_graph \<T>)"
      and
      -- "No Access Control side effects must occur"
      compliant_stateful_ACS:
        "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T> ). F \<subseteq> backflows (filternew_flows_state \<T>)"

  begin
    lemma compliant_stateful_ACS_no_side_effects_filternew_helper:
      "\<forall> E \<subseteq> backflows (filternew_flows_state \<T>). \<forall> F \<in> get_offending_flows (get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> E \<rparr>. F \<subseteq> E"
    proof(rule, rule)
      fix E
      assume a1: "E \<subseteq> backflows (filternew_flows_state \<T>)"
      from validReqs have valid_ReqsACS: "valid_reqs (get_ACS M)" by(simp add: get_ACS_def valid_reqs_def)

      from compliant_stateful_ACS stateful_policy_to_network_graph_filternew[OF stateful_policy_valid] have compliant_stateful_ACS_only_state_violations_filternew:
      "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<lparr>hosts = hosts \<T>, flows_fix = flows_fix \<T>, flows_state = filternew_flows_state \<T> \<rparr>). F \<subseteq> backflows (filternew_flows_state \<T>)" by simp

      from valid_stateful_policy_is_valid_graph[OF stateful_policy_valid] have validGfilternew:
        "valid_graph \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> filternew_flows_state \<T> \<union> backflows (filternew_flows_state \<T>)\<rparr>"
        apply(simp add: all_flows_def filternew_flows_state_alt backflows_minus_backflows)
        by(auto simp add: valid_graph_def)

      from valid_stateful_policy.E_state_fix[OF stateful_policy_valid] filternew_subseteq_flows_state have flows_fix_un_filternew_simp: "flows_fix \<T> \<union> filternew_flows_state \<T> = flows_fix \<T>" by blast

      from compliant_stateful_ACS_only_state_violations_filternew have
        "\<And>m. m \<in> set (get_ACS M) \<Longrightarrow>
        \<Union>(c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> filternew_flows_state \<T> \<union> backflows (filternew_flows_state \<T>)\<rparr>) \<subseteq> backflows (filternew_flows_state \<T>)"
        by(simp add: stateful_policy_to_network_graph_def all_flows_def get_offending_flows_def, blast)

      --{*idea: use @{thm compliant_stateful_ACS} with the @{thm configured_SecurityInvariant.Un_set_offending_flows_bound_minus_subseteq}
        lemma and substract @{term "backflows (filternew_flows_state \<T>) - E"}, on the right hand side @{term E} remains, as Graph's edges @{term "flows_fix \<T>  \<union> E"} remains*}

      from configured_SecurityInvariant.Un_set_offending_flows_bound_minus_subseteq[where X="backflows (filternew_flows_state \<T>)", OF _ validGfilternew this]
        `valid_reqs (get_ACS M)`
        have
        "\<And> m E. m \<in> set (get_ACS M) \<Longrightarrow>
        \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> filternew_flows_state \<T> \<union> backflows (filternew_flows_state \<T>) - E\<rparr>. F \<subseteq> backflows (filternew_flows_state \<T>) - E"
        by(auto simp add: all_flows_def valid_reqs_def)
      from this flows_fix_un_filternew_simp have rule:
        "\<And> m E. m \<in> set (get_ACS M) \<Longrightarrow>
        \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - E\<rparr>. F \<subseteq> backflows (filternew_flows_state \<T>) - E"
        by simp

      from  backflows_finite rev_finite_subset[OF valid_stateful_policy.finite_state[OF stateful_policy_valid] filternew_subseteq_flows_state] have
        "finite (backflows (filternew_flows_state \<T>))" by blast
      from a1 this have "finite E" by (metis rev_finite_subset)

      from a1 obtain E' where E'_prop1: "backflows (filternew_flows_state \<T>) - E' = E" and E'_prop2: "E' = backflows (filternew_flows_state \<T>) - E" by blast
      from E'_prop2 `finite (backflows (filternew_flows_state \<T>))` `finite E` have "finite E'" by blast

      from Set.double_diff[where B="backflows (filternew_flows_state \<T>)" and C="backflows (filternew_flows_state \<T>)" and A="E", OF a1, simplified] have Ebackflowssimp:
        "backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E) = E" .

      have "flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E) =
          (flows_fix \<T> - (backflows (filternew_flows_state \<T>))) \<union> E"
          apply(simp add: Set.Un_Diff)
          apply(simp add: Ebackflowssimp)
          by blast
      also have "(flows_fix \<T> - (backflows (filternew_flows_state \<T>))) \<union> E = flows_fix \<T>  \<union> E" using backflows_filternew_disjunct_flows_fix by blast
      finally have flows_E_simp: "flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E) = flows_fix \<T>  \<union> E" .

      from rule[simplified E'_prop1 E'_prop2] have
      "\<And>m. m \<in> set (get_ACS M) \<Longrightarrow>
      \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E)\<rparr>.
       F \<subseteq> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E)"
       by(simp)
      from this Ebackflowssimp flows_E_simp have
      "\<And>m. m \<in> set (get_ACS M) \<Longrightarrow>
        \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E"
       by simp
      thus  "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E"
        by(simp add: get_offending_flows_def)
      qed

    theorem compliant_stateful_ACS_no_side_effects:
      "\<forall> E \<subseteq> backflows (flows_state \<T>). \<forall> F \<in> get_offending_flows(get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> E \<rparr>. F \<subseteq> E"
    proof -
      from compliant_stateful_ACS stateful_policy_to_network_graph_filternew[OF stateful_policy_valid] have a1:
      "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<lparr>hosts = hosts \<T>, flows_fix = flows_fix \<T>, flows_state = filternew_flows_state \<T> \<rparr>). F \<subseteq> backflows (filternew_flows_state \<T>)" by simp

      have backflows_split: "backflows (filternew_flows_state \<T>) \<union> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>)) = backflows (flows_state \<T>)"
        by (metis Diff_subset Un_Diff_cancel Un_absorb1 backflows_minus_backflows filternew_flows_state_alt)

      have
        "\<forall>E\<subseteq>backflows (filternew_flows_state \<T>) \<union> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>)).
             \<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E"
        proof(rule allI, rule impI)
          fix E
          assume h1: "E \<subseteq> backflows (filternew_flows_state \<T>) \<union> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>))"

          have "\<exists> E1 E2. E1 \<subseteq> backflows (filternew_flows_state \<T>) \<and> E2 \<subseteq> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>)) \<and> E1 \<union> E2 = E \<and> E1 \<inter> E2 = {}"
            apply(rule_tac x="{e \<in> E. e \<in> backflows (filternew_flows_state \<T>)}" in exI)
            apply(rule_tac x="{e \<in> E. e \<in>(backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>))}" in exI)
            apply(simp)
            apply(rule)
             apply blast
            apply(rule)
             apply blast
            apply(rule)
             using h1 apply blast
            using backflows_filternew_disjunct_flows_fix by blast

          from this obtain E1 E2 where E1_prop: "E1 \<subseteq> backflows (filternew_flows_state \<T>)" and E2_prop: "E2 \<subseteq> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>))" and "E = E1 \<union> E2" and "E1 \<inter> E2 = {}" by blast

          --{*the stateful flows are @{text "\<subseteq>"} fix flows. If substracting the new stateful flows, onyly the existing fix flows remain*}
          from E2_prop filternew_flows_state_alt have "E2 \<subseteq> flows_fix \<T>" by (metis (hide_lams, no_types) Diff_subset_conv Un_Diff_cancel2 backflows_minus_backflows inf_sup_ord(3) order.trans)
          --"hence, E2 disappears"
          from Set.Un_absorb1[OF this] have E2_absorb: "flows_fix \<T> \<union> E2 = flows_fix \<T>" by blast

          from `E = E1 \<union> E2` have E2E1eq: "E2 \<union> E1 = E" by blast

          from `E = E1 \<union> E2` `E1 \<inter> E2 = {}` have "E1 \<subseteq> E" by simp

          from compliant_stateful_ACS_no_side_effects_filternew_helper E1_prop have "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E1 \<rparr>. F \<subseteq> E1" by simp
          hence "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E2 \<union> E1 \<rparr>. F \<subseteq> E1" using E2_absorb[symmetric] by simp
          hence "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E \<rparr>. F \<subseteq> E1" using E2E1eq by (metis Un_assoc)

          from this `E1 \<subseteq> E` show "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E" by blast
        qed

      from this backflows_split show ?thesis by presburger
    qed

    corollary compliant_stateful_ACS_no_side_effects': "\<forall> E \<subseteq> backflows (flows_state \<T>). \<forall> F \<in> get_offending_flows(get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T> \<union> E \<rparr>. F \<subseteq> E"
      using compliant_stateful_ACS_no_side_effects valid_stateful_policy.E_state_fix[OF stateful_policy_valid] by (metis Un_absorb2)

    text{* The high level graph generated from the low level policy is a valid graph*}
    lemma valid_stateful_policy: "valid_graph \<lparr>nodes = hosts \<T>, edges = all_flows \<T>\<rparr>"
      by(rule valid_stateful_policy_is_valid_graph,fact stateful_policy_valid)

    text{* The security requirements are definitely fulfilled if we consider only the fixed flows and the
           normal direction of the stateful flows (i.e. no backflows).
           I.e. considering no states, everything must be fulfilled *}
    lemma compliant_stateful_ACS_static_valid: "all_security_requirements_fulfilled (get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T>  \<rparr>"
    proof -
      from validReqs have valid_ReqsACS: "valid_reqs (get_ACS M)" by(simp add: get_ACS_def valid_reqs_def)
      from validG hosts_nodes[symmetric] have validG': "valid_graph \<lparr> nodes = hosts \<T>, edges = edges G  \<rparr>" by(case_tac G, simp)
      from high_level_policy_valid have "all_security_requirements_fulfilled (get_ACS M) G"
        by(simp add: get_ACS_def all_security_requirements_fulfilled_def)
      from this hosts_nodes[symmetric] have "all_security_requirements_fulfilled (get_ACS M) \<lparr> nodes = hosts \<T>, edges = edges G  \<rparr>"
        by(case_tac G, simp)
      from all_security_requirements_fulfilled_mono[OF valid_ReqsACS flows_edges validG' this] show ?thesis .
    qed
    theorem compliant_stateful_ACS_static_valid':
      "all_security_requirements_fulfilled M \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T>  \<rparr>"
      proof -
        from validReqs have valid_ReqsIFS: "valid_reqs (get_IFS M)" by(simp add: get_IFS_def valid_reqs_def)

        --"show that it holds for IFS, by monotonicity as it holds for more in IFS"
        from all_security_requirements_fulfilled_mono[OF valid_ReqsIFS _ valid_stateful_policy compliant_stateful_IFS[unfolded stateful_policy_to_network_graph_def]] have
          goalIFS: "all_security_requirements_fulfilled (get_IFS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T>  \<rparr>" by(simp add: all_flows_def)

        from valid_stateful_policy.E_state_fix[OF stateful_policy_valid] have "flows_fix \<T> \<union> flows_state \<T> =  flows_fix \<T>" by blast
        from this compliant_stateful_ACS_static_valid have goalACS:
          "all_security_requirements_fulfilled (get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T>  \<rparr>" by simp

        --"ACS and IFS together form M, we know it holds for ACS"
        from goalACS goalIFS show ?thesis
          apply(simp add: all_security_requirements_fulfilled_def get_IFS_def get_ACS_def)
          by fastforce
    qed

    text{* The flows with state are a subset of the flows allowed by the policy *}
    theorem flows_state_edges: "flows_state \<T> \<subseteq> edges G"
      using valid_stateful_policy.E_state_fix[OF stateful_policy_valid] flows_edges by simp

    text{* All offending flows are subsets of the reveres stateful flows *}
    lemma compliant_stateful_ACS_only_state_violations:
      "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>). F \<subseteq> backflows (flows_state \<T>)"
      proof -
        have "backflows (filternew_flows_state \<T>) \<subseteq> backflows (flows_state \<T>)" by (metis Diff_subset backflows_minus_backflows filternew_flows_state_alt)
        from compliant_stateful_ACS this have
          "\<forall> F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>). F \<subseteq> backflows (flows_state \<T>)"
          by (metis subset_trans)
        thus ?thesis .
      qed
    theorem compliant_stateful_ACS_only_state_violations': "\<forall>F \<in> get_offending_flows M (stateful_policy_to_network_graph \<T>). F \<subseteq> backflows (flows_state \<T>)"
      proof -
        from validReqs have valid_ReqsIFS: "valid_reqs (get_IFS M)" by(simp add: get_IFS_def valid_reqs_def)
        have offending_split: "\<And>G. get_offending_flows M G = (get_offending_flows (get_IFS M) G \<union> get_offending_flows (get_ACS M) G)"
          apply(simp add: get_offending_flows_def get_IFS_def get_ACS_def) by blast
       show ?thesis
        apply(subst offending_split)
        using compliant_stateful_ACS_only_state_violations
              all_security_requirements_fulfilled_imp_get_offending_empty[OF valid_ReqsIFS compliant_stateful_IFS]
        by auto
      qed

    text {* All violations are backflows of valid flows *}
    corollary compliant_stateful_ACS_only_state_violations_union: "\<Union> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>) \<subseteq> backflows (flows_state \<T>)"
    using compliant_stateful_ACS_only_state_violations by fastforce

    corollary compliant_stateful_ACS_only_state_violations_union': "\<Union> get_offending_flows M (stateful_policy_to_network_graph \<T>) \<subseteq> backflows (flows_state \<T>)"
    using compliant_stateful_ACS_only_state_violations' by fastforce

    text{* All individual flows cause no side effects, i.e. each backflow causes at most itself as violation, no other
           side-effect violations are induced. *}
    lemma  compliant_stateful_ACS_no_state_singleflow_side_effect:
      "\<forall> (v\<^sub>1, v\<^sub>2) \<in> backflows (flows_state \<T>).
       (\<Union> get_offending_flows(get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T> \<union> {(v\<^sub>1, v\<^sub>2)} \<rparr>) \<subseteq> {(v\<^sub>1, v\<^sub>2)}"
    using compliant_stateful_ACS_no_side_effects' by blast
  end

subsection{* Summarizing the important theorems *}

  text{* No information flow security requirements are violated (including all added stateful flows)*}
  thm stateful_policy_compliance.compliant_stateful_IFS

  text{* There are not access control side effects when allowing stateful backflows.
          I.e. for all possible subsets of the to-allow backflows, the violations they cause are only these backflows themselves*}
  thm stateful_policy_compliance.compliant_stateful_ACS_no_side_effects'

    text{* Also, considering all backflows individually, they cause no side effect, i.e. the only violation added is the backflow itself *}
    thm stateful_policy_compliance.compliant_stateful_ACS_no_state_singleflow_side_effect

    text{* In particular, all introduced offending flows for access control strategies are at most the stateful backflows *}
    thm stateful_policy_compliance.compliant_stateful_ACS_only_state_violations_union
    text{* Which implies: all introduced offending flows are at most the stateful backflows *}
    thm stateful_policy_compliance.compliant_stateful_ACS_only_state_violations_union'

  text{* Disregarding the backflows of stateful flows, all security requirements are fulfilled. *}
  thm stateful_policy_compliance.compliant_stateful_ACS_static_valid'

end


section \<open>Values\<close>
theory Sep_Value
imports
  "../../lib/Monad"
begin

  subsection \<open>Values and Addresses\<close>
  datatype 'a val = STRUCT (fields: "'a val list") | PRIMITIVE (the: 'a)
  hide_const (open) val.fields val.the
  define_lenses (open) val

  datatype va_item = PFLD (the_va_item_idx: nat)
  type_synonym vaddr = "va_item list"

  subsection \<open>Focusing on Address\<close>
  fun lens_of_item where
    "lens_of_item (PFLD i) = val.fields\<^sub>L \<bullet>\<^sub>L idx\<^sub>L i"

  definition "lens_of_vaddr vp = foldr (\<lambda>i L. lens_of_item i \<bullet>\<^sub>L L) vp id\<^sub>L"

  lemma lens_of_vaddr_simps[simp]:
    "lens_of_vaddr [] = id\<^sub>L"
    "lens_of_vaddr (i#is) = lens_of_item i \<bullet>\<^sub>L lens_of_vaddr is"
    unfolding lens_of_vaddr_def
    by auto

  lemma ex_two_vals[simp, intro]: "\<exists>a b::'a val. a \<noteq> b" by auto

  lemma lens_of_item_rnl[simp, intro!]: "rnlens (lens_of_item i :: 'a val \<Longrightarrow> 'a val)"
  proof (cases i)
    case [simp]: (PFLD i)
    show ?thesis
      apply (rule rnlensI[where x="PRIMITIVE undefined" and y="STRUCT undefined" and s="STRUCT (replicate (Suc i) undefined)"])
      by simp_all

  qed

  lemma lens_of_item_hlens[simp, intro!]: "hlens (lens_of_item i :: 'a val \<Longrightarrow> 'a val)"
    by (cases i) (auto)

  lemma lens_of_vaddr_rnl[simp, intro!]: "rnlens (lens_of_vaddr vp)"
    by (induction vp) auto

  lemma lens_of_vaddr_hlens[simp, intro!]: "hlens (lens_of_vaddr vp)"
    by (induction vp) auto

  lemma lens_of_item_complete[simp, intro!]: "complete_lens (lens_of_item i)"
    apply (rule)
    apply (simp; fail)
    by (meson lens.get_put lens.get_put_pre lens_of_item_rnl rnlens_def)

  subsection \<open>Loading and Storing Address\<close>
  definition "vload err a \<equiv> zoom (lift_lens err (lens_of_vaddr a)) Monad.get"
  definition "vstore err x a \<equiv> zoom (lift_lens err (lens_of_vaddr a)) (Monad.set x)"

  subsection \<open>GEP\<close>

  definition "checked_gep err addr item \<equiv> doM {
    let addr = addr@[item];
    use (lift_lens err (lens_of_vaddr addr));
    return addr
  }"

  subsection \<open>Structure of Value\<close>
  datatype 's vstruct = VS_STRUCT "'s vstruct list" | VS_PRIMITIVE 's

  locale structured_value_defs =
    fixes struct_of_primval :: "'a \<Rightarrow> 's"
      and init_primval :: "'s \<Rightarrow> 'a"
  begin
    fun struct_of_val :: "'a val \<Rightarrow> 's vstruct" where
      "struct_of_val (STRUCT fs) = VS_STRUCT (map struct_of_val fs)"
    | "struct_of_val (PRIMITIVE x) = VS_PRIMITIVE (struct_of_primval x)"

    fun init_val :: "'s vstruct \<Rightarrow> 'a val" where
      "init_val (VS_STRUCT fs) = STRUCT (map init_val fs)"
    | "init_val (VS_PRIMITIVE ps) = PRIMITIVE (init_primval ps)"

  end

  lemmas structured_value_code[code] =
    structured_value_defs.struct_of_val.simps
    structured_value_defs.init_val.simps

  locale structured_value = structured_value_defs struct_of_primval init_primval
    for struct_of_primval :: "'a \<Rightarrow> 's"
      and init_primval :: "'s \<Rightarrow> 'a" +
    assumes struct_of_init_primval[simp]: "struct_of_primval (init_primval s) = s"
  begin

    lemma put_preserves_struct:
      assumes "pre_get (lens_of_vaddr a) s"
      assumes "struct_of_val (get' (lens_of_vaddr a) s) = struct_of_val x"
      shows "struct_of_val (put' (lens_of_vaddr a) x s) = struct_of_val s"
      using assms
    proof (induction a arbitrary: s)
      case Nil
      then show ?case by auto
    next
      case (Cons i as)
      then show ?case
        by (cases s; cases i; simp add: map_upd_eq)

    qed

    lemma struct_of_init[simp]: "struct_of_val (init_val s) = s"
      apply (induction s)
      by (auto simp: map_idI)

  end

end


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

(*
  The state and error monads in Isabelle,
*)

chapter "Monads"

theory StateMonad (* FIXME: untested/unused *)
imports Lib
begin

type_synonym ('s,'a) state_monad = "'s \<Rightarrow> 'a \<times> 's"

definition
  runState :: "('s,'a) state_monad \<Rightarrow> 's \<Rightarrow> 'a \<times> 's"
where
  "runState \<equiv> id"

definition
  "return a \<equiv> \<lambda>s. (a,s)"

definition
  bind :: "('s, 'a) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_monad) \<Rightarrow>
           ('s, 'b) state_monad" (infixl ">>=" 60)
where
  "bind f g \<equiv> (\<lambda>s. let (v,s') = f s in (g v) s')"

definition
  "bind' f g \<equiv> bind f (\<lambda>_. g)"

declare bind'_def [iff]

definition
  "get \<equiv> \<lambda>s. (s,s)"

definition
  "put s \<equiv> \<lambda>_. ((),s)"

definition
  "gets f \<equiv> get >>= (\<lambda>s. return $ f s)"

definition
  "modify f \<equiv> get >>= (\<lambda>s. put $ f s)"

definition
  "when p s \<equiv> if p then s else return ()"

definition
  "unless p s \<equiv> when (\<not>p) s"

text \<open>The monad laws:\<close>

lemma return_bind [simp]: "(return x >>= f) = f x"
  by (simp add: return_def bind_def runState_def)

lemma bind_return [simp]: "(m >>= return) = m"
  unfolding bind_def return_def runState_def
  by (simp add: Let_def split_def)

lemma bind_assoc:
  fixes m :: "('s,'a) state_monad"
  fixes f :: "'a \<Rightarrow> ('s,'b) state_monad"
  fixes g :: "'b \<Rightarrow> ('s,'c) state_monad"
  shows "(m >>= f) >>= g  =  m >>= (\<lambda>x. f x >>= g)"
  unfolding bind_def
  by (clarsimp simp add: Let_def split_def)

text \<open>An errorT state\_monad (returnOk=return, bindE=bind):\<close>

definition
  "returnOk \<equiv> return o Inr"

definition
  "throwError \<equiv> return o Inl"

definition
  "Ok \<equiv> Inr"

definition
  lift :: "('a \<Rightarrow> ('s, 'e + 'b) state_monad) \<Rightarrow> 'e+'a \<Rightarrow> ('s, 'e + 'b) state_monad"
where
  "lift f v \<equiv> case v of Inl e \<Rightarrow> throwError e | Inr v' \<Rightarrow> f v'"

definition
  lift2 :: "('c \<Rightarrow> ('a, 'b + 'e + 'd) state_monad) \<Rightarrow> 'b+'e+'c \<Rightarrow> ('a, 'b+'e+'d) state_monad"
where
  "lift2 f v \<equiv> case v of
                 Inl e \<Rightarrow> throwError e
               | Inr v'' \<Rightarrow> (case v'' of Inl e' \<Rightarrow> return $ Inr $ Inl e' | Inr v' \<Rightarrow> f v')"

(* This is used if you are just trying to throwError by itself *)
definition
  raise :: "'a \<Rightarrow> 's \<Rightarrow> ('a + unit) \<times> 's"
where
  "raise \<equiv> return \<circ> Inl"

definition
  bindE :: "('s, 'e + 'a) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'e + 'b) state_monad) \<Rightarrow>
            ('s, 'e + 'b) state_monad"  (infixl ">>=E" 60)
where
  "bindE f g \<equiv> bind f (lift g)"

definition
  "bindE' f g \<equiv> bindE f (\<lambda>_. g)"

definition
  liftE :: "('s,'a) state_monad \<Rightarrow> ('s, 'e+'a) state_monad" where
  "liftE f \<equiv> \<lambda>s. let (v,s') = f s in (Inr v, s')"

definition
  "whenE P f \<equiv> if P then f else returnOk ()"

definition
  "unlessE P f \<equiv> if P then returnOk () else f"

definition
  "throw_opt ex x \<equiv> case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"

definition
  "bindEE f g \<equiv> bind f (lift2 g)"
definition
  "bindEE' f g \<equiv> bindEE f (\<lambda>_. g)"

definition
  "modifyE \<equiv> (liftE \<circ> modify)"
definition
  "getsE x \<equiv> liftE $ gets x"

syntax
  bindEE :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixl ">>=EE" 60)

declare
  bindE'_def [iff]
  bindEE_def [iff]
  bindEE'_def [iff]

lemma returnOk_bindE [simp]: "(returnOk x >>=E f) = f x"
  unfolding bindE_def return_def returnOk_def
  by (clarsimp simp: lift_def bind_def)

lemma lift_return [simp]:
  "lift (return \<circ> Inr) = return"
  by (auto simp: lift_def throwError_def split: sum.splits)

lemma bindE_returnOk [simp]: "(m >>=E returnOk) = m"
  by (simp add: bindE_def returnOk_def)

 lemma bindE_assoc:
  shows "(m >>=E f) >>=E g  =  m >>=E (\<lambda>x. f x >>=E g)"
  by (auto simp: Let_def bindE_def bind_def lift_def split_def runState_def throwError_def return_def
           split: sum.splits)

lemma throwError_bindE [simp]:
  "throwError E >>=E f = throwError E"
  by (simp add: bindE_def bind_def throwError_def lift_def return_def)

subsection "Syntax for state monad"

nonterminal
  dobinds and dobind and nobind

syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do (_);//   (_)//od)" 100)
syntax (xsymbols)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)

translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "CONST bind' b e"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

lemma "do x \<leftarrow> return 1; return 2; return x od = return 1"
  by simp

subsection "Syntax for errorT state monad"

syntax
  "_doE" :: "[dobinds, 'a] => 'a"  ("(doE (_);//    (_)//odE)" 100)

translations
  "_doE (_dobinds b bs) e"  == "_doE b (_doE bs e)"
  "_doE (_nobind b) e"      == "CONST bindE' b e"
  "doE x <- a; e odE"       == "a >>=E (\<lambda>x. e)"

subsection "Syntax for errorT errorT state monad"

syntax
  "_doEE" :: "[dobinds, 'a] => 'a" ("(doEE (_);//     (_)//odEE)" 100)

translations
  "_doEE (_dobinds b bs) e"  == "_doEE b (_doEE bs e)"
  "_doEE (_nobind b) e"      == "CONST bindEE' b e"
  "doEE x <- a; e odEE"      == "a >>=EE (\<lambda>x. e)"

primrec
  inc_forloop :: "nat \<Rightarrow> 'g::{plus,one} \<Rightarrow> ('g \<Rightarrow> ('a, 'b + unit) state_monad) \<Rightarrow>
                  ('a, 'b + unit) state_monad"
where
  "inc_forloop 0 current body = returnOk ()"
| "inc_forloop (Suc left) current body = doE body current ; inc_forloop left (current+1) body odE"

primrec
  do_times :: "nat \<Rightarrow> ('a, 'b + unit) state_monad \<Rightarrow> ('a, 'b + unit) state_monad \<Rightarrow>
              ('a, 'b + unit) state_monad"
where
  "do_times 0 body increment = returnOk ()"
| "do_times (Suc left) body increment = doE body ; increment ; do_times left body increment odE"

definition
  function_update :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" where
  "function_update index modifier f \<equiv>
   \<lambda>x. if x = index then modifier (f x) else (f x)"

lemma "doE x \<leftarrow> returnOk 1; returnOk 2; returnOk x odE = returnOk 1"
  by simp

term "doEE x \<leftarrow> returnOk $ Ok 1; returnOk $ Ok 2; returnOk $ Ok x odEE"

definition
  "skip \<equiv> returnOk $ Ok ()"

definition
  "liftM f m \<equiv> do x \<leftarrow> m; return (f x) od"
definition
  "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"

definition
  "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"

definition
  "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"
definition
  "mapM_x f xs \<equiv> sequence_x (map f xs)"

definition
  "sequence xs \<equiv> let mcons = (\<lambda>p q. p >>= (\<lambda>x. q >>= (\<lambda>y. return (x#y))))
                 in foldr mcons xs (return [])"

definition
  "mapM f xs \<equiv> sequence (map f xs)"

definition
  "sequenceE_x xs \<equiv> foldr (\<lambda>x y. doE uu <- x; y odE) xs (returnOk ())"
definition
  "mapME_x f xs \<equiv> sequenceE_x (map f xs)"

definition
  "sequenceEE_x xs \<equiv> foldr bindEE' xs (skip)"
definition
  "mapMEE_x f xs \<equiv> sequenceEE_x (map f xs)"

definition
  catch :: "('s, 'a + 'b) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_monad) \<Rightarrow> ('s, 'b) state_monad"
where
  "catch f handler \<equiv> do x \<leftarrow> f;
                        case x of
                            Inr b \<Rightarrow> return b
                          | Inl e \<Rightarrow> handler e
                      od"

definition
  handleE :: "('s, 'x + 'a) state_monad \<Rightarrow>
              ('x \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
              ('s, 'x + 'a) state_monad" (infix "<handle>" 11) where
  "f <handle> handler \<equiv>
   do v \<leftarrow> f; case v of Inl e \<Rightarrow> handler e | Inr v' \<Rightarrow> return v od"

definition
  handle_elseE :: "('s, 'x + 'a) state_monad \<Rightarrow>
                   ('x \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
                   ('a \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
                   ('s, 'x + 'a) state_monad" ("_ <handle> _ <else> _" 10)
where
  "f <handle> handler <else> continue \<equiv>
    do v \<leftarrow> f;
       case v of Inl e \<Rightarrow> handler e
               | Inr v \<Rightarrow> continue v
    od"

definition
  isSkip :: "('s, 'a) state_monad \<Rightarrow> bool" where
  "isSkip m \<equiv> \<forall>s. \<exists>r. m s = (r,s)"

lemma isSkip_bindI: "\<lbrakk> isSkip f; \<And>x. isSkip (g x) \<rbrakk> \<Longrightarrow> isSkip (f >>= g)"
  apply (clarsimp simp: isSkip_def bind_def Let_def)
  apply (erule_tac x=s in allE)
  apply clarsimp
  done

lemma isSkip_return [simp,intro!]:
  "isSkip (return x)"
  by (simp add: isSkip_def return_def)

lemma isSkip_gets [simp,intro!]:
  "isSkip (gets x)"
  by (simp add: isSkip_def gets_def get_def bind_def return_def)

lemma isSkip_liftE [iff]: "isSkip (liftE f) = isSkip f"
  apply (simp add: isSkip_def liftE_def Let_def split_def)
  apply rule
   apply clarsimp
   apply (case_tac "f s")
   apply (erule_tac x = s in allE)
   apply simp
  apply clarsimp
  apply (case_tac "f s")
  apply (erule_tac x = s in allE)
  apply simp
  done

lemma isSkip_liftI [simp, intro!]:
  "\<lbrakk> \<And>y. x = Inr y \<Longrightarrow> isSkip (f y) \<rbrakk> \<Longrightarrow> isSkip (lift f x)"
  by (simp add: lift_def throwError_def return_def isSkip_def split: sum.splits)

lemma isSkip_Error [iff]:
  "isSkip (throwError x)"
  by (simp add: throwError_def)

lemma isSkip_returnOk [iff]:
  "isSkip (returnOk x)"
  by (simp add: returnOk_def)

lemma isSkip_throw_opt [iff]:
  "isSkip (throw_opt e x)"
  by (simp add: throw_opt_def split: option.splits)

lemma nested_bind [simp]:
  "do x <- do y <- f; return (g y) od; h x od =
   do y <- f; h (g y) od"
  apply (clarsimp simp add: bind_def)
  apply (rule ext)
  apply (clarsimp simp add: Let_def split_def runState_def return_def)
  done

lemma skip_bind:
  "isSkip s \<Longrightarrow> do _ \<leftarrow> s; g od = g"
  apply (clarsimp simp add: bind_def)
  apply (rule ext)
  apply (clarsimp simp add: isSkip_def Let_def)
  apply (erule_tac x=sa in allE)
  apply clarsimp
  done

lemma bind_eqI:
  "\<lbrakk> f = f'; \<And>x. g x = g' x \<rbrakk> \<Longrightarrow> f >>= g = f' >>= g'"
  by (simp add: bind_def)

lemma bind'_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s s'. f' s = (v, s') \<Longrightarrow> g s' = g' s' \<rbrakk> \<Longrightarrow> bind' f g = bind' f' g'"
  by (auto intro: bind_cong)

lemma bindE_cong[fundef_cong]:
  "\<lbrakk> M = M' ; \<And>v s s'. M' s = (Inr v, s') \<Longrightarrow> N v s' = N' v s' \<rbrakk> \<Longrightarrow> bindE M N = bindE M' N'"
  apply (simp add: bindE_def)
  apply (rule bind_cong)
   apply (rule refl)
  apply (unfold lift_def)
  apply (case_tac v, simp_all)
  done

lemma bindE'_cong[fundef_cong]:
  "\<lbrakk> M = M' ; \<And>v s s'. M' s = (Inr v, s') \<Longrightarrow> N s' = N' s' \<rbrakk> \<Longrightarrow> bindE' M N = bindE' M' N'"
  by (auto intro: bindE_cong)

definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) state_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>") where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> split Q (f s)"

definition
  validE :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) state_monad \<Rightarrow> ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>, \<lbrace>_\<rbrace>") where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> split (\<lambda>r s. case r of Inr b \<Rightarrow> Q b s
                                                  | Inl a \<Rightarrow> R a s) (f s)"

lemma validE_def2:
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace> \<lambda>r s. case r of Inr b \<Rightarrow> Q b s | Inl a \<Rightarrow> R a s \<rbrace>"
  by (unfold valid_def validE_def)

(* FIXME: modernize *)
syntax top :: "'a \<Rightarrow> bool" ("\<top>")
       bottom :: "'a \<Rightarrow> bool" ("\<bottom>")

translations
  "\<top>" == "\<lambda>_. CONST True"
  "\<bottom>" == "\<lambda>_. CONST False"

definition
  bipred_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" (infixl "And" 96)
where
  "bipred_conj P Q \<equiv> \<lambda>x y. P x y \<and> Q x y"

definition
  bipred_disj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" (infixl "Or" 91)
where
  "bipred_disj P Q \<equiv> \<lambda>x y. P x y \<or> Q x y"

definition
  bipred_neg :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" ("Not _") where
  "bipred_neg P \<equiv> \<lambda>x y. \<not> P x y"

syntax toptop :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<top>\<top>")
       botbot :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<bottom>\<bottom>")

translations "\<top>\<top>" == "\<lambda>_ _. CONST True"
             "\<bottom>\<bottom>" == "\<lambda>_ _. CONST False"

definition
  pred_lift_exact :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" ("\<guillemotleft>_,_\<guillemotright>") where
  "pred_lift_exact P Q \<equiv> \<lambda>x y. P x \<and> Q y"

lemma pred_lift_taut[simp]: "\<guillemotleft>\<top>,\<top>\<guillemotright> = \<top>\<top>"
  by (simp add:pred_lift_exact_def)

lemma pred_lift_cont_l[simp]: "\<guillemotleft>\<bottom>,x\<guillemotright> = \<bottom>\<bottom>"
  by (simp add:pred_lift_exact_def)

lemma pred_lift_cont_r[simp]: "\<guillemotleft>x,\<bottom>\<guillemotright> = \<bottom>\<bottom>"
  by (simp add:pred_lift_exact_def)

lemma pred_liftI[intro!]: "\<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> \<guillemotleft>P,Q\<guillemotright> x y"
  by (simp add:pred_lift_exact_def)

lemma pred_exact_split:
  "\<guillemotleft>P,Q\<guillemotright> = (\<guillemotleft>P,\<top>\<guillemotright> And \<guillemotleft>\<top>,Q\<guillemotright>)"
  by (simp add:pred_lift_exact_def bipred_conj_def)

lemma pred_andE[elim!]: "\<lbrakk> (A and B) x; \<lbrakk> A x; B x \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (simp add:pred_conj_def)

lemma pred_andI[intro!]: "\<lbrakk> A x; B x \<rbrakk> \<Longrightarrow> (A and B) x"
  by (simp add:pred_conj_def)

lemma bipred_conj_app[simp]: "(P And Q) x = (P x and Q x)"
  by (simp add:pred_conj_def bipred_conj_def)

lemma bipred_disj_app[simp]: "(P Or Q) x = (P x or Q x)"
  by (simp add:pred_disj_def bipred_disj_def)

lemma pred_conj_app[simp]: "(P and Q) x = (P x \<and> Q x)"
  by (simp add:pred_conj_def)

lemma pred_disj_app[simp]: "(P or Q) x = (P x \<or> Q x)"
  by (simp add:pred_disj_def)

lemma pred_notnotD[simp]: "(not not P) = P"
  by (simp add:pred_neg_def)

lemma bipred_notnotD[simp]: "(Not Not P) = P"
  by (simp add:bipred_neg_def)

lemma pred_lift_add[simp]: "\<guillemotleft>P,Q\<guillemotright> x = ((\<lambda>s. P x) and Q)"
  by (simp add:pred_lift_exact_def pred_conj_def)

lemma pred_and_true[simp]: "(P and \<top>) = P"
  by (simp add:pred_conj_def)

lemma pred_and_true_var[simp]: "(\<top> and P) = P"
  by (simp add:pred_conj_def)

lemma pred_and_false[simp]: "(P and \<bottom>) = \<bottom>"
  by (simp add:pred_conj_def)

lemma pred_and_false_var[simp]: "(\<bottom> and P) = \<bottom>"
  by (simp add:pred_conj_def)

lemma seq':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>;
     \<forall>x. P x \<longrightarrow> \<lbrace>C\<rbrace> g x \<lbrace>D\<rbrace>;
     \<forall>x s. B x s \<longrightarrow> P x \<and> C s \<rbrakk> \<Longrightarrow>
   \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  apply (clarsimp simp: valid_def runState_def bind_def Let_def split_def)
  apply (case_tac "f s")
  apply fastforce
  done

lemma seq:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>"
  assumes "\<And>x. P x \<Longrightarrow> \<lbrace>C\<rbrace> g x \<lbrace>D\<rbrace>"
  assumes "\<And>x s. B x s \<Longrightarrow> P x \<and> C s"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  using assms by (blast intro: seq')

lemma seq_invar_nobind:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. \<lbrace>A\<rbrace> g x \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  apply(rule_tac B="\<guillemotleft>\<top>,A\<guillemotright>" and C="A" and P="\<top>" in seq)
    apply(insert f_valid g_valid)
    apply(simp_all add:pred_lift_exact_def)
  done

lemma seq_invar_bind:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>B,A\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. P x \<Longrightarrow> \<lbrace>A\<rbrace> g x \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  assumes bind: "\<And>x. B x \<Longrightarrow> P x"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  apply(rule_tac B="\<guillemotleft>B,A\<guillemotright>" and C="A" and P="P" in seq)
    apply(insert f_valid g_valid bind)
    apply(simp_all add: pred_lift_exact_def)
  done

lemma seq_noimp:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>C,B\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. C x \<Longrightarrow> \<lbrace>B\<rbrace> g x \<lbrace>D\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  apply(rule_tac B="\<guillemotleft>C,B\<guillemotright>" and C="B" and P="C" in seq)
    apply(insert f_valid g_valid, simp_all add:pred_lift_exact_def)
  done

lemma seq_ext':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>; \<forall>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
  by (clarsimp simp: valid_def runState_def bind_def Let_def split_def)

lemma seq_ext:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>" "\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
  using assms by (blast intro: seq_ext')

lemma seqE':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>,\<lbrace>E\<rbrace>;
     \<forall>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow>
   \<lbrace>A\<rbrace> doE x \<leftarrow> f; g x odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  apply(simp add: bindE_def lift_def bind_def Let_def split_def)
  apply(clarsimp simp: validE_def)
  apply(rename_tac s r x)
  apply(case_tac "fst (f s)"; case_tac r; fastforce simp:throwError_def return_def)
  done

lemma seqE:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>,\<lbrace>E\<rbrace>" "\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  shows "\<lbrace>A\<rbrace> doE x \<leftarrow> f; g x odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  using assms by(blast intro: seqE')

lemma get_sp:
  "\<lbrace>P\<rbrace> get \<lbrace>\<lambda>a s. s = a \<and> P s\<rbrace>"
  by (simp add:get_def valid_def)

lemma put_sp:
  "\<lbrace>\<top>\<rbrace> put a \<lbrace>\<lambda>_ s. s = a\<rbrace>"
  by (simp add:put_def valid_def)

lemma return_sp:
  "\<lbrace>P\<rbrace> return a \<lbrace>\<lambda>b s. b = a \<and> P s\<rbrace>"
  by (simp add:return_def valid_def)

lemma hoare_post_conj [intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> Q \<rbrace>; \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> a \<lbrace> Q And R \<rbrace>"
  by (simp add:valid_def split_def bipred_conj_def)

lemma hoare_pre_disj [intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace>; \<lbrace> Q \<rbrace> a \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> P or Q \<rbrace> a \<lbrace> R \<rbrace>"
  by (simp add:valid_def pred_disj_def)

lemma hoare_post_taut [iff]: "\<lbrace> P \<rbrace> a \<lbrace> \<top>\<top> \<rbrace>"
  by (simp add:valid_def)

lemma hoare_pre_cont [iff]: "\<lbrace> \<bottom> \<rbrace> a \<lbrace> P \<rbrace>"
  by (simp add:valid_def)

lemma hoare_return [intro!]: "\<And>x. P x \<Longrightarrow> \<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>P,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_drop [iff]: "\<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>\<top>,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_drop_var [iff]: "\<lbrace> Q \<rbrace> return x \<lbrace> \<lambda>r. Q \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_only [intro!]: "\<And>x. P x \<Longrightarrow> \<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>P,\<top>\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_get [iff]: "\<lbrace> P \<rbrace> get \<lbrace> \<guillemotleft>P,P\<guillemotright> \<rbrace>"
  by (simp add:valid_def get_def pred_lift_exact_def)

lemma hoare_gets [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) s \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> gets f \<lbrace> Q \<rbrace>"
  by (simp add:valid_def gets_def get_def bind_def return_def)

lemma hoare_modify [iff]: "\<lbrace> P o f \<rbrace> modify f \<lbrace> \<guillemotleft>\<top>,P\<guillemotright> \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_modifyE [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> modify f \<lbrace> \<guillemotleft>\<top>,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_modifyE_var [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> modify f \<lbrace> \<lambda>r s. Q s \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_put [intro!]: "P x \<Longrightarrow> \<lbrace> Q \<rbrace> put x \<lbrace> \<guillemotleft>\<top>,P\<guillemotright>\<rbrace>"
  by (simp add:valid_def put_def pred_lift_exact_def)

lemma hoare_if [intro!]:
  "\<lbrakk> P \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> R \<rbrace>; \<not> P \<Longrightarrow> \<lbrace> Q \<rbrace> b \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> if P then a else b \<lbrace> R \<rbrace>"
  by (simp add:valid_def)

lemma hoare_when [intro!]:
  "\<lbrakk> \<lbrakk> P \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>; \<And>s. \<lbrakk> \<not> P; Q s \<rbrakk> \<Longrightarrow> R s \<rbrakk> \<Longrightarrow>
   \<lbrace> Q \<rbrace> when P a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>"
  by (simp add:valid_def when_def split_def return_def pred_lift_exact_def)

lemma hoare_unless [intro!]:
  "\<lbrakk> \<And>s. \<lbrakk> P; Q s \<rbrakk> \<Longrightarrow> R s; \<lbrakk> \<not> P \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace> \<rbrakk> \<Longrightarrow>
   \<lbrace> Q \<rbrace> unless P a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>"
  by (simp add:valid_def unless_def split_def when_def return_def pred_lift_exact_def)

lemma hoare_pre_subst: "\<lbrakk> A = B; \<lbrace>A\<rbrace> a \<lbrace>C\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>B\<rbrace> a \<lbrace>C\<rbrace>"
  by (clarsimp simp:valid_def split_def)

lemma hoare_post_subst: "\<lbrakk> B = C; \<lbrace>A\<rbrace> a \<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> a \<lbrace>C\<rbrace>"
  by (clarsimp simp:valid_def split_def)

lemma hoare_pre_tautI: "\<lbrakk> \<lbrace>A and P\<rbrace> a \<lbrace>B\<rbrace>; \<lbrace>A and not P\<rbrace> a \<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> a \<lbrace>B\<rbrace>"
  by (clarsimp simp:valid_def split_def pred_conj_def pred_neg_def, blast)

lemma hoare_return_var[intro!]: "\<lbrakk> \<And>x. P x \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> \<lbrace>R\<rbrace> return x \<lbrace>\<guillemotleft>Q,R\<guillemotright>\<rbrace>)"
  by (rule hoare_return)

lemma hoare_return_drop_imp[intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> return x \<lbrace>\<guillemotleft>\<top>,Q\<guillemotright>\<rbrace>"
 by (simp add:valid_def return_def)

lemmas hoare_case_option_inference = option.exhaust

lemma hoare_pre_imp: "\<lbrakk> \<lbrace>Q\<rbrace> a \<lbrace>R\<rbrace>; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>"
  by (simp add:valid_def)

lemma hoare_post_imp: "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>; \<And>r s. Q r s \<Longrightarrow> R r s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>"
  by (simp add:valid_def split_def)

lemma hoare_post_impE:
  "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>; \<And>r s. Q r s \<Longrightarrow> R r s; \<And>e s. E e s \<Longrightarrow> F e s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>,\<lbrace>F\<rbrace>"
  apply(clarsimp simp: validE_def)
  apply(rename_tac s r x)
  apply(case_tac r; fastforce)
  done

lemma "isSkip f \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> \<guillemotleft>\<top>,P\<guillemotright> \<rbrace>"
  apply (clarsimp simp: valid_def split_def isSkip_def)
  apply (rename_tac s)
  apply (case_tac "f s")
  apply (erule_tac x=s in allE)
  apply auto
  done

end


(*
 * Copyright Julius Michaelis, Cornelius Diekmann
 * SPDX-License-Identifier: BSD-3-Clause
 *)

section\<open>Increment and Decrement Machine Words Without Wrap-Around\<close>

theory Next_and_Prev
imports
  Aligned
begin

text \<open>Previous and next words addresses, without wrap around.\<close>

lift_definition word_next :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  is \<open>\<lambda>k. if 2 ^ LENGTH('a) dvd k + 1 then - 1 else k + 1\<close>
  by (simp flip: take_bit_eq_0_iff) (metis take_bit_add)

lift_definition word_prev :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  is \<open>\<lambda>k. if 2 ^ LENGTH('a) dvd k then 0 else k - 1\<close>
  by (simp flip: take_bit_eq_0_iff) (metis take_bit_diff)

lemma word_next_unfold:
  \<open>word_next w = (if w = - 1 then - 1 else w + 1)\<close>
  by transfer (simp flip: take_bit_eq_mask_iff_exp_dvd)

lemma word_prev_unfold:
  \<open>word_prev w = (if w = 0 then 0 else w - 1)\<close>
  by transfer (simp flip: take_bit_eq_0_iff)

lemma [code]:
  \<open>Word.the_int (word_prev w :: 'a::len word) =
    (if w = 0 then Word.the_int w else Word.the_int w - 1)\<close>
  by transfer (simp add: take_bit_eq_0_iff take_bit_decr_eq)

lemma word_adjacent_union:
  "word_next e = s' \<Longrightarrow> s \<le> e \<Longrightarrow> s' \<le> e' \<Longrightarrow> {s..e} \<union> {s'..e'} = {s .. e'}"
  apply (simp add: word_next_unfold ivl_disj_un_two_touch split: if_splits)
  apply (drule sym)
  apply simp
  apply (subst word_atLeastLessThan_Suc_atLeastAtMost_union)
     apply (simp_all add: word_Suc_le)
  done

end