theory function_ring
  imports domain_poly "HOL-Algebra.UnivPoly" "HOL-Library.FuncSet"
begin

definition function_mult:: "'c set \<Rightarrow> ('a, 'b) ring_scheme \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'a)" where
"function_mult S R f g = (\<lambda>x \<in> S. (f x) \<otimes>\<^bsub>R\<^esub> (g x))"

abbreviation ring_function_mult:: "('a, 'b) ring_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
"ring_function_mult R f g \<equiv> function_mult (carrier R) R f g"

definition function_add:: "'c set \<Rightarrow> ('a, 'b) ring_scheme \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'a)" where
"function_add S R f g = (\<lambda>x \<in> S. (f x) \<oplus>\<^bsub>R\<^esub> (g x))"

abbreviation ring_function_add:: "('a, 'b) ring_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
"ring_function_add R f g \<equiv> function_add (carrier R) R f g"

definition function_one:: "'c set \<Rightarrow> ('a, 'b) ring_scheme \<Rightarrow> ('c \<Rightarrow> 'a)" where
"function_one S R = (\<lambda>x \<in> S. \<one>\<^bsub>R\<^esub>)"

abbreviation ring_function_one :: "('a, 'b) ring_scheme \<Rightarrow> ('a \<Rightarrow> 'a)" where
"ring_function_one R \<equiv> function_one (carrier R) R"

definition function_zero:: "'c set \<Rightarrow> ('a, 'b) ring_scheme \<Rightarrow> ('c \<Rightarrow> 'a)" where
"function_zero S R = (\<lambda>x \<in> S. \<zero>\<^bsub>R\<^esub>)"

abbreviation ring_function_zero :: "('a, 'b) ring_scheme \<Rightarrow> ('a \<Rightarrow> 'a)" where
"ring_function_zero R \<equiv> function_zero (carrier R) R"

definition function_uminus:: "'c set \<Rightarrow> ('a, 'b) ring_scheme \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'a)" where
"function_uminus S R a = (\<lambda> x \<in> S. \<ominus>\<^bsub>R\<^esub> (a x))"

definition ring_function_uminus:: " ('a, 'b) ring_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
"ring_function_uminus R a = function_uminus (carrier R) R a"

definition function_ring:: "'c set \<Rightarrow> ('a, 'b) ring_scheme \<Rightarrow> ('c \<Rightarrow> 'a) ring" where
"function_ring S R = \<lparr>
   carrier = {f. f \<in> S \<rightarrow> (carrier R) \<and> (f = restrict f S)},
   Group.monoid.mult = (function_mult S R),
   one = (function_one S R),
   zero = (function_zero S R),
   add = (function_add S R)\<rparr> "

abbreviation ring_function_ring:: "('a, 'b) ring_scheme \<Rightarrow> ('a \<Rightarrow> 'a) ring" ("Fun") where
"ring_function_ring R \<equiv> function_ring (carrier R) R"

lemma function_ring_car_simp[simp]:
  assumes "a \<in> S"
  assumes "f \<in> (carrier (function_ring S R))"
  shows "f a \<in> carrier R"
  using assms
  unfolding function_ring_def
  by auto

lemma function_ring_not_car_simp:
  assumes "a \<notin> S"
  assumes "f \<in> (carrier (function_ring S R))"
  shows "f a = undefined"
  using assms
  unfolding function_ring_def
  by (metis (mono_tags, lifting) mem_Collect_eq partial_object.select_convs(1) restrict_def)

lemma function_ring_car_eqI:
  assumes "f \<in> (carrier (function_ring S R))"
  assumes "g \<in> (carrier (function_ring S R))"
  assumes "\<And>a. a \<in> S \<Longrightarrow> f a = g a"
  shows "f = g"
proof
  fix x
  show "f x = g x"
  proof(cases "x \<in> S")
    case True
    then show ?thesis
      by (simp add: assms(3))
  next
    case False
    then have fx: "f x = undefined"
      using False assms
      unfolding function_ring_def
      by (metis (mono_tags, lifting) mem_Collect_eq partial_object.select_convs(1) restrict_def)
    have gx: "g x = undefined"
      using False assms
      unfolding function_ring_def
      by (metis (mono_tags, lifting) mem_Collect_eq partial_object.select_convs(1) restrict_def)
    then show ?thesis using fx
      by auto
qed
qed

lemma function_ring_car_memI:
  assumes "\<And>a. a \<in> S \<Longrightarrow> f a \<in> carrier R"
  assumes "\<And> a. a \<notin> S\<Longrightarrow> f a = undefined"
  shows "f \<in> carrier (function_ring S R)"
  using assms
  unfolding function_ring_def
  by (simp add: extensional_def extensional_restrict)

text\<open>Function multiplication lemmas\<close>

lemma(in ring) function_mult_eval_simp[simp]:
  assumes "a \<in> S"
  assumes "f \<in> carrier (function_ring S R)"
  assumes "g \<in> carrier (function_ring S R)"
  shows "(f \<otimes>\<^bsub>(function_ring S R)\<^esub> g) a = (f a) \<otimes> (g a)"
  using assms
  unfolding function_ring_def function_mult_def
  by simp

lemma(in ring) function_mult_closed[simp]:
  assumes "a \<in> S"
  assumes "f \<in> carrier (function_ring S R)"
  assumes "g \<in> carrier (function_ring S R)"
  shows "(f \<otimes>\<^bsub>(function_ring S R)\<^esub> g) a \<in> carrier R"
  using assms
  unfolding function_ring_def function_mult_def
  by (simp add: Pi_iff)

lemma(in ring) function_mult_closed'[simp]:
  assumes "f \<in> carrier (function_ring S R)"
  assumes "g \<in> carrier (function_ring S R)"
  shows "(f \<otimes>\<^bsub>(function_ring S R)\<^esub> g) \<in> carrier (function_ring S R)"
  using assms function_mult_closed function_ring_car_memI[of "S" "(f \<otimes>\<^bsub>(function_ring S R)\<^esub> g)"]
  by (metis (no_types, lifting) function_mult_def function_ring_def monoid.simps(1) restrict_def)

lemma(in ring) function_multE:
  assumes "a \<in> S"
  assumes "f \<in> carrier (function_ring S R)"
  assumes "g \<in> carrier (function_ring S R)"
  assumes "h =  f \<otimes>\<^bsub>(function_ring S R)\<^esub> g"
  shows "h a = f a \<otimes> g a"
  using assms unfolding function_ring_def function_mult_def
  by simp

lemma(in ring) set_fun_mult_assoc:
  assumes "x \<in> carrier (function_ring S R)"
  assumes "y \<in> carrier (function_ring S R)"
  assumes " z \<in> carrier (function_ring S R)"
  assumes "a \<in> S"
  shows "(x \<otimes>\<^bsub>(function_ring S R)\<^esub> y \<otimes>\<^bsub>(function_ring S R)\<^esub> z) a = (x \<otimes>\<^bsub>(function_ring S R)\<^esub> (y \<otimes>\<^bsub>(function_ring S R)\<^esub> z)) a"
proof-
  have 0: "(x \<otimes>\<^bsub>(function_ring S R)\<^esub> y \<otimes>\<^bsub>(function_ring S R)\<^esub> z) a = (x a) \<otimes> (y a) \<otimes> (z a) "
    using assms function_multE[of a S] function_mult_closed'[of _ S ]
    by presburger
  have 1: "(x \<otimes>\<^bsub>(function_ring S R)\<^esub> (y \<otimes>\<^bsub>(function_ring S R)\<^esub> z)) a = (x a) \<otimes> ((y a) \<otimes> (z a))"
    using assms  function_multE[of a S] function_mult_closed'
    by metis
  have 2:"(x \<otimes>\<^bsub>(function_ring S R)\<^esub> (y \<otimes>\<^bsub>(function_ring S R)\<^esub> z)) a = (x a) \<otimes> (y a) \<otimes> (z a)"
    using 1 assms
    by (simp add: m_assoc)
  show ?thesis
    using 0 2 by auto
qed

lemma(in ring) set_fun_mult_assoc':
  assumes "x \<in> carrier (function_ring S R)"
  assumes "y \<in> carrier (function_ring S R)"
  assumes " z \<in> carrier (function_ring S R)"
  shows "(x \<otimes>\<^bsub>(function_ring S R)\<^esub> y \<otimes>\<^bsub>(function_ring S R)\<^esub> z) = (x \<otimes>\<^bsub>(function_ring S R)\<^esub> (y \<otimes>\<^bsub>(function_ring S R)\<^esub> z))"
  using set_fun_mult_assoc[of x]
  by (meson assms(1) assms(2) assms(3) function_ring_car_eqI
      local.ring_axioms ring.function_mult_closed')

text\<open>Function addition lemmas\<close>

lemma(in ring) function_add_eval_simp[simp]:
  assumes "a \<in> S"
  assumes "f \<in> carrier (function_ring S R)"
  assumes "g \<in> carrier (function_ring S R)"
  shows "(f \<oplus>\<^bsub>function_ring S R\<^esub> g) a = (f a) \<oplus> (g a)"
  using assms
  unfolding function_ring_def function_add_def
  by simp

lemma(in ring) function_add_closed[simp]:
  assumes "a \<in> S"
  assumes "f \<in> carrier (function_ring S R)"
  assumes "g \<in> carrier (function_ring S R)"
  shows "(f \<oplus>\<^bsub>(function_ring S R)\<^esub> g) a \<in> carrier R"
  using assms
  unfolding function_ring_def function_add_def
  by (simp add: Pi_iff)

lemma(in ring) function_add_closed'[simp]:
  assumes "f \<in> carrier (function_ring S R)"
  assumes "g \<in> carrier (function_ring S R)"
  shows "(f \<oplus>\<^bsub>(function_ring S R)\<^esub> g) \<in> carrier (function_ring S R)"
  using assms function_add_closed function_ring_car_memI[of S "(f \<oplus>\<^bsub>(function_ring S R)\<^esub> g)"]
  by (metis (no_types, lifting) function_add_def function_ring_def restrict_def ring.simps(2))

lemma(in ring) ring_function_addE[simp]:
  assumes "a \<in> S"
  assumes "f \<in> carrier (function_ring S R)"
  assumes "g \<in> carrier (function_ring S R)"
  assumes "h =  f \<oplus>\<^bsub>(function_ring S R)\<^esub> g"
  shows "h a = f a \<oplus> g a"
  using assms unfolding function_ring_def function_add_def
  by simp

lemma(in ring) fun_add_assoc:
  assumes "x \<in> carrier (function_ring S R)"
  assumes "y \<in> carrier (function_ring S R)"
  assumes " z \<in> carrier (function_ring S R)"
  assumes "a \<in> S"
  shows "(x \<oplus>\<^bsub>(function_ring S R)\<^esub> y \<oplus>\<^bsub>function_ring S R\<^esub> z) a = (x \<oplus>\<^bsub>function_ring S R\<^esub> (y \<oplus>\<^bsub>function_ring S R\<^esub> z)) a"
proof-
  have 0: "(x \<oplus>\<^bsub>function_ring S R\<^esub> y \<oplus>\<^bsub>function_ring S R\<^esub> z) a = (x a) \<oplus> (y a) \<oplus> (z a) "
    using assms ring_function_addE function_add_closed'
    by simp
  have 1: "(x \<oplus>\<^bsub>function_ring S R\<^esub> (y \<oplus>\<^bsub>function_ring S R\<^esub> z)) a = (x a) \<oplus> ((y a) \<oplus> (z a))"
    using assms  ring_function_addE function_add_closed'
    by simp
  have 2:"(x \<oplus>\<^bsub>function_ring S R\<^esub> (y \<oplus>\<^bsub>function_ring S R\<^esub> z)) a = (x a) \<oplus> (y a) \<oplus> (z a)"
    using 1 assms
    by (simp add: assms(1) assms(2) assms(3) add.m_assoc)
  show ?thesis
    using 0 2 by auto
qed

lemma(in ring) fun_add_comm:
  assumes "a \<in> S"
  assumes "x \<in> carrier (function_ring S R)"
  assumes "y \<in> carrier (function_ring S R)"
  shows "(x \<oplus>\<^bsub>function_ring S R\<^esub> y) a = (y \<oplus>\<^bsub>function_ring S R\<^esub> x) a"
  using assms
  by (metis add.m_comm ring_function_addE function_ring_car_simp)

lemma(in ring) fun_add_comm':
  assumes "x \<in> carrier (function_ring S R)"
  assumes "y \<in> carrier (function_ring S R)"
  shows "x \<oplus>\<^bsub>function_ring S R\<^esub> y = y \<oplus>\<^bsub>function_ring S R\<^esub> x"
  using fun_add_comm assms
  by (metis (no_types, hide_lams) function_add_closed' function_ring_car_eqI)

text\<open>Lemmas about ring_function_one\<close>

lemma(in ring) function_one_closed[simp]:
"\<one>\<^bsub>function_ring S R\<^esub> \<in>carrier (function_ring S R)"
  unfolding function_ring_def function_one_def
  by simp

lemma(in ring) function_oneE[simp]:
  assumes "a \<in> S"
  shows "\<one>\<^bsub>function_ring S R\<^esub> a = \<one>"
  using assms
  unfolding function_ring_def function_one_def
  by simp

lemma(in ring) function_times_oneL[simp]:
  assumes "a \<in> carrier (function_ring S R)"
  shows "\<one>\<^bsub>function_ring S R\<^esub> \<otimes>\<^bsub>function_ring S R\<^esub> a = a"
proof(rule function_ring_car_eqI)
  show "\<one>\<^bsub>function_ring S R\<^esub> \<otimes>\<^bsub>function_ring S R\<^esub> a \<in> carrier (function_ring S R)"
    using assms function_mult_closed' function_one_closed
    by blast
  show " a \<in> carrier (function_ring S R)"
    using assms by simp
  show "\<And>c. c \<in> S \<Longrightarrow> (\<one>\<^bsub>function_ring S R\<^esub> \<otimes>\<^bsub>function_ring S R\<^esub> a) c = a c "
  by (metis assms function_multE function_oneE function_one_closed function_ring_car_simp is_monoid monoid.l_one)
qed

lemma(in ring) function_times_oneR[simp]:
  assumes "a \<in> carrier (function_ring S R)"
  shows "a\<otimes>\<^bsub>function_ring S R\<^esub> \<one>\<^bsub>function_ring S R\<^esub>  = a"
proof(rule function_ring_car_eqI)
  show "a\<otimes>\<^bsub>function_ring S R\<^esub> \<one>\<^bsub>function_ring S R\<^esub> \<in> carrier (function_ring S R)"
    using assms function_mult_closed' function_one_closed
    by blast
  show " a \<in> carrier (function_ring S R)"
    using assms by simp
  show "\<And>c. c \<in> S \<Longrightarrow> (a\<otimes>\<^bsub>function_ring S R\<^esub> \<one>\<^bsub>function_ring S R\<^esub>) c = a c "
    using assms
    by (metis function_multE function_oneE function_one_closed function_ring_car_simp r_one)
qed

text\<open>Lemmas about ring_function_zero\<close>

lemma(in ring) function_zero_closed[simp]:
"\<zero>\<^bsub>function_ring S R\<^esub> \<in>carrier (function_ring S R)"
  unfolding function_ring_def function_zero_def
  by simp

lemma(in ring) ring_function_zeroE[simp]:
  assumes "a \<in> S"
  shows "\<zero>\<^bsub>function_ring S R\<^esub> a = \<zero>"
  using assms
  unfolding function_ring_def function_zero_def
  by simp

lemma(in ring) function_add_zeroL[simp]:
  assumes "a \<in> carrier (function_ring S R)"
  shows "\<zero>\<^bsub>function_ring S R\<^esub> \<oplus>\<^bsub>function_ring S R\<^esub> a = a"
proof(rule function_ring_car_eqI)
  show "\<zero>\<^bsub>function_ring S R\<^esub> \<oplus>\<^bsub>function_ring S R\<^esub> a \<in> carrier (function_ring S R)"
    using assms function_add_closed' function_zero_closed
    by blast
  show "a \<in> carrier (function_ring S R)"
    using assms by simp
  show "\<And>c. c \<in> S \<Longrightarrow> (\<zero>\<^bsub>function_ring S R\<^esub> \<oplus>\<^bsub>function_ring S R\<^esub> a) c = a c "
    using assms
    by (metis ring_function_addE function_mult_closed function_one_closed function_times_oneL
        ring_function_zeroE function_zero_closed local.ring_axioms ring.ring_simprules(8))
qed

lemma(in ring) function_add_zeroR[simp]:
  assumes "a \<in> carrier (function_ring S R)"
  shows "a \<oplus>\<^bsub>function_ring S R\<^esub> \<zero>\<^bsub>function_ring S R\<^esub> = a"
  using assms fun_add_comm' function_add_zeroL
  by fastforce

text\<open>Lemmas about ring_function_uminus\<close>

lemma(in ring) function_uminus_eval[simp]:
  assumes "a \<in> S"
  assumes "f \<in> carrier (function_ring S R)"
  shows "function_uminus S R f a = \<ominus> (f a)"
  using assms unfolding function_uminus_def
  by simp

lemma(in ring) function_uminus_closed[simp]:
  assumes "f \<in> carrier (function_ring S R)"
  shows "function_uminus S R f \<in> carrier (function_ring S R)"
proof(rule function_ring_car_memI)
  show "\<And>a. a \<in> S \<Longrightarrow> function_uminus S R f a \<in> carrier R"
    by (simp add: assms)
  show "\<And>a. a \<notin> S \<Longrightarrow> function_uminus S R f a = undefined"
    by (simp add: function_uminus_def)
qed

lemma(in ring) function_uminus_addR[simp]:
  assumes "f \<in> carrier (function_ring S R)"
  shows "f \<oplus>\<^bsub>function_ring S R\<^esub> (function_uminus S R f)= \<zero>\<^bsub>function_ring S R\<^esub>"
proof(rule function_ring_car_eqI)
  show "f \<oplus>\<^bsub>function_ring S R\<^esub> function_uminus S R f \<in> carrier (function_ring S R)"
    using assms
    by simp
  show "\<zero>\<^bsub>function_ring S R\<^esub> \<in> carrier (function_ring S R)"
    by simp
  show "\<And>a. a \<in> S \<Longrightarrow> (f \<oplus>\<^bsub>function_ring S R\<^esub> (function_uminus S R f)) a = \<zero>\<^bsub>function_ring S R\<^esub> a"
    using assms
    by (metis (full_types) ring_function_addE function_add_closed function_add_zeroL
        function_uminus_closed function_uminus_eval ring_function_zeroE function_zero_closed r_neg)
qed

lemma(in ring) function_uminus_addL[simp]:
  assumes "f \<in> carrier (function_ring S R)"
  shows "(function_uminus S R f) \<oplus>\<^bsub>function_ring S R\<^esub> f  = \<zero>\<^bsub>function_ring S R\<^esub>"
  by (simp add: assms fun_add_comm')

text\<open>Distributive Laws\<close>
lemma(in ring) function_mult_distr:
  assumes "x \<in> carrier (function_ring S R)"
  assumes" y \<in> carrier (function_ring S R)"
  assumes " z \<in> carrier (function_ring S R)"
  shows " (x \<oplus>\<^bsub>function_ring S R\<^esub> y) \<otimes>\<^bsub>function_ring S R\<^esub> z = x \<otimes>\<^bsub>function_ring S R\<^esub> z \<oplus>\<^bsub>function_ring S R\<^esub> y \<otimes>\<^bsub>function_ring S R\<^esub> z"
proof(rule function_ring_car_eqI)
  show "(x \<oplus>\<^bsub>function_ring S R\<^esub> y) \<otimes>\<^bsub>function_ring S R\<^esub> z \<in> carrier (function_ring S R)"
    by (simp add: assms ring.function_add_closed' ring.function_mult_closed')
  show "x \<otimes>\<^bsub>function_ring S R\<^esub> z \<oplus>\<^bsub>function_ring S R\<^esub> y \<otimes>\<^bsub>function_ring S R\<^esub> z \<in> carrier (function_ring S R)"
    by (simp add: assms ring.function_add_closed' ring.function_mult_closed')
  show  "\<And>a. a \<in> S \<Longrightarrow> ((x \<oplus>\<^bsub>function_ring S R\<^esub> y) \<otimes>\<^bsub>function_ring S R\<^esub> z) a = (x \<otimes>\<^bsub>function_ring S R\<^esub> z \<oplus>\<^bsub>function_ring S R\<^esub> y \<otimes>\<^bsub>function_ring S R\<^esub> z) a"
  proof-
    fix a
    assume A: "a \<in> S"
    show "((x \<oplus>\<^bsub>function_ring S R\<^esub> y) \<otimes>\<^bsub>function_ring S R\<^esub> z) a = (x \<otimes>\<^bsub>function_ring S R\<^esub> z \<oplus>\<^bsub>function_ring S R\<^esub> y \<otimes>\<^bsub>function_ring S R\<^esub> z) a"
      using A assms function_mult_eval_simp[of a S "(x \<oplus>\<^bsub>function_ring S R\<^esub> y)" z]  function_add_eval_simp[of a S x y]
            function_mult_eval_simp[of a S x z]  function_mult_eval_simp[of a S y z] function_add_eval_simp
      by (metis (full_types) function_add_closed function_add_closed' function_add_zeroR
          function_mult_closed' function_zero_closed l_distr)
  qed
qed

lemma(in ring) function_mult_distr':
  assumes "x \<in> carrier (function_ring S R)"
  assumes" y \<in> carrier (function_ring S R)"
  assumes " z \<in> carrier (function_ring S R)"
  shows "z \<otimes>\<^bsub>function_ring S R\<^esub> (x \<oplus>\<^bsub>function_ring S R\<^esub> y) = z \<otimes>\<^bsub>function_ring S R\<^esub> x \<oplus>\<^bsub>function_ring S R\<^esub> z \<otimes>\<^bsub>function_ring S R\<^esub> y"
proof(rule function_ring_car_eqI)
  show "z \<otimes>\<^bsub>function_ring S R\<^esub> (x \<oplus>\<^bsub>function_ring S R\<^esub> y) \<in> carrier (function_ring S R)"
    by (simp add: assms ring.function_add_closed' ring.function_mult_closed')
  show "z \<otimes>\<^bsub>function_ring S R\<^esub> x \<oplus>\<^bsub>function_ring S R\<^esub> z \<otimes>\<^bsub>function_ring S R\<^esub> y \<in> carrier (function_ring S R)"
    by (simp add: assms ring.function_add_closed' ring.function_mult_closed')
  show  "\<And>a. a \<in> S \<Longrightarrow> (z \<otimes>\<^bsub>function_ring S R\<^esub> (x \<oplus>\<^bsub>function_ring S R\<^esub> y)) a = (z \<otimes>\<^bsub>function_ring S R\<^esub> x \<oplus>\<^bsub>function_ring S R\<^esub> z \<otimes>\<^bsub>function_ring S R\<^esub> y) a"
  proof-
    fix a
    assume A: "a \<in> S"
    show "(z \<otimes>\<^bsub>function_ring S R\<^esub> (x \<oplus>\<^bsub>function_ring S R\<^esub> y)) a = (z \<otimes>\<^bsub>function_ring S R\<^esub> x \<oplus>\<^bsub>function_ring S R\<^esub> z \<otimes>\<^bsub>function_ring S R\<^esub> y) a"
      using A assms function_mult_eval_simp[of a S z "(x \<oplus>\<^bsub>function_ring S R\<^esub> y)"]  function_add_eval_simp[of a S x y]
            function_mult_eval_simp[of a S z x]  function_mult_eval_simp[of a S z y] function_add_eval_simp
      by (metis (full_types) function_add_closed function_add_closed' function_add_zeroR
          function_mult_closed' function_zero_closed r_distr)
  qed
qed

text\<open>Function rings are closed under composition\<close>

abbreviation(in ring) restricted_comp :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
"restricted_comp f g \<equiv> restrict  (f \<circ> g) (carrier R) "

lemma(in ring) ring_function_ring_comp[simp]:
  assumes "f \<in> carrier (Fun R)"
  assumes "g \<in> carrier (Fun R)"
  shows "restricted_comp f g\<in> carrier (Fun R)"
  apply(rule function_ring_car_memI)
  using assms
  apply (metis comp_apply function_ring_car_simp restrict_def)
  by simp

text\<open>Function rings over a ring form a ring\<close>

lemma ring_imp_Fun_is_ring:
  assumes "ring R"
  shows "ring (function_ring S R)"
proof(rule ringI)
  show "abelian_group (function_ring S R)"
  proof(rule abelian_groupI)
    show "\<zero>\<^bsub>function_ring S R\<^esub> \<in> carrier (function_ring S R)"
      using assms unfolding function_one_def function_ring_def
      by (simp add: function_zero_def ring.ring_simprules(2))
    show "\<And>x y. x \<in> carrier (function_ring S R) \<Longrightarrow> y \<in> carrier (function_ring S R) \<Longrightarrow> x \<oplus>\<^bsub>function_ring S R\<^esub> y \<in> carrier (function_ring S R)"
      unfolding function_add_def function_ring_def
      by (simp add: Pi_iff assms ring.ring_simprules(1))
    show "\<And>x y z. x \<in> carrier (function_ring S R) \<Longrightarrow> y \<in> carrier (function_ring S R) \<Longrightarrow> z \<in> carrier (function_ring S R) \<Longrightarrow> x \<oplus>\<^bsub>function_ring S R\<^esub> y \<oplus>\<^bsub>function_ring S R\<^esub> z = x \<oplus>\<^bsub>function_ring S R\<^esub> (y \<oplus>\<^bsub>function_ring S R\<^esub> z)"
      by (meson \<open>\<And>y x. \<lbrakk>x \<in> carrier (function_ring S R); y \<in> carrier (function_ring S R)\<rbrakk> \<Longrightarrow> x \<oplus>\<^bsub>function_ring S R\<^esub> y \<in> carrier (function_ring S R)\<close>
        assms function_ring_car_eqI ring.fun_add_assoc)
    show " \<And>x y. x \<in> carrier (function_ring S R) \<Longrightarrow> y \<in> carrier (function_ring S R) \<Longrightarrow> x \<oplus>\<^bsub>function_ring S R\<^esub> y = y \<oplus>\<^bsub>function_ring S R\<^esub> x"
      by (simp add: assms ring.fun_add_comm')
    show "\<And>x. x \<in> carrier (function_ring S R) \<Longrightarrow> \<zero>\<^bsub>function_ring S R\<^esub> \<oplus>\<^bsub>function_ring S R\<^esub> x = x"
      by (simp add: assms ring.function_add_zeroL)
    show "\<And>x. x \<in> carrier (function_ring S R) \<Longrightarrow> \<exists>y\<in>carrier (function_ring S R). y \<oplus>\<^bsub>function_ring S R\<^esub> x = \<zero>\<^bsub>function_ring S R\<^esub>"
      using assms ring.function_uminus_addL ring.function_uminus_closed by blast
  qed
  show "Group.monoid (function_ring S R)"
    apply(rule monoidI)
      apply (simp add: assms ring.function_mult_closed')
        apply (simp add: assms ring.function_one_closed)
          apply  (simp add: assms ring.set_fun_mult_assoc')
            apply (simp add: assms ring.function_times_oneL)
              by (simp add: assms ring.function_times_oneR)

  show "\<And>x y z.
       x \<in> carrier (function_ring S R) \<Longrightarrow>
       y \<in> carrier (function_ring S R) \<Longrightarrow> z \<in> carrier (function_ring S R) \<Longrightarrow> (x \<oplus>\<^bsub>function_ring S R\<^esub> y) \<otimes>\<^bsub>function_ring S R\<^esub> z = x \<otimes>\<^bsub>function_ring S R\<^esub> z \<oplus>\<^bsub>function_ring S R\<^esub> y \<otimes>\<^bsub>function_ring S R\<^esub> z"
    by (simp add: assms ring.function_mult_distr)
  show "\<And>x y z.
       x \<in> carrier (function_ring S R) \<Longrightarrow>
       y \<in> carrier (function_ring S R) \<Longrightarrow> z \<in> carrier (function_ring S R) \<Longrightarrow> z \<otimes>\<^bsub>function_ring S R\<^esub> (x \<oplus>\<^bsub>function_ring S R\<^esub> y) = z \<otimes>\<^bsub>function_ring S R\<^esub> x \<oplus>\<^bsub>function_ring S R\<^esub> z \<otimes>\<^bsub>function_ring S R\<^esub> y"
  by (simp add: assms ring.function_mult_distr')
qed

lemma cring_imp_Fun_is_cring:
  assumes "cring R"
  shows "cring (function_ring S R)"
  apply(rule cringI)
    apply (simp add: assms cring.axioms(1) ring.is_abelian_group ring_imp_Fun_is_ring)
proof-
  show "Group.comm_monoid (function_ring S R)"
    apply(rule comm_monoidI)
    apply (simp add: assms cring.axioms(1) ring.function_mult_closed')
       apply (simp add: assms cring.axioms(1) ring.function_one_closed)
        apply (simp add: assms cring.axioms(1) ring.set_fun_mult_assoc')
     apply (simp add: assms cring.axioms(1) ring.function_times_oneL)
  proof-
    show "\<And>x y. x \<in> carrier (function_ring S R) \<Longrightarrow> y \<in> carrier (function_ring S R) \<Longrightarrow> x \<otimes>\<^bsub>function_ring S R\<^esub> y = y \<otimes>\<^bsub>function_ring S R\<^esub> x"
    proof- fix x y
      assume A:  "x \<in> carrier (function_ring S R)" "y \<in> carrier (function_ring S R)"
      show "x \<otimes>\<^bsub>function_ring S R\<^esub> y = y \<otimes>\<^bsub>function_ring S R\<^esub> x"
      proof(rule function_ring_car_eqI)
        show "x \<otimes>\<^bsub>function_ring S R\<^esub> y \<in> carrier (function_ring S R)"
          using A(1) A(2) assms cring_def ring.function_mult_closed' by blast
        show "y \<otimes>\<^bsub>function_ring S R\<^esub> x \<in> carrier (function_ring S R)"
          using A(1) A(2) assms cring_def ring.function_mult_closed' by blast
        show "\<And>a. a \<in> S \<Longrightarrow> (x \<otimes>\<^bsub>function_ring S R\<^esub> y) a = (y \<otimes>\<^bsub>function_ring S R\<^esub> x) a"
        proof-
          fix a
          assume "a \<in> S"
          then show "(x \<otimes>\<^bsub>function_ring S R\<^esub> y) a = (y \<otimes>\<^bsub>function_ring S R\<^esub> x) a"
            using assms A
            by (simp add: cring.axioms(1) cring.cring_simprules(14) ring.function_mult_eval_simp)
        qed
      qed
    qed
  qed
  show "\<And>x y z.
       x \<in> carrier (function_ring S R) \<Longrightarrow>
       y \<in> carrier (function_ring S R) \<Longrightarrow> z \<in> carrier (function_ring S R) \<Longrightarrow> (x \<oplus>\<^bsub>function_ring S R\<^esub> y) \<otimes>\<^bsub>function_ring S R\<^esub> z = x \<otimes>\<^bsub>function_ring S R\<^esub> z \<oplus>\<^bsub>function_ring S R\<^esub> y \<otimes>\<^bsub>function_ring S R\<^esub> z"
  by (simp add: assms cring.axioms(1) ring.function_mult_distr)
qed

lemma function_ring_uminus:
  assumes "cring R"
  assumes "a \<in> S"
  assumes "f \<in> carrier (function_ring S R)"
  shows "(\<ominus>\<^bsub>function_ring S R\<^esub> f) a = \<ominus>\<^bsub>R\<^esub> (f a)"
proof-
  have "((\<ominus>\<^bsub>function_ring S R\<^esub> f) \<oplus>\<^bsub>function_ring S R\<^esub> f) = \<zero>\<^bsub>function_ring S R\<^esub>"
    using assms cring_imp_Fun_is_cring[of R S]
    by (simp add: cring.cring_simprules(9))
  then have "((\<ominus>\<^bsub>function_ring S R\<^esub> f) \<oplus>\<^bsub>function_ring S R\<^esub> f) a = \<zero>\<^bsub>R\<^esub>"
    by (simp add: assms(1) assms(2) cring.axioms(1) ring.ring_function_zeroE)
  then show ?thesis
    by (metis assms(1) assms(2) assms(3) cring.axioms(1) cring.cring_simprules(3)
        cring_imp_Fun_is_cring ring.function_add_zeroR ring.function_uminus_addR
        ring.function_uminus_closed ring.function_uminus_eval ring.ring_simprules(18))
qed

text\<open>constant ring_functions\<close>

definition constant_function  where
"constant_function S a = restrict (\<lambda>_. a) S"

lemma constant_function[simp]:
  assumes "a \<in> carrier R"
  shows "constant_function S a \<in> carrier (function_ring S R)"
  using assms constant_function_def
  by (simp add: constant_function_def function_ring_car_memI)

lemma constant_function_add:
  assumes "a \<in> carrier R"
  assumes "b \<in> carrier R"
  shows "(constant_function S a) \<oplus>\<^bsub>(function_ring S R)\<^esub> (constant_function S b) =
          (constant_function S (a \<oplus>\<^bsub>R\<^esub> b)) "
  unfolding constant_function_def
  by (smt function_add_def function_ring_def restrict_apply' restrict_ext ring.simps(2))

lemma constant_function_mult:
  assumes "a \<in> carrier R"
  assumes "b \<in> carrier R"
  shows "(constant_function S a) \<otimes>\<^bsub>(function_ring S R)\<^esub> (constant_function S b) =
          (constant_function S (a \<otimes>\<^bsub>R\<^esub> b)) "
  unfolding constant_function_def
  by (smt function_mult_def function_ring_def monoid.simps(1) restrict_apply' restrict_ext)

lemma constant_function_minus:
  assumes "cring R"
  assumes "a \<in> carrier R"
  shows "\<ominus>\<^bsub>function_ring S R\<^esub>(constant_function S a) =
          (constant_function S (\<ominus>\<^bsub>R\<^esub> a)) "
  unfolding constant_function_def
  apply(rule ext)
  using assms function_ring_uminus[of R]
  by (smt cring.cring_simprules(3) cring_imp_Fun_is_cring function_ring_car_memI
      function_ring_not_car_simp restrict_apply)

context cring
begin

text\<open>Restricted algebraic operations\<close>

definition(in ring) ring_constant_function ("\<cc>\<index>") where
"ring_constant_function a = constant_function (carrier R) a"

lemma(in ring) ring_constant_function[simp]:
  assumes "a \<in> carrier R"
  shows "ring_constant_function a \<in> carrier (Fun R)"
  using assms constant_function_def
  by (simp add: ring_constant_function_def)

definition a_translate :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
"a_translate = (\<lambda> r \<in> carrier R. restrict ((add R) r) (carrier R))"

definition m_translate :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
"m_translate  = (\<lambda> r \<in> carrier R. restrict ((mult R) r) (carrier R))"

definition nat_power :: "nat \<Rightarrow> 'a \<Rightarrow> 'a" where
"nat_power = (\<lambda>(n::nat). restrict (\<lambda>a.  a[^]\<^bsub>R\<^esub>n) (carrier R)) "

text\<open>Restricted operations are in Fs\<close>

lemma a_translate_functions[simp]:
  assumes "c \<in> carrier R"
  shows "a_translate c \<in> carrier (Fun R)"
  apply(rule function_ring_car_memI)
  using assms a_translate_def
   apply simp
  using assms a_translate_def
  by simp

lemma m_translate_functions[simp]:
  assumes "c \<in> carrier R"
  shows "m_translate c \<in> carrier (Fun R)"
  apply(rule function_ring_car_memI)
  using assms m_translate_def
  apply simp
    using assms m_translate_def
  by simp

lemma nat_power_functions[simp]:
  shows "nat_power n \<in> carrier (Fun R)"
  apply(rule function_ring_car_memI)
  using  nat_power_def
   apply simp
  by (simp add: nat_power_def)

text\<open>Restricted operations simps\<close>

lemma a_translate_eq[simp]:
  assumes "c \<in> carrier R"
  assumes "a \<in> carrier R"
  shows "a_translate c a = c \<oplus> a"
  by (simp add: a_translate_def assms(1) assms(2))

lemma a_translate_eq'[simp]:
  assumes "c \<in> carrier R"
  assumes "a \<notin> carrier R"
  shows "a_translate c a = undefined "
  by (meson a_translate_functions assms(1) assms(2) function_ring_not_car_simp)

lemma a_translate_eq''[simp]:
  assumes "c \<notin> carrier R"
  shows "a_translate c = undefined"
  by (simp add: a_translate_def assms)

lemma m_translate_eq[simp]:
  assumes "c \<in> carrier R"
  assumes "a \<in> carrier R"
  shows "m_translate c a = c \<otimes> a"
  by (simp add: m_translate_def assms(1) assms(2))

lemma m_translate_eq'[simp]:
  assumes "c \<in> carrier R"
  assumes "a \<notin> carrier R"
  shows "m_translate c a = undefined "
  by (meson m_translate_functions assms(1) assms(2) function_ring_not_car_simp)

lemma m_translate_eq''[simp]:
  assumes "c \<notin> carrier R"
  shows "m_translate c = undefined"
  by (simp add: m_translate_def assms)

lemma nat_power_eq[simp]:
  assumes "a \<in> carrier R"
  shows "nat_power n a = a[^]\<^bsub>R\<^esub> n"
  by (simp add: assms nat_power_def)

lemma nat_power_eq'[simp]:
  assumes "a \<notin> carrier R"
  shows "nat_power n a = undefined"
  by (simp add: assms nat_power_def)

text\<open>Constant ring_function properties\<close>

lemma constant_function_eq[simp]:
  assumes "a \<in> carrier R"
  assumes "b \<in> carrier R"
  shows "\<cc>\<^bsub>a\<^esub> b = a"
  by (simp add: assms(2) constant_function_def ring_constant_function_def)

lemma constant_function_eq'[simp]:
  assumes "a \<in> carrier R"
  assumes "b \<notin> carrier R"
  shows "\<cc>\<^bsub>a\<^esub> b = undefined"
  by (simp add: assms(2) constant_function_def ring_constant_function_def)

lemma constant_zero[simp]:
"\<cc>\<^bsub>\<zero>\<^esub> = \<zero>\<^bsub>Fun R\<^esub>"
proof(rule ext)
  show "\<And>x. \<cc>\<^bsub>\<zero>\<^esub> x = \<zero>\<^bsub>Fun R\<^esub> x"
  by (smt constant_function_eq constant_function_eq' function_ring_def function_zero_closed
      mem_Collect_eq partial_object.select_convs(1) restrict_def ring_function_zeroE zero_closed)
qed

lemma constant_one[simp]:
"\<cc>\<^bsub>\<one>\<^esub> = \<one>\<^bsub>Fun R\<^esub>"
  apply(rule ext)
  by (smt constant_function_eq constant_function_eq' cring_def function_ring_def is_cring
      mem_Collect_eq one_closed partial_object.select_convs(1) restrict_def
      ring.function_oneE ring.function_one_closed)

lemma constant_add[simp]:
  assumes "a \<in> carrier R"
  assumes "b \<in> carrier R"
  shows "\<cc>\<^bsub>a \<oplus> b\<^esub> = \<cc>\<^bsub>a\<^esub> \<oplus>\<^bsub>Fun R\<^esub> \<cc>\<^bsub>b\<^esub>"
proof
  fix x
  show " \<cc>\<^bsub>a \<oplus> b\<^esub> x = (\<cc>\<^bsub>a\<^esub> \<oplus>\<^bsub>Fun R\<^esub> \<cc>\<^bsub>b\<^esub>) x"
    apply(cases "x \<in> carrier R")
     apply (metis (full_types) add.m_closed assms(1) assms(2) constant_function
      constant_function_eq ring_constant_function_def ring_function_addE)
      by (metis (mono_tags, lifting) add.m_closed assms(1) assms(2) constant_function
      function_add_closed' function_ring_not_car_simp ring_constant_function_def)
qed

lemma constant_mult[simp]:
  assumes "a \<in> carrier R"
  assumes "b \<in> carrier R"
  shows "\<cc>\<^bsub>a \<otimes> b\<^esub> = \<cc>\<^bsub>a\<^esub> \<otimes>\<^bsub>Fun R\<^esub> \<cc>\<^bsub>b\<^esub>"
proof
  fix x
  show "\<cc>\<^bsub>a \<otimes> b\<^esub> x = (\<cc>\<^bsub>a\<^esub> \<otimes>\<^bsub>Fun R\<^esub> \<cc>\<^bsub>b\<^esub>) x"
    apply(cases "x \<in> carrier R")
     apply (metis assms(1) assms(2) constant_function constant_function_eq
      function_multE m_closed ring_constant_function_def)
      by (metis (no_types, lifting) constant_function_def function_mult_def function_ring_def
       monoid.simps(1) restrict_apply ring_constant_function_def)
qed

text\<open>Compound expressions from algebraic operations\<close>

definition monomial where
"monomial c n = restricted_comp (m_translate c)  (nat_power n)"

lemma monomial_functions:
  assumes "c \<in> carrier R"
  shows "monomial c n \<in> carrier (Fun R)"
  by (simp add: assms monomial_def)

abbreviation ring_id ("X") where
"ring_id \<equiv> restrict (\<lambda>x. x) (carrier R) "

lemma ring_id_carrier[simp]:
"ring_id \<in> carrier (Fun R)"
  by (simp add: function_ring_car_memI)

lemma ring_id_def[simp]:
  assumes "a \<in> carrier R"
  shows "X a = a"
  by (simp add: assms)

lemma constant_a_trans:
  assumes "a \<in>carrier R"
  shows "m_translate a  = \<cc>\<^bsub>a\<^esub> \<otimes>\<^bsub>Fun R\<^esub> X"
proof(rule function_ring_car_eqI)
   show "m_translate a \<in> carrier (Fun R)"
     using assms
     using m_translate_functions by blast
   show "\<cc>\<^bsub>a\<^esub> \<otimes>\<^bsub>Fun R\<^esub> X \<in> carrier (Fun R)"
     using assms constant_function function_mult_closed' ring_id_carrier
     by simp
  show "\<And>x. x \<in> carrier R \<Longrightarrow> m_translate a x = (\<cc>\<^bsub>a\<^esub> \<otimes>\<^bsub>Fun R\<^esub> X) x"
    using assms
    by simp
qed

fun polynomial :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a)" where
"polynomial []  = \<zero>\<^bsub>Fun R\<^esub> "|
"polynomial (a#as) = restricted_comp (a_translate a) (X \<otimes>\<^bsub>Fun R\<^esub> (polynomial as))"

lemma polynomial_function:
  shows "set as \<subseteq> carrier R \<Longrightarrow> polynomial as \<in> carrier (Fun R)"
  apply(induct as)
   apply simp
proof-
  show " \<And>a as. (set as \<subseteq> carrier R \<Longrightarrow> polynomial as \<in> carrier (Fun R))
            \<Longrightarrow> set (a # as) \<subseteq> carrier R \<Longrightarrow> polynomial (a # as) \<in> carrier (Fun R)"
    by simp
qed

lemma polynomial_constant[simp]:
  assumes "a \<in> carrier R"
  shows "polynomial [a] = \<cc>\<^bsub>a\<^esub>"
proof(rule function_ring_car_eqI)
  show "polynomial [a] \<in> carrier (Fun R)"
using assms
  by simp
  show " \<cc>\<^bsub>a\<^esub> \<in> carrier (Fun R)"
    using assms
    by simp
  show "\<And>aa. aa \<in> carrier R \<Longrightarrow> polynomial [a] aa = \<cc>\<^bsub>a\<^esub> aa"
    using assms by simp
qed

lemma polynomial_monomial:
  assumes "a \<in> carrier R"
  shows "polynomial [\<zero>, a] =  \<cc>\<^bsub>a\<^esub> \<otimes>\<^bsub>Fun R\<^esub>  X"
  apply(rule function_ring_car_eqI[of "polynomial [\<zero>, a]" "(carrier R)" R])
  using assms
    apply simp
  using assms constant_function function_mult_closed' ring_id_carrier
  apply simp
proof-
   fix x
   assume A: "x \<in> carrier R"
   have "polynomial [\<zero>, a] x = restricted_comp (a_translate \<zero>) (X \<otimes>\<^bsub>Fun R\<^esub> (polynomial [a])) x"
     by simp
  then have  "polynomial [\<zero>, a] x = ((a_translate \<zero>) \<circ> (X \<otimes>\<^bsub>Fun R\<^esub> (polynomial [a]))) x"
    using assms A by auto
  then have A0:  "polynomial [\<zero>, a] x = \<zero> \<oplus> (X \<otimes>\<^bsub>Fun R\<^esub> (polynomial [a])) x"
    using assms A by simp
  then show "polynomial [\<zero>, a] x = ( \<cc>\<^bsub>a\<^esub> \<otimes>\<^bsub>Fun R\<^esub>  X) x" using A assms
    by (simp add: m_comm)
qed

end

text\<open>Maps between structures\<close>

definition struct_maps :: "('a, 'c) partial_object_scheme \<Rightarrow> ('b, 'd) partial_object_scheme
                              \<Rightarrow> ('a \<Rightarrow> 'b) set" where
"struct_maps T S = {f. (f \<in> (carrier T) \<rightarrow> (carrier S)) \<and> f = restrict f (carrier T) }"

definition to_struct_map where
"to_struct_map T f = restrict f (carrier T)"

lemma to_struct_map_eq:
  assumes "f \<in> (carrier T) \<rightarrow> (carrier S)"
  shows "to_struct_map T f \<in> (struct_maps T S)"
  by (smt PiE_restrict Pi_iff assms mem_Collect_eq restrict_PiE struct_maps_def to_struct_map_def)

lemma struct_mapsI:
  assumes "\<And> x. x \<in> carrier T \<Longrightarrow> f x \<in> carrier S"
  assumes "\<And>x. x \<notin> carrier T \<Longrightarrow> f x = undefined"
  shows "f \<in> struct_maps T S"
proof-
  have 0: " (f \<in> (carrier T) \<rightarrow> (carrier S))"
    using assms
    by blast
  have 1: "f  = restrict f (carrier T)"
    using assms
    by (simp add: extensional_def extensional_restrict)
  show ?thesis
    using 0 1
    unfolding struct_maps_def
    by blast
qed

lemma struct_mapsE:
  assumes "f \<in> struct_maps T S"
  shows  "\<And> x. x \<in> carrier T \<Longrightarrow> f x \<in> carrier S"
         "\<And>x. x \<notin> carrier T \<Longrightarrow> f x = undefined"
  using assms unfolding struct_maps_def
  apply blast
    using assms unfolding struct_maps_def
    by (metis (mono_tags, lifting) mem_Collect_eq restrict_apply)

definition s_comp where
"s_comp S f g = restrict (f \<circ> g) (carrier S)"

lemma struct_map_comp[simp]:
  assumes "g \<in> (struct_maps T S)"
  assumes "f \<in> (struct_maps S U)"
  shows "s_comp T f g \<in> (struct_maps T U)"
proof(rule struct_mapsI)
  show "\<And>x. x \<in> carrier T \<Longrightarrow> s_comp T f g x \<in> carrier U"
    using assms struct_mapsE(1)
    by (metis comp_apply restrict_def s_comp_def)
  show " \<And>x. x \<notin> carrier T \<Longrightarrow> s_comp T f g x = undefined"
    by (simp add: s_comp_def)
qed

lemma s_comp_simp[simp]:
  assumes "g \<in> (struct_maps T S)"
  assumes "f \<in> (struct_maps S U)"
  assumes "a \<in> (carrier T)"
  shows "(s_comp T f g) a = (f \<circ> g) a"
  by (simp add: assms(3) s_comp_def)

lemma s_comp_simp'[simp]:
  assumes "g \<in> (struct_maps T S)"
  assumes "f \<in> (struct_maps S U)"
  assumes "a \<notin> (carrier T)"
  shows "(s_comp T f g) a = undefined"
  by (simp add: assms(3) s_comp_def)

definition pullback ::
    "('a, 'd) partial_object_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'c)" where
"pullback T f g = s_comp T g f"

lemma pullback_closed:
  assumes "f \<in> (struct_maps T S)"
  assumes "g \<in> (struct_maps S U)"
  shows "pullback T f g \<in> (struct_maps T U)"
  by (metis assms(1) assms(2) pullback_def struct_map_comp)

definition pushforward ::
    "('a, 'd) partial_object_scheme \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b)  \<Rightarrow> ('a \<Rightarrow> 'c)" where
"pushforward T f g \<equiv> s_comp T f g"

lemma pushforward_closed:
  assumes "g \<in> (struct_maps T S)"
  assumes "f \<in> (struct_maps S U)"
  shows "pushforward T f g \<in> (struct_maps T U)"
  using assms(1) assms(2) struct_map_comp
  by (metis pushforward_def)

end


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

theory Examples
  imports Bitwise Next_and_Prev Generic_set_bit Word_Syntax Signed_Division_Word
begin

text "modulus"

lemma "(27 :: 4 word) = -5" by simp

lemma "(27 :: 4 word) = 11" by simp

lemma "27 \<noteq> (11 :: 6 word)" by simp

text "signed"

lemma "(127 :: 6 word) = -1" by simp

text "number ring simps"

lemma
  "27 + 11 = (38::'a::len word)"
  "27 + 11 = (6::5 word)"
  "7 * 3 = (21::'a::len word)"
  "11 - 27 = (-16::'a::len word)"
  "- (- 11) = (11::'a::len word)"
  "-40 + 1 = (-39::'a::len word)"
  by simp_all

lemma "word_pred 2 = 1" by simp

lemma "word_succ (- 3) = -2" by simp

lemma "23 < (27::8 word)" by simp
lemma "23 \<le> (27::8 word)" by simp
lemma "\<not> 23 < (27::2 word)" by simp
lemma "0 < (4::3 word)" by simp
lemma "1 < (4::3 word)" by simp
lemma "0 < (1::3 word)" by simp

text "ring operations"

lemma "a + 2 * b + c - b = (b + c) + (a :: 32 word)" by simp

text "casting"

lemma "uint (234567 :: 10 word) = 71" by simp
lemma "uint (-234567 :: 10 word) = 953" by simp
lemma "sint (234567 :: 10 word) = 71" by simp
lemma "sint (-234567 :: 10 word) = -71" by simp
lemma "uint (1 :: 10 word) = 1" by simp

lemma "unat (-234567 :: 10 word) = 953" by simp
lemma "unat (1 :: 10 word) = 1" by simp

lemma "ucast (0b1010 :: 4 word) = (0b10 :: 2 word)" by simp
lemma "ucast (0b1010 :: 4 word) = (0b1010 :: 10 word)" by simp
lemma "scast (0b1010 :: 4 word) = (0b111010 :: 6 word)" by simp
lemma "ucast (1 :: 4 word) = (1 :: 2 word)" by simp

text "reducing goals to nat or int and arith:"
lemma "i < x \<Longrightarrow> i < i + 1" for i x :: "'a::len word"
  by unat_arith
lemma "i < x \<Longrightarrow> i < i + 1" for i x :: "'a::len word"
  by unat_arith

text "bool lists"

lemma "of_bl [True, False, True, True] = (0b1011::'a::len word)" by simp

lemma "to_bl (0b110::4 word) = [False, True, True, False]" by simp

lemma "of_bl (replicate 32 True) = (0xFFFFFFFF::32 word)"
  by (simp add: numeral_eq_Suc)

text "bit operations"

lemma "0b110 AND 0b101 = (0b100 :: 32 word)" by simp
lemma "0b110 OR 0b011 = (0b111 :: 8 word)" by simp
lemma "0xF0 XOR 0xFF = (0x0F :: 8 word)" by simp
lemma "NOT (0xF0 :: 16 word) = 0xFF0F" by simp
lemma "0 AND 5 = (0 :: 8 word)" by simp
lemma "1 AND 1 = (1 :: 8 word)" by simp
lemma "1 AND 0 = (0 :: 8 word)" by simp
lemma "1 AND 5 = (1 :: 8 word)" by simp
lemma "1 OR 6 = (7 :: 8 word)" by simp
lemma "1 OR 1 = (1 :: 8 word)" by simp
lemma "1 XOR 7 = (6 :: 8 word)" by simp
lemma "1 XOR 1 = (0 :: 8 word)" by simp
lemma "NOT 1 = (254 :: 8 word)" by simp
lemma "NOT 0 = (255 :: 8 word)" by simp

lemma "(-1 :: 32 word) = 0xFFFFFFFF" by simp

lemma "(0b0010 :: 4 word) !! 1" by simp
lemma "\<not> (0b0010 :: 4 word) !! 0" by simp
lemma "\<not> (0b1000 :: 3 word) !! 4" by simp
lemma "\<not> (1 :: 3 word) !! 2" by simp

lemma "(0b11000 :: 10 word) !! n = (n = 4 \<or> n = 3)"
  by (auto simp add: bin_nth_Bit0 bin_nth_Bit1)

lemma "set_bit 55 7 True = (183::'a::len word)" by simp
lemma "set_bit 0b0010 7 True = (0b10000010::'a::len word)" by simp
lemma "set_bit 0b0010 1 False = (0::'a::len word)" by simp
lemma "set_bit 1 3 True = (0b1001::'a::len word)" by simp
lemma "set_bit 1 0 False = (0::'a::len word)" by simp
lemma "set_bit 0 3 True = (0b1000::'a::len word)" by simp
lemma "set_bit 0 3 False = (0::'a::len word)" by simp

lemma "odd (0b0101::'a::len word)" by simp
lemma "even (0b1000::'a::len word)" by simp
lemma "odd (1::'a::len word)" by simp
lemma "even (0::'a::len word)" by simp

lemma "\<not> msb (0b0101::4 word)" by simp
lemma   "msb (0b1000::4 word)" by simp
lemma "\<not> msb (1::4 word)" by simp
lemma "\<not> msb (0::4 word)" by simp

lemma "word_cat (27::4 word) (27::8 word) = (2843::'a::len word)" by simp
lemma "word_cat (0b0011::4 word) (0b1111::6word) = (0b0011001111 :: 10 word)"
  by simp

lemma "0b1011 << 2 = (0b101100::'a::len word)" by simp
lemma "0b1011 >> 2 = (0b10::8 word)" by simp
lemma "0b1011 >>> 2 = (0b10::8 word)" by simp
lemma "1 << 2 = (0b100::'a::len word)" apply simp? oops

lemma "slice 3 (0b101111::6 word) = (0b101::3 word)" by simp
lemma "slice 3 (1::6 word) = (0::3 word)" apply simp? oops

lemma "word_rotr 2 0b0110 = (0b1001::4 word)" by simp
lemma "word_rotl 1 0b1110 = (0b1101::4 word)" by simp
lemma "word_roti 2 0b1110 = (0b1011::4 word)" by simp
lemma "word_roti (- 2) 0b0110 = (0b1001::4 word)" by simp
lemma "word_rotr 2 0 = (0::4 word)" by simp
lemma "word_rotr 2 1 = (0b0100::4 word)" apply simp? oops
lemma "word_rotl 2 1 = (0b0100::4 word)" apply simp? oops
lemma "word_roti (- 2) 1 = (0b0100::4 word)" apply simp? oops

lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)"
proof -
  have "(x AND 0xff00) OR (x AND 0x00ff) = x AND (0xff00 OR 0x00ff)"
    by (simp only: word_ao_dist2)
  also have "0xff00 OR 0x00ff = (-1::16 word)"
    by simp
  also have "x AND -1 = x"
    by simp
  finally show ?thesis .
qed

text "proofs using bitwise expansion"

lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)"
  by word_bitwise

lemma "(x AND NOT 3) >> 4 << 2 = ((x >> 2) AND NOT 3)"
  for x :: "10 word"
  by word_bitwise

lemma "((x AND -8) >> 3) AND 7 = (x AND 56) >> 3"
  for x :: "12 word"
  by word_bitwise

text "some problems require further reasoning after bit expansion"

lemma "x \<le> 42 \<Longrightarrow> x \<le> 89"
  for x :: "8 word"
  apply word_bitwise
  apply blast
  done

lemma "(x AND 1023) = 0 \<Longrightarrow> x \<le> -1024"
  for x :: \<open>32 word\<close>
  apply word_bitwise
  apply clarsimp
  done

text "operations like shifts by non-numerals will expose some internal list
 representations but may still be easy to solve"

lemma shiftr_overflow: "32 \<le> a \<Longrightarrow> b >> a = 0"
  for b :: \<open>32 word\<close>
  apply word_bitwise
  apply simp
  done

(* testing for presence of word_bitwise *)
lemma "((x :: 32 word) >> 3) AND 7 = (x AND 56) >> 3"
  by word_bitwise

(* Tests *)
lemma
  "( 4 :: 32 word) sdiv  4 =  1"
  "(-4 :: 32 word) sdiv  4 = -1"
  "(-3 :: 32 word) sdiv  4 =  0"
  "( 3 :: 32 word) sdiv -4 =  0"
  "(-3 :: 32 word) sdiv -4 =  0"
  "(-5 :: 32 word) sdiv -4 =  1"
  "( 5 :: 32 word) sdiv -4 = -1"
  by (simp_all add: sdiv_word_def signed_divide_int_def)

lemma
  "( 4 :: 32 word) smod  4 =   0"
  "( 3 :: 32 word) smod  4 =   3"
  "(-3 :: 32 word) smod  4 =  -3"
  "( 3 :: 32 word) smod -4 =   3"
  "(-3 :: 32 word) smod -4 =  -3"
  "(-5 :: 32 word) smod -4 =  -1"
  "( 5 :: 32 word) smod -4 =   1"
  by (simp_all add: smod_word_def signed_modulo_int_def signed_divide_int_def)

lemma "1 < (1024::32 word) \<and> 1 \<le> (1024::32 word)"
  by simp

end


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

theory Word_Next
imports
  Aligned
begin

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

definition word_next :: "'a::len word \<Rightarrow> 'a::len word" where
  "word_next a \<equiv> if a = max_word then max_word else a + 1"

definition word_prev :: "'a::len word \<Rightarrow> 'a::len word" where
  "word_prev a \<equiv> if a = 0 then 0 else a - 1"

text\<open>Examples:\<close>

lemma plus_one_helper[elim!]:
  "x < n + (1 :: 'a :: len word) \<Longrightarrow> x \<le> n"
  apply (simp add: word_less_nat_alt word_le_nat_alt field_simps)
  apply (case_tac "1 + n = 0")
   apply simp
  apply (subst(asm) unatSuc, assumption)
  apply arith
  done

lemma less_x_plus_1:
  fixes x :: "'a :: len word" shows
  "x \<noteq> max_word \<Longrightarrow> (y < (x + 1)) = (y < x \<or> y = x)"
  apply (rule iffI)
   apply (rule disjCI)
   apply (drule plus_one_helper)
   apply simp
  apply (subgoal_tac "x < x + 1")
   apply (erule disjE, simp_all)
  apply (rule plus_one_helper2 [OF order_refl])
  apply (rule notI, drule max_word_wrap)
  apply simp
  done

lemma word_Suc_leq: fixes k::"'a::len word" shows "k \<noteq> max_word \<Longrightarrow> x < k + 1 \<longleftrightarrow> x \<le> k"
  using less_x_plus_1 word_le_less_eq by auto

lemma word_Suc_le: fixes k::"'a::len word" shows "x \<noteq> max_word \<Longrightarrow> x + 1 \<le> k \<longleftrightarrow> x < k"
  by (meson not_less word_Suc_leq)

lemma word_lessThan_Suc_atMost: fixes k::"'a::len word" shows "k \<noteq> max_word \<Longrightarrow> {..< k + 1} = {..k}"
  by(simp add: lessThan_def atMost_def word_Suc_leq)

lemma word_atLeastLessThan_Suc_atLeastAtMost:
  fixes l::"'a::len word" shows "u \<noteq> max_word \<Longrightarrow> {l..< u + 1} = {l..u}"
  by (simp add: atLeastAtMost_def atLeastLessThan_def word_lessThan_Suc_atMost)

lemma word_atLeastAtMost_Suc_greaterThanAtMost: fixes l::"'a::len word"
  shows "m \<noteq> max_word \<Longrightarrow> {m<..u} = {m + 1..u}"
  by(simp add: greaterThanAtMost_def greaterThan_def atLeastAtMost_def atLeast_def word_Suc_le)

lemma word_atLeastLessThan_Suc_atLeastAtMost_union:
  fixes l::"'a::len word"
  assumes "m \<noteq> max_word" and "l \<le> m" and "m \<le> u"
  shows "{l..m} \<union> {m+1..u} = {l..u}"
  proof -
  from ivl_disj_un_two(8)[OF assms(2) assms(3)] have "{l..u} = {l..m} \<union> {m<..u}" by blast
  with assms show ?thesis by(simp add: word_atLeastAtMost_Suc_greaterThanAtMost)
  qed

lemma word_adjacent_union:
  "word_next e = s' \<Longrightarrow> s \<le> e \<Longrightarrow> s' \<le> e' \<Longrightarrow> {s..e} \<union> {s'..e'} = {s .. e'}"
  by (metis Un_absorb2 atLeastatMost_subset_iff ivl_disj_un_two(7) max_word_max
            word_atLeastLessThan_Suc_atLeastAtMost word_le_less_eq word_next_def linorder_not_le)

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Explicit Formulas for Roots\<close>

text \<open>We provide algorithms which use the explicit formulas to
  compute the roots of polynomials of degree up to 2. We also define the formula for
  polynomials of degree 3, but did not (yet) prove anything about it.\<close>

theory Explicit_Roots
imports
  Polynomial_Interpolation.Missing_Polynomial
  Sqrt_Babylonian.Sqrt_Babylonian
begin

lemma roots0: assumes p: "p \<noteq> 0" and p0: "degree p = 0"
  shows "{x. poly p x = 0} = {}"
  using degree0_coeffs[OF p0] p by auto

definition roots1 :: "'a :: field poly \<Rightarrow> 'a" where
  "roots1 p = (- coeff p 0 / coeff p 1)"

lemma roots1: fixes p :: "'a :: field poly"
  assumes p1: "degree p = 1"
  shows "{x. poly p x = 0} = {roots1 p}"
  using degree1_coeffs[OF p1] unfolding roots1_def
  by (auto simp: add_eq_0_iff nonzero_neg_divide_eq_eq2)

lemma roots2: fixes p :: "'a :: field_char_0 poly"
  assumes p2: "p = [: c, b, a :]" and a: "a \<noteq> 0"
  shows "{x. poly p x = 0} = { - ( b / (2 * a)) + e | e. e^2 = ( b / (2 * a))^2 - c/a}" (is "?l = ?r")
proof -
  define b2a where "b2a = b / (2 * a)"
  {
    fix x
    have "(x \<in> ?l) = (x * x * a + x * b + c = 0)" unfolding p2 by (simp add: field_simps)
    also have "\<dots> = ((x * x + 2 * x * b2a) + c/a = 0)" using a by (auto simp: b2a_def field_simps)
    also have "x * x + 2 * x * b2a = (x * x + 2 * x * b2a + b2a^2) - b2a^2" by simp
    also have "\<dots> = (x + b2a) ^ 2 - b2a ^ 2"
      by (simp add: field_simps power2_eq_square)
    also have "(\<dots> + c / a = 0) = ((x + b2a) ^ 2 = b2a^2 - c/a)" by algebra
    also have "\<dots> = (x \<in> ?r)" unfolding b2a_def[symmetric] by (auto simp: field_simps)
    finally have "(x \<in> ?l) = (x \<in> ?r)" .
  }
  thus ?thesis by auto
qed

definition croots2 :: "complex poly \<Rightarrow> complex list" where
  "croots2 p = (let a = coeff p 2; b = coeff p 1; c = coeff p 0; b2a = b / (2 * a);
    bac = b2a^2 - c/a;
    e = csqrt bac
    in
     remdups [- b2a + e, - b2a - e])"

definition complex_rat :: "complex \<Rightarrow> bool" where
  "complex_rat x = (Re x \<in> \<rat> \<and> Im x \<in> \<rat>)"

lemma croots2: assumes "degree p = 2"
  shows "{x. poly p x = 0} = set (croots2 p)"
proof -
  from degree2_coeffs[OF assms] obtain a b c
  where p: "p = [:c, b, a:]" and a: "a \<noteq> 0" by auto
  note main = roots2[OF p a]
  have 2: "2 = Suc (Suc 0)" by simp
  have coeff: "coeff p 2 = a" "coeff p 1 = b" "coeff p 0 = c" unfolding p by (auto simp: 2)
  let ?b2a = "b / (2 * a)"
  define b2a where "b2a = ?b2a"
  let ?bac = "b2a^2 - c/a"
  define bac where "bac = ?bac"
  have roots: "set (croots2 p) = {- b2a + csqrt bac, - b2a - csqrt bac}"
    unfolding croots2_def Let_def coeff b2a_def[symmetric] bac_def[symmetric]
    by (auto split: if_splits)
  show ?thesis unfolding roots main b2a_def[symmetric] bac_def[symmetric]
    using power2_eq_iff by fastforce
qed

definition rroots2 :: "real poly \<Rightarrow> real list" where
  "rroots2 p = (let a = coeff p 2; b = coeff p 1; c = coeff p 0; b2a = b / (2 * a);
    bac = b2a^2 - c/a
  in if bac = 0 then [- b2a] else if bac < 0 then []
    else let e = sqrt bac
    in
     [- b2a + e, - b2a - e])"

definition rat_roots2 :: "rat poly \<Rightarrow> rat list" where
  "rat_roots2 p = (let a = coeff p 2; b = coeff p 1; c = coeff p 0; b2a = b / (2 * a);
    bac = b2a^2 - c/a
  in map (\<lambda> e. - b2a + e) (sqrt_rat bac))"

lemma rroots2: assumes "degree p = 2"
  shows "{x. poly p x = 0} = set (rroots2 p)"
proof -
  from degree2_coeffs[OF assms] obtain a b c
  where p: "p = [:c, b, a:]" and a: "a \<noteq> 0" by auto
  note main = roots2[OF p a]
  have 2: "2 = Suc (Suc 0)" by simp
  have coeff: "coeff p 2 = a" "coeff p 1 = b" "coeff p 0 = c" unfolding p by (auto simp: 2)
  let ?b2a = "b / (2 * a)"
  define b2a where "b2a = ?b2a"
  let ?bac = "b2a^2 - c/a"
  define bac where "bac = ?bac"
  have roots: "set (rroots2 p) = (if bac < 0 then {} else {- b2a + sqrt bac, - b2a - sqrt bac})"
    unfolding rroots2_def Let_def coeff b2a_def[symmetric] bac_def[symmetric]
    by (auto split: if_splits)
  show ?thesis unfolding roots main b2a_def[symmetric] bac_def[symmetric]
    by auto
qed

lemma rat_roots2: assumes "degree p = 2"
  shows "{x. poly p x = 0} = set (rat_roots2 p)"
proof -
  from degree2_coeffs[OF assms] obtain a b c
  where p: "p = [:c, b, a:]" and a: "a \<noteq> 0" by auto
  note main = roots2[OF p a]
  have 2: "2 = Suc (Suc 0)" by simp
  have coeff: "coeff p 2 = a" "coeff p 1 = b" "coeff p 0 = c" unfolding p by (auto simp: 2)
  let ?b2a = "b / (2 * a)"
  define b2a where "b2a = ?b2a"
  let ?bac = "b2a^2 - c/a"
  define bac where "bac = ?bac"
  have roots: "(rat_roots2 p) = (map (\<lambda> e. -b2a + e) (sqrt_rat bac))"
    unfolding rat_roots2_def Let_def coeff b2a_def[symmetric] bac_def[symmetric] by auto
  show ?thesis unfolding roots main b2a_def[symmetric] bac_def[symmetric]
    by (auto simp: power2_eq_square)
qed

text \<open>Determinining roots of complex polynomials of degree up to 2.\<close>

definition croots :: "complex poly \<Rightarrow> complex list" where
  "croots p = (if p = 0 \<or> degree p > 2 then []
    else (if degree p = 0 then [] else if degree p = 1 then [roots1 p]
    else croots2 p))"

lemma croots: assumes "p \<noteq> 0" "degree p \<le> 2"
  shows "set (croots p) = {x. poly p x = 0}"
  using assms unfolding croots_def
  using roots0[of p] roots1[of p] croots2[of p]
  by (auto split: if_splits)

text \<open>Determinining roots of real polynomials of degree up to 2.\<close>

definition rroots :: "real poly \<Rightarrow> real list" where
  "rroots p = (if p = 0 \<or> degree p > 2 then []
    else (if degree p = 0 then [] else if degree p = 1 then [roots1 p]
    else rroots2 p))"

lemma rroots: assumes "p \<noteq> 0" "degree p \<le> 2"
  shows "set (rroots p) = {x. poly p x = 0}"
  using assms unfolding rroots_def
  using roots0[of p] roots1[of p] rroots2[of p]
  by (auto split: if_splits)

text \<open>Although there is a closed form for cubic roots,
  which is specified below, we did not yet integrate it into the
 @{const croots} and @{const rroots} algorithms.
 One obstracle is that for complex numbers, the cubic root is not
 even defined. Therefore, we also did not proof soundness of the croots3 algorithm.\<close>

context
  fixes croot :: "nat \<Rightarrow> complex \<Rightarrow> complex"
begin

definition croots3 :: "complex poly \<Rightarrow> complex \<times> complex \<times> complex \<times> complex" where
  "croots3 p = (let a = coeff p 3; b = coeff p 2; c = coeff p 1; d = coeff p 0;
    \<Delta>\<^sub>0 = b^2 - 3 * a * c;
    \<Delta>\<^sub>1 = 2 * b^3 - 9 * a * b * c + 27 * a^2 * d;
    C = croot 3 ((\<Delta>\<^sub>1 + csqrt ( \<Delta>\<^sub>1^2 - 4 * \<Delta>\<^sub>0^3)) / 2);
    u\<^sub>1 = 1;
    u\<^sub>2 = (-1 + \<i> * csqrt 3) / 2;
    u\<^sub>3 = (-1 - \<i> * csqrt 3) / 2;
    x\<^sub>k = (\<lambda> u. (-1 / (3 * a)) * (b + u * C + \<Delta>\<^sub>0 / (u * C)))
    in
     (x\<^sub>k u\<^sub>1, x\<^sub>k u\<^sub>2, x\<^sub>k u\<^sub>3, a))"
end
end


(*  Title:      HOL/Algebra/RingHom.thy
    Author:     Stephan Hohe, TU Muenchen
*)

theory RingHom
imports Ideal
begin

section \<open>Homomorphisms of Non-Commutative Rings\<close>

text \<open>Lifting existing lemmas in a \<open>ring_hom_ring\<close> locale\<close>
locale ring_hom_ring = R?: ring R + S?: ring S
    for R (structure) and S (structure) +
  fixes h
  assumes homh: "h \<in> ring_hom R S"
  notes hom_mult [simp] = ring_hom_mult [OF homh]
    and hom_one [simp] = ring_hom_one [OF homh]

sublocale ring_hom_cring \<subseteq> ring: ring_hom_ring
  by standard (rule homh)

sublocale ring_hom_ring \<subseteq> abelian_group?: abelian_group_hom R S
proof
  show "h \<in> hom (add_monoid R) (add_monoid S)"
    using homh by (simp add: hom_def ring_hom_def)
qed

lemma (in ring_hom_ring) is_ring_hom_ring:
  "ring_hom_ring R S h"
  by (rule ring_hom_ring_axioms)

lemma ring_hom_ringI:
  fixes R (structure) and S (structure)
  assumes "ring R" "ring S"
  assumes hom_closed: "!!x. x \<in> carrier R ==> h x \<in> carrier S"
      and compatible_mult: "\<And>x y. [| x \<in> carrier R; y \<in> carrier R |] ==> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
      and compatible_add: "\<And>x y. [| x \<in> carrier R; y \<in> carrier R |] ==> h (x \<oplus> y) = h x \<oplus>\<^bsub>S\<^esub> h y"
      and compatible_one: "h \<one> = \<one>\<^bsub>S\<^esub>"
  shows "ring_hom_ring R S h"
proof -
  interpret ring R by fact
  interpret ring S by fact
  show ?thesis
  proof
    show "h \<in> ring_hom R S"
      unfolding ring_hom_def
      by (auto simp: compatible_mult compatible_add compatible_one hom_closed)
  qed
qed

lemma ring_hom_ringI2:
  assumes "ring R" "ring S"
  assumes h: "h \<in> ring_hom R S"
  shows "ring_hom_ring R S h"
proof -
  interpret R: ring R by fact
  interpret S: ring S by fact
  show ?thesis
  proof
    show "h \<in> ring_hom R S"
      using h .
  qed
qed

lemma ring_hom_ringI3:
  fixes R (structure) and S (structure)
  assumes "abelian_group_hom R S h" "ring R" "ring S"
  assumes compatible_mult: "\<And>x y. [| x \<in> carrier R; y \<in> carrier R |] ==> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
      and compatible_one: "h \<one> = \<one>\<^bsub>S\<^esub>"
  shows "ring_hom_ring R S h"
proof -
  interpret abelian_group_hom R S h by fact
  interpret R: ring R by fact
  interpret S: ring S by fact
  show ?thesis
  proof
    show "h \<in> ring_hom R S"
      unfolding ring_hom_def by (auto simp: compatible_one compatible_mult)
  qed
qed

lemma ring_hom_cringI:
  assumes "ring_hom_ring R S h" "cring R" "cring S"
  shows "ring_hom_cring R S h"
proof -
  interpret ring_hom_ring R S h by fact
  interpret R: cring R by fact
  interpret S: cring S by fact
  show ?thesis
  proof
    show "h \<in> ring_hom R S"
      by (simp add: homh)
  qed
qed

subsection \<open>The Kernel of a Ring Homomorphism\<close>

\<comment> \<open>the kernel of a ring homomorphism is an ideal\<close>
lemma (in ring_hom_ring) kernel_is_ideal: "ideal (a_kernel R S h) R"
  apply (rule idealI [OF R.ring_axioms])
    apply (rule additive_subgroup.a_subgroup[OF additive_subgroup_a_kernel])
   apply (auto simp: a_kernel_def')
  done

text \<open>Elements of the kernel are mapped to zero\<close>
lemma (in abelian_group_hom) kernel_zero [simp]:
  "i \<in> a_kernel R S h \<Longrightarrow> h i = \<zero>\<^bsub>S\<^esub>"
by (simp add: a_kernel_defs)

subsection \<open>Cosets\<close>

text \<open>Cosets of the kernel correspond to the elements of the image of the homomorphism\<close>
lemma (in ring_hom_ring) rcos_imp_homeq:
  assumes acarr: "a \<in> carrier R"
      and xrcos: "x \<in> a_kernel R S h +> a"
  shows "h x = h a"
proof -
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  from xrcos
      have "\<exists>i \<in> a_kernel R S h. x = i \<oplus> a" by (simp add: a_r_coset_defs)
  from this obtain i
      where iker: "i \<in> a_kernel R S h"
        and x: "x = i \<oplus> a"
      by fast+
  note carr = acarr iker[THEN a_Hcarr]

  from x
      have "h x = h (i \<oplus> a)" by simp
  also from carr
      have "\<dots> = h i \<oplus>\<^bsub>S\<^esub> h a" by simp
  also from iker
      have "\<dots> = \<zero>\<^bsub>S\<^esub> \<oplus>\<^bsub>S\<^esub> h a" by simp
  also from carr
      have "\<dots> = h a" by simp
  finally
      show "h x = h a" .
qed

lemma (in ring_hom_ring) homeq_imp_rcos:
  assumes acarr: "a \<in> carrier R"
      and xcarr: "x \<in> carrier R"
      and hx: "h x = h a"
  shows "x \<in> a_kernel R S h +> a"
proof -
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  note carr = acarr xcarr
  note hcarr = acarr[THEN hom_closed] xcarr[THEN hom_closed]

  from hx and hcarr
      have a: "h x \<oplus>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub>h a = \<zero>\<^bsub>S\<^esub>" by algebra
  from carr
      have "h x \<oplus>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub>h a = h (x \<oplus> \<ominus>a)" by simp
  from a and this
      have b: "h (x \<oplus> \<ominus>a) = \<zero>\<^bsub>S\<^esub>" by simp

  from carr have "x \<oplus> \<ominus>a \<in> carrier R" by simp
  from this and b
      have "x \<oplus> \<ominus>a \<in> a_kernel R S h"
      unfolding a_kernel_def'
      by fast

  from this and carr
      show "x \<in> a_kernel R S h +> a" by (simp add: a_rcos_module_rev)
qed

corollary (in ring_hom_ring) rcos_eq_homeq:
  assumes acarr: "a \<in> carrier R"
  shows "(a_kernel R S h) +> a = {x \<in> carrier R. h x = h a}"
proof -
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)
  show ?thesis
    using assms by (auto simp: intro: homeq_imp_rcos rcos_imp_homeq a_elemrcos_carrier)
qed

lemma (in ring_hom_ring) hom_nat_pow:
  "x \<in> carrier R \<Longrightarrow> h (x [^] (n :: nat)) = (h x) [^]\<^bsub>S\<^esub> n"
  by (induct n) (auto)

lemma (in ring_hom_ring) inj_on_domain: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  assumes "inj_on h (carrier R)"
  shows "domain S \<Longrightarrow> domain R"
proof -
  assume A: "domain S" show "domain R"
  proof
    have "h \<one> = \<one>\<^bsub>S\<^esub> \<and> h \<zero> = \<zero>\<^bsub>S\<^esub>" by simp
    hence "h \<one> \<noteq> h \<zero>"
      using domain.one_not_zero[OF A] by simp
    thus "\<one> \<noteq> \<zero>"
      using assms unfolding inj_on_def by fastforce
  next
    fix a b
    assume a: "a \<in> carrier R"
       and b: "b \<in> carrier R"
    have "h (a \<otimes> b) = (h a) \<otimes>\<^bsub>S\<^esub> (h b)" by (simp add: a b)
    also have " ... = (h b) \<otimes>\<^bsub>S\<^esub> (h a)" using a b A cringE(1)[of S]
      by (simp add: cring.cring_simprules(14) domain_def)
    also have " ... = h (b \<otimes> a)" by (simp add: a b)
    finally have "h (a \<otimes> b) = h (b \<otimes> a)" .
    thus "a \<otimes> b = b \<otimes> a"
      using assms a b unfolding inj_on_def by simp

    assume  ab: "a \<otimes> b = \<zero>"
    hence "h (a \<otimes> b) = \<zero>\<^bsub>S\<^esub>" by simp
    hence "(h a) \<otimes>\<^bsub>S\<^esub> (h b) = \<zero>\<^bsub>S\<^esub>" using a b by simp
    hence "h a =  \<zero>\<^bsub>S\<^esub> \<or> h b =  \<zero>\<^bsub>S\<^esub>" using a b domain.integral[OF A] by simp
    thus "a = \<zero> \<or> b = \<zero>"
      using a b assms unfolding inj_on_def by force
  qed
qed

end


section \<open>The ``sturm'' proof method\<close>

(* Author: Manuel Eberl <eberlm@in.tum.de> *)
theory Sturm_Method
imports Sturm_Theorem
begin

subsection \<open>Preliminary lemmas\<close>

text \<open>
  In this subsection, we prove lemmas that reduce root counting and
  related statements to simple, computable expressions using the
  @{term "count_roots"} function family.
\<close>

lemma poly_card_roots_less_leq:
  "card {x. a < x \<and> x \<le> b \<and> poly p x = 0} = count_roots_between p a b"
  by (simp add: count_roots_between_correct)

lemma poly_card_roots_leq_leq:
  "card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
       ( count_roots_between p a b +
      (if (a \<le> b \<and> poly p a = 0 \<and> p \<noteq> 0) \<or> (a = b \<and> p = 0) then 1 else 0))"
proof (cases "(a \<le> b \<and> poly p a = 0 \<and> p \<noteq> 0) \<or> (a = b \<and> p = 0)")
  case False
    note False' = this
    thus ?thesis
    proof (cases "p = 0")
      case False
        with False' have "poly p a \<noteq> 0 \<or> a > b" by auto
        hence "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
               {x. a < x \<and> x \<le> b \<and> poly p x = 0}"
        by (auto simp: less_eq_real_def)
        thus ?thesis using poly_card_roots_less_leq False'
            by (auto split: if_split_asm)
    next
      case True
        have "{x. a \<le> x \<and> x \<le> b} = {a..b}"
             "{x. a < x \<and> x \<le> b} = {a<..b}" by auto
        with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a \<le> x \<and> x \<le> b} = 0"
          by (auto simp add: card_eq_0_iff infinite_Ioc infinite_Icc)
        with True False show ?thesis
            using count_roots_between_correct by (simp add: )
    qed
next
  case True
    note True' = this
    have fin: "finite {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0}"
    proof (cases "p = 0")
      case True
        with True' have "a = b" by simp
        hence "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} = {b}" using True by auto
        thus ?thesis by simp
    next
      case False
        from poly_roots_finite[OF this] show ?thesis by fast
    qed
    with True have "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
        insert a {x. a < x \<and> x \<le> b \<and> poly p x = 0}" by auto
    hence "card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
           Suc (card {x. a < x \<and> x \<le> b \<and> poly p x = 0})" using fin by force
    thus ?thesis using True count_roots_between_correct by simp
qed

lemma poly_card_roots_less_less:
  "card {x. a < x \<and> x < b \<and> poly p x = 0} =
      ( count_roots_between p a b -
              (if poly p b = 0 \<and> a < b \<and> p \<noteq> 0 then 1 else 0))"
proof (cases "poly p b = 0 \<and> a < b \<and> p \<noteq> 0")
  case False
    note False' = this
    show ?thesis
    proof (cases "p = 0")
      case True
        have [simp]: "{x. a < x \<and> x < b} = {a<..<b}"
                     "{x. a < x \<and> x \<le> b} = {a<..b}" by auto
        with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a < x \<and> x < b} = 0"
          by (auto simp add: card_eq_0_iff infinite_Ioo infinite_Ioc)
        with True False' show ?thesis
            by (auto simp: count_roots_between_correct)
    next
      case False
        with False' have "{x. a < x \<and> x < b \<and> poly p x = 0} =
                          {x. a < x \<and> x \<le> b \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis using poly_card_roots_less_leq False by auto
  qed
next
  case True
    with poly_roots_finite
        have fin: "finite {x. a < x \<and> x < b \<and> poly p x = 0}" by fast
    from True have "{x. a < x \<and> x \<le> b \<and> poly p x = 0} =
        insert b {x. a < x \<and> x < b \<and> poly p x = 0}" by auto
    hence "Suc (card {x. a < x \<and> x < b \<and> poly p x = 0}) =
           card {x. a < x \<and> x \<le> b \<and> poly p x = 0}" using fin by force
    also note count_roots_between_correct[symmetric]
    finally show ?thesis using True by simp
qed

lemma poly_card_roots_leq_less:
  "card {x::real. a \<le> x \<and> x < b \<and> poly p x = 0} =
      ( count_roots_between p a b +
      (if p \<noteq> 0 \<and> a < b \<and> poly p a = 0 then 1 else 0) -
      (if p \<noteq> 0 \<and> a < b \<and> poly p b = 0 then 1 else 0))"
proof (cases "p = 0 \<or> a \<ge> b")
  case True
    note True' = this
    show ?thesis
    proof (cases "a \<ge> b")
      case False
        hence "{x. a < x \<and> x \<le> b} = {a<..b}"
              "{x. a \<le> x \<and> x < b} = {a..<b}" by auto
        with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a \<le> x \<and> x < b} = 0"
          by (auto simp add: card_eq_0_iff infinite_Ico infinite_Ioc)
        with False True' show ?thesis
            by (simp add: count_roots_between_correct)
    next
      case True
        with True' have "{x. a \<le> x \<and> x < b \<and> poly p x = 0} =
                          {x. a < x \<and> x \<le> b \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis using poly_card_roots_less_leq True by simp
  qed
next
  case False
    let ?A = "{x. a \<le> x \<and> x < b \<and> poly p x = 0}"
    let ?B = "{x. a < x \<and> x \<le> b \<and> poly p x = 0}"
    let ?C = "{x. x = b \<and> poly p x = 0}"
    let ?D = "{x. x = a \<and> poly p a = 0}"
    have CD_if: "?C = (if poly p b = 0 then {b} else {})"
                "?D = (if poly p a = 0 then {a} else {})" by auto
    from False poly_roots_finite
        have [simp]: "finite ?A" "finite ?B" "finite ?C" "finite ?D"
            by (fast, fast, simp_all)

    from False have "?A = (?B \<union> ?D) - ?C" by (auto simp: less_eq_real_def)
    with False have "card ?A = card ?B + (if poly p a = 0 then 1 else 0) -
                       (if poly p b = 0 then 1 else 0)" by (auto simp: CD_if)
    also note count_roots_between_correct[symmetric]
    finally show ?thesis using False by simp
qed

lemma poly_card_roots:
  "card {x::real. poly p x = 0} = count_roots p"
  using count_roots_correct by simp

lemma poly_no_roots:
  "(\<forall>x. poly p x \<noteq> 0) \<longleftrightarrow> ( p \<noteq> 0 \<and> count_roots p = 0)"
    by (auto simp: count_roots_correct dest: poly_roots_finite)

lemma poly_pos:
  "(\<forall>x. poly p x > 0) \<longleftrightarrow> (
        p \<noteq> 0 \<and> poly_inf p = 1 \<and> count_roots p = 0)"
  by (simp only: Let_def poly_pos poly_no_roots, blast)

lemma poly_card_roots_greater:
  "card {x::real. x > a \<and> poly p x = 0} = count_roots_above p a"
  using count_roots_above_correct by simp

lemma poly_card_roots_leq:
  "card {x::real. x \<le> a \<and> poly p x = 0} = count_roots_below p a"
  using count_roots_below_correct by simp

lemma poly_card_roots_geq:
  "card {x::real. x \<ge> a \<and> poly p x = 0} = (
      count_roots_above p a + (if poly p a = 0 \<and> p \<noteq> 0 then 1 else 0))"
proof (cases "poly p a = 0 \<and> p \<noteq> 0")
  case False
    hence "card {x. x \<ge> a \<and> poly p x = 0} = card {x. x > a \<and> poly p x = 0}"
    proof (cases rule: disjE)
      assume "p = 0"
      have "\<not>finite {a<..<a+1}"
        by (metis infinite_Ioo less_add_one)
      moreover have "{a<..<a+1} \<subseteq> {x. x \<ge> a \<and> poly p x = 0}"
                    "{a<..<a+1} \<subseteq> {x. x > a \<and> poly p x = 0}"
          using \<open>p = 0\<close> by auto
      ultimately have "\<not>finite {x. x \<ge> a \<and> poly p x = 0}"
                      "\<not>finite {x. x > a \<and> poly p x = 0}"
        by (auto dest!: finite_subset[of "{a<..<a+1}"] simp: infinite_Ioo)
      thus ?thesis by simp
    next
      assume "poly p a \<noteq> 0"
      hence "{x. x \<ge> a \<and> poly p x = 0} = {x. x > a \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis by simp
    qed auto
    thus ?thesis using False
        by (auto intro: poly_card_roots_greater)
next
  case True
    hence "finite {x. x > a \<and> poly p x = 0}" using poly_roots_finite by force
    moreover have "{x. x \<ge> a \<and> poly p x = 0} =
                       insert a {x. x > a \<and> poly p x = 0}" using True by auto
    ultimately have "card {x. x \<ge> a \<and> poly p x = 0} =
                         Suc (card {x. x > a \<and> poly p x = 0})"
        using card_insert_disjoint by auto
    thus ?thesis using True by (auto intro: poly_card_roots_greater)
qed

lemma poly_card_roots_less:
  "card {x::real. x < a \<and> poly p x = 0} =
       (count_roots_below p a - (if poly p a = 0 \<and> p \<noteq> 0 then 1 else 0))"
proof (cases "poly p a = 0 \<and> p \<noteq> 0")
  case False
    hence "card {x. x < a \<and> poly p x = 0} = card {x. x \<le> a \<and> poly p x = 0}"
    proof (cases rule: disjE)
      assume "p = 0"
      have "\<not>finite {a - 1<..<a}"
        by (metis infinite_Ioo diff_add_cancel less_add_one)
      moreover have "{a - 1<..<a} \<subseteq> {x. x \<le> a \<and> poly p x = 0}"
                    "{a - 1<..<a} \<subseteq> {x. x < a \<and> poly p x = 0}"
          using \<open>p = 0\<close> by auto
      ultimately have "\<not>finite {x. x \<le> a \<and> poly p x = 0}"
                     "\<not>finite {x. x < a \<and> poly p x = 0}"
          by (auto dest: finite_subset[of "{a - 1<..<a}"] simp: infinite_Ioo)
      thus ?thesis by simp
    next
      assume "poly p a \<noteq> 0"
      hence "{x. x < a \<and> poly p x = 0} = {x. x \<le> a \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis by simp
    qed auto
    thus ?thesis using False
        by (auto intro: poly_card_roots_leq)
next
  case True
    hence "finite {x. x < a \<and> poly p x = 0}" using poly_roots_finite by force
    moreover have "{x. x \<le> a \<and> poly p x = 0} =
                       insert a {x. x < a \<and> poly p x = 0}" using True by auto
    ultimately have "Suc (card {x. x < a \<and> poly p x = 0}) =
                     (card {x. x \<le> a \<and> poly p x = 0})"
        using card_insert_disjoint by auto
    also note count_roots_below_correct[symmetric]
    finally show ?thesis using True by simp
qed

lemma poly_no_roots_less_leq:
  "(\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> count_roots_between p a b = 0)))"
  by (auto simp: count_roots_between_correct card_eq_0_iff not_le
           dest: poly_roots_finite)

lemma poly_pos_between_less_leq:
  "(\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p b > 0 \<and> count_roots_between p a b = 0)))"
  by (simp only: poly_pos_between_less_leq Let_def
                 poly_no_roots_less_leq, blast)

lemma poly_no_roots_leq_leq:
  "(\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a > b \<or> (p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_between p a b = 0)))"
apply (intro iffI)
apply (force simp add: count_roots_between_correct card_eq_0_iff)
apply (elim conjE disjE, simp, intro allI)
apply (rename_tac x, case_tac "x = a")
apply (auto simp add: count_roots_between_correct card_eq_0_iff
            dest: poly_roots_finite)
done

lemma poly_pos_between_leq_leq:
  "(\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a > b \<or> (p \<noteq> 0 \<and> poly p a > 0 \<and>
                count_roots_between p a b = 0)))"
by (simp only: poly_pos_between_leq_leq Let_def poly_no_roots_leq_leq, force)

lemma poly_no_roots_less_less:
  "(\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a \<ge> b \<or> p \<noteq> 0 \<and> count_roots_between p a b =
       (if poly p b = 0 then 1 else 0)))"
proof (standard, goal_cases)
  case A: 1
    show ?case
    proof (cases "a \<ge> b")
      case True
      with A show ?thesis by simp
    next
      case False
      with A have [simp]: "p \<noteq> 0" using dense[of a b] by auto
      have B: "{x. a < x \<and> x \<le> b \<and> poly p x = 0} =
                {x. a < x \<and> x < b \<and> poly p x = 0} \<union>
                (if poly p b = 0 then {b} else {})" using A False by auto
      have "count_roots_between p a b =
                 card {x. a < x \<and> x < b \<and> poly p x = 0} +
                (if poly p b = 0 then 1 else 0)"
         by (subst count_roots_between_correct, subst B, subst card_Un_disjoint,
             rule finite_subset[OF _ poly_roots_finite], blast, simp_all)
      also from A have "{x. a < x \<and> x < b \<and> poly p x = 0} = {}" by simp
      finally show ?thesis by auto
    qed
next
  case prems: 2
    hence "card {x. a < x \<and> x < b \<and> poly p x = 0} = 0"
        by (subst poly_card_roots_less_less, auto simp: count_roots_between_def)
    thus ?case using prems
        by (cases "p = 0", simp, subst (asm) card_eq_0_iff,
            auto dest: poly_roots_finite)
qed

lemma poly_pos_between_less_less:
  "(\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p ((a+b)/2) > 0 \<and>
       count_roots_between p a b = (if poly p b = 0 then 1 else 0))))"
  by (simp only: poly_pos_between_less_less Let_def
                 poly_no_roots_less_less, blast)

lemma poly_no_roots_leq_less:
  "(\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a \<ge> b \<or> p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_between p a b =
       (if a < b \<and> poly p b = 0 then 1 else 0)))"
proof (standard, goal_cases)
  case prems: 1
    hence "\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0" by simp
    thus ?case using prems by (subst (asm) poly_no_roots_less_less, auto)
next
  case prems: 2
    hence "(b \<le> a \<or> p \<noteq> 0 \<and> count_roots_between p a b =
               (if poly p b = 0 then 1 else 0))" by auto
    thus ?case using prems unfolding Let_def
        by (subst (asm) poly_no_roots_less_less[symmetric, unfolded Let_def],
        auto split: if_split_asm simp: less_eq_real_def)
qed

lemma poly_pos_between_leq_less:
  "(\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p a > 0 \<and> count_roots_between p a b =
        (if a < b \<and> poly p b = 0 then 1 else 0))))"
 by (simp only: poly_pos_between_leq_less Let_def
                poly_no_roots_leq_less, force)

lemma poly_no_roots_greater:
  "(\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ((p \<noteq> 0 \<and> count_roots_above p a = 0))"
proof-
  have "\<forall>x. \<not> a < x \<Longrightarrow> False" by (metis gt_ex)
  thus ?thesis by (auto simp: count_roots_above_correct card_eq_0_iff
                        intro: poly_roots_finite )
qed

lemma poly_pos_greater:
  "(\<forall>x. x > a \<longrightarrow> poly p x > 0) \<longleftrightarrow> (
       p \<noteq> 0 \<and> poly_inf p = 1 \<and> count_roots_above p a = 0)"
  unfolding Let_def
  by (subst poly_pos_greater, subst poly_no_roots_greater, force)

lemma poly_no_roots_leq:
  "(\<forall>x. x \<le> a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ( (p \<noteq> 0 \<and> count_roots_below p a = 0))"
    by (auto simp: Let_def count_roots_below_correct card_eq_0_iff
             intro: poly_roots_finite)

lemma poly_pos_leq:
  "(\<forall>x. x \<le> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ( p \<noteq> 0 \<and> poly_neg_inf p = 1 \<and> count_roots_below p a = 0)"
  by (simp only: poly_pos_leq Let_def poly_no_roots_leq, blast)

lemma poly_no_roots_geq:
  "(\<forall>x. x \<ge> a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ( (p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_above p a = 0))"
proof (standard, goal_cases)
  case prems: 1
  hence "\<forall>x>a. poly p x \<noteq> 0" by simp
  thus ?case using prems by (subst (asm) poly_no_roots_greater, auto)
next
  case prems: 2
  hence "(p \<noteq> 0 \<and> count_roots_above p a = 0)" by simp
  thus ?case using prems
      by (subst (asm) poly_no_roots_greater[symmetric, unfolded Let_def],
          auto simp: less_eq_real_def)
qed

lemma poly_pos_geq:
  "(\<forall>x. x \<ge> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   (p \<noteq> 0 \<and> poly_inf p = 1 \<and> poly p a \<noteq> 0 \<and> count_roots_above p a = 0)"
  by (simp only: poly_pos_geq Let_def poly_no_roots_geq, blast)

lemma poly_no_roots_less:
  "(\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ((p \<noteq> 0 \<and> count_roots_below p a = (if poly p a = 0 then 1 else 0)))"
proof (standard, goal_cases)
  case prems: 1
  hence "{x. x \<le> a \<and> poly p x = 0} = (if poly p a = 0 then {a} else {})"
      by (auto simp: less_eq_real_def)
  moreover have "\<forall>x. \<not> x < a \<Longrightarrow> False" by (metis lt_ex)
  ultimately show ?case using prems by (auto simp: count_roots_below_correct)
next
  case prems: 2
  have A: "{x. x \<le> a \<and> poly p x = 0} = {x. x < a \<and> poly p x = 0} \<union>
            (if poly p a = 0 then {a} else {})" by (auto simp: less_eq_real_def)
  have "count_roots_below p a = card {x. x < a \<and> poly p x = 0} +
            (if poly p a = 0 then 1 else 0)" using prems
      by (subst count_roots_below_correct, subst A, subst card_Un_disjoint,
          auto intro: poly_roots_finite)
  with prems have "card {x. x < a \<and> poly p x = 0} = 0" by simp
  thus ?case using prems
      by (subst (asm) card_eq_0_iff, auto intro: poly_roots_finite)
qed

lemma poly_pos_less:
  "(\<forall>x. x < a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   (p \<noteq> 0 \<and> poly_neg_inf p = 1 \<and> count_roots_below p a =
       (if poly p a = 0 then 1 else 0))"
  by (simp only: poly_pos_less Let_def poly_no_roots_less, blast)

lemmas sturm_card_substs = poly_card_roots poly_card_roots_less_leq
    poly_card_roots_leq_less poly_card_roots_less_less poly_card_roots_leq_leq
    poly_card_roots_less poly_card_roots_leq poly_card_roots_greater
    poly_card_roots_geq

lemmas sturm_prop_substs = poly_no_roots poly_no_roots_less_leq
    poly_no_roots_leq_leq poly_no_roots_less_less poly_no_roots_leq_less
    poly_no_roots_leq poly_no_roots_less poly_no_roots_geq
    poly_no_roots_greater
    poly_pos poly_pos_greater poly_pos_geq poly_pos_less poly_pos_leq
    poly_pos_between_leq_less poly_pos_between_less_leq
    poly_pos_between_leq_leq poly_pos_between_less_less

subsection \<open>Reification\<close>

text \<open>
  This subsection defines a number of equations to automatically convert
  statements about roots of polynomials into a canonical form so that they
  can be proven using the above substitutions.
\<close>

definition "PR_TAG x \<equiv> x"

lemma sturm_id_PR_prio0:
  "{x::real. P x} = {x::real. (PR_TAG P) x}"
  "(\<forall>x::real. f x < g x) = (\<forall>x::real. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. P x) = (\<forall>x::real. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  by (simp_all add: PR_TAG_def)

lemma sturm_id_PR_prio1:
  "{x::real. x < a \<and> P x} = {x::real. x < a \<and> (PR_TAG P) x}"
  "{x::real. x \<le> a \<and> P x} = {x::real. x \<le> a \<and> (PR_TAG P) x}"
  "{x::real. x \<ge> b \<and> P x} = {x::real. x \<ge> b \<and> (PR_TAG P) x}"
  "{x::real. x > b \<and> P x} = {x::real. x > b \<and> (PR_TAG P) x}"
  "(\<forall>x::real < a. f x < g x) = (\<forall>x::real < a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real \<le> a. f x < g x) = (\<forall>x::real \<le> a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real > a. f x < g x) = (\<forall>x::real > a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real \<ge> a. f x < g x) = (\<forall>x::real \<ge> a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real < a. P x) = (\<forall>x::real < a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real > a. P x) = (\<forall>x::real > a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real \<le> a. P x) = (\<forall>x::real \<le> a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real \<ge> a. P x) = (\<forall>x::real \<ge> a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  by (simp_all add: PR_TAG_def)

lemma sturm_id_PR_prio2:
  "{x::real. x > a \<and> x \<le> b \<and> P x} =
       {x::real. x > a \<and> x \<le> b \<and> PR_TAG P x}"
  "{x::real. x \<ge> a \<and> x \<le> b \<and> P x} =
       {x::real. x \<ge> a \<and> x \<le> b \<and> PR_TAG P x}"
  "{x::real. x \<ge> a \<and> x < b \<and> P x} =
       {x::real. x \<ge> a \<and> x < b \<and> PR_TAG P x}"
  "{x::real. x > a \<and> x < b \<and> P x} =
       {x::real. x > a \<and> x < b \<and> PR_TAG P x}"
  "(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a < x \<and> x < b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a < x \<and> x < b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> P x) =
       (\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> P x) =
       (\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> P x) =
       (\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real. a < x \<and> x < b \<longrightarrow> P x) =
       (\<forall>x::real. a < x \<and> x < b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  by (simp_all add: PR_TAG_def)

lemma PR_TAG_intro_prio0:
  fixes P :: "real \<Rightarrow> bool" and f :: "real \<Rightarrow> real"
  shows
  "PR_TAG P = P' \<Longrightarrow> PR_TAG (\<lambda>x. \<not>(\<not>P x)) = P'"
  "\<lbrakk>PR_TAG P = (\<lambda>x. poly p x = 0); PR_TAG Q = (\<lambda>x. poly q x = 0)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. P x \<and> Q x) = (\<lambda>x. poly (gcd p q) x = 0)" and
 " \<lbrakk>PR_TAG P = (\<lambda>x. poly p x = 0); PR_TAG Q = (\<lambda>x. poly q x = 0)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. P x \<or> Q x) = (\<lambda>x. poly (p*q) x = 0)" and

  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x = g x) = (\<lambda>x. poly (p-q) x = 0)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x \<noteq> g x) = (\<lambda>x. poly (p-q) x \<noteq> 0)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x < g x) = (\<lambda>x. poly (q-p) x > 0)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x \<le> g x) = (\<lambda>x. poly (q-p) x \<ge> 0)"

  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. -f x) = (\<lambda>x. poly (-p) x)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x + g x) = (\<lambda>x. poly (p+q) x)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x - g x) = (\<lambda>x. poly (p-q) x)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * g x) = (\<lambda>x. poly (p*q) x)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^n) = (\<lambda>x. poly (p^n) x)"
  "PR_TAG (\<lambda>x. poly p x :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. x::real) = (\<lambda>x. poly [:0,1:] x)"
  "PR_TAG (\<lambda>x. a::real) = (\<lambda>x. poly [:a:] x)"
  by (simp_all add: PR_TAG_def poly_eq_0_iff_dvd field_simps)

lemma PR_TAG_intro_prio1:
  fixes f :: "real \<Rightarrow> real"
  shows
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x = 0) = (\<lambda>x. poly p x = 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<noteq> 0) = (\<lambda>x. poly p x \<noteq> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. 0 = f x) = (\<lambda>x. poly p x = 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. 0 \<noteq> f x) = (\<lambda>x. poly p x \<noteq> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<ge> 0) = (\<lambda>x. poly p x \<ge> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x > 0) = (\<lambda>x. poly p x > 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<le> 0) = (\<lambda>x. poly (-p) x \<ge> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x < 0) = (\<lambda>x. poly (-p) x > 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow>
       PR_TAG (\<lambda>x. 0 \<le> f x) = (\<lambda>x. poly (-p) x \<le> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow>
       PR_TAG (\<lambda>x. 0 < f x) = (\<lambda>x. poly (-p) x < 0)"
  "PR_TAG f = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. a * f x) = (\<lambda>x. poly (smult a p) x)"
  "PR_TAG f = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * a) = (\<lambda>x. poly (smult a p) x)"
  "PR_TAG f = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x / a) = (\<lambda>x. poly (smult (inverse a) p) x)"
  "PR_TAG (\<lambda>x. x^n :: real) = (\<lambda>x. poly (monom 1 n) x)"
by (simp_all add: PR_TAG_def field_simps poly_monom)

lemma PR_TAG_intro_prio2:
  "PR_TAG (\<lambda>x. 1 / b) = (\<lambda>x. inverse b)"
  "PR_TAG (\<lambda>x. a / b) = (\<lambda>x. a / b)"
  "PR_TAG (\<lambda>x. a / b * x^n :: real) = (\<lambda>x. poly (monom (a/b) n) x)"
  "PR_TAG (\<lambda>x. x^n * a / b :: real) = (\<lambda>x. poly (monom (a/b) n) x)"
  "PR_TAG (\<lambda>x. a * x^n :: real) = (\<lambda>x. poly (monom a n) x)"
  "PR_TAG (\<lambda>x. x^n * a :: real) = (\<lambda>x. poly (monom a n) x)"
  "PR_TAG (\<lambda>x. x^n / a :: real) = (\<lambda>x. poly (monom (inverse a) n) x)"
(* TODO: can this be done more efficiently? I should think so. *)
  "PR_TAG (\<lambda>x. f x^(Suc (Suc 0)) :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * f x :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. (f x)^Suc n :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^n * f x :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. (f x)^Suc n :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * (f x)^n :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. (f x)^(m+n) :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^m * (f x)^n :: real) = (\<lambda>x. poly p x)"
by (simp_all add: PR_TAG_def field_simps poly_monom power_add)

lemma sturm_meta_spec: "(\<And>x::real. P x) \<Longrightarrow> P x" by simp
lemma sturm_imp_conv:
  "(a < x \<longrightarrow> x < b \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x < b \<longrightarrow> c)"
  "(a \<le> x \<longrightarrow> x < b \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x < b \<longrightarrow> c)"
  "(a < x \<longrightarrow> x \<le> b \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x \<le> b \<longrightarrow> c)"
  "(a \<le> x \<longrightarrow> x \<le> b \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x \<le> b \<longrightarrow> c)"
  "(x < b \<longrightarrow> a < x \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x < b \<longrightarrow> c)"
  "(x < b \<longrightarrow> a \<le> x \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x < b \<longrightarrow> c)"
  "(x \<le> b \<longrightarrow> a < x \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x \<le> b \<longrightarrow> c)"
  "(x \<le> b \<longrightarrow> a \<le> x \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x \<le> b \<longrightarrow> c)"
  by auto

subsection \<open>Setup for the ``sturm'' method\<close>

ML_file \<open>sturm.ML\<close>

method_setup sturm = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Sturm.sturm_tac ctxt true))
\<close>

end