(* Title:      Applications of Modal Kleene Algebras
   Author:     Victor B. F. Gomes, Walter Guttmann, Peter Höfner, Georg Struth, Tjark Weber
   Maintainer: Walter Guttmann <walter.guttman at canterbury.ac.nz>
               Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Applications of Modal Kleene Algebras\<close>

theory Modal_Kleene_Algebra_Applications
imports Antidomain_Semiring
begin

text \<open>This file collects some applications of the theories developed so far. These are described
 in~\cite{guttmannstruthweber11algmeth}.\<close>

context antidomain_kleene_algebra
begin

subsection \<open>A Reachability Result\<close>

text \<open>This example is taken from~\cite{desharnaismoellerstruth06kad}.\<close>

lemma opti_iterate_var [simp]: "|(ad y \<cdot> x)\<^sup>\<star>\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof (rule antisym)
  show "|(ad y \<cdot> x)\<^sup>\<star>\<rangle> y \<le> |x\<^sup>\<star>\<rangle> y"
    by (simp add: a_subid_aux1' ds.fd_iso2 star_iso)
  have "d y + |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y = d y + ad y \<cdot> |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    using local.ads_d_def local.d_6 local.fdia_def by auto
  also have "... = d y + |ad y \<cdot> x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    by (simp add: fdia_export_2)
  finally have "d y + |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y = |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    by simp
  thus "|x\<^sup>\<star>\<rangle> y \<le> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    using local.dka.fd_def local.dka.fdia_star_induct_eq by auto
qed

lemma opti_iterate [simp]: "d y + |(x \<cdot> ad y)\<^sup>\<star>\<rangle> |x\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof -
  have "d y + |(x \<cdot> ad y)\<^sup>\<star>\<rangle> |x\<rangle> y = d y + |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    by (metis local.conway.dagger_slide local.ds.fdia_mult)
  also have "... = d y + |x\<rangle> |x\<^sup>\<star>\<rangle> y"
    by simp
  finally show ?thesis
    by force
qed

lemma opti_iterate_var_2 [simp]: "d y + |ad y \<cdot> x\<rangle> |x\<^sup>\<star>\<rangle> y = |x\<^sup>\<star>\<rangle> y"
  by (metis local.dka.fdia_star_unfold_var opti_iterate_var)

subsection \<open>Derivation of Segerberg's Formula\<close>

text \<open>This example is taken from~\cite{DesharnaisMoellerStruthLMCS}.\<close>

definition Alpha :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("A")
  where "A x y = d (x \<cdot> y) \<cdot> ad y"

lemma A_dom [simp]: "d (A x y) = A x y"
  using Alpha_def local.a_d_closed local.ads_d_def local.apd_d_def by auto

lemma A_fdia: "A x y = |x\<rangle> y \<cdot> ad y"
  by (simp add: Alpha_def local.dka.fd_def)

lemma A_fdia_var: "A x y = |x\<rangle> d y \<cdot> ad y"
  by (simp add: A_fdia)

lemma a_A: "ad (A x (ad y)) = |x] y + ad y"
  using Alpha_def local.a_6 local.a_d_closed local.apd_d_def local.fbox_def by force

lemma fsegerberg [simp]: "d y + |x\<^sup>\<star>\<rangle> A x y = |x\<^sup>\<star>\<rangle> y"
proof (rule antisym)
  have "d y + |x\<rangle> (d y + |x\<^sup>\<star>\<rangle> A x y) = d y + |x\<rangle> y + |x\<rangle> |x\<^sup>\<star>\<rangle> ( |x\<rangle> y \<cdot> ad y )"
    by (simp add: A_fdia add_assoc local.ds.fdia_add1)
  also have "... = d y + |x\<rangle> y \<cdot> ad y + |x\<rangle> |x\<^sup>\<star>\<rangle> ( |x\<rangle> y \<cdot> ad y )"
    by (metis local.am2 local.d_6 local.dka.fd_def local.fdia_def)
  finally have "d y + |x\<rangle> (d y + |x\<^sup>\<star>\<rangle> A x y) = d y + |x\<^sup>\<star>\<rangle> A x y"
    by (metis A_dom A_fdia add_assoc local.dka.fdia_star_unfold_var)
  thus "|x\<^sup>\<star>\<rangle> y \<le> d y + |x\<^sup>\<star>\<rangle> A x y"
    by (metis local.a_d_add_closure local.ads_d_def local.dka.fdia_star_induct_eq local.fdia_def)
  have "d y + |x\<^sup>\<star>\<rangle> A x y = d y + |x\<^sup>\<star>\<rangle> ( |x\<rangle> y \<cdot> ad y )"
    by (simp add: A_fdia)
  also have "... \<le> d y + |x\<^sup>\<star>\<rangle> |x\<rangle> y"
    using local.dpdz.domain_1'' local.ds.fd_iso1 local.join.sup_mono by blast
  finally show "d y + |x\<^sup>\<star>\<rangle> A x y \<le> |x\<^sup>\<star>\<rangle> y"
    by simp
qed

lemma fbox_segerberg [simp]: "d y \<cdot> |x\<^sup>\<star>] ( |x] y + ad y ) = |x\<^sup>\<star>] y"
proof -
  have "|x\<^sup>\<star>] ( |x] y + ad y ) = d ( |x\<^sup>\<star>] ( |x] y + ad y ) )"
    using local.a_d_closed local.ads_d_def local.apd_d_def local.fbox_def by auto
  hence f1: "|x\<^sup>\<star>] ( |x] y + ad y ) = ad ( |x\<^sup>\<star>\<rangle> (A x (ad y)) )"
    by (simp add: a_A local.fdia_fbox_de_morgan_2)
  have "ad y + |x\<^sup>\<star>\<rangle> (A x (ad y)) = |x\<^sup>\<star>\<rangle> ad y"
    by (metis fsegerberg local.a_d_closed local.ads_d_def local.apd_d_def)
  thus ?thesis
    by (metis f1 local.ads_d_def local.ans4 local.fbox_simp local.fdia_fbox_de_morgan_2)
qed

subsection \<open>Wellfoundedness and Loeb's Formula\<close>

text \<open>This example is taken from~\cite{DesharnaisStruthSCP}.\<close>

definition Omega :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<Omega>")
  where "\<Omega> x y = d y \<cdot> ad (x \<cdot> y)"

text \<open>If $y$ is a set, then $\Omega(x,y)$ describes those elements in $y$ from which no further $x$ transitions are possible.\<close>

lemma omega_fdia: "\<Omega> x y = d y \<cdot> ad ( |x\<rangle> y )"
  using Omega_def local.a_d_closed local.ads_d_def local.apd_d_def local.dka.fd_def by auto

lemma omega_fbox: "\<Omega> x y = d y \<cdot> |x] (ad y)"
  by (simp add: fdia_fbox_de_morgan_2 omega_fdia)

lemma omega_absorb1 [simp]: "\<Omega> x y \<cdot> ad ( |x\<rangle> y ) = \<Omega> x y"
  by (simp add: mult_assoc omega_fdia)

lemma omega_absorb2 [simp]: "\<Omega> x y \<cdot> ad (x \<cdot> y) = \<Omega> x y"
  by (simp add: Omega_def mult_assoc)

lemma omega_le_1: "\<Omega> x y \<le> d y"
  by (simp add: Omega_def d_a_galois1)

lemma omega_subid: "\<Omega> x (d y) \<le> d y"
  by (simp add: Omega_def local.a_subid_aux2)

lemma omega_le_2: "\<Omega> x y \<le> ad ( |x\<rangle> y )"
  by (simp add: local.dka.dom_subid_aux2 omega_fdia)

lemma omega_dom [simp]: "d (\<Omega> x y) = \<Omega> x y"
  using Omega_def local.a_d_closed local.ads_d_def local.apd_d_def by auto

lemma a_omega: "ad (\<Omega> x y) = ad y + |x\<rangle> y"
  by (simp add: Omega_def local.a_6 local.ds.fd_def)

lemma omega_fdia_3 [simp]: "d y \<cdot> ad (\<Omega> x y) = d y \<cdot> |x\<rangle> y"
  using Omega_def local.ads_d_def local.fdia_def local.s4 by presburger

lemma omega_zero_equiv_1: "\<Omega> x y = 0 \<longleftrightarrow> d y \<le> |x\<rangle> y"
  by (simp add: Omega_def local.a_gla local.ads_d_def local.fdia_def)

definition Loebian :: "'a \<Rightarrow> bool"
  where "Loebian x = (\<forall>y. |x\<rangle> y \<le> |x\<rangle> \<Omega> x y)"

definition PreLoebian :: "'a \<Rightarrow> bool"
  where "PreLoebian x = (\<forall>y. d y \<le> |x\<^sup>\<star>\<rangle> \<Omega> x y)"

definition Noetherian :: "'a \<Rightarrow> bool"
  where "Noetherian x = (\<forall>y. \<Omega> x y = 0 \<longrightarrow> d y = 0)"

lemma noetherian_alt: "Noetherian x \<longleftrightarrow> (\<forall>y. d y \<le> |x\<rangle> y \<longrightarrow> d y = 0)"
  by (simp add: Noetherian_def omega_zero_equiv_1)

lemma Noetherian_iff_PreLoebian: "Noetherian x \<longleftrightarrow> PreLoebian x"
proof
  assume hyp: "Noetherian x"
  {
    fix y
    have "d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ) = d y \<cdot> ad (\<Omega> x y + |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y)"
      by (metis local.dka.fdia_star_unfold_var omega_dom)
    also have "... = d y \<cdot> ad (\<Omega> x y) \<cdot> ad ( |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y )"
      using ans4 mult_assoc by presburger
    also have "... \<le> |x\<rangle> d y \<cdot> ad ( |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y )"
      by (simp add: local.dka.dom_subid_aux2 local.mult_isor)
    also have "... \<le> |x\<rangle> (d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ))"
      by (simp add: local.dia_diff)
    finally have "d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ) \<le> |x\<rangle> (d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ))"
      by blast
    hence "d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ) = 0"
      by (metis hyp local.ads_d_def local.dpdz.dom_mult_closed local.fdia_def noetherian_alt)
    hence "d y \<le> |x\<^sup>\<star>\<rangle> \<Omega> x y"
      by (simp add: local.a_gla local.ads_d_def local.dka.fd_def)
  }
  thus "PreLoebian x"
    using PreLoebian_def by blast
next
  assume a: "PreLoebian x"
  {
    fix y
    assume b: "\<Omega> x y = 0"
    hence "d y \<le> |x\<rangle> d y"
      using omega_zero_equiv_1 by auto
    hence "d y = 0"
      by (metis (no_types) PreLoebian_def a b a_one a_zero add_zeror annir fdia_def less_eq_def)
  }
  thus "Noetherian x"
    by (simp add: Noetherian_def)
qed

lemma Loebian_imp_Noetherian: "Loebian x \<Longrightarrow> Noetherian x"
proof -
  assume a: "Loebian x"
  {
    fix y
    assume b: "\<Omega> x y = 0"
    hence "d y \<le> |x\<rangle> d y"
      using omega_zero_equiv_1 by auto
    also have "... \<le> |x\<rangle> (\<Omega> x y)"
      using Loebian_def a by auto
    finally have "d y = 0"
      by (simp add: b local.antisym local.fdia_def)
  }
  thus "Noetherian x"
    by (simp add: Noetherian_def)
qed

lemma d_transitive: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y) \<Longrightarrow> (\<forall>y. |x\<rangle> y = |x\<^sup>\<star>\<rangle> |x\<rangle> y)"
proof -
  assume a: "\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
  {
    fix y
    have "|x\<rangle> y + |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
      by (simp add: a)
    hence "|x\<^sup>\<star>\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
      using local.dka.fd_def local.dka.fdia_star_induct_var by auto
    have "|x\<rangle> y \<le> |x\<^sup>\<star>\<rangle> |x\<rangle> y"
      using local.dka.fd_def local.order_prop opti_iterate by force
  }
  thus ?thesis
    using a local.antisym local.dka.fd_def local.dka.fdia_star_induct_var by auto
qed

lemma d_transitive_var: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y) \<Longrightarrow> (\<forall>y. |x\<rangle> y = |x\<rangle> |x\<^sup>\<star>\<rangle> y)"
proof -
  assume "\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
  then have "\<forall>a. |x\<rangle> |x\<^sup>\<star>\<rangle> a = |x\<rangle> a"
    by (metis (full_types) d_transitive local.dka.fd_def local.dka.fdia_d_simp local.star_slide_var mult_assoc)
  then show ?thesis
    by presburger
qed

lemma d_transitive_PreLoebian_imp_Loebian: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y) \<Longrightarrow> PreLoebian x \<Longrightarrow> Loebian x"
proof -
  assume wt: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y)"
  and "PreLoebian x"
  hence "\<forall>y. |x\<rangle> y \<le> |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y"
    using PreLoebian_def local.ads_d_def local.dka.fd_def local.ds.fd_iso1 by auto
  hence "\<forall>y. |x\<rangle> y \<le> |x\<rangle> \<Omega> x y"
    by (metis wt d_transitive_var)
  then show "Loebian x"
    using Loebian_def fdia_def by auto
qed

lemma d_transitive_Noetherian_iff_Loebian: "\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y \<Longrightarrow> Noetherian x \<longleftrightarrow> Loebian x"
  using Loebian_imp_Noetherian Noetherian_iff_PreLoebian d_transitive_PreLoebian_imp_Loebian by blast

lemma Loeb_iff_box_Loeb: "Loebian x \<longleftrightarrow> (\<forall>y. |x] (ad ( |x] y ) + d y) \<le> |x] y)"
proof -
  have "Loebian x \<longleftrightarrow> (\<forall>y. |x\<rangle> y \<le> |x\<rangle> (d y \<cdot> |x] (ad y)))"
    using Loebian_def omega_fbox by auto
  also have "... \<longleftrightarrow> (\<forall>y. ad ( |x\<rangle> (d y \<cdot> |x] (ad y)) ) \<le> ad ( |x\<rangle> y ))"
    using a_antitone' fdia_def by fastforce
  also have "... \<longleftrightarrow> (\<forall>y. |x] ad (d y \<cdot> |x] (ad y)) \<le> |x] (ad y))"
    by (simp add: fdia_fbox_de_morgan_2)
  also have "... \<longleftrightarrow> (\<forall>y. |x] (d (ad y) + ad ( |x] (ad y) )) \<le> |x] (ad y))"
    by (simp add: local.ads_d_def local.fbox_def)
  finally show ?thesis
    by (metis add_commute local.a_d_closed local.ads_d_def local.apd_d_def local.fbox_def)
qed

end

subsection \<open>Divergence Kleene Algebras and Separation of Termination\<close>

text \<open>The notion of divergence has been added to modal Kleene algebras in~\cite{DesharnaisMoellerStruthLMCS}.
More facts about divergence could be added in the future. Some could be adapted from omega algebras.\<close>

class nabla_op =
  fixes nabla :: "'a \<Rightarrow> 'a" ("\<nabla>_" [999] 1000)

class fdivergence_kleene_algebra = antidomain_kleene_algebra + nabla_op +
  assumes nabla_closure [simp]: "d \<nabla> x = \<nabla> x"
  and nabla_unfold: "\<nabla> x \<le> |x\<rangle> \<nabla> x"
  and nabla_coinduction: "d y \<le> |x\<rangle> y + d z \<Longrightarrow> d y \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> z"

begin

lemma nabla_coinduction_var: "d y \<le> |x\<rangle> y \<Longrightarrow> d y \<le> \<nabla> x"
proof -
  assume "d y \<le> |x\<rangle> y"
  hence "d y \<le> |x\<rangle> y + d 0"
    by simp
  hence "d y \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> 0"
    using nabla_coinduction by blast
  thus "d y \<le> \<nabla> x"
    by (simp add: fdia_def)
qed

lemma nabla_unfold_eq [simp]: "|x\<rangle> \<nabla> x = \<nabla> x"
proof -
  have f1: "ad (ad (x \<cdot> \<nabla>x)) = ad (ad (x \<cdot> \<nabla>x)) + \<nabla>x"
    using local.ds.fd_def local.join.sup.order_iff local.nabla_unfold by presburger
  then have "ad (ad (x \<cdot> \<nabla>x)) \<cdot> ad (ad \<nabla>x) = \<nabla>x"
    by (metis local.ads_d_def local.dpdz.dns5 local.dpdz.dsg4 local.join.sup_commute local.nabla_closure)
  then show ?thesis
    using f1 by (metis local.ads_d_def local.ds.fd_def local.ds.fd_subdist_2 local.join.sup.order_iff local.join.sup_commute nabla_coinduction_var)
qed

lemma nabla_subdist: "\<nabla> x \<le> \<nabla> (x + y)"
proof -
  have "d \<nabla> x \<le> \<nabla> (x + y)"
    by (metis local.ds.fd_iso2 local.join.sup.cobounded1 local.nabla_closure nabla_coinduction_var nabla_unfold_eq)
  thus ?thesis
    by simp
qed

lemma nabla_iso: "x \<le> y \<Longrightarrow> \<nabla> x \<le> \<nabla> y"
  by (metis less_eq_def nabla_subdist)

lemma nabla_omega: "\<Omega> x (d y) = 0 \<Longrightarrow> d y \<le> \<nabla> x"
  using omega_zero_equiv_1 nabla_coinduction_var by fastforce

lemma nabla_noether: "\<nabla> x = 0 \<Longrightarrow> Noetherian x"
  using local.join.le_bot local.noetherian_alt nabla_coinduction_var by blast

lemma nabla_preloeb: "\<nabla> x = 0 \<Longrightarrow> PreLoebian x"
  using Noetherian_iff_PreLoebian nabla_noether by auto

lemma star_nabla_1 [simp]: "|x\<^sup>\<star>\<rangle> \<nabla> x = \<nabla> x"
proof (rule antisym)
  show "|x\<^sup>\<star>\<rangle> \<nabla> x \<le> \<nabla> x"
    by (metis local.dka.fdia_star_induct_var local.eq_iff local.nabla_closure nabla_unfold_eq)
  show "\<nabla> x \<le> |x\<^sup>\<star>\<rangle> \<nabla> x"
    by (metis local.ds.fd_iso2 local.star_ext nabla_unfold_eq)
qed

lemma nabla_sum_expand [simp]: "|x\<rangle> \<nabla> (x + y) + |y\<rangle> \<nabla> (x + y) = \<nabla> (x + y)"
proof -
  have "d ((x + y) \<cdot> \<nabla>(x + y)) = \<nabla>(x + y)"
    using local.dka.fd_def nabla_unfold_eq by presburger
  thus ?thesis
    by (simp add: local.dka.fd_def)
qed

lemma wagner_3:
  assumes "d z + |x\<rangle> \<nabla> (x + y) = \<nabla> (x + y)"
  shows "\<nabla> (x + y) = \<nabla> x + |x\<^sup>\<star>\<rangle> z"
proof (rule antisym)
  have "d \<nabla>(x + y) \<le> d z + |x\<rangle> \<nabla>(x + y)"
    by (simp add: assms)
  thus "\<nabla> (x + y) \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> z"
    by (metis add_commute nabla_closure nabla_coinduction)
  have "d z + |x\<rangle> \<nabla> (x + y) \<le> \<nabla> (x + y)"
    using assms by auto
  hence "|x\<^sup>\<star>\<rangle> z \<le> \<nabla> (x + y)"
    by (metis local.dka.fdia_star_induct local.nabla_closure)
  thus "\<nabla> x + |x\<^sup>\<star>\<rangle> z \<le> \<nabla> (x + y)"
    by (simp add: sup_least nabla_subdist)
qed

lemma nabla_sum_unfold [simp]: "\<nabla> x + |x\<^sup>\<star>\<rangle> |y\<rangle> \<nabla> (x + y) = \<nabla> (x + y)"
proof -
  have "\<nabla> (x + y) = |x\<rangle> \<nabla> (x + y) + |y\<rangle> \<nabla> (x + y)"
    by simp
  thus ?thesis
    by (metis add_commute local.dka.fd_def local.ds.fd_def local.ds.fdia_d_simp wagner_3)
qed

lemma nabla_separation: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> \<Longrightarrow> (\<nabla> (x + y) = \<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y)"
proof (rule antisym)
  assume quasi_comm: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  hence a: "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    using quasicomm_var by blast
  have "\<nabla> (x + y) = \<nabla> y + |y\<^sup>\<star>\<cdot> x\<rangle> \<nabla> (x + y)"
    by (metis local.ds.fdia_mult local.join.sup_commute nabla_sum_unfold)
  also have "... \<le> \<nabla> y + |x \<cdot> (x + y)\<^sup>\<star>\<rangle> \<nabla> (x + y)"
    using a local.ds.fd_iso2 local.join.sup.mono by blast
  also have "... = \<nabla> y + |x\<rangle> |(x + y)\<^sup>\<star>\<rangle> \<nabla> (x + y)"
    by (simp add: fdia_def mult_assoc)
  finally have "\<nabla> (x + y) \<le> \<nabla> y + |x\<rangle> \<nabla> (x + y)"
    by (metis star_nabla_1)
  thus "\<nabla> (x + y) \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y"
    by (metis add_commute nabla_closure nabla_coinduction)
next
  have "\<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y = \<nabla> x + |x\<^sup>\<star>\<rangle> |y\<rangle> \<nabla> y"
    by simp
  also have "... = \<nabla> x + |x\<^sup>\<star> \<cdot> y\<rangle> \<nabla> y"
    by (simp add: fdia_def mult_assoc)
  also have "... \<le> \<nabla> x + |x\<^sup>\<star> \<cdot> y\<rangle> \<nabla> (x + y)"
    using dpdz.dom_iso eq_refl fdia_def join.sup_ge2 join.sup_mono mult_isol nabla_iso by presburger
  also have "... = \<nabla> x + |x\<^sup>\<star>\<rangle> |y\<rangle> \<nabla> (x + y)"
    by (simp add: fdia_def mult_assoc)
  finally show "\<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y \<le> \<nabla> (x + y)"
    by (metis nabla_sum_unfold)
qed

text \<open>The next lemma is a separation of termination theorem by Bachmair and Dershowitz~\cite{bachmair86commutation}.\<close>

lemma bachmair_dershowitz: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> \<Longrightarrow> \<nabla> x + \<nabla> y = 0 \<longleftrightarrow> \<nabla> (x + y) = 0"
proof -
  assume quasi_comm: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  have "\<forall>x. |x\<rangle> 0 = 0"
    by (simp add: fdia_def)
  hence "\<nabla>y = 0 \<Longrightarrow> \<nabla>x + \<nabla>y = 0 \<longleftrightarrow> \<nabla>(x + y) = 0"
    using quasi_comm nabla_separation by presburger
  thus ?thesis
    using add_commute local.join.le_bot nabla_subdist by fastforce
qed

text \<open>The next lemma is a more complex separation of termination theorem by Doornbos,
Backhouse and van der Woude~\cite{doornbos97calculational}.\<close>

lemma separation_of_termination:
assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> + y"
shows "\<nabla> x + \<nabla> y = 0 \<longleftrightarrow> \<nabla> (x + y) = 0"
proof
  assume xy_wf: "\<nabla> x + \<nabla> y = 0"
  hence x_preloeb: "\<nabla> (x + y) \<le> |x\<^sup>\<star>\<rangle> \<Omega> x (\<nabla> (x + y))"
    by (metis PreLoebian_def no_trivial_inverse nabla_closure nabla_preloeb)
  hence y_div: "\<nabla> y = 0"
    using add_commute no_trivial_inverse xy_wf by blast
  have "\<nabla> (x + y) \<le> |y\<rangle> \<nabla> (x + y) + |x\<rangle> \<nabla> (x + y)"
    by (simp add: local.join.sup_commute)
  hence "\<nabla> (x + y) \<cdot> ad ( |x\<rangle> \<nabla> (x + y) ) \<le> |y\<rangle> \<nabla>(x + y)"
    by (simp add: local.da_shunt1 local.dka.fd_def local.join.sup_commute)
  hence "\<Omega> x \<nabla>(x + y) \<le> |y\<rangle> \<nabla> (x + y)"
    by (simp add: fdia_def omega_fdia)
  also have "... \<le> |y\<rangle> |x\<^sup>\<star>\<rangle> (\<Omega> x \<nabla>(x + y))"
    using local.dpdz.dom_iso local.ds.fd_iso1 x_preloeb by blast
  also have "... = |y \<cdot> x\<^sup>\<star>\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: fdia_def mult_assoc)
  also have "... \<le> |x \<cdot> (x + y)\<^sup>\<star> + y\<rangle> (\<Omega> x \<nabla>(x + y))"
    using assms local.ds.fd_iso2 local.lazycomm_var by blast
  also have "... = |x \<cdot> (x + y)\<^sup>\<star>\<rangle> (\<Omega> x \<nabla>(x + y)) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: local.dka.fd_def)
  also have "... \<le> |(x \<cdot> (x + y)\<^sup>\<star>)\<rangle> \<nabla>(x + y) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    using local.add_iso local.dpdz.domain_1'' local.ds.fd_iso1 local.omega_fdia by auto
  also have "... \<le> |x\<rangle> |(x + y)\<^sup>\<star>\<rangle> \<nabla>(x + y) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: fdia_def mult_assoc)
  finally have "\<Omega> x \<nabla>(x + y) \<le> |x\<rangle> \<nabla>(x + y) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (metis star_nabla_1)
  hence "\<Omega> x \<nabla>(x + y) \<cdot> ad ( |x\<rangle> \<nabla>(x + y) ) \<le> |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: local.da_shunt1 local.dka.fd_def)
  hence "\<Omega> x \<nabla>(x + y) \<le> |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: omega_fdia mult_assoc)
  hence "(\<Omega> x \<nabla>(x + y)) = 0"
    by (metis noetherian_alt omega_dom nabla_noether y_div)
  thus "\<nabla> (x + y) = 0"
    using local.dka.fd_def local.join.le_bot x_preloeb by auto
next
  assume "\<nabla> (x + y) = 0"
  thus "(\<nabla> x) + (\<nabla> y) = 0"
    by (metis local.join.le_bot local.join.sup.order_iff local.join.sup_commute nabla_subdist)
qed

text \<open>The final examples can be found in~\cite{guttmannstruthweber11algmeth}.\<close>

definition T :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_ \<leadsto> _ \<leadsto> _" [61,61,61] 60)
  where "p\<leadsto>x\<leadsto>q \<equiv> ad p + |x] d q"

lemma T_d [simp]: "d (p\<leadsto>x\<leadsto>q) = p\<leadsto>x\<leadsto>q"
  using T_def local.a_d_add_closure local.fbox_def by auto

lemma T_p: "d p \<cdot> (p\<leadsto>x\<leadsto>q) = d p \<cdot> |x] d q"
proof -
  have "d p \<cdot> (p\<leadsto>x\<leadsto>q) = ad (ad p + ad (p\<leadsto>x\<leadsto>q))"
    using T_d local.ads_d_def by auto
  thus ?thesis
    using T_def add_commute local.a_mult_add local.ads_d_def by auto
qed

lemma T_a [simp]: "ad p \<cdot> (p\<leadsto>x\<leadsto>q) = ad p"
  by (metis T_d T_def local.a_d_closed local.ads_d_def local.apd_d_def local.dpdz.dns5 local.join.sup.left_idem)

lemma T_seq: "(p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>y\<leadsto>s) \<le> p\<leadsto>x \<cdot> y\<leadsto>s"
proof -
  have f1: "|x] q = |x] d q"
    using local.fbox_simp by auto
  have "ad p \<cdot> ad (x \<cdot> ad (q\<leadsto>y\<leadsto>s)) + |x] d q \<cdot> |x] (ad q + |y] d s) \<le> ad p + |x] d q \<cdot> |x] (ad q + |y] d s)"
    using local.a_subid_aux2 local.add_iso by blast
  hence "(p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>y\<leadsto>s) \<le> ad p + |x](d q \<cdot> (q\<leadsto>y\<leadsto>s))"
    by (metis T_d T_def f1 local.distrib_right' local.fbox_add1 local.fbox_def)
  also have "... = ad p + |x](d q \<cdot> (ad q + |y] d s))"
    by (simp add: T_def)
  also have "... = ad p + |x](d q \<cdot> |y] d s)"
    using T_def T_p by auto
  also have "... \<le> ad p + |x] |y] d s"
    by (metis (no_types, lifting) local.dka.dom_subid_aux2 local.dka.dsg3 local.eq_iff local.fbox_iso local.join.sup.mono)
  finally show ?thesis
    by (simp add: T_def fbox_mult)
qed

lemma T_square: "(p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<le> p\<leadsto>x\<cdot>x\<leadsto>p"
  by (simp add: T_seq)

lemma T_segerberg [simp]: "d p \<cdot> |x\<^sup>\<star>](p\<leadsto>x\<leadsto>p) = |x\<^sup>\<star>] d p"
  using T_def add_commute local.fbox_segerberg local.fbox_simp by force

lemma lookahead [simp]: "|x\<^sup>\<star>](d p \<cdot> |x] d p) = |x\<^sup>\<star>] d p"
  by (metis (full_types) local.dka.dsg3 local.fbox_add1 local.fbox_mult local.fbox_simp local.fbox_star_unfold_var local.star_slide_var local.star_trans_eq)

lemma alternation: "d p \<cdot> |x\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |x\<cdot>(x\<cdot>x)\<^sup>\<star>](d q \<cdot> (p\<leadsto>x\<leadsto>q))"
proof -
  have fbox_simp_2: "\<And>x p. |x]p = d( |x] p )"
    using local.a_d_closed local.ads_d_def local.apd_d_def local.fbox_def by fastforce
  have "|(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q)) \<le> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p))"
    using local.dka.domain_1'' local.fbox_iso local.order_trans by blast
  also have "... \<le> |(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p)"
    using T_seq local.dka.dom_iso local.fbox_iso by blast
  finally have 1: "|(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q)) \<le> |(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p)".
  have "d p \<cdot> |x\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) = d p \<cdot> |1+x] |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    by (metis (full_types) fbox_mult meyer_1)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |x\<cdot>(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    using fbox_simp_2 fbox_mult fbox_add2 mult_assoc by auto
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |(x\<cdot>x)\<^sup>\<star>\<cdot>x]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    by (simp add: star_slide)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |(x\<cdot>x)\<^sup>\<star>] |x]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    by (simp add: fbox_mult)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)))"
    by (metis T_d fbox_simp_2 local.dka.dom_mult_closed local.fbox_add1 mult_assoc)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
  proof -
    have f1: "d ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)) = (q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)"
      by (metis (full_types) T_d fbox_simp_2 local.dka.dsg3)
    then have "|(x \<cdot> x)\<^sup>\<star>] (d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))) = |(x \<cdot> x)\<^sup>\<star>] d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> |(x \<cdot> x)\<^sup>\<star>] ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))"
      by (metis (full_types) fbox_simp_2 local.fbox_add1)
    then have f2: "|(x \<cdot> x)\<^sup>\<star>] (d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))) = ad ((x \<cdot> x)\<^sup>\<star> \<cdot> ad ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)) + (x \<cdot> x)\<^sup>\<star> \<cdot> ad (d ( |x] (q \<leadsto> x \<leadsto> p))))"
      by (simp add: add_commute local.fbox_def)
    have "d ( |x] (p \<leadsto> x \<leadsto> q)) \<cdot> d ( |x] (q \<leadsto> x \<leadsto> p)) = |x] ((p \<leadsto> x \<leadsto> q) \<cdot> (q \<leadsto> x \<leadsto> p))"
      by (metis (no_types) T_d fbox_simp_2 local.fbox_add1)
    then have "d ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)) \<cdot> d (d ( |x] (q \<leadsto> x \<leadsto> p))) = (q \<leadsto> x \<leadsto> p) \<cdot> |x] ((p \<leadsto> x \<leadsto> q) \<cdot> (q \<leadsto> x \<leadsto> p))"
      using f1 fbox_simp_2 mult_assoc by force
    then have "|(x \<cdot> x)\<^sup>\<star>] (d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))) = |(x \<cdot> x)\<^sup>\<star>] ((q \<leadsto> x \<leadsto> p) \<cdot> |x] ((p \<leadsto> x \<leadsto> q) \<cdot> (q \<leadsto> x \<leadsto> p)))"
      using f2 by (metis (no_types) local.ans4 local.fbox_add1 local.fbox_def)
    then show ?thesis
      by (metis (no_types) T_d fbox_simp_2 local.dka.dsg3 local.fbox_add1 mult_assoc)
  qed
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p) \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))" using "1"
    by (metis fbox_simp_2 local.dka.dns5 local.dka.dsg4 local.join.sup.absorb2 mult_assoc)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> (p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
    using T_segerberg local.a_d_closed local.ads_d_def local.apd_d_def local.distrib_left local.fbox_def mult_assoc by auto
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x] d q \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
    by (simp add: T_p)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x] d q \<cdot> |x] |x] d p \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
    by (metis T_d T_p fbox_simp_2 fbox_add1 fbox_simp mult_assoc)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x\<cdot>x] d p \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x] d q \<cdot> |x](p\<leadsto>x\<leadsto>q))"
  proof -
    have f1: "ad (x \<cdot> ad ( |x] d p)) = |x \<cdot> x] d p"
      using local.fbox_def local.fbox_mult by presburger
    have f2: "ad (d q \<cdot> d (x \<cdot> ad (d p))) = q \<leadsto> x \<leadsto> p"
      by (simp add: T_def local.a_de_morgan_var_4 local.fbox_def)
    have "ad q + |x] d p = ad (d q \<cdot> d (x \<cdot> ad (d p)))"
      by (simp add: local.a_de_morgan_var_4 local.fbox_def)
    then have "ad (x \<cdot> ad ( |x] d p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] d q) = ad (x \<cdot> ad ( |x] d p)) \<cdot> ad (x \<cdot> ad (d q)) \<cdot> (ad q + |x] d p)"
      using f2 by (metis (no_types) local.am2 local.fbox_def mult_assoc)
    then show ?thesis
      using f1 by (simp add: T_def local.am2 local.fbox_def mult_assoc)
  qed
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x\<cdot>x] d p \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](d q \<cdot> (p\<leadsto>x\<leadsto>q)))"
    using local.a_d_closed local.ads_d_def local.apd_d_def local.distrib_left local.fbox_def mult_assoc by auto
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x\<cdot>x] d p) \<cdot> |(x\<cdot>x)\<^sup>\<star>](q\<leadsto>x\<leadsto>p) \<cdot> |(x\<cdot>x)\<^sup>\<star>] |x](d q \<cdot> (p\<leadsto>x\<leadsto>q))"
    by (metis T_d fbox_simp_2 local.dka.dom_mult_closed local.fbox_add1)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |(x\<cdot>x)\<^sup>\<star>] |x] (d q \<cdot> (p\<leadsto>x\<leadsto>q))"
    by (metis T_d local.fbox_add1 local.fbox_simp lookahead)
  finally show ?thesis
    by (metis fbox_mult star_slide)
qed

lemma "|(x\<cdot>x)\<^sup>\<star>] d p \<cdot> |x\<cdot>(x\<cdot>x)\<^sup>\<star>] ad p = d p \<cdot> |x\<^sup>\<star>]((p\<leadsto>x\<leadsto>ad p) \<cdot> (ad p\<leadsto>x\<leadsto>p))"
  using alternation local.a_d_closed local.ads_d_def local.apd_d_def by auto

lemma "|x\<^sup>\<star>] d p = d p \<cdot> |x\<^sup>\<star>](p\<leadsto>x\<leadsto>p)"
  by (simp add: alternation)

end

end


(*  Title:      ZF/UNITY/AllocBase.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section\<open>Common declarations for Chandy and Charpentier's Allocator\<close>

theory AllocBase imports Follows MultisetSum Guar begin

abbreviation (input)
  tokbag   :: i  (* tokbags could be multisets...or any ordered type?*)
where
  "tokbag == nat"

axiomatization
  NbT :: i and  (* Number of tokens in system *)
  Nclients :: i  (* Number of clients *)
where
  NbT_pos: "NbT \<in> nat-{0}" and
  Nclients_pos: "Nclients \<in> nat-{0}"

text\<open>This function merely sums the elements of a list\<close>
consts tokens :: "i =>i"
       item :: i (* Items to be merged/distributed *)
primrec
  "tokens(Nil) = 0"
  "tokens (Cons(x,xs)) = x #+ tokens(xs)"

consts bag_of :: "i => i"
primrec
  "bag_of(Nil)    = 0"
  "bag_of(Cons(x,xs)) = {#x#} +# bag_of(xs)"

text\<open>Definitions needed in Client.thy.  We define a recursive predicate
using 0 and 1 to code the truth values.\<close>
consts all_distinct0 :: "i=>i"
primrec
  "all_distinct0(Nil) = 1"
  "all_distinct0(Cons(a, l)) =
     (if a \<in> set_of_list(l) then 0 else all_distinct0(l))"

definition
  all_distinct  :: "i=>o"  where
   "all_distinct(l) == all_distinct0(l)=1"

definition
  state_of :: "i =>i" \<comment> \<open>coersion from anyting to state\<close>  where
   "state_of(s) == if s \<in> state then s else st0"

definition
  lift :: "i =>(i=>i)" \<comment> \<open>simplifies the expression of programs\<close>  where
   "lift(x) == %s. s`x"

text\<open>function to show that the set of variables is infinite\<close>
consts
  nat_list_inj :: "i=>i"
  var_inj      :: "i=>i"

primrec
  "nat_list_inj(0) = Nil"
  "nat_list_inj(succ(n)) = Cons(n, nat_list_inj(n))"

primrec
  "var_inj(Var(l)) = length(l)"

definition
  nat_var_inj  :: "i=>i"  where
  "nat_var_inj(n) == Var(nat_list_inj(n))"

subsection\<open>Various simple lemmas\<close>

lemma Nclients_NbT_gt_0 [simp]: "0 < Nclients & 0 < NbT"
apply (cut_tac Nclients_pos NbT_pos)
apply (auto intro: Ord_0_lt)
done

lemma Nclients_NbT_not_0 [simp]: "Nclients \<noteq> 0 & NbT \<noteq> 0"
by (cut_tac Nclients_pos NbT_pos, auto)

lemma Nclients_type [simp,TC]: "Nclients\<in>nat"
by (cut_tac Nclients_pos NbT_pos, auto)

lemma NbT_type [simp,TC]: "NbT\<in>nat"
by (cut_tac Nclients_pos NbT_pos, auto)

lemma INT_Nclient_iff [iff]:
     "b\<in>\<Inter>(RepFun(Nclients, B)) \<longleftrightarrow> (\<forall>x\<in>Nclients. b\<in>B(x))"
by (force simp add: INT_iff)

lemma setsum_fun_mono [rule_format]:
     "n\<in>nat ==>
      (\<forall>i\<in>nat. i<n \<longrightarrow> f(i) $\<le> g(i)) \<longrightarrow>
      setsum(f, n) $\<le> setsum(g,n)"
apply (induct_tac "n", simp_all)
apply (subgoal_tac "Finite(x) & x\<notin>x")
 prefer 2 apply (simp add: nat_into_Finite mem_not_refl, clarify)
apply (simp (no_asm_simp) add: succ_def)
apply (subgoal_tac "\<forall>i\<in>nat. i<x\<longrightarrow> f(i) $\<le> g(i) ")
 prefer 2 apply (force dest: leI)
apply (rule zadd_zle_mono, simp_all)
done

lemma tokens_type [simp,TC]: "l\<in>list(A) ==> tokens(l)\<in>nat"
by (erule list.induct, auto)

lemma tokens_mono_aux [rule_format]:
     "xs\<in>list(A) ==> \<forall>ys\<in>list(A). <xs, ys>\<in>prefix(A)
   \<longrightarrow> tokens(xs) \<le> tokens(ys)"
apply (induct_tac "xs")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD] simp add: prefix_def)
done

lemma tokens_mono: "<xs, ys>\<in>prefix(A) ==> tokens(xs) \<le> tokens(ys)"
apply (cut_tac prefix_type)
apply (blast intro: tokens_mono_aux)
done

lemma mono_tokens [iff]: "mono1(list(A), prefix(A), nat, Le,tokens)"
apply (unfold mono1_def)
apply (auto intro: tokens_mono simp add: Le_def)
done

lemma tokens_append [simp]:
"[| xs\<in>list(A); ys\<in>list(A) |] ==> tokens(xs@ys) = tokens(xs) #+ tokens(ys)"
apply (induct_tac "xs", auto)
done

subsection\<open>The function \<^term>\<open>bag_of\<close>\<close>

lemma bag_of_type [simp,TC]: "l\<in>list(A) ==>bag_of(l)\<in>Mult(A)"
apply (induct_tac "l")
apply (auto simp add: Mult_iff_multiset)
done

lemma bag_of_multiset:
     "l\<in>list(A) ==> multiset(bag_of(l)) & mset_of(bag_of(l))<=A"
apply (drule bag_of_type)
apply (auto simp add: Mult_iff_multiset)
done

lemma bag_of_append [simp]:
    "[| xs\<in>list(A); ys\<in>list(A)|] ==> bag_of(xs@ys) = bag_of(xs) +# bag_of(ys)"
apply (induct_tac "xs")
apply (auto simp add: bag_of_multiset munion_assoc)
done

lemma bag_of_mono_aux [rule_format]:
     "xs\<in>list(A) ==> \<forall>ys\<in>list(A). <xs, ys>\<in>prefix(A)
      \<longrightarrow> <bag_of(xs), bag_of(ys)>\<in>MultLe(A, r)"
apply (induct_tac "xs", simp_all, clarify)
apply (frule_tac l = ys in bag_of_multiset)
apply (auto intro: empty_le_MultLe simp add: prefix_def)
apply (rule munion_mono)
apply (force simp add: MultLe_def Mult_iff_multiset)
apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
done

lemma bag_of_mono [intro]:
     "[|  <xs, ys>\<in>prefix(A); xs\<in>list(A); ys\<in>list(A) |]
      ==> <bag_of(xs), bag_of(ys)>\<in>MultLe(A, r)"
apply (blast intro: bag_of_mono_aux)
done

lemma mono_bag_of [simp]:
     "mono1(list(A), prefix(A), Mult(A), MultLe(A,r), bag_of)"
by (auto simp add:  mono1_def bag_of_type)

subsection\<open>The function \<^term>\<open>msetsum\<close>\<close>

lemmas nat_into_Fin = eqpoll_refl [THEN [2] Fin_lemma]

lemma list_Int_length_Fin: "l \<in> list(A) ==> C \<inter> length(l) \<in> Fin(length(l))"
apply (drule length_type)
apply (rule Fin_subset)
apply (rule Int_lower2)
apply (erule nat_into_Fin)
done

lemma mem_Int_imp_lt_length:
     "[|xs \<in> list(A); k \<in> C \<inter> length(xs)|] ==> k < length(xs)"
by (simp add: ltI)

lemma Int_succ_right:
     "A \<inter> succ(k) = (if k \<in> A then cons(k, A \<inter> k) else A \<inter> k)"
by auto

lemma bag_of_sublist_lemma:
     "[|C \<subseteq> nat; x \<in> A; xs \<in> list(A)|]
  ==>  msetsum(\<lambda>i. {#nth(i, xs @ [x])#}, C \<inter> succ(length(xs)), A) =
       (if length(xs) \<in> C then
          {#x#} +# msetsum(\<lambda>x. {#nth(x, xs)#}, C \<inter> length(xs), A)
        else msetsum(\<lambda>x. {#nth(x, xs)#}, C \<inter> length(xs), A))"
apply (simp add: subsetD nth_append lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong)
apply (simp add: Int_succ_right)
apply (simp add: lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong, clarify)
apply (subst msetsum_cons)
apply (rule_tac [3] succI1)
apply (blast intro: list_Int_length_Fin subset_succI [THEN Fin_mono, THEN subsetD])
apply (simp add: mem_not_refl)
apply (simp add: nth_type lt_not_refl)
apply (blast intro: nat_into_Ord ltI length_type)
apply (simp add: lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong)
done

lemma bag_of_sublist_lemma2:
     "l\<in>list(A) ==>
  C \<subseteq> nat ==>
  bag_of(sublist(l, C)) =
      msetsum(%i. {#nth(i, l)#}, C \<inter> length(l), A)"
apply (erule list_append_induct)
apply (simp (no_asm))
apply (simp (no_asm_simp) add: sublist_append nth_append bag_of_sublist_lemma munion_commute bag_of_sublist_lemma msetsum_multiset munion_0)
done

lemma nat_Int_length_eq: "l \<in> list(A) ==> nat \<inter> length(l) = length(l)"
apply (rule Int_absorb1)
apply (rule OrdmemD, auto)
done

(*eliminating the assumption C<=nat*)
lemma bag_of_sublist:
     "l\<in>list(A) ==>
  bag_of(sublist(l, C)) = msetsum(%i. {#nth(i, l)#}, C \<inter> length(l), A)"
apply (subgoal_tac " bag_of (sublist (l, C \<inter> nat)) = msetsum (%i. {#nth (i, l) #}, C \<inter> length (l), A) ")
apply (simp add: sublist_Int_eq)
apply (simp add: bag_of_sublist_lemma2 Int_lower2 Int_assoc nat_Int_length_eq)
done

lemma bag_of_sublist_Un_Int:
"l\<in>list(A) ==>
  bag_of(sublist(l, B \<union> C)) +# bag_of(sublist(l, B \<inter> C)) =
      bag_of(sublist(l, B)) +# bag_of(sublist(l, C))"
apply (subgoal_tac "B \<inter> C \<inter> length (l) = (B \<inter> length (l)) \<inter> (C \<inter> length (l))")
prefer 2 apply blast
apply (simp (no_asm_simp) add: bag_of_sublist Int_Un_distrib2 msetsum_Un_Int)
apply (rule msetsum_Un_Int)
apply (erule list_Int_length_Fin)+
 apply (simp add: ltI nth_type)
done

lemma bag_of_sublist_Un_disjoint:
     "[| l\<in>list(A); B \<inter> C = 0  |]
      ==> bag_of(sublist(l, B \<union> C)) =
          bag_of(sublist(l, B)) +# bag_of(sublist(l, C))"
by (simp add: bag_of_sublist_Un_Int [symmetric] bag_of_multiset)

lemma bag_of_sublist_UN_disjoint [rule_format]:
     "[|Finite(I); \<forall>i\<in>I. \<forall>j\<in>I. i\<noteq>j \<longrightarrow> A(i) \<inter> A(j) = 0;
        l\<in>list(B) |]
      ==> bag_of(sublist(l, \<Union>i\<in>I. A(i))) =
          (msetsum(%i. bag_of(sublist(l, A(i))), I, B)) "
apply (simp (no_asm_simp) del: UN_simps
           add: UN_simps [symmetric] bag_of_sublist)
apply (subst  msetsum_UN_disjoint [of _ _ _ "length (l)"])
apply (drule Finite_into_Fin, assumption)
prefer 3 apply force
apply (auto intro!: Fin_IntI2 Finite_into_Fin simp add: ltI nth_type length_type nat_into_Finite)
done

lemma part_ord_Lt [simp]: "part_ord(nat, Lt)"
apply (unfold part_ord_def Lt_def irrefl_def trans_on_def)
apply (auto intro: lt_trans)
done

subsubsection\<open>The function \<^term>\<open>all_distinct\<close>\<close>

lemma all_distinct_Nil [simp]: "all_distinct(Nil)"
by (unfold all_distinct_def, auto)

lemma all_distinct_Cons [simp]:
    "all_distinct(Cons(a,l)) \<longleftrightarrow>
      (a\<in>set_of_list(l) \<longrightarrow> False) & (a \<notin> set_of_list(l) \<longrightarrow> all_distinct(l))"
apply (unfold all_distinct_def)
apply (auto elim: list.cases)
done

subsubsection\<open>The function \<^term>\<open>state_of\<close>\<close>

lemma state_of_state: "s\<in>state ==> state_of(s)=s"
by (unfold state_of_def, auto)
declare state_of_state [simp]

lemma state_of_idem: "state_of(state_of(s))=state_of(s)"

apply (unfold state_of_def, auto)
done
declare state_of_idem [simp]

lemma state_of_type [simp,TC]: "state_of(s)\<in>state"
by (unfold state_of_def, auto)

lemma lift_apply [simp]: "lift(x, s)=s`x"
by (simp add: lift_def)

(** Used in ClientImp **)

lemma gen_Increains_state_of_eq:
     "Increasing(A, r, %s. f(state_of(s))) = Increasing(A, r, f)"
apply (unfold Increasing_def, auto)
done

lemmas Increasing_state_ofD1 =
      gen_Increains_state_of_eq [THEN equalityD1, THEN subsetD]
lemmas Increasing_state_ofD2 =
      gen_Increains_state_of_eq [THEN equalityD2, THEN subsetD]

lemma Follows_state_of_eq:
     "Follows(A, r, %s. f(state_of(s)), %s. g(state_of(s))) =
      Follows(A, r, f, g)"
apply (unfold Follows_def Increasing_def, auto)
done

lemmas Follows_state_ofD1 =
      Follows_state_of_eq [THEN equalityD1, THEN subsetD]
lemmas Follows_state_ofD2 =
      Follows_state_of_eq [THEN equalityD2, THEN subsetD]

lemma nat_list_inj_type: "n\<in>nat ==> nat_list_inj(n)\<in>list(nat)"
by (induct_tac "n", auto)

lemma length_nat_list_inj: "n\<in>nat ==> length(nat_list_inj(n)) = n"
by (induct_tac "n", auto)

lemma var_infinite_lemma:
  "(\<lambda>x\<in>nat. nat_var_inj(x))\<in>inj(nat, var)"
apply (unfold nat_var_inj_def)
apply (rule_tac d = var_inj in lam_injective)
apply (auto simp add: var.intros nat_list_inj_type)
apply (simp add: length_nat_list_inj)
done

lemma nat_lepoll_var: "nat \<lesssim> var"
apply (unfold lepoll_def)
apply (rule_tac x = " (\<lambda>x\<in>nat. nat_var_inj (x))" in exI)
apply (rule var_infinite_lemma)
done

lemma var_not_Finite: "~Finite(var)"
apply (insert nat_not_Finite)
apply (blast intro: lepoll_Finite [OF nat_lepoll_var])
done

lemma not_Finite_imp_exist: "~Finite(A) ==> \<exists>x. x\<in>A"
apply (subgoal_tac "A\<noteq>0")
apply (auto simp add: Finite_0)
done

lemma Inter_Diff_var_iff:
     "Finite(A) ==> b\<in>(\<Inter>(RepFun(var-A, B))) \<longleftrightarrow> (\<forall>x\<in>var-A. b\<in>B(x))"
apply (subgoal_tac "\<exists>x. x\<in>var-A", auto)
apply (subgoal_tac "~Finite (var-A) ")
apply (drule not_Finite_imp_exist, auto)
apply (cut_tac var_not_Finite)
apply (erule swap)
apply (rule_tac B = A in Diff_Finite, auto)
done

lemma Inter_var_DiffD:
     "[| b\<in>\<Inter>(RepFun(var-A, B)); Finite(A); x\<in>var-A |] ==> b\<in>B(x)"
by (simp add: Inter_Diff_var_iff)

(* [| Finite(A); (\<forall>x\<in>var-A. b\<in>B(x)) |] ==> b\<in>\<Inter>(RepFun(var-A, B)) *)
lemmas Inter_var_DiffI = Inter_Diff_var_iff [THEN iffD2]

declare Inter_var_DiffI [intro!]

lemma Acts_subset_Int_Pow_simp [simp]:
     "Acts(F)<= A \<inter> Pow(state*state)  \<longleftrightarrow> Acts(F)<=A"
by (insert Acts_type [of F], auto)

lemma setsum_nsetsum_eq:
     "[| Finite(A); \<forall>x\<in>A. g(x)\<in>nat |]
      ==> setsum(%x. $#(g(x)), A) = $# nsetsum(%x. g(x), A)"
apply (erule Finite_induct)
apply (auto simp add: int_of_add)
done

lemma nsetsum_cong:
     "[| A=B;  \<forall>x\<in>A. f(x)=g(x);  \<forall>x\<in>A. g(x)\<in>nat;  Finite(A) |]
      ==> nsetsum(f, A) = nsetsum(g, B)"
apply (subgoal_tac "$# nsetsum (f, A) = $# nsetsum (g, B)", simp)
apply (simp add: setsum_nsetsum_eq [symmetric] cong: setsum_cong)
done

end


theory padic_int_polynomials
imports padic_int_topology domain_poly
begin

context padic_int_polynomial
begin

type_synonym padic_int_poly = "nat \<Rightarrow> padic_int"

lemma monom_term_car:
  assumes "c \<in> carrier Z\<^sub>p"
  assumes "x \<in> carrier Z\<^sub>p"
  shows "c \<otimes> x[^](n::nat) \<in> carrier Z\<^sub>p"
  using assms Zp_is_cring monoid.nat_pow_closed
  by (simp add: monoid.nat_pow_closed cring.cring_simprules(5) cring_def ring_def)

(*Univariate polynomial ring over Z\<^sub>p*)

abbreviation Z\<^sub>p_x where
"Z\<^sub>p_x \<equiv> UP Z\<^sub>p"

lemma Z\<^sub>p_x_is_UP_ring[simp]:
"UP_ring Z\<^sub>p"
  by (metis UP_ring.intro Zp_is_cring cring_def)

lemma Z\<^sub>p_x_is_UP_cring[simp]:
"UP_cring Z\<^sub>p"
  by (simp add: UP_cring_def)

lemma Z\<^sub>p_x_is_UP_domain[simp]:
"UP_domain Z\<^sub>p"
  by (simp add: UP_domain_def)

lemma Z\<^sub>p_x_ring[simp]:
"ring Z\<^sub>p_x "
  by (simp add: UP_ring.UP_ring)

lemma Z\<^sub>p_x_cring[simp]:
"cring Z\<^sub>p_x "
  by (simp add: UP_cring.UP_cring)

lemma Z\<^sub>p_x_domain[simp]:
"domain Z\<^sub>p_x "
  by (simp add: UP_domain.UP_domain)

(*Basic simp rules to streaminline computation*)
lemma pow_closedP[simp]:
  assumes "f \<in> carrier Z\<^sub>p_x"
  shows "f[^]\<^bsub>Z\<^sub>p_x\<^esub>(n::nat) \<in> carrier Z\<^sub>p_x "
  by (meson Z\<^sub>p_x_ring assms monoid.nat_pow_closed ring_def)

lemma pow_closed[simp]:
  assumes "a \<in> carrier Z\<^sub>p"
  shows "a[^](n::nat) \<in> carrier Z\<^sub>p"
  by (meson Zp_is_domain domain_def cring_def assms monoid.nat_pow_closed ring_def)

lemma(in ring) pow_zero[simp]:
  assumes "(n::nat)>0"
  shows "\<zero>[^] n = \<zero>"
  by (simp add: assms nat_pow_zero)

lemma pow_zero[simp]:
  assumes "(n::nat)>0"
  shows "\<zero>[^] n = \<zero>"
  using Zp_is_cring
  unfolding cring_def
  using ring.pow_zero
        assms
  by blast

lemma pow_zeroP[simp]:
  assumes "n >0"
  shows "\<zero>\<^bsub>Z\<^sub>p_x\<^esub>[^]\<^bsub>Z\<^sub>p_x\<^esub>(n::nat) = \<zero>\<^bsub>Z\<^sub>p_x\<^esub>"
  using assms ring.pow_zero[of Z\<^sub>p_x] by simp

lemma sum_closedP[simp]:
  assumes "f \<in> carrier Z\<^sub>p_x"
  assumes "g \<in> carrier Z\<^sub>p_x"
  shows "f \<oplus>\<^bsub>Z\<^sub>p_x\<^esub>g \<in>  carrier Z\<^sub>p_x"
  by (simp add: assms(1) assms(2) cring.cring_simprules(1))

lemma sum_closed[simp]:
  assumes "f \<in> carrier Z\<^sub>p"
  assumes "g \<in> carrier Z\<^sub>p"
  shows "f \<oplus> g \<in>  carrier Z\<^sub>p"
  by (simp add: assms(1) assms(2) cring.cring_simprules(1))

lemma mult_zero[simp]:
  assumes "f \<in> carrier Z\<^sub>p"
  shows "f \<otimes> \<zero> = \<zero>"
        "\<zero> \<otimes> f = \<zero>"
   apply (simp add: assms cring.cring_simprules(27))
   apply (simp add: assms cring.cring_simprules(26))
  done

lemma mult_zeroP[simp]:
  assumes "f \<in> carrier Z\<^sub>p_x"
  shows "f \<otimes>\<^bsub>Z\<^sub>p_x\<^esub> \<zero>\<^bsub>Z\<^sub>p_x\<^esub> = \<zero>\<^bsub>Z\<^sub>p_x\<^esub>"
        "\<zero>\<^bsub>Z\<^sub>p_x\<^esub> \<otimes>\<^bsub>Z\<^sub>p_x\<^esub> f = \<zero>\<^bsub>Z\<^sub>p_x\<^esub>"
  apply (simp add: assms cring.cring_simprules(27))
  apply (simp add: assms cring.cring_simprules(26))
  done

lemma add_zero[simp]:
  assumes "f \<in> carrier Z\<^sub>p"
  shows "f \<oplus> \<zero> = f"
        "\<zero> \<oplus> f = f"
   apply (simp add: assms cring.cring_simprules)
   apply (simp add: assms cring.cring_simprules)
   done

lemma add_zeroP[simp]:
  assumes "f \<in> carrier Z\<^sub>p_x "
  shows "f \<oplus>\<^bsub>Z\<^sub>p_x\<^esub> \<zero>\<^bsub>Z\<^sub>p_x\<^esub> = f"
        "\<zero>\<^bsub>Z\<^sub>p_x\<^esub> \<oplus>\<^bsub>Z\<^sub>p_x\<^esub> f = f"
   apply (simp add: assms cring.cring_simprules)
   apply (simp add: assms cring.cring_simprules)
   done

(*Degree function*)
abbreviation degree:: "padic_int_poly \<Rightarrow> nat" where
"degree f \<equiv>  deg Z\<^sub>p f"

(*Coefficient function*)
abbreviation cf :: "padic_int_poly \<Rightarrow> nat \<Rightarrow> padic_int" where
"cf  \<equiv> coeff (UP Z\<^sub>p)"

(*Leading term function*)
abbreviation lt  where
"lt \<equiv> leading_term Z\<^sub>p"

(*Leading coefficient function*)
abbreviation lc where
"lc \<equiv> leading_coefficient Z\<^sub>p"

(*Truncation function, which sends a polynomial f \<Longrightarrow> (f - leading_term (f)), which has strictly
smaller degree in the case where degree f > 0*)
abbreviation trunc where
"trunc \<equiv> truncate Z\<^sub>p"

(*Turning a padic polynomial into a function on Z\<^sub>p*)
abbreviation fun_of :: "_ \<Rightarrow> padic_int_fun" (infixl "\<^emph>" 70) where
"fun_of f a \<equiv> function_of Z\<^sub>p f a"

(*predicate for monomial polynomials*)
abbreviation is_monom where
"is_monom \<equiv> is_monom_poly Z\<^sub>p"

(*technical lemmas for reasoning about fun_of*)
lemma id_is_hom:
"ring_hom_cring Z\<^sub>p Z\<^sub>p (\<lambda>x. x)"
proof(rule ring_hom_cringI)
  show "cring Z\<^sub>p"
    using Zp_is_cring by auto
  show "cring Z\<^sub>p"
    using Zp_is_cring by auto
  show "(\<lambda>x. x) \<in> ring_hom Z\<^sub>p Z\<^sub>p"
    unfolding ring_hom_def
    apply(auto)
    done
qed

lemma UP_pre_univ_prop_fact:
"UP_pre_univ_prop Z\<^sub>p Z\<^sub>p (\<lambda>x. x)"
  unfolding UP_pre_univ_prop_def
  by (simp add: UP_cring_def  id_is_hom)

(*Z\<^sub>p_x addition commutes with evaluation addition*)
lemma fun_of_fun_sum:
  assumes "f \<in> carrier Z\<^sub>p_x"
  assumes "g \<in> carrier Z\<^sub>p_x"
  assumes "h = f \<oplus>\<^bsub>Z\<^sub>p_x\<^esub> g"
  shows "fun_sum (fun_of f) (fun_of g) \<doteq> fun_of h"
  unfolding eq_on_Zp_def
  apply(auto)
proof-
  fix x
  assume A: "x \<in> carrier Z\<^sub>p"
  show "fun_sum (fun_of f) (fun_of g) x = fun_of h x "
    unfolding fun_sum_def
    unfolding function_of_def
  proof-
    have "(eval Z\<^sub>p Z\<^sub>p (\<lambda>x. x)) x \<in> (ring_hom Z\<^sub>p_x Z\<^sub>p)"
      using UP_pre_univ_prop_fact A UP_pre_univ_prop.eval_ring_hom[of Z\<^sub>p Z\<^sub>p "(\<lambda>x. x)" x]    by auto
    then show "eval Z\<^sub>p Z\<^sub>p (\<lambda>x. x) x f \<oplus> eval Z\<^sub>p Z\<^sub>p (\<lambda>x. x) x g = eval Z\<^sub>p Z\<^sub>p (\<lambda>x. x) x h "
      using assms ring_hom_add   by (simp add: \<open>f \<in> carrier Z\<^sub>p_x\<close> ring_hom_def)
  qed
qed

(*monomial functions are monomials*)
lemma fun_of_monom_is_monom0:
  assumes "c \<in> carrier Z\<^sub>p"
  assumes "c \<noteq>\<zero>"
  assumes "f = monom Z\<^sub>p_x c n"
  assumes "x \<in> carrier Z\<^sub>p"
  shows "f\<^emph>x = mon c n x"
proof-
  have 1: "f\<^emph>x = c \<otimes> x [^] n"
    using UP_domain.fun_of_monom assms Z\<^sub>p_x_is_UP_domain
    by (simp add: UP_domain.fun_of_monom)
  show ?thesis
    unfolding mon_def scalar_mult_def X_pow_Zp_def
    apply auto
     apply (metis "1" Zp_is_cring cring.axioms(1) monoid.nat_pow_0 ring_def)
    using 1  by simp
qed

lemma fun_of_monom_is_monom:
  assumes "c \<in> carrier Z\<^sub>p"
  assumes "f = monom Z\<^sub>p_x c n"
  shows "fun_of f \<doteq> mon c n"
proof(cases "c = \<zero>")
  case True
  have H: "f = (\<lambda> i. \<zero>)"
    apply(auto simp: assms(2))
    apply(auto simp:True)
  proof-
    have A: "\<zero> \<in> carrier Z\<^sub>p"
      using True assms(1) by auto
    then have "monom  (UP Z\<^sub>p) = (\<lambda>a\<in>carrier Z\<^sub>p. (\<lambda>n i. if i = n then a else \<zero>)) "
      by(simp add: UP_def)
    then have "monom (UP Z\<^sub>p) \<zero>  = (\<lambda>n i. if i = n then \<zero> else \<zero>)"
      using A by simp
    then have "monom (UP Z\<^sub>p) \<zero> n  =  (\<lambda>i. if i = n then \<zero> else \<zero>)"
      by simp
    then show "monom (UP Z\<^sub>p) \<zero> n = (\<lambda>i. \<zero>)"
      by simp
  qed
  have H1: "cf f= f"
    by (simp add:UP_domain.coeff_simp1 UP_ring.monom_closed assms(1) assms(2))
  show ?thesis
    unfolding eq_on_Zp_def
    apply(auto )
    unfolding mon_def scalar_mult_def X_pow_Zp_def
  proof-
    fix x
    assume A: "x \<in> carrier Z\<^sub>p"
    have P0: "f\<^emph>x = \<zero>"
    proof-
      have C0: "abelian_monoid Z\<^sub>p"
        using Zp_is_cring abelian_group_def cring_def ring_def by blast
      have C1: "\<And> i::nat. \<zero> \<otimes> x [^]i = \<zero>"
      proof-
        fix i::nat
        show "\<zero> \<otimes> x [^] i = \<zero>"
          using Zp_is_cring A monoid.nat_pow_closed
          by (simp add: monoid.nat_pow_closed cring.cring_simprules(26) cring_def ring_def)
      qed
      have C2: "f \<in> carrier Z\<^sub>p_x"
        apply(auto simp: assms(2))
        using assms(1) Z\<^sub>p_x_is_UP_ring UP_ring.monom_closed[of Z\<^sub>p c n] apply simp
        done
      have C3: "f\<^emph>x = (\<Oplus>i \<in> {..degree f}. (cf f i) \<otimes> x [^] i)"
        using  A  C2 Z\<^sub>p_x_is_UP_domain UP_domain.fun_of_formula[of Z\<^sub>p f x]
        by blast
      show ?thesis
        apply(auto simp: C3 H1 )
        apply(auto simp: H)
        apply(auto simp: C1)
        apply(auto simp: C0 abelian_monoid.finsum_zero)
        done
    qed
    show "f\<^emph>x = c \<otimes> (if n = 0 then \<one> else x [^] n) "
      apply(auto simp: P0)
       apply (simp add: True Zp_one_car cring.cring_simprules(26))
      using A assms(1) monom_term_car[of c x]
      by (metis True Zp_is_cring cring.cring_simprules(26) cring_def monoid.nat_pow_closed ring_def)
  qed
next
  case False
  then show ?thesis
    unfolding eq_on_Zp_def
    apply(auto)
    by (simp add: assms(1) assms(2) fun_of_monom_is_monom0)
qed

lemma fun_of_monom_is_monom':
  assumes "is_monom f"
  shows "fun_of f \<doteq> mon (lc f) (degree f)"
  using Z\<^sub>p_x_is_UP_domain assms
    UP_domain.is_monom_id[of Z\<^sub>p f]
    fun_of_monom_is_monom[of "lc f" f "degree f"]
    UP_domain.lc_closed[of Z\<^sub>p f]
  unfolding   is_monom_poly_def
  by auto

(*monomials are continuous*)

lemma monom_poly_is_continuous:
  assumes "c \<in> carrier Z\<^sub>p"
  assumes "f = monom Z\<^sub>p_x c n"
  shows "is_continuous (fun_of f)"
proof-
  have 0: "is_continuous (mon c n)"
    unfolding mon_def using assms(1)
    by (simp add: X_pow_Zp_is_continuous scalar_mult_is_continuous)
  have 1: "fun_of f \<doteq> mon c n"
    by (simp add: assms(1) assms(2) fun_of_monom_is_monom)
  show ?thesis using 0 1 is_continuous_eq eq_on_Zp_def by auto
qed

lemma monom_poly_is_continuous':
  assumes "is_monom f"
  shows "is_continuous (fun_of f)"
  using Z\<^sub>p_x_is_UP_domain UP_domain.is_monom_id[of Z\<^sub>p f]
        monom_poly_is_continuous[of "lc f" f "degree f"]
        assms UP_domain.lc_closed[of Z\<^sub>p f]
  unfolding is_monom_poly_def
  by (simp add:  )

lemma degree_0_is_constant:
  assumes "f \<in> carrier Z\<^sub>p_x"
  assumes "degree f = 0"
  obtains g where "is_constant_fun g" and "g \<doteq> fun_of f"
proof-
  obtain c where c0: "c \<in> carrier Z\<^sub>p" and  c1: "\<And>x.  x \<in> carrier Z\<^sub>p \<Longrightarrow> (fun_of f) x = c"
    using Z\<^sub>p_x_is_UP_domain UP_domain.degree_0_imp_constant0  assms(1) assms(2) by blast
  obtain g where g_def: "g = to_const_fun c"
    by simp
  have 0: "is_constant_fun g"
    by (simp add: \<open>g = to_const_fun c\<close> c0 to_const_fun_is_const)
  have 1: "g \<doteq> fun_of f"
    unfolding eq_on_Zp_def
    apply(auto)
  proof-
    fix x
    assume A: "x \<in> carrier Z\<^sub>p"
    show "g x = f\<^emph>x "
    proof-
      have LHS: "g x = c"
        using g_def using to_const_fun_def by simp
      have RHS: "f\<^emph>x = c"
        apply(auto simp: A c1)
        done
      then show ?thesis
        using RHS LHS by auto
    qed
  qed
  show ?thesis
    using 0 1  that by auto
qed

(*degree 0 polynomials induce continuous functions*)
lemma degree_0_is_continuous:
  assumes "f \<in> carrier Z\<^sub>p_x"
  assumes "degree f = 0"
  shows "is_continuous (fun_of f)"
proof-
  obtain g where 0: "is_constant_fun g" and 1: "g \<doteq> fun_of f"
    using assms degree_0_is_constant by auto
  have "is_continuous g"
    using 0 by (simp add: constant_is_continuous)
  then show ?thesis
    using 1 is_continuous_eq by blast
qed

(*all polynomials induce continuous functions*)
lemma polynomial_is_continuous_induct:
  fixes n::nat
  shows "\<And>f. f \<in> carrier Z\<^sub>p_x \<Longrightarrow> degree f \<le> n \<Longrightarrow> is_continuous (fun_of f)"
proof(induction n)
case 0
  then show ?case
    using degree_0_is_continuous by blast
next
  case (Suc n)
  fix n
  assume IH: "\<And>f. f \<in> carrier Z\<^sub>p_x \<Longrightarrow> (degree f \<le> n \<Longrightarrow> is_continuous (fun_of f))"
  show "\<And>f. f \<in> carrier Z\<^sub>p_x \<Longrightarrow> degree f \<le> Suc n \<Longrightarrow> is_continuous (fun_of f) "
  proof-
    fix f
    assume A0:"f \<in> carrier Z\<^sub>p_x"
    assume D: "degree f \<le> Suc n"
    show "is_continuous (fun_of f)"
    proof(cases "degree f < Suc n")
      case True
      then show ?thesis
        using IH A0 by simp
    next
      case False
      then have E: "degree f = Suc n"
        using D by auto
      then have E0: "degree f > (0::nat)"
        by auto
      obtain g where g_def: "g \<in> carrier Z\<^sub>p_x \<and> (f = g \<oplus>\<^bsub>Z\<^sub>p_x\<^esub> (lt f)) \<and> degree g < degree f"
        using E0 A0 Z\<^sub>p_x_is_UP_domain UP_domain.lt_decomp[of Z\<^sub>p f] by auto
      have g0: "g \<in> carrier Z\<^sub>p_x"
        using g_def by auto
      have g1: "f = g \<oplus>\<^bsub>Z\<^sub>p_x\<^esub> (lt f)"
        using g_def by auto
      have g2: "degree g < degree f"
        using g_def by auto
      have LS: "is_continuous (fun_of g)"
        using E g0 g1 g2 IH by auto
      have RS: "is_continuous (fun_of (lt f))"
        using monom_poly_is_continuous leading_term_def A0  UP_ring.lcoeff_closed
            Z\<^sub>p_x_is_UP_ring UP_domain.coeff_simp1 Z\<^sub>p_x_is_UP_domain   by metis
      have "fun_of f \<doteq>  fun_sum (fun_of g) (fun_of (lt f))"
        using  fun_of_fun_sum g0 A0 g1  eq_on_Zp_def UP_domain.lt_closed
        by (metis (mono_tags, lifting) Z\<^sub>p_x_is_UP_domain)
      then show ?thesis
        using LS RS sum_of_cont_is_cont
        by (metis eq_on_Zp_def is_continuous_eq)
    qed
  qed
qed

lemma polynomial_is_continuous:
  assumes "f \<in> carrier Z\<^sub>p_x"
  shows "is_continuous (fun_of f)"
proof-
  obtain n where n_def: "n = degree f"
    by simp
  then show ?thesis
    using assms polynomial_is_continuous_induct by auto
qed

(**************************************************************************************************)
(**************************************************************************************************)
(**********************************    Polynomial Substitution   **********************************)
(**************************************************************************************************)
(**************************************************************************************************)

(*The inclusion of Z\<^sub>p into Z\<^sub>p_x*)

abbreviation to_poly :: "padic_int \<Rightarrow> padic_int_poly" where
"to_poly \<equiv> to_polynomial Z\<^sub>p"

lemma to_poly_is_ring_hom:
"to_poly \<in> ring_hom Z\<^sub>p Z\<^sub>p_x"
  by (simp add: UP_domain.to_poly_is_ring_hom)

abbreviation sub :: "padic_int_poly \<Rightarrow> padic_int_poly \<Rightarrow> padic_int_poly" (infixl "of" 70)where
"sub \<equiv> compose Z\<^sub>p"

abbreviation rev_sub :: "padic_int_poly \<Rightarrow> padic_int_poly \<Rightarrow> padic_int_poly" where
"rev_sub \<equiv> rev_compose Z\<^sub>p"

lemma sub_rev_sub:
"sub f g = rev_sub g f"
  by (simp add:  UP_domain.sub_rev_sub)

(*The polynomial X*)
abbreviation X where
"X \<equiv> X_poly Z\<^sub>p"

(*Translates of X*)
abbreviation X_plus where
"X_plus \<equiv> X_poly_plus  Z\<^sub>p"

abbreviation X_minus where
"X_minus \<equiv> X_poly_minus  Z\<^sub>p"

(*Powers of X*)
abbreviation X_pow where
"X_pow n \<equiv> X[^]\<^bsub>Z\<^sub>p_x\<^esub>n"

(*The Taylor expansion*)

abbreviation Taylor ("T\<^bsub>_\<^esub>") where
"Taylor \<equiv> taylor_expansion Z\<^sub>p"

(*Derivative function*)

abbreviation deriv   where
"deriv \<equiv> derivative Z\<^sub>p"

(*Zero coefficient function*)
abbreviation cf0 where
"cf0 \<equiv> zero_coefficient"

(*The horner shift function. Satisfies the equation:       f = a0 + X(poly_shift f)      *)
abbreviation poly_shift where
"poly_shift \<equiv> polynomial_shift Z\<^sub>p"

(*The iterated shift function. Satisfies   f = a0 + a1*X + ...+ (an-1)*X^(n-1) + X^n(shift n f) *)
abbreviation shift where
"shift \<equiv> poly_shift_iter Z\<^sub>p"

(*The "first n+1 terms" function*)
abbreviation deg_leq where
"deg_leq \<equiv> degree_n_or_less_terms Z\<^sub>p"

(*The linear part function*)
abbreviation lin_part where
"lin_part \<equiv> linear_part Z\<^sub>p"

(*the derivative operator*)

abbreviation pderiv where
"pderiv \<equiv> poly_deriv Z\<^sub>p"

(*Evaluating polynomials in the residue rings*)

lemma fun_of_res_X_pow:
  assumes "a \<in> carrier Z\<^sub>p"
  assumes "b \<in> carrier Z\<^sub>p"
  assumes "a k = b k"
  shows "(X_pow(n::nat)\<^emph> a) k = (X_pow n\<^emph>b) k"
proof(induction n)
  case 0
  then show ?case
    by (smt Z\<^sub>p_x_is_UP_domain Z\<^sub>p_x_is_UP_ring Z\<^sub>p_x_ring UP_domain.X_closed UP_ring.deg_monom
        UP_ring.monom_one Zp_one_car Zp_one_notzero assms(1) assms(2) degree_0_is_constant
        eq_on_Zp_def is_constant_fun_def monoid.nat_pow_0 pow_closedP ring_def)
next
  case (Suc n)
  fix n::nat
  assume IH: "(X [^]\<^bsub>Z\<^sub>p_x\<^esub> n \<^emph> a) k = (X [^]\<^bsub>Z\<^sub>p_x\<^esub> n \<^emph> b) k"
  show "(X [^]\<^bsub>Z\<^sub>p_x\<^esub> Suc n \<^emph> a) k = (X [^]\<^bsub>Z\<^sub>p_x\<^esub> Suc n \<^emph> b) k"
  proof-
    have LHS0: "(X [^]\<^bsub>Z\<^sub>p_x\<^esub> Suc n \<^emph> a) k = ((X [^]\<^bsub>Z\<^sub>p_x\<^esub> n \<^emph> a) \<otimes> (X \<^emph> a)) k"
      by (metis (no_types, lifting) Z\<^sub>p_x_is_UP_domain Z\<^sub>p_x_ring UP_domain.X_closed
          UP_domain.fun_of_mult assms(1) monoid.nat_pow_Suc pow_closedP ring_def)
    have LHS1: "(X [^]\<^bsub>Z\<^sub>p_x\<^esub> Suc n \<^emph> a) k = (X [^]\<^bsub>Z\<^sub>p_x\<^esub> n \<^emph> a) k \<otimes>\<^bsub>R k\<^esub> (X \<^emph> a) k"
      using LHS0
      by (simp add:  Z\<^sub>p_def padic_mult_simp)
    then show ?thesis using assms IH
      by (smt Z\<^sub>p_x_is_UP_domain Z\<^sub>p_x_ring UP_domain.X_closed
          UP_domain.fun_of_X UP_domain.fun_of_mult Z\<^sub>p_def monoid.nat_pow_Suc
          monoid.simps(1) padic_simps(3) pow_closedP ring_def)
  qed
qed

lemma fun_of_res_lt:
  assumes "a \<in> carrier Z\<^sub>p"
  assumes "b \<in> carrier Z\<^sub>p"
  assumes "f \<in> carrier Z\<^sub>p_x"
  assumes "a k = b k"
  shows "((lt f)\<^emph>a) k = ((lt f)\<^emph>b) k"
proof-
  have "lt f = (lc f)\<odot>\<^bsub>Z\<^sub>p_x\<^esub>(X_pow (degree f))"
    by (simp add: UP_domain.lt_rep_X_pow assms(3))
  have LHS0: "(fun_of (lt f) a) = (lc f) \<otimes> (fun_of (X_pow (degree f)) a)"
    by (simp add: UP_domain.X_closed UP_domain.fun_of_smult UP_domain.lc_closed \<open>lt f = lc f \<odot>\<^bsub>Z\<^sub>p_x\<^esub> X [^]\<^bsub>Z\<^sub>p_x\<^esub> degree f\<close> assms(1) assms(3))
  have RHS0: "(fun_of (lt f) b) = (lc f) \<otimes> (fun_of (X_pow (degree f)) b)"
    by (simp add: UP_domain.X_closed UP_domain.fun_of_smult UP_domain.lc_closed \<open>lt f = lc f \<odot>\<^bsub>Z\<^sub>p_x\<^esub> X [^]\<^bsub>Z\<^sub>p_x\<^esub> degree f\<close> assms(2) assms(3))
  have LHS1: "(fun_of (lt f) a) k = ((lc f) k) \<otimes>\<^bsub>R k\<^esub> (fun_of (X_pow (degree f)) a) k"
    using LHS0 assms
    by (simp add:  Z\<^sub>p_def padic_simps(3))
  have RHS1: "(fun_of (lt f) b) k = ((lc f) k) \<otimes>\<^bsub>R k\<^esub> (fun_of (X_pow (degree f)) b) k"
    using RHS0 assms
    by (simp add:  Z\<^sub>p_def padic_simps(3))
  then show ?thesis
    using LHS1 RHS1 assms
    by (metis fun_of_res_X_pow)
qed

(*Polynomial application commutes with taking residues*)
lemma fun_of_res:
  assumes "f \<in> carrier Z\<^sub>p_x"
  assumes "a \<in> carrier Z\<^sub>p"
  assumes "b \<in> carrier Z\<^sub>p"
  assumes "a k = b k"
  shows "(f\<^emph>a) k = (f\<^emph>b) k"
proof(rule UP_domain.poly_induct2[of Z\<^sub>p f])
  show "UP_domain Z\<^sub>p"
    by simp
  show "f \<in> carrier Z\<^sub>p_x"
    using assms by simp
  show "\<And>p. p \<in> carrier Z\<^sub>p_x \<Longrightarrow> degree p = 0 \<Longrightarrow> (p \<^emph> a) k = (p \<^emph> b) k"
    by (metis Z\<^sub>p_x_is_UP_domain UP_domain.degree_0_imp_constant0 assms(2) assms(3))
  show "\<And>p. 0 < degree p \<Longrightarrow> p \<in> carrier Z\<^sub>p_x \<Longrightarrow> (trunc p \<^emph> a) k = (trunc p \<^emph> b) k
                \<Longrightarrow> (p \<^emph> a) k = (p \<^emph> b) k"
  proof-
    fix p
    assume A: "0 < degree p" "p \<in> carrier Z\<^sub>p_x"
    assume IH: " (trunc p \<^emph> a) k = (trunc p \<^emph> b) k "
    show "(p \<^emph> a) k = (p \<^emph> b) k"
    proof-
      have "(p \<^emph> a) k = (((trunc p)\<^emph> a) \<oplus> ((lt p) \<^emph> a)) k "
        by (metis A(2) Z\<^sub>p_x_is_UP_domain UP_domain.fun_of_plus
            UP_domain.lt_closed UP_domain.trunc_simps(1) UP_domain.trunc_simps(3) assms(2))
      then have 0: "(p \<^emph> a) k = (((trunc p)\<^emph> b) k) \<oplus>\<^bsub>R k\<^esub> ((lt p) \<^emph> a) k "
        using IH
        by (simp add:  Z\<^sub>p_def padic_add_def)
      have "((lt p) \<^emph> a) k = ((lt p) \<^emph> b) k"
        by (simp add: A(2) assms(2) assms(3) assms(4) fun_of_res_lt)
      then have 1: "(p \<^emph> a) k = (((trunc p)\<^emph> b) k) \<oplus>\<^bsub>R k\<^esub> ((lt p) \<^emph> b) k "
        using 0 by auto
      then have 2: "(p \<^emph> a) k = (((trunc p)\<^emph> b) \<oplus> ((lt p) \<^emph> b)) k "
        using IH Z\<^sub>p_def \<open>(lt p \<^emph> a) k = (lt p \<^emph> b) k\<close> \<open>(p \<^emph> a) k = (trunc p \<^emph> a \<oplus> lt p \<^emph> a) k\<close>
          padic_add_def by auto
      then have 2: "(p \<^emph> a) k = (((trunc p) \<oplus>\<^bsub>Z\<^sub>p_x\<^esub>(lt p)) \<^emph> b) k"
        by (simp add: A(2) UP_domain.fun_of_plus UP_domain.lt_closed
            UP_domain.trunc_simps(3) assms(3))
      then show ?thesis
        by (metis A(2) Z\<^sub>p_x_is_UP_domain UP_domain.trunc_simps(1))
    qed
  qed
qed

(*If a and b has equal kth residues, then do f'(a) and f'(b)*)
lemma deriv_res:
  assumes "f \<in> carrier Z\<^sub>p_x"
  assumes "a \<in> carrier Z\<^sub>p"
  assumes "b \<in> carrier Z\<^sub>p"
  assumes "a k = b k"
  shows "(deriv f a) k = (deriv f b) k"
proof-
  have 0: "deriv f a = fun_of (pderiv f) a"
    by (simp add: UP_domain.pderiv_eval_deriv assms(1) assms(2))
  have 1: "deriv f b = fun_of (pderiv f) b"
    by (simp add: UP_domain.pderiv_eval_deriv assms(1) assms(3))
  have 2: "pderiv f \<in> carrier Z\<^sub>p_x"
    by (simp add: UP_domain.poly_deriv_closed assms(1))
  show ?thesis
    using assms fun_of_res[of "pderiv f" a b k] 0 1 2
    by auto
qed

end
end


(*  Title:      HOL/ex/Set_Comprehension_Pointfree_Examples.thy
    Author:     Lukas Bulwahn, Rafal Kolanski
    Copyright   2012 TU Muenchen
*)

section {* Examples for the set comprehension to pointfree simproc *}

theory Set_Comprehension_Pointfree_Examples
imports Main
begin

declare [[simproc add: finite_Collect]]

lemma
  "finite (UNIV::'a set) ==> finite {p. EX x::'a. p = (x, x)}"
  by simp

lemma
  "finite A ==> finite B ==> finite {f a b| a b. a : A \<and> b : B}"
  by simp

lemma
  "finite B ==> finite A' ==> finite {f a b| a b. a : A \<and> a : A' \<and> b : B}"
  by simp

lemma
  "finite A ==> finite B ==> finite {f a b| a b. a : A \<and> b : B \<and> b : B'}"
  by simp

lemma
  "finite A ==> finite B ==> finite C ==> finite {f a b c| a b c. a : A \<and> b : B \<and> c : C}"
  by simp

lemma
  "finite A ==> finite B ==> finite C ==> finite D ==>
     finite {f a b c d| a b c d. a : A \<and> b : B \<and> c : C \<and> d : D}"
  by simp

lemma
  "finite A ==> finite B ==> finite C ==> finite D ==> finite E ==>
    finite {f a b c d e | a b c d e. a : A \<and> b : B \<and> c : C \<and> d : D \<and> e : E}"
  by simp

lemma
  "finite A ==> finite B ==> finite C ==> finite D ==> finite E \<Longrightarrow>
    finite {f a d c b e | e b c d a. b : B \<and> a : A \<and> e : E' \<and> c : C \<and> d : D \<and> e : E \<and> b : B'}"
  by simp

lemma
  "\<lbrakk> finite A ; finite B ; finite C ; finite D \<rbrakk>
  \<Longrightarrow> finite ({f a b c d| a b c d. a : A \<and> b : B \<and> c : C \<and> d : D})"
  by simp

lemma
  "finite ((\<lambda>(a,b,c,d). f a b c d) ` (A \<times> B \<times> C \<times> D))
  \<Longrightarrow> finite ({f a b c d| a b c d. a : A \<and> b : B \<and> c : C \<and> d : D})"
  by simp

lemma
  "finite S ==> finite {s'. EX s:S. s' = f a e s}"
  by simp

lemma
  "finite A ==> finite B ==> finite {f a b| a b. a : A \<and> b : B \<and> a \<notin> Z}"
  by simp

lemma
  "finite A ==> finite B ==> finite R ==> finite {f a b x y| a b x y. a : A \<and> b : B \<and> (x,y) \<in> R}"
by simp

lemma
  "finite A ==> finite B ==> finite R ==> finite {f a b x y| a b x y. a : A \<and> (x,y) \<in> R \<and> b : B}"
by simp

lemma
  "finite A ==> finite B ==> finite R ==> finite {f a (x, b) y| y b x a. a : A \<and> (x,y) \<in> R \<and> b : B}"
by simp

lemma
  "finite A ==> finite AA ==> finite B ==> finite {f a b| a b. (a : A \<or> a : AA) \<and> b : B \<and> a \<notin> Z}"
by simp

lemma
  "finite A1 ==> finite A2 ==> finite A3 ==> finite A4 ==> finite A5 ==> finite B ==>
     finite {f a b c | a b c. ((a : A1 \<and> a : A2) \<or> (a : A3 \<and> (a : A4 \<or> a : A5))) \<and> b : B \<and> a \<notin> Z}"
apply simp
oops

lemma "finite B ==> finite {c. EX x. x : B & c = a * x}"
by simp

lemma
  "finite A ==> finite B ==> finite {f a * g b |a b. a : A & b : B}"
by simp

lemma
  "finite S ==> inj (%(x, y). g x y) ==> finite {f x y| x y. g x y : S}"
  by (auto intro: finite_vimageI)

lemma
  "finite A ==> finite S ==> inj (%(x, y). g x y) ==> finite {f x y z | x y z. g x y : S & z : A}"
  by (auto intro: finite_vimageI)

lemma
  "finite S ==> finite A ==> inj (%(x, y). g x y) ==> inj (%(x, y). h x y)
    ==> finite {f a b c d | a b c d. g a c : S & h b d : A}"
  by (auto intro: finite_vimageI)

lemma
  assumes "finite S" shows "finite {(a,b,c,d). ([a, b], [c, d]) : S}"
using assms by (auto intro!: finite_vimageI simp add: inj_on_def)
  (* injectivity to be automated with further rules and automation *)

schematic_lemma (* check interaction with schematics *)
  "finite {x :: ?'A \<Rightarrow> ?'B \<Rightarrow> bool. \<exists>a b. x = Pair_Rep a b}
   = finite ((\<lambda>(b :: ?'B, a:: ?'A). Pair_Rep a b) ` (UNIV \<times> UNIV))"
  by simp

declare [[simproc del: finite_Collect]]

section {* Testing simproc in code generation *}

definition union :: "nat set => nat set => nat set"
where
  "union A B = {x. x : A \<or> x : B}"

definition common_subsets :: "nat set => nat set => nat set set"
where
  "common_subsets S1 S2 = {S. S \<subseteq> S1 \<and> S \<subseteq> S2}"

definition products :: "nat set => nat set => nat set"
where
  "products A B = {c. EX a b. a : A & b : B & c = a * b}"

export_code products in Haskell

export_code union common_subsets products in Haskell

end