(*  Title:       LogisticFunction.thy
    Author:      Filip Smola, 2019-2021
*)

theory LogisticFunction
  imports HyperdualFunctionExtension
begin

subsection\<open>Logistic Function\<close>

text\<open>Define the standard logistic function and its hyperdual variant:\<close>
definition logistic :: "real \<Rightarrow> real"
  where "logistic x = inverse (1 + exp (-x))"
definition hyp_logistic :: "real hyperdual \<Rightarrow> real hyperdual"
  where "hyp_logistic x = inverse (1 + (*h* exp) (-x))"

text\<open>Hyperdual extension of the logistic function is its hyperdual variant:\<close>
lemma hypext_logistic:
  "(*h* logistic) x = hyp_logistic x"
proof -
  have "(*h* (\<lambda>x. exp (- x) + 1)) x = (*h* exp) (- x) + of_comp 1"
    by (simp add: hypext_compose hypext_uminus hypext_fun_cadd twice_field_differentiable_at_compose)
  then have "(*h* (\<lambda>x. 1 + exp (- x))) x = 1 + (*h* exp) (- x)"
    by (simp add: one_hyperdual_def add.commute)
  moreover have "1 + exp (- Base x) \<noteq> 0"
    by (metis exp_ge_zero add_eq_0_iff neg_0_le_iff_le not_one_le_zero)
  moreover have "(\<lambda>x. 1 + exp (- x)) twice_field_differentiable_at Base x"
  proof -
    have "(\<lambda>x. exp (- x)) twice_field_differentiable_at Base x"
      by (simp add: twice_field_differentiable_at_compose)
    then have "(\<lambda>x. exp (- x) + 1) twice_field_differentiable_at Base x"
      using twice_field_differentiable_at_compose[of "\<lambda>x. exp (- x)" "Base x" "\<lambda>x. x + 1"]
      by simp
    then show ?thesis
      by (simp add: add.commute)
  qed
  ultimately have "(*h* (\<lambda>x. inverse (1 + exp (- x)))) x = inverse (1 + (*h* exp) (- x))"
    by (simp add: hypext_fun_inverse)
  then show ?thesis
    unfolding logistic_def hyp_logistic_def .
qed

text\<open>From properties of autodiff we know it gives us the derivative:\<close>
lemma "Eps1 (hyp_logistic (\<beta> x)) = deriv logistic x"
  by (metis Eps1_hypext hypext_logistic)
text\<open>which is equal to the known derivative of the standard logistic function:\<close>
lemma "First (autodiff logistic x) = exp (- x) / (1 + exp (- x)) ^ 2"
  (* Move to hyperdual variant: *)
  apply (simp only: autodiff.simps hyperdual_to_derivs.simps derivs.sel hypext_logistic)
  (* Unfold extensions of functions that have a hyperdual variant (all except exp): *)
  apply (simp only: hyp_logistic_def inverse_hyperdual.code hyperdual.sel)
  (* Finish by expanding the extension of exp and hyperdual computations: *)
  apply (simp add: hyperdualx_def hypext_exp_Hyperdual hyperdual_bases)
  done

text\<open>Similarly we can get the second derivative:\<close>
lemma "Second (autodiff logistic x) = deriv (deriv logistic) x"
  by (rule autodiff_extract_second)
text\<open>and derive its value:\<close>
lemma "Second (autodiff logistic x) = ((exp (- x) - 1) * exp (- x)) / ((1 + exp (- x)) ^ 3)"
  (* Move to hyperdual variant: *)
  apply (simp only: autodiff.simps hyperdual_to_derivs.simps derivs.sel hypext_logistic)
  (* Unfold extensions of functions that have a hyperdual variant (all except exp): *)
  apply (simp only: hyp_logistic_def inverse_hyperdual.code hyperdual.sel)
  (* Finish by expanding the extension of exp and hyperdual computations: *)
  apply (simp add: hyperdualx_def hypext_exp_Hyperdual hyperdual_bases)
  (* Simplify the resulting expression: *)
proof -
  have
    "2 * (exp (- x) * exp (- x)) / (1 + exp (- x)) ^ 3 - exp (- x) / (1 + exp (- x)) ^ 2 =
     (2 * exp (- x) / (1 + exp (- x)) ^ 3 - 1 / (1 + exp (- x)) ^ 2) * exp (- x)"
    by (simp add: field_simps)
  also have "... = (2 * exp (- x) / (1 + exp (- x)) ^ 3 - (1 + exp (- x)) / (1 + exp (- x)) ^ 3) * exp (- x)"
  proof -
    have "inverse ((1 + exp (- x)) ^ 2) = inverse (1 + exp (- x)) ^ 2"
      by (simp add: power_inverse)
    also have "... = (1 + exp (- x)) * inverse (1 + exp (- x)) * inverse (1 + exp (- x)) ^ 2"
      by (simp add: inverse_eq_divide)
    also have "... = (1 + exp (- x)) * inverse (1 + exp (- x)) ^ 3"
      by (simp add: power2_eq_square power3_eq_cube)
    finally have "inverse ((1 + exp (- x)) ^ 2) = (1 + exp (- x)) * inverse ((1 + exp (- x)) ^ 3)"
      by (simp add: power_inverse)
    then show ?thesis
      by (simp add: inverse_eq_divide)
  qed
  also have "... = (2 * exp (- x) - (1 + exp (- x))) / (1 + exp (- x)) ^ 3 * exp (- x)"
    by (metis diff_divide_distrib)
  finally show
    "2 * (exp (- x) * exp (- x)) / (1 + exp (- x)) ^ 3 - exp (- x) / (1 + exp (- x))\<^sup>2 =
     (exp (- x) - 1) * exp (- x) / (1 + exp (- x)) ^ 3"
    by (simp add: field_simps)
qed

end


theory Cyclic_Group_Ext imports
  CryptHOL.CryptHOL
  "HOL-Number_Theory.Cong"
begin

context cyclic_group begin

lemma generator_pow_order: "\<^bold>g [^] order G = \<one>"
proof(cases "order G > 0")
  case True
  hence fin: "finite (carrier G)" by(simp add: order_gt_0_iff_finite)
  then have [symmetric]: "(\<lambda>x. x \<otimes> \<^bold>g) ` carrier G = carrier G"
    by(rule endo_inj_surj)(auto simp add: inj_on_multc)
  then have "carrier G = (\<lambda> n. \<^bold>g [^] Suc n) ` {..<order G}"
    using fin by(simp add: carrier_conv_generator image_image)
  then obtain n where n: "\<one> = \<^bold>g [^] Suc n" "n < order G" by auto
  have "n = order G - 1" using n inj_onD[OF inj_on_generator, of 0 "Suc n"] by fastforce
  with True n show ?thesis by auto
qed simp

lemma pow_generator_mod: "\<^bold>g [^] (k mod order G) = \<^bold>g [^] k"
proof(cases "order G > 0")
  case True
  obtain n where n: "k = n * order G + k mod order G" by (metis div_mult_mod_eq)
  have "\<^bold>g [^] k = (\<^bold>g [^] order G) [^] n \<otimes> \<^bold>g [^] (k mod order G)"
    by(subst n)(simp add: nat_pow_mult nat_pow_pow mult_ac)
  then show ?thesis by(simp add: generator_pow_order)
qed simp

lemma int_nat_pow:
  assumes "a \<ge> 0"
  shows "(\<^bold>g [^] (int (a ::nat))) [^] (b::int)  = \<^bold>g [^] (a*b)"
  using assms
proof(cases "a > 0")
  case True
  show ?thesis
    using int_pow_pow by blast
next case False
  have "(\<^bold>g [^] (int (a ::nat))) [^] (b::int) = \<one>" using False by simp
  also have "\<^bold>g [^] (a*b) = \<one>" using False by simp
  ultimately show ?thesis by simp
qed

lemma pow_generator_mod_int: "\<^bold>g [^] ((k :: int) mod order G) = \<^bold>g [^] k"
proof(cases "order G > 0")
  case True
  obtain n :: int where n: "k = order G * n + k mod order G"
    by (metis div_mult_mod_eq mult.commute)
  then have "\<^bold>g [^] k = \<^bold>g [^] (order G * n) \<otimes> \<^bold>g [^] (k mod order G)"
    using int_pow_mult nat_pow_mult by (metis generator_closed)
  then have "\<^bold>g [^] k = (\<^bold>g [^] order G) [^] n \<otimes> \<^bold>g [^] (k mod order G)"
    using int_nat_pow by (simp add: int_pow_int)
  then show ?thesis by(simp add: generator_pow_order)
qed simp

lemma pow_generator_eq_iff_cong:
  "finite (carrier G) \<Longrightarrow> \<^bold>g [^] x = \<^bold>g [^] y \<longleftrightarrow> [x = y] (mod order G)"
  by(subst (1 2) pow_generator_mod[symmetric])(auto simp add: cong_def order_gt_0_iff_finite intro: inj_onD[OF inj_on_generator])

lemma cyclic_group_commute:
  assumes "a \<in> carrier G" "b \<in> carrier G"
  shows "a \<otimes> b = b \<otimes> a"
(is "?lhs = ?rhs")
proof-
  obtain n :: nat where n: "a = \<^bold>g [^] n" using generatorE assms by auto
  also  obtain k :: nat where k: "b = \<^bold>g [^] k" using generatorE assms by auto
  ultimately have "?lhs =  \<^bold>g [^] n \<otimes> \<^bold>g [^] k" by simp
  then have "... = \<^bold>g [^] (n + k)" by(simp add: nat_pow_mult)
  then have "... = \<^bold>g [^] (k + n)" by(simp add: add.commute)
  then show ?thesis by(simp add: nat_pow_mult n k)
qed

lemma cyclic_group_assoc:
  assumes "a \<in> carrier G" "b \<in> carrier G" "c \<in> carrier G"
  shows "(a \<otimes> b) \<otimes> c = a \<otimes> (b \<otimes> c)"
(is "?lhs = ?rhs")
proof-
  obtain n :: nat where n: "a = \<^bold>g [^] n" using generatorE assms by auto
  obtain k :: nat where k: "b = \<^bold>g [^] k" using generatorE assms by auto
  obtain j :: nat where j: "c = \<^bold>g [^] j" using generatorE assms by auto
  have "?lhs = (\<^bold>g [^] n \<otimes> \<^bold>g [^] k) \<otimes> \<^bold>g [^] j" using n k j by simp
  then have "... = \<^bold>g [^] (n + (k + j))" by(simp add: nat_pow_mult add.assoc)
  then show ?thesis by(simp add: nat_pow_mult n k j)
qed

lemma l_cancel_inv:
  assumes "h \<in> carrier G"
  shows "(\<^bold>g [^] (a :: nat) \<otimes> inv (\<^bold>g [^] a)) \<otimes> h = h"
(is "?lhs = ?rhs")
proof-
  have "?lhs = (\<^bold>g [^] int a \<otimes> inv (\<^bold>g [^] int a)) \<otimes> h" by simp
  then have "... = (\<^bold>g [^] int a \<otimes> (\<^bold>g [^] (- a))) \<otimes> h" using int_pow_neg[symmetric] by simp
  then have "... = \<^bold>g [^] (int a - a)  \<otimes> h" by(simp add: int_pow_mult)
  then have "... = \<^bold>g [^] ((0:: int)) \<otimes> h" by simp
  then show ?thesis by (simp add: assms)
qed

lemma inverse_split:
  assumes "a \<in> carrier G" and "b \<in> carrier G"
  shows "inv (a \<otimes> b) = inv a \<otimes> inv b"
  by (simp add:  assms comm_group.inv_mult cyclic_group_commute group_comm_groupI)

lemma inverse_pow_pow:
  assumes "a \<in> carrier G"
  shows "inv (a [^] (r::nat)) = (inv a) [^] r"
proof -
  have "a [^] r \<in> carrier G"
    using assms by blast
  then show ?thesis
    by (simp add: assms nat_pow_inv)
qed

lemma l_neq_1_exp_neq_0:
  assumes "l \<in> carrier G"
    and "l \<noteq> \<one>"
    and "l = \<^bold>g [^] (t::nat)"
  shows "t \<noteq> 0"
proof(rule ccontr)
  assume "\<not> (t \<noteq> 0)"
  hence "t = 0" by simp
  hence "\<^bold>g [^] t = \<one>" by simp
  then show "False" using assms by simp
qed

lemma order_gt_1_gen_not_1:
  assumes "order G > 1"
  shows "\<^bold>g \<noteq> \<one>"
proof(rule ccontr)
  assume "\<not> \<^bold>g \<noteq> \<one>"
  hence "\<^bold>g = \<one>" by simp
  hence g_pow_eq_1: "\<^bold>g [^] n = \<one>" for n :: nat by simp
  hence "range (\<lambda>n :: nat. \<^bold>g [^] n) = {\<one>}" by auto
  hence "carrier G \<subseteq> {\<one>}" using generator by auto
  hence "order G < 1"
    by (metis One_nat_def assms g_pow_eq_1 inj_onD inj_on_generator lessThan_iff not_gr_zero zero_less_Suc)
  with assms show "False" by simp
qed

lemma power_swap: "((\<^bold>g [^] (\<alpha>0::nat)) [^] (r::nat)) = ((\<^bold>g [^] r) [^] \<alpha>0)"
(is "?lhs = ?rhs")
proof-
  have "?lhs = \<^bold>g [^] (\<alpha>0 * r)"
    using nat_pow_pow mult.commute by auto
  hence "... = \<^bold>g [^] (r * \<alpha>0)"
    by(metis mult.commute)
  thus ?thesis using nat_pow_pow by auto
qed

end

end


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

section \<open>Fundamental Theorem of Algebra\<close>

theory Fundamental_Theorem_Algebra
imports Polynomial Complex_Main
begin

subsection \<open>More lemmas about module of complex numbers\<close>

text \<open>The triangle inequality for cmod\<close>

lemma complex_mod_triangle_sub: "cmod w \<le> cmod (w + z) + norm z"
  using complex_mod_triangle_ineq2[of "w + z" "-z"] by auto

subsection \<open>Basic lemmas about polynomials\<close>

lemma poly_bound_exists:
  fixes p :: "'a::{comm_semiring_0,real_normed_div_algebra} poly"
  shows "\<exists>m. m > 0 \<and> (\<forall>z. norm z \<le> r \<longrightarrow> norm (poly p z) \<le> m)"
proof (induct p)
  case 0
  then show ?case by (rule exI[where x=1]) simp
next
  case (pCons c cs)
  from pCons.hyps obtain m where m: "\<forall>z. norm z \<le> r \<longrightarrow> norm (poly cs z) \<le> m"
    by blast
  let ?k = " 1 + norm c + \<bar>r * m\<bar>"
  have kp: "?k > 0"
    using abs_ge_zero[of "r*m"] norm_ge_zero[of c] by arith
  have "norm (poly (pCons c cs) z) \<le> ?k" if H: "norm z \<le> r" for z
  proof -
    from m H have th: "norm (poly cs z) \<le> m"
      by blast
    from H have rp: "r \<ge> 0"
      using norm_ge_zero[of z] by arith
    have "norm (poly (pCons c cs) z) \<le> norm c + norm (z * poly cs z)"
      using norm_triangle_ineq[of c "z* poly cs z"] by simp
    also have "\<dots> \<le> norm c + r * m"
      using mult_mono[OF H th rp norm_ge_zero[of "poly cs z"]]
      by (simp add: norm_mult)
    also have "\<dots> \<le> ?k"
      by simp
    finally show ?thesis .
  qed
  with kp show ?case by blast
qed

text \<open>Offsetting the variable in a polynomial gives another of same degree\<close>

definition offset_poly :: "'a::comm_semiring_0 poly \<Rightarrow> 'a \<Rightarrow> 'a poly"
  where "offset_poly p h = fold_coeffs (\<lambda>a q. smult h q + pCons a q) p 0"

lemma offset_poly_0: "offset_poly 0 h = 0"
  by (simp add: offset_poly_def)

lemma offset_poly_pCons:
  "offset_poly (pCons a p) h =
    smult h (offset_poly p h) + pCons a (offset_poly p h)"
  by (cases "p = 0 \<and> a = 0") (auto simp add: offset_poly_def)

lemma offset_poly_single: "offset_poly [:a:] h = [:a:]"
  by (simp add: offset_poly_pCons offset_poly_0)

lemma poly_offset_poly: "poly (offset_poly p h) x = poly p (h + x)"
  apply (induct p)
  apply (simp add: offset_poly_0)
  apply (simp add: offset_poly_pCons algebra_simps)
  done

lemma offset_poly_eq_0_lemma: "smult c p + pCons a p = 0 \<Longrightarrow> p = 0"
  by (induct p arbitrary: a) (simp, force)

lemma offset_poly_eq_0_iff: "offset_poly p h = 0 \<longleftrightarrow> p = 0"
  apply (safe intro!: offset_poly_0)
  apply (induct p)
  apply simp
  apply (simp add: offset_poly_pCons)
  apply (frule offset_poly_eq_0_lemma, simp)
  done

lemma degree_offset_poly: "degree (offset_poly p h) = degree p"
  apply (induct p)
  apply (simp add: offset_poly_0)
  apply (case_tac "p = 0")
  apply (simp add: offset_poly_0 offset_poly_pCons)
  apply (simp add: offset_poly_pCons)
  apply (subst degree_add_eq_right)
  apply (rule le_less_trans [OF degree_smult_le])
  apply (simp add: offset_poly_eq_0_iff)
  apply (simp add: offset_poly_eq_0_iff)
  done

definition "psize p = (if p = 0 then 0 else Suc (degree p))"

lemma psize_eq_0_iff [simp]: "psize p = 0 \<longleftrightarrow> p = 0"
  unfolding psize_def by simp

lemma poly_offset:
  fixes p :: "'a::comm_ring_1 poly"
  shows "\<exists>q. psize q = psize p \<and> (\<forall>x. poly q x = poly p (a + x))"
proof (intro exI conjI)
  show "psize (offset_poly p a) = psize p"
    unfolding psize_def
    by (simp add: offset_poly_eq_0_iff degree_offset_poly)
  show "\<forall>x. poly (offset_poly p a) x = poly p (a + x)"
    by (simp add: poly_offset_poly)
qed

text \<open>An alternative useful formulation of completeness of the reals\<close>
lemma real_sup_exists:
  assumes ex: "\<exists>x. P x"
    and bz: "\<exists>z. \<forall>x. P x \<longrightarrow> x < z"
  shows "\<exists>s::real. \<forall>y. (\<exists>x. P x \<and> y < x) \<longleftrightarrow> y < s"
proof
  from bz have "bdd_above (Collect P)"
    by (force intro: less_imp_le)
  then show "\<forall>y. (\<exists>x. P x \<and> y < x) \<longleftrightarrow> y < Sup (Collect P)"
    using ex bz by (subst less_cSup_iff) auto
qed

subsection \<open>Fundamental theorem of algebra\<close>

lemma unimodular_reduce_norm:
  assumes md: "cmod z = 1"
  shows "cmod (z + 1) < 1 \<or> cmod (z - 1) < 1 \<or> cmod (z + \<i>) < 1 \<or> cmod (z - \<i>) < 1"
proof -
  obtain x y where z: "z = Complex x y "
    by (cases z) auto
  from md z have xy: "x\<^sup>2 + y\<^sup>2 = 1"
    by (simp add: cmod_def)
  have False if "cmod (z + 1) \<ge> 1" "cmod (z - 1) \<ge> 1" "cmod (z + \<i>) \<ge> 1" "cmod (z - \<i>) \<ge> 1"
  proof -
    from that z xy have "2 * x \<le> 1" "2 * x \<ge> -1" "2 * y \<le> 1" "2 * y \<ge> -1"
      by (simp_all add: cmod_def power2_eq_square algebra_simps)
    then have "\<bar>2 * x\<bar> \<le> 1" "\<bar>2 * y\<bar> \<le> 1"
      by simp_all
    then have "\<bar>2 * x\<bar>\<^sup>2 \<le> 1\<^sup>2" "\<bar>2 * y\<bar>\<^sup>2 \<le> 1\<^sup>2"
      by - (rule power_mono, simp, simp)+
    then have th0: "4 * x\<^sup>2 \<le> 1" "4 * y\<^sup>2 \<le> 1"
      by (simp_all add: power_mult_distrib)
    from add_mono[OF th0] xy show ?thesis
      by simp
  qed
  then show ?thesis
    unfolding linorder_not_le[symmetric] by blast
qed

text \<open>Hence we can always reduce modulus of \<open>1 + b z^n\<close> if nonzero\<close>
lemma reduce_poly_simple:
  assumes b: "b \<noteq> 0"
    and n: "n \<noteq> 0"
  shows "\<exists>z. cmod (1 + b * z^n) < 1"
  using n
proof (induct n rule: nat_less_induct)
  fix n
  assume IH: "\<forall>m<n. m \<noteq> 0 \<longrightarrow> (\<exists>z. cmod (1 + b * z ^ m) < 1)"
  assume n: "n \<noteq> 0"
  let ?P = "\<lambda>z n. cmod (1 + b * z ^ n) < 1"
  show "\<exists>z. ?P z n"
  proof cases
    assume "even n"
    then have "\<exists>m. n = 2 * m"
      by presburger
    then obtain m where m: "n = 2 * m"
      by blast
    from n m have "m \<noteq> 0" "m < n"
      by presburger+
    with IH[rule_format, of m] obtain z where z: "?P z m"
      by blast
    from z have "?P (csqrt z) n"
      by (simp add: m power_mult)
    then show ?thesis ..
  next
    assume "odd n"
    then have "\<exists>m. n = Suc (2 * m)"
      by presburger+
    then obtain m where m: "n = Suc (2 * m)"
      by blast
    have th0: "cmod (complex_of_real (cmod b) / b) = 1"
      using b by (simp add: norm_divide)
    from unimodular_reduce_norm[OF th0] \<open>odd n\<close>
    have "\<exists>v. cmod (complex_of_real (cmod b) / b + v^n) < 1"
      apply (cases "cmod (complex_of_real (cmod b) / b + 1) < 1")
      apply (rule_tac x="1" in exI)
      apply simp
      apply (cases "cmod (complex_of_real (cmod b) / b - 1) < 1")
      apply (rule_tac x="-1" in exI)
      apply simp
      apply (cases "cmod (complex_of_real (cmod b) / b + \<i>) < 1")
      apply (cases "even m")
      apply (rule_tac x="\<i>" in exI)
      apply (simp add: m power_mult)
      apply (rule_tac x="- \<i>" in exI)
      apply (simp add: m power_mult)
      apply (cases "even m")
      apply (rule_tac x="- \<i>" in exI)
      apply (simp add: m power_mult)
      apply (auto simp add: m power_mult)
      apply (rule_tac x="\<i>" in exI)
      apply (auto simp add: m power_mult)
      done
    then obtain v where v: "cmod (complex_of_real (cmod b) / b + v^n) < 1"
      by blast
    let ?w = "v / complex_of_real (root n (cmod b))"
    from odd_real_root_pow[OF \<open>odd n\<close>, of "cmod b"]
    have th1: "?w ^ n = v^n / complex_of_real (cmod b)"
      by (simp add: power_divide of_real_power[symmetric])
    have th2:"cmod (complex_of_real (cmod b) / b) = 1"
      using b by (simp add: norm_divide)
    then have th3: "cmod (complex_of_real (cmod b) / b) \<ge> 0"
      by simp
    have th4: "cmod (complex_of_real (cmod b) / b) *
        cmod (1 + b * (v ^ n / complex_of_real (cmod b))) <
        cmod (complex_of_real (cmod b) / b) * 1"
      apply (simp only: norm_mult[symmetric] distrib_left)
      using b v
      apply (simp add: th2)
      done
    from mult_left_less_imp_less[OF th4 th3]
    have "?P ?w n" unfolding th1 .
    then show ?thesis ..
  qed
qed

text \<open>Bolzano-Weierstrass type property for closed disc in complex plane.\<close>

lemma metric_bound_lemma: "cmod (x - y) \<le> \<bar>Re x - Re y\<bar> + \<bar>Im x - Im y\<bar>"
  using real_sqrt_sum_squares_triangle_ineq[of "Re x - Re y" 0 0 "Im x - Im y"]
  unfolding cmod_def by simp

lemma Bolzano_Weierstrass_complex_disc:
  assumes r: "\<forall>n. cmod (s n) \<le> r"
  shows "\<exists>f z. strict_mono (f :: nat \<Rightarrow> nat) \<and> (\<forall>e >0. \<exists>N. \<forall>n \<ge> N. cmod (s (f n) - z) < e)"
proof -
  from seq_monosub[of "Re \<circ> s"]
  obtain f where f: "strict_mono f" "monoseq (\<lambda>n. Re (s (f n)))"
    unfolding o_def by blast
  from seq_monosub[of "Im \<circ> s \<circ> f"]
  obtain g where g: "strict_mono g" "monoseq (\<lambda>n. Im (s (f (g n))))"
    unfolding o_def by blast
  let ?h = "f \<circ> g"
  from r[rule_format, of 0] have rp: "r \<ge> 0"
    using norm_ge_zero[of "s 0"] by arith
  have th: "\<forall>n. r + 1 \<ge> \<bar>Re (s n)\<bar>"
  proof
    fix n
    from abs_Re_le_cmod[of "s n"] r[rule_format, of n]
    show "\<bar>Re (s n)\<bar> \<le> r + 1" by arith
  qed
  have conv1: "convergent (\<lambda>n. Re (s (f n)))"
    apply (rule Bseq_monoseq_convergent)
    apply (simp add: Bseq_def)
    apply (metis gt_ex le_less_linear less_trans order.trans th)
    apply (rule f(2))
    done
  have th: "\<forall>n. r + 1 \<ge> \<bar>Im (s n)\<bar>"
  proof
    fix n
    from abs_Im_le_cmod[of "s n"] r[rule_format, of n]
    show "\<bar>Im (s n)\<bar> \<le> r + 1"
      by arith
  qed

  have conv2: "convergent (\<lambda>n. Im (s (f (g n))))"
    apply (rule Bseq_monoseq_convergent)
    apply (simp add: Bseq_def)
    apply (metis gt_ex le_less_linear less_trans order.trans th)
    apply (rule g(2))
    done

  from conv1[unfolded convergent_def] obtain x where "LIMSEQ (\<lambda>n. Re (s (f n))) x"
    by blast
  then have x: "\<forall>r>0. \<exists>n0. \<forall>n\<ge>n0. \<bar>Re (s (f n)) - x\<bar> < r"
    unfolding LIMSEQ_iff real_norm_def .

  from conv2[unfolded convergent_def] obtain y where "LIMSEQ (\<lambda>n. Im (s (f (g n)))) y"
    by blast
  then have y: "\<forall>r>0. \<exists>n0. \<forall>n\<ge>n0. \<bar>Im (s (f (g n))) - y\<bar> < r"
    unfolding LIMSEQ_iff real_norm_def .
  let ?w = "Complex x y"
  from f(1) g(1) have hs: "strict_mono ?h"
    unfolding strict_mono_def by auto
  have "\<exists>N. \<forall>n\<ge>N. cmod (s (?h n) - ?w) < e" if "e > 0" for e
  proof -
    from that have e2: "e/2 > 0"
      by simp
    from x[rule_format, OF e2] y[rule_format, OF e2]
    obtain N1 N2 where N1: "\<forall>n\<ge>N1. \<bar>Re (s (f n)) - x\<bar> < e / 2"
      and N2: "\<forall>n\<ge>N2. \<bar>Im (s (f (g n))) - y\<bar> < e / 2"
      by blast
    have "cmod (s (?h n) - ?w) < e" if "n \<ge> N1 + N2" for n
    proof -
      from that have nN1: "g n \<ge> N1" and nN2: "n \<ge> N2"
        using seq_suble[OF g(1), of n] by arith+
      from add_strict_mono[OF N1[rule_format, OF nN1] N2[rule_format, OF nN2]]
      show ?thesis
        using metric_bound_lemma[of "s (f (g n))" ?w] by simp
    qed
    then show ?thesis by blast
  qed
  with hs show ?thesis by blast
qed

text \<open>Polynomial is continuous.\<close>

lemma poly_cont:
  fixes p :: "'a::{comm_semiring_0,real_normed_div_algebra} poly"
  assumes ep: "e > 0"
  shows "\<exists>d >0. \<forall>w. 0 < norm (w - z) \<and> norm (w - z) < d \<longrightarrow> norm (poly p w - poly p z) < e"
proof -
  obtain q where q: "degree q = degree p" "poly q x = poly p (z + x)" for x
  proof
    show "degree (offset_poly p z) = degree p"
      by (rule degree_offset_poly)
    show "\<And>x. poly (offset_poly p z) x = poly p (z + x)"
      by (rule poly_offset_poly)
  qed
  have th: "\<And>w. poly q (w - z) = poly p w"
    using q(2)[of "w - z" for w] by simp
  show ?thesis unfolding th[symmetric]
  proof (induct q)
    case 0
    then show ?case
      using ep by auto
  next
    case (pCons c cs)
    from poly_bound_exists[of 1 "cs"]
    obtain m where m: "m > 0" "norm z \<le> 1 \<Longrightarrow> norm (poly cs z) \<le> m" for z
      by blast
    from ep m(1) have em0: "e/m > 0"
      by (simp add: field_simps)
    have one0: "1 > (0::real)"
      by arith
    from field_lbound_gt_zero[OF one0 em0]
    obtain d where d: "d > 0" "d < 1" "d < e / m"
      by blast
    from d(1,3) m(1) have dm: "d * m > 0" "d * m < e"
      by (simp_all add: field_simps)
    show ?case
    proof (rule ex_forward[OF field_lbound_gt_zero[OF one0 em0]], clarsimp simp add: norm_mult)
      fix d w
      assume H: "d > 0" "d < 1" "d < e/m" "w \<noteq> z" "norm (w - z) < d"
      then have d1: "norm (w-z) \<le> 1" "d \<ge> 0"
        by simp_all
      from H(3) m(1) have dme: "d*m < e"
        by (simp add: field_simps)
      from H have th: "norm (w - z) \<le> d"
        by simp
      from mult_mono[OF th m(2)[OF d1(1)] d1(2) norm_ge_zero] dme
      show "norm (w - z) * norm (poly cs (w - z)) < e"
        by simp
    qed
  qed
qed

text \<open>Hence a polynomial attains minimum on a closed disc
  in the complex plane.\<close>
lemma poly_minimum_modulus_disc: "\<exists>z. \<forall>w. cmod w \<le> r \<longrightarrow> cmod (poly p z) \<le> cmod (poly p w)"
proof -
  show ?thesis
  proof (cases "r \<ge> 0")
    case False
    then show ?thesis
      by (metis norm_ge_zero order.trans)
  next
    case True
    then have "cmod 0 \<le> r \<and> cmod (poly p 0) = - (- cmod (poly p 0))"
      by simp
    then have mth1: "\<exists>x z. cmod z \<le> r \<and> cmod (poly p z) = - x"
      by blast
    have False if "cmod z \<le> r" "cmod (poly p z) = - x" "\<not> x < 1" for x z
    proof -
      from that have "- x < 0 "
        by arith
      with that(2) norm_ge_zero[of "poly p z"] show ?thesis
        by simp
    qed
    then have mth2: "\<exists>z. \<forall>x. (\<exists>z. cmod z \<le> r \<and> cmod (poly p z) = - x) \<longrightarrow> x < z"
      by blast
    from real_sup_exists[OF mth1 mth2] obtain s where
      s: "\<forall>y. (\<exists>x. (\<exists>z. cmod z \<le> r \<and> cmod (poly p z) = - x) \<and> y < x) \<longleftrightarrow> y < s"
      by blast
    let ?m = "- s"
    have s1[unfolded minus_minus]:
      "(\<exists>z x. cmod z \<le> r \<and> - (- cmod (poly p z)) < y) \<longleftrightarrow> ?m < y" for y
      using s[rule_format, of "-y"]
      unfolding minus_less_iff[of y] equation_minus_iff by blast
    from s1[of ?m] have s1m: "\<And>z x. cmod z \<le> r \<Longrightarrow> cmod (poly p z) \<ge> ?m"
      by auto
    have "\<exists>z. cmod z \<le> r \<and> cmod (poly p z) < - s + 1 / real (Suc n)" for n
      using s1[rule_format, of "?m + 1/real (Suc n)"] by simp
    then have th: "\<forall>n. \<exists>z. cmod z \<le> r \<and> cmod (poly p z) < - s + 1 / real (Suc n)" ..
    from choice[OF th] obtain g where
        g: "\<forall>n. cmod (g n) \<le> r" "\<forall>n. cmod (poly p (g n)) <?m + 1 /real(Suc n)"
      by blast
    from Bolzano_Weierstrass_complex_disc[OF g(1)]
    obtain f z where fz: "strict_mono (f :: nat \<Rightarrow> nat)" "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. cmod (g (f n) - z) < e"
      by blast
    {
      fix w
      assume wr: "cmod w \<le> r"
      let ?e = "\<bar>cmod (poly p z) - ?m\<bar>"
      {
        assume e: "?e > 0"
        then have e2: "?e/2 > 0"
          by simp
        from poly_cont[OF e2, of z p] obtain d where
            d: "d > 0" "\<forall>w. 0<cmod (w - z)\<and> cmod(w - z) < d \<longrightarrow> cmod(poly p w - poly p z) < ?e/2"
          by blast
        have th1: "cmod(poly p w - poly p z) < ?e / 2" if w: "cmod (w - z) < d" for w
          using d(2)[rule_format, of w] w e by (cases "w = z") simp_all
        from fz(2) d(1) obtain N1 where N1: "\<forall>n\<ge>N1. cmod (g (f n) - z) < d"
          by blast
        from reals_Archimedean2[of "2/?e"] obtain N2 :: nat where N2: "2/?e < real N2"
          by blast
        have th2: "cmod (poly p (g (f (N1 + N2))) - poly p z) < ?e/2"
          using N1[rule_format, of "N1 + N2"] th1 by simp
        have th0: "a < e2 \<Longrightarrow> \<bar>b - m\<bar> < e2 \<Longrightarrow> 2 * e2 \<le> \<bar>b - m\<bar> + a \<Longrightarrow> False"
          for a b e2 m :: real
          by arith
        have ath: "m \<le> x \<Longrightarrow> x < m + e \<Longrightarrow> \<bar>x - m\<bar> < e" for m x e :: real
          by arith
        from s1m[OF g(1)[rule_format]] have th31: "?m \<le> cmod(poly p (g (f (N1 + N2))))" .
        from seq_suble[OF fz(1), of "N1 + N2"]
        have th00: "real (Suc (N1 + N2)) \<le> real (Suc (f (N1 + N2)))"
          by simp
        have th000: "0 \<le> (1::real)" "(1::real) \<le> 1" "real (Suc (N1 + N2)) > 0"
          using N2 by auto
        from frac_le[OF th000 th00]
        have th00: "?m + 1 / real (Suc (f (N1 + N2))) \<le> ?m + 1 / real (Suc (N1 + N2))"
          by simp
        from g(2)[rule_format, of "f (N1 + N2)"]
        have th01:"cmod (poly p (g (f (N1 + N2)))) < - s + 1 / real (Suc (f (N1 + N2)))" .
        from order_less_le_trans[OF th01 th00]
        have th32: "cmod (poly p (g (f (N1 + N2)))) < ?m + (1/ real(Suc (N1 + N2)))" .
        from N2 have "2/?e < real (Suc (N1 + N2))"
          by arith
        with e2 less_imp_inverse_less[of "2/?e" "real (Suc (N1 + N2))"]
        have "?e/2 > 1/ real (Suc (N1 + N2))"
          by (simp add: inverse_eq_divide)
        with ath[OF th31 th32] have thc1: "\<bar>cmod (poly p (g (f (N1 + N2)))) - ?m\<bar> < ?e/2"
          by arith
        have ath2: "\<bar>a - b\<bar> \<le> c \<Longrightarrow> \<bar>b - m\<bar> \<le> \<bar>a - m\<bar> + c" for a b c m :: real
          by arith
        have th22: "\<bar>cmod (poly p (g (f (N1 + N2)))) - cmod (poly p z)\<bar> \<le>
            cmod (poly p (g (f (N1 + N2))) - poly p z)"
          by (simp add: norm_triangle_ineq3)
        from ath2[OF th22, of ?m]
        have thc2: "2 * (?e/2) \<le>
            \<bar>cmod(poly p (g (f (N1 + N2)))) - ?m\<bar> + cmod (poly p (g (f (N1 + N2))) - poly p z)"
          by simp
        from th0[OF th2 thc1 thc2] have False .
      }
      then have "?e = 0"
        by auto
      then have "cmod (poly p z) = ?m"
        by simp
      with s1m[OF wr] have "cmod (poly p z) \<le> cmod (poly p w)"
        by simp
    }
    then show ?thesis by blast
  qed
qed

text \<open>Nonzero polynomial in z goes to infinity as z does.\<close>

lemma poly_infinity:
  fixes p:: "'a::{comm_semiring_0,real_normed_div_algebra} poly"
  assumes ex: "p \<noteq> 0"
  shows "\<exists>r. \<forall>z. r \<le> norm z \<longrightarrow> d \<le> norm (poly (pCons a p) z)"
  using ex
proof (induct p arbitrary: a d)
  case 0
  then show ?case by simp
next
  case (pCons c cs a d)
  show ?case
  proof (cases "cs = 0")
    case False
    with pCons.hyps obtain r where r: "\<forall>z. r \<le> norm z \<longrightarrow> d + norm a \<le> norm (poly (pCons c cs) z)"
      by blast
    let ?r = "1 + \<bar>r\<bar>"
    have "d \<le> norm (poly (pCons a (pCons c cs)) z)" if "1 + \<bar>r\<bar> \<le> norm z" for z
    proof -
      have r0: "r \<le> norm z"
        using that by arith
      from r[rule_format, OF r0] have th0: "d + norm a \<le> 1 * norm(poly (pCons c cs) z)"
        by arith
      from that have z1: "norm z \<ge> 1"
        by arith
      from order_trans[OF th0 mult_right_mono[OF z1 norm_ge_zero[of "poly (pCons c cs) z"]]]
      have th1: "d \<le> norm(z * poly (pCons c cs) z) - norm a"
        unfolding norm_mult by (simp add: algebra_simps)
      from norm_diff_ineq[of "z * poly (pCons c cs) z" a]
      have th2: "norm (z * poly (pCons c cs) z) - norm a \<le> norm (poly (pCons a (pCons c cs)) z)"
        by (simp add: algebra_simps)
      from th1 th2 show ?thesis
        by arith
    qed
    then show ?thesis by blast
  next
    case True
    with pCons.prems have c0: "c \<noteq> 0"
      by simp
    have "d \<le> norm (poly (pCons a (pCons c cs)) z)"
      if h: "(\<bar>d\<bar> + norm a) / norm c \<le> norm z" for z :: 'a
    proof -
      from c0 have "norm c > 0"
        by simp
      from h c0 have th0: "\<bar>d\<bar> + norm a \<le> norm (z * c)"
        by (simp add: field_simps norm_mult)
      have ath: "\<And>mzh mazh ma. mzh \<le> mazh + ma \<Longrightarrow> \<bar>d\<bar> + ma \<le> mzh \<Longrightarrow> d \<le> mazh"
        by arith
      from norm_diff_ineq[of "z * c" a] have th1: "norm (z * c) \<le> norm (a + z * c) + norm a"
        by (simp add: algebra_simps)
      from ath[OF th1 th0] show ?thesis
        using True by simp
    qed
    then show ?thesis by blast
  qed
qed

text \<open>Hence polynomial's modulus attains its minimum somewhere.\<close>
lemma poly_minimum_modulus: "\<exists>z.\<forall>w. cmod (poly p z) \<le> cmod (poly p w)"
proof (induct p)
  case 0
  then show ?case by simp
next
  case (pCons c cs)
  show ?case
  proof (cases "cs = 0")
    case False
    from poly_infinity[OF False, of "cmod (poly (pCons c cs) 0)" c]
    obtain r where r: "cmod (poly (pCons c cs) 0) \<le> cmod (poly (pCons c cs) z)"
      if "r \<le> cmod z" for z
      by blast
    have ath: "\<And>z r. r \<le> cmod z \<or> cmod z \<le> \<bar>r\<bar>"
      by arith
    from poly_minimum_modulus_disc[of "\<bar>r\<bar>" "pCons c cs"]
    obtain v where v: "cmod (poly (pCons c cs) v) \<le> cmod (poly (pCons c cs) w)"
      if "cmod w \<le> \<bar>r\<bar>" for w
      by blast
    have "cmod (poly (pCons c cs) v) \<le> cmod (poly (pCons c cs) z)" if z: "r \<le> cmod z" for z
      using v[of 0] r[OF z] by simp
    with v ath[of r] show ?thesis
      by blast
  next
    case True
    with pCons.hyps show ?thesis
      by simp
  qed
qed

text \<open>Constant function (non-syntactic characterization).\<close>
definition "constant f \<longleftrightarrow> (\<forall>x y. f x = f y)"

lemma nonconstant_length: "\<not> constant (poly p) \<Longrightarrow> psize p \<ge> 2"
  by (induct p) (auto simp: constant_def psize_def)

lemma poly_replicate_append: "poly (monom 1 n * p) (x::'a::comm_ring_1) = x^n * poly p x"
  by (simp add: poly_monom)

text \<open>Decomposition of polynomial, skipping zero coefficients after the first.\<close>

lemma poly_decompose_lemma:
  assumes nz: "\<not> (\<forall>z. z \<noteq> 0 \<longrightarrow> poly p z = (0::'a::idom))"
  shows "\<exists>k a q. a \<noteq> 0 \<and> Suc (psize q + k) = psize p \<and> (\<forall>z. poly p z = z^k * poly (pCons a q) z)"
  unfolding psize_def
  using nz
proof (induct p)
  case 0
  then show ?case by simp
next
  case (pCons c cs)
  show ?case
  proof (cases "c = 0")
    case True
    from pCons.hyps pCons.prems True show ?thesis
      apply auto
      apply (rule_tac x="k+1" in exI)
      apply (rule_tac x="a" in exI)
      apply clarsimp
      apply (rule_tac x="q" in exI)
      apply auto
      done
  next
    case False
    show ?thesis
      apply (rule exI[where x=0])
      apply (rule exI[where x=c])
      apply (auto simp: False)
      done
  qed
qed

lemma poly_decompose:
  assumes nc: "\<not> constant (poly p)"
  shows "\<exists>k a q. a \<noteq> (0::'a::idom) \<and> k \<noteq> 0 \<and>
               psize q + k + 1 = psize p \<and>
              (\<forall>z. poly p z = poly p 0 + z^k * poly (pCons a q) z)"
  using nc
proof (induct p)
  case 0
  then show ?case
    by (simp add: constant_def)
next
  case (pCons c cs)
  have "\<not> (\<forall>z. z \<noteq> 0 \<longrightarrow> poly cs z = 0)"
  proof
    assume "\<forall>z. z \<noteq> 0 \<longrightarrow> poly cs z = 0"
    then have "poly (pCons c cs) x = poly (pCons c cs) y" for x y
      by (cases "x = 0") auto
    with pCons.prems show False
      by (auto simp add: constant_def)
  qed
  from poly_decompose_lemma[OF this]
  show ?case
    apply clarsimp
    apply (rule_tac x="k+1" in exI)
    apply (rule_tac x="a" in exI)
    apply simp
    apply (rule_tac x="q" in exI)
    apply (auto simp add: psize_def split: if_splits)
    done
qed

text \<open>Fundamental theorem of algebra\<close>

lemma fundamental_theorem_of_algebra:
  assumes nc: "\<not> constant (poly p)"
  shows "\<exists>z::complex. poly p z = 0"
  using nc
proof (induct "psize p" arbitrary: p rule: less_induct)
  case less
  let ?p = "poly p"
  let ?ths = "\<exists>z. ?p z = 0"

  from nonconstant_length[OF less(2)] have n2: "psize p \<ge> 2" .
  from poly_minimum_modulus obtain c where c: "\<forall>w. cmod (?p c) \<le> cmod (?p w)"
    by blast

  show ?ths
  proof (cases "?p c = 0")
    case True
    then show ?thesis by blast
  next
    case False
    from poly_offset[of p c] obtain q where q: "psize q = psize p" "\<forall>x. poly q x = ?p (c + x)"
      by blast
    have False if h: "constant (poly q)"
    proof -
      from q(2) have th: "\<forall>x. poly q (x - c) = ?p x"
        by auto
      have "?p x = ?p y" for x y
      proof -
        from th have "?p x = poly q (x - c)"
          by auto
        also have "\<dots> = poly q (y - c)"
          using h unfolding constant_def by blast
        also have "\<dots> = ?p y"
          using th by auto
        finally show ?thesis .
      qed
      with less(2) show ?thesis
        unfolding constant_def by blast
    qed
    then have qnc: "\<not> constant (poly q)"
      by blast
    from q(2) have pqc0: "?p c = poly q 0"
      by simp
    from c pqc0 have cq0: "\<forall>w. cmod (poly q 0) \<le> cmod (?p w)"
      by simp
    let ?a0 = "poly q 0"
    from False pqc0 have a00: "?a0 \<noteq> 0"
      by simp
    from a00 have qr: "\<forall>z. poly q z = poly (smult (inverse ?a0) q) z * ?a0"
      by simp
    let ?r = "smult (inverse ?a0) q"
    have lgqr: "psize q = psize ?r"
      using a00
      unfolding psize_def degree_def
      by (simp add: poly_eq_iff)
    have False if h: "\<And>x y. poly ?r x = poly ?r y"
    proof -
      have "poly q x = poly q y" for x y
      proof -
        from qr[rule_format, of x] have "poly q x = poly ?r x * ?a0"
          by auto
        also have "\<dots> = poly ?r y * ?a0"
          using h by simp
        also have "\<dots> = poly q y"
          using qr[rule_format, of y] by simp
        finally show ?thesis .
      qed
      with qnc show ?thesis
        unfolding constant_def by blast
    qed
    then have rnc: "\<not> constant (poly ?r)"
      unfolding constant_def by blast
    from qr[rule_format, of 0] a00 have r01: "poly ?r 0 = 1"
      by auto
    have mrmq_eq: "cmod (poly ?r w) < 1 \<longleftrightarrow> cmod (poly q w) < cmod ?a0" for w
    proof -
      have "cmod (poly ?r w) < 1 \<longleftrightarrow> cmod (poly q w / ?a0) < 1"
        using qr[rule_format, of w] a00 by (simp add: divide_inverse ac_simps)
      also have "\<dots> \<longleftrightarrow> cmod (poly q w) < cmod ?a0"
        using a00 unfolding norm_divide by (simp add: field_simps)
      finally show ?thesis .
    qed
    from poly_decompose[OF rnc] obtain k a s where
      kas: "a \<noteq> 0" "k \<noteq> 0" "psize s + k + 1 = psize ?r"
        "\<forall>z. poly ?r z = poly ?r 0 + z^k* poly (pCons a s) z" by blast
    have "\<exists>w. cmod (poly ?r w) < 1"
    proof (cases "psize p = k + 1")
      case True
      with kas(3) lgqr[symmetric] q(1) have s0: "s = 0"
        by auto
      have hth[symmetric]: "cmod (poly ?r w) = cmod (1 + a * w ^ k)" for w
        using kas(4)[rule_format, of w] s0 r01 by (simp add: algebra_simps)
      from reduce_poly_simple[OF kas(1,2)] show ?thesis
        unfolding hth by blast
    next
      case False note kn = this
      from kn kas(3) q(1) lgqr have k1n: "k + 1 < psize p"
        by simp
      have th01: "\<not> constant (poly (pCons 1 (monom a (k - 1))))"
        unfolding constant_def poly_pCons poly_monom
        using kas(1)
        apply simp
        apply (rule exI[where x=0])
        apply (rule exI[where x=1])
        apply simp
        done
      from kas(1) kas(2) have th02: "k + 1 = psize (pCons 1 (monom a (k - 1)))"
        by (simp add: psize_def degree_monom_eq)
      from less(1) [OF k1n [simplified th02] th01]
      obtain w where w: "1 + w^k * a = 0"
        unfolding poly_pCons poly_monom
        using kas(2) by (cases k) (auto simp add: algebra_simps)
      from poly_bound_exists[of "cmod w" s] obtain m where
        m: "m > 0" "\<forall>z. cmod z \<le> cmod w \<longrightarrow> cmod (poly s z) \<le> m" by blast
      have w0: "w \<noteq> 0"
        using kas(2) w by (auto simp add: power_0_left)
      from w have "(1 + w ^ k * a) - 1 = 0 - 1"
        by simp
      then have wm1: "w^k * a = - 1"
        by simp
      have inv0: "0 < inverse (cmod w ^ (k + 1) * m)"
        using norm_ge_zero[of w] w0 m(1)
        by (simp add: inverse_eq_divide zero_less_mult_iff)
      with field_lbound_gt_zero[OF zero_less_one] obtain t where
        t: "t > 0" "t < 1" "t < inverse (cmod w ^ (k + 1) * m)" by blast
      let ?ct = "complex_of_real t"
      let ?w = "?ct * w"
      have "1 + ?w^k * (a + ?w * poly s ?w) = 1 + ?ct^k * (w^k * a) + ?w^k * ?w * poly s ?w"
        using kas(1) by (simp add: algebra_simps power_mult_distrib)
      also have "\<dots> = complex_of_real (1 - t^k) + ?w^k * ?w * poly s ?w"
        unfolding wm1 by simp
      finally have "cmod (1 + ?w^k * (a + ?w * poly s ?w)) =
        cmod (complex_of_real (1 - t^k) + ?w^k * ?w * poly s ?w)"
        by metis
      with norm_triangle_ineq[of "complex_of_real (1 - t^k)" "?w^k * ?w * poly s ?w"]
      have th11: "cmod (1 + ?w^k * (a + ?w * poly s ?w)) \<le> \<bar>1 - t^k\<bar> + cmod (?w^k * ?w * poly s ?w)"
        unfolding norm_of_real by simp
      have ath: "\<And>x t::real. 0 \<le> x \<Longrightarrow> x < t \<Longrightarrow> t \<le> 1 \<Longrightarrow> \<bar>1 - t\<bar> + x < 1"
        by arith
      have "t * cmod w \<le> 1 * cmod w"
        apply (rule mult_mono)
        using t(1,2)
        apply auto
        done
      then have tw: "cmod ?w \<le> cmod w"
        using t(1) by (simp add: norm_mult)
      from t inv0 have "t * (cmod w ^ (k + 1) * m) < 1"
        by (simp add: field_simps)
      with zero_less_power[OF t(1), of k] have th30: "t^k * (t* (cmod w ^ (k + 1) * m)) < t^k * 1"
        by simp
      have "cmod (?w^k * ?w * poly s ?w) = t^k * (t* (cmod w ^ (k + 1) * cmod (poly s ?w)))"
        using w0 t(1)
        by (simp add: algebra_simps power_mult_distrib norm_power norm_mult)
      then have "cmod (?w^k * ?w * poly s ?w) \<le> t^k * (t* (cmod w ^ (k + 1) * m))"
        using t(1,2) m(2)[rule_format, OF tw] w0
        by auto
      with th30 have th120: "cmod (?w^k * ?w * poly s ?w) < t^k"
        by simp
      from power_strict_mono[OF t(2), of k] t(1) kas(2) have th121: "t^k \<le> 1"
        by auto
      from ath[OF norm_ge_zero[of "?w^k * ?w * poly s ?w"] th120 th121]
      have th12: "\<bar>1 - t^k\<bar> + cmod (?w^k * ?w * poly s ?w) < 1" .
      from th11 th12 have "cmod (1 + ?w^k * (a + ?w * poly s ?w)) < 1"
        by arith
      then have "cmod (poly ?r ?w) < 1"
        unfolding kas(4)[rule_format, of ?w] r01 by simp
      then show ?thesis
        by blast
    qed
    with cq0 q(2) show ?thesis
      unfolding mrmq_eq not_less[symmetric] by auto
  qed
qed

text \<open>Alternative version with a syntactic notion of constant polynomial.\<close>

lemma fundamental_theorem_of_algebra_alt:
  assumes nc: "\<not> (\<exists>a l. a \<noteq> 0 \<and> l = 0 \<and> p = pCons a l)"
  shows "\<exists>z. poly p z = (0::complex)"
  using nc
proof (induct p)
  case 0
  then show ?case by simp
next
  case (pCons c cs)
  show ?case
  proof (cases "c = 0")
    case True
    then show ?thesis by auto
  next
    case False
    have "\<not> constant (poly (pCons c cs))"
    proof
      assume nc: "constant (poly (pCons c cs))"
      from nc[unfolded constant_def, rule_format, of 0]
      have "\<forall>w. w \<noteq> 0 \<longrightarrow> poly cs w = 0" by auto
      then have "cs = 0"
      proof (induct cs)
        case 0
        then show ?case by simp
      next
        case (pCons d ds)
        show ?case
        proof (cases "d = 0")
          case True
          then show ?thesis
            using pCons.prems pCons.hyps by simp
        next
          case False
          from poly_bound_exists[of 1 ds] obtain m where
            m: "m > 0" "\<forall>z. \<forall>z. cmod z \<le> 1 \<longrightarrow> cmod (poly ds z) \<le> m" by blast
          have dm: "cmod d / m > 0"
            using False m(1) by (simp add: field_simps)
          from field_lbound_gt_zero[OF dm zero_less_one]
          obtain x where x: "x > 0" "x < cmod d / m" "x < 1"
            by blast
          let ?x = "complex_of_real x"
          from x have cx: "?x \<noteq> 0" "cmod ?x \<le> 1"
            by simp_all
          from pCons.prems[rule_format, OF cx(1)]
          have cth: "cmod (?x*poly ds ?x) = cmod d"
            by (simp add: eq_diff_eq[symmetric])
          from m(2)[rule_format, OF cx(2)] x(1)
          have th0: "cmod (?x*poly ds ?x) \<le> x*m"
            by (simp add: norm_mult)
          from x(2) m(1) have "x * m < cmod d"
            by (simp add: field_simps)
          with th0 have "cmod (?x*poly ds ?x) \<noteq> cmod d"
            by auto
          with cth show ?thesis
            by blast
        qed
      qed
      then show False
        using pCons.prems False by blast
    qed
    then show ?thesis
      by (rule fundamental_theorem_of_algebra)
  qed
qed

subsection \<open>Nullstellensatz, degrees and divisibility of polynomials\<close>

lemma nullstellensatz_lemma:
  fixes p :: "complex poly"
  assumes "\<forall>x. poly p x = 0 \<longrightarrow> poly q x = 0"
    and "degree p = n"
    and "n \<noteq> 0"
  shows "p dvd (q ^ n)"
  using assms
proof (induct n arbitrary: p q rule: nat_less_induct)
  fix n :: nat
  fix p q :: "complex poly"
  assume IH: "\<forall>m<n. \<forall>p q.
                 (\<forall>x. poly p x = (0::complex) \<longrightarrow> poly q x = 0) \<longrightarrow>
                 degree p = m \<longrightarrow> m \<noteq> 0 \<longrightarrow> p dvd (q ^ m)"
    and pq0: "\<forall>x. poly p x = 0 \<longrightarrow> poly q x = 0"
    and dpn: "degree p = n"
    and n0: "n \<noteq> 0"
  from dpn n0 have pne: "p \<noteq> 0" by auto
  show "p dvd (q ^ n)"
  proof (cases "\<exists>a. poly p a = 0")
    case True
    then obtain a where a: "poly p a = 0" ..
    have ?thesis if oa: "order a p \<noteq> 0"
    proof -
      let ?op = "order a p"
      from pne have ap: "([:- a, 1:] ^ ?op) dvd p" "\<not> [:- a, 1:] ^ (Suc ?op) dvd p"
        using order by blast+
      note oop = order_degree[OF pne, unfolded dpn]
      show ?thesis
      proof (cases "q = 0")
        case True
        with n0 show ?thesis by (simp add: power_0_left)
      next
        case False
        from pq0[rule_format, OF a, unfolded poly_eq_0_iff_dvd]
        obtain r where r: "q = [:- a, 1:] * r" by (rule dvdE)
        from ap(1) obtain s where s: "p = [:- a, 1:] ^ ?op * s"
          by (rule dvdE)
        have sne: "s \<noteq> 0"
          using s pne by auto
        show ?thesis
        proof (cases "degree s = 0")
          case True
          then obtain k where kpn: "s = [:k:]"
            by (cases s) (auto split: if_splits)
          from sne kpn have k: "k \<noteq> 0" by simp
          let ?w = "([:1/k:] * ([:-a,1:] ^ (n - ?op))) * (r ^ n)"
          have "q ^ n = p * ?w"
            apply (subst r)
            apply (subst s)
            apply (subst kpn)
            using k oop [of a]
            apply (subst power_mult_distrib)
            apply simp
            apply (subst power_add [symmetric])
            apply simp
            done
          then show ?thesis
            unfolding dvd_def by blast
        next
          case False
          with sne dpn s oa have dsn: "degree s < n"
            apply auto
            apply (erule ssubst)
            apply (simp add: degree_mult_eq degree_linear_power)
            done
          have "poly r x = 0" if h: "poly s x = 0" for x
          proof -
            have xa: "x \<noteq> a"
            proof
              assume "x = a"
              from h[unfolded this poly_eq_0_iff_dvd] obtain u where u: "s = [:- a, 1:] * u"
                by (rule dvdE)
              have "p = [:- a, 1:] ^ (Suc ?op) * u"
                apply (subst s)
                apply (subst u)
                apply (simp only: power_Suc ac_simps)
                done
              with ap(2)[unfolded dvd_def] show False
                by blast
            qed
            from h have "poly p x = 0"
              by (subst s) simp
            with pq0 have "poly q x = 0"
              by blast
            with r xa show ?thesis
              by auto
          qed
          with IH[rule_format, OF dsn, of s r] False have "s dvd (r ^ (degree s))"
            by blast
          then obtain u where u: "r ^ (degree s) = s * u" ..
          then have u': "\<And>x. poly s x * poly u x = poly r x ^ degree s"
            by (simp only: poly_mult[symmetric] poly_power[symmetric])
          let ?w = "(u * ([:-a,1:] ^ (n - ?op))) * (r ^ (n - degree s))"
          from oop[of a] dsn have "q ^ n = p * ?w"
            apply -
            apply (subst s)
            apply (subst r)
            apply (simp only: power_mult_distrib)
            apply (subst mult.assoc [where b=s])
            apply (subst mult.assoc [where a=u])
            apply (subst mult.assoc [where b=u, symmetric])
            apply (subst u [symmetric])
            apply (simp add: ac_simps power_add [symmetric])
            done
          then show ?thesis
            unfolding dvd_def by blast
        qed
      qed
    qed
    then show ?thesis
      using a order_root pne by blast
  next
    case False
    with fundamental_theorem_of_algebra_alt[of p]
    obtain c where ccs: "c \<noteq> 0" "p = pCons c 0"
      by blast
    then have pp: "poly p x = c" for x
      by simp
    let ?w = "[:1/c:] * (q ^ n)"
    from ccs have "(q ^ n) = (p * ?w)"
      by simp
    then show ?thesis
      unfolding dvd_def by blast
  qed
qed

lemma nullstellensatz_univariate:
  "(\<forall>x. poly p x = (0::complex) \<longrightarrow> poly q x = 0) \<longleftrightarrow>
    p dvd (q ^ (degree p)) \<or> (p = 0 \<and> q = 0)"
proof -
  consider "p = 0" | "p \<noteq> 0" "degree p = 0" | n where "p \<noteq> 0" "degree p = Suc n"
    by (cases "degree p") auto
  then show ?thesis
  proof cases
    case p: 1
    then have eq: "(\<forall>x. poly p x = (0::complex) \<longrightarrow> poly q x = 0) \<longleftrightarrow> q = 0"
      by (auto simp add: poly_all_0_iff_0)
    {
      assume "p dvd (q ^ (degree p))"
      then obtain r where r: "q ^ (degree p) = p * r" ..
      from r p have False by simp
    }
    with eq p show ?thesis by blast
  next
    case dp: 2
    then obtain k where k: "p = [:k:]" "k \<noteq> 0"
      by (cases p) (simp split: if_splits)
    then have th1: "\<forall>x. poly p x \<noteq> 0"
      by simp
    from k dp(2) have "q ^ (degree p) = p * [:1/k:]"
      by simp
    then have th2: "p dvd (q ^ (degree p))" ..
    from dp(1) th1 th2 show ?thesis
      by blast
  next
    case dp: 3
    have False if dvd: "p dvd (q ^ (Suc n))" and h: "poly p x = 0" "poly q x \<noteq> 0" for x
    proof -
      from dvd obtain u where u: "q ^ (Suc n) = p * u" ..
      from h have "poly (q ^ (Suc n)) x \<noteq> 0"
        by simp
      with u h(1) show ?thesis
        by (simp only: poly_mult) simp
    qed
    with dp nullstellensatz_lemma[of p q "degree p"] show ?thesis
      by auto
  qed
qed

text \<open>Useful lemma\<close>
lemma constant_degree:
  fixes p :: "'a::{idom,ring_char_0} poly"
  shows "constant (poly p) \<longleftrightarrow> degree p = 0" (is "?lhs = ?rhs")
proof
  show ?rhs if ?lhs
  proof -
    from that[unfolded constant_def, rule_format, of _ "0"]
    have th: "poly p = poly [:poly p 0:]"
      by auto
    then have "p = [:poly p 0:]"
      by (simp add: poly_eq_poly_eq_iff)
    then have "degree p = degree [:poly p 0:]"
      by simp
    then show ?thesis
      by simp
  qed
  show ?lhs if ?rhs
  proof -
    from that obtain k where "p = [:k:]"
      by (cases p) (simp split: if_splits)
    then show ?thesis
      unfolding constant_def by auto
  qed
qed

text \<open>Arithmetic operations on multivariate polynomials.\<close>

lemma mpoly_base_conv:
  fixes x :: "'a::comm_ring_1"
  shows "0 = poly 0 x" "c = poly [:c:] x" "x = poly [:0,1:] x"
  by simp_all

lemma mpoly_norm_conv:
  fixes x :: "'a::comm_ring_1"
  shows "poly [:0:] x = poly 0 x" "poly [:poly 0 y:] x = poly 0 x"
  by simp_all

lemma mpoly_sub_conv:
  fixes x :: "'a::comm_ring_1"
  shows "poly p x - poly q x = poly p x + -1 * poly q x"
  by simp

lemma poly_pad_rule: "poly p x = 0 \<Longrightarrow> poly (pCons 0 p) x = 0"
  by simp

lemma poly_cancel_eq_conv:
  fixes x :: "'a::field"
  shows "x = 0 \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> y = 0 \<longleftrightarrow> a * y - b * x = 0"
  by auto

lemma poly_divides_pad_rule:
  fixes p:: "('a::comm_ring_1) poly"
  assumes pq: "p dvd q"
  shows "p dvd (pCons 0 q)"
proof -
  have "pCons 0 q = q * [:0,1:]" by simp
  then have "q dvd (pCons 0 q)" ..
  with pq show ?thesis by (rule dvd_trans)
qed

lemma poly_divides_conv0:
  fixes p:: "'a::field poly"
  assumes lgpq: "degree q < degree p"
    and lq: "p \<noteq> 0"
  shows "p dvd q \<longleftrightarrow> q = 0" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  then have "q = p * 0" by simp
  then show ?lhs ..
next
  assume l: ?lhs
  show ?rhs
  proof (cases "q = 0")
    case True
    then show ?thesis by simp
  next
    assume q0: "q \<noteq> 0"
    from l q0 have "degree p \<le> degree q"
      by (rule dvd_imp_degree_le)
    with lgpq show ?thesis by simp
  qed
qed

lemma poly_divides_conv1:
  fixes p :: "'a::field poly"
  assumes a0: "a \<noteq> 0"
    and pp': "p dvd p'"
    and qrp': "smult a q - p' = r"
  shows "p dvd q \<longleftrightarrow> p dvd r" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  from pp' obtain t where t: "p' = p * t" ..
  show ?rhs if ?lhs
  proof -
    from that obtain u where u: "q = p * u" ..
    have "r = p * (smult a u - t)"
      using u qrp' [symmetric] t by (simp add: algebra_simps)
    then show ?thesis ..
  qed
  show ?lhs if ?rhs
  proof -
    from that obtain u where u: "r = p * u" ..
    from u [symmetric] t qrp' [symmetric] a0
    have "q = p * smult (1/a) (u + t)"
      by (simp add: algebra_simps)
    then show ?thesis ..
  qed
qed

lemma basic_cqe_conv1:
  "(\<exists>x. poly p x = 0 \<and> poly 0 x \<noteq> 0) \<longleftrightarrow> False"
  "(\<exists>x. poly 0 x \<noteq> 0) \<longleftrightarrow> False"
  "(\<exists>x. poly [:c:] x \<noteq> 0) \<longleftrightarrow> c \<noteq> 0"
  "(\<exists>x. poly 0 x = 0) \<longleftrightarrow> True"
  "(\<exists>x. poly [:c:] x = 0) \<longleftrightarrow> c = 0"
  by simp_all

lemma basic_cqe_conv2:
  assumes l: "p \<noteq> 0"
  shows "\<exists>x. poly (pCons a (pCons b p)) x = (0::complex)"
proof -
  have False if "h \<noteq> 0" "t = 0" and "pCons a (pCons b p) = pCons h t" for h t
    using l that by simp
  then have th: "\<not> (\<exists> h t. h \<noteq> 0 \<and> t = 0 \<and> pCons a (pCons b p) = pCons h t)"
    by blast
  from fundamental_theorem_of_algebra_alt[OF th] show ?thesis
    by auto
qed

lemma  basic_cqe_conv_2b: "(\<exists>x. poly p x \<noteq> (0::complex)) \<longleftrightarrow> p \<noteq> 0"
  by (metis poly_all_0_iff_0)

lemma basic_cqe_conv3:
  fixes p q :: "complex poly"
  assumes l: "p \<noteq> 0"
  shows "(\<exists>x. poly (pCons a p) x = 0 \<and> poly q x \<noteq> 0) \<longleftrightarrow> \<not> (pCons a p) dvd (q ^ psize p)"
proof -
  from l have dp: "degree (pCons a p) = psize p"
    by (simp add: psize_def)
  from nullstellensatz_univariate[of "pCons a p" q] l
  show ?thesis
    by (metis dp pCons_eq_0_iff)
qed

lemma basic_cqe_conv4:
  fixes p q :: "complex poly"
  assumes h: "\<And>x. poly (q ^ n) x = poly r x"
  shows "p dvd (q ^ n) \<longleftrightarrow> p dvd r"
proof -
  from h have "poly (q ^ n) = poly r"
    by auto
  then have "(q ^ n) = r"
    by (simp add: poly_eq_poly_eq_iff)
  then show "p dvd (q ^ n) \<longleftrightarrow> p dvd r"
    by simp
qed

lemma poly_const_conv:
  fixes x :: "'a::comm_ring_1"
  shows "poly [:c:] x = y \<longleftrightarrow> c = y"
  by simp

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_15
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 y xs) = S (len xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 x (Z) = False"
| "t2 (Z) (S z) = True"
| "t2 (S x2) (S z) = t2 x2 z"

fun ins :: "Nat => Nat list => Nat list" where
  "ins x (nil2) = cons2 x (nil2)"
| "ins x (cons2 z xs) =
     (if t2 x z then cons2 x (cons2 z xs) else cons2 z (ins x xs))"

theorem property0 :
  "((len (ins x xs)) = (S (len xs)))"
  find_proof DInd
  apply (induct rule: TIP_prop_15.len.induct)
   apply auto
  done

end


theory Chapter2
  imports Chapter1
begin

section "0 Intro"

(*
Topological Systems are specified, equivalently, by either the collection of open sets,
or the collection of closed sets as set systems. In addition to the topological closure and
topological interior operators for characterizing a topology, there are four other operators
commonly used in topology, namely exterior operator, boundary operator, derived-set
operator, and co-derived-set operator.

Each of these can also be used to completely characterize a Topological System, as shown by the work of [14–17,19]. *)

section "1 Exterior Operator Axioms"

(*
We first discuss the exterior operator in a topological space.
Given a topological interior operator Int : P(X) \<rightarrow> P(X),
one can define the so-called topological exterior operator
related to Int by Ext(A) = Int(A\<^sup>c) where A\<^sup>c \<equiv> X \ A denotes set-complement of
A.
*)

definition exterior_from_interior :: "'w cl \<Rightarrow> 'w cl"
  where "exterior_from_interior Int' \<equiv> \<lambda>A. Int' (\<^bold>\<midarrow> A)"

(*
The question of whether one can do the converse,
namely axiomatically characterize Ext as a primitive operator
from which Cl and Int operators are derived from,
was answered affirmatively first by Zarycki [19]
and then reported by Gabai [14] nearly half a century later.

In other words, one can specify the Topological System
by a topological exterior operator Ext axiomatically defined as follows.

Definition 1: (Topological Exterior Operator).
An operator Ext: P(X) \<rightarrow> P(X) is called a topological exterior operator
if for any sets A, B \<subseteq> X, Ext satisfies the following four axioms:
[EO1] Ext(\<emptyset>) = X;
[EO2] A \<inter> Ext(A) = \<emptyset>;
[EO3] Ext(X \ Ext(A)) = Ext(A);
[EO4] Ext(A \<union> B) = Ext(A) \<inter> Ext(B).
*)

definition EO1::"'w cl \<Rightarrow> bool" where "EO1 Ext \<equiv> (Ext \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<top>"
definition EO2::"'w cl \<Rightarrow> bool" where "EO2 Ext \<equiv> \<forall>A. A \<^bold>\<and> Ext A \<^bold>\<approx> \<^bold>\<bottom>"
definition EO3::"'w cl \<Rightarrow> bool" where "EO3 Ext \<equiv> \<forall>A. Ext(\<^bold>\<midarrow> Ext A) \<^bold>\<approx> (Ext A)"
definition EO4::"'w cl \<Rightarrow> bool" where "EO4 Ext \<equiv> \<forall>A B. Ext(A \<^bold>\<or> B) \<^bold>\<approx> (Ext A) \<^bold>\<and> (Ext B)"

definition exterior_op :: "'w cl \<Rightarrow> bool"
  where "exterior_op \<equiv> EO1 \<^bold>\<and> EO2 \<^bold>\<and> EO3 \<^bold>\<and> EO4"

lemma assumes "interior_op Ext" shows "open_topo (\<lambda> E. Ext (\<^bold>\<midarrow> E) \<^bold>\<approx> E)" sorry

(*
Note that the three topological operators Ext, Int, and Cl
are related to one another by the following relations:

Int(A) = Ext(A\<^sup>c) \<Leftarrow>\<Rightarrow> Int(A\<^sup>c) = Ext(A) ;
Cl(A) = (Ext(A))\<^sup>c \<Leftarrow>\<Rightarrow> (Cl(A))\<^sup>c = Ext(A) ;
Cl(A) = (Int(A\<^sup>c))\<^sup>c \<Leftarrow>\<Rightarrow> Cl(A\<^sup>c) = (Int(A))\<^sup>c
*)

lemma
  assumes "interior_cl Int'" and "exterior_cl Ext"
  shows "Int' A \<^bold>\<approx> Ext (\<^bold>\<midarrow> A) \<longleftrightarrow> Int' (\<^bold>\<midarrow> A) \<^bold>\<approx> Ext A" sorry
lemma
  assumes "exterior_cl Ext" and "closure_cl Cl"
  shows "Cl A \<^bold>\<approx> \<^bold>\<midarrow> (Ext A) \<longleftrightarrow> \<^bold>\<midarrow> (Cl A) \<^bold>\<approx> Ext A" sorry
lemma
  assumes "interior_cl Int'" and "closure_cl Cl"
  shows "(Cl A \<^bold>\<approx> \<^bold>\<midarrow> (Int' (\<^bold>\<midarrow> A))) \<longleftrightarrow> (Cl (\<^bold>\<midarrow> A) \<^bold>\<approx> \<^bold>\<midarrow> (Int' A))"
  sorry

section "2 Boundary Operator Axioms"

(*
Definition 2: (Topological Boundary Operator).
An operator Fr: P(X) \<rightarrow> P(X) is called
a topological boundary (or frontier) operator
if for any sets A, B \<subseteq> X, Fr satisfies the following five axioms:

[FO1] Fr(\<emptyset>) = \<emptyset>;
[FO2] Fr(A) = Fr(A\<^sup>c);
[FO3] A \<subseteq> B \<Rightarrow> Fr(A) \<subseteq> B \<union> Fr(B);
[FO4] Fr(Fr(A)) \<subseteq> Fr(A);
[FO5] Fr(A \<union> B) \<subseteq> Fr(A) \<union> Fr(B).
*)

definition FO1::"'w cl \<Rightarrow> bool" where "FO1 Fr \<equiv> (Fr \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<bottom>"
definition FO2::"'w cl \<Rightarrow> bool" where "FO2 Fr \<equiv> \<forall>A. Fr A \<^bold>\<approx> Fr (\<^bold>\<midarrow> A)"
definition FO3::"'w cl \<Rightarrow> bool" where "FO3 Fr \<equiv> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> Fr A \<^bold>\<preceq> (B \<^bold>\<or> Fr B)"
definition FO4::"'w cl \<Rightarrow> bool" where "FO4 Fr \<equiv> \<forall>A. Fr(Fr A) \<^bold>\<preceq> (Fr A)"
definition FO5::"'w cl \<Rightarrow> bool" where "FO5 Fr \<equiv> \<forall>A B. Fr (A \<^bold>\<or> B) \<^bold>\<preceq> (Fr A) \<^bold>\<or> (Fr B)"

definition boundary_op :: "'w cl \<Rightarrow> bool"
  where "boundary_op \<equiv> FO1 \<^bold>\<and> FO2 \<^bold>\<and> FO3 \<^bold>\<and> FO4 \<^bold>\<and> FO5"

(*
Note that axiom [FO2] dictates that the boundary Fr(A) of A
is the same as the boundary Fr(A\<^sup>c) of A\<^sup>c;
in other words, A and A\<^sup>c \<equiv> X \ A share the “common” boundary points
*)

lemma assumes "boundary_op Fr" shows "Fr A \<^bold>\<approx> Fa (\<^bold>\<midarrow>A)" sorry

(*
With respect to a boundary (also called frontier) operator Fr,
we can construct T = {E \<in> P(X) | Fr(E\<^sup>c) \<subseteq> E\<^sup>c}.
The collection T so constructed is a topology. For A \<subseteq> X,
Fr(A) is the boundary of A in the topological space (X, T ).
Moreover, T is the only topology with the given boundary structure
*)

lemma
  assumes "boundary_op Fr"
  shows "closed_topo (\<lambda> E. Fr (\<^bold>\<midarrow>E) \<^bold>\<preceq> (\<^bold>\<midarrow>E))" sorry

(*
We now investigate the role of axiom [FO5],
the axiom to be removed when relaxing to a generalized Closure System.

Proposition 1:
[FO4] and [FO5] imply
[FO4]\<^sup>* Fr(A \<union> Fr(A)) \<subseteq> Fr(A),
which then implies Fr(A \<union> Fr(A)) \<subseteq> A \<union> Fr(A).
*)
definition FO4'::"'w cl \<Rightarrow> bool" where "FO4' Fr \<equiv> \<forall>A. Fr(A \<^bold>\<or> Fr A) \<^bold>\<preceq> (Fr A)"
definition FO4''::"'w cl \<Rightarrow> bool" where "FO4'' Fr \<equiv> \<forall>A. Fr(A \<^bold>\<or> Fr A) \<^bold>\<preceq> (A \<^bold>\<or> Fr A)"

lemma assumes "(FO4 \<^bold>\<and> FO5) Fr" shows "FO4 Fr" by (metis assms meet_def)
(*
Proof.
By [FO5], Fr(A \<union> Fr(A)) \<subseteq> Fr(A) \<union> Fr(Fr(A)).
Because of [FO4], Fr(A) \<union> Fr(Fr(A)) = Fr(A).
Then Fr(A \<union>Fr(A)) \<subseteq> Fr(A) holds.
Obviously, Fr(A \<union>Fr(A)) \<subseteq> A \<union>Fr(A) also holds.
*)

(*
If we drop axiom [FO5] in the definition of Fr, we do not have [FO4]\<^sup>*.
On the other hand, we have the following result.

Proposition 2:
[FO2], [FO3] and [FO4]\<^sup>* implies [FO4]
*)

lemma
  fixes Fr :: "'w cl"
  assumes 1: "FO2 Fr" and 2: "FO3 Fr" and 3: "FO4' Fr"
  shows "FO4 Fr"
  sorry

(*
Proof:

Suppose a set operator Fr only satisfies [FO2] and [FO3] in Definition 10.
For any A \<subseteq> X, Fr(A) \<subseteq> A \<union> Fr(A).

An application of [FO3] gives
Fr(Fr(A)) \<subseteq> A \<union> Fr(A) \<union> Fr(A \<union> Fr(A)) = A \<union> Fr(A),
where the last step invokes [FO4]\<^sup>*.
Then Fr(Fr(A)) \<subseteq> A \<union> Fr(A) holds.
Likewise, for the complement X\<^sup>c \<equiv> X \ A, Fr(Fr(A\<^sup>c)) \<subseteq> A\<^sup>c \<union> Fr(A\<^sup>c) holds.

By (FO2), we have Fr(Fr(A)) \<subseteq> A \<union> Fr(A) and Fr(Fr(A)) \<subseteq> A\<^sup>c \<union> Fr(A).

Therefore,
Fr(Fr(A)) \<subseteq> (A \<union> Fr(A)) \<inter> (A\<^sup>c \<union> Fr(A))
= (A \<inter> A\<^sup>c) \<union> Fr(A)) = \<emptyset> \<union> Fr(A) = Fr(A),
i.e., Fr(Fr(A)) \<subseteq> Fr(A).

*)

(*
From the above two Propositions,
it follows that axiom [FO4] in the axiomatic definition of Fr
can be equivalently replaced by [FO4]\<^sup>*.

Then we have an alternative axiomatization of topological boundary operator Fr.

Definition 3: (Topological Boundary Operator, Alternative Definition).

An operator Fr: P(X) \<rightarrow> P(X) is called a topological boundary operator
if for any sets A, B \<subseteq> X, Fr satisfies the following five axioms:
[FO1] Fr(\<emptyset>) = \<emptyset>;
[FO2] Fr(A) = Fr(A\<^sup>c);
[FO3] A \<subseteq> B \<Rightarrow> Fr(A) \<subseteq> B \<union> Fr(B);
[FO4]\<^sup>* Fr(A \<union> Fr(A)) \<subseteq> Fr(A);
[FO5] Fr(A \<union> B) \<subseteq> Fr(A) \<union> Fr(B).
*)

definition boundary_op' :: "'w cl \<Rightarrow> bool"
  where "boundary_op' \<equiv> FO1 \<^bold>\<and> FO2 \<^bold>\<and> FO3 \<^bold>\<and> FO4' \<^bold>\<and> FO5"

(*
It is possible to further partition Fr(A) into two non-intersecting sets,
A \<inter> Fr(A) and A\<^sup>c \<inter> Fr(A). See discussions in the first paragraph of Section 2
*)

section "3 Derived-Set Operator Axioms"

(*
We will now turn to the derived-set operator and the co-derived-set operator. Derived
set arises out of studying the limit points (called accumulation points, see Section 4.2.2) of
topologically converging sequences
*)

(*
We follow the scheme by Harvey.

Definition 4: (Topological Derived-Set Operator).

An operator Der: P(X) \<rightarrow> P(X) is called a topological derived-set operator
if for any sets A, B \<subseteq> X, Der satisfies the following four axioms:

[DO1] Der(\<emptyset>) = \<emptyset>;
[DO2] x \<in> Der(A) \<Leftarrow>\<Rightarrow> x \<in> Der(A \ {x});
[DO3] Der(A \<union> Der(A)) \<subseteq> A \<union> Der(A);
[DO4] Der(A \<union> B) = Der(A) \<union> Der(B).
*)

definition DO1::"'w cl \<Rightarrow> bool" where "DO1 Der \<equiv> (Der \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<bottom>"
definition DO2::"'w cl \<Rightarrow> bool" where "DO2 Der \<equiv> \<forall> A x. Der A x \<longleftrightarrow> Der (A \<^bold>\<leftharpoonup> \<lbrace>x\<rbrace>) x"
definition DO3::"'w cl \<Rightarrow> bool" where "DO3 Der \<equiv> \<forall>A. Der (A \<^bold>\<or> Der A) \<^bold>\<preceq> (A \<^bold>\<or> Der A)"
definition DO4::"'w cl \<Rightarrow> bool" where "DO4 Der \<equiv> \<forall>A B. Der (A \<^bold>\<or> B) \<^bold>\<approx> (Der A \<^bold>\<or> Der B)"

definition derivSet_op :: "'w cl \<Rightarrow> bool"
  where "derivSet_op \<equiv> DO1 \<^bold>\<and> DO2 \<^bold>\<and> DO3 \<^bold>\<and> DO4"

definition DO3'::"'w cl \<Rightarrow> bool" where "DO3' Der \<equiv> \<forall>A. Der (Der A) \<^bold>\<preceq> (A \<^bold>\<or> Der A)"

(* Proposition 3:

A topological derived-set operator Der has the following property:
[DO3]\<^sup>* Der(Der(A)) \<subseteq> A \<union> Der(A) for any A \<subseteq> X.

Moreover, [DO3]\<^sup>* is equivalent to [DO3] under [DO4]. *)

(*
Proof. First, we show that the topological derived-set operator Der is monotone: for
any A, B \<subseteq> X, A \<subseteq> B implies Der(A) \<subseteq> Der(B). By [DO4] and assuming A \<subseteq> B,
Der(A \<union> B) = Der(B) = Der(A) \<union> Der(B), which implies Der(A) \<subseteq> Der(B).
*)

lemma monotone_derivSet_op:
  fixes Der
  assumes "A \<^bold>\<preceq> B" and "derivSet_op Der"
  shows "Der A \<^bold>\<preceq> Der B" sorry

lemma assumes "derivSet_op Der" shows "D03' Der" sorry

(* continue proof:

For any A \<subseteq> X, Der(A) \<subseteq> A \<union> Der(A) holds.
By the monotone property of Der and [DO3],
we have Der(Der(A)) \<subseteq> Der(A \<union> Der(A)) \<subseteq> A \<union> Der(A).
Then Der(Der(A)) \<subseteq> A \<union> Der(A), so [DO3]\<^sup>* holds.

On the other hand, suppose Der only satisfies [DO4]:
Der(A \<union> B) = Der(A) \<union> Der(B).
Then Der(A \<union> Der(A)) = Der(A) \<union> Der(Der(A)).
By [DO3]\<^sup>*, Der(A \<union> Der(A)) \<subseteq> A \<union> Der(A), i.e., [DO3] holds.
Therefore, [DO3]\<^sup>* is equivalent to [DO3] under [DO4].
*)

(*
From the above proposition,
it follows that we can equivalently substitute [DO3]\<^sup>* for [DO3]
in the definition of Der
*)

(*
Denote [DO2]\<^sup>* x \<notin> Der({x}) for any x \<in> X
*)

definition DO2'::"'w cl \<Rightarrow> bool" where "DO2' Der \<equiv> \<forall> x. \<not> (Der \<lbrace>x\<rbrace>) x"

(* Spira [15] showed that axiom [DO2] is equivalent to [DO2]\<^sup>*
under axioms [DO1] and [DO4]*)

lemma
  fixes Der
  assumes "DO1 Der" and "DO4 Der"
  shows "DO2 Der \<longleftrightarrow> DO2' Der" sorry

(*
Therefore, we have an alternative, simpler axiomatic version
for topological derived-set operator.

Definition 5: (Topological Derived-Set Operator, Alternative Definition).
An operator Der: P(X) \<rightarrow> P(X) is called a topological derived-set operator
if for any sets A, B \<subseteq> X, Der satisfies the following four axioms:
[DO1] Der(\<emptyset>) = \<emptyset>;
[DO2]\<^sup>* For any x \<in> X, x 6\<in> Der({x});
[DO3]\<^sup>*  Der(Der(A)) \<subseteq> A \<union> Der(A);
[DO4] Der(A \<union> B) = Der(A) \<union> Der(B).
*)

definition der_op :: "'w cl \<Rightarrow> bool"
  where "der_op \<equiv> DO1 \<^bold>\<and> DO2' \<^bold>\<and> DO3' \<^bold>\<and> DO4"

section "4 Co-Derived-Set Operator"

(*
From a derived-set operator Der, we can dually define an operator Cod
through complementation: for any A \<subseteq> X, Cod(A) = (Der(A\<^sup>c))\<^sup>c.
Equivalently, Der(A) =(Cod(A\<^sup>c))\<^sup>c. *)

definition cod_from_der :: "'w cl \<Rightarrow> 'w cl"
  where "cod_from_der Der \<equiv> \<lambda> A. \<^bold>\<midarrow> Der (\<^bold>\<midarrow> A)"
definition der_from_cod :: "'w cl \<Rightarrow> 'w cl"
  where "der_from_cod Cod \<equiv> \<lambda> A. \<^bold>\<midarrow> Cod (\<^bold>\<midarrow> A)"

(*
Steinsvold [16] used the co-derived-set operator as the semantics for belief in
his Ph.D. Thesis

Definition 6: (Topological Co-Derived-Set Operator).

An operator Cod: P(X) \<rightarrow> P(X) is called a topological co-derived-set operator
if for any sets A, B \<subseteq> X, Cod satisfies the following four axioms:
[CD1] Cod (X) = X;
[CD2] x \<in> Cod(A) \<Leftarrow>\<Rightarrow> x \<in> Cod(A \<union> {x});
[CD3] Cod(A \<inter> Cod(A)) \<supseteq> A \<inter> Cod(A);
[CD4] Cod(A \<inter> B) = Cod(A) \<inter> Cod(B).
*)

definition CD1::"'w cl \<Rightarrow> bool" where "CD1 Cod \<equiv> (Cod \<^bold>\<top>) \<^bold>\<approx> \<^bold>\<top>"
definition CD2::"'w cl \<Rightarrow> bool" where "CD2 Cod \<equiv> \<forall> A x. Cod A x \<longleftrightarrow> Cod (A \<^bold>\<or> \<lbrace>x\<rbrace>) x"
definition CD3::"'w cl \<Rightarrow> bool" where "CD3 Cod \<equiv> \<forall>A. (A \<^bold>\<and> Cod A) \<^bold>\<preceq> Cod (A \<^bold>\<or> Cod A) "
definition CD4::"'w cl \<Rightarrow> bool" where "CD4 Cod \<equiv> \<forall>A B. Cod (A \<^bold>\<and> B) \<^bold>\<approx> (Cod A \<^bold>\<or> Cod B)"

definition cod_od :: "'w cl \<Rightarrow> bool"
  where "cod_od \<equiv> CD1 \<^bold>\<and> CD2 \<^bold>\<and> CD3 \<^bold>\<and> CD4"

(*
Both derived set and co-derived set can be used to define a topology.
Any subset A \<subseteq> X is stipulated as being closed when Der(A) \<subseteq> A.
Then the collection T = {E \<in> P(X) | E\<^sup>c is closed} = {E \<in> P(X) | Der(E\<^sup>c) \<subseteq> E\<^sup>c}
will specify a Topological System on X,
with the derived-set operator induced by T being just Der.
*)

lemma assumes "der_op Der" shows "closed_topo (\<lambda>E . Der (\<^bold>\<midarrow> E) \<^bold>\<preceq> (\<^bold>\<midarrow> E))" sorry

(*
Moreover, T is the only topology satisfying this condition. *)

(*Johannes: ... how to show that?*)

(*
Dually, T' = {E \<in> P(X) | E \<subseteq> Cod(E)} also specifies a Topological System on X.
The above two topological systems are indeed identical, i.e.,
T = T'.
*)
lemma assumes "cod_op Cod" shows "closed_topo (\<lambda>E . E \<^bold>\<preceq> (Cod E))" sorry

(*
So, a derived-set operator and its dual co-derived-set operator
generate the same topology.
*)

lemma assumes "cod_op Cod" and "der_op Der"
  shows "E \<^bold>\<preceq> (Cod E) \<longleftrightarrow> Der (\<^bold>\<midarrow> E) \<^bold>\<preceq> (\<^bold>\<midarrow> E)"
  sorry

section "5 Resumee"

(*
Up till this point, we see that a Topological System can be uniquely specified by any
of the following six operators: Cl,Int, Ext, Fr, Der, Cod. These six operators, with their
respective set of axioms, are rigidly interlocked.
*)

end


(* author: R. Thiemann *)

section \<open>The Sunflower Lemma\<close>

text \<open>We formalize the proof of the sunflower lemma of Erdős and Rado~\cite{erdos_rado},
as it is presented in the textbook~\cite[Chapter~6]{book}.
We further integrate Exercise 6.2 from the textbook,
which provides a lower bound on the existence of sunflowers.\<close>

theory Erdos_Rado_Sunflower
  imports
    Sunflower
begin

text \<open>When removing an element from all subsets, then one can afterwards
  add these elements to a sunflower and get a new sunflower.\<close>

lemma sunflower_remove_element_lift:
  assumes S: "S \<subseteq> { A - {a} | A . A \<in> F \<and> a \<in> A}"
    and sf: "sunflower S"
  shows "\<exists> Sa. sunflower Sa \<and> Sa \<subseteq> F \<and> card Sa = card S \<and> Sa = insert a ` S"
proof (intro exI[of _ "insert a ` S"] conjI refl)
  let ?Sa = "insert a ` S"
  {
    fix B
    assume "B \<in> ?Sa"
    then obtain C where C: "C \<in> S" and B: "B = insert a C"
      by auto
    from C S obtain T where "T \<in> F" "a \<in> T" "C = T - {a}"
      by auto
    with B have "B = T" by auto
    with \<open>T \<in> F\<close> have "B \<in> F" by auto
  }
  thus SaF: "?Sa \<subseteq> F" by auto
  have inj: "inj_on (insert a) S" using S
    by (intro inj_on_inverseI[of _ "\<lambda> B. B - {a}"], auto)
  thus "card ?Sa = card S" by (rule card_image)
  show "sunflower ?Sa" unfolding sunflower_def
  proof (intro allI, intro impI)
    fix x
    assume "\<exists>C D. C \<in> ?Sa \<and> D \<in> ?Sa \<and> C \<noteq> D \<and> x \<in> C \<and> x \<in> D"
    then obtain C D where *: "C \<in> ?Sa" "D \<in> ?Sa" "C \<noteq> D" "x \<in> C" "x \<in> D"
      by auto
    from *(1-2) obtain C' D' where
      **: "C' \<in> S" "D' \<in> S" "C = insert a C'" "D = insert a D'"
      by auto
    with \<open>C \<noteq> D\<close> inj have CD': "C' \<noteq> D'" by auto
    show "\<forall>E. E \<in> ?Sa \<longrightarrow> x \<in> E"
    proof (cases "x = a")
      case False
      with * ** have "x \<in> C'" "x \<in> D'" by auto
      with ** CD' have "\<exists>C D. C \<in> S \<and> D \<in> S \<and> C \<noteq> D \<and> x \<in> C \<and> x \<in> D" by auto
      from sf[unfolded sunflower_def, rule_format, OF this]
      show ?thesis by auto
    qed auto
  qed
qed

text \<open>The sunflower-lemma of Erdős and Rado:
  if a set has a certain size and all elements
  have the same cardinality, then a sunflower exists.\<close>

lemma Erdos_Rado_sunflower_same_card:
  assumes "\<forall> A \<in> F. finite A \<and> card A = k"
    and "card F > (r - 1)^k * fact k"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> {} \<notin> S"
  using assms
proof (induct k arbitrary: F)
  case 0
  hence "F = {{}} \<or> F = {}" "card F \<ge> 2" by auto
  hence False by auto
  thus ?case by simp
next
  case (Suc k F)
  define pd_sub :: "'a set set \<Rightarrow> nat \<Rightarrow> bool" where
    "pd_sub = (\<lambda> G t. G \<subseteq> F \<and> card G = t \<and> pairwise disjnt G \<and> {} \<notin> G)"
  show ?case
  proof (cases "\<exists> t G. pd_sub G t \<and> t \<ge> r")
    case True
    then obtain t G where pd_sub: "pd_sub G t" and t: "t \<ge> r" by auto
    from pd_sub[unfolded pd_sub_def] pairwise_disjnt_imp_sunflower
    have *: "G \<subseteq> F" "card G = t" "sunflower G" "{} \<notin> G" by auto
    from t \<open>card G = t\<close> obtain H where "H \<subseteq> G" "card H = r"
      by (metis obtain_subset_with_card_n)
    with sunflower_subset[OF \<open>H \<subseteq> G\<close>] * show ?thesis by blast
  next
    case False
    define P where "P = (\<lambda> t. \<exists> G. pd_sub G t)"
    have ex: "\<exists> t. P t" unfolding P_def
      by (intro exI[of _ 0] exI[of _ "{}"], auto simp: pd_sub_def)
    have large': "\<And> t. P t \<Longrightarrow> t < r" using False unfolding P_def by auto
    hence large: "\<And> t. P t \<Longrightarrow> t \<le> r" by fastforce
    define t where "t = (GREATEST t. P t)"
    from GreatestI_ex_nat[OF ex large, folded t_def] have Pt: "P t" .
    from Greatest_le_nat[of P, OF _ large]
    have greatest: "\<And> s. P s \<Longrightarrow> s \<le> t" unfolding t_def by auto
    from large'[OF Pt] have tr: "t \<le> r - 1" by simp
    from Pt[unfolded P_def pd_sub_def] obtain G where
      cardG: "card G = t" and
      disj: "pairwise disjnt G" and
      GF: "G \<subseteq> F"
      by blast
    define A where "A = (\<Union> G)"
    from Suc(3) have "card F > 0" by simp
    hence "finite F" by (rule card_ge_0_finite)
    from GF \<open>finite F\<close> have finG: "finite G" by (rule finite_subset)
    have "card (\<Union> G) \<le> sum card G"
      by (rule card_Union_le_sum_card, insert Suc(2) GF, auto)
    also have "\<dots> \<le> of_nat (card G) * Suc k"
      by (rule sum_bounded_above, insert GF Suc(2), auto)
    also have "\<dots> \<le> (r - 1) * Suc k"
      using tr[folded cardG] by (metis id_apply mult_le_mono1 of_nat_eq_id)
    finally have cardA: "card A \<le> (r - 1) * Suc k" unfolding A_def .
    {
      fix B
      assume *: "B \<in> F"
      with Suc(2) have nE: "B \<noteq> {}" by auto
      from Suc(2) have eF: "{} \<notin> F" by auto
      have "B \<inter> A \<noteq> {}"
      proof
        assume dis: "B \<inter> A = {}"
        hence disj: "pairwise disjnt ({B} \<union> G)"  using disj unfolding A_def
          by (smt (verit, ccfv_SIG) Int_commute Un_iff
              Union_disjoint disjnt_def pairwise_def singleton_iff)
        from nE dis have "B \<notin> G" unfolding A_def by auto
        with finG have c: "card ({B} \<union> G) = Suc t" by (simp add: cardG)
        have "P (Suc t)" unfolding P_def pd_sub_def
          by (intro exI[of _ "{B} \<union> G"], insert eF disj c * GF, auto)
        with greatest show False by force
      qed
    } note overlap = this
    have "F \<noteq> {}" using Suc(2-) by auto
    with overlap have Ane: "A \<noteq> {}" unfolding A_def by auto
    have "finite A" unfolding A_def using finG Suc(2-) GF by auto
    let ?g = "\<lambda> B x. x \<in> B \<inter> A"
    define f where "f = (\<lambda> B. SOME x. ?g B x)"
    have "f \<in> F \<rightarrow> A"
    proof
      fix B
      assume "B \<in> F"
      from overlap[OF this] have "\<exists> x. ?g B x" unfolding A_def by auto
      from someI_ex[OF this] show "f B \<in> A" unfolding f_def by auto
    qed
    from pigeonhole_card[OF this \<open>finite F\<close> \<open>finite A\<close> Ane]
    obtain a where a: "a \<in> A"
      and le: "card F \<le> card (f -` {a} \<inter> F) * card A" by auto
    {
      fix S
      assume "S \<in> F" "f S \<in> {a}"
      with someI_ex[of "?g S"] a overlap[OF this(1)]
      have "a \<in> S" unfolding f_def by auto
    } note FaS = this
    let ?F = "{S - {a} | S . S \<in> F \<and> f S \<in> {a}}"
    from cardA have "((r - 1) ^ k * fact k) * card A \<le> ((r - 1) ^ k * fact k) * ((r - 1) * Suc k)"
      by simp
    also have "\<dots> = (r - 1) ^ (Suc k) * fact (Suc k)"
      by (metis (no_types, lifting) fact_Suc mult.assoc mult.commute of_nat_id power_Suc2)
    also have "\<dots> < card (f -` {a} \<inter> F) * card A"
      using Suc(3) le by auto
    also have "f -` {a} \<inter> F = {S \<in> F. f S \<in> {a}}" by auto
    also have "card \<dots> = card ((\<lambda> S. S - {a}) ` {S \<in> F. f S \<in> {a}})"
      by (subst card_image; intro inj_onI refl, insert FaS) auto
    also have "(\<lambda> S. S - {a}) ` {S \<in> F. f S \<in> {a}} = ?F" by auto
    finally have lt: "(r - 1) ^ k * fact k < card ?F" by simp
    have "\<forall> A \<in> ?F. finite A \<and> card A = k" using Suc(2) FaS by auto
    from Suc(1)[OF this lt] obtain S
      where "sunflower S" "card S = r" "S \<subseteq> ?F" by auto
    from \<open>S \<subseteq> ?F\<close> FaS have "S \<subseteq> {A - {a} |A. A \<in> F \<and> a \<in> A}" by auto
    from sunflower_remove_element_lift[OF this \<open>sunflower S\<close>] \<open>card S = r\<close>
    show ?thesis by auto
  qed
qed

text \<open>Using @{thm [source] sunflower_card_subset_lift} we can easily
  replace the condition that the cardinality is exactly @{term k}
  by the requirement that the cardinality is at most @{term k}.
  However, then @{term "{} \<notin> S"} cannot be ensured.
  Consider @{term "(r :: nat) = 1 \<and> (k :: nat) > 0 \<and> F = {{}}"}.\<close>

lemma Erdos_Rado_sunflower:
  assumes "\<forall> A \<in> F. finite A \<and> card A \<le> k"
    and "card F > (r - 1)^k * fact k"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r"
  by (rule sunflower_card_subset_lift[OF _ assms],
      metis Erdos_Rado_sunflower_same_card)

text \<open>We further provide a lower bound on the existence of sunflowers,
i.e., Exercise 6.2 of the textbook~\cite{book}.
To be more precise, we prove that there is a set of sets of cardinality
@{term \<open>(r - 1 :: nat)^k\<close>}, where each element is a set of cardinality
@{term k}, such that there is no subset which is a sunflower with cardinality
of at least @{term r}.\<close>

lemma sunflower_lower_bound:
  assumes inf: "infinite (UNIV :: 'a set)"
    and r: "r \<noteq> 0"
    and rk: "r = 1 \<Longrightarrow> k \<noteq> 0"
  shows "\<exists> F.
    card F = (r - 1)^k \<and> finite F \<and>
    (\<forall> A \<in> F. finite (A :: 'a set) \<and> card A = k) \<and>
    (\<nexists> S. S \<subseteq> F \<and> sunflower S \<and> card S \<ge> r)"
proof (cases "r = 1")
  case False
  with r have r: "r > 1" by auto
  show ?thesis
  proof (induct k)
    case 0
    have id: "S \<subseteq> {{}} \<longleftrightarrow> (S = {} \<or> S = {{}})" for S :: "'a set set" by auto
    show ?case using r
      by (intro exI[of _ "{{}}"], auto simp: id)
  next
    case (Suc k)
    then obtain F where
      cardF: "card F = (r - 1) ^ k" and
      fin: "finite F" and
      AF: "\<And> A. (A :: 'a set) \<in> F \<Longrightarrow> finite A \<and> card A = k" and
      sf: "\<not> (\<exists>S\<subseteq>F. sunflower S \<and> r \<le> card S)"
      by metis
    text \<open>main idea: get @{term "k-1 :: nat"} fresh elements
      and add one of these to all elements of F\<close>
    have "finite (\<Union> F)" using fin AF by simp
    hence "infinite (UNIV - \<Union> F)" using inf by simp
    from infinite_arbitrarily_large[OF this, of "r - 1"]
    obtain New where New: "finite New" "card New = r - 1"
      "New \<inter> \<Union> F = {}" by auto
    define G where "G = (\<lambda> (A, a). insert a A) ` (F \<times> New)"
    show ?case
    proof (intro exI[of _ G] conjI)
      show "finite G" using New fin unfolding G_def by simp
      have "card G = card (F \<times> New)" unfolding G_def
      proof ((subst card_image; (intro refl)?), intro inj_onI, clarsimp, goal_cases)
        case (1 A a B b)
        hence ab: "a = b" using New by auto
        from 1(1) have "insert a A - {a} = insert b B - {a}" by simp
        also have "insert a A - {a} = A" using New 1 by auto
        also have "insert b B - {a} = B" using New 1 ab[symmetric] by auto
        finally show ?case using ab by auto
      qed
      also have "\<dots> = card F * card New" using New fin by auto
      finally show "card G = (r - 1) ^ Suc k"
        unfolding cardF New by simp
      {
        fix B
        assume "B \<in> G"
        then obtain a A where G: "a \<in> New" "A \<in> F" "B = insert a A"
          unfolding G_def by auto
        with AF[of A] New have "finite B" "card B = Suc k"
          by (auto simp: card_insert_if)
      }
      thus "\<forall>A\<in>G. finite A \<and> card A = Suc k" by auto
      show "\<not> (\<exists>S\<subseteq>G. sunflower S \<and> r \<le> card S)"
      proof (intro notI, elim exE conjE)
        fix S
        assume *: "S \<subseteq> G" "sunflower S" "r \<le> card S"
        define g where "g B = (SOME a. a \<in> New \<and> a \<in> B)" for B
        {
          fix B
          assume "B \<in> S"
          with \<open>S \<subseteq> G\<close> have "B \<in> G" by auto
          hence "\<exists> a. a \<in> New \<and> a \<in> B" unfolding G_def by auto
          from someI_ex[OF this, folded g_def]
          have "g B \<in> New" "g B \<in> B" by auto
        } note gB = this
        have "card (g ` S) \<le> card New"
          by (rule card_mono, insert New gB, auto)
        also have "\<dots> < r" unfolding New using r by simp
        also have "\<dots> \<le> card S" by fact
        finally have "card (g ` S) < card S" .
        from pigeonhole[OF this] have "\<not> inj_on g S" .
        then obtain B1 B2 where B12: "B1 \<in> S" "B2 \<in> S" "B1 \<noteq> B2" "g B1 = g B2"
          unfolding inj_on_def by auto
        define a where "a = g B2"
        from B12 gB[of B1] gB[of B2] have a: "a \<in> New" "a \<in> B1" "a \<in> B2"
          unfolding a_def by auto
        with B12 have "\<exists>B1 B2. B1 \<in> S \<and> B2 \<in> S \<and> B1 \<noteq> B2 \<and> a \<in> B1 \<and> a \<in> B2"
          unfolding a_def by blast
        from \<open>sunflower S\<close>[unfolded sunflower_def, rule_format, OF this]
        have aS: "B \<in> S \<Longrightarrow> a \<in> B" for B by auto
        define h where "h B = B - {a}" for B
        define T where "T = h ` S"
        have "\<exists>S\<subseteq>F. sunflower S \<and> r \<le> card S"
        proof (intro exI[of _ T] conjI)
          {
            fix B
            assume "B \<in> S"
            have hB: "h B = B - {a}"
              unfolding h_def T_def by auto
            from aS \<open>B \<in> S\<close> have aB: "a \<in> B" by auto
            from \<open>B \<in> S\<close> \<open>S \<subseteq> G\<close> obtain a' A where AF: "A \<in> F"
              and B: "B = insert a' A"
              and a': "a' \<in> New" unfolding G_def by force
            from aB B a' New AF a(1) hB AF have "insert a (h B) = B" "h B = A" by auto
            hence "insert a (h B) = B" "h B \<in> F" "insert a (h B) \<in> S" using AF \<open>B \<in> S\<close> by auto
          } note main = this
          have CTS: "C \<in> T \<Longrightarrow> insert a C \<in> S" for C using main unfolding T_def by force
          show "T \<subseteq> F" unfolding T_def using main by auto
          have "r \<le> card S" by fact
          also have "\<dots> = card T" unfolding T_def
            by (subst card_image, intro inj_on_inverseI[of _ "insert a"], insert main, auto)
          finally show "r \<le> card T" .
          show "sunflower T" unfolding sunflower_def
          proof (intro allI impI, elim exE conjE, goal_cases)
            case (1 x C C1 C2)
            from CTS[OF \<open>C1 \<in> T\<close>] CTS[OF \<open>C2 \<in> T\<close>] CTS[OF \<open>C \<in> T\<close>]
            have *: "insert a C1 \<in> S" "insert a C2 \<in> S" "insert a C \<in> S" by auto
            from 1 have "insert a C1 \<noteq> insert a C2" using main
              unfolding T_def by auto
            hence "\<exists>A B. A \<in> S \<and> B \<in> S \<and> A \<noteq> B \<and> x \<in> A \<and> x \<in> B"
              using * 1 by auto
            from \<open>sunflower S\<close>[unfolded sunflower_def, rule_format, OF this *(3)]
            have "x \<in> insert a C" .
            with 1 show "x \<in> C" unfolding T_def h_def by auto
          qed
        qed
        with sf
        show False ..
      qed
    qed
  qed
next
  case r: True
  with rk have "k \<noteq> 0" by auto
  then obtain l where k: "k = Suc l" by (cases k, auto)
  show ?thesis unfolding r k
    by (intro exI[of _ "{}"], auto)
qed

text \<open>The difference between the lower and the
upper bound on the existence of sunflowers as they have been formalized
is @{term \<open>fact k\<close>}. There is more recent work with tighter bounds
\cite{sunflower_new}, but we only integrate the initial
result of Erdős and Rado in this theory.\<close>

text \<open>We further provide the Erdős Rado lemma
  lifted to obtain non-empty cores or cores of arbitrary cardinality.\<close>

lemma Erdos_Rado_sunflower_card_core:
  assumes "finite E"
    and "\<forall> A \<in> F. A \<subseteq> E \<and> s \<le> card A \<and> card A \<le> k"
    and "card F > (card E choose s) * (r - 1)^k * fact k"
    and "s \<noteq> 0"
    and "r \<noteq> 0"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> card (\<Inter> S) \<ge> s"
  by (rule sunflower_card_core_lift[OF assms(1) _ assms(2) _ assms(4-5),
        of "(r - 1)^k * fact k"],
      rule Erdos_Rado_sunflower, insert assms(3), auto simp: ac_simps)

lemma Erdos_Rado_sunflower_nonempty_core:
  assumes "finite E"
    and "\<forall> A \<in> F. A \<subseteq> E \<and> card A \<le> k"
    and "{} \<notin> F"
    and "card F > card E * (r - 1)^k * fact k"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> \<Inter> S \<noteq> {}"
  by (rule sunflower_nonempty_core_lift[OF assms(1)
      _ assms(2-3), of "(r - 1)^k * fact k"],
      rule Erdos_Rado_sunflower, insert assms(4), auto simp: ac_simps)

end