theory SINVAR_NonInterference
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant NonInterference *}

datatype node_config = Interfering | Unrelated

definition default_node_properties :: "node_config"
  where  "default_node_properties = Interfering"

definition undirected_reachable :: "'v graph \<Rightarrow> 'v => 'v set" where
  "undirected_reachable G v = (succ_tran (undirected G) v) - {v}"

lemma undirected_reachable_mono:
  "E' \<subseteq> E \<Longrightarrow> undirected_reachable \<lparr>nodes = N, edges = E'\<rparr> n \<subseteq> undirected_reachable \<lparr>nodes = N, edges = E\<rparr> n"
unfolding undirected_reachable_def undirected_def succ_tran_def
by (fastforce intro: trancl_mono)

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> n \<in> (nodes G). (nP n) = Interfering \<longrightarrow> (nP ` (undirected_reachable G n)) \<subseteq> {Unrelated})"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where
  "receiver_violation = True"

text{*simplifications for sets we need in the uniqueness proof*}
  lemma tmp1: "{(b, a). a = vertex_1 \<and> b = vertex_2} = {(vertex_2, vertex_1)}" by auto
  lemma tmp6: "{(vertex_1, vertex_2), (vertex_2, vertex_1)}\<^sup>+ =
    {(vertex_1, vertex_1), (vertex_2, vertex_2), (vertex_1, vertex_2), (vertex_2, vertex_1)}"
    apply(rule)
     apply(rule)
     apply(case_tac x, simp)
     apply(erule_tac r="{(vertex_1, vertex_2), (vertex_2, vertex_1)}" in trancl_induct)
      apply(auto)
     apply (metis (mono_tags) insertCI r_r_into_trancl)+
  done
  lemma tmp2: "(insert (vertex_1, vertex_2) {(b, a). a = vertex_1 \<and> b = vertex_2})\<^sup>+ =
    {(vertex_1, vertex_1), (vertex_2, vertex_2), (vertex_1, vertex_2), (vertex_2, vertex_1)}"
    apply(subst tmp1)
    apply(fact tmp6)
    done
  lemma tmp3: "{(b, a). False} = {}" by simp
  lemma tmp4: "{(e1, e2). e1 = vertex_1 \<and> e2 = vertex_2 \<and> (e1 = vertex_1 \<longrightarrow> e2 \<noteq> vertex_2)} = {}" by blast
  lemma tmp5: "{(b, a). a = vertex_1 \<and> b = vertex_2 \<or> a = vertex_1 \<and> b = vertex_2 \<and> (a = vertex_1 \<longrightarrow> b \<noteq> vertex_2)} =
    {(vertex_2, vertex_1)}" by fastforce
  lemma unique_default_example: "undirected_reachable \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_1 = {vertex_2}"
    by(auto simp add: undirected_def undirected_reachable_def succ_tran_def tmp2)
  lemma unique_default_example_hlp1: "delete_edges \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1, vertex_2)} =
    \<lparr>nodes = {vertex_1, vertex_2}, edges = {}\<rparr>"
    by(simp add: delete_edges_def)
  lemma unique_default_example_2:
    "undirected_reachable (delete_edges \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1,vertex_2 )}) vertex_1 = {}"
    apply(simp add: undirected_def undirected_reachable_def succ_tran_def unique_default_example_hlp1)
    apply(subst tmp3)
    by auto
  lemma unique_default_example_3:
    "undirected_reachable (delete_edges \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1,vertex_2 )}) vertex_2 = {}"
    apply(simp add: undirected_def undirected_reachable_def succ_tran_def unique_default_example_hlp1)
    apply(subst tmp3)
    by auto
  lemma unique_default_example_4:
    "(undirected_reachable (add_edge vertex_1 vertex_2 (delete_edges \<lparr>nodes = {vertex_1, vertex_2},
    edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1, vertex_2)})) vertex_1) = {vertex_2}"
    apply(simp add: delete_edges_def add_edge_def undirected_def undirected_reachable_def succ_tran_def)
    apply(subst tmp4)
    apply(subst tmp5)
    apply(simp)
    apply(subst tmp6)
    by force
  lemma unique_default_example_5:
    "(undirected_reachable (add_edge vertex_1 vertex_2 (delete_edges \<lparr>nodes = {vertex_1, vertex_2},
    edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1, vertex_2)})) vertex_2) = {vertex_1}"
    apply(simp add: delete_edges_def add_edge_def undirected_def undirected_reachable_def succ_tran_def)
    apply(subst tmp4)
    apply(subst tmp5)
    apply(simp)
    apply(subst tmp6)
    by force

  (*lemma empty_undirected_reachable_false: "xb \<in> undirected_reachable \<lparr>nodes = nodes G, edges = {(e1, e2). False}\<rparr> na \<longleftrightarrow> False"
    apply(simp add: undirected_reachable_def succ_tran_def undirected_def)
    apply(subst tmp3)
    by fastforce*)

  lemma empty_undirected_reachable_false: "xb \<in> undirected_reachable (delete_edges G (edges G)) na \<longleftrightarrow> False"
    apply(simp add: undirected_reachable_def succ_tran_def undirected_def delete_edges_edges_empty)
    apply(subst tmp3)
    by fastforce

subsubsection{*monotonic and preliminaries*}

interpretation NonInterference: SecurityInvariant_IFS
where default_node_properties = SINVAR_NonInterference.default_node_properties
and sinvar = SINVAR_NonInterference.sinvar
and verify_globals = verify_globals
  unfolding SINVAR_NonInterference.default_node_properties_def
  apply unfold_locales
   apply(rule ballI)
   apply(drule SINVAR_NonInterference.offending_notevalD)
   apply(simp)
   apply clarify
   apply(rename_tac xa)
   apply(case_tac "nP xa")
    (*case Interfering*)
    apply simp
    apply(erule_tac x=n and A="nodes G" in ballE)
     prefer 2
     apply fast
    apply(simp)
    apply(thin_tac "valid_graph G")
    apply(thin_tac "(a,b) \<in> f")
    apply(thin_tac "n \<in> nodes G")
    apply(thin_tac "nP n = Interfering")
    apply(erule disjE)
     apply (metis fun_upd_other fun_upd_same imageI node_config.distinct(1) set_rev_mp singleton_iff)
    apply (metis fun_upd_other fun_upd_same imageI node_config.distinct(1) set_rev_mp singleton_iff)
   (*case Unrelated*)
   apply simp
  (*unique: *)
  apply(erule default_uniqueness_by_counterexample_IFS)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:delete_edges_set_nodes)
  apply (simp split: split_split_asm split_split)
  apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: valid_graph_def)
  apply(rule_tac x="(\<lambda> x. default_node_properties)(vertex_1 := Interfering, vertex_2 := Interfering)" in exI, simp)
  apply(rule conjI)
   apply(simp add: unique_default_example)
  apply(rule_tac x="vertex_2" in exI, simp)
  apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(simp add: unique_default_example)
  apply(simp add: unique_default_example_2)
  apply(simp add: unique_default_example_3)
  apply(simp add: unique_default_example_4)
  apply(simp add: unique_default_example_5)
  apply(case_tac otherbot)
   apply simp
  apply(simp add:graph_ops)
  done

  lemma TopoS_NonInterference: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar verify_globals receiver_violation default_node_properties

--{*Hide all the helper lemmas.*}
hide_fact tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 unique_default_example
          unique_default_example_2 unique_default_example_3 unique_default_example_4
          unique_default_example_5 empty_undirected_reachable_false

end


section \<open> UTP Variables \<close>

theory utp_var
  imports
  "UTP1-Toolkit.utp_toolkit"
  HOL.Deriv
  utp_parser_utils
begin

text \<open> In this first UTP theory we set up variables, which are are built on lenses~\cite{Foster09,Foster16a}.
  A large part of this theory is setting up the parser for UTP variable syntax. \<close>

subsection \<open> Initial syntax setup \<close>

text \<open> We will overload the square order relation with refinement and also the lattice operators so
  we will turn off these notations. \<close>

purge_notation
  Order.le (infixl "\<sqsubseteq>\<index>" 50) and
  Lattice.sup ("\<Squnion>\<index>_" [90] 90) and
  Lattice.inf ("\<Sqinter>\<index>_" [90] 90) and
  Lattice.join (infixl "\<squnion>\<index>" 65) and
  Lattice.meet (infixl "\<sqinter>\<index>" 70) and
  Set.member ("op :") and
  Set.member ("(_/ : _)" [51, 51] 50) and
  disj  (infixr "|" 30) and
  conj  (infixr "&" 35)

declare fst_vwb_lens [simp]
declare snd_vwb_lens [simp]
declare comp_vwb_lens [simp]
declare lens_inv_bij [simp]
declare id_bij_lens [simp]
declare lens_indep_left_ext [simp]
declare lens_indep_right_ext [simp]
declare lens_comp_quotient [simp]
declare plus_lens_distr [THEN sym, simp]
declare lens_comp_assoc [simp]

subsection \<open> Variable foundations \<close>

text \<open> This theory describes the foundational structure of UTP variables, upon which the rest
  of our model rests. We start by defining alphabets, which following~\cite{Feliachi2010,Feliachi2012}
  in this shallow model are simply represented as types @{typ "'\<alpha>"}, though by convention usually a record
  type where each field corresponds to a variable. UTP variables in this frame are simply modelled
  as lenses @{typ "'a \<Longrightarrow> '\<alpha>"}, where the view type @{typ "'a"} is the variable type, and the
  source type @{text "'\<alpha>"} is the alphabet or state-space type.

  We define some lifting functions for variables to create input and output variables.
  These simply lift the alphabet to a tuple type since relations will ultimately be defined
  by a tuple alphabet.
\<close>

definition in_var :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "in_var x = x ;\<^sub>L fst\<^sub>L"

definition out_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "out_var x = x ;\<^sub>L snd\<^sub>L"

text \<open> Variables can also be used to effectively define sets of variables. Here we define the
  the universal alphabet ($\Sigma$) to be the bijective lens @{term "1\<^sub>L"}. This characterises
  the whole of the source type, and thus is effectively the set of all alphabet variables. \<close>

abbreviation (input) univ_alpha :: "('\<alpha> \<Longrightarrow> '\<alpha>)" ("\<Sigma>") where
"univ_alpha \<equiv> 1\<^sub>L"

text \<open> The next construct is vacuous and simply exists to help the parser distinguish predicate
  variables from input and output variables. \<close>

definition pr_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<beta>)" where
[lens_defs]: "pr_var x = x"

subsection \<open> Variable lens properties \<close>

text \<open> We can now easily show that our UTP variable construction are various classes of
  well-behaved lens .\<close>

lemma in_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (in_var x)"
  by (simp add: comp_weak_lens in_var_def)

lemma in_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (in_var x)"
  by (simp add: comp_mwb_lens in_var_def)

lemma pr_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma pr_var_mwb_lens [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma pr_var_vwb_lens [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma in_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (in_var x)"
  by (simp add: in_var_def)

lemma out_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (out_var x)"
  by (simp add: comp_weak_lens out_var_def)

lemma out_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (out_var x)"
  by (simp add: comp_mwb_lens out_var_def)

lemma out_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (out_var x)"
  by (simp add: out_var_def)

text \<open> Moreover, we can show that input and output variables are independent, since they refer
  to different sections of the alphabet. \<close>

lemma out_in_indep [simp]:
  "out_var x \<bowtie> in_var y"
  by (simp add: lens_indep_def in_var_def out_var_def fst_lens_def snd_lens_def lens_comp_def)

lemma in_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> in_var x \<bowtie> in_var y"
  by (simp add: in_var_def out_var_def)

lemma out_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> out_var x \<bowtie> out_var y"
  by (simp add: out_var_def)

lemma pr_var_indeps [simp]:
  "x \<bowtie> y \<Longrightarrow> pr_var x \<bowtie> y"
  "x \<bowtie> y \<Longrightarrow> x \<bowtie> pr_var y"
  by (simp_all add: pr_var_def)

lemma prod_lens_indep_in_var [simp]:
  "a \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> in_var x"
  by (metis in_var_def in_var_indep out_in_indep out_var_def plus_pres_lens_indep prod_as_plus)

lemma prod_lens_indep_out_var [simp]:
  "b \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> out_var x"
  by (metis in_out_indep in_var_def out_var_def out_var_indep plus_pres_lens_indep prod_as_plus)

lemma in_var_pr_var [simp]:
  "in_var (pr_var x) = in_var x"
  by (simp add: pr_var_def)

lemma out_var_pr_var [simp]:
  "out_var (pr_var x) = out_var x"
  by (simp add: pr_var_def)

lemma pr_var_idem [simp]:
  "pr_var (pr_var x) = pr_var x"
  by (simp add: pr_var_def)

lemma pr_var_lens_plus [simp]:
  "pr_var (x +\<^sub>L y) = (x +\<^sub>L y)"
  by (simp add: pr_var_def)

lemma pr_var_lens_comp_1 [simp]:
  "pr_var x ;\<^sub>L y = pr_var (x ;\<^sub>L y)"
  by (simp add: pr_var_def)

lemma pr_var_lens_comp_2 [simp]:
  "(x ;\<^sub>L pr_var y) = pr_var (x ;\<^sub>L y)"
  by (simp_all add: pr_var_def)

lemma pr_var_len_quotient_1 [simp]:
  "pr_var x /\<^sub>L y = pr_var (x /\<^sub>L y)"
  by (simp add: pr_var_def)

lemma pr_var_len_quotient_2 [simp]:
  "x /\<^sub>L pr_var y = pr_var (x /\<^sub>L y)"
  by (simp add: pr_var_def)

lemma in_var_plus [simp]: "in_var (x +\<^sub>L y) = in_var x +\<^sub>L in_var y"
  by (simp add: in_var_def)

lemma out_var_plus [simp]: "out_var (x +\<^sub>L y) = out_var x +\<^sub>L out_var y"
  by (simp add: out_var_def)

text \<open> Similar properties follow for sublens \<close>

lemma in_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> in_var y \<subseteq>\<^sub>L in_var x"
  by (metis (no_types, opaque_lifting) in_var_def lens_comp_assoc sublens_def)

lemma out_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> out_var y \<subseteq>\<^sub>L out_var x"
  by (metis (no_types, opaque_lifting) out_var_def lens_comp_assoc sublens_def)

lemma pr_var_sublens_l [simp]: "a \<subseteq>\<^sub>L b \<Longrightarrow> pr_var (a) \<subseteq>\<^sub>L b"
  by (simp add: pr_var_def)

lemma pr_var_sublens_r [simp]: "a \<subseteq>\<^sub>L b \<Longrightarrow> a \<subseteq>\<^sub>L pr_var (b)"
  by (simp add: pr_var_def)

subsection \<open> Lens simplifications \<close>

text \<open> We also define some lookup abstraction simplifications. \<close>

lemma var_lookup_in [simp]: "lens_get (in_var x) (A, A') = lens_get x A"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_lookup_out [simp]: "lens_get (out_var x) (A, A') = lens_get x A'"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

lemma var_update_in [simp]: "lens_put (in_var x) (A, A') v = (lens_put x A v, A')"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_update_out [simp]: "lens_put (out_var x) (A, A') v = (A, lens_put x A' v)"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

lemma get_lens_plus [simp]: "get\<^bsub>x +\<^sub>L y\<^esub> s = (get\<^bsub>x\<^esub> s, get\<^bsub>y\<^esub> s)"
  by (simp add: lens_defs)

subsection \<open> Syntax translations \<close>

text \<open> In order to support nice syntax for variables, we here set up some translations. The first
  step is to introduce a collection of non-terminals. \<close>

nonterminal svid and svids and svar and svars and salpha

text \<open> These non-terminals correspond to the following syntactic entities. Non-terminal
  @{typ "svid"} is an atomic variable identifier, and @{typ "svids"} is a list of identifier.
  @{typ "svar"} is a decorated variable, such as an input or output variable, and @{typ "svars"} is
  a list of decorated variables. @{typ "salpha"} is an alphabet or set of variables. Such sets can
  be constructed only through lens composition due to typing restrictions. Next we introduce some
  syntax constructors. \<close>

syntax \<comment> \<open> Identifiers \<close>
  "_svid"         :: "id_position \<Rightarrow> svid" ("_" [999] 999)
  "_svlongid"     :: "longid_position \<Rightarrow> svid" ("_" [999] 999)
  "_svid_unit"    :: "svid \<Rightarrow> svids" ("_")
  "_svid_list"    :: "svid \<Rightarrow> svids \<Rightarrow> svids" ("_,/ _")
  "_svid_alpha"   :: "svid" ("\<^bold>v")
  "_svid_dot"     :: "svid \<Rightarrow> svid \<Rightarrow> svid" ("_:_" [999,998] 998)
  "_svid_res"     :: "svid \<Rightarrow> svid \<Rightarrow> svid" ("_\<restriction>_" [999,998] 998)
  "_mk_svid_list" :: "svids \<Rightarrow> logic" \<comment> \<open> Helper function for summing a list of identifiers \<close>
  "_svid_view"    :: "logic \<Rightarrow> svid" ("\<V>[_]") \<comment> \<open> View of a symmetric lens \<close>
  "_svid_coview"  :: "logic \<Rightarrow> svid" ("\<C>[_]") \<comment> \<open> Coview of a symmetric lens \<close>

text \<open> A variable identifier can either be a HOL identifier, the complete set of variables in the
  alphabet $\textbf{v}$, or a composite identifier separated by colons, which
  corresponds to a sort of qualification. The final option is effectively a lens composition. \<close>

syntax \<comment> \<open> Decorations \<close>
  "_spvar"       :: "svid \<Rightarrow> svar" ("&_" [990] 990)
  "_sinvar"      :: "svid \<Rightarrow> svar" ("$_" [990] 990)
  "_soutvar"     :: "svid \<Rightarrow> svar" ("$_\<acute>" [990] 990)

text \<open> A variable can be decorated with an ampersand, to indicate it is a predicate variable, with
  a dollar to indicate its an unprimed relational variable, or a dollar and ``acute'' symbol to
  indicate its a primed relational variable. Isabelle's parser is extensible so additional
  decorations can be and are added later. \<close>

syntax \<comment> \<open> Variable sets \<close>
  "_salphaid"    :: "svid \<Rightarrow> salpha" ("_" [990] 990)
  "_salphavar"   :: "svar \<Rightarrow> salpha" ("_" [990] 990)
  "_salphaparen" :: "salpha \<Rightarrow> salpha" ("'(_')")
  "_salphacomp"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr ";" 75)
  "_salphaprod"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr "\<times>" 85)
  "_salpha_all"  :: "salpha" ("\<Sigma>")
  "_salpha_none" :: "salpha" ("\<emptyset>")
  "_svar_nil"    :: "svar \<Rightarrow> svars" ("_")
  "_svar_cons"   :: "svar \<Rightarrow> svars \<Rightarrow> svars" ("_,/ _")
  "_salphaset"   :: "svars \<Rightarrow> salpha" ("{_}")
  "_salphamk"    :: "logic \<Rightarrow> salpha"

text \<open> The terminals of an alphabet are either HOL identifiers or UTP variable identifiers.
  We support two ways of constructing alphabets; by composition of smaller alphabets using
  a semi-colon or by a set-style construction $\{a,b,c\}$ with a list of UTP variables. \<close>

syntax \<comment> \<open> Quotations \<close>
  "_ualpha_set"  :: "svars \<Rightarrow> logic" ("{_}\<^sub>\<alpha>")
  "_svid_set"    :: "svids \<Rightarrow> logic" ("{_}\<^sub>v")
  "_svid_empty"  :: "logic" ("{}\<^sub>v")
  "_svar"        :: "svar \<Rightarrow> logic" ("'(_')\<^sub>v")

text \<open> For various reasons, the syntax constructors above all yield specific grammar categories and
  will not parser at the HOL top level (basically this is to do with us wanting to reuse the syntax
  for expressions). As a result we provide some quotation constructors above.

  Next we need to construct the syntax translations rules. Finally, we set up the translations rules. \<close>

translations
  \<comment> \<open> Identifiers \<close>
  "_svid x" \<rightharpoonup> "x"
  "_svlongid x" \<rightharpoonup> "x"
  "_svid_alpha" \<rightleftharpoons> "\<Sigma>"
  "_svid_dot x y" \<rightharpoonup> "y ;\<^sub>L x"
  "_svid_res x y" \<rightharpoonup> "x /\<^sub>L y"
  "_mk_svid_list (_svid_unit x)" \<rightharpoonup> "x"
  "_mk_svid_list (_svid_list x xs)" \<rightharpoonup> "x +\<^sub>L _mk_svid_list xs"
  "_svid_view a" => "\<V>\<^bsub>a\<^esub>"
  "_svid_coview a" => "\<C>\<^bsub>a\<^esub>"

  \<comment> \<open> Decorations \<close>
  "_spvar \<Sigma>"  \<leftharpoondown>  "CONST pr_var CONST id_lens"
  "_sinvar \<Sigma>"  \<leftharpoondown> "CONST in_var 1\<^sub>L"
  "_soutvar \<Sigma>" \<leftharpoondown> "CONST out_var 1\<^sub>L"
  "_spvar (_svid_dot x y)" \<leftharpoondown> "CONST pr_var (CONST lens_comp y x)"
  "_sinvar (_svid_dot x y)" \<leftharpoondown> "CONST in_var (CONST lens_comp y x)"
  "_soutvar (_svid_dot x y)" \<leftharpoondown> "CONST out_var (CONST lens_comp y x)"
  "_svid_dot x (_svid_dot y z)" \<leftharpoondown> "_svid_dot x (CONST lens_comp z y)"

  "_spvar (_svid_res x y)" \<leftharpoondown> "CONST pr_var (CONST lens_quotient x y)"
  "_sinvar (_svid_res x y)" \<leftharpoondown> "CONST in_var (CONST lens_quotient x y)"
  "_soutvar (_svid_res x y)" \<leftharpoondown> "CONST out_var (CONST lens_quotient x y)"

  "_spvar x" \<rightleftharpoons> "CONST pr_var x"
  "_sinvar x" \<rightleftharpoons> "CONST in_var x"
  "_soutvar x" \<rightleftharpoons> "CONST out_var x"

  \<comment> \<open> Alphabets \<close>
  "_salphaparen a" \<rightharpoonup> "a"
  "_salphaid x" \<rightharpoonup> "x"
  "_salphacomp x y" \<rightharpoonup> "x +\<^sub>L y"
  "_salphaprod a b" \<rightleftharpoons> "a \<times>\<^sub>L b"
  "_salphavar x" \<rightharpoonup> "x"
  "_svar_nil x" \<rightharpoonup> "x"
  "_svar_cons x xs" \<rightharpoonup> "x +\<^sub>L xs"
  "_salphaset A" \<rightharpoonup> "A"
  "(_svar_cons x (_salphamk y))" \<leftharpoondown> "_salphamk (x +\<^sub>L y)"
  "x" \<leftharpoondown> "_salphamk x"
  "_salpha_all" \<rightleftharpoons> "1\<^sub>L"
  "_salpha_none" \<rightleftharpoons> "0\<^sub>L"

  \<comment> \<open> Quotations \<close>
  "_ualpha_set A" \<rightharpoonup> "A"
  "_svid_set A" \<rightharpoonup> "_mk_svid_list A"
  "_svid_empty" \<rightharpoonup> "0\<^sub>L"
  "_svar x" \<rightharpoonup> "x"

text \<open> The translation rules mainly convert syntax into lens constructions, using a mixture
  of lens operators and the bespoke variable definitions. Notably, a colon variable identifier
  qualification becomes a lens composition, and variable sets are constructed using len sum.
  The translation rules are carefully crafted to ensure both parsing and pretty printing.

  Finally we create the following useful utility translation function that allows us to construct a
  UTP variable (lens) type given a return and alphabet type. \<close>

syntax
  "_uvar_ty"      :: "type \<Rightarrow> type \<Rightarrow> type"

parse_translation \<open>
let
  fun uvar_ty_tr [ty] = Syntax.const @{type_syntax lens} $ ty $ Syntax.const @{type_syntax dummy}
    | uvar_ty_tr ts = raise TERM ("uvar_ty_tr", ts);
in [(@{syntax_const "_uvar_ty"}, K uvar_ty_tr)] end
\<close>

end


theory Fixed_Action
imports Semantics_Ternary
begin

section\<open>Fixed Action\<close>

text\<open>If firewall rules have the same action, we can focus on the matching only.\<close>

text\<open>Applying a rule once or several times makes no difference.\<close>
lemma approximating_bigstep_fun_prepend_replicate:
  "n > 0 \<Longrightarrow> approximating_bigstep_fun \<gamma> p (r#rs) Undecided = approximating_bigstep_fun \<gamma> p ((replicate n r)@rs) Undecided"
apply(induction n)
 apply(simp)
apply(simp)
apply(case_tac r)
apply(rename_tac m a)
apply(simp split: action.split)
by fastforce

text\<open>utility lemmas\<close>
context
begin
  private lemma fixedaction_Log: "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m Log) ms) Undecided = Undecided"
    by(induction ms, simp_all)

  private lemma fixedaction_Empty:"approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m Empty) ms) Undecided = Undecided"
    by(induction ms, simp_all)

  private lemma helperX1_Log: "matches \<gamma> m' Log p \<Longrightarrow>
         approximating_bigstep_fun \<gamma> p (map ((\<lambda>m. Rule m Log) \<circ> MatchAnd m') m2' @ rs2) Undecided =
         approximating_bigstep_fun \<gamma> p rs2 Undecided"
    by(induction m2')(simp_all split: action.split)

  private

  private lemma helperX3: "matches \<gamma> m' a p \<Longrightarrow>
       approximating_bigstep_fun \<gamma> p (map ((\<lambda>m. Rule m a) \<circ> MatchAnd m') m2' @ rs2 ) Undecided =
       approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) m2' @ rs2) Undecided"
  proof(induction m2')
    case Nil thus ?case by simp
    next
    case Cons thus ?case by(cases a) (simp_all add: matches_simps)
  qed

  lemmas fixed_action_simps = fixedaction_Log fixedaction_Empty helperX1_Log helperX1_Empty helperX3
end

lemma fixedaction_swap:
   "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m1@m2)) s = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m2@m1)) s"
proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
case Undecided
  have "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) m1 @ map (\<lambda>m. Rule m a) m2) Undecided =
        approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) m2 @ map (\<lambda>m. Rule m a) m1) Undecided"
  proof(induction m1)
    case Nil thus ?case by simp
    next
    case (Cons m m1)
      { fix m rs
        have "approximating_bigstep_fun \<gamma> p ((map (\<lambda>m. Rule m Log) m)@rs) Undecided =
            approximating_bigstep_fun \<gamma> p rs Undecided"
        by(induction m) (simp_all)
      } note Log_helper=this
      { fix m rs
        have "approximating_bigstep_fun \<gamma> p ((map (\<lambda>m. Rule m Empty) m)@rs) Undecided =
            approximating_bigstep_fun \<gamma> p rs Undecided"
        by(induction m) (simp_all)
      } note Empty_helper=this

      show ?case
        proof(cases "matches \<gamma> m a p")
          case True
            thus ?thesis
              proof(induction m2)
                case Nil thus ?case by simp
              next
                case Cons thus ?case
                  apply(simp split:action.split action.split_asm)
                  using Log_helper Empty_helper by fastforce+
              qed
          next
          case False
            thus ?thesis
             apply(simp)
             apply(simp add: Cons.IH)
             apply(induction m2)
              apply(simp_all)
             apply(simp split:action.split action.split_asm)
             apply fastforce
            done
        qed
    qed
  thus ?thesis using Undecided by simp
qed

corollary fixedaction_reorder: "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m1 @ m2 @ m3)) s = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m2 @ m1 @ m3)) s"
proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
case Undecided
have "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m1 @ m2 @ m3)) Undecided = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m2 @ m1 @ m3)) Undecided"
  proof(induction m3)
    case Nil thus ?case using fixedaction_swap by fastforce
    next
    case (Cons m3'1 m3)
      have "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ((m3'1 # m3) @ m1 @ m2)) Undecided = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ((m3'1 # m3) @ m2 @ m1)) Undecided"
        apply(simp)
        apply(cases "matches \<gamma> m3'1 a p")
         apply(simp split: action.split action.split_asm)
         apply (metis append_assoc fixedaction_swap map_append Cons.IH)
        apply(simp)
        by (metis append_assoc fixedaction_swap map_append Cons.IH)
      hence "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ((m1 @ m2) @ m3'1 # m3)) Undecided = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ((m2 @ m1) @ m3'1 # m3)) Undecided"
        apply(subst fixedaction_swap)
        apply(subst(2) fixedaction_swap)
        by simp
      thus ?case
        apply(subst append_assoc[symmetric])
        apply(subst append_assoc[symmetric])
        by simp
  qed
  thus ?thesis using Undecided by simp
qed

text\<open>If the actions are equal, the @{term set} (position and replication independent) of the match expressions can be considered.\<close>
lemma approximating_bigstep_fun_fixaction_matchseteq: "set m1 = set m2 \<Longrightarrow>
        approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) m1) s =
       approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) m2) s"
proof(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
  assume m1m2_seteq: "set m1 = set m2" and "s = Undecided"
  from m1m2_seteq have
    "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) m1) Undecided =
     approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) m2) Undecided"
  proof(induction m1 arbitrary: m2)
   case Nil thus ?case by simp
   next
   case (Cons m m1)
    show ?case
      proof (cases "m \<in> set m1")
      case True
        from True have "set m1 = set (m # m1)" by auto
        from Cons.IH[OF \<open>set m1 = set (m # m1)\<close>] have "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m # m1)) Undecided = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m1)) Undecided" ..
        thus ?thesis by (metis Cons.IH Cons.prems \<open>set m1 = set (m # m1)\<close>)
      next
      case False
        from False have "m \<notin> set m1" .
        show ?thesis
        proof (cases "m \<notin> set m2")
          case True
          from True \<open>m \<notin> set m1\<close> Cons.prems have "set m1 = set m2" by auto
          from Cons.IH[OF this] show ?thesis by (metis Cons.IH Cons.prems \<open>set m1 = set m2\<close>)
        next
        case False
          hence "m \<in> set m2" by simp

          have repl_filter_simp: "(replicate (length [x\<leftarrow>m2 . x = m]) m) = [x\<leftarrow>m2 . x = m]"
            by (metis (lifting, full_types) filter_set member_filter replicate_length_same)

          from Cons.prems  \<open>m \<notin> set m1\<close> have "set m1 = set (filter (\<lambda>x. x\<noteq>m) m2)" by auto
          from Cons.IH[OF this] have "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) m1) Undecided = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) [x\<leftarrow>m2 . x \<noteq> m]) Undecided" .
          from this have "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m#m1)) Undecided = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (m#[x\<leftarrow>m2 . x \<noteq> m])) Undecided"
            apply(simp split: action.split)
            by fast
          also have "\<dots> = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ([x\<leftarrow>m2 . x = m]@[x\<leftarrow>m2 . x \<noteq> m])) Undecided"
            apply(simp only: list.map)
            thm approximating_bigstep_fun_prepend_replicate[where n="length [x\<leftarrow>m2 . x = m]"]
            apply(subst approximating_bigstep_fun_prepend_replicate[where n="length [x\<leftarrow>m2 . x = m]"])
            apply (metis (full_types) False filter_empty_conv neq0_conv repl_filter_simp replicate_0)
            by (metis (lifting, no_types) map_append map_replicate repl_filter_simp)
          also have "\<dots> =  approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) m2) Undecided"
            proof(induction m2)
            case Nil thus ?case by simp
            next
            case(Cons m2'1 m2')
              have "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) [x\<leftarrow>m2' . x = m] @ Rule m2'1 a # map (\<lambda>m. Rule m a) [x\<leftarrow>m2' . x \<noteq> m]) Undecided =
                    approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ([x\<leftarrow>m2' . x = m] @ [m2'1] @ [x\<leftarrow>m2' . x \<noteq> m])) Undecided" by fastforce
              also have "\<dots> = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ([m2'1] @ [x\<leftarrow>m2' . x = m] @ [x\<leftarrow>m2' . x \<noteq> m])) Undecided"
              using fixedaction_reorder by fast
              finally have XX: "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) [x\<leftarrow>m2' . x = m] @ Rule m2'1 a # map (\<lambda>m. Rule m a) [x\<leftarrow>m2' . x \<noteq> m]) Undecided =
                    approximating_bigstep_fun \<gamma> p (Rule m2'1 a # (map (\<lambda>m. Rule m a) [x\<leftarrow>m2' . x = m] @ map (\<lambda>m. Rule m a) [x\<leftarrow>m2' . x \<noteq> m])) Undecided"
              by fastforce
              from Cons show ?case
                apply(case_tac "m2'1 = m")
                 apply(simp split: action.split)
                 apply fast
                apply(simp del: approximating_bigstep_fun.simps)
                apply(simp only: XX)
                apply(case_tac "matches \<gamma> m2'1 a p")
                 apply(simp)
                 apply(simp split: action.split)
                 apply(fast)
                apply(simp)
                done
            qed
          finally show ?thesis .
        qed
      qed
  qed
  thus ?thesis using \<open>s = Undecided\<close> by simp
qed

subsection\<open>@{term match_list}\<close>
  text\<open>Reducing the firewall semantics to short-circuit matching evaluation\<close>

  fun match_list :: "('a, 'packet) match_tac \<Rightarrow> 'a match_expr list \<Rightarrow> action \<Rightarrow> 'packet \<Rightarrow> bool" where
   "match_list \<gamma> [] a p = False" |
   "match_list \<gamma> (m#ms) a p = (if matches \<gamma> m a p then True else match_list \<gamma> ms a p)"

  lemma match_list_matches: "match_list \<gamma> ms a p \<longleftrightarrow> (\<exists>m \<in> set ms. matches \<gamma> m a p)"
    by(induction ms, simp_all)

  lemma match_list_True: "match_list \<gamma> ms a p \<Longrightarrow> approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ms) Undecided = (case a of Accept \<Rightarrow> Decision FinalAllow
              | Drop \<Rightarrow> Decision FinalDeny
              | Reject \<Rightarrow> Decision FinalDeny
              | Log \<Rightarrow> Undecided
              | Empty \<Rightarrow> Undecided
              (*unhandled cases*)
              )"
    apply(induction ms)
     apply(simp)
    apply(simp split: if_split_asm action.split)
    apply(simp add: fixed_action_simps)
    done
  lemma match_list_False: "\<not> match_list \<gamma> ms a p \<Longrightarrow> approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ms) Undecided = Undecided"
    apply(induction ms)
     apply(simp)
    apply(simp split: if_split_asm action.split)
    done

  text\<open>The key idea behind @{const match_list}: Reducing semantics to match list\<close>
  lemma match_list_semantics: "match_list \<gamma> ms1 a p \<longleftrightarrow> match_list \<gamma> ms2 a p \<Longrightarrow>
    approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ms1) s = approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) ms2) s"
    apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
    apply(simp)
    apply(thin_tac "s = Undecided")
    apply(induction ms2)
     apply(simp)
     apply(induction ms1)
      apply(simp)
     apply(simp split: if_split_asm)
    apply(rename_tac m ms2)
    apply(simp del: approximating_bigstep_fun.simps)
    apply(simp split: if_split_asm del: approximating_bigstep_fun.simps)
     apply(simp split: action.split add: match_list_True fixed_action_simps)
    apply(simp)
    done

  text\<open>We can exploit de-morgan to get a disjunction in the match expression!\<close>
  (*but we need to normalize afterwards, which is quite slow*)
  fun match_list_to_match_expr :: "'a match_expr list \<Rightarrow> 'a match_expr" where
    "match_list_to_match_expr [] = MatchNot MatchAny" |
    "match_list_to_match_expr (m#ms) = MatchOr m (match_list_to_match_expr ms)"
  text\<open>@{const match_list_to_match_expr} constructs a unwieldy @{typ "'a match_expr"} from a list.
        The semantics of the resulting match expression is the disjunction of the elements of the list.
        This is handy because the normal match expressions do not directly support disjunction.
        Use this function with care because the resulting match expression is very ugly!\<close>
  lemma match_list_to_match_expr_disjunction: "match_list \<gamma> ms a p \<longleftrightarrow> matches \<gamma> (match_list_to_match_expr ms) a p"
    apply(induction ms rule: match_list_to_match_expr.induct)
     apply(simp add: bunch_of_lemmata_about_matches; fail)
    apply(simp add: MatchOr)
  done

  lemma match_list_singleton: "match_list \<gamma> [m] a p \<longleftrightarrow> matches \<gamma> m a p" by(simp)

  lemma match_list_append: "match_list \<gamma> (m1@m2) a p \<longleftrightarrow> (\<not> match_list \<gamma> m1 a p \<longrightarrow> match_list \<gamma> m2 a p)"
      by(induction m1) simp+

  lemma match_list_helper1: "\<not> matches \<gamma> m2 a p \<Longrightarrow> match_list \<gamma> (map (\<lambda>x. MatchAnd x m2) m1') a p \<Longrightarrow> False"
    apply(induction m1')
     apply(simp; fail)
    apply(simp split:if_split_asm)
    by(auto dest: matches_dest)
  lemma match_list_helper2: " \<not> matches \<gamma> m a p \<Longrightarrow> \<not> match_list \<gamma> (map (MatchAnd m) m2') a p"
    apply(induction m2')
     apply(simp; fail)
    apply(simp split:if_split_asm)
    by(auto dest: matches_dest)
  lemma match_list_helper3: "matches \<gamma> m a p \<Longrightarrow> match_list \<gamma> m2' a p \<Longrightarrow> match_list \<gamma> (map (MatchAnd m) m2') a p"
    apply(induction m2')
     apply(simp; fail)
    apply(simp split:if_split_asm)
    by (simp add: matches_simps)
  lemma match_list_helper4: "\<not> match_list \<gamma> m2' a p \<Longrightarrow> \<not> match_list \<gamma> (map (MatchAnd aa) m2') a p "
    apply(induction m2')
     apply(simp; fail)
    apply(simp split:if_split_asm)
    by(auto dest: matches_dest)
  lemma match_list_helper5: " \<not> match_list \<gamma> m2' a p \<Longrightarrow> \<not> match_list \<gamma> (concat (map (\<lambda>x. map (MatchAnd x) m2') m1')) a p "
    apply(induction m2')
     apply(simp add:empty_concat; fail)
    apply(simp split:if_split_asm)
    apply(induction m1')
     apply(simp; fail)
    apply(simp add: match_list_append)
    by(auto dest: matches_dest)
  lemma match_list_helper6: "\<not> match_list \<gamma> m1' a p \<Longrightarrow> \<not> match_list \<gamma> (concat (map (\<lambda>x. map (MatchAnd x) m2') m1')) a p "
    apply(induction m2')
     apply(simp add:empty_concat; fail)
    apply(simp split:if_split_asm)
    apply(induction m1')
     apply(simp; fail)
    apply(simp add: match_list_append split: if_split_asm)
    by(auto dest: matches_dest)

  lemmas match_list_helper = match_list_helper1 match_list_helper2 match_list_helper3 match_list_helper4 match_list_helper5 match_list_helper6
  hide_fact match_list_helper1 match_list_helper2 match_list_helper3 match_list_helper4 match_list_helper5 match_list_helper6

  lemma match_list_map_And1: "matches \<gamma> m1 a p = match_list \<gamma> m1' a p \<Longrightarrow>
           matches \<gamma> (MatchAnd m1 m2) a p \<longleftrightarrow> match_list \<gamma>  (map (\<lambda>x. MatchAnd x m2) m1') a p"
    apply(induction m1')
     apply(auto dest: matches_dest; fail)[1]
    apply(simp split: if_split_asm)
     apply safe
        apply(simp_all add: matches_simps)
      apply(auto dest: match_list_helper(1))[1]
     by(auto dest: matches_dest)

  lemma matches_list_And_concat: "matches \<gamma> m1 a p = match_list \<gamma> m1' a p \<Longrightarrow> matches \<gamma> m2 a p = match_list \<gamma> m2' a p \<Longrightarrow>
           matches \<gamma> (MatchAnd m1 m2) a p \<longleftrightarrow> match_list \<gamma> [MatchAnd x y. x <- m1', y <- m2'] a p"
    apply(induction m1')
     apply(auto dest: matches_dest; fail)[1]
    apply(simp split: if_split_asm)
     prefer 2
     apply(simp add: match_list_append)
     apply(subgoal_tac "\<not> match_list \<gamma> (map (MatchAnd aa) m2') a p")
      apply(simp; fail)
     apply safe
               apply(simp_all add: matches_simps match_list_append match_list_helper)
    done

  lemma match_list_concat: "match_list \<gamma> (concat lss) a p \<longleftrightarrow> (\<exists>ls \<in> set lss. match_list \<gamma> ls a p)"
    apply(induction lss)
     apply(simp; fail)
    by(auto simp add: match_list_append)

lemma fixedaction_wf_ruleset: "wf_ruleset \<gamma> p (map (\<lambda>m. Rule m a) ms) \<longleftrightarrow>
  \<not> match_list \<gamma> ms a p \<or> \<not> (\<exists>chain. a = Call chain) \<and> a \<noteq> Return \<and> \<not> (\<exists>chain. a = Goto chain) \<and> a \<noteq> Unknown"
  proof -
  have helper: "\<And>a b c. a \<longleftrightarrow> c \<Longrightarrow> (a \<longrightarrow> b) = (c \<longrightarrow> b)" by fast
  show ?thesis
    apply(simp add: wf_ruleset_def)
    apply(rule helper)
    apply(induction ms)
     apply(simp; fail)
    apply(simp)
    done
  qed

lemma wf_ruleset_singleton: "wf_ruleset \<gamma> p [Rule m a] \<longleftrightarrow> \<not> matches \<gamma> m a p \<or> \<not> (\<exists>chain. a = Call chain) \<and> a \<noteq> Return \<and> \<not> (\<exists>chain. a = Goto chain) \<and> a \<noteq> Unknown"
  by(simp add: wf_ruleset_def)

end


(*  Title:      HOL/Corec_Examples/Stream_Processor.thy
    Author:     Andreas Lochbihler, ETH Zuerich
    Author:     Dmitriy Traytel, ETH Zuerich
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2014, 2016

Stream processors---a syntactic representation of continuous functions on streams.
*)

section \<open>Stream Processors---A Syntactic Representation of Continuous Functions on Streams\<close>

theory Stream_Processor
imports "HOL-Library.BNF_Corec" "HOL-Library.Stream"
begin

datatype (discs_sels) ('a, 'b, 'c) sp\<^sub>\<mu> =
  Get "'a \<Rightarrow> ('a, 'b, 'c) sp\<^sub>\<mu>"
| Put "'b" "'c"

codatatype ('a, 'b) sp\<^sub>\<nu> =
  In (out: "('a, 'b, ('a, 'b) sp\<^sub>\<nu>) sp\<^sub>\<mu>")

definition "sub \<equiv> {(f a, Get f) | a f. True}"

lemma subI[intro]: "(f a, Get f) \<in> sub"
  unfolding sub_def by blast

lemma wf_sub[simp, intro]: "wf sub"
proof (rule wfUNIVI)
  fix P  :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> bool" and x
  assume "\<forall>x. (\<forall>y. (y, x) \<in> sub \<longrightarrow> P y) \<longrightarrow> P x"
  hence I: "\<And>x. (\<forall>y. (\<exists>a f. y = f a \<and> x = Get f) \<longrightarrow> P y) \<Longrightarrow> P x" unfolding sub_def by blast
  show "P x" by (induct x) (auto intro: I)
qed

lemma Get_neq: "Get f \<noteq> f a"
  by (metis subI wf_not_sym wf_sub)

definition get where
  "get f = In (Get (\<lambda>a. out (f a)))"

corecursive run :: "('a, 'b) sp\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b stream" where
  "run sp s = (case out sp of
     Get f \<Rightarrow> run (In (f (shd s))) (stl s)
   | Put b sp \<Rightarrow> b ## run sp s)"
  by (relation "inv_image (map_prod In In ` sub) fst")
     (auto simp: inj_on_def out_def split: sp\<^sub>\<nu>.splits intro: wf_map_prod_image)

corec copy where
  "copy = In (Get (\<lambda>a. Put a copy))"

friend_of_corec get where
  "get f = In (Get (\<lambda>a. out (f a)))"
  by (auto simp: rel_fun_def get_def sp\<^sub>\<mu>.rel_map rel_prod.simps, metis sndI)

lemma run_simps [simp]:
  "run (In (Get f)) s = run (In (f (shd s))) (stl s)"
  "run (In (Put b sp)) s = b ## run sp s"
by(subst run.code; simp; fail)+

lemma copy_sel[simp]: "out copy = Get (\<lambda>a. Put a copy)"
  by (subst copy.code; simp)

corecursive sp_comp (infixl "oo" 65) where
  "sp oo sp' = (case (out sp, out sp') of
      (Put b sp, _) \<Rightarrow> In (Put b (sp oo sp'))
    | (Get f, Put b sp) \<Rightarrow> In (f b) oo sp
    | (_, Get g) \<Rightarrow> get (\<lambda>a. (sp oo In (g a))))"
  by (relation "map_prod In In ` sub <*lex*> map_prod In In ` sub")
    (auto simp: inj_on_def out_def split: sp\<^sub>\<nu>.splits intro: wf_map_prod_image)

lemma run_copy_unique:
    "(\<And>s. h s = shd s ## h (stl s)) \<Longrightarrow> h = run copy"
apply corec_unique
apply(rule ext)
apply(subst copy.code)
apply simp
done

end


(*  Title:      HOL/Groebner_Basis.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Groebner bases\<close>

theory Groebner_Basis
imports Semiring_Normalization Parity
begin

subsection \<open>Groebner Bases\<close>

lemmas bool_simps = simp_thms(1-34) \<comment> \<open>FIXME move to @{theory HOL}\<close>

lemma nnf_simps: \<comment> \<open>FIXME shadows fact binding in @{theory HOL}\<close>
  "(\<not>(P \<and> Q)) = (\<not>P \<or> \<not>Q)" "(\<not>(P \<or> Q)) = (\<not>P \<and> \<not>Q)"
  "(P \<longrightarrow> Q) = (\<not>P \<or> Q)"
  "(P = Q) = ((P \<and> Q) \<or> (\<not>P \<and> \<not> Q))" "(\<not> \<not>(P)) = P"
  by blast+

lemma dnf:
  "(P & (Q | R)) = ((P&Q) | (P&R))"
  "((Q | R) & P) = ((Q&P) | (R&P))"
  "(P \<and> Q) = (Q \<and> P)"
  "(P \<or> Q) = (Q \<or> P)"
  by blast+

lemmas weak_dnf_simps = dnf bool_simps

lemma PFalse:
    "P \<equiv> False \<Longrightarrow> \<not> P"
    "\<not> P \<Longrightarrow> (P \<equiv> False)"
  by auto

named_theorems algebra "pre-simplification rules for algebraic methods"
ML_file "Tools/groebner.ML"

method_setup algebra = \<open>
  let
    fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
    val addN = "add"
    val delN = "del"
    val any_keyword = keyword addN || keyword delN
    val thms = Scan.repeats (Scan.unless any_keyword Attrib.multi_thm);
  in
    Scan.optional (keyword addN |-- thms) [] --
     Scan.optional (keyword delN |-- thms) [] >>
    (fn (add_ths, del_ths) => fn ctxt =>
      SIMPLE_METHOD' (Groebner.algebra_tac add_ths del_ths ctxt))
  end
\<close> "solve polynomial equations over (semi)rings and ideal membership problems using Groebner bases"

declare dvd_def[algebra]
declare mod_eq_0_iff_dvd[algebra]
declare mod_div_trivial[algebra]
declare mod_mod_trivial[algebra]
declare div_by_0[algebra]
declare mod_by_0[algebra]
declare mult_div_mod_eq[algebra]
declare div_minus_minus[algebra]
declare mod_minus_minus[algebra]
declare div_minus_right[algebra]
declare mod_minus_right[algebra]
declare div_0[algebra]
declare mod_0[algebra]
declare mod_by_1[algebra]
declare div_by_1[algebra]
declare mod_minus1_right[algebra]
declare div_minus1_right[algebra]
declare mod_mult_self2_is_0[algebra]
declare mod_mult_self1_is_0[algebra]
declare zmod_eq_0_iff[algebra]
declare dvd_0_left_iff[algebra]
declare zdvd1_eq[algebra]
declare zmod_eq_dvd_iff[algebra]
declare nat_mod_eq_iff[algebra]

context semiring_parity
begin

declare even_times_iff [algebra]
declare even_power [algebra]

end

context ring_parity
begin

declare even_minus [algebra]

end

declare even_Suc [algebra]
declare even_diff_nat [algebra]

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: upred.thy                                                            *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Core Predicates\<close>

theory upred
imports ustate
begin

text \<open>This theory needs rework for integration with @{text uexpr}.\<close>

subsection \<open>Predicate Type\<close>

typedef upred = "UNIV :: ustate set set"
apply (rule UNIV_witness)
done

notation Rep_upred ("\<beta>")

setup_lifting type_definition_upred

subsection \<open>Literal Predicates\<close>

lift_definition TrueP :: "upred"
is "UNIV"
done

notation TrueP ("true\<^sub>p")

lift_definition FalseP :: "upred"
is "{}"
done

notation FalseP ("false\<^sub>p")

subsection \<open>Logical Connectives\<close>

lift_definition NotP :: "upred \<Rightarrow> upred"
is "uminus"
done

notation NotP ("\<not>\<^sub>p _" [190] 190)

lift_definition AndP :: "upred \<Rightarrow> upred \<Rightarrow> upred"
is "(\<inter>)"
done

notation AndP (infixr "\<and>\<^sub>p" 180)

lift_definition OrP :: "upred \<Rightarrow> upred \<Rightarrow> upred"
is "(\<union>)"
done

notation OrP (infixr "\<or>\<^sub>p" 170)

definition ImpliesP :: "upred \<Rightarrow> upred \<Rightarrow> upred" where
"ImpliesP p1 p2 = \<not>\<^sub>p p1 \<or>\<^sub>p p2"

notation ImpliesP (infixr "\<Rightarrow>\<^sub>p" 160)

definition IffP :: "upred \<Rightarrow> upred \<Rightarrow> upred" where
"IffP p1 p2 = (p1 \<Rightarrow>\<^sub>p p2) \<and>\<^sub>p (p2 \<Rightarrow>\<^sub>p p1)"

notation IffP (infixr "\<Leftrightarrow>\<^sub>p" 150)

syntax "_RevIffP" :: "upred \<Rightarrow> upred \<Rightarrow> upred" (infixr "\<Leftarrow>\<^sub>p" 160)

translations "p1 \<Leftarrow>\<^sub>p p2" \<rightharpoonup> "p2 \<Rightarrow>\<^sub>p p1"

subsection \<open>Quantifiers\<close>

lift_definition ExistsP :: "uvar set \<Rightarrow> upred \<Rightarrow> upred" is
"\<lambda>vs p. {b1 \<oplus>\<^sub>s b2 on vs| b1 b2. b1 \<in> p}"
done

notation ExistsP ("(\<exists>\<^sub>p _./ _)" [0, 100] 100)

definition ForallP :: "uvar set \<Rightarrow> upred \<Rightarrow> upred" where
"ForallP vs p = \<not>\<^sub>p (\<exists>\<^sub>p vs. \<not>\<^sub>p p)"

notation ForallP ("(\<forall>\<^sub>p _./ _)" [0, 100] 100)

definition ClosureP :: "upred \<Rightarrow> upred" where
"ClosureP p = \<forall>\<^sub>p UVAR. p"

notation ClosureP ("[_]\<^sub>p")

subsection \<open>Meta-logical Operators\<close>

definition TautP :: "upred \<Rightarrow> bool" ("taut _" 10) where
"(taut p) = (p = true\<^sub>p)"

definition ContraP :: "upred \<Rightarrow> bool" ("contra _" 10) where
"(contra p) = (p = false\<^sub>p)"

definition RefineP :: "upred \<Rightarrow> upred \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
"p1 \<sqsubseteq> p2 = (taut p1 \<Leftarrow>\<^sub>p p2)"

text \<open>\fixme{I am slightly unsure about the coercion below.}\<close>

declare [[coercion TautP]]

subsection \<open>Proof Support\<close>

named_theorems evalp "evalp theorems"

method upred_tac = (unfold evalp, (auto)?)

text \<open>Evaluation Function\<close>

lift_definition EvalP :: "upred \<Rightarrow> ustate \<Rightarrow> bool" ("\<lbrakk>_\<rbrakk>_" [0, 1000] 51)
is "\<lambda> (p::ustate set) b. b \<in> p"
done

text \<open>Interpretation Laws\<close>

theorem EvalP_eq [evalp]:
"p1 = p2 \<longleftrightarrow> (\<forall>b. \<lbrakk>p1\<rbrakk>b \<longleftrightarrow> \<lbrakk>p2\<rbrakk>b)"
apply (transfer)
apply (auto)
done

theorem EvalP_eqI:
"(\<And>b. \<lbrakk>p1\<rbrakk>b \<longleftrightarrow> \<lbrakk>p2\<rbrakk>b) \<Longrightarrow> p1 = p2"
apply (transfer)
apply (auto)
done

theorem EvalP_TrueP [evalp]:
"\<lbrakk>true\<^sub>p\<rbrakk>b = True"
apply (transfer)
apply (simp)
done

theorem EvalP_FalseP [evalp]:
"\<lbrakk>false\<^sub>p\<rbrakk>b = False"
apply (transfer)
apply (simp)
done

theorem EvalP_NotP [evalp]:
"\<lbrakk>\<not>\<^sub>p p\<rbrakk>b = (\<not>\<lbrakk>p\<rbrakk>b)"
apply (transfer)
apply (simp)
done

theorem EvalP_AndP [evalp]:
"\<lbrakk>p1 \<and>\<^sub>p p2\<rbrakk>b = (\<lbrakk>p1\<rbrakk>b \<and> \<lbrakk>p2\<rbrakk>b)"
apply (transfer)
apply (simp)
done

theorem EvalP_OrP [evalp]:
"\<lbrakk>p1 \<or>\<^sub>p p2\<rbrakk>b = (\<lbrakk>p1\<rbrakk>b \<or> \<lbrakk>p2\<rbrakk>b)"
apply (transfer)
apply (simp)
done

theorem EvalP_ImpliesP [evalp]:
"\<lbrakk>p1 \<Rightarrow>\<^sub>p p2\<rbrakk>b = (\<lbrakk>p1\<rbrakk>b \<longrightarrow> \<lbrakk>p2\<rbrakk>b)"
apply (unfold ImpliesP_def)
apply (auto simp: evalp)
done

theorem EvalP_IffP [evalp]:
"\<lbrakk>p1 \<Leftrightarrow>\<^sub>p p2\<rbrakk>b = (\<lbrakk>p1\<rbrakk>b \<longleftrightarrow> \<lbrakk>p2\<rbrakk>b)"
apply (unfold IffP_def)
apply (auto simp: evalp)
done

theorem EvalP_ExistsP [evalp]:
"\<lbrakk>\<exists>\<^sub>p vs. p\<rbrakk>b = (\<exists>b'. \<lbrakk>p\<rbrakk>(b \<oplus>\<^sub>s b' on vs))"
apply (transfer')
apply (clarsimp)
apply (safe, simp)
\<comment> \<open>Subgoal 1\<close>
apply (rule_tac x = "b1" in exI)
apply (simp)
\<comment> \<open>Subgoal 2\<close>
apply (rule_tac x = "b \<oplus>\<^sub>s b' on vs" in exI)
apply (simp)
apply (rule_tac x = "b" in exI)
apply (simp)
done

theorem EvalP_ForallP [evalp]:
"\<lbrakk>\<forall>\<^sub>p vs . p\<rbrakk>b = (\<forall>b'. \<lbrakk>p\<rbrakk>(b \<oplus>\<^sub>s b' on vs))"
apply (unfold ForallP_def)
apply (auto simp: evalp)
done

theorem EvalP_ClosureP [evalp]:
"\<lbrakk>[p]\<^sub>p\<rbrakk>b = (\<forall>b. \<lbrakk>p\<rbrakk>b)"
apply (unfold ClosureP_def)
apply (auto simp: evalp)
done

declare TautP_def [evalp]
declare ContraP_def [evalp]
declare RefineP_def [evalp]
end