(*
    Title:      Mod_Type.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Class for modular arithmetic\<close>

theory Mod_Type
imports
  "HOL-Library.Numeral_Type"
  "HOL-Analysis.Cartesian_Euclidean_Space"
  Dual_Order
begin

subsection\<open>Definition and properties\<close>

text\<open>Class for modular arithmetic. It is inspired by the locale mod\_type.\<close>

class mod_type = times + wellorder + neg_numeral +
fixes Rep :: "'a => int"
  and Abs :: "int => 'a"
  assumes type: "type_definition Rep Abs {0..<int CARD ('a)}"
  and size1: "1 < int CARD ('a)"
  and zero_def: "0 = Abs 0"
  and one_def:  "1 = Abs 1"
  and add_def:  "x + y = Abs ((Rep x + Rep y) mod (int CARD ('a)))"
  and mult_def: "x * y = Abs ((Rep x * Rep y) mod (int CARD ('a)))"
  and diff_def: "x - y = Abs ((Rep x - Rep y) mod (int CARD ('a)))"
  and minus_def: "- x = Abs ((- Rep x) mod (int CARD ('a)))"
  and strict_mono_Rep: "strict_mono Rep"
begin

lemmas definitions =
  zero_def one_def add_def mult_def minus_def diff_def

lemma Rep_less_n: "Rep x < int CARD ('a)"
  by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])

lemma Rep_le_n: "Rep x \<le> int CARD ('a)"
  by (rule Rep_less_n [THEN order_less_imp_le])

lemma Rep_inject_sym: "x = y \<longleftrightarrow> Rep x = Rep y"
  by (rule type_definition.Rep_inject [OF type, symmetric])

lemma Rep_inverse: "Abs (Rep x) = x"
  by (rule type_definition.Rep_inverse [OF type])

lemma Abs_inverse: "m \<in> {0..<int CARD ('a)} \<Longrightarrow> Rep (Abs m) = m"
  by (rule type_definition.Abs_inverse [OF type])

lemma Rep_Abs_mod: "Rep (Abs (m mod int CARD ('a))) = m mod int CARD ('a)"
  using size0 by (auto simp add: Abs_inverse)

lemma Rep_Abs_0: "Rep (Abs 0) = 0"
  apply (rule Abs_inverse [of 0])
  using size0 by simp

lemma Rep_0: "Rep 0 = 0"
  by (simp add: zero_def Rep_Abs_0)

lemma Rep_Abs_1: "Rep (Abs 1) = 1"
  by (simp add: Abs_inverse size1)

lemma Rep_1: "Rep 1 = 1"
  by (simp add: one_def Rep_Abs_1)

lemma Rep_mod: "Rep x mod int CARD ('a) = Rep x"
  apply (rule_tac x=x in type_definition.Abs_cases [OF type])
  apply (simp add: type_definition.Abs_inverse [OF type])
done

lemmas Rep_simps =
  Rep_inject_sym Rep_inverse Rep_Abs_mod Rep_mod Rep_Abs_0 Rep_Abs_1

subsection\<open>Conversion between a modular class and the subset of natural numbers associated.\<close>
text\<open>Definitions to make transformations among elements of a modular class and naturals\<close>
definition to_nat :: "'a => nat"
  where "to_nat = nat \<circ> Rep"

definition Abs' :: "int => 'a"
  where "Abs' x = Abs(x mod int CARD ('a))"

definition from_nat :: "nat \<Rightarrow> 'a"
  where "from_nat = (Abs' \<circ> int)"

lemma bij_Rep: "bij_betw (Rep) (UNIV::'a set) {0..<int CARD('a)}"
proof (unfold bij_betw_def, rule conjI)
  show "inj Rep" by (metis strict_mono_imp_inj_on strict_mono_Rep)
  show "range Rep = {0..<int CARD('a)}" using Typedef.type_definition.Rep_range[OF type] .
qed

lemma mono_Rep: "mono Rep" by (metis strict_mono_Rep strict_mono_mono)

lemma Rep_ge_0: "0 \<le> Rep x" using bij_Rep unfolding bij_betw_def by auto

lemma bij_Abs: "bij_betw (Abs) {0..<int CARD('a)} (UNIV::'a set)"
proof (unfold bij_betw_def, rule conjI)
  show "inj_on Abs {0..<int CARD('a)}" by (metis inj_on_inverseI type type_definition.Abs_inverse)
  show "Abs ` {0..<int CARD('a)} = (UNIV::'a set)" by (metis type type_definition.univ)
qed

corollary bij_Abs': "bij_betw (Abs') {0..<int CARD('a)} (UNIV::'a set)"
proof (unfold bij_betw_def, rule conjI)
  show "inj_on Abs' {0..<int CARD('a)}"
    unfolding inj_on_def Abs'_def
    by (auto, metis Rep_Abs_mod mod_pos_pos_trivial)
  show "Abs' ` {0..<int CARD('a)} = (UNIV::'a set)"
  proof (unfold image_def Abs'_def, auto)
    fix x show "\<exists>xa\<in>{0..<int CARD('a)}. x = Abs xa"
      by (rule bexI[of _ "Rep x"], auto simp add: Rep_less_n[of x] Rep_ge_0[of x], metis Rep_inverse)
  qed
qed

lemma bij_from_nat: "bij_betw (from_nat) {0..<CARD('a)} (UNIV::'a set)"
proof (unfold bij_betw_def, rule conjI)
  have set_eq: "{0::int..<int CARD('a)} = int` {0..<CARD('a)}" apply (auto)
  proof -
    fix x::int  assume x1: "(0::int) \<le> x" and x2: "x < int CARD('a)" show "x \<in> int ` {0::nat..<CARD('a)}"
    proof (unfold image_def, auto, rule bexI[of _ "nat x"])
      show " x = int (nat x)" using x1 by auto
      show "nat x \<in> {0::nat..<CARD('a)}" using x1 x2 by auto
    qed
  qed
  show "inj_on (from_nat::nat\<Rightarrow>'a) {0::nat..<CARD('a)}"
  proof (unfold from_nat_def , rule comp_inj_on)
    show "inj_on int {0::nat..<CARD('a)}" by (metis inj_of_nat subset_inj_on top_greatest)
    show "inj_on (Abs'::int=>'a) (int ` {0::nat..<CARD('a)})"
      using bij_Abs unfolding bij_betw_def set_eq
      by (metis (opaque_lifting, no_types) Abs'_def Abs_inverse Rep_inverse Rep_mod inj_on_def set_eq)
  qed
  show "(from_nat::nat=>'a)` {0::nat..<CARD('a)} = UNIV"
    unfolding from_nat_def using bij_Abs'
    unfolding bij_betw_def set_eq o_def by blast
qed

lemma to_nat_is_inv: "the_inv_into {0..<CARD('a)} (from_nat::nat=>'a) = (to_nat::'a=>nat)"
proof (unfold the_inv_into_def fun_eq_iff from_nat_def to_nat_def o_def, clarify)
  fix x::"'a" show "(THE y::nat. y \<in> {0::nat..<CARD('a)} \<and> Abs' (int y) = x) = nat (Rep x)"
  proof (rule the_equality, auto)
    show " Abs' (Rep x) = x" by (metis Abs'_def Rep_inverse Rep_mod)
    show "nat (Rep x) < CARD('a)" by (metis (full_types) Rep_less_n nat_int size0 zless_nat_conj)
    assume x:  "\<not> (0::int) \<le> Rep x" show "(0::nat) < CARD('a)" and "Abs' (0::int) = x"
      using Rep_ge_0 x by auto
  next
    fix y::nat assume y: "y < CARD('a)"
    have "(Rep(Abs'(int y)::'a)) = (Rep((Abs(int y mod int CARD('a)))::'a))" unfolding Abs'_def ..
    also have "... =  (Rep (Abs (int y)::'a))" using zmod_int[of y "CARD('a)"]
      using y mod_less by auto
    also have "... =  (int y)" proof (rule Abs_inverse) show "int y \<in> {0::int..<int CARD('a)}"
      using y by auto qed
    finally show "y = nat (Rep (Abs' (int y)::'a))" by (metis nat_int)
  qed
qed

lemma bij_to_nat: "bij_betw (to_nat) (UNIV::'a set) {0..<CARD('a)}"
  using bij_betw_the_inv_into[OF bij_from_nat] unfolding to_nat_is_inv .

lemma finite_mod_type: "finite (UNIV::'a set)"
  using finite_imageD[of "to_nat" "UNIV::'a set"] using bij_to_nat unfolding bij_betw_def by auto

subclass (in mod_type) finite by (intro_classes, rule finite_mod_type)

lemma least_0: "(LEAST n. n \<in> (UNIV::'a set)) = 0"
proof (rule Least_equality, auto)
  fix y::"'a"
  have "(0::'a) \<le> Abs (Rep y mod int CARD('a))" using strict_mono_Rep unfolding strict_mono_def
  by (metis (opaque_lifting, mono_tags) Rep_0 Rep_ge_0 strict_mono_Rep strict_mono_less_eq)
  also have "... = y" by (metis Rep_inverse Rep_mod)
  finally show "(0::'a) \<le> y" .
qed

lemma add_to_nat_def: "x + y = from_nat (to_nat x + to_nat y)"
  unfolding from_nat_def to_nat_def o_def using Rep_ge_0[of x] using Rep_ge_0[of y]
  using Rep_less_n[of x] Rep_less_n[of y]
  unfolding Abs'_def unfolding add_def[of x y] by auto

lemma to_nat_1: "to_nat 1 = 1"
  by (simp add: to_nat_def Rep_1)

lemma add_def':
  shows "x + y = Abs' (Rep x + Rep y)" unfolding Abs'_def using add_def by simp

lemma Abs'_0:
  shows "Abs' (CARD('a))=(0::'a)" by (metis (opaque_lifting, mono_tags) Abs'_def mod_self zero_def)

lemma Rep_plus_one_le_card:
  assumes a: "a + 1 \<noteq> 0"
  shows "(Rep a) + 1 < CARD ('a)"
proof (rule ccontr)
  assume "\<not> Rep a + 1 < CARD('a)" hence to_nat_eq_card: "Rep a + 1 = CARD('a)"
    using Rep_less_n
    by (simp add: add1_zle_eq order_class.less_le)
  have "a+1 = Abs' (Rep a + Rep (1::'a))" using add_def' by auto
  also have "... = Abs' ((Rep a) + 1)" using Rep_1 by simp
  also have "... = Abs' (CARD('a))" unfolding to_nat_eq_card ..
  also have "... = 0" using Abs'_0 by auto
  finally show False using a by contradiction
qed

lemma to_nat_plus_one_less_card: "\<forall>a. a+1 \<noteq> 0 --> to_nat a + 1 < CARD('a)"
proof (clarify)
fix a
assume a: "a + 1 \<noteq> 0"
have "Rep a + 1 < int CARD('a)" using Rep_plus_one_le_card[OF a] by auto
hence "nat (Rep a + 1) < nat (int CARD('a))" unfolding zless_nat_conj using size0 by fast
thus "to_nat a + 1 < CARD('a)" unfolding to_nat_def o_def using nat_add_distrib[OF Rep_ge_0] by simp
qed

corollary to_nat_plus_one_less_card':
assumes "a+1 \<noteq> 0"
shows "to_nat a + 1 < CARD('a)" using to_nat_plus_one_less_card assms by simp

lemma strict_mono_to_nat: "strict_mono to_nat"
  using strict_mono_Rep
  unfolding strict_mono_def to_nat_def using Rep_ge_0 by (metis comp_apply nat_less_eq_zless)

lemma to_nat_eq [simp]: "to_nat x = to_nat y \<longleftrightarrow> x = y"
  using injD [OF bij_betw_imp_inj_on[OF bij_to_nat]] by blast

lemma mod_type_forall_eq [simp]: "(\<forall>j::'a. (to_nat j)<CARD('a) \<longrightarrow> P j) = (\<forall>a. P a)"
proof (auto)
  fix a assume a: "\<forall>j. (to_nat::'a=>nat) j < CARD('a) \<longrightarrow> P j"
  have "(to_nat::'a=>nat) a < CARD('a)" using bij_to_nat unfolding bij_betw_def by auto
  thus "P a" using a by auto
qed

lemma to_nat_from_nat:
  assumes t:"to_nat j = k"
  shows "from_nat k = j"
proof -
  have "from_nat k = from_nat (to_nat j)"  unfolding t ..
  also have "... = from_nat (the_inv_into {0..<CARD('a)} (from_nat) j)" unfolding to_nat_is_inv ..
  also have "... = j"
  proof (rule f_the_inv_into_f)
    show "inj_on from_nat {0..<CARD('a)}" by (metis bij_betw_imp_inj_on bij_from_nat)
    show "j \<in> from_nat ` {0..<CARD('a)}" by (metis UNIV_I bij_betw_def bij_from_nat)
  qed
  finally show "from_nat k = j" .
qed

lemma to_nat_mono:
  assumes ab: "a < b"
  shows "to_nat a < to_nat b"
  using strict_mono_to_nat unfolding strict_mono_def using assms by fast

lemma to_nat_mono':
  assumes ab: "a \<le> b"
  shows "to_nat a \<le> to_nat b"
proof (cases "a=b")
  case True thus ?thesis by auto
next
  case False
  hence "a<b" using ab by simp
  thus ?thesis using to_nat_mono by fastforce
qed

lemma least_mod_type:
  shows "0 \<le> (n::'a)"
  using least_0 by (metis (full_types) Least_le UNIV_I)

lemma to_nat_from_nat_id:
  assumes x: "x<CARD('a)"
  shows "to_nat ((from_nat x)::'a) = x"
  unfolding to_nat_is_inv[symmetric] proof (rule the_inv_into_f_f)
  show "inj_on (from_nat::nat=>'a) {0..<CARD('a)}" using bij_from_nat unfolding bij_betw_def by auto
  show "x \<in> {0..<CARD('a)}" using x by simp
qed

lemma from_nat_to_nat_id[simp]:
  shows "from_nat (to_nat x) = x" by (metis to_nat_from_nat)

lemma from_nat_to_nat:
  assumes t:"from_nat j = k" and j: "j<CARD('a)"
  shows "to_nat k = j" by (metis j t to_nat_from_nat_id)

lemma from_nat_mono:
  assumes i_le_j: "i<j" and j: "j<CARD('a)"
  shows "(from_nat i::'a) < from_nat j"
proof -
have i: "i<CARD('a)" using i_le_j j by simp
obtain a where a: "i=to_nat a"
  using bij_to_nat unfolding bij_betw_def using i to_nat_from_nat_id by metis
obtain b where b: "j=to_nat b"
  using bij_to_nat unfolding bij_betw_def using j to_nat_from_nat_id by metis
show ?thesis by (metis a b from_nat_to_nat_id i_le_j strict_mono_less strict_mono_to_nat)
qed

lemma from_nat_mono':
  assumes i_le_j: "i \<le> j" and "j<CARD ('a)"
  shows "(from_nat i::'a) \<le> from_nat j"
proof (cases "i=j")
  case True
  have "(from_nat i::'a) = from_nat j" using True by simp
  thus ?thesis by simp
next
  case False
  hence "i<j" using i_le_j by simp
  thus ?thesis by (metis assms(2) from_nat_mono less_imp_le)
qed

lemma to_nat_suc:
  assumes "to_nat (x)+1 < CARD ('a)"
  shows "to_nat (x + 1::'a) = (to_nat x) + 1"
proof -
  have "(x::'a) + 1 = from_nat (to_nat x + to_nat (1::'a))" unfolding add_to_nat_def ..
  hence "to_nat ((x::'a) + 1) = to_nat (from_nat (to_nat x + to_nat (1::'a))::'a)" by presburger
  also have "... = to_nat (from_nat (to_nat x + 1)::'a)" unfolding to_nat_1 ..
  also have "... = (to_nat x + 1)" by (metis assms to_nat_from_nat_id)
  finally show ?thesis .
qed

lemma to_nat_le:
  assumes "y < from_nat k"
  shows  "to_nat y < k"
proof (cases "k<CARD('a)")
  case True show ?thesis by (metis (full_types) True assms to_nat_from_nat_id to_nat_mono)
next
  case False have "to_nat y < CARD ('a)" using bij_to_nat unfolding bij_betw_def by auto
  thus ?thesis using False by auto
qed

lemma le_Suc:
  assumes ab: "a < (b::'a)"
  shows "a + 1 \<le> b"
proof -
  have "a + 1 = (from_nat (to_nat (a + 1))::'a)" using from_nat_to_nat_id [of "a+1",symmetric] .
  also have "... \<le> (from_nat (to_nat (b::'a))::'a)"
  proof (rule from_nat_mono')
    have "to_nat a < to_nat b" using ab by (metis to_nat_mono)
    hence "to_nat a + 1 \<le> to_nat b" by simp
    thus "to_nat b < CARD ('a)" using bij_to_nat unfolding  bij_betw_def by auto
    hence "to_nat a + 1 < CARD ('a)" by (metis \<open>to_nat a + 1 \<le> to_nat b\<close> preorder_class.le_less_trans)
    thus "to_nat (a + 1) \<le> to_nat b" by (metis \<open>to_nat a + 1 \<le> to_nat b\<close> to_nat_suc)
  qed
  also have "... = b" by (metis from_nat_to_nat_id)
  finally show "a + (1::'a) \<le> b" .
qed

lemma le_Suc':
assumes ab: "a + 1 \<le> b"
  and less_card: "(to_nat a) + 1 < CARD ('a)"
  shows "a < b"
proof -
  have "a = (from_nat (to_nat a)::'a)" using from_nat_to_nat_id [of "a",symmetric] .
  also have "... < (from_nat (to_nat b)::'a)"
  proof (rule from_nat_mono)
    show "to_nat b < CARD('a)" using bij_to_nat unfolding  bij_betw_def by auto
    have "to_nat (a + 1) \<le>  to_nat b" using ab by (metis to_nat_mono')
    hence "to_nat (a) + 1 \<le>  to_nat b"  using to_nat_suc[OF less_card] by auto
    thus "to_nat a < to_nat b" by simp
  qed
  finally show "a < b" by (metis to_nat_from_nat)
qed

lemma Suc_le:
  assumes less_card: "(to_nat a) + 1 < CARD ('a)"
  shows "a < a + 1"
proof -
  have "(to_nat a) < (to_nat a) + 1" by simp
  hence "(to_nat a) < to_nat (a + 1)" by (metis less_card to_nat_suc)
  hence "(from_nat (to_nat a)::'a) < from_nat (to_nat (a + 1))"
    by (rule from_nat_mono, metis less_card to_nat_suc)
  thus "a < a + 1" by (metis to_nat_from_nat)
qed

lemma Suc_le':
  fixes a::'a
  assumes "a + 1 \<noteq> 0"
  shows "a < a + 1" using Suc_le to_nat_plus_one_less_card assms by blast

lemma from_nat_not_eq:
  assumes a_eq_to_nat: "a \<noteq> to_nat b"
  and a_less_card: "a<CARD('a)"
  shows "from_nat a \<noteq> b"
proof (rule ccontr)
  assume "\<not> from_nat a \<noteq> b" hence "from_nat a = b" by simp
  hence "to_nat ((from_nat a)::'a) = to_nat b" by auto
  thus False by (metis a_eq_to_nat a_less_card to_nat_from_nat_id)
qed

lemma Suc_less:
  fixes i::'a
  assumes "i<j"
  and "i+1 \<noteq> j"
  shows "i+1<j" by (metis assms le_Suc le_neq_trans)

lemma Greatest_is_minus_1: "\<forall>a::'a. a \<le> -1"
proof (clarify)
  fix a::'a
  have zero_ge_card_1: "0 \<le> int CARD('a) - 1" using size1 by auto
  have card_less: "int CARD('a) - 1 < int CARD('a)" by auto
  have not_zero: "1 mod int CARD('a) \<noteq> 0"
    by (metis (opaque_lifting, mono_tags) Rep_Abs_1 Rep_mod zero_neq_one)
  have int_card: "int (CARD('a) - 1) = int CARD('a) - 1" using of_nat_diff[of 1 "CARD ('a)"]
    using size1 by simp
  have "a = Abs' (Rep a)" by (metis (opaque_lifting, mono_tags) Rep_0 add_0_right add_def'
      monoid_add_class.add.right_neutral)
  also have "... = Abs' (int (nat (Rep a)))" by (metis Rep_ge_0 int_nat_eq)
  also have "...  \<le> Abs' (int (CARD('a) - 1))"
  proof (rule from_nat_mono'[unfolded from_nat_def o_def, of "nat (Rep a)" "CARD('a) - 1"])
    show "nat (Rep a) \<le> CARD('a) - 1" using Rep_less_n
      using int_card nat_le_iff by auto
    show "CARD('a) - 1 < CARD('a)" using finite_UNIV_card_ge_0 finite_mod_type by fastforce
  qed
  also have "... = - 1"
  unfolding Abs'_def unfolding minus_def zmod_zminus1_eq_if unfolding Rep_1
  apply (rule cong [of Abs], rule refl)
  unfolding if_not_P [OF not_zero]
  unfolding int_card
  unfolding mod_pos_pos_trivial[OF zero_ge_card_1 card_less]
  using mod_pos_pos_trivial[OF _ size1] by presburger
  finally show "a \<le> -1" by fastforce
qed

lemma a_eq_minus_1: "\<forall>a::'a. a+1 = 0 \<longrightarrow> a = -1"
  by (metis eq_neg_iff_add_eq_0)

lemma forall_from_nat_rw:
  shows "(\<forall>x\<in>{0..<CARD('a)}. P (from_nat x::'a)) = (\<forall>x. P (from_nat x))"
proof (auto)
  fix y assume *: "\<forall>x\<in>{0..<CARD('a)}. P (from_nat x)"
  have "from_nat y \<in> (UNIV::'a set)" by auto
  from this obtain x where x1: "from_nat y = (from_nat x::'a)" and x2: "x\<in>{0..<CARD('a)}"
    using bij_from_nat unfolding bij_betw_def
    by (metis from_nat_to_nat_id rangeI the_inv_into_onto to_nat_is_inv)
  show "P (from_nat y::'a)" unfolding x1 using * x2 by simp
qed

lemma from_nat_eq_imp_eq:
  assumes f_eq: "from_nat x = (from_nat xa::'a)"
and x: "x<CARD('a)" and xa: "xa<CARD('a)"
  shows "x=xa" using assms from_nat_not_eq by metis

lemma to_nat_less_card:
  fixes j::"'a"
  shows "to_nat j < CARD ('a)"
  using bij_to_nat unfolding bij_betw_def by auto

lemma from_nat_0: "from_nat 0 = 0"
  unfolding from_nat_def o_def of_nat_0 Abs'_def mod_0 zero_def ..
lemma to_nat_0: "to_nat 0 = 0" unfolding to_nat_def o_def Rep_0 nat_0 ..
lemma to_nat_eq_0: "(to_nat x = 0) = (x = 0)"
  by (auto simp add: to_nat_0 from_nat_0 dest: to_nat_from_nat)

lemma suc_not_zero:
  assumes "to_nat a + 1 \<noteq> CARD('a)"
  shows "a+1 \<noteq> 0"
proof (rule ccontr, simp)
  assume a_plus_one_zero: "a + 1 = 0"
  hence rep_eq_card: "Rep a + 1 = CARD('a)"
    using assms to_nat_0 Suc_eq_plus1 Suc_lessI Zero_not_Suc to_nat_less_card to_nat_suc
    by (metis (opaque_lifting, mono_tags))
  moreover have "Rep a + 1 < CARD('a)"
    using Abs'_0 Rep_1 Suc_eq_plus1 Suc_lessI Suc_neq_Zero add_def' assms
    rep_eq_card to_nat_0 to_nat_less_card to_nat_suc by (metis (opaque_lifting, mono_tags))
  ultimately show False by fastforce
qed

lemma from_nat_suc:
shows "from_nat (j + 1) = from_nat j + 1"
unfolding from_nat_def o_def Abs'_def add_def' Rep_1 Rep_Abs_mod
unfolding of_nat_add apply (subst mod_add_left_eq) unfolding of_nat_1 ..

lemma to_nat_plus_1_set:
shows "to_nat a + 1 \<in> {1..<CARD('a)+1}"
using to_nat_less_card by simp

end

lemma from_nat_CARD:
  shows "from_nat (CARD('a)) = (0::'a::{mod_type})"
  unfolding from_nat_def o_def Abs'_def by (simp add: zero_def)

subsection\<open>Instantiations\<close>

instantiation bit0 and bit1:: (finite) mod_type
begin

definition "(Rep::'a bit0 => int)  x = Rep_bit0 x"
definition "(Abs::int => 'a bit0) x = Abs_bit0' x"

definition "(Rep::'a bit1 => int)  x = Rep_bit1 x"
definition "(Abs::int => 'a bit1) x = Abs_bit1' x"

instance
proof
  show "(0::'a bit0) = Abs (0::int)" unfolding Abs_bit0_def Abs_bit0'_def zero_bit0_def by auto
  show "(1::int) < int CARD('a bit0)" by (metis bit0.size1)
  show "type_definition (Rep::'a bit0 => int) (Abs:: int => 'a bit0) {0::int..<int CARD('a bit0)}"
  proof (unfold type_definition_def Rep_bit0_def [abs_def]
      Abs_bit0_def [abs_def] Abs_bit0'_def, intro conjI)
    show "\<forall>x::'a bit0. Rep_bit0 x \<in> {0::int..<int CARD('a bit0)}"
      unfolding card_bit0 unfolding of_nat_mult
      using Rep_bit0 [where ?'a = "'a"] by simp
    show "\<forall>x::'a bit0. Abs_bit0 (Rep_bit0 x mod int CARD('a bit0)) = x"
      by (metis Rep_bit0_inverse bit0.Rep_mod)
    show "\<forall>y::int. y \<in> {0::int..<int CARD('a bit0)}
      \<longrightarrow> Rep_bit0 ((Abs_bit0::int => 'a bit0) (y mod int CARD('a bit0))) = y"
      by (metis bit0.Abs_inverse bit0.Rep_mod)
  qed
  show "(1::'a bit0) = Abs (1::int)" unfolding Abs_bit0_def Abs_bit0'_def one_bit0_def
    by (metis bit0.of_nat_eq of_nat_1 one_bit0_def)
  fix x y :: "'a bit0"
  show "x + y = Abs ((Rep x + Rep y) mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def plus_bit0_def Abs_bit0'_def by fastforce
  show "x * y = Abs (Rep x * Rep y mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def times_bit0_def Abs_bit0'_def by fastforce
  show "x - y = Abs ((Rep x - Rep y) mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def minus_bit0_def Abs_bit0'_def by fastforce
  show "- x = Abs (- Rep x mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def uminus_bit0_def Abs_bit0'_def by fastforce
  show "(0::'a bit1) = Abs (0::int)" unfolding Abs_bit1_def Abs_bit1'_def zero_bit1_def by auto
  show "(1::int) < int CARD('a bit1)" by (metis bit1.size1)
  show "(1::'a bit1) = Abs (1::int)" unfolding Abs_bit1_def Abs_bit1'_def one_bit1_def
    by (metis bit1.of_nat_eq of_nat_1 one_bit1_def)
  fix x y :: "'a bit1"
  show "x + y = Abs ((Rep x + Rep y) mod int CARD('a bit1))"
    unfolding Abs_bit1_def Abs_bit1'_def Rep_bit1_def plus_bit1_def by fastforce
  show "x * y = Abs (Rep x * Rep y mod int CARD('a bit1))"
    unfolding Abs_bit1_def Rep_bit1_def times_bit1_def Abs_bit1'_def by fastforce
  show "x - y = Abs ((Rep x - Rep y) mod int CARD('a bit1))"
    unfolding Abs_bit1_def Rep_bit1_def minus_bit1_def Abs_bit1'_def by fastforce
  show "- x = Abs (- Rep x mod int CARD('a bit1))"
    unfolding Abs_bit1_def Rep_bit1_def uminus_bit1_def Abs_bit1'_def by fastforce
  show "type_definition (Rep::'a bit1 => int) (Abs:: int => 'a bit1) {0::int..<int CARD('a bit1)}"
  proof (unfold type_definition_def Rep_bit1_def [abs_def]
      Abs_bit1_def [abs_def] Abs_bit1'_def, intro conjI)
    have int_2: "int 2 = 2" by auto
   show "\<forall>x::'a bit1. Rep_bit1 x \<in> {0::int..<int CARD('a bit1)}"
      unfolding card_bit1
      unfolding of_nat_Suc of_nat_mult
      using Rep_bit1 [where ?'a = "'a"]
      unfolding int_2 ..
   show "\<forall>x::'a bit1. Abs_bit1 (Rep_bit1 x mod int CARD('a bit1)) = x"
      by (metis Rep_bit1_inverse bit1.Rep_mod)
   show "\<forall>y::int. y \<in> {0::int..<int CARD('a bit1)}
    \<longrightarrow> Rep_bit1 ((Abs_bit1::int => 'a bit1) (y mod int CARD('a bit1))) = y"
   by (metis bit1.Abs_inverse bit1.Rep_mod)
  qed
  show "strict_mono (Rep::'a bit0 => int)" unfolding strict_mono_def
    by (metis Rep_bit0_def less_bit0_def)
  show "strict_mono (Rep::'a bit1 => int)" unfolding strict_mono_def
    by (metis Rep_bit1_def less_bit1_def)
qed
end

end


(* Author: Manuel Eberl *)
theory Polynomial_Growth_Functions
  imports "HOL-Real_Asymp.Real_Asymp"
    Landau_Symbols.Landau_More
begin

subsection \<open>Auxiliary stuff\<close>

lemma natfun_bigoE:
  fixes f :: "nat \<Rightarrow> _"
  assumes bigo: "f \<in> O(g)" and nz: "\<And>n. n \<ge> n0 \<Longrightarrow> g n \<noteq> 0"
  obtains c where "c > 0" "\<And>n. n \<ge> n0 \<Longrightarrow> norm (f n) \<le> c * norm (g n)"
proof -
  from bigo obtain c where c: "c > 0" "eventually (\<lambda>n. norm (f n) \<le> c * norm (g n)) at_top"
    by (auto elim: landau_o.bigE)
  then obtain n0' where n0': "\<And>n. n \<ge> n0' \<Longrightarrow> norm (f n) \<le> c * norm (g n)"
    by (auto simp: eventually_at_top_linorder)
  define c' where "c' = Max ((\<lambda>n. norm (f n) / norm (g n)) ` (insert n0 {n0..<n0'}))"
  have "norm (f n) \<le> max 1 (max c c') * norm (g n)" if "n \<ge> n0" for n
  proof (cases "n \<ge> n0'")
    case False
    with that have "norm (f n) / norm (g n) \<le> c'"
      unfolding c'_def by (intro Max.coboundedI) auto
    also have "\<dots> \<le> max 1 (max c c')" by simp
    finally show ?thesis using nz[of n] that by (simp add: field_simps)
  next
    case True
    hence "norm (f n) \<le> c * norm (g n)" by (rule n0')
    also have "\<dots> \<le> max 1 (max c c') * norm (g n)"
      by (intro mult_right_mono) auto
    finally show ?thesis .
  qed
  with that[of "max 1 (max c c')"] show ?thesis by auto
qed

lemma natfun_bigo_poly_iff:
  fixes f :: "nat \<Rightarrow> real"
  shows "f \<in> O(\<lambda>n. n ^ k) \<longleftrightarrow> (\<exists>c. \<forall>n>0. \<bar>f n\<bar> \<le> c * real n ^ k)"
proof
  assume "\<exists>c. \<forall>n>0. \<bar>f n\<bar> \<le> c * real n ^ k"
  then obtain c where c: "\<forall>n>0. \<bar>f n\<bar> \<le> c * real n ^ k"
    by auto
  have "eventually (\<lambda>n. \<bar>f n\<bar> \<le> c * real n ^ k) at_top"
    using eventually_gt_at_top[of 0] by eventually_elim (use c in auto)
  thus "f \<in> O(\<lambda>n. n ^ k)"
    by (intro bigoI[of _ c]) (auto intro!: always_eventually)
next
  assume 1: "f \<in> O(\<lambda>n. n ^ k)"
  have 2: "real n ^ k \<noteq> 0" if "n \<ge> 1" for n :: nat using that by auto
  from natfun_bigoE[OF 1 2, of 1] obtain c where "\<forall>n\<ge>1. \<bar>f n\<bar> \<le> c * real n ^ k"
    by simp metis?
  thus "\<exists>c. \<forall>n>0. \<bar>f n\<bar> \<le> c * real n ^ k"
    by (auto simp: Suc_le_eq)
qed

subsection \<open>Polynomial-growth functions\<close>

definition poly :: "(nat \<Rightarrow> nat) \<Rightarrow> bool"
  where "poly f \<longleftrightarrow> (\<exists>k. (\<lambda>n. real (f n)) \<in> O(\<lambda>n. real n ^ k))"

lemma poly_iff_ex_smallo: "poly f \<longleftrightarrow> (\<exists>k. (\<lambda>n. real (f n)) \<in> o(\<lambda>n. real n ^ k))"
  unfolding poly_def
proof safe
  fix k assume "f \<in> O(\<lambda>n. n ^ k)"
  also have "(\<lambda>n. real n ^ k) \<in> o(\<lambda>n. real n ^ (k + 1))"
    by force
  finally have "f \<in> o(\<lambda>n. n ^ (k + 1))" .
  thus "\<exists>k. f \<in> o(\<lambda>n. n ^ k)" ..
qed (auto intro: landau_o.small_imp_big)

lemma poly_const [simp, intro]: "poly (\<lambda>_. c)"
  by (auto simp: poly_def intro!: exI[of _ 0])

lemma poly_cmult [intro]: "poly f \<Longrightarrow> poly (\<lambda>x. c * f x)"
  by (auto simp: poly_def)

lemma poly_add [intro]:
  assumes "poly f" "poly g"
  shows   "poly (\<lambda>x. f x + g x)"
proof -
  from assms obtain k l where kl: "f \<in> O(\<lambda>n. n ^ k)" "g \<in> O(\<lambda>n. n ^ l)"
    by (auto simp: poly_def)
  have "f \<in> O(\<lambda>n. n ^ max k l)" "g \<in> O(\<lambda>n. n ^ max k l)"
    by (rule kl[THEN landau_o.big.trans], force)+
  from sum_in_bigo(1)[OF this] show ?thesis
    by (auto simp: poly_def)
qed

lemma poly_diff [intro]:
  assumes "poly f" "poly g"
  shows   "poly (\<lambda>x. f x - g x)"
proof -
  from assms obtain k l where kl: "f \<in> O(\<lambda>n. n ^ k)" "g \<in> O(\<lambda>n. n ^ l)"
    by (auto simp: poly_def)
  have "(\<lambda>x. real (f x - g x)) \<in> O(\<lambda>x. real (f x) - real (g x))"
    by (intro landau_o.big_mono) (auto intro!: always_eventually)
  also have "f \<in> O(\<lambda>n. n ^ max k l)" "g \<in> O(\<lambda>n. n ^ max k l)"
    by (rule kl[THEN landau_o.big.trans], force)+
  from sum_in_bigo(2)[OF this] have "(\<lambda>x. real (f x) - real (g x)) \<in> O(\<lambda>x. real x ^ max k l)" .
  finally show ?thesis
    by (auto simp: poly_def)
qed

lemma poly_mult [intro]:
  assumes "poly f" "poly g"
  shows   "poly (\<lambda>x. f x * g x)"
proof -
  from assms obtain k l where kl: "f \<in> O(\<lambda>n. n ^ k)" "g \<in> O(\<lambda>n. n ^ l)"
    by (auto simp: poly_def)
  from landau_o.big.mult[OF this] have "(\<lambda>n. f n * g n) \<in> O(\<lambda>n. n ^ (k + l))"
    by (simp add: power_add)
  thus ?thesis by (auto simp: poly_def)
qed

definition make_mono :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "make_mono f n = Max (f ` {..n})"

lemma le_make_mono [intro]: "f n \<le> make_mono f n"
  by (auto simp: make_mono_def)

lemma mono_make_mono [intro]: "mono (make_mono f)"
  by (auto simp: make_mono_def incseq_def)

lemma poly_make_mono_iff: "poly (make_mono f) \<longleftrightarrow> poly f"
proof safe
  fix f
  assume *: "poly (make_mono f)"
  have "f \<in> O(make_mono f)"
    by (rule landau_o.big_mono) (auto intro!: always_eventually)
  also from * obtain k where "make_mono f \<in> O(\<lambda>n. n ^ k)"
    by (auto simp: poly_def)
  finally show "poly f"
    by (auto simp: poly_def)
next
  assume "poly f"
  then obtain k where "f \<in> O(\<lambda>n. n ^ k)"
    by (auto simp: poly_def)
  then obtain c' :: real where c': "\<And>n. n > 0 \<Longrightarrow> f n \<le> c' * n ^ k"
    by (subst (asm) natfun_bigo_poly_iff) auto
  define c where "c = max c' 1"
  have "c > 0" by (simp add: c_def)
  have c: "f n \<le> c * n ^ k" if "n > 0" for n
  proof -
    have "f n \<le> c' * n ^ k"
      using c'[of n] that by simp
    also have "\<dots> \<le> c * n ^ k"
      by (intro mult_right_mono) (auto simp: c_def)
    finally show ?thesis by simp
  qed

  have "eventually (\<lambda>n. real (make_mono f n) \<le> real (f 0) + c * real n ^ k) at_top"
    using eventually_gt_at_top[of 0]
  proof eventually_elim
    case (elim n)
    have "real (make_mono f n) = real (Max (f ` {..n}))"
      by (auto simp: make_mono_def)
    also have "{..n} = insert 0 {0<..n}"
      using elim by auto
    also have "Max (f ` \<dots>) = max (f 0) (Max (f ` {0<..n}))"
      using elim by (simp add: Max_insert)
    also have "real \<dots> = max (real (f 0)) (real (Max (f ` {0<..n})))"
      by simp
    also have "real (Max (f ` {0<..n})) = Max ((real \<circ> f) ` {0<..n})"
      using elim by (subst mono_Max_commute) (auto simp: image_image incseq_def)
    also have "\<dots> \<le> c * real n ^ k"
      unfolding o_def
    proof (intro Max.boundedI; safe?)
      fix i assume i: "i \<in> {0<..n}"
      from i have "real (f i) \<le> c * real i ^ k"
        by (intro c) auto
      also have "\<dots> \<le> c * real n ^ k"
        using i \<open>c > 0\<close> by (auto intro!: mult_left_mono power_mono)
      finally show "real (f i) \<le> c * real n ^ k" .
    qed (use elim in auto)
    hence "max (real (f 0)) (Max ((real \<circ> f) ` {0<..n})) \<le> max (real (f 0)) (c * real n ^ k)"
      by (intro max.mono) auto
    also have "\<dots> \<le> real (f 0) + c * real n ^ k"
      using \<open>c > 0\<close> by simp
    finally show ?case .
  qed
  hence "make_mono f \<in> O(\<lambda>n. real (f 0) + c * real n ^ k)"
    using \<open>c > 0\<close> by (intro bigoI[of _ 1]) auto
  also have "(\<lambda>n. real (f 0) + c * real n ^ k) \<in> O(\<lambda>n. real n ^ k)"
    using \<open>c > 0\<close> by (intro sum_in_bigo) auto
  finally show "poly (make_mono f)"
    by (auto simp: poly_def)
qed

lemma poly_compose [intro]:
  assumes "poly f" "poly g"
  shows   "poly (f \<circ> g)"
proof -
  from assms have "poly (make_mono f)"
    by (simp add: poly_make_mono_iff)
  then obtain k c where k: "\<And>n. n > 0 \<Longrightarrow> make_mono f n \<le> c * real n ^ k"
    by (auto simp: poly_def natfun_bigo_poly_iff)
  from assms obtain l where l: "g \<in> o(\<lambda>n. n ^ l)"
    by (auto simp: poly_iff_ex_smallo)

  have "eventually (\<lambda>n. g n \<le> n ^ l) at_top"
    using landau_o.smallD[OF l, of 1] by auto
  hence "eventually (\<lambda>n. real (f (g n)) \<le> c * real n ^ (k * l)) at_top"
    using eventually_gt_at_top[of 0]
  proof eventually_elim
    case (elim n)
    have "real (f (g n)) \<le> real (make_mono f (g n))"
      by auto
    also from elim(1) have "make_mono f (g n) \<le> make_mono f (n ^ l)"
      by (rule monoD[OF mono_make_mono])
    also have "\<dots> \<le> c * (n ^ l) ^ k"
      using k[of "n ^ l"] \<open>n > 0\<close> by simp
    also have "\<dots> = c * real n ^ (k * l)"
      by (subst mult.commute) (simp add: power_mult)
    finally show ?case by simp
  qed
  hence "f \<circ> g \<in> O(\<lambda>n. n ^ (k * l))"
    by (intro bigoI[of _ c]) auto
  thus ?thesis by (auto simp: poly_def)
qed

lemma poly_linear: "poly (\<lambda>a. a)"
  unfolding poly_def by force

end


section "Skew Heap"

theory Skew_Heap
imports
  "HOL-Library.Tree_Multiset"
  "HOL-Library.Pattern_Aliases"
  "HOL-Data_Structures.Priority_Queue_Specs"
begin

unbundle pattern_aliases

text\<open>Skew heaps~\cite{SleatorT-SIAM86} are possibly the simplest functional
priority queues that have logarithmic (albeit amortized) complexity.

The implementation below should be generalized to separate the elements from
their priorities.\<close>

type_synonym 'a heap = "'a tree"

subsection "Get Minimum"

fun get_min :: "'a::linorder heap \<Rightarrow> 'a" where
"get_min(Node l m r) = m"

lemma get_min: "\<lbrakk> heap h;  h \<noteq> Leaf \<rbrakk> \<Longrightarrow> get_min h = Min_mset (mset_tree h)"
by (auto simp add: eq_Min_iff neq_Leaf_iff)

subsection "Merge"

function merge :: "('a::linorder) heap \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"merge Leaf h = h" |
"merge h Leaf = h" |
"merge (Node l1 a1 r1 =: h1) (Node l2 a2 r2 =: h2) =
   (if a1 \<le> a2 then Node (merge h2 r1) a1 l1
    else Node (merge h1 r2) a2 l2)"
by pat_completeness auto
termination
by (relation "measure (\<lambda>(x, y). size x + size y)") auto

lemma merge_code: "merge h1 h2 =
  (case h1 of
   Leaf \<Rightarrow> h2 |
   Node l1 a1 r1 \<Rightarrow> (case h2 of
     Leaf \<Rightarrow> h1 |
     Node l2 a2 r2 \<Rightarrow>
       (if a1 \<le> a2
        then Node (merge h2 r1) a1 l1
        else Node (merge h1 r2) a2 l2)))"
by(auto split: tree.split)

text\<open>An alternative version that always walks to the Leaf of both heaps:\<close>
function merge2 :: "('a::linorder) heap \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"merge2 Leaf Leaf = Leaf" |
"merge2 Leaf (Node l2 a2 r2) = Node (merge2 r2 Leaf) a2 l2" |
"merge2 (Node l1 a1 r1) Leaf = Node (merge2 r1 Leaf) a1 l1" |
"merge2 (Node l1 a1 r1) (Node l2 a2 r2) =
   (if a1 \<le> a2
    then Node (merge2 (Node l2 a2 r2) r1) a1 l1
    else Node (merge2 (Node l1 a1 r1) r2) a2 l2)"
by pat_completeness auto
termination
by (relation "measure (\<lambda>(x, y). size x + size y)") auto

lemma size_merge[simp]: "size(merge t1 t2) = size t1 + size t2"
by(induction t1 t2 rule: merge.induct) auto

lemma size_merge2[simp]: "size(merge2 t1 t2) = size t1 + size t2"
by(induction t1 t2 rule: merge2.induct) auto

lemma mset_merge: "mset_tree (merge h1 h2) = mset_tree h1 + mset_tree h2"
by (induction h1 h2 rule: merge.induct) (auto simp add: ac_simps)

lemma set_merge: "set_tree (merge h1 h2) = set_tree h1 \<union> set_tree h2"
by (metis mset_merge set_mset_tree set_mset_union)

lemma heap_merge:
  "heap h1 \<Longrightarrow> heap h2 \<Longrightarrow> heap (merge h1 h2)"
by (induction h1 h2 rule: merge.induct)(auto simp: ball_Un set_merge)

subsection "Insert"

hide_const (open) insert

definition insert :: "'a::linorder \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"insert a t = merge (Node Leaf a Leaf) t"

lemma heap_insert: "heap h \<Longrightarrow> heap (insert a h)"
by (simp add: insert_def heap_merge)

lemma mset_insert: "mset_tree (insert a h) = {#a#} + mset_tree h"
by (auto simp: mset_merge insert_def)

subsection "Delete minimum"

fun del_min :: "'a::linorder heap \<Rightarrow> 'a heap" where
"del_min Leaf = Leaf" |
"del_min (Node l m r) = merge l r"

lemma heap_del_min: "heap h \<Longrightarrow> heap (del_min h)"
by (cases h) (auto simp: heap_merge)

lemma mset_del_min: "mset_tree (del_min h) = mset_tree h - {# get_min h #}"
by (cases h) (auto simp: mset_merge ac_simps)

interpretation skew_heap: Priority_Queue_Merge
where empty = Leaf and is_empty = "\<lambda>h. h = Leaf"
and merge = merge and insert = insert
and del_min = del_min and get_min = get_min
and invar = heap and mset = mset_tree
proof(standard, goal_cases)
  case 1 show ?case by simp
next
  case (2 q) show ?case by (cases q) auto
next
  case 3 show ?case by(simp add: mset_insert)
next
  case 4 show ?case by(rule mset_del_min)
next
  case 5 thus ?case using get_min mset_tree.simps(1) by blast
next
  case 6 thus ?case by(simp)
next
  case 7 thus ?case by(simp add: heap_insert)
next
  case 8 thus ?case by(simp add: heap_del_min)
next
  case 9 thus ?case by(simp add: mset_merge)
next
  case 10 thus ?case by(simp add: heap_merge)
qed

end


(*
    Title:      Budan-Fourier theorem
    Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
*)

section \<open>Budan-Fourier theorem\<close>

theory Budan_Fourier imports
  BF_Misc
begin

text \<open>
The Budan-Fourier theorem is a classic result in real algebraic geometry to over-approximate
real roots of a polynomial (counting multiplicity) within an interval. When all roots of the
the polynomial are known to be real, the over-approximation becomes tight -- the number of
roots are counted exactly. Also note that Descartes' rule of sign is a direct consequence of
the Budan-Fourier theorem.

The proof mainly follows Theorem 2.35 in
  Basu, S., Pollack, R., Roy, M.-F.: Algorithms in Real Algebraic Geometry.
  Springer Berlin Heidelberg, Berlin, Heidelberg (2006).
\<close>

subsection \<open>More results related to @{term sign_r_pos}\<close>

lemma sign_r_pos_nzero_right:
  assumes nzero:"\<forall>x. c<x \<and> x\<le>d \<longrightarrow> poly p x \<noteq>0" and "c<d"
  shows "if sign_r_pos p c then poly p d>0 else poly p d<0"
proof (cases "sign_r_pos p c")
  case True
  then obtain d' where "d'>c" and d'_pos:"\<forall>y>c. y < d' \<longrightarrow> 0 < poly p y"
    unfolding sign_r_pos_def eventually_at_right by auto
  have False when "\<not> poly p d>0"
  proof -
    have "\<exists>x>(c + min d d') / 2. x < d \<and> poly p x = 0"
      apply (rule poly_IVT_neg)
      using \<open>d'>c\<close> \<open>c<d\<close> that nzero[rule_format,of d,simplified]
      by (auto intro:d'_pos[rule_format])
    then show False using nzero \<open>c < d'\<close> by auto
  qed
  then show ?thesis using True by auto
next
  case False
  then have "sign_r_pos (-p) c"
    using sign_r_pos_minus[of p c] nzero[rule_format,of d,simplified] \<open>c<d\<close>
    by fastforce
  then obtain d' where "d'>c" and d'_neg:"\<forall>y>c. y < d' \<longrightarrow> 0 > poly p y"
    unfolding sign_r_pos_def eventually_at_right by auto
  have False when "\<not> poly p d<0"
  proof -
    have "\<exists>x>(c + min d d') / 2. x < d \<and> poly p x = 0"
      apply (rule poly_IVT_pos)
      using \<open>d'>c\<close> \<open>c<d\<close> that nzero[rule_format,of d,simplified]
      by (auto intro:d'_neg[rule_format])
    then show False using nzero \<open>c < d'\<close> by auto
  qed
  then show ?thesis using False by auto
qed

lemma sign_r_pos_at_left:
  assumes "p\<noteq>0"
  shows "if even (order c p) \<longleftrightarrow>sign_r_pos p c then eventually (\<lambda>x. poly p x>0) (at_left c)
         else eventually (\<lambda>x. poly p x<0) (at_left c)"
  using assms
proof (induct p rule:poly_root_induct_alt)
  case 0
  then show ?case by simp
next
  case (no_proots p)
  then have [simp]:"order c p = 0" using order_root by blast
  have ?case when "poly p c >0"
  proof -
    have "\<forall>\<^sub>F x in at c. 0 < poly p x"
      using that
      by (metis (no_types, lifting) less_linear no_proots.hyps not_eventuallyD
          poly_IVT_neg poly_IVT_pos)
    then have "\<forall>\<^sub>F x in at_left c. 0 < poly p x"
      using eventually_at_split by blast
    moreover have "sign_r_pos p c" using sign_r_pos_rec[OF \<open>p\<noteq>0\<close>] that by auto
    ultimately show ?thesis by simp
  qed
  moreover have ?case when "poly p c <0"
  proof -
    have "\<forall>\<^sub>F x in at c. poly p x < 0"
      using that
      by (metis (no_types, lifting) less_linear no_proots.hyps not_eventuallyD
          poly_IVT_neg poly_IVT_pos)
    then have "\<forall>\<^sub>F x in at_left c. poly p x < 0"
      using eventually_at_split by blast
    moreover have "\<not> sign_r_pos p c" using sign_r_pos_rec[OF \<open>p\<noteq>0\<close>] that by auto
    ultimately show ?thesis by simp
  qed
  ultimately show ?case using no_proots(1)[of c] by argo
next
  case (root a p)
  define aa where "aa=[:-a,1:]"
  have [simp]:"aa\<noteq>0" "p\<noteq>0" using \<open>[:- a, 1:] * p \<noteq> 0\<close> unfolding aa_def by auto
  have ?case when "c>a"
  proof -
    have "?thesis = (if even (order c p) = sign_r_pos p c
            then \<forall>\<^sub>F x in at_left c. 0 < poly (aa * p) x
            else \<forall>\<^sub>F x in at_left c. poly (aa * p) x < 0)"
    proof -
      have "order c aa=0" unfolding aa_def using order_0I that by force
      then have "even (order c (aa * p)) = even (order c p)"
        by (subst order_mult) auto
      moreover have "sign_r_pos aa c"
        unfolding aa_def using that
        by (auto simp: sign_r_pos_rec)
      then have "sign_r_pos (aa * p) c = sign_r_pos p c"
        by (subst sign_r_pos_mult) auto
      ultimately show ?thesis
        by (fold aa_def) auto
    qed
    also have "... = (if even (order c p) = sign_r_pos p c
            then \<forall>\<^sub>F x in at_left c. 0 < poly p x
            else \<forall>\<^sub>F x in at_left c. poly p x < 0)"
    proof -
      have "\<forall>\<^sub>F x in at_left c. 0 < poly aa x"
        apply (simp add:aa_def)
        using that eventually_at_left_field by blast
      then have "(\<forall>\<^sub>F x in at_left c. 0 < poly (aa * p) x) \<longleftrightarrow> (\<forall>\<^sub>F x in at_left c. 0 < poly p x)"
        "(\<forall>\<^sub>F x in at_left c. 0 > poly (aa * p) x) \<longleftrightarrow> (\<forall>\<^sub>F x in at_left c. 0 > poly p x)"
        apply auto
        by (erule (1) eventually_elim2,simp add: zero_less_mult_iff mult_less_0_iff)+
      then show ?thesis by simp
    qed
    also have "..." using root.hyps by simp
    finally show ?thesis .
  qed
  moreover have ?case when "c<a"
  proof -
    have "?thesis = (if even (order c p) = sign_r_pos p c
            then \<forall>\<^sub>F x in at_left c. poly (aa * p) x < 0
            else \<forall>\<^sub>F x in at_left c. 0 < poly (aa * p) x) "
    proof -
      have "order c aa=0" unfolding aa_def using order_0I that by force
      then have "even (order c (aa * p)) = even (order c p)"
        by (subst order_mult) auto
      moreover have "\<not> sign_r_pos aa c"
        unfolding aa_def using that
        by (auto simp: sign_r_pos_rec)
      then have "sign_r_pos (aa * p) c = (\<not> sign_r_pos p c)"
        by (subst sign_r_pos_mult) auto
      ultimately show ?thesis
        by (fold aa_def) auto
    qed
    also have "... = (if even (order c p) = sign_r_pos p c
            then \<forall>\<^sub>F x in at_left c. 0 < poly p x
            else \<forall>\<^sub>F x in at_left c. poly p x < 0)"
    proof -
      have "\<forall>\<^sub>F x in at_left c. poly aa x < 0"
        apply (simp add:aa_def)
        using that eventually_at_filter by fastforce
      then have "(\<forall>\<^sub>F x in at_left c. 0 < poly (aa * p) x) \<longleftrightarrow> (\<forall>\<^sub>F x in at_left c. poly p x < 0)"
        "(\<forall>\<^sub>F x in at_left c. 0 > poly (aa * p) x) \<longleftrightarrow> (\<forall>\<^sub>F x in at_left c. 0 < poly p x)"
        apply auto
        by (erule (1) eventually_elim2,simp add: zero_less_mult_iff mult_less_0_iff)+
      then show ?thesis by simp
    qed
    also have "..." using root.hyps by simp
    finally show ?thesis .
  qed
  moreover have ?case when "c=a"
  proof -
    have "?thesis = (if even (order c p) = sign_r_pos p c
            then \<forall>\<^sub>F x in at_left c. 0 > poly (aa * p) x
            else \<forall>\<^sub>F x in at_left c. poly (aa * p) x > 0)"
    proof -
      have "order c aa=1" unfolding aa_def using that
        by (metis order_power_n_n power_one_right)
      then have "even (order c (aa * p)) = odd (order c p)"
        by (subst order_mult) auto
      moreover have "sign_r_pos aa c"
        unfolding aa_def using that
        by (auto simp: sign_r_pos_rec pderiv_pCons)
      then have "sign_r_pos (aa * p) c = sign_r_pos p c"
        by (subst sign_r_pos_mult) auto
      ultimately show ?thesis
        by (fold aa_def) auto
    qed
    also have "... = (if even (order c p) = sign_r_pos p c
            then \<forall>\<^sub>F x in at_left c. 0 < poly p x
            else \<forall>\<^sub>F x in at_left c. poly p x < 0)"
    proof -
      have "\<forall>\<^sub>F x in at_left c. 0 > poly aa x"
        apply (simp add:aa_def)
        using that by (simp add: eventually_at_filter)
      then have "(\<forall>\<^sub>F x in at_left c. 0 < poly (aa * p) x) \<longleftrightarrow> (\<forall>\<^sub>F x in at_left c. 0 > poly p x)"
        "(\<forall>\<^sub>F x in at_left c. 0 > poly (aa * p) x) \<longleftrightarrow> (\<forall>\<^sub>F x in at_left c. 0 < poly p x)"
        apply auto
        by (erule (1) eventually_elim2,simp add: zero_less_mult_iff mult_less_0_iff)+
      then show ?thesis by simp
    qed
    also have "..." using root.hyps by simp
    finally show ?thesis .
  qed
  ultimately show ?case by argo
qed

lemma sign_r_pos_nzero_left:
  assumes nzero:"\<forall>x. d\<le>x \<and> x<c \<longrightarrow> poly p x \<noteq>0" and "d<c"
  shows "if even (order c p) \<longleftrightarrow>sign_r_pos p c then poly p d>0 else poly p d<0"
proof (cases "even (order c p) \<longleftrightarrow>sign_r_pos p c")
  case True
  then have "eventually (\<lambda>x. poly p x>0) (at_left c)"
    using nzero[rule_format,of d,simplified] \<open>d<c\<close> sign_r_pos_at_left
    by (simp add: order_root)
  then obtain d' where "d'<c" and d'_pos:"\<forall>y>d'. y < c \<longrightarrow> 0 < poly p y"
    unfolding eventually_at_left by auto
  have False when "\<not> poly p d>0"
  proof -
    have "\<exists>x>d. x < (c + max d d') / 2 \<and> poly p x = 0"
      apply (rule poly_IVT_pos)
      using \<open>d'<c\<close> \<open>c>d\<close> that nzero[rule_format,of d,simplified]
      by (auto intro:d'_pos[rule_format])
    then show False using nzero \<open>c > d'\<close> by auto
  qed
  then show ?thesis using True by auto
next
  case False
  then have "eventually (\<lambda>x. poly p x<0) (at_left c)"
    using nzero[rule_format,of d,simplified] \<open>d<c\<close> sign_r_pos_at_left
    by (simp add: order_root)
  then obtain d' where "d'<c" and d'_neg:"\<forall>y>d'. y < c \<longrightarrow> 0 > poly p y"
    unfolding eventually_at_left by auto
  have False when "\<not> poly p d<0"
  proof -
    have "\<exists>x>d. x < (c + max d d') / 2 \<and> poly p x = 0"
      apply (rule poly_IVT_neg)
      using \<open>d'<c\<close> \<open>c>d\<close> that nzero[rule_format,of d,simplified]
      by (auto intro:d'_neg[rule_format])
    then show False using nzero \<open>c > d'\<close> by auto
  qed
  then show ?thesis using False by auto
qed

subsection \<open>Fourier sequences\<close>

function pders::"real poly \<Rightarrow> real poly list" where
  "pders p = (if p =0 then [] else Cons p (pders (pderiv p)))"
  by auto
termination
  apply (relation "measure (\<lambda>p. if p=0 then 0 else degree p + 1)")
  by (auto simp:degree_pderiv pderiv_eq_0_iff)

declare pders.simps[simp del]

lemma set_pders_nzero:
  assumes "p\<noteq>0" "q\<in>set (pders p)"
  shows "q\<noteq>0"
  using assms
proof (induct p rule:pders.induct)
  case (1 p)
  then have "q \<in> set (p # pders (pderiv p))"
    by (simp add: pders.simps)
  then have "q=p \<or> q\<in>set (pders (pderiv p))" by auto
  moreover have ?case when "q=p"
    using that \<open>p\<noteq>0\<close> by auto
  moreover have ?case when "q\<in>set (pders (pderiv p))"
    using 1 pders.simps by fastforce
  ultimately show ?case by auto
qed

subsection \<open>Sign variations for Fourier sequences\<close>

definition changes_itv_der:: "real \<Rightarrow> real \<Rightarrow>real poly \<Rightarrow>  int" where
  "changes_itv_der a b p= (let ps= pders p in changes_poly_at ps a - changes_poly_at ps b)"

definition changes_gt_der:: "real \<Rightarrow>real poly \<Rightarrow> int" where
  "changes_gt_der a p= changes_poly_at (pders p) a"

definition changes_le_der:: "real \<Rightarrow>real poly \<Rightarrow> int" where
  "changes_le_der b p= (degree p - changes_poly_at (pders p) b)"

lemma changes_poly_pos_inf_pders[simp]:"changes_poly_pos_inf (pders p) = 0"
proof (induct "degree p" arbitrary:p)
  case 0
  then obtain a where "p=[:a:]" using degree_eq_zeroE by auto
  then show ?case
    apply (cases "a=0")
    by (auto simp:changes_poly_pos_inf_def pders.simps)
next
  case (Suc x)
  then have "pderiv p\<noteq>0" "p\<noteq>0" using pderiv_eq_0_iff by force+
  define ps where "ps=pders (pderiv (pderiv p))"
  have ps:"pders p = p# pderiv p #ps" "pders (pderiv p) = pderiv p#ps"
    unfolding ps_def by (simp_all add: \<open>p \<noteq> 0\<close> \<open>pderiv p \<noteq> 0\<close> pders.simps)
  have hyps:"changes_poly_pos_inf (pders (pderiv p)) = 0"
    apply (rule Suc(1))
    using \<open>Suc x = degree p\<close> by (metis degree_pderiv diff_Suc_1)
  moreover have "sgn_pos_inf p * sgn_pos_inf (pderiv p) >0"
    unfolding sgn_pos_inf_def lead_coeff_pderiv
    apply (simp add:algebra_simps sgn_mult)
    using Suc.hyps(2) \<open>p \<noteq> 0\<close> by linarith
  ultimately show ?case unfolding changes_poly_pos_inf_def ps by auto
qed

lemma changes_poly_neg_inf_pders[simp]: "changes_poly_neg_inf (pders p) = degree p"
proof (induct "degree p" arbitrary:p)
  case 0
  then obtain a where "p=[:a:]" using degree_eq_zeroE by auto
  then show ?case unfolding changes_poly_neg_inf_def by (auto simp: pders.simps)
next
  case (Suc x)
  then have "pderiv p\<noteq>0" "p\<noteq>0" using pderiv_eq_0_iff by force+
  then have "changes_poly_neg_inf (pders p)
                  = changes_poly_neg_inf (p # pderiv p#pders (pderiv (pderiv p)))"
    by (simp add:pders.simps)
  also have "... = 1 +  changes_poly_neg_inf (pderiv p#pders (pderiv (pderiv p)))"
  proof -
    have "sgn_neg_inf p * sgn_neg_inf (pderiv p) < 0"
      unfolding sgn_neg_inf_def using \<open>p\<noteq>0\<close> \<open>pderiv p\<noteq>0\<close>
      by (auto simp add:lead_coeff_pderiv degree_pderiv coeff_pderiv sgn_mult pderiv_eq_0_iff)
    then show ?thesis unfolding changes_poly_neg_inf_def by auto
  qed
  also have "... = 1 +  changes_poly_neg_inf (pders (pderiv p))"
    using \<open>pderiv p\<noteq>0\<close> by (simp add:pders.simps)
  also have "... = 1 + degree (pderiv p)"
    apply (subst Suc(1))
    using Suc(2) by (auto simp add: degree_pderiv)
  also have "... = degree p"
    by (metis Suc.hyps(2) degree_pderiv diff_Suc_1 plus_1_eq_Suc)
  finally show ?case .
qed

lemma pders_coeffs_sgn_eq:"map (\<lambda>p. sgn(poly p 0)) (pders p) = map sgn (coeffs p)"
proof (induct "degree p" arbitrary:p)
  case 0
  then obtain a where "p=[:a:]" using degree_eq_zeroE by auto
  then show ?case by (auto simp: pders.simps)
next
  case (Suc x)
  then have "pderiv p\<noteq>0" "p\<noteq>0" using pderiv_eq_0_iff by force+

  have "map (\<lambda>p. sgn (poly p 0)) (pders p)
          = sgn (poly p 0)# map (\<lambda>p. sgn (poly p 0)) (pders (pderiv p))"
    apply (subst pders.simps)
    using \<open>p\<noteq>0\<close> by simp
  also have "... = sgn (coeff p 0) # map sgn (coeffs (pderiv p))"
  proof -
    have "sgn (poly p 0) = sgn (coeff p 0)" by (simp add: poly_0_coeff_0)
    then show ?thesis
      apply (subst Suc(1))
      subgoal by (metis Suc.hyps(2) degree_pderiv diff_Suc_1)
      subgoal by auto
      done
  qed
  also have "... =  map sgn (coeffs p)"
  proof (rule nth_equalityI)
    show p_length:"length (sgn (coeff p 0) # map sgn (coeffs (pderiv p)))
                         = length (map sgn (coeffs p))"
      by (metis Suc.hyps(2) \<open>p \<noteq> 0\<close> \<open>pderiv p \<noteq> 0\<close> degree_pderiv diff_Suc_1 length_Cons
          length_coeffs_degree length_map)
    show "(sgn (coeff p 0) # map sgn (coeffs (pderiv p))) ! i = map sgn (coeffs p) ! i"
      if "i < length (sgn (coeff p 0) # map sgn (coeffs (pderiv p)))" for i
    proof -
      show "(sgn (coeff p 0) # map sgn (coeffs (pderiv p))) ! i = map sgn (coeffs p) ! i"
      proof (cases i)
        case 0
        then show ?thesis
          by (simp add: \<open>p \<noteq> 0\<close> coeffs_nth)
      next
        case (Suc i')
        then show ?thesis
          using that p_length
          apply simp
          apply (subst (1 2) coeffs_nth)
          by (auto simp add: \<open>p \<noteq> 0\<close> \<open>pderiv p \<noteq> 0\<close> length_coeffs_degree coeff_pderiv sgn_mult)
      qed
    qed
  qed
  finally show ?case .
qed

lemma changes_poly_at_pders_0:"changes_poly_at (pders p) 0 = changes (coeffs p)"
  unfolding changes_poly_at_def
  apply (subst (1 2) changes_map_sgn_eq)
  by (auto simp add:pders_coeffs_sgn_eq comp_def)

subsection \<open>Budan-Fourier theorem\<close>

lemma budan_fourier_aux_right:
  assumes "c<d2" and "p\<noteq>0"
  assumes "\<forall>x. c<x\<and> x\<le>d2 \<longrightarrow> (\<forall>q\<in>set (pders p). poly q x\<noteq>0)"
  shows "changes_itv_der c d2 p=0"
  using assms(2-3)
proof (induct "degree p" arbitrary:p)
  case 0
  then obtain a where "p=[:a:]" "a\<noteq>0" by (metis degree_eq_zeroE pCons_0_0)
  then show ?case
    by (auto simp add:changes_itv_der_def pders.simps intro:order_0I)
next
  case (Suc n)
  then have [simp]:"pderiv p\<noteq>0" by (metis nat.distinct(1) pderiv_eq_0_iff)
  note nzero=\<open>\<forall>x. c < x \<and> x \<le> d2 \<longrightarrow> (\<forall>q\<in>set (pders p). poly q x \<noteq> 0)\<close>

  have hyps:"changes_itv_der c d2 (pderiv p) = 0"
    apply (rule Suc(1))
    subgoal by (metis Suc.hyps(2) degree_pderiv diff_Suc_1)
    subgoal by (simp add: Suc.prems(1) Suc.prems(2) pders.simps)
    subgoal by (simp add: Suc.prems(1) nzero pders.simps)
    done
  have pders_changes_c:"changes_poly_at (r# pders q) c = (if sign_r_pos q c \<longleftrightarrow> poly r c>0
          then changes_poly_at (pders q) c else 1+changes_poly_at (pders q) c)"
    when "poly r c\<noteq>0" "q\<noteq>0" for q r
    using \<open>q\<noteq>0\<close>
  proof (induct q rule:pders.induct)
    case (1 q)
    have ?case when "pderiv q=0"
    proof -
      have "degree q=0" using that pderiv_eq_0_iff by blast
      then obtain a where "q=[:a:]" "a\<noteq>0" using \<open>q\<noteq>0\<close> by (metis degree_eq_zeroE pCons_0_0)
      then show ?thesis using \<open>poly r c\<noteq>0\<close>
        by (auto simp add:sign_r_pos_rec changes_poly_at_def mult_less_0_iff pders.simps)
    qed
    moreover have ?case when "pderiv q\<noteq>0"
    proof -
      obtain qs where qs:"pders q=q#qs" "pders (pderiv q) = qs"
        using \<open>q\<noteq>0\<close> by (simp add:pders.simps)
      have "changes_poly_at (r # qs) c = (if sign_r_pos (pderiv q) c = (0 < poly r c)
              then changes_poly_at qs c else 1 + changes_poly_at qs c)"
        using 1 \<open>pderiv q\<noteq>0\<close> unfolding qs by simp
      then show ?thesis unfolding qs
        apply (cases "poly q c=0")
        subgoal unfolding changes_poly_at_def by (auto simp:sign_r_pos_rec[OF \<open>q\<noteq>0\<close>,of c])
        subgoal unfolding changes_poly_at_def using \<open>poly r c\<noteq>0\<close>
          by (auto simp:sign_r_pos_rec[OF \<open>q\<noteq>0\<close>,of c] mult_less_0_iff)
        done
    qed
    ultimately show ?case by blast
  qed
  have pders_changes_d2:"changes_poly_at (r# pders q) d2 = (if sign_r_pos q c \<longleftrightarrow> poly r c>0
          then changes_poly_at (pders q) d2 else 1+changes_poly_at (pders q) d2)"
    when "poly r c\<noteq>0" "q\<noteq>0" and qr_nzero:"\<forall>x. c < x \<and> x \<le> d2 \<longrightarrow> poly r x \<noteq> 0 \<and> poly q x\<noteq>0"
    for q r
  proof -
    have "r\<noteq>0" using that(1) using poly_0 by blast
    obtain qs where qs:"pders q=q#qs" "pders (pderiv q) = qs"
      using \<open>q\<noteq>0\<close> by (simp add:pders.simps)
    have "if sign_r_pos r c then 0 < poly r d2 else poly r d2 < 0"
      "if sign_r_pos q c then 0 < poly q d2 else poly q d2 < 0"
      subgoal by (rule sign_r_pos_nzero_right[of c d2 r]) (use qr_nzero \<open>c<d2\<close> in auto)
      subgoal by (rule sign_r_pos_nzero_right[of c d2 q]) (use qr_nzero \<open>c<d2\<close> in auto)
      done
    then show ?thesis unfolding qs changes_poly_at_def
      using \<open>poly r c\<noteq>0\<close> by (auto split:if_splits simp:mult_less_0_iff sign_r_pos_rec[OF \<open>r\<noteq>0\<close>])
  qed
  have  d2c_nzero:"\<forall>x. c<x \<and> x\<le>d2 \<longrightarrow> poly p x\<noteq>0 \<and> poly (pderiv p) x \<noteq>0"
    and p_cons:"pders p = p#pders(pderiv p)"
    subgoal by (simp add: nzero Suc.prems(1) pders.simps)
    subgoal by (simp add: Suc.prems(1) pders.simps)
    done

  have ?case when "poly p c=0"
  proof -
    define ps where "ps=pders (pderiv (pderiv p))"
    have ps_cons:"p#pderiv p#ps = pders p" "pderiv p#ps=pders (pderiv p)"
      unfolding ps_def using \<open>p\<noteq>0\<close> by (auto simp:pders.simps)

    have "changes_poly_at (p # pderiv p # ps) c =  changes_poly_at (pderiv p # ps) c"
      unfolding changes_poly_at_def using that by auto
    moreover have "changes_poly_at (p # pderiv p # ps) d2 = changes_poly_at (pderiv p # ps) d2"
    proof -
      have "if sign_r_pos p c then 0 < poly p d2 else poly p d2 < 0"
        apply (rule sign_r_pos_nzero_right[OF _ \<open>c<d2\<close>])
        using nzero[folded ps_cons] assms(1-2) by auto
      moreover have "if sign_r_pos (pderiv p) c then 0 < poly (pderiv p) d2
                     else poly (pderiv p) d2 < 0"
        apply (rule sign_r_pos_nzero_right[OF _ \<open>c<d2\<close>])
        using nzero[folded ps_cons] assms(1-2) by auto
      ultimately have "poly p d2 * poly (pderiv p) d2 > 0"
        unfolding zero_less_mult_iff sign_r_pos_rec[OF \<open>p\<noteq>0\<close>] using \<open>poly p c=0\<close>
        by (auto split:if_splits)
      then show ?thesis unfolding changes_poly_at_def by auto
    qed
    ultimately show ?thesis using hyps unfolding changes_itv_der_def
      apply (fold ps_cons)
      by (auto simp:Let_def)
  qed
  moreover have ?case when "poly p c\<noteq>0" "sign_r_pos (pderiv p) c \<longleftrightarrow> poly p c>0"
  proof -
    have "changes_poly_at (pders p) c = changes_poly_at (pders (pderiv p)) c"
      unfolding p_cons
      apply (subst pders_changes_c[OF \<open>poly p c\<noteq>0\<close>])
      using that by auto
    moreover have "changes_poly_at (pders p) d2 = changes_poly_at (pders (pderiv p)) d2"
      unfolding p_cons
      apply (subst pders_changes_d2[OF \<open>poly p c\<noteq>0\<close> _ d2c_nzero])
      using that by auto
    ultimately show ?thesis using hyps unfolding changes_itv_der_def Let_def
      by auto
  qed
  moreover have ?case when "poly p c\<noteq>0" "\<not> sign_r_pos (pderiv p) c \<longleftrightarrow> poly p c>0"
  proof -
    have "changes_poly_at (pders p) c = changes_poly_at (pders (pderiv p)) c +1"
      unfolding p_cons
      apply (subst pders_changes_c[OF \<open>poly p c\<noteq>0\<close>])
      using that by auto
    moreover have "changes_poly_at (pders p) d2 = changes_poly_at (pders (pderiv p)) d2 + 1"
      unfolding p_cons
      apply (subst pders_changes_d2[OF \<open>poly p c\<noteq>0\<close> _ d2c_nzero])
      using that by auto
    ultimately show ?thesis using hyps unfolding changes_itv_der_def Let_def
      by auto
  qed
  ultimately show ?case by blast
qed

lemma budan_fourier_aux_left':
  assumes "d1<c" and "p\<noteq>0"
  assumes "\<forall>x. d1\<le>x\<and> x<c \<longrightarrow> (\<forall>q\<in>set (pders p). poly q x\<noteq>0)"
  shows "changes_itv_der d1 c p \<ge> order c p \<and> even (changes_itv_der d1 c p - order c p)"
  using assms(2-3)
proof (induct "degree p" arbitrary:p)
  case 0
  then obtain a where "p=[:a:]" "a\<noteq>0" by (metis degree_eq_zeroE pCons_0_0)
  then show ?case
    apply (auto simp add:changes_itv_der_def pders.simps intro:order_0I)
    by (metis add.right_neutral dvd_0_right mult_zero_right order_root poly_pCons)
next
  case (Suc n)
  then have [simp]:"pderiv p\<noteq>0" by (metis nat.distinct(1) pderiv_eq_0_iff)
  note nzero=\<open>\<forall>x. d1 \<le> x \<and> x < c \<longrightarrow> (\<forall>q\<in>set (pders p). poly q x \<noteq> 0)\<close>
  define v where "v=order c (pderiv p)"

  have hyps:"v \<le> changes_itv_der d1 c (pderiv p) \<and> even (changes_itv_der d1 c (pderiv p) - v)"
    unfolding v_def
    apply (rule Suc(1))
    subgoal by (metis Suc.hyps(2) degree_pderiv diff_Suc_1)
    subgoal by (simp add: Suc.prems(1) Suc.prems(2) pders.simps)
    subgoal by (simp add: Suc.prems(1) nzero pders.simps)
    done
  have pders_changes_c:"changes_poly_at (r# pders q) c = (if sign_r_pos q c \<longleftrightarrow> poly r c>0
          then changes_poly_at (pders q) c else 1+changes_poly_at (pders q) c)"
    when "poly r c\<noteq>0" "q\<noteq>0" for q r
    using \<open>q\<noteq>0\<close>
  proof (induct q rule:pders.induct)
    case (1 q)
    have ?case when "pderiv q=0"
    proof -
      have "degree q=0" using that pderiv_eq_0_iff by blast
      then obtain a where "q=[:a:]" "a\<noteq>0" using \<open>q\<noteq>0\<close> by (metis degree_eq_zeroE pCons_0_0)
      then show ?thesis using \<open>poly r c\<noteq>0\<close>
        by (auto simp add:sign_r_pos_rec changes_poly_at_def mult_less_0_iff pders.simps)
    qed
    moreover have ?case when "pderiv q\<noteq>0"
    proof -
      obtain qs where qs:"pders q=q#qs" "pders (pderiv q) = qs"
        using \<open>q\<noteq>0\<close> by (simp add:pders.simps)
      have "changes_poly_at (r # qs) c = (if sign_r_pos (pderiv q) c = (0 < poly r c)
              then changes_poly_at qs c else 1 + changes_poly_at qs c)"
        using 1 \<open>pderiv q\<noteq>0\<close> unfolding qs by simp
      then show ?thesis unfolding qs
        apply (cases "poly q c=0")
        subgoal unfolding changes_poly_at_def by (auto simp:sign_r_pos_rec[OF \<open>q\<noteq>0\<close>,of c])
        subgoal unfolding changes_poly_at_def using \<open>poly r c\<noteq>0\<close>
          by (auto simp:sign_r_pos_rec[OF \<open>q\<noteq>0\<close>,of c] mult_less_0_iff)
        done
    qed
    ultimately show ?case by blast
  qed
  have pders_changes_d1:"changes_poly_at (r# pders q) d1 = (if even (order c q) \<longleftrightarrow> sign_r_pos q c \<longleftrightarrow> poly r c>0
          then changes_poly_at (pders q) d1 else 1+changes_poly_at (pders q) d1)"
    when "poly r c\<noteq>0" "q\<noteq>0" and qr_nzero:"\<forall>x. d1 \<le> x \<and> x < c \<longrightarrow> poly r x \<noteq> 0 \<and> poly q x\<noteq>0"
    for q r
  proof -
    have "r\<noteq>0" using that(1) using poly_0 by blast
    obtain qs where qs:"pders q=q#qs" "pders (pderiv q) = qs"
      using \<open>q\<noteq>0\<close> by (simp add:pders.simps)
    have "if even (order c r) = sign_r_pos r c then 0 < poly r d1 else poly r d1 < 0"
      "if even (order c q) = sign_r_pos q c then 0 < poly q d1 else poly q d1 < 0"
      subgoal by (rule sign_r_pos_nzero_left[of d1 c r]) (use qr_nzero \<open>d1<c\<close> in auto)
      subgoal by (rule sign_r_pos_nzero_left[of d1 c q]) (use qr_nzero \<open>d1<c\<close> in auto)
      done
    moreover have "order c r=0" by (simp add: order_0I that(1))
    ultimately show ?thesis unfolding qs changes_poly_at_def
      using \<open>poly r c\<noteq>0\<close> by (auto split:if_splits simp:mult_less_0_iff sign_r_pos_rec[OF \<open>r\<noteq>0\<close>])
  qed
  have d1c_nzero:"\<forall>x. d1 \<le> x \<and> x < c \<longrightarrow> poly p x \<noteq> 0 \<and> poly (pderiv p) x \<noteq> 0"
    and p_cons:"pders p = p#pders(pderiv p)"
    by (simp_all add: nzero Suc.prems(1) pders.simps)

  have ?case when "poly p c=0"
  proof -
    define ps where "ps=pders (pderiv (pderiv p))"
    have ps_cons:"p#pderiv p#ps = pders p" "pderiv p#ps=pders (pderiv p)"
      unfolding ps_def using \<open>p\<noteq>0\<close> by (auto simp:pders.simps)

    have p_order:"order c p = Suc v"
      apply (subst order_pderiv)
      using Suc.prems(1) order_root that unfolding v_def by auto
    moreover have "changes_poly_at (p#pderiv p # ps) d1 = changes_poly_at (pderiv p#ps) d1 +1"
    proof -
      have "if even (order c p) = sign_r_pos p c then 0 < poly p d1 else poly p d1 < 0"
        apply (rule sign_r_pos_nzero_left[OF _ \<open>d1<c\<close>])
        using nzero[folded ps_cons] assms(1-2) by auto
      moreover have "if even v = sign_r_pos (pderiv p) c
                      then 0 < poly (pderiv p) d1 else poly (pderiv p) d1 < 0"
        unfolding v_def
        apply (rule sign_r_pos_nzero_left[OF _ \<open>d1<c\<close>])
        using nzero[folded ps_cons] assms(1-2) by auto
      ultimately have "poly p d1 * poly (pderiv p) d1 < 0"
        unfolding mult_less_0_iff sign_r_pos_rec[OF \<open>p\<noteq>0\<close>] using \<open>poly p c=0\<close> p_order
        by (auto split:if_splits)
      then show ?thesis
        unfolding changes_poly_at_def by auto
    qed
    moreover have "changes_poly_at (p # pderiv p # ps) c =  changes_poly_at (pderiv p # ps) c"
      unfolding changes_poly_at_def using that by auto
    ultimately show ?thesis using hyps unfolding changes_itv_der_def
      apply (fold ps_cons)
      by (auto simp:Let_def)
  qed
  moreover have ?case when "poly p c\<noteq>0" "odd v" "sign_r_pos (pderiv p) c \<longleftrightarrow> poly p c>0"
  proof -
    have "order c p=0" by (simp add: order_0I that(1))
    moreover have "changes_poly_at (pders p) d1 = changes_poly_at (pders (pderiv p)) d1 +1"
      unfolding p_cons
      apply (subst pders_changes_d1[OF \<open>poly p c\<noteq>0\<close> _ d1c_nzero])
      using that unfolding v_def by auto
    moreover have "changes_poly_at (pders p) c = changes_poly_at (pders (pderiv p)) c"
      unfolding p_cons
      apply (subst pders_changes_c[OF \<open>poly p c\<noteq>0\<close>])
      using that unfolding v_def by auto
    ultimately show ?thesis using hyps \<open>odd v\<close> unfolding changes_itv_der_def Let_def
      by auto
  qed
  moreover have ?case when "poly p c\<noteq>0" "odd v" "\<not> sign_r_pos (pderiv p) c \<longleftrightarrow> poly p c>0"
  proof -
    have "v\<ge>1" using \<open>odd v\<close> using not_less_eq_eq by auto
    moreover have "order c p=0" by (simp add: order_0I that(1))
    moreover have "changes_poly_at (pders p) d1 = changes_poly_at (pders (pderiv p)) d1"
      unfolding p_cons
      apply (subst pders_changes_d1[OF \<open>poly p c\<noteq>0\<close> _ d1c_nzero])
      using that unfolding v_def by auto
    moreover have "changes_poly_at (pders p) c = changes_poly_at (pders (pderiv p)) c + 1"
      unfolding p_cons
      apply (subst pders_changes_c[OF \<open>poly p c\<noteq>0\<close>])
      using that unfolding v_def by auto
    ultimately show ?thesis using hyps \<open>odd v\<close> unfolding changes_itv_der_def Let_def
      by auto
  qed
  moreover have ?case when "poly p c\<noteq>0" "even v" "sign_r_pos (pderiv p) c \<longleftrightarrow> poly p c>0"
  proof -
    have "order c p=0" by (simp add: order_0I that(1))
    moreover have "changes_poly_at (pders p) d1 = changes_poly_at (pders (pderiv p)) d1"
      unfolding p_cons
      apply (subst pders_changes_d1[OF \<open>poly p c\<noteq>0\<close> _ d1c_nzero])
      using that unfolding v_def by auto
    moreover have "changes_poly_at (pders p) c = changes_poly_at (pders (pderiv p)) c"
      unfolding p_cons
      apply (subst pders_changes_c[OF \<open>poly p c\<noteq>0\<close>])
      using that unfolding v_def by auto
    ultimately show ?thesis using hyps \<open>even v\<close> unfolding changes_itv_der_def Let_def
      by auto
  qed
  moreover have ?case when "poly p c\<noteq>0" "even v" "\<not> sign_r_pos (pderiv p) c \<longleftrightarrow> poly p c>0"
  proof -
    have "order c p=0" by (simp add: order_0I that(1))
    moreover have "changes_poly_at (pders p) d1 = changes_poly_at (pders (pderiv p)) d1 + 1"
      unfolding p_cons
      apply (subst pders_changes_d1[OF \<open>poly p c\<noteq>0\<close> _ d1c_nzero])
      using that unfolding v_def by auto
    moreover have "changes_poly_at (pders p) c = changes_poly_at (pders (pderiv p)) c +1"
      unfolding p_cons
      apply (subst pders_changes_c[OF \<open>poly p c\<noteq>0\<close>])
      using that unfolding v_def by auto
    ultimately show ?thesis using hyps \<open>even v\<close> unfolding changes_itv_der_def Let_def
      by auto
  qed
  ultimately show ?case by blast
qed

lemma budan_fourier_aux_left:
  assumes "d1<c" and "p\<noteq>0"
  assumes nzero:"\<forall>x. d1<x\<and> x<c \<longrightarrow> (\<forall>q\<in>set (pders p). poly q x\<noteq>0)"
  shows "changes_itv_der d1 c p \<ge> order c p" "even (changes_itv_der d1 c p - order c p)"
proof -
  define d where "d=(d1+c)/2"
  have "d1<d" "d<c" unfolding d_def using \<open>d1<c\<close> by auto

  have "changes_itv_der d1 d p = 0"
    apply (rule budan_fourier_aux_right[OF \<open>d1<d\<close> \<open>p\<noteq>0\<close>])
    using nzero \<open>d1<d\<close> \<open>d<c\<close> by auto
  moreover have "order c p \<le> changes_itv_der d c p \<and> even (changes_itv_der d c p - order c p)"
    apply (rule budan_fourier_aux_left'[OF \<open>d<c\<close> \<open>p\<noteq>0\<close>])
    using nzero \<open>d1<d\<close> \<open>d<c\<close> by auto
  ultimately show "changes_itv_der d1 c p \<ge> order c p" "even (changes_itv_der d1 c p - order c p)"
    unfolding changes_itv_der_def Let_def by auto
qed

theorem budan_fourier_interval:
  assumes "a<b" "p\<noteq>0"
  shows "changes_itv_der a b p \<ge> proots_count p {x. a< x \<and> x\<le> b} \<and>
          even (changes_itv_der a b p - proots_count p {x. a< x \<and> x\<le> b})"
  using \<open>a<b\<close>
proof (induct "card {x. \<exists>p\<in>set (pders p). poly p x=0 \<and> a<x \<and> x<b}" arbitrary:b)
  case 0
  have nzero:"\<forall>x. a<x \<and> x<b \<longrightarrow> (\<forall>q\<in>set (pders p). poly q x\<noteq>0)"
  proof -
    define S where "S={x. \<exists>p\<in>set (pders p). poly p x = 0 \<and> a < x \<and> x < b}"
    have "finite S"
    proof -
      have "S \<subseteq> (\<Union>p\<in>set (pders p). proots p)"
        unfolding S_def by auto
      moreover have "finite (\<Union>p\<in>set (pders p). proots p)"
        apply (subst finite_UN)
        using set_pders_nzero[OF \<open>p\<noteq>0\<close>] by auto
      ultimately show ?thesis by (simp add: finite_subset)
    qed
    moreover have "card S = 0" unfolding S_def using 0 by auto
    ultimately have "S={}" by auto
    then show ?thesis unfolding S_def using \<open>a<b\<close> assms(2) pders.simps by fastforce
  qed
  from budan_fourier_aux_left[OF \<open>a<b\<close> \<open>p\<noteq>0\<close> this]
  have "order b p \<le> changes_itv_der a b p" "even (changes_itv_der a b p - order b p)" by simp_all
  moreover have "proots_count p {x. a< x \<and> x\<le> b} = order b p"
  proof -
    have p_cons:"pders p=p#pders (pderiv p)" by (simp add: assms(2) pders.simps)
    have "proots_within p {x. a < x \<and> x \<le> b} = (if poly p b=0 then {b} else {})"
      using nzero \<open>a< b\<close> unfolding p_cons
      apply auto
      using not_le by fastforce
    then show ?thesis unfolding proots_count_def using order_root by auto
  qed
  ultimately show ?case by auto
next
  case (Suc n)
  define P where "P=(\<lambda>x. \<exists>p\<in>set (pders p). poly p x = 0)"
  define S where "S=(\<lambda>b. {x. P x \<and> a < x \<and> x < b})"
  define b' where "b'=Max (S b)"
  have f_S:"finite (S x)" for x
  proof -
    have "S x \<subseteq> (\<Union>p\<in>set (pders p). proots p)"
      unfolding S_def P_def by auto
    moreover have "finite (\<Union>p\<in>set (pders p). proots p)"
      apply (subst finite_UN)
      using set_pders_nzero[OF \<open>p\<noteq>0\<close>] by auto
    ultimately show ?thesis by (simp add: finite_subset)
  qed
  have "b'\<in>S b"
    unfolding b'_def
    apply (rule Max_in[OF f_S])
    using Suc(2) unfolding S_def P_def by force
  then have "a<b'" "b'<b" unfolding S_def by auto
  have b'_nzero:"\<forall>x. b'<x \<and> x<b \<longrightarrow> (\<forall>q\<in>set (pders p). poly q x\<noteq>0)"
  proof (rule ccontr)
    assume "\<not> (\<forall>x. b' < x \<and> x < b \<longrightarrow> (\<forall>q\<in>set (pders p). poly q x \<noteq> 0))"
    then obtain bb where "P bb" "b'<bb" "bb<b" unfolding P_def by auto
    then have "bb\<in>S b" unfolding S_def using \<open>a<b'\<close> \<open>b'<b\<close> by auto
    from Max_ge[OF f_S this, folded b'_def] have "bb \<le> b'" .
    then show False using \<open>b'<bb\<close> by auto
  qed

  have hyps:"proots_count p {x. a < x \<and> x \<le> b'} \<le> changes_itv_der a b' p \<and>
                even (changes_itv_der a b' p - proots_count p {x. a < x \<and> x \<le> b'})"
  proof (rule Suc(1)[OF _ \<open>a<b'\<close>])
    have "S b= {b'} \<union> S b'"
    proof -
      have "{x. P x \<and> b' < x \<and> x < b} = {}"
        using b'_nzero unfolding P_def by auto
      then have "{x. P x\<and> b' \<le> x \<and> x < b} = {b'}"
        using \<open>b'\<in>S b\<close> unfolding S_def by force
      moreover have "S b= S b' \<union>  {x. P x \<and> b' \<le> x \<and> x < b}"
        unfolding S_def using \<open>a<b'\<close> \<open>b'<b\<close> by auto
      ultimately show ?thesis by auto
    qed
    moreover have "Suc n = card (S b)" using Suc(2) unfolding S_def P_def by simp
    moreover have "b'\<notin>S b'" unfolding S_def by auto
    ultimately have "n=card (S b')" using f_S by auto
    then show "n = card {x. \<exists>p\<in>set (pders p). poly p x = 0 \<and> a < x \<and> x < b'}"
      unfolding S_def P_def by simp
  qed
  moreover have "proots_count p {x. a < x \<and> x \<le> b}
                    = proots_count p {x. a < x \<and> x \<le> b'} + order b p"
  proof -
    have p_cons:"pders p=p#pders (pderiv p)" by (simp add: assms(2) pders.simps)
    have "proots_within p {x. b' < x \<and> x \<le> b} = (if poly p b=0 then {b} else {})"
      using b'_nzero \<open>b' < b\<close> unfolding p_cons
      apply auto
      using not_le by fastforce
    then have "proots_count p {x. b' < x \<and> x \<le> b} = order b p"
      unfolding proots_count_def using order_root by auto
    moreover have "proots_count p {x. a < x \<and> x \<le> b} = proots_count p {x. a < x \<and> x \<le> b'} +
            proots_count p {x. b' < x \<and> x \<le> b}"
      apply (subst proots_count_union_disjoint[symmetric])
      using \<open>a<b'\<close> \<open>b'<b\<close> \<open>p\<noteq>0\<close> by (auto intro:arg_cong2[where f=proots_count])
    ultimately show ?thesis by auto
  qed
  moreover note budan_fourier_aux_left[OF \<open>b'<b\<close> \<open>p\<noteq>0\<close> b'_nzero]
  ultimately show ?case unfolding changes_itv_der_def Let_def by auto
qed

theorem budan_fourier_gt:
  assumes "p\<noteq>0"
  shows "changes_gt_der a p \<ge> proots_count p {x. a< x} \<and>
          even (changes_gt_der a p - proots_count p {x. a< x})"
proof -
  define ps where "ps=pders p"
  obtain ub where ub_root:"\<forall>p\<in>set ps. \<forall>x. poly p x = 0 \<longrightarrow> x < ub"
    and ub_sgn:"\<forall>x\<ge>ub. \<forall>p\<in>set ps. sgn (poly p x) = sgn_pos_inf p"
    and "a < ub"
    using root_list_ub[of ps a] set_pders_nzero[OF \<open>p\<noteq>0\<close>,folded ps_def] by blast
  have "proots_count p {x. a< x} = proots_count p {x. a< x \<and> x \<le> ub}"
  proof -
    have "p\<in>set ps" unfolding ps_def by (simp add: assms pders.simps)
    then have "proots_within p {x. a< x} = proots_within p {x. a< x \<and> x\<le>ub}"
      using ub_root by fastforce
    then show ?thesis unfolding proots_count_def by auto
  qed
  moreover have "changes_gt_der a p = changes_itv_der a ub p"
  proof -
    have "map (sgn \<circ> (\<lambda>p. poly p ub)) ps = map sgn_pos_inf ps"
      using ub_sgn[THEN spec,of ub,simplified]
      by (metis (mono_tags, lifting) comp_def list.map_cong0)
    hence "changes_poly_at ps ub=changes_poly_pos_inf ps"
      unfolding changes_poly_pos_inf_def changes_poly_at_def
      by (subst changes_map_sgn_eq,metis map_map)
    then have "changes_poly_at ps ub=0" unfolding ps_def by simp
    thus ?thesis unfolding changes_gt_der_def changes_itv_der_def ps_def
      by (simp add:Let_def)
  qed
  moreover have "proots_count p {x. a < x \<and> x \<le> ub} \<le> changes_itv_der a ub p \<and>
      even (changes_itv_der a ub p - proots_count p {x. a < x \<and> x \<le> ub})"
    using budan_fourier_interval[OF \<open>a<ub\<close> \<open>p\<noteq>0\<close>] .
  ultimately show ?thesis by auto
qed

text \<open>Descartes' rule of signs is a direct consequence of the Budan-Fourier theorem\<close>
theorem descartes_sign:
  fixes p::"real poly"
  assumes "p\<noteq>0"
  shows " changes (coeffs p) \<ge> proots_count p {x. 0 < x} \<and>
          even (changes (coeffs p) - proots_count p {x. 0< x})"
  using budan_fourier_gt[OF \<open>p\<noteq>0\<close>,of 0] unfolding changes_gt_der_def
  by (simp add:changes_poly_at_pders_0)

theorem budan_fourier_le:
  assumes "p\<noteq>0"
  shows "changes_le_der b p \<ge> proots_count p {x. x \<le>b} \<and>
          even (changes_le_der b p - proots_count p {x. x \<le>b})"
proof -
  define ps where "ps=pders p"
  obtain lb where lb_root:"\<forall>p\<in>set ps. \<forall>x. poly p x = 0 \<longrightarrow> x > lb"
    and lb_sgn:"\<forall>x\<le>lb. \<forall>p\<in>set ps. sgn (poly p x) = sgn_neg_inf p"
    and "lb < b"
    using root_list_lb[of ps b] set_pders_nzero[OF \<open>p\<noteq>0\<close>,folded ps_def] by blast
  have "proots_count p {x. x \<le>b} = proots_count p {x. lb< x \<and> x \<le> b}"
  proof -
    have "p\<in>set ps" unfolding ps_def by (simp add: assms pders.simps)
    then have "proots_within p {x. x \<le>b} = proots_within p {x. lb< x \<and> x\<le>b}"
      using lb_root by fastforce
    then show ?thesis unfolding proots_count_def by auto
  qed
  moreover have "changes_le_der b p = changes_itv_der lb b p"
  proof -
    have "map (sgn \<circ> (\<lambda>p. poly p lb)) ps = map sgn_neg_inf ps"
      using lb_sgn[THEN spec,of lb,simplified]
      by (metis (mono_tags, lifting) comp_def list.map_cong0)
    hence "changes_poly_at ps lb=changes_poly_neg_inf ps"
      unfolding changes_poly_neg_inf_def changes_poly_at_def
      by (subst changes_map_sgn_eq,metis map_map)
    then have "changes_poly_at ps lb=degree p" unfolding ps_def by simp
    thus ?thesis unfolding changes_le_der_def changes_itv_der_def ps_def
      by (simp add:Let_def)
  qed
  moreover have "proots_count p {x. lb < x \<and> x \<le> b} \<le> changes_itv_der lb b p \<and>
      even (changes_itv_der lb b p - proots_count p {x. lb < x \<and> x \<le> b})"
    using budan_fourier_interval[OF \<open>lb<b\<close> \<open>p\<noteq>0\<close>] .
  ultimately show ?thesis by auto
qed

subsection \<open>Count exactly when all roots are real\<close>

definition all_roots_real:: "real poly \<Rightarrow> bool " where
  "all_roots_real p = (\<forall>r\<in>proots (map_poly of_real p). Im r=0)"

lemma all_roots_real_mult[simp]:
  "all_roots_real (p*q) \<longleftrightarrow> all_roots_real p \<and> all_roots_real q"
  unfolding all_roots_real_def by auto

lemma all_roots_real_const_iff:
  assumes all_real:"all_roots_real p"
  shows "degree p\<noteq>0 \<longleftrightarrow> (\<exists>x. poly p x=0)"
proof
  assume "degree p \<noteq> 0"
  moreover have "degree p=0" when "\<forall>x. poly p x\<noteq>0"
  proof -
    define pp where "pp=map_poly complex_of_real p"
    have "\<forall>x. poly pp x\<noteq>0"
    proof (rule ccontr)
      assume "\<not> (\<forall>x. poly pp x \<noteq> 0)"
      then obtain x where "poly pp x=0" by auto
      moreover have "Im x=0"
        using all_real[unfolded all_roots_real_def, rule_format,of x,folded pp_def] \<open>poly pp x=0\<close>
        by auto
      ultimately have "poly pp (of_real (Re x)) = 0"
        by (simp add: complex_is_Real_iff)
      then have "poly p (Re x) = 0"
        unfolding pp_def
        by (metis Re_complex_of_real of_real_poly_map_poly zero_complex.simps(1))
      then show False using that by simp
    qed
    then obtain a where "pp=[:of_real a:]" "a\<noteq>0"
      by (metis \<open>degree p \<noteq> 0\<close> constant_degree degree_map_poly
            fundamental_theorem_of_algebra of_real_eq_0_iff pp_def)
    then have "p=[:a:]" unfolding pp_def
      by (metis map_poly_0 map_poly_pCons of_real_0 of_real_poly_eq_iff)
    then show ?thesis by auto
  qed
  ultimately show "\<exists>x. poly p x = 0" by auto
next
  assume "\<exists>x. poly p x = 0"
  then show "degree p \<noteq> 0"
    by (metis UNIV_I all_roots_real_def assms degree_pCons_eq_if
        imaginary_unit.sel(2) map_poly_0 nat.simps(3) order_root pCons_eq_0_iff
        proots_within_iff synthetic_div_eq_0_iff synthetic_div_pCons zero_neq_one)
qed

lemma all_roots_real_degree:
  assumes "all_roots_real p"
  shows "proots_count p UNIV =degree p" using assms
proof (induct p rule:poly_root_induct_alt)
  case 0
  then have False using imaginary_unit.sel(2) unfolding all_roots_real_def by auto
  then show ?case by simp
next
  case (no_proots p)
  from all_roots_real_const_iff[OF this(2)] this(1)
  have "degree p=0" by auto
  then obtain a where "p=[:a:]" "a\<noteq>0"
    by (metis degree_eq_zeroE no_proots.hyps poly_const_conv)
  then have "proots p={}" by auto
  then show ?case using \<open>p=[:a:]\<close> by (simp add:proots_count_def)
next
  case (root a p)
  define a1 where "a1=[:- a, 1:]"
  have "p\<noteq>0" using root.prems
    apply auto
    using imaginary_unit.sel(2) unfolding all_roots_real_def by auto
  have "a1\<noteq>0" unfolding a1_def by auto

  have "proots_count (a1 * p) UNIV = proots_count a1 UNIV + proots_count p UNIV"
    using \<open>p\<noteq>0\<close> \<open>a1\<noteq>0\<close> by (subst proots_count_times,auto)
  also have "... = 1 + degree p"
  proof -
    have "proots_count a1 UNIV = 1" unfolding a1_def by (simp add: proots_count_pCons_1_iff)
    moreover have hyps:"proots_count p UNIV = degree p"
      apply (rule root.hyps)
      using root.prems[folded a1_def] unfolding all_roots_real_def by auto
    ultimately show ?thesis by auto
  qed
  also have "... = degree (a1*p)"
    apply (subst degree_mult_eq)
    using \<open>a1\<noteq>0\<close> \<open>p\<noteq>0\<close> unfolding a1_def by auto
  finally show ?case unfolding a1_def .
qed

lemma all_real_roots_mobius:
  fixes a b::real
  assumes "all_roots_real p" and "a<b"
  shows "all_roots_real (fcompose p [:a,b:] [:1,1:])" using assms(1)
proof (induct p rule:poly_root_induct_alt)
  case 0
  then show ?case by simp
next
  case (no_proots p)
  from all_roots_real_const_iff[OF this(2)] this(1)
  have "degree p=0" by auto
  then obtain a where "p=[:a:]" "a\<noteq>0"
    by (metis degree_eq_zeroE no_proots.hyps poly_const_conv)
  then show ?case by (auto simp add:all_roots_real_def)
next
  case (root x p)
  define x1 where "x1=[:- x, 1:]"
  define fx where "fx=fcompose x1 [:a, b:] [:1, 1:]"

  have "all_roots_real fx"
  proof (cases "x=b")
    case True
    then have "fx = [:a-x:]" "a\<noteq>x"
      subgoal unfolding fx_def by (simp add:fcompose_def smult_add_right x1_def)
      subgoal using \<open>a<b\<close> True by auto
      done
    then have "proots (map_poly complex_of_real fx) = {}"
      by auto
    then show ?thesis unfolding all_roots_real_def by auto
  next
    case False
    then have "fx = [:a-x,b-x:]"
      unfolding fx_def by (simp add:fcompose_def smult_add_right x1_def)
    then have "proots (map_poly complex_of_real fx) = {of_real ((x-a)/(b-x))}"
      using False by (auto simp add:field_simps)
    then show ?thesis unfolding all_roots_real_def by auto
  qed
  moreover have "all_roots_real (fcompose p [:a, b:] [:1, 1:])"
    using root[folded x1_def] all_roots_real_mult by auto
  ultimately show ?case
    apply (fold x1_def)
    by (auto simp add:fcompose_mult fx_def)
qed

text \<open>If all roots are real, we can use the
      Budan-Fourier theorem to EXACTLY count the number of real roots.\<close>
corollary budan_fourier_real:
  assumes "p\<noteq>0"
  assumes "all_roots_real p"
  shows "proots_count p {x. x \<le>a} = changes_le_der a p"
        "a<b \<Longrightarrow> proots_count p {x. a <x \<and> x \<le>b} = changes_itv_der a b p"
        "proots_count p {x. b <x} = changes_gt_der b p"
proof -
  have *:"proots_count p {x. x \<le>a} = changes_le_der a p
        \<and> proots_count p {x. a <x \<and> x \<le>b} = changes_itv_der a b p
        \<and> proots_count p {x. b <x} = changes_gt_der b p"
    when "a<b" for a b
  proof -
    define c1 c2 c3 where
      "c1=changes_le_der a p - proots_count p {x. x \<le>a}" and
      "c2=changes_itv_der a b p - proots_count p {x. a <x \<and> x \<le>b}" and
      "c3=changes_gt_der b p - proots_count p {x. b <x}"

    have "c1\<ge>0" "c2\<ge>0" "c3\<ge>0"
      using budan_fourier_interval[OF \<open>a<b\<close> \<open>p\<noteq>0\<close>] budan_fourier_gt[OF \<open>p\<noteq>0\<close>,of b]
          budan_fourier_le[OF \<open>p\<noteq>0\<close>,of a]
      unfolding c1_def c2_def c3_def by auto
    moreover have "c1+c2+c3=0"
    proof -
      have proots_deg:"proots_count p UNIV =degree p"
        using all_roots_real_degree[OF \<open>all_roots_real p\<close>] .
      have "changes_le_der a p + changes_itv_der a b p + changes_gt_der b p = degree p"
        unfolding changes_le_der_def changes_itv_der_def changes_gt_der_def
        by (auto simp add:Let_def)
      moreover have "proots_count p {x. x \<le>a} + proots_count p {x. a <x \<and> x \<le>b}
          + proots_count p {x. b <x} = degree p"
        using \<open>p\<noteq>0\<close> \<open>a<b\<close>
        apply (subst proots_count_union_disjoint[symmetric],auto)+
        apply (subst proots_deg[symmetric])
        by (auto intro!:arg_cong2[where f=proots_count])
      ultimately show ?thesis unfolding c1_def c2_def c3_def
        by (auto simp add:algebra_simps)
    qed
    ultimately have "c1 =0 \<and> c2=0 \<and> c3=0" by auto
    then show ?thesis unfolding c1_def c2_def c3_def by auto
  qed
  show "proots_count p {x. x \<le>a} = changes_le_der a p" using *[of a "a+1"] by auto
  show "proots_count p {x. a <x \<and> x \<le>b} = changes_itv_der a b p" when "a<b"
    using *[OF that] by auto
  show "proots_count p {x. b <x} = changes_gt_der b p"
    using *[of "b-1" b] by auto
qed

text \<open>Similarly, Descartes' rule of sign counts exactly when all roots are real.\<close>
corollary descartes_sign_real:
  fixes p::"real poly" and a b::real
  assumes "p\<noteq>0"
  assumes "all_roots_real p"
  shows "proots_count p {x. 0 < x} = changes (coeffs p)"
  using budan_fourier_real(3)[OF \<open>p\<noteq>0\<close> \<open>all_roots_real p\<close>]
  unfolding changes_gt_der_def by (simp add:changes_poly_at_pders_0)

end


section\<open>Presentation of All Variants as Studied in \<^cite>\<open>"C85"\<close> \label{sec:all}\<close>

subsection\<open>Preliminaries: Modal Ultrafilter (Fig.~2 in \<^cite>\<open>"C85"\<close>)\<close>

theory MFilter imports HOML
begin
text\<open>Some abbreviations for auxiliary operations.\<close>
abbreviation a::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("_\<^bold>\<in>_") where "x\<^bold>\<in>S \<equiv> S x"
abbreviation b::\<gamma> ("\<^bold>\<emptyset>") where "\<^bold>\<emptyset> \<equiv> \<lambda>x. \<^bold>\<bottom>"
abbreviation c::\<gamma> ("\<^bold>U") where "\<^bold>U \<equiv> \<lambda>x. \<^bold>\<top>"
abbreviation d::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<sigma>" ("_\<^bold>\<subseteq>_") where "\<phi>\<^bold>\<subseteq>\<psi> \<equiv> \<^bold>\<forall>x.((\<phi> x) \<^bold>\<rightarrow> (\<psi> x))"
abbreviation e::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<gamma>" ("_\<^bold>\<sqinter>_") where "\<phi>\<^bold>\<sqinter>\<psi> \<equiv> \<lambda>x.((\<phi> x) \<^bold>\<and> (\<psi> x))"
abbreviation f::"\<gamma>\<Rightarrow>\<gamma>" ("\<inverse>_") where "\<inverse>\<psi> \<equiv> \<lambda>x. \<^bold>\<not>(\<psi> x)"

text\<open>Definition of modal filter.\<close>
abbreviation g::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("Filter")
 where "Filter \<Phi> \<equiv> (((\<^bold>U\<^bold>\<in>\<Phi>) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<Phi>))
         \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>. (((\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<and> (\<phi>\<^bold>\<subseteq>\<psi>)) \<^bold>\<rightarrow> (\<psi>\<^bold>\<in>\<Phi>))))
         \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>. (((\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<and> (\<psi>\<^bold>\<in>\<Phi>)) \<^bold>\<rightarrow> ((\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<Phi>)))"

text\<open>Definition of modal ultrafilter .\<close>
abbreviation h::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("UFilter") where
 "UFilter \<Phi> \<equiv> (Filter \<Phi>)\<^bold>\<and>(\<^bold>\<forall>\<phi>.((\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<or> ((\<inverse>\<phi>)\<^bold>\<in>\<Phi>)))"

text\<open>Modal filter and modal ultrafilter are consistent.\<close>
lemma "\<lfloor>\<^bold>\<forall>\<Phi> \<phi>.((UFilter \<Phi>) \<^bold>\<rightarrow> \<^bold>\<not>((\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<and> ((\<inverse>\<phi>)\<^bold>\<in>\<Phi>)))\<rfloor>" by force
end


section \<open>Selected Simplified Ontological Argument \label{sec:selected}\<close>

theory SimplifiedOntologicalArgument imports
  HOML
begin
text \<open>Positive properties:\<close>
consts posProp::"\<gamma>\<Rightarrow>\<sigma>" ("\<P>")

text \<open>An entity x is God-like if it possesses all positive properties.\<close>
definition G ("\<G>") where "\<G>(x) \<equiv> \<^bold>\<forall>\<Phi>.(\<P>(\<Phi>) \<^bold>\<rightarrow> \<Phi>(x))"

text \<open>The axiom's of the simplified variant are presented next; these axioms are further motivated in \<^cite>\<open>"C85" and "J52"\<close>).\<close>
text \<open>Self-difference is not a positive property (possible alternative:
      the empty property is not a positive property).\<close>
axiomatization where CORO1: "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>"
text \<open>A property entailed by a positive property is positive.\<close>
axiomatization where CORO2: "\<lfloor>\<^bold>\<forall>\<Phi> \<Psi>. \<P>(\<Phi>) \<^bold>\<and> (\<^bold>\<forall>x. \<Phi>(x) \<^bold>\<rightarrow> \<Psi>(x)) \<^bold>\<rightarrow> \<P>(\<Psi>)\<rfloor>"
text \<open>Being Godlike is a positive property.\<close>
axiomatization where AXIOM3: "\<lfloor>\<P> \<G>\<rfloor>"

subsection\<open>Verifying the Selected Simplified Ontological Argument (version 1)\<close>

text \<open>The existence of a non-exemplified positive property implies that self-difference
      (or, alternatively, the empty property) is a positive property.\<close>
lemma LEMMA1: "\<lfloor>(\<^bold>\<exists>\<Phi>.(\<P>(\<Phi>) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<exists>x. \<Phi>(x)))) \<^bold>\<rightarrow> \<P>(\<lambda>x.(x\<^bold>\<noteq>x))\<rfloor>"
  using CORO2 by meson
text \<open>A non-exemplified positive property does not exist.\<close>
lemma LEMMA2: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>\<Phi>.(\<P>(\<Phi>) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<exists>x. \<Phi>(x))))\<rfloor>"
  using CORO1 LEMMA1 by blast
text \<open>Positive properties are exemplified.\<close>
lemma LEMMA3: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<P>(\<Phi>) \<^bold>\<rightarrow> (\<^bold>\<exists>x. \<Phi>(x)))\<rfloor>"
  using LEMMA2 by blast
text \<open>There exists a God-like entity.\<close>
theorem THEOREM3': "\<lfloor>\<^bold>\<exists>x. \<G>(x)\<rfloor>"
  using AXIOM3 LEMMA3 by auto
text \<open>Necessarily, there exists a God-like entity.\<close>
theorem THEOREM3: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>x. \<G>(x))\<rfloor>"
  using THEOREM3' by simp
text \<open>However, the possible existence of Godlike entity is not implied.\<close>
theorem CORO: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>x. \<G>(x))\<rfloor>"
  nitpick oops (*Countermodel*)

subsection\<open>Verifying the Selected Simplified Ontological Argument (version 2)\<close>

text \<open>We switch to logic T.\<close>
axiomatization where T: "\<lfloor>\<^bold>\<forall>\<phi>. \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<phi>\<rfloor>"
lemma T': "\<lfloor>\<^bold>\<forall>\<phi>. \<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<phi>\<rfloor>" using T by metis
text \<open>Positive properties are possibly exemplified.\<close>
theorem THEOREM1: "\<lfloor>\<^bold>\<forall>\<Phi>. \<P>(\<Phi>) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>x. \<Phi>(x))\<rfloor>"
  using CORO1 CORO2 T' by metis
text \<open>Possibly there exists a God-like entity.\<close>
theorem CORO: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>x. \<G>(x))\<rfloor>"
  using AXIOM3 THEOREM1 by auto
text \<open>The possible existence of a God-like entity impplies the necessary  existence of a God-like entity.\<close>
theorem THEOREM2: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>x. \<G>(x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>x. \<G>(x))\<rfloor>"
  using AXIOM3 CORO1 CORO2 by metis
text \<open>Necessarily, there exists a God-like entity.\<close>
theorem THEO3: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>x. \<G>(x))\<rfloor>"
  using CORO THEOREM2 by blast
text \<open>There exists a God-like entity.\<close>
theorem THEO3': "\<lfloor>\<^bold>\<exists>x. \<G>(x)\<rfloor>"
  using T THEO3 by metis

text \<open>Modal collapse is not implied; nitpick reports a countermodel.\<close>

lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>. \<Phi> \<^bold>\<rightarrow> \<^bold>\<box>\<Phi>\<rfloor>" nitpick oops

text \<open>Consistency of the theory; nitpick reports a model.\<close>
lemma True nitpick[satisfy] oops (*Model found*)
end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory IsPrime
imports
  "../../AutoCorres"
  "~~/src/HOL/Number_Theory/Number_Theory"
begin

(* Parse the input file. *)
install_C_file "is_prime.c"

(* Abstract the input file. *)
autocorres [ ts_rules = nondet, unsigned_word_abs = is_prime_linear is_prime ] "is_prime.c"

context is_prime begin

definition
  "partial_prime p (n :: nat) \<equiv>
        (1 < p \<and> (\<forall>i \<in> {2 ..< min p n}. \<not> i dvd p))"

lemma partial_prime_ge [simp]:
     "\<lbrakk> p' \<ge> p \<rbrakk> \<Longrightarrow> partial_prime p p' = prime p"
  by (clarsimp simp: partial_prime_def prime_nat_iff' min_def)

lemma divide_self_plus_one [simp]: "(x dvd Suc x) = (x = 1)"
  apply (case_tac "x = 0", simp)
  apply (case_tac "x = 1", simp)
  apply (clarsimp simp: dvd_def)
  apply (case_tac "k = 0", simp)
  apply (case_tac "k = 1", simp)
  apply (subgoal_tac "x * 2 \<le> x * k")
   apply (subgoal_tac "Suc x < x * 2")
    apply simp
   apply clarsimp
  apply clarsimp
  done

lemma partial_prime_Suc [simp]:
  "partial_prime p (Suc n)
              = (partial_prime p n \<and> (1 < n \<and> Suc n < p \<longrightarrow> \<not> n dvd p))"
   apply (clarsimp simp: partial_prime_def min_def atLeastLessThanSuc not_le)
  apply (case_tac "p = Suc n")
   apply (clarsimp simp: atLeastLessThanSuc)
  apply fastforce
  done

lemma mod_to_dvd:
   "(n mod i \<noteq> 0) = (\<not> i dvd (n :: nat))"
  by (clarsimp simp: dvd_eq_mod_eq_0)

lemma prime_of_product [simp]: "prime ((a::nat) * b) = ((a = 1 \<and> prime b) \<or> (prime a \<and> b = 1))"
  using prime_product by force

lemma partial_prime_2 [simp]: "(partial_prime a 2) = (a > 1)"
  by (clarsimp simp: partial_prime_def)

definition [simp]:
  "is_prime_linear_inv n i s \<equiv> (1 < i \<and> 1 < n \<and> i \<le> n \<and> partial_prime n i)"

theorem is_prime_correct:
    "\<lbrace> \<lambda>s. n \<le> UINT_MAX \<rbrace> is_prime_linear' n \<lbrace> \<lambda>r s. (r \<noteq> 0) \<longleftrightarrow> prime n \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (case_tac "n = 0")
   apply (clarsimp simp: is_prime_linear'_def, wp, simp)[1]
  apply (case_tac "n = 1")
   apply (clarsimp simp: is_prime_linear'_def, wp, simp)[1]
  apply (unfold is_prime_linear'_def)
  apply (subst whileLoopE_add_inv [
      where I="\<lambda>r s. is_prime_linear_inv n r s"
                  and M="(\<lambda>(r, s). n - r)"])
  apply (wp, auto simp: mod_to_dvd [simplified])
  done

lemma not_prime:
    "\<lbrakk> \<not> prime (a :: nat); a > 1 \<rbrakk> \<Longrightarrow> \<exists>x y. x * y = a \<and> 1 < x \<and> 1 < y \<and> x * x \<le> a"
  apply (clarsimp simp: prime_nat_iff dvd_def)
  apply (case_tac "m > k")
   apply (metis Suc_lessD Suc_lessI less_imp_le_nat mult.commute nat_0_less_mult_iff nat_mult_less_cancel_disj)
  apply fastforce
  done

lemma sqrt_prime:
  "\<lbrakk> a * a > n; \<forall>x<a. (x dvd n) = (x = Suc 0 \<or> x = n); 1 < n \<rbrakk> \<Longrightarrow> prime n"
  apply (rule ccontr)
  apply (drule not_prime)
   apply clarsimp
  apply (metis dvd_triv_right less_le_trans mult.commute mult_le_cancel2
           One_nat_def less_eq_nat.simps(1) less_not_refl2
           mult_eq_self_implies_10 not_less)
  done

lemma partial_prime_sqr:
     "\<lbrakk> n * n > p \<rbrakk> \<Longrightarrow> partial_prime p n = prime p"
  apply (case_tac "n \<ge> p")
   apply (clarsimp simp: partial_prime_ge)
  apply (case_tac "partial_prime p n")
   apply clarsimp
   apply (erule sqrt_prime)
    apply (clarsimp simp: partial_prime_def)
    apply (case_tac "x = 0", simp)
    apply (case_tac "x = 1", simp)
    apply (frule_tac x=x in bspec)
     apply (clarsimp simp: min_def)
    apply clarsimp
   apply (clarsimp simp: not_le partial_prime_def)
  apply (case_tac "p = 0", simp)
  apply (case_tac "p = 1", simp)
  apply (auto simp: not_le partial_prime_def min_def prime_nat_iff')
  done

definition "SQRT_UINT_MAX \<equiv> 65536 :: nat"

lemma uint_max_factor [simp]:
  "UINT_MAX = SQRT_UINT_MAX * SQRT_UINT_MAX - 1"
  by (clarsimp simp: UINT_MAX_def SQRT_UINT_MAX_def)

lemma prime_dvd:
    "\<lbrakk> prime (p::nat) \<rbrakk> \<Longrightarrow> (r dvd p) = (r = 1 \<or> r = p)"
  by (fastforce simp: prime_nat_iff)

definition is_prime_inv
  where [simp]: "is_prime_inv n i s \<equiv> (1 < i \<and> i \<le> n \<and> i \<le> SQRT_UINT_MAX \<and> i * i \<le> SQRT_UINT_MAX * SQRT_UINT_MAX \<and> partial_prime n i)"

lemma nat_leE: "\<lbrakk> (a::nat) \<le> b; a < b \<Longrightarrow> R; a = b \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  apply atomize_elim
    apply clarsimp
  done

lemma sqr_less_mono [simp]:
    "((i::nat) * i < j * j) = (i < j)"
  by (metis (full_types) le0 less_not_refl3 linorder_neqE_nat
        mult_strict_mono' order.strict_trans)

declare mult_le_mono [intro]

lemma sqr_le_sqr_minus_1 [simp]:
    "\<lbrakk> b \<noteq> 0 \<rbrakk> \<Longrightarrow> (a * a \<le> b * b - Suc 0) = (a < b)"
  by (metis gr0I is_prime.sqr_less_mono nat_0_less_mult_iff nat_le_Suc_less)

theorem is_prime_faster_correct:
  notes times_nat.simps(2) [simp del] mult_Suc_right [simp del]
  shows "\<lbrace> \<lambda>s. n \<le> UINT_MAX \<rbrace> is_prime' n \<lbrace> \<lambda>r s. (r \<noteq> 0) \<longleftrightarrow> prime n \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (case_tac "n = 0")
   apply (clarsimp simp: is_prime'_def, wp, simp)[1]
  apply (case_tac "n = 1")
   apply (clarsimp simp: is_prime'_def, wp, simp)[1]
  apply (unfold is_prime'_def dvd_eq_mod_eq_0 [symmetric] SQRT_UINT_MAX_def [symmetric])
  apply (subst whileLoopE_add_inv [
      where I="\<lambda>r s. is_prime_inv n r s"
      and M="(\<lambda>(r, s). (Suc n) * (Suc n) - r * r)"])
   apply wp
    apply (fastforce elim: nat_leE simp: partial_prime_sqr prime_dvd)+
  apply (clarsimp simp: SQRT_UINT_MAX_def)
  done

end

end