theory TopoS_Stateful_Policy
imports TopoS_Composition_Theory
begin

section\<open>Stateful Policy\<close>

text\<open>Details described in \<^cite>\<open>"diekmann2014esss"\<close>.\<close>

text\<open>Algorithm\<close>
term TopoS_Composition_Theory.generate_valid_topology
text\<open>generates a valid high-level topology. Now we discuss how to turn this into
       a stateful policy.\<close>

text\<open>
Example:
  SensorNode produces data and has no security level.
  SensorSink has high security level
  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.
\<close>

term all_security_requirements_fulfilled

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

text\<open>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.\<close>
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\<open>@{typ "'v stateful_policy"} syntactically well-formed\<close>
locale wf_stateful_policy =
  fixes \<T> :: "'v stateful_policy"
  assumes E_wf: "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 finite_fix: "finite (flows_fix \<T>)"
  proof -
    from finite_subset[OF E_wf(1) finite_Hosts] have 1: "finite (fst ` flows_fix \<T>)" .
    from finite_subset[OF E_wf(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_wf: "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\<open>Minimizing stateful flows such that only newly added backflows remain\<close>
  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)

  \<comment> \<open>alternative definitions, all are equal\<close>
  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> wf_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 wf_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\<open>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!\<close>
  lemma "wf_graph G \<Longrightarrow> wf_stateful_policy \<lparr> hosts = nodes G, flows_fix = nodes G \<times> nodes G, flows_state = nodes G \<times> nodes G \<rparr>"
    by(simp add: wf_stateful_policy_def wf_graph_def)

text\<open>@{const wf_stateful_policy} implies @{term wf_graph}\<close>
  lemma wf_stateful_policy_is_wf_graph: "wf_stateful_policy \<T> \<Longrightarrow> wf_graph \<lparr>nodes = hosts \<T>, edges = all_flows \<T>\<rparr>"
    apply(frule wf_stateful_policy.E_state_backflows_wf)
    apply(frule wf_stateful_policy.E_state_backflows_wf(2))
    apply(frule wf_stateful_policy.E_state_valid)
    apply(frule wf_stateful_policy.E_state_valid(2))
    apply(frule wf_stateful_policy.E_wf)
    apply(frule wf_stateful_policy.E_wf(2))
    apply(simp add: all_flows_def wf_graph_def wf_stateful_policy_def
          wf_stateful_policy.finite_fix wf_stateful_policy.finite_state wf_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>)) \<longleftrightarrow>
    \<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\<open>When is a stateful policy @{term "\<T>"} compliant with a high-level policy @{term "G"} and the security requirements @{term "M"}?\<close>
locale stateful_policy_compliance =
  fixes \<T> :: "('v::vertex) stateful_policy"
  fixes G :: "'v graph"
  fixes M :: "('v) SecurityInvariant_configured list"
  assumes
    \<comment> \<open>the graph must be syntactically valid\<close>
    wfG: "wf_graph G"
    and
    \<comment> \<open>security requirements must be valid\<close>
    validReqs: "valid_reqs M"
    and
    \<comment> \<open>the high-level policy must be valid\<close>
    high_level_policy_valid: "all_security_requirements_fulfilled M G"
    and
    \<comment> \<open>the stateful policy must be syntactically valid\<close>
    stateful_policy_wf:
    "wf_stateful_policy \<T>"
    and
    \<comment> \<open>the stateful policy must talk about the same nodes as the high-level policy\<close>
    hosts_nodes:
    "hosts \<T> = nodes G"
    and
    \<comment> \<open>only flows that are allowed in the high-level policy are allowed in the stateful policy\<close>
    flows_edges:
    "flows_fix \<T> \<subseteq> edges G"
    and
    \<comment> \<open>the low level policy must comply with the high-level policy\<close>
      \<comment> \<open>all information flow strategy requirements must be fulfilled, i.e. no leaks!\<close>
      compliant_stateful_IFS:
        "all_security_requirements_fulfilled (get_IFS M) (stateful_policy_to_network_graph \<T>)"
      and
      \<comment> \<open>No Access Control side effects must occur\<close>
      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_wf] 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 wf_stateful_policy_is_wf_graph[OF stateful_policy_wf] have wfGfilternew:
        "wf_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: wf_graph_def)

      from wf_stateful_policy.E_state_fix[OF stateful_policy_wf] 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)

      \<comment> \<open>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\<close>

      from configured_SecurityInvariant.Un_set_offending_flows_bound_minus_subseteq[where X="backflows (filternew_flows_state \<T>)", OF _ wfGfilternew this]
        \<open>valid_reqs (get_ACS M)\<close>
        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 wf_stateful_policy.finite_state[OF stateful_policy_wf] 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 \<open>finite (backflows (filternew_flows_state \<T>))\<close> \<open>finite E\<close> 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_wf] 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

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

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

          from \<open>E = E1 \<union> E2\<close> \<open>E1 \<inter> E2 = {}\<close> 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 \<open>E1 \<subseteq> E\<close> 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 wf_stateful_policy.E_state_fix[OF stateful_policy_wf] by (metis Un_absorb2)

    text\<open>The high level graph generated from the low level policy is a valid graph\<close>
    lemma valid_stateful_policy: "wf_graph \<lparr>nodes = hosts \<T>, edges = all_flows \<T>\<rparr>"
      by(rule wf_stateful_policy_is_wf_graph,fact stateful_policy_wf)

    text\<open>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\<close>
    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 wfG hosts_nodes[symmetric] have wfG': "wf_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 wfG' 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)

        \<comment> \<open>show that it holds for IFS, by monotonicity as it holds for more in IFS\<close>
        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 wf_stateful_policy.E_state_fix[OF stateful_policy_wf] 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

        \<comment> \<open>ACS and IFS together form M, we know it holds for ACS\<close>
        from goalACS goalIFS show ?thesis
          apply(simp add: all_security_requirements_fulfilled_def get_IFS_def get_ACS_def)
          by fastforce
    qed

    text\<open>The flows with state are a subset of the flows allowed by the policy\<close>
    theorem flows_state_edges: "flows_state \<T> \<subseteq> edges G"
      using wf_stateful_policy.E_state_fix[OF stateful_policy_wf] flows_edges by simp

    text\<open>All offending flows are subsets of the reveres stateful flows\<close>
    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 \<open>All violations are backflows of valid flows\<close>
    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\<open>All individual flows cause no side effects, i.e. each backflow causes at most itself as violation, no other
           side-effect violations are induced.\<close>
    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\<open>Summarizing the important theorems\<close>

  text\<open>No information flow security requirements are violated (including all added stateful flows)\<close>
  thm stateful_policy_compliance.compliant_stateful_IFS

  text\<open>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\<close>
  thm stateful_policy_compliance.compliant_stateful_ACS_no_side_effects'

    text\<open>Also, considering all backflows individually, they cause no side effect, i.e. the only violation added is the backflow itself\<close>
    thm stateful_policy_compliance.compliant_stateful_ACS_no_state_singleflow_side_effect

    text\<open>In particular, all introduced offending flows for access control strategies are at most the stateful backflows\<close>
    thm stateful_policy_compliance.compliant_stateful_ACS_only_state_violations_union
    text\<open>Which implies: all introduced offending flows are at most the stateful backflows\<close>
    thm stateful_policy_compliance.compliant_stateful_ACS_only_state_violations_union'

  text\<open>Disregarding the backflows of stateful flows, all security requirements are fulfilled.\<close>
  thm stateful_policy_compliance.compliant_stateful_ACS_static_valid'

end


\<^marker>\<open>creator "Bohua Zhan"\<close>
\<^marker>\<open>contributor "Kevin Kappelmann"\<close>
section \<open>Logic Proof Steps\<close>
theory Proof_Steps_Logic
imports Auto2_HOTG
  HOTG.Pairs
begin
paragraph \<open>Summary\<close>
text \<open>Setup for proof steps related to logic. Adapted from \<open>Auto2_HOL/HOL/Logic_Thms.thy\<close>.\<close>

subsection \<open>Trivial contradictions\<close>
setup \<open>add_resolve_prfstep @{thm HOL.refl}\<close>
setup \<open>add_forward_prfstep @{thm contra_triv}\<close>
setup \<open>add_resolve_prfstep @{thm TrueI}\<close>
lemma FalseD [resolve]: "\<not>False" by simp
lemma exists_triv_eq [resolve]: "\<exists>x. x = x" by auto

subsection \<open>Not\<close>
setup \<open>add_forward_prfstep_cond @{thm HOL.not_sym}
  [with_filt (not_type_filter "s" boolT)]\<close>

subsection \<open>Iff\<close>
setup \<open>add_gen_prfstep ("iff_intro1",
  [WithGoal @{term_pat "(?A::bool) = ?B"},
   CreateCase @{term_pat "?A::bool"},
   WithScore 25])\<close>
lemma iff_goal:
  "A \<noteq> B \<Longrightarrow> A \<Longrightarrow> \<not>B" "A \<noteq> B \<Longrightarrow> B \<Longrightarrow> \<not>A"
  "A \<noteq> B \<Longrightarrow> \<not>A \<Longrightarrow> B" "A \<noteq> B \<Longrightarrow> \<not>B \<Longrightarrow> A"
  "(\<not>A) \<noteq> B \<Longrightarrow> A \<Longrightarrow> B" "A \<noteq> (\<not>B) \<Longrightarrow> B \<Longrightarrow> A" by auto
setup \<open>fold (fn th => add_forward_prfstep_cond th [with_score 1]) @{thms iff_goal}\<close>

subsection \<open>Quantifiers: normalization\<close>
lemma exists_split: "(\<exists>x y. P x \<and> Q y) = ((\<exists>x. P x) \<and> (\<exists>y. Q y))" by simp
setup \<open>add_backward_prfstep (equiv_backward_th @{thm exists_split})\<close>
subsection \<open>Case analysis\<close>
setup \<open>add_gen_prfstep ("case_intro",
  [WithTerm @{term_pat "if ?cond then (?yes::?'a) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
setup \<open>add_gen_prfstep ("case_intro_fact",
  [WithFact @{term_pat "if ?cond then (?yes::bool) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
setup \<open>add_gen_prfstep ("case_intro_goal",
  [WithGoal @{term_pat "if ?cond then (?yes::bool) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
lemma if_eval':
  "P \<Longrightarrow> (if \<not>P then x else y) = y" by auto
lemma ifb_eval:
  "P \<Longrightarrow> (if P then (x::bool) else y) = x"
  "\<not>P \<Longrightarrow> (if P then (x::bool) else y) = y"
  "P \<Longrightarrow> (if \<not>P then (x::bool) else y) = y" by auto
setup \<open>fold (fn th => add_rewrite_rule_cond th [with_score 1])
  ([@{thm HOL.if_P}, @{thm HOL.if_not_P}, @{thm if_eval'}] @ @{thms ifb_eval})\<close>

subsection \<open>THE and \<exists>!\<close>
setup \<open>add_forward_prfstep_cond @{thm theI'} [with_term "THE x. ?P x"]\<close>
setup \<open>add_gen_prfstep ("ex1_case",
  [WithGoal @{term_pat "\<exists>!x. ?P x"}, CreateConcl @{term_pat "\<exists>x. ?P x"}])\<close>
lemma ex_ex1I' [backward1]: "\<forall>y. P y \<longrightarrow> x = y \<Longrightarrow> P x \<Longrightarrow> \<exists>!x. P x" by auto
lemma the1_equality': "P a \<Longrightarrow> \<exists>!x. P x \<Longrightarrow> (THE x. P x) = a" by (simp add: the1_equality)
setup \<open>add_forward_prfstep_cond @{thm the1_equality'} [with_term "THE x. ?P x"]\<close>

(* subsection \<open>Axiom of choice\<close>
setup \<open>add_prfstep_custom ("ex_choice",
  [WithGoal @{term_pat "EX f. !x. ?Q f x"}],
  (fn ((id, _), ths) => fn _ => fn _ =>
    let
      val choice = @{thm choice} |> apply_to_thm (Conv.rewr_conv UtilBase.backward_conv_th)
    in
      [Update.thm_update (id, (ths MRS choice))]
    end
    handle THM _ => []))
\<close> *)

(*subsection \<open>Least operator\<close>
lemma Least_equality' [backward1]:
  "P (x::('a::order)) \<Longrightarrow> \<forall>y. P y \<longrightarrow> x \<le> y \<Longrightarrow> Least P = x" by (simp add: Least_equality)*)

subsection \<open>Pairs\<close>
setup \<open>add_rewrite_rule @{thm fst_pair_eq}\<close>
setup \<open>add_rewrite_rule @{thm snd_pair_eq}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm pair_eq_iff})\<close>
setup \<open>Auto2_Setup.Normalizer.add_rewr_normalizer ("rewr_case", @{thm uncurry_def})\<close>

subsection \<open>Let\<close>
setup \<open>Auto2_Setup.Normalizer.add_rewr_normalizer ("rewr_let", @{thm Let_def})\<close>

(*subsection \<open>Equivalence relations\<close>
setup \<open>add_forward_prfstep @{thm Relation.symD}\<close>
setup \<open>add_backward_prfstep @{thm Relation.symI}\<close>
setup \<open>add_forward_prfstep @{thm Relation.transD}\<close>
setup \<open>add_backward_prfstep @{thm Relation.transI}\<close>

subsection \<open>Options\<close>
setup \<open>add_resolve_prfstep @{thm option.distinct(1)}\<close>
setup \<open>add_rewrite_rule @{thm Option.option.sel}\<close>
setup \<open>add_forward_prfstep @{thm option.collapse}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm option.simps(1)})\<close>
setup \<open>fold (fn th => add_rewrite_rule_cond th [with_score 1]) @{thms Option.option.case}\<close>*)

end


theory Basics_AffineRealSpace3D_aux
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"binary_inverse\", \"antisym\", \"refl\", \"trans\",
     \"subtype_def\", \"subtype_pred_def\", \"ga_assoc___Xx__\",
     \"ga_right_unit___Xx__\", \"ga_left_unit___Xx__\", \"inv_Group\",
     \"rinv_Group\", \"ga_comm___Xx__\", \"ga_assoc___Xx___1\",
     \"ga_right_unit___Xx___1\", \"ga_left_unit___Xx___1\",
     \"distr1_Ring\", \"distr2_Ring\", \"left_zero\", \"right_zero\",
     \"ga_comm___Xx___1\", \"noZeroDiv\", \"zeroNeqOne\", \"Ax1\",
     \"ga_assoc___Xx___2\", \"ga_right_unit___Xx___2\",
     \"ga_left_unit___Xx___2\", \"inv_Group_1\", \"rinv_Group_1\",
     \"binary_inverse_1\", \"Ax1_1\", \"refl_1\", \"trans_1\",
     \"antisym_1\", \"dichotomy_TotalOrder\", \"FWO_plus_left\",
     \"FWO_times_left\", \"FWO_plus_right\", \"FWO_times_right\",
     \"FWO_plus\", \"inf_def\", \"Real_completeness\",
     \"geq_def_ExtPartialOrder\", \"less_def_ExtPartialOrder\",
     \"greater_def_ExtPartialOrder\", \"ga_comm_inf\", \"ga_comm_sup\",
     \"inf_def_ExtPartialOrder\", \"sup_def_ExtPartialOrder\",
     \"ga_comm_min\", \"ga_comm_max\", \"ga_assoc_min\",
     \"ga_assoc_max\", \"ga_left_comm_min\", \"ga_left_comm_max\",
     \"min_def_ExtTotalOrder\", \"max_def_ExtTotalOrder\",
     \"min_inf_relation\", \"max_sup_relation\",
     \"RealNonNeg_pred_def\", \"RealPos_pred_def\", \"Ax3\", \"Ax4\",
     \"RealNonNeg_subtype\", \"RealPos_subtype\", \"abs_def\",
     \"times_cancel_right_nonneg_leq\", \"times_leq_nonneg_cond\",
     \"sqr_def\", \"sqrt_def\", \"Pos_def\", \"X2_def_Real\",
     \"X3_def_Real\", \"X4_def_Real\", \"X5_def_Real\", \"X6_def_Real\",
     \"X7_def_Real\", \"X8_def_Real\", \"X9_def_Real\",
     \"ZeroToNine_type\", \"decimal_def\", \"ga_select_C1\",
     \"ga_select_C2\", \"ga_select_C3\", \"Zero_Point\",
     \"Point_choice\", \"ga_select_C1_1\", \"ga_select_C2_1\",
     \"ga_select_C3_1\", \"Zero_Vector\", \"VectorStar_pred_def\",
     \"Ax7\", \"VectorStar_subtype\", \"def_of_vector_addition\",
     \"def_of_minus_vector\", \"binary_inverse_2_1\",
     \"scalar_multiplication\", \"scalar_product\", \"vector_product\",
     \"ONB1\", \"ONB2\", \"ONB3\", \"cross_left_homogenity\",
     \"cross_product_antisymmetric\", \"binary_inverse_1_1_1\",
     \"distributive\", \"homogeneous\", \"symmetric\", \"pos_definite\",
     \"unit\", \"mix_assoc\", \"distr_Field\", \"distr_Space\",
     \"ga_assoc___Xx___3_1\", \"ga_right_unit___Xx___3_1\",
     \"ga_left_unit___Xx___3_1\", \"inv_Group_2_1\", \"rinv_Group_2_1\",
     \"ga_comm___Xx___3\", \"zero_by_left_zero\",
     \"zero_by_right_zero\", \"inverse_by_XMinus1\",
     \"right_distributive\", \"right_homogeneous\", \"non_degenerate\",
     \"lindep_def\", \"lindep_reflexivity\", \"lindep_symmetry\",
     \"simple_lindep_condition\", \"lindep_nonlindep_transitivity\",
     \"norm_from_inner_prod_def\", \"proj_def\", \"orthcomp_def\",
     \"orthogonal_def\", \"orth_symmetric\", \"lindep_orth_transitive\",
     \"orthogonal_existence_theorem\",
     \"orthogonal_on_zero_projection\",
     \"orthogonal_projection_theorem\",
     \"orthogonal_decomposition_theorem\",
     \"unique_orthogonal_decomposition\", \"cross_product_orthogonal\",
     \"cross_product_zero_iff_lindep\", \"e1e2_nonlindep\",
     \"point_vector_map\", \"plus_injective\", \"plus_surjective\",
     \"point_vector_plus_associative\"]"

typedecl NonZero
typedecl Real
typedecl RealNonNeg
typedecl RealPos
typedecl VectorStar
typedecl ZeroToNine

datatype Point = X_P "Real" "Real" "Real" ("P/'(_,/ _,/ _')" [3,3,3] 999)
datatype Vector = X_V "Real" "Real" "Real" ("V/'(_,/ _,/ _')" [3,3,3] 999)

consts
C1X1 :: "Point => Real" ("C1''/'(_')" [3] 999)
C1X2 :: "Vector => Real" ("C1''''/'(_')" [3] 999)
C2X1 :: "Point => Real" ("C2''/'(_')" [3] 999)
C2X2 :: "Vector => Real" ("C2''''/'(_')" [3] 999)
C3X1 :: "Point => Real" ("C3''/'(_')" [3] 999)
C3X2 :: "Vector => Real" ("C3''''/'(_')" [3] 999)
X0X1 :: "Point" ("0''")
X0X2 :: "Real" ("0''''")
X0X3 :: "Vector" ("0'_3")
X1X1 :: "NonZero" ("1''")
X1X2 :: "Real" ("1''''")
X2 :: "Real" ("2''")
X3 :: "Real" ("3''")
X4 :: "Real" ("4''")
X5 :: "Real" ("5''")
X6 :: "Real" ("6''")
X7 :: "Real" ("7''")
X8 :: "Real" ("8''")
X9 :: "Real" ("9''")
XMinus__XX1 :: "Real => Real" ("(-''/ _)" [56] 56)
XMinus__XX2 :: "Vector => Vector" ("(-''''/ _)" [56] 56)
XVBarXVBar__XVBarXVBar :: "Vector => Real" ("(||/ _/ ||)" [10] 999)
X_Pos :: "Real => bool" ("Pos/'(_')" [3] 999)
X_RealNonNeg_inj :: "RealNonNeg => Real" ("RealNonNeg'_inj/'(_')" [3] 999)
X_RealNonNeg_pred :: "Real => bool" ("RealNonNeg'_pred/'(_')" [3] 999)
X_RealNonNeg_proj :: "Real => RealNonNeg" ("RealNonNeg'_proj/'(_')" [3] 999)
X_RealPos_inj :: "RealPos => Real" ("RealPos'_inj/'(_')" [3] 999)
X_RealPos_pred :: "Real => bool" ("RealPos'_pred/'(_')" [3] 999)
X_RealPos_proj :: "Real => RealPos" ("RealPos'_proj/'(_')" [3] 999)
X_VectorStar_inj :: "VectorStar => Vector" ("VectorStar'_inj/'(_')" [3] 999)
X_VectorStar_pred :: "Vector => bool" ("VectorStar'_pred/'(_')" [3] 999)
X_VectorStar_proj :: "Vector => VectorStar" ("VectorStar'_proj/'(_')" [3] 999)
X__XAtXAt__X :: "ZeroToNine => Real => Real" ("(_/ @@/ _)" [54,54] 52)
X__XGtXEq__X :: "Real => Real => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGt__X :: "Real => Real => bool" ("(_/ >''/ _)" [44,44] 42)
X__XHash__X :: "Vector => Vector => Vector" ("(_/ #''/ _)" [54,54] 52)
X__XLtXEq__X :: "Real => Real => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLt__X :: "Real => Real => bool" ("(_/ <''/ _)" [44,44] 42)
X__XMinus__XX1 :: "Real => Real => Real" ("(_/ -''/ _)" [54,54] 52)
X__XMinus__XX2 :: "Vector => Vector => Vector" ("(_/ -''''/ _)" [54,54] 52)
X__XPlus__XX1 :: "Point => Vector => Point" ("(_/ +''/ _)" [54,54] 52)
X__XPlus__XX2 :: "Real => Real => Real" ("(_/ +''''/ _)" [54,54] 52)
X__XPlus__XX3 :: "Vector => Vector => Vector" ("(_/ +'_3/ _)" [54,54] 52)
X__XSlash__X :: "Real => NonZero => Real" ("(_/ '/''/ _)" [54,54] 52)
X__Xx__XX1 :: "NonZero => NonZero => NonZero" ("(_/ *''/ _)" [54,54] 52)
X__Xx__XX2 :: "Real => Real => Real" ("(_/ *''''/ _)" [54,54] 52)
X__Xx__XX3 :: "Real => Vector => Vector" ("(_/ *'_3/ _)" [54,54] 52)
X__Xx__XX4 :: "Vector => Vector => Real" ("(_/ *'_4/ _)" [54,54] 52)
X_abs :: "Real => RealNonNeg" ("abs''/'(_')" [3] 999)
X_choose :: "(Point => bool) => Point" ("choose''/'(_')" [3] 999)
X_gn_inj :: "'a => 'b" ("gn'_inj/'(_')" [3] 999)
X_gn_proj :: "'a => 'b partial" ("gn'_proj/'(_')" [3] 999)
X_inv :: "NonZero => NonZero" ("inv''/'(_')" [3] 999)
X_isSubtype :: "('s => 't) => ('t => 's) => bool" ("isSubtype/'(_,/ _')" [3,3] 999)
X_isSubtypeWithPred :: "('t => bool) => ('s => 't) => ('t => 's) => bool" ("isSubtypeWithPred/'(_,/ _,/ _')" [3,3,3] 999)
X_lindep :: "Vector => Vector => bool" ("lindep/'(_,/ _')" [3,3] 999)
X_max :: "Real => Real => Real" ("max''/'(_,/ _')" [3,3] 999)
X_min :: "Real => Real => Real" ("min''/'(_,/ _')" [3,3] 999)
X_orth :: "Vector => Vector => bool" ("orth/'(_,/ _')" [3,3] 999)
X_orthcomp :: "Vector => Vector => Vector" ("orthcomp/'(_,/ _')" [3,3] 999)
X_proj :: "Vector => Vector => Vector" ("proj/'(_,/ _')" [3,3] 999)
X_sqr :: "Real => RealNonNeg" ("sqr/'(_')" [3] 999)
X_sqrt :: "RealNonNeg => RealNonNeg" ("sqrt/'(_')" [3] 999)
X_sup :: "Real => Real => Real partial" ("sup/'(_,/ _')" [3,3] 999)
e1 :: "Vector"
e2 :: "Vector"
e3 :: "Vector"
infX1 :: "Real => Real => Real partial" ("inf''/'(_,/ _')" [3,3] 999)
infX2 :: "(Real => bool) => Real partial" ("inf''''/'(_')" [3] 999)

axioms
binary_inverse [rule_format] :
"ALL x. ALL y. x /' y = x *'' inv'(y)"

antisym [rule_format] :
"ALL x. ALL y. __~__ x y & __~__ y x --> x = y"

refl [rule_format] : "ALL x. __~__ x x"

trans [rule_format] :
"ALL x. ALL y. ALL z. __~__ x y & __~__ y z --> __~__ x z"

subtype_def [rule_format] :
"ALL injection.
 ALL projection.
 isSubtype(injection, projection) =
 (ALL x. x = projection (injection x))"

subtype_pred_def [rule_format] :
"ALL X_P.
 ALL injection.
 ALL projection.
 isSubtypeWithPred(X_P, injection, projection) =
 ((isSubtype(injection, projection) &
   (ALL x. X_P x --> x = injection (projection x))) &
  (ALL x. X_P (injection x)))"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x +'' y) +'' z = x +'' (y +'' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x +'' 0'' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 0'' +'' x = x"

inv_Group [rule_format] : "ALL x. -' x +'' x = 0''"

rinv_Group [rule_format] : "ALL x. x +'' -' x = 0''"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x +'' y = y +'' x"

ga_assoc___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. (x *'' y) *'' z = x *'' (y *'' z)"

ga_right_unit___Xx___1 [rule_format] : "ALL x. x *'' 1'' = x"

ga_left_unit___Xx___1 [rule_format] : "ALL x. 1'' *'' x = x"

distr1_Ring [rule_format] :
"ALL x. ALL y. ALL z. (x +'' y) *'' z = (x *'' z) +'' (y *'' z)"

distr2_Ring [rule_format] :
"ALL x. ALL y. ALL z. z *'' (x +'' y) = (z *'' x) +'' (z *'' y)"

left_zero [rule_format] : "ALL x. 0'' *'' x = 0''"

right_zero [rule_format] : "ALL x. x *'' 0'' = 0''"

ga_comm___Xx___1 [rule_format] : "ALL x. ALL y. x *'' y = y *'' x"

noZeroDiv [rule_format] :
"ALL x. ALL y. x *'' y = 0'' --> x = 0'' | y = 0''"

zeroNeqOne [rule_format] : "~ 1'' = 0''"

Ax1 [rule_format] : "ALL x. defOp (gn_proj(x)) = (~ x = 0'')"

ga_assoc___Xx___2 [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx___2 [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx___2 [rule_format] : "ALL x. 1' *' x = x"

inv_Group_1 [rule_format] : "ALL x. inv'(x) *' x = 1'"

rinv_Group_1 [rule_format] : "ALL x. x *' inv'(x) = 1'"

binary_inverse_1 [rule_format] :
"ALL x. ALL y. x -' y = x +'' -' y"

Ax1_1 [rule_format] :
"ALL x. ALL y. x /' y = x *'' gn_inj(inv'(y))"

refl_1 [rule_format] : "ALL x. x <=' x"

trans_1 [rule_format] :
"ALL x. ALL y. ALL z. x <=' y & y <=' z --> x <=' z"

antisym_1 [rule_format] :
"ALL x. ALL y. x <=' y & y <=' x --> x = y"

dichotomy_TotalOrder [rule_format] :
"ALL x. ALL y. x <=' y | y <=' x"

FWO_plus_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b --> a +'' c <=' b +'' c"

FWO_times_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b & 0'' <=' c --> a *'' c <=' b *'' c"

FWO_plus_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c --> a +'' b <=' a +'' c"

FWO_times_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c & 0'' <=' a --> a *'' b <=' a *'' c"

FWO_plus [rule_format] :
"ALL a.
 ALL b. ALL c. ALL d. a <=' c & b <=' d --> a +'' b <=' c +'' d"

inf_def [rule_format] :
"ALL S.
 ALL m.
 inf''(S) = makePartial m =
 (ALL m2. (ALL x. S x --> x <=' m2) --> m <=' m2)"

Real_completeness [rule_format] :
"ALL S.
 (EX x. S x) & (EX B. ALL x. S x --> x <=' B) -->
 (EX m. makePartial m = inf''(S))"

geq_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >=' y) = (y <=' x)"

less_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x <' y) = (x <=' y & ~ x = y)"

greater_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >' y) = (y <' x)"

ga_comm_inf [rule_format] : "ALL x. ALL y. inf'(x, y) = inf'(y, x)"

ga_comm_sup [rule_format] : "ALL x. ALL y. sup(x, y) = sup(y, x)"

inf_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 inf'(x, y) = makePartial z =
 (z <=' x & z <=' y & (ALL t. t <=' x & t <=' y --> t <=' z))"

sup_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 sup(x, y) = makePartial z =
 (x <=' z & y <=' z & (ALL t. x <=' t & y <=' t --> z <=' t))"

ga_comm_min [rule_format] : "ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_comm_max [rule_format] : "ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_min [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_assoc_max [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_left_comm_min [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_left_comm_max [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

min_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. min'(x, y) = (if x <=' y then x else y)"

max_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. max'(x, y) = (if x <=' y then y else x)"

min_inf_relation [rule_format] :
"ALL x. ALL y. makePartial (min'(x, y)) = inf'(x, y)"

max_sup_relation [rule_format] :
"ALL x. ALL y. makePartial (max'(x, y)) = sup(x, y)"

RealNonNeg_pred_def [rule_format] :
"ALL x. RealNonNeg_pred(x) = (x >=' 0'')"

RealPos_pred_def [rule_format] :
"ALL x. RealPos_pred(x) = (x >' 0'')"

Ax3 [rule_format] :
"ALL x. defOp (gn_proj(x)) = RealNonNeg_pred(x)"

Ax4 [rule_format] : "ALL x. defOp (gn_proj(x)) = RealPos_pred(x)"

RealNonNeg_subtype [rule_format] :
"isSubtypeWithPred(X_RealNonNeg_pred, X_RealNonNeg_inj,
 X_RealNonNeg_proj)"

RealPos_subtype [rule_format] :
"isSubtypeWithPred(X_RealPos_pred, X_RealPos_inj, X_RealPos_proj)"

abs_def [rule_format] :
"ALL x.
 makePartial (abs'(x)) =
 (if 0'' <=' x then gn_proj(x) else gn_proj(-' x))"

times_cancel_right_nonneg_leq [rule_format] :
"ALL a. ALL b. ALL c. a *'' b <=' c *'' b & b >=' 0'' --> a <=' c"

times_leq_nonneg_cond [rule_format] :
"ALL a. ALL b. 0'' <=' a *'' b & b >=' 0'' --> 0'' <=' a"

sqr_def [rule_format] :
"ALL r. gn_inj(sqr(r)) = makePartial (r *'' r)"

sqrt_def [rule_format] : "ALL q. sqr(gn_inj(sqrt(q))) = q"

Pos_def [rule_format] : "ALL x. Pos(x) = (0'' <=' x)"

X2_def_Real [rule_format] : "2' = gn_inj(1') +'' gn_inj(1')"

X3_def_Real [rule_format] : "3' = 2' +'' gn_inj(1')"

X4_def_Real [rule_format] : "4' = 3' +'' gn_inj(1')"

X5_def_Real [rule_format] : "5' = 4' +'' gn_inj(1')"

X6_def_Real [rule_format] : "6' = 5' +'' gn_inj(1')"

X7_def_Real [rule_format] : "7' = 6' +'' gn_inj(1')"

X8_def_Real [rule_format] : "8' = 7' +'' gn_inj(1')"

X9_def_Real [rule_format] : "9' = 8' +'' gn_inj(1')"

ZeroToNine_type [rule_format] :
"ALL x.
 defOp (gn_proj(x)) =
 (((((((((x = 0'' | makePartial x = gn_inj(1')) | x = 2') |
        x = 3') |
       x = 4') |
      x = 5') |
     x = 6') |
    x = 7') |
   x = 8') |
  x = 9')"

decimal_def [rule_format] :
"ALL m.
 ALL X_n. m @@ X_n = (gn_inj(m) *'' (9' +'' gn_inj(1'))) +'' X_n"

ga_select_C1 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C1'(P(x_1, x_2, x_3)) = x_1"

ga_select_C2 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C2'(P(x_1, x_2, x_3)) = x_2"

ga_select_C3 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C3'(P(x_1, x_2, x_3)) = x_3"

Zero_Point [rule_format] : "0' = P(0'', 0'', 0'')"

Point_choice [rule_format] :
"ALL X_P. (EX y. X_P y) --> X_P (choose'(X_P))"

ga_select_C1_1 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C1''(V(x_1, x_2, x_3)) = x_1"

ga_select_C2_1 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C2''(V(x_1, x_2, x_3)) = x_2"

ga_select_C3_1 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C3''(V(x_1, x_2, x_3)) = x_3"

Zero_Vector [rule_format] : "0_3 = V(0'', 0'', 0'')"

VectorStar_pred_def [rule_format] :
"ALL x. VectorStar_pred(x) = (~ x = 0_3)"

Ax7 [rule_format] :
"ALL x. defOp (gn_proj(x)) = VectorStar_pred(x)"

VectorStar_subtype [rule_format] :
"isSubtypeWithPred(X_VectorStar_pred, X_VectorStar_inj,
 X_VectorStar_proj)"

def_of_vector_addition [rule_format] :
"ALL x.
 ALL y.
 x +_3 y =
 V(C1''(x) +'' C1''(y), C2''(x) +'' C2''(y), C3''(x) +'' C3''(y))"

def_of_minus_vector [rule_format] :
"ALL x. -'' x = V(-' C1''(x), -' C2''(x), -' C3''(x))"

binary_inverse_2_1 [rule_format] :
"ALL x. ALL y. x -'' y = x +_3 -'' y"

scalar_multiplication [rule_format] :
"ALL x.
 ALL y. x *_3 y = V(x *'' C1''(y), x *'' C2''(y), x *'' C3''(y))"

scalar_product [rule_format] :
"ALL x.
 ALL y.
 x *_4 y =
 ((C1''(x) *'' C1''(y)) +'' (C2''(x) *'' C2''(y))) +''
 (C3''(x) *'' C3''(y))"

vector_product [rule_format] :
"ALL x.
 ALL y.
 x #' y =
 V((C2''(x) *'' C3''(y)) -' (C2''(y) *'' C3''(x)),
 (C3''(x) *'' C1''(y)) -' (C3''(y) *'' C1''(x)),
 (C1''(x) *'' C2''(y)) -' (C1''(y) *'' C2''(x)))"

ONB1 [rule_format] : "e1 = V(gn_inj(1'), 0'', 0'')"

ONB2 [rule_format] : "e2 = V(0'', gn_inj(1'), 0'')"

ONB3 [rule_format] : "e3 = V(0'', 0'', gn_inj(1'))"

cross_left_homogenity [rule_format] :
"ALL r. ALL x. ALL y. r *_3 (x #' y) = (r *_3 x) #' y"

cross_product_antisymmetric [rule_format] :
"ALL x. ALL y. x #' y = -'' (y #' x)"

binary_inverse_1_1_1 [rule_format] :
"ALL x. ALL y. x /' y = __*__ x (inv'(y))"

distributive [rule_format] :
"ALL v. ALL v'. ALL w. (v +_3 v') *_4 w = (v *_4 w) +'' (v' *_4 w)"

homogeneous [rule_format] :
"ALL a. ALL v. ALL w. (a *_3 v) *_4 w = a *'' (v *_4 w)"

symmetric [rule_format] : "ALL v. ALL w. v *_4 w = w *_4 v"

pos_definite [rule_format] : "ALL v. ~ v = 0_3 --> v *_4 v >' 0''"

unit [rule_format] : "ALL x. gn_inj(1') *_3 x = x"

mix_assoc [rule_format] :
"ALL r. ALL s. ALL x. (r *'' s) *_3 x = r *_3 (s *_3 x)"

distr_Field [rule_format] :
"ALL r. ALL s. ALL x. (r +'' s) *_3 x = (r *_3 x) +_3 (s *_3 x)"

distr_Space [rule_format] :
"ALL r. ALL x. ALL y. r *_3 (x +_3 y) = (r *_3 x) +_3 (r *_3 y)"

ga_assoc___Xx___3_1 [rule_format] :
"ALL x. ALL y. ALL z. (x +_3 y) +_3 z = x +_3 (y +_3 z)"

ga_right_unit___Xx___3_1 [rule_format] : "ALL x. x +_3 0_3 = x"

ga_left_unit___Xx___3_1 [rule_format] : "ALL x. 0_3 +_3 x = x"

inv_Group_2_1 [rule_format] : "ALL x. -'' x +_3 x = 0_3"

rinv_Group_2_1 [rule_format] : "ALL x. x +_3 -'' x = 0_3"

ga_comm___Xx___3 [rule_format] : "ALL x. ALL y. x +_3 y = y +_3 x"

zero_by_left_zero [rule_format] : "ALL x. 0'' *_3 x = 0_3"

zero_by_right_zero [rule_format] : "ALL r. r *_3 0_3 = 0_3"

inverse_by_XMinus1 [rule_format] :
"ALL x. -' gn_inj(1') *_3 x = -'' x"

right_distributive [rule_format] :
"ALL v. ALL v'. ALL w. w *_4 (v +_3 v') = (w *_4 v) +'' (w *_4 v')"

right_homogeneous [rule_format] :
"ALL a. ALL v. ALL w. v *_4 (a *_3 w) = a *'' (v *_4 w)"

non_degenerate [rule_format] : "ALL v. v *_4 v = 0'' --> v = 0_3"

lindep_def [rule_format] :
"ALL x. ALL y. lindep(x, y) = (y = 0_3 | (EX r. x = r *_3 y))"

lindep_reflexivity [rule_format] : "ALL x. lindep(x, x)"

lindep_symmetry [rule_format] :
"ALL x. ALL y. lindep(x, y) --> lindep(y, x)"

simple_lindep_condition [rule_format] :
"ALL r. ALL x. ALL y. x = r *_3 y --> lindep(x, y)"

lindep_nonlindep_transitivity [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 (~ x = 0_3 & lindep(x, y)) & ~ lindep(y, z) --> ~ lindep(x, z)"

norm_from_inner_prod_def [rule_format] :
"ALL x.
 makePartial ( || x || ) =
 restrictOp (gn_proj(sqrt(makeTotal (gn_proj(x *_4 x)))))
 (defOp (gn_proj(x *_4 x)))"

proj_def [rule_format] :
"ALL v.
 ALL w.
 makePartial (proj(v, w)) =
 (if w = 0_3 then makePartial 0_3
     else restrictOp
          (makePartial (((v *_4 w) /' makeTotal (gn_proj(w *_4 w))) *_3 w))
          (defOp (gn_proj(w *_4 w))))"

orthcomp_def [rule_format] :
"ALL v. ALL w. orthcomp(v, w) = v -'' proj(v, w)"

orthogonal_def [rule_format] :
"ALL x. ALL y. orth(x, y) = (x *_4 y = 0'')"

orth_symmetric [rule_format] :
"ALL x. ALL y. orth(x, y) --> orth(y, x)"

lindep_orth_transitive [rule_format] :
"ALL x. ALL y. ALL z. lindep(x, y) & orth(y, z) --> orth(x, z)"

orthogonal_existence_theorem [rule_format] :
"ALL x.
 (EX a. EX b. ~ lindep(a, b)) --> (EX c. ~ c = 0_3 & orth(c, x))"

orthogonal_on_zero_projection [rule_format] :
"ALL x. ALL y. proj(x, y) = 0_3 --> orth(x, y)"

orthogonal_projection_theorem [rule_format] :
"ALL x. ALL y. orth(orthcomp(x, y), y)"

orthogonal_decomposition_theorem [rule_format] :
"ALL x. ALL y. proj(x, y) +_3 orthcomp(x, y) = x"

unique_orthogonal_decomposition [rule_format] :
"ALL v.
 ALL w.
 ALL x.
 ALL y.
 ALL z.
 ((((~ z = 0_3 & x +_3 y = v +_3 w) & lindep(x, z)) &
   lindep(v, z)) &
  orth(z, y)) &
 orth(z, w) -->
 x = v & y = w"

cross_product_orthogonal [rule_format] :
"ALL x. ALL y. orth(x, x #' y)"

cross_product_zero_iff_lindep [rule_format] :
"ALL x. ALL y. lindep(x, y) = (x #' y = 0_3)"

e1e2_nonlindep [rule_format] : "~ lindep(e1, e2)"

point_vector_map [rule_format] :
"ALL p.
 ALL v.
 p +' v =
 P(C1'(p) +'' C1''(v), C2'(p) +'' C2''(v), C3'(p) +'' C3''(v))"

declare refl [simp]
declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare inv_Group [simp]
declare rinv_Group [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx___1 [simp]
declare ga_right_unit___Xx___1 [simp]
declare ga_left_unit___Xx___1 [simp]
declare left_zero [simp]
declare right_zero [simp]
declare ga_comm___Xx___1 [simp]
declare ga_assoc___Xx___2 [simp]
declare ga_right_unit___Xx___2 [simp]
declare ga_left_unit___Xx___2 [simp]
declare inv_Group_1 [simp]
declare rinv_Group_1 [simp]
declare refl_1 [simp]
declare FWO_plus_left [simp]
declare FWO_plus_right [simp]
declare ga_comm_inf [simp]
declare ga_comm_sup [simp]
declare ga_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_min [simp]
declare ga_assoc_max [simp]
declare ga_left_comm_min [simp]
declare ga_left_comm_max [simp]
declare min_inf_relation [simp]
declare max_sup_relation [simp]
declare Ax3 [simp]
declare Ax4 [simp]
declare RealNonNeg_subtype [simp]
declare RealPos_subtype [simp]
declare sqrt_def [simp]
declare ga_select_C1 [simp]
declare ga_select_C2 [simp]
declare ga_select_C3 [simp]
declare ga_select_C1_1 [simp]
declare ga_select_C2_1 [simp]
declare ga_select_C3_1 [simp]
declare Ax7 [simp]
declare VectorStar_subtype [simp]
declare unit [simp]
declare ga_assoc___Xx___3_1 [simp]
declare ga_right_unit___Xx___3_1 [simp]
declare ga_left_unit___Xx___3_1 [simp]
declare inv_Group_2_1 [simp]
declare rinv_Group_2_1 [simp]
declare ga_comm___Xx___3 [simp]
declare zero_by_left_zero [simp]
declare zero_by_right_zero [simp]
declare inverse_by_XMinus1 [simp]
declare lindep_reflexivity [simp]
declare lindep_symmetry [simp]
declare orth_symmetric [simp]
declare orthogonal_on_zero_projection [simp]
declare orthogonal_projection_theorem [simp]
declare orthogonal_decomposition_theorem [simp]
declare cross_product_orthogonal [simp]
declare e1e2_nonlindep [simp]

theorem plus_injective :
"ALL p. ALL v. ALL w. p +' v = p +' w --> v = w"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Point
      Zero_Vector VectorStar_pred_def scalar_multiplication
      scalar_product vector_product ONB1 ONB2 ONB3 lindep_def
      norm_from_inner_prod_def proj_def orthcomp_def orthogonal_def
      point_vector_map
by (auto)

ML "Header.record \"plus_injective\""

theorem plus_surjective : "ALL p. ALL q. EX y. p +' y = q"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Point
      Zero_Vector VectorStar_pred_def scalar_multiplication
      scalar_product vector_product ONB1 ONB2 ONB3 lindep_def
      norm_from_inner_prod_def proj_def orthcomp_def orthogonal_def
      point_vector_map
by (auto)

ML "Header.record \"plus_surjective\""

theorem point_vector_plus_associative :
"ALL p. ALL v. ALL w. p +' (v +_3 w) = (p +' v) +' w"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Point
      Zero_Vector VectorStar_pred_def scalar_multiplication
      scalar_product vector_product ONB1 ONB2 ONB3 lindep_def
      norm_from_inner_prod_def proj_def orthcomp_def orthogonal_def
      point_vector_map
by (auto)

ML "Header.record \"point_vector_plus_associative\""

end


           (*-------------------------------------------*
            |  The Dining Mathematicians in CSP-Prover  |
            |               August 2004                 |
            |             December 2004 (modified)      |
            |             November 2005 (modified)      |
            |                March 2007  (modified)     |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory DM4_Spc_def
imports DM3_hide
begin

(*****************************************************************

         1. defines Spc
         2.
         3.
         4.

 *****************************************************************)

(*********************************************************
                     specification
 *********************************************************)

datatype SpcName = TH0_TH1 | EAT0_TH1 | TH0_EAT1

primrec
  Spcfun :: "SpcName => (SpcName, Event) proc"
where
   "Spcfun
      (TH0_TH1)  = ! x:OBS -> IF (x = Eat0) THEN ($EAT0_TH1)
                                 ELSE IF (x = Eat1) THEN ($TH0_EAT1)
                                                    ELSE ($TH0_TH1)"

  |"Spcfun
      (EAT0_TH1) = ! x:(OBS - {Eat1}) -> IF (x = End0)
                                            THEN ($TH0_TH1)
                                            ELSE ($EAT0_TH1)"

  |"Spcfun
      (TH0_EAT1) = ! x:(OBS - {Eat0}) -> IF (x = End1)
                                            THEN ($TH0_TH1)
                                            ELSE ($TH0_EAT1)"
(*
defs (overloaded)
Set_Spcfun_def [simp]: "PNfun == Spcfun"
*)
overloading Set_Spcfun ==
  "PNfun :: (SpcName, Event) pnfun"
begin
  definition "PNfun == Spcfun"
end

declare Set_Spcfun_def [simp]

definition
  Spc :: "(SpcName,Event) proc"
  where
  Spc_def: "Spc == $TH0_TH1"

(*********************************************************
        Lemmas for   ALL n.  verify Spc <=sf Imp n
 *********************************************************)

(*** relation between Spcfun and ImpDef ***)

primrec
  Spc_to_Imp :: "SpcName => (ImpName,Event) proc"
where
  "Spc_to_Imp
     TH0_TH1 =
       !<NUM> n .. (($TH0) |[CH0]| ($(VAR n))
                                 |[CH1]| ($TH1)) -- (CH0 Un CH1)
       |~|
       !<NUM> n .. (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                          |[CH1]| ($TH1)) -- (CH0 Un CH1)
       |~|
       !<NUM> n .. (($TH0) |[CH0]| ($(VAR n))
                                 |[CH1]| Back1 -> ($TH1)) -- (CH0 Un CH1)
       |~|
       !<NUM> n .. (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                          |[CH1]| Back1 -> ($TH1))
                  -- (CH0 Un CH1)
       |~|
       !<NUM> n:EVENs .. (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n))
                                           |[CH1]| Back1 -> ($TH1))
                        -- (CH0 Un CH1)
       |~|
       !<NUM> n:ODDs  .. (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| Eat1 -> ($(EAT1 n)))
                        -- (CH0 Un CH1)
       |~|
       !<NUM> n:EVENs .. (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n))
                                           |[CH1]| ($TH1))
                        -- (CH0 Un CH1)
       |~|
       !<NUM> n:ODDs  .. (($TH0) |[CH0]| ($(VAR n))
                                       |[CH1]| Eat1 -> ($(EAT1 n)))
                        -- (CH0 Un CH1)
       |~|
       !<NUM> n:EVENs .. (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                        |[CH1]| ($TH1))
                       -- (CH0 Un CH1)
       |~|
       !<NUM> n:EVENs .. (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                        |[CH1]| Back1 -> ($TH1))
                       -- (CH0 Un CH1)
       |~|
       !<NUM> n:ODDs  .. (($TH0) |[CH0]| ($(VAR n))
                                       |[CH1]| WR1 ! (3 * n + 1) -> ($TH1))
                       -- (CH0 Un CH1)
       |~|
       !<NUM> n:ODDs  .. (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| WR1 ! (3 * n + 1) -> ($TH1))
                       -- (CH0 Un CH1)"

 |"Spc_to_Imp
     EAT0_TH1 =
       !<NUM> n:EVENs .. (($(EAT0 n)) |[CH0]| ($(VAR n))
                                            |[CH1]| ($TH1))
                       -- (CH0 Un CH1)
       |~|
       !<NUM> n:EVENs .. (($(EAT0 n)) |[CH0]| ($(VAR n))
                                            |[CH1]| Back1 -> ($TH1))
                       -- (CH0 Un CH1)"

 |"Spc_to_Imp
     TH0_EAT1 =
       !<NUM> n:ODDs .. (($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
                       -- (CH0 Un CH1)
       |~|
       !<NUM> n:ODDs .. (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                               |[CH1]| ($(EAT1 n)))
                       -- (CH0 Un CH1)"

(*********************************************************
                gProc lemmas (routine work)
 *********************************************************)

lemma guarded_Spc[simp]:
      "guardedfun Spcfun"
by (simp add: guardedfun_def, rule allI, induct_tac p, simp_all)+

end


section "Big Proofs"

theory Big_Proof
imports Big Common_Proof
begin

lemma step_list [simp]: "invar big \<Longrightarrow> list (step big) = list big"
proof(induction big rule: step_state.induct)
  case 1
  then show ?case
    by auto
next
  case 2
  then show ?case
    by(auto split: current.splits)
next
  case 3
  then show ?case
    by(auto simp: rev_take take_drop drop_Suc tl_take rev_drop split: current.splits)
qed

lemma step_list_current [simp]: "invar big \<Longrightarrow> list_current (step big) = list_current big"
  by(induction big rule: step_state.induct)(auto split: current.splits)

lemma push_list [simp]: "list (push x big) = x # list big"
proof(induction x big rule: push.induct)
  case (1 x state)
  then show ?case
    by auto
next
  case (2 x current big aux count)
  then show ?case
    by(induction x current rule: Current.push.induct) auto
qed

lemma list_Reverse: "\<lbrakk>
    0 < size (Reverse current big aux count);
    invar (Reverse current big aux count)
\<rbrakk> \<Longrightarrow> first current # list (Reverse (drop_first current) big aux count) =
      list (Reverse current big aux count)"
proof(induction current rule: Current.pop.induct)
  case (1 added old remained)
  then have [simp]: "remained - Suc 0 < length (reverseN count (Stack.list big) aux)"
    by(auto simp: le_diff_conv)

  (* TODO: *)
  then have "
   \<lbrakk>0 < size old; 0 < remained; added = 0; remained - count \<le> length aux; count \<le> size big;
     Stack.list old =
     rev (take (size old - size big) aux) @ rev (take (size old) (rev (Stack.list big)));
     take remained (rev (take (size old - size big) aux)) @
     take (remained - min (length aux) (size old - size big))
      (rev (take (size old) (rev (Stack.list big)))) =
     rev (take (remained - count) aux) @ rev (take remained (rev (take count (Stack.list big))))\<rbrakk>
    \<Longrightarrow> hd (rev (take (size old - size big) aux) @ rev (take (size old) (rev (Stack.list big)))) =
        (rev (take count (Stack.list big)) @ aux) ! (remained - Suc 0)"
    by (smt (verit) Suc_pred hd_drop_conv_nth hd_rev hd_take last_snoc length_rev length_take min.absorb2 rev_append reverseN_def size_list_length take_append take_hd_drop)

  with 1 have [simp]: "Stack.first old = reverseN count (Stack.list big) aux ! (remained - Suc 0)"
    by(auto simp: take_hd_drop first_hd)

  from 1 show ?case
    using reverseN_nth[of
          "remained - Suc 0" "reverseN count (Stack.list big) aux" "Stack.first old" "[]"
        ]
    by auto
next
  case 2
  then show ?case by auto
qed

lemma size_list [simp]: " \<lbrakk>0 < size big; invar big; list big = []\<rbrakk> \<Longrightarrow> False"
proof(induction big rule: list.induct)
  case 1
  then show ?case
    using list_size by auto
next
  case 2
  then show ?case
    by (metis list.distinct(1) list_Reverse)
qed

lemma pop_list [simp]: "\<lbrakk>0 < size big; invar big; Big.pop big = (x, big')\<rbrakk>
   \<Longrightarrow> x # list big' = list big"
proof(induction big arbitrary: x rule: list.induct)
  case 1
  then show ?case
    by(auto split: prod.splits)
next
  case 2
  then show ?case
    by (metis Big.pop.simps(2) list_Reverse prod.inject)
qed

lemma pop_list_tl: "\<lbrakk>0 < size big; invar big; Big.pop big = (x, big')\<rbrakk>
   \<Longrightarrow> Big.list big' = tl (Big.list big)"
  using pop_list cons_tl[of x "list big'" "list big"]
  by force

(* TODO: *)

  then obtain extra old remained where current:
      "current = Current extra (length extra) old remained"
    by(auto split: current.splits)

  (* TODO: *)
  with 2 have "\<lbrakk>current = Current extra (length extra) old remained; remained \<le> length aux;
     Stack.list old =
     rev (take (size old - size big) aux) @ rev (take (size old) (rev (Stack.list big)));
     take remained (rev (take (size old - size big) aux)) @
     take (remained - min (length aux) (size old - size big))
      (rev (take (size old) (rev (Stack.list big)))) =
     rev (take remained aux)\<rbrakk>
    \<Longrightarrow> remained \<le> size old"
    by(metis length_rev length_take min.absorb_iff2 size_list_length take_append)

  with 2 current have "remained - size old = 0"
    by auto

  with current 2 show ?case
    by(auto simp: reverseN_drop drop_rev)
next
  case (3 current big aux count)
  then have "0 < size big"
    by(auto split: current.splits)

  then have big_not_empty:  "Stack.list big \<noteq> []"
    by(auto simp: Stack_Proof.size_not_empty  Stack_Proof.list_not_empty)

  with 3 have a: "
      rev (Stack.list big) @ aux =
      rev (Stack.list (Stack.pop big)) @ Stack.first big # aux"
    by(auto simp: rev_tl_hd first_hd split: current.splits)

  from 3 have "0 < size big"
    by(auto split: current.splits)

  from 3 big_not_empty have "
      reverseN (Suc count) (Stack.list big) aux =
      reverseN count (Stack.list (Stack.pop big)) (Stack.first big # aux)"
    using reverseN_tl_hd[of "Suc count" "Stack.list big" aux]
    by(auto simp: Stack_Proof.list_not_empty split: current.splits)

  with 3 a show ?case
    by(auto split: current.splits)
qed

lemma invar_push: "invar big \<Longrightarrow> invar (push x big)"
  by(induction x big rule: push.induct)(auto simp: invar_push split: current.splits)

(* TODO: *)
lemma invar_pop: "\<lbrakk>
  0 < size big;
  invar big;
  pop big = (x, big')
\<rbrakk> \<Longrightarrow> invar big'"
proof(induction big arbitrary: x rule: pop.induct)
  case (1 state)
  then show ?case
    by(auto simp: invar_pop split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    have linarith: "\<And>x y z. x - y \<le> z \<Longrightarrow> x - (Suc y) \<le> z"
      by linarith

    have a: " \<lbrakk>remained \<le> count + length aux; 0 < remained; added = 0; x = Stack.first old;
         big' = Reverse (Current [] 0 (Stack.pop old) (remained - Suc 0)) big aux count;
         count \<le> size big; Stack.list old = rev aux @ Stack.list big;
         take remained (rev aux) @ take (remained - length aux) (Stack.list big) =
         drop (count + length aux - remained) (rev aux) @
         drop (count - remained) (take count (Stack.list big));
         \<not> size old \<le> length aux + size big\<rbrakk>
        \<Longrightarrow> tl (rev aux @ Stack.list big) = rev aux @ Stack.list big"
      by (metis le_refl length_append length_rev size_list_length)

    have b: "\<lbrakk>remained \<le> length (reverseN count (Stack.list big) aux); 0 < size old;
          0 < remained; added = 0;
         x = Stack.first old;
         big' = Reverse (Current [] 0 (Stack.pop old) (remained - Suc 0)) big aux count;
         remained - count \<le> length aux; count \<le> size big;
         Stack.list old =
         drop (length aux - (size old - size big)) (rev aux) @
         drop (size big - size old) (Stack.list big);
         take remained (drop (length aux - (size old - size big)) (rev aux)) @
         take (remained + (length aux - (size old - size big)) - length aux)
          (drop (size big - size old) (Stack.list big)) =
         drop (length (reverseN count (Stack.list big) aux) - remained)
          (rev (reverseN count (Stack.list big) aux))\<rbrakk>
        \<Longrightarrow> tl (drop (length aux - (size old - size big)) (rev aux) @
                drop (size big - size old) (Stack.list big)) =
            drop (length aux - (size old - Suc (size big))) (rev aux) @
            drop (Suc (size big) - size old) (Stack.list big)"
      apply(cases "size old - size big \<le> length aux"; cases "size old \<le> size big")
      by(auto simp: tl_drop_2 Suc_diff_le le_diff_conv le_refl a)

    from 1 have "remained \<le> length (reverseN count (Stack.list big) aux)"
      by(auto)

    with 1 show ?case
      apply(auto simp: rev_take take_tl drop_Suc Suc_diff_le tl_drop linarith simp del: reverseN_def)
      using b by simp
  next
    case (2 x xs added old remained)
    then show ?case by auto
  qed
qed

lemma push_list_current [simp]: "list_current (push x big) = x # list_current big"
  by(induction x big rule: push.induct) auto

lemma pop_list_current [simp]: "\<lbrakk>invar big; 0 < size big; Big.pop big = (x, big')\<rbrakk>
   \<Longrightarrow> x # Big.list_current big' = Big.list_current big"
proof(induction big arbitrary: x rule: pop.induct)
  case (1 state)
  then show ?case
    by(auto simp: pop_list_current split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)

    then have
        "rev (take (size old - size big) aux) @ rev (take (size old) (rev (Stack.list big))) \<noteq> []"
      using
        order_less_le_trans[of 0 "size old" "size big"]
        order_less_le_trans[of 0 count "size big"]
      by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_not_empty)

    with 1 show ?case
      by(auto simp: first_hd)
  next
    case (2 x xs added old remained)
    then show ?case
      by auto
  qed
qed

lemma list_current_size: "\<lbrakk>0 < size big; list_current big = []; invar big\<rbrakk> \<Longrightarrow> False"
proof(induction big rule: list_current.induct)
  case 1
  then show ?case
    using list_current_size
    by simp
next
  case (2 current uu uv uw)
  then show ?case
    apply(cases current)
    by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_empty)
qed

lemma step_size: "invar (big :: 'a state) \<Longrightarrow> size big = size (step big)"
  by(induction big rule: step_state.induct)(auto split: current.splits)

lemma size_empty: "\<lbrakk>invar (big :: 'a state); size big = 0\<rbrakk> \<Longrightarrow> is_empty big"
proof(induction big)
  case Reverse
  then show ?case
    by(auto simp: min_def Stack_Proof.list_empty split: if_splits current.splits)
next
  case Common
  then show ?case
    by(auto simp: size_empty)
qed

lemma remaining_steps_step [simp]: "\<lbrakk>invar (big :: 'a state); remaining_steps big > 0\<rbrakk>
   \<Longrightarrow> Suc (remaining_steps (step big)) = remaining_steps big"
  by(induction big rule: step_state.induct)(auto split: current.splits)

lemma remaining_steps_step_0 [simp]: "\<lbrakk>invar (big :: 'a state); remaining_steps big = 0\<rbrakk>
    \<Longrightarrow> remaining_steps (step big) = 0"
  by(induction big)(auto split: current.splits)

lemma remaining_steps_push: "invar big \<Longrightarrow> remaining_steps (push x big) = remaining_steps big"
  by(induction x big rule: push.induct)(auto split: current.splits)

lemma remaining_steps_pop: "\<lbrakk>invar big; 0 < size big; pop big = (x, big')\<rbrakk>
   \<Longrightarrow> remaining_steps big' \<le> remaining_steps big"
proof(induction big rule: pop.induct)
  case (1 state)
  then show ?case
    by(auto simp: remaining_steps_pop split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_push [simp]: "invar big \<Longrightarrow> size (push x big) = Suc (size big)"
  by(induction x big rule: push.induct)(auto split: current.splits)

lemma size_new_push [simp]: "invar big \<Longrightarrow> size_new (push x big) = Suc (size_new big)"
  by(induction x big rule: Big.push.induct)(auto split: current.splits)

lemma size_pop [simp]: "\<lbrakk>invar big; 0 < size big; pop big = (x, big')\<rbrakk>
   \<Longrightarrow> Suc (size big') = size big"
proof(induction big rule: pop.induct)
  case 1
  then show ?case
    by(auto split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_new_pop [simp]: "\<lbrakk>invar big; 0 < size_new big; pop big = (x, big')\<rbrakk>
    \<Longrightarrow> Suc (size_new big') = size_new big"
proof(induction big rule: pop.induct)
  case 1
  then show ?case
    by(auto split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_size_new: "\<lbrakk>invar (big :: 'a state); 0 < size big\<rbrakk> \<Longrightarrow> 0 < size_new big"
  by(induction big)(auto simp: size_size_new)

end


theory NarrowPhase
  imports
    Common
begin

nitpick_params [sat_solver = smart, max_threads = 1, verbose=true]

(*
lemma eval_not_undef:
  "([m,p] \<turnstile> e \<mapsto> v) \<longrightarrow> v \<noteq> UndefVal"
  by (induction e; auto)
*)

section \<open>Optimizations for Narrow/Widen Nodes\<close>

text \<open>Our first goal in this section is to explore the known (fixed) bug
  in narrowing / widening within equality comparisons, in Issue 2011.\<close>

context
  includes bit_operations_syntax
begin

text \<open>Some of the CodeUtil methods from the GraalVM compiler"\<close>

(*
//    public static long signExtend(long value, int inputBits) {
//        if (inputBits < 64) {
//            return (value >>> inputBits - 1 & 1L) == 1L
//                   ? value | -1L << inputBits
//                   : value & ~(-1L << inputBits);
//        } else {
//            return value;
//        }
//    }
*)
definition CodeUtil_signExtend :: "int64 \<Rightarrow> nat \<Rightarrow> int64" where
  "CodeUtil_signExtend value inputBits =
    (if inputBits < 64
     then (if ((value >>> (inputBits - 1)) AND 1) = 1
          then value OR ((-1) << inputBits)
          else value AND NOT((-1) << inputBits))
     else value)"

(* TODO? prove that this is equal to:
       (value << (64 - inputBits)) >>> (64 - inputBits)
*)

(* temporary version for 32-bit in and out. *)
definition CodeUtil_signExtend32 :: "int32 \<Rightarrow> nat \<Rightarrow> int32" where
  "CodeUtil_signExtend32 value inputBits =
    (if inputBits < 64
     then (if ((value >>> (inputBits - 1)) AND 1) = 1
          then value OR ((-1) << inputBits)
          else value AND NOT((-1) << inputBits))
     else value)"

(*
//     public static long zeroExtend(long value, int inputBits) {
//         return inputBits < 64 ? value & ~(-1L << inputBits) : value;
//     }
*)
definition CodeUtil_zeroExtend :: "int64 \<Rightarrow> nat \<Rightarrow> int64" where
  "CodeUtil_zeroExtend value inputBits =
    (if inputBits < 64
     then value AND NOT((-1) << inputBits)
     else value)"

(* temporary version for 32-bit in and out. *)
definition CodeUtil_zeroExtend32 :: "int32 \<Rightarrow> nat \<Rightarrow> int32" where
  "CodeUtil_zeroExtend32 value inputBits =
    (if inputBits < 64
     then value AND NOT((-1) << inputBits)
     else value)"

(*
//     public static long narrow(long value, int resultBits) {
//         long ret = value & mask(resultBits);
//         return signExtend(ret, resultBits);
//     }
*)
definition CodeUtil_narrow :: "int64 \<Rightarrow> nat \<Rightarrow> int64" where
  "CodeUtil_narrow value resultBits =
    signed_take_bit (resultBits - 1) (value AND mask resultBits)"

definition CodeUtil_narrow32 :: "int32 \<Rightarrow> nat \<Rightarrow> int32" where
  "CodeUtil_narrow32 value resultBits =
    signed_take_bit (resultBits - 1) (value AND mask resultBits)"

end

lemma dummy: "(0 :: int32) + 1 = 1"
  by simp

subsection \<open>Example tests of the CodeUtil narrow and widen operators\<close>

experiment begin
corollary "sint(CodeUtil_signExtend 0x00FF 64) = 255" by code_simp
corollary "sint(CodeUtil_signExtend 0x007F 8)  = 127" by code_simp
corollary "sint(CodeUtil_signExtend 0x00FF 8)  = -1" by code_simp
corollary "sint(CodeUtil_signExtend 0x0000 1)  = 0" by code_simp
corollary "sint(CodeUtil_signExtend 0x0001 1)  = -1" by code_simp

corollary "sint(CodeUtil_zeroExtend 0x00FF 64) = 255" by code_simp
corollary "sint(CodeUtil_zeroExtend 0x007F 8)  = 127" by code_simp
corollary "sint(CodeUtil_zeroExtend 0x00FF 8)  = 255" by code_simp
corollary "sint(CodeUtil_zeroExtend 0x0000 1)  = 0" by code_simp
corollary "sint(CodeUtil_zeroExtend 0x0001 1)  = 1" by code_simp

corollary "sint(CodeUtil_narrow 0xFFFF 8) = -1" by code_simp
corollary "sint(CodeUtil_narrow 0xFF7F 8) = 127" by code_simp
corollary "sint(CodeUtil_narrow 0x00FF 8) = -1" by code_simp
corollary "sint(CodeUtil_narrow 0x0000 1) = 0" by code_simp
corollary "sint(CodeUtil_narrow 0x0001 1) = -1" by code_simp
end

(* nitpick demo: gives kodkod warning:
    Kodkod warning: cannot launch SAT solver, falling back on "DefaultSAT4J"

lemma "P \<longleftrightarrow> Q"
  nitpick
*)

phase Issue2011Phase
  terminating size
begin

fun isDefaultForKind :: "Value \<Rightarrow> bool" where
  "isDefaultForKind (IntVal b val) = (val = 0)" |
  "isDefaultForKind _ = False"

value "not(-1 << 8 :: int32)"
value "mask 7 :: int32"

lemma shift_n_eq_bit_n:
  fixes val :: \<open>'a::len word\<close>
  shows "(and (val >>> n) 1 = 1) = bit val n"
  by (simp add: bit_iff_and_drop_bit_eq_1 shiftr_def)

declare [[show_types=true]]
lemma neg1_shift_eq_mask:
  fixes val :: \<open>'a::len word\<close>
  fixes n :: nat
  assumes "n < LENGTH('a)"
  assumes "0 < n"
  shows "((- 1 << n) :: 'a::len word) = not (mask n)" (is "?A = ?B")
  by (simp add: shiftl_def)

lemma take_bit_suc:
  fixes v :: int32
  assumes "\<not> bit v (n::nat)"
  shows "take_bit (Suc n::nat) v = take_bit (n::nat) v"
  by (smt (verit, best) assms bit_take_bit_iff le_eq_less_or_eq less_Suc_eq_le linorder_not_less
         signed_take_bit_eq_if_positive signed_take_bit_take_bit take_bit_signed_take_bit)

lemma narrow_reverse_pos:
  assumes 1: "and (val32 >>> 7) 1 \<noteq> 1"
  assumes pos: "\<not> bit val32 7"
  assumes 4: "revKonst = and konst (not (- 1 << 8))"
  assumes 5: "intval_narrow 32 8 (IntVal32 revKonst) = IntVal32 konst"
  shows "IntVal32 konst = intval_narrow 32 8 (IntVal32 val32)
        \<longleftrightarrow>
         revKonst = val32"
  unfolding assms intval_narrow.simps narrow_helper.simps
  apply (simp add: neg1_shift_eq_mask signed_take_bit_eq_if_positive[OF pos])
proof (intro iffI)
  assume a: "konst = take_bit 7 val32"
(*  then have "konst = take_bit 8 val32"
    thm take_bit_Suc_from_most
  using assms take_bit_Suc_from_most
*)
  then have 8: "and konst (mask 8) = konst"
    using mask_eq_iff_w2p
    by (smt (verit, ccfv_SIG) and_mask_lt_2p mask_eq_iff numeral_Bit0 numeral_less_iff one_eq_numeral_iff power_strict_increasing semiring_norm(81) take_bit_eq_mask)
  then have "(signed_take_bit 7 revKonst) = konst"
    using 5 by simp
  then have 9: "(take_bit 7 revKonst) = konst"
    by (simp add: 4 a bit_and_iff bit_take_bit_iff signed_take_bit_eq_if_positive)
(*
  then have "and revKonst (mask 8) = revKonst"
    by (simp add: "4" shiftl_def)
  then have 10: "and val32 (mask 8) = val32"
    using 8 9 a by fastforce
*)
  show "and konst (mask 8) = val32"

    using 9 10 a by fastforce
  next
    assume b: "and konst (mask 8) = val32"
    then have "take_bit 8 val32 = val32"
      by (metis and.right_idem take_bit_eq_mask)
    then have "take_bit 7 val32 = val32"
      using take_bit_suc pos by force
    then have 8: "and konst (mask 8) = konst"
      using assms
      print_facts
    then show "konst = take_bit 7 val32"
      using b
    qed

(* this is where the Issue2011 bug should appear. *)
lemma narrow_reverse_neg:
  assumes "and (val32 >>> 7) 1 = 1"
  assumes neg: "bit val32 7"  (* 8-bit val32 is negative *)
  assumes "val32 = 0xC0"     (* example value from bug report *)
  shows "IntVal32 i32 = intval_narrow 32 8 (IntVal32 val32)
        \<longleftrightarrow>
         IntVal32 (or i32 (- 1 << 8)) = (IntVal32 val32)"
  unfolding assms intval_narrow.simps narrow_helper.simps
  apply (simp add: neg1_shift_eq_mask signed_take_bit_eq_if_negative[OF neg])
proof (intro iffI)
  assume "i32 = - (64::32 word)"
  then show "or i32 (not (mask (8::nat))) = (192::32 word)"
    apply (code_simp; simp)
    (* now we have:
           i32 = - (64::32 word) \<Longrightarrow> False
       i.e. a contradiction.  This is not provable.
    *)
    oops

(*
  nitpick
  unfolding shift_n_eq_bit_n apply simp
  oops
*)

lemma unfold_ex_let: "(\<exists>x. x=E \<and> P) = (let x=E in P)"
  by force

lemma unfold_ex2_let: "(\<exists>x y. x=E \<and> P x y) = (let x=E in (\<exists>y. P x y))"
  by force

lemma unfold_ex2_ex_let: "(\<exists>y. (\<exists>x. (R x y \<and> y=E x \<and> Q x y)) \<and> P y) = (\<exists>x'. (let y=E x' in (R x' y \<and> Q x' y \<and> P y)))"
  by metis

lemma unfold_ex_bubble_out: "(P \<and> (\<exists>x. Q x) \<and> R) = (\<exists>x. (Q x \<and> P \<and> R))"
  by auto

(* TODO: make this more general, but still usable in unfolding? *)
lemma unfold_intval_eq32:
  "((intval_equals (IntVal32 v1) v2 = intval_equals (IntVal32 v3) v4) \<and>
   (intval_equals (IntVal32 v1) v2 \<noteq> UndefVal))
   = ((v1 = un_IntVal32 v2) = (v3 = un_IntVal32 v4) \<and>
      is_IntVal32 v2 \<and> is_IntVal32 v4)" (is "?A = (?B = ?C \<and> ?I2 \<and> ?I4)")
  proof (intro iffI)
    assume ?A
    show "?B = ?C \<and> ?I2 \<and> ?I4"
      by (smt (verit, best) Value.sel(1) \<open>intval_equals (IntVal32 (v1::32 word)) (v2::Value) = intval_equals (IntVal32 (v3::32 word)) (v4::Value) \<and> intval_equals (IntVal32 v1) v2 \<noteq> UndefVal\<close> bool_to_val.elims intval_eq32 intval_eq32_simp zero_neq_one)
  next
    assume "?B = ?C \<and> ?I2 \<and> ?I4"
    show ?A
      by (smt (verit, best) Value.collapse(1) Value.disc(1) Value.discI(1) \<open>((v1::32 word) = un_IntVal32 (v2::Value)) = ((v3::32 word) = un_IntVal32 (v4::Value)) \<and> is_IntVal32 v2 \<and> is_IntVal32 v4\<close> bool_to_val.simps(1) bool_to_val.simps(2) intval_equals.simps(1))
  qed

(* use context assumptions about definedness to deduce int size *)
lemma eq_must_be_int32:
  assumes "intval_equals (IntVal32 a) b \<noteq> UndefVal"
  shows "(intval_equals (IntVal32 a) b = intval_equals (IntVal32 c) d)
         = ((a = un_IntVal32 b) \<longleftrightarrow> (c = un_IntVal32 d))"
proof (rule iffI)
  assume 1: "(intval_equals (IntVal32 a) b = intval_equals (IntVal32 c) d)"
  obtain bv where "b = IntVal32 bv"
    using assms intval_eq32 is_IntVal32_def by blast
  then show "(a = un_IntVal32 b) \<longleftrightarrow> (c = un_IntVal32 d)"
    using 1 assms intval_eq32 is_IntVal32_def by fastforce
next
  assume 2: "(a = un_IntVal32 b) \<longleftrightarrow> (c = un_IntVal32 d)"
  then have 3: "bool_to_val (a = un_IntVal32 b) = bool_to_val (c = un_IntVal32 d)"
    by simp
  obtain bv where "b = IntVal32 bv"
    using assms intval_eq32 is_IntVal32_def by blast
  then have "intval_equals (IntVal32 c) d \<noteq> UndefVal"
    using assms sorry
  then have "intval_equals (IntVal32 a) b = intval_equals (IntVal32 c) d"
    using 3 assms sorry

  then show "(intval_equals (IntVal32 a) b = intval_equals (IntVal32 c) d)"
    using 2
    oops

(* we first investigate the case of narrowing from 32 to 8 bits.
Input: Constant constant == ValueNode nonConstant
       ConvertNode convert = (ConvertNode) nonConstant;  // actually a NarrowNode
  TODO: add some of these side conditions:
  if isConstantConversionSupported(convert, view, smallestCompareWidth)
  ConstantNode newConstant = canonicalConvertConstant(constantReflection, metaAccess,
                                      condition, convert, constant, view);
  i.e. {
     if (convert.preservesOrder(condition, constant, constantReflection)) {
        Constant reverseConverted = convert.reverse(constant, constantReflection);
              i.e. = table.getSignExtend().foldConstant(getResultBits(), getInputBits(), constant)
        if (reverseConverted != null &&
            convert.convert(reverseConverted, constantReflection).equals(constant))
                     i.e.  = narrow(reverseConverted) = constant
      return ConstantNode.forConstant(convert.getValue().stamp(view), reverseConverted, metaAccess);
     }
  if newConstant != null
  return newConstant == convert.getValue()
*)
optimization Issue2011_Bug:
  "((const (IntVal32 value)) eq
      (UnaryExpr (UnaryNarrow inBits outBits) expr))
   \<longmapsto>
   ((const (IntVal32 (CodeUtil_signExtend32 value outBits)))
      eq expr)
   when (inBits = 32 \<and> outBits = 8)"
  apply (rule impI)
  subgoal premises 1
  unfolding le_expr_def unfold_evaltree bin_eval.simps unary_eval.simps
   apply (rule allI impI)+
  unfolding ex_neg_all_pos unfold_ex_bubble_out
  subgoal premises 2 for m p v x y ev
    apply (rule exI[of _ "IntVal32 (CodeUtil_signExtend32 value outBits)"];
           rule exI[of _ ev])
      unfolding CodeUtil_signExtend32_def
      apply (simp add: 1 2 unfold_intval_eq32)
      (* this gives two conjuncts, which are similar to above lemmas:
1. (and (value >>> (7::nat)) (1::32 word) = (1::32 word) \<longrightarrow>
     (value = un_IntVal32 (intval_narrow (32::nat) (8::nat) ev)) =
     (or value (- (1::32 word) << (8::nat)) = un_IntVal32 ev) \<and>
     is_IntVal32 (intval_narrow (32::nat) (8::nat) ev) \<and> is_IntVal32 ev)
2.  (and (value >>> (7::nat)) (1::32 word) \<noteq> (1::32 word) \<longrightarrow>
     (value = un_IntVal32 (intval_narrow (32::nat) (8::nat) ev)) =
     (and value (not (- (1::32 word) << (8::nat))) = un_IntVal32 ev) \<and>
     is_IntVal32 (intval_narrow (32::nat) (8::nat) ev) \<and> is_IntVal32 ev)
 *)
      print_facts
      oops

optimization Issue2011_Fix:
  "(BinaryExpr BinIntegerEquals
      (ConstantExpr (IntVal32 value))
      (UnaryExpr (UnaryNarrow inBits outBits) expr))
   \<longmapsto>
   (BinaryExpr BinIntegerEquals
      (ConstantExpr (IntVal32 (CodeUtil_zeroExtend32 value outBits)))
      expr)
   when (inBits = 32 \<and> outBits = 8)"
   apply unfold_optimization
  apply (rule impI)
  subgoal premises 1
  unfolding le_expr_def unfold_evaltree bin_eval.simps unary_eval.simps
   apply (rule allI impI)+
  unfolding ex_neg_all_pos unfold_ex_bubble_out
  subgoal premises 2 for m p v x y ev
      apply (rule exI[of _ "IntVal32 (CodeUtil_zeroExtend32 value outBits)"]; rule exI[of _ ev])
      unfolding CodeUtil_zeroExtend32_def
      apply (simp add: 1 2 unfold_intval_eq32)
      apply (rule conjI)
(* this gives two goals (first one is false, e.g. ev=0x100):
 1. (value = un_IntVal32 (intval_narrow (32::nat) (8::nat) ev)) =
    (and value (not (- (1::32 word) << (8::nat))) = un_IntVal32 ev)
 2. is_IntVal32 (intval_narrow (32::nat) (8::nat) ev) \<and> is_IntVal32 ev
*)
      print_facts
      oops

(* other side-conditions in the code:
  NB. 'convert' and narrowNode are the unary narrow expr.

  !(narrowNode.getInputBits() > 32 && !constant.isDefaultForKind())
   smallestCompareWidth != null &&
     intStamp.getBits() >= smallestCompareWidth

  (convert.preservesOrder(condition, constant, constantReflection))
  // then calculate reverseConverted:
  (reverseConverted != null && convert.convert(reverseConverted, constantReflection).equals(constant))

  (ConstantExpr newConstant) is:
    return ConstantNode.forConstant(convert.getValue().stamp(view), reverseConverted, metaAccess);
*)

(*

optimization e:
  "x * (const c) \<longmapsto> x << (const n) when (n = intval_log2 c \<and> in_bounds n 0 32)"
   apply unfold_optimization apply simp using e_intval
  using BinaryExprE ConstantExprE bin_eval.simps(2,7) sorry

  nitpick [unary_ints]
  nitpick [binary_ints, bits=16]
  But these give error:
    Unsupported case: representation function on "Int.int"

+//   && supported   // ie. (convert.stamp as IntegerStamp).getBits() >= smallestCompareWidth
+//   && let value = ((PrimitiveConstant) konstant).asLong()
+//   && let narrow = convert
+//   && let inputBits = narrow.inputBits
# Ian: instead shift left then right
+//   && let reverseConverted = if (convert.inputBits < 64)
+//                             then if (value >>> inputBits - 1 & 1L) == 1L
+//                                  then value | -1L << inputBits
+//                                  else value & ~(-1L << inputBits)
+//                             else value
+//   && reverseConverted != null   // I don't think it can be null?
+//   && narrow.convert(reverseConverted, constantReflection).equals(konstant))
+//   && !GeneratePIC.getValue(options))
+//   && let newConstant = ConstantNode.forConstant(narrow.getValue().stamp(view), reverseConverted, metaAccess)
+//   && newConstant != null
*)

lemma negate_min32:
  fixes y :: int32
  assumes "y = (0x80000000 :: int32)"
  shows "-y = (0x80000000 :: int32)"
  using assms apply code_simp
  by force

lemma sub_min32:
  fixes y :: int32
  assumes "y = (0x80000000 :: int32)"
  shows "x - y = x + y"
  unfolding assms negate_min32
  by simp

end