theory Ex4_7
  imports Main "~~/src/HOL/Library/Code_Target_Nat" "../Chapter 3/ASMOrig"
begin

section "Exercise 4.6"

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
  empty: "ok n [] n" |
  loadi: "ok n\<^sub>b is n\<^sub>a \<Longrightarrow> ok n\<^sub>b (is @ [LOADI _]) (n\<^sub>a + 1)" |
  load: "ok n\<^sub>b is n\<^sub>a \<Longrightarrow> ok n\<^sub>b (is @ [LOAD _]) (n\<^sub>a + 1)" |
  add: "ok n\<^sub>b is n\<^sub>a \<Longrightarrow> n\<^sub>a \<ge> 2 \<Longrightarrow> ok n\<^sub>b (is @ [ADD]) (n\<^sub>a - 1)"

theorem ok_computes_stack_size:
  "\<lbrakk>ok n instructions n'; length stack = n \<rbrakk> \<Longrightarrow> length (exec instructions state stack) = n'"
  apply(induction rule: ok.induct)
  by(simp_all)

lemma ok_append: "\<lbrakk>ok n\<^sub>a\<^sub>0 is1 n\<^sub>a; ok n\<^sub>b is0 n\<^sub>a\<^sub>0\<rbrakk> \<Longrightarrow> ok n\<^sub>b (is0 @ is1) n\<^sub>a"
  apply(induction (* arbitrary: n\<^sub>a Is bad here *) rule: ok.induct)
     apply simp
  using ok.loadi apply fastforce
  using ok.load apply fastforce
  using ok.add by fastforce

theorem comp_cant_underflow: "ok n (comp expr) (n+1)"
  apply(induction expr arbitrary: n)
  using empty loadi apply fastforce
  using empty load apply fastforce
  using add ok_append by fastforce

lemma ok_for_larger:"ok nb0 is na0 \<Longrightarrow> nb1 \<ge> nb0 \<Longrightarrow> ok nb1 is (na0 + (nb1 - nb0))"
  apply(induction rule: ok.induct)
  using empty apply simp
  using loadi apply fastforce
  using load apply simp
  using add by fastforce

lemma test0_1:"ok 0 [LOADI 9] 1"
  using empty loadi by fastforce

lemma "ok 1 [LOADI 9] 2"
  using empty loadi
  by (metis append_Nil nat_1_add_1)

lemma "ok n [LOADI 9] (n+1)"
  using empty loadi by fastforce

lemma test0_2:"ok 0 [LOADI 9, LOADI 9] 2"
  using test0_1 loadi
  by (metis Cons_eq_append_conv one_add_one)

lemma test1_3:"ok 1 [LOADI 9, LOADI 9] 3"
  using test0_2 ok_for_larger
  by (metis diff_diff_cancel diff_is_0_eq le_numeral_extra(4) nat_1_add_1 numeral_Bit1 numerals(1) zero_le_one)

lemma "ok 2 [ADD] 1"
proof -
  have "ok 2 [] 2"
    using empty by metis
  hence "ok 2 [ADD] (2-1)" using add by fastforce
  thus ?thesis by simp
qed

lemma add2_1:"ok 2 [ADD, LOADI 1] 2"
proof -
  have "ok 2 [] 2"
    using empty by metis
  hence "ok 2 [ADD] 1" using add by fastforce
  hence "ok 2 [ADD, LOADI 1] (1+1)"
    using loadi
    by fastforce
  thus ?thesis
    by (metis one_add_one)
qed

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_45
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x2) (Z) = False"
| "y (S x2) (S y22) = y x2 y22"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = x (y z z2) (elem z xs)"

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

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

theorem property0 :
  "elem z (insert z y2)"
  oops

end


theory Misc_Analysis
imports Limits
begin

(* This could fit into Real.thy *)

lemma real_infinite_interval:
  assumes "a < (b::real)"
  shows "\<not>finite {a<..<b}"
proof
  assume "finite {a<..<b}"
  {
    fix S assume fin: "finite (S::real set)" and "\<exists>l u. l < u \<and> S = {l<..<u}"
    from this(2) have "\<not>finite S"
    proof (induction rule: finite_psubset_induct[OF fin])
      case (goal1 S)
        then obtain l u where "l < u" and [simp]: "S = {l<..<u}" by blast
        def S' \<equiv> "{l<..<l + (u-l)/3}"
        have "(l+u)/2 \<in> S" "(l+u)/2 \<notin> S'" unfolding S'_def using `l < u`
            by (simp_all add: field_simps)
        hence "S \<noteq> S'" by blast
        hence "S' \<subset> S" unfolding S'_def by (auto simp: field_simps)
        moreover have "\<exists>l' u'. l' < u' \<and> S' = {l'<..<u'}" using `l < u`
            by (rule_tac exI[of _ l], rule_tac exI[of _ "l+(u-l)/3"],
                simp add: S'_def)
        ultimately have "\<not>finite S'" by (intro goal1(2), simp_all)
        thus ?case using `S' \<subset> S` using finite_subset by blast
    qed
  }
  from this[OF `finite {a<..<b}`] have "\<not> finite {a<..<b}" using assms by blast
  thus False using `finite {a<..<b}` by contradiction
qed

lemma real_interval_card_eq:
  "card {a<..<b::real} = 0"
  "card {a<..b::real} = 0"
  "card {a..<b::real} = 0"
  "card {a..b::real} = (if a = b then 1 else 0)"
proof-
  show "card {a<..<b} = 0"
      by (cases "a < b", simp_all add: real_infinite_interval)
  have "{a<..<b} \<subseteq> {a<..b}" by auto
  from finite_subset[OF this] show "card {a<..b::real} = 0"
      by (cases "a < b", auto simp: real_infinite_interval card_eq_0_iff)
  have "{a<..<b} \<subseteq> {a..<b}" by auto
  from finite_subset[OF this] show "card {a..<b::real} = 0"
      by (cases "a < b", auto simp: real_infinite_interval card_eq_0_iff)
  have "{a<..<b} \<subseteq> {a..b}" by auto
  from finite_subset[OF this]
      show "card {a..b::real} = (if a = b then 1 else 0)"
      by (cases "a < b", auto simp: real_infinite_interval card_eq_0_iff)
qed

(* This might fit into Limits.thy *)

lemma x_pow_n_limit_at_top[intro]:
  assumes "n \<ge> 1"
  shows "LIM (x::real) at_top. x^n :> at_top"
proof (simp only: filterlim_at_top eventually_at_top_linorder, clarify)
  fix b :: real
  let ?x\<^sub>0 = "max b 1"
  show "\<exists>x\<^sub>0. \<forall>x\<ge>x\<^sub>0. x ^ n \<ge> b"
  proof (rule exI[of _ ?x\<^sub>0], clarify)
    fix x assume "x \<ge> max b 1"
    have "b \<le> ?x\<^sub>0" by simp
    also from power_increasing[OF assms, of ?x\<^sub>0]
        have "... \<le> ?x\<^sub>0 ^ n" by simp
    also from power_mono[OF `x \<ge> ?x\<^sub>0`] have "... \<le> x ^ n" by simp
    finally show "b \<le> x ^ n" .
  qed
qed

lemma filterlim_pow_at_top:
  assumes "LIM (x::real) F. f x :> at_top" "n \<ge> 1"
  shows "LIM (x::real) F. (f x)^n :: real :> at_top"
proof-
  from assms
      have "filtermap f F \<le> at_top"
      by (simp add: filterlim_def)
  from filtermap_mono[OF this, of "\<lambda>x. x^n"]
      have "filtermap (\<lambda>x. (f x)^n) F \<le> filtermap (\<lambda>x. x^n) at_top"
      by (simp add: filtermap_filtermap)
  also from x_pow_n_limit_at_top[OF `n \<ge> 1`]
      have "... \<le> at_top" by (simp add: filterlim_def)
  finally show ?thesis by (simp add: filterlim_def)
qed

lemma x_pow_n_limit_at_bot[intro]:
  assumes "n \<ge> 1"
  shows "even n \<Longrightarrow> LIM (x::real) at_bot. x^n :> at_top"
    and "odd n \<Longrightarrow> LIM (x::real) at_bot. x^n :> at_bot"
proof-
  assume "even n"
  show "LIM (x::real) at_bot. x^n :> at_top"
  proof (subst filterlim_cong, rule refl, rule refl)
    from `even n` show "eventually (\<lambda>x::real. x^n = (-x)^n) at_bot"
        by (simp add: neg_power_if)
    show "LIM (x::real) at_bot. (-x)^n :> at_top" using assms
        by (simp add: filterlim_at_bot_mirror x_pow_n_limit_at_top)
  qed
next
  assume "odd n"
  show "LIM (x::real) at_bot. x^n :> at_bot"
  proof (subst filterlim_cong, rule refl, rule refl)
    from `odd n` show "eventually (\<lambda>x::real. x^n = -((-x)^n)) at_bot"
        by (simp add: neg_power_if)
    show "LIM (x::real) at_bot. -((-x)^n) :> at_bot" using assms
        by (simp add: filterlim_at_bot_mirror filterlim_uminus_at_bot
                      x_pow_n_limit_at_top)
  qed
qed

lemma filterlim_pow:
  assumes "LIM (x::real) F. f x :> at_top" "n \<ge> 1"
  shows "LIM (x::real) F. (f x)^n :: real :> at_top"
proof-
  from assms
      have "filtermap f F \<le> at_top"
      by (simp add: filterlim_def)
  from filtermap_mono[OF this, of "\<lambda>x. x^n"]
      have "filtermap (\<lambda>x. (f x)^n) F \<le> filtermap (\<lambda>x. x^n) at_top"
      by (simp add: filtermap_filtermap)
  also from x_pow_n_limit_at_top[OF `n \<ge> 1`]
      have "... \<le> at_top" by (simp add: filterlim_def)
  finally show ?thesis by (simp add: filterlim_def)
qed

lemma filterlim_pow_at_bot:
  fixes f :: "real \<Rightarrow> real" assumes "n \<ge> 1"
  shows "even n \<Longrightarrow> LIM x F. f x :> at_bot \<Longrightarrow>
                    LIM x F. (f x)^n :> at_top"
    and "odd n \<Longrightarrow> LIM x F. f x :> at_bot
               \<Longrightarrow> LIM x F. (f x)^n :> at_bot"
proof-
  assume "even n" "LIM x F. f x :> at_bot"
  hence "filtermap f F \<le> at_bot" by (simp add: filterlim_def)
  from filtermap_mono[OF this, of "\<lambda>x. x^n"]
      have "filtermap (\<lambda>x. (f x)^n) F \<le> filtermap (\<lambda>x. x^n) at_bot"
      by (simp add: filtermap_filtermap)
  also from x_pow_n_limit_at_bot(1)[OF `n \<ge> 1` `even n`]
      have "... \<le> at_top" by (simp add: filterlim_def)
  finally show "LIM x F. (f x)^n :> at_top" by (simp add: filterlim_def)
next
  assume "odd n" "LIM x F. f x :> at_bot"
  hence "filtermap f F \<le> at_bot" by (simp add: filterlim_def)
  from filtermap_mono[OF this, of "\<lambda>x. x^n"]
      have "filtermap (\<lambda>x. (f x)^n) F \<le> filtermap (\<lambda>x. x^n) at_bot"
      by (simp add: filtermap_filtermap)
  also from x_pow_n_limit_at_bot(2)[OF `n \<ge> 1` `odd n`]
      have "... \<le> at_bot" by (simp add: filterlim_def)
  finally show "LIM x F. (f x)^n :> at_bot" by (simp add: filterlim_def)
qed

(* This may be too specific to be of general interest *)

lemma real_nat_one_half[dest]:
  "(n::nat) = (m::nat) - 1/2 \<Longrightarrow> False"
  "(n::nat) = (m::nat) + 1/2 \<Longrightarrow> False"
proof-
  assume "(n::nat) = (m::nat) - 1/2"
  hence "2*(n - m) = 1" by linarith
  thus False by simp
next
  assume "(n::nat) = (m::nat) + 1/2"
  hence "2*(n - m) = 1" by linarith
  thus False by simp
qed

lemma natfun_eq_in_ivl:
  assumes "a \<le> b"
  assumes "\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> eventually (\<lambda>\<xi>. f \<xi> = (f x::nat)) (at x)"
  shows "f a = f b"
proof-
  have cont: "\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> isCont f x"
  proof (clarify, simp add: isCont_def, rule tendstoI, simp add: dist_real_def)
    fix \<epsilon> :: real and x :: real assume "\<epsilon> > 0" and  "a \<le> x" "x \<le> b"
    with assms have A: "eventually (\<lambda>\<xi>. f \<xi> = (f x::nat)) (at x)" by simp
    show "eventually (\<lambda>\<xi>. \<bar>real (f \<xi>) - real (f x)\<bar> < \<epsilon>) (at x)"
        by (rule eventually_mono[OF _ A], simp add: `\<epsilon> > 0`)
  qed

  {
    def y \<equiv> "f a + 1/2"
    assume "f a < f b"
    hence "f a \<le> y" "y \<le> f b" by (simp_all add: y_def)
    with IVT[OF this `a \<le> b` cont] have False by (auto simp: y_def)
  }
  moreover
  {
    def y \<equiv> "f a - 1/2"
    assume "f a > f b"
    hence "f b \<le> y" "y \<le> f a" by (simp_all add: y_def)
    with IVT2[OF this `a \<le> b` cont] have False by (auto simp: y_def)
  }
  ultimately show "f a = f b" by force
qed

end


(*
    Author:      Sebastiaan Joosten
                 René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Complex Algebraic Numbers\<close>

text \<open>Since currently there is no immediate analog of Sturm's theorem for the complex numbers,
  we implement complex algebraic numbers via their real and imaginary part.

  The major algorithm in this theory is a factorization algorithm which factors a rational
  polynomial over the complex numbers.

  For factorization of polynomials with complex algebraic coefficients, there
  is a separate AFP entry "Factor-Algebraic-Polynomial".\<close>

theory Complex_Algebraic_Numbers
imports
  Real_Roots
  Complex_Roots_Real_Poly
  Compare_Complex
  Jordan_Normal_Form.Char_Poly
  Berlekamp_Zassenhaus.Code_Abort_Gcd
  Interval_Arithmetic
begin

subsection \<open>Complex Roots\<close>

hide_const (open) UnivPoly.coeff
hide_const (open) Module.smult
hide_const (open) Coset.order

abbreviation complex_of_int_poly :: "int poly \<Rightarrow> complex poly" where
  "complex_of_int_poly \<equiv> map_poly of_int"

abbreviation complex_of_rat_poly :: "rat poly \<Rightarrow> complex poly" where
  "complex_of_rat_poly \<equiv> map_poly of_rat"

lemma poly_complex_to_real: "(poly (complex_of_int_poly p) (complex_of_real x) = 0)
  = (poly (real_of_int_poly p) x = 0)"
proof -
  have id: "of_int = complex_of_real o real_of_int" by auto
  interpret cr: semiring_hom complex_of_real by (unfold_locales, auto)
  show ?thesis unfolding id
    by (subst map_poly_map_poly[symmetric], force+)
qed

lemma represents_cnj: assumes "p represents x" shows "p represents (cnj x)"
proof -
  from assms have p: "p \<noteq> 0" and "ipoly p x = 0" by auto
  hence rt: "poly (complex_of_int_poly p) x = 0" by auto
  have "poly (complex_of_int_poly p) (cnj x) = 0"
    by (rule complex_conjugate_root[OF _ rt], subst coeffs_map_poly, auto)
  with p show ?thesis by auto
qed

definition poly_2i :: "int poly" where
  "poly_2i \<equiv> [: 4, 0, 1:]"

lemma represents_2i: "poly_2i represents (2 * \<i>)"
  unfolding represents_def poly_2i_def by simp

definition root_poly_Re :: "int poly \<Rightarrow> int poly" where
  "root_poly_Re p = cf_pos_poly (poly_mult_rat (inverse 2) (poly_add p p))"

lemma root_poly_Re_code[code]:
  "root_poly_Re p = (let fs = coeffs (poly_add p p); k = length fs
     in cf_pos_poly (poly_of_list (map (\<lambda>(fi, i). fi * 2 ^ i) (zip fs [0..<k]))))"
proof -
  have [simp]: "quotient_of (1 / 2) = (1,2)" by eval
  show ?thesis unfolding root_poly_Re_def poly_mult_rat_def poly_mult_rat_main_def Let_def by simp
qed

definition root_poly_Im :: "int poly \<Rightarrow> int poly list" where
  "root_poly_Im p = (let fs = factors_of_int_poly
    (poly_add p (poly_uminus p))
    in remdups ((if (\<exists> f \<in> set fs. coeff f 0 = 0) then [[:0,1:]] else [])) @
      [ cf_pos_poly (poly_div f poly_2i) . f \<leftarrow> fs, coeff f 0 \<noteq> 0])"

lemma represents_root_poly:
  assumes "ipoly p x = 0" and p: "p \<noteq> 0"
  shows "(root_poly_Re p) represents (Re x)"
    and "\<exists> q \<in> set (root_poly_Im p). q represents (Im x)"
proof -
  let ?Rep = "root_poly_Re p"
  let ?Imp = "root_poly_Im p"
  from assms have ap: "p represents x" by auto
  from represents_cnj[OF this] have apc: "p represents (cnj x)" .
  from represents_mult_rat[OF _ represents_add[OF ap apc], of "inverse 2"]
  have "?Rep represents (1 / 2 * (x + cnj x))" unfolding root_poly_Re_def Let_def
    by (auto simp: hom_distribs)
  also have "1 / 2 * (x + cnj x) = of_real (Re x)"
    by (simp add: complex_add_cnj)
  finally have Rep: "?Rep \<noteq> 0" and rt: "ipoly ?Rep (complex_of_real (Re x)) = 0" unfolding represents_def by auto
  from rt[unfolded poly_complex_to_real]
  have "ipoly ?Rep (Re x) = 0" .
  with Rep show "?Rep represents (Re x)" by auto
  let ?q = "poly_add p (poly_uminus p)"
  from represents_add[OF ap, of "poly_uminus p" "- cnj x"] represents_uminus[OF apc]
  have apq: "?q represents (x - cnj x)" by auto
  from factors_int_poly_represents[OF this] obtain pi where pi: "pi \<in> set (factors_of_int_poly ?q)"
    and appi: "pi represents (x - cnj x)" and irr_pi: "irreducible pi" by auto
  have id: "inverse (2 * \<i>) * (x - cnj x) = of_real (Im x)"
    apply (cases x) by (simp add: complex_split imaginary_unit.ctr legacy_Complex_simps)
  from represents_2i have 12: "poly_2i represents (2 * \<i>)" by simp
  have "\<exists> qi \<in> set ?Imp. qi represents (inverse (2 * \<i>) * (x - cnj x))"
  proof (cases "x - cnj x = 0")
    case False
    have "poly poly_2i 0 \<noteq> 0" unfolding poly_2i_def by auto
    from represents_div[OF appi 12 this]
      represents_irr_non_0[OF irr_pi appi False, unfolded poly_0_coeff_0] pi
    show ?thesis unfolding root_poly_Im_def Let_def by (auto intro: bexI[of _ "cf_pos_poly (poly_div pi poly_2i)"])
  next
    case True
    hence id2: "Im x = 0" by (simp add: complex_eq_iff)
    from appi[unfolded True represents_def] have "coeff pi 0 = 0" by (cases pi, auto)
    with pi have mem: "[:0,1:] \<in> set ?Imp" unfolding root_poly_Im_def Let_def by auto
    have "[:0,1:] represents (complex_of_real (Im x))" unfolding id2 represents_def by simp
    with mem show ?thesis unfolding id by auto
  qed
  then obtain qi where qi: "qi \<in> set ?Imp" "qi \<noteq> 0" and rt: "ipoly qi (complex_of_real (Im x)) = 0"
    unfolding id represents_def by auto
  from qi rt[unfolded poly_complex_to_real]
  show "\<exists> qi \<in> set ?Imp. qi represents (Im x)" by auto
qed

definition complex_poly :: "int poly \<Rightarrow> int poly \<Rightarrow> int poly list" where
  "complex_poly re im = (let i = [:1,0,1:]
     in factors_of_int_poly (poly_add re (poly_mult im i)))"

lemma complex_poly: assumes re: "re represents (Re x)"
   and im: "im represents (Im x)"
  shows "\<exists> f \<in> set (complex_poly re im). f represents x" "\<And> f. f \<in> set (complex_poly re im) \<Longrightarrow> poly_cond f"
proof -
  let ?p = "poly_add re (poly_mult im [:1, 0, 1:])"
  from re have re: "re represents complex_of_real (Re x)" by simp
  from im have im: "im represents complex_of_real (Im x)" by simp
  have "[:1,0,1:] represents \<i>" by auto
  from represents_add[OF re represents_mult[OF im this]]
  have "?p represents of_real (Re x) + complex_of_real (Im x) * \<i>" by simp
  also have "of_real (Re x) + complex_of_real (Im x) * \<i> = x"
    by (metis complex_eq mult.commute)
  finally have p: "?p represents x" by auto
  have "factors_of_int_poly ?p = complex_poly re im"
    unfolding complex_poly_def Let_def by simp
  from factors_of_int_poly(1)[OF this] factors_of_int_poly(2)[OF this, of x] p
  show "\<exists> f \<in> set (complex_poly re im). f represents x" "\<And> f. f \<in> set (complex_poly re im) \<Longrightarrow> poly_cond f"
    unfolding represents_def by auto
qed

lemma algebraic_complex_iff: "algebraic x = (algebraic (Re x) \<and> algebraic (Im x))"
proof
  assume "algebraic x"
  from this[unfolded algebraic_altdef_ipoly] obtain p where "ipoly p x = 0" "p \<noteq> 0" by auto
  from represents_root_poly[OF this] show "algebraic (Re x) \<and> algebraic (Im x)"
    unfolding represents_def algebraic_altdef_ipoly by auto
next
  assume "algebraic (Re x) \<and> algebraic (Im x)"
  from this[unfolded algebraic_altdef_ipoly] obtain re im where
    "re represents (Re x)" "im represents (Im x)" by blast
  from complex_poly[OF this] show "algebraic x"
    unfolding represents_def algebraic_altdef_ipoly by auto
qed

definition algebraic_complex :: "complex \<Rightarrow> bool" where
  [simp]: "algebraic_complex = algebraic"

lemma algebraic_complex_code_unfold[code_unfold]: "algebraic = algebraic_complex" by simp

lemma algebraic_complex_code[code]:
  "algebraic_complex x = (algebraic (Re x) \<and> algebraic (Im x))"
  unfolding algebraic_complex_def algebraic_complex_iff ..

text \<open>Determine complex roots of a polynomial,
   intended for polynomials of degree 3 or higher,
   for lower degree polynomials use @{const roots1} or @{const croots2}\<close>

hide_const (open) eq

primrec remdups_gen :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "remdups_gen eq [] = []"
| "remdups_gen eq (x # xs) = (if (\<exists> y \<in> set xs. eq x y) then
     remdups_gen eq xs else x # remdups_gen eq xs)"

lemma real_of_3_remdups_equal_3[simp]: "real_of_3 ` set (remdups_gen equal_3 xs) = real_of_3 ` set xs"
  by (induct xs, auto simp: equal_3)

lemma distinct_remdups_equal_3: "distinct (map real_of_3 (remdups_gen equal_3 xs))"
  by (induct xs, auto, auto simp: equal_3)

lemma real_of_3_code [code]: "real_of_3 x = real_of (Real_Alg_Quotient x)"
  by (transfer, auto)

definition "real_parts_3 p = roots_of_3 (root_poly_Re p)"

definition "pos_imaginary_parts_3 p =
  remdups_gen equal_3 (filter (\<lambda> x. sgn_3 x = 1) (concat (map roots_of_3 (root_poly_Im p))))"

lemma real_parts_3: assumes p: "p \<noteq> 0" and "ipoly p x = 0"
  shows "Re x \<in> real_of_3 ` set (real_parts_3 p)"
  unfolding real_parts_3_def using represents_root_poly(1)[OF assms(2,1)]
    roots_of_3(1) unfolding represents_def by auto

lemma distinct_real_parts_3: "distinct (map real_of_3 (real_parts_3 p))"
  unfolding real_parts_3_def using roots_of_3(2) .

lemma pos_imaginary_parts_3: assumes p: "p \<noteq> 0" and "ipoly p x = 0" and "Im x > 0"
  shows "Im x \<in> real_of_3 ` set (pos_imaginary_parts_3 p)"
proof -
  from represents_root_poly(2)[OF assms(2,1)] obtain q where
    q: "q \<in> set (root_poly_Im p)" "q represents Im x" by auto
  from roots_of_3(1)[of q] have "Im x \<in> real_of_3 ` set (roots_of_3 q)" using q
    unfolding represents_def by auto
  then obtain i3 where i3: "i3 \<in> set (roots_of_3 q)" and id: "Im x = real_of_3 i3" by auto
  from \<open>Im x > 0\<close> have "sgn (Im x) = 1" by simp
  hence sgn: "sgn_3 i3 = 1" unfolding id by (metis of_rat_eq_1_iff sgn_3)
  show ?thesis unfolding pos_imaginary_parts_3_def real_of_3_remdups_equal_3 id
    using sgn i3 q(1) by auto
qed

lemma distinct_pos_imaginary_parts_3: "distinct (map real_of_3 (pos_imaginary_parts_3 p))"
  unfolding pos_imaginary_parts_3_def by (rule distinct_remdups_equal_3)

lemma remdups_gen_subset: "set (remdups_gen eq xs) \<subseteq> set xs"
  by (induct xs, auto)

lemma positive_pos_imaginary_parts_3: assumes "x \<in> set (pos_imaginary_parts_3 p)"
  shows "0 < real_of_3 x"
proof -
  from subsetD[OF remdups_gen_subset assms[unfolded pos_imaginary_parts_3_def]]
  have "sgn_3 x = 1" by auto
  thus ?thesis using sgn_3[of x] by (simp add: sgn_1_pos)
qed

definition "pair_to_complex ri \<equiv> case ri of (r,i) \<Rightarrow> Complex (real_of_3 r) (real_of_3 i)"

fun get_itvl_2 :: "real_alg_2 \<Rightarrow> real interval" where
  "get_itvl_2 (Irrational n (p,l,r)) = Interval (of_rat l) (of_rat r)"
| "get_itvl_2 (Rational r) = (let rr = of_rat r in Interval rr rr)"

lemma get_bounds_2: assumes "invariant_2 x"
  shows "real_of_2 x \<in>\<^sub>i get_itvl_2 x"
proof (cases x)
  case (Irrational n plr)
  with assms obtain p l r where plr: "plr = (p,l,r)" by (cases plr, auto)
  from assms Irrational plr have inv1: "invariant_1 (p,l,r)"
    and id: "real_of_2 x = real_of_1 (p,l,r)" by auto
  show ?thesis unfolding id using invariant_1D(1)[OF inv1] by (auto simp: plr Irrational)
qed (insert assms, auto simp: Let_def)

lift_definition get_itvl_3 :: "real_alg_3 \<Rightarrow> real interval" is get_itvl_2 .

lemma get_itvl_3: "real_of_3 x \<in>\<^sub>i get_itvl_3 x"
  by (transfer, insert get_bounds_2, auto)

fun tighten_bounds_2 :: "real_alg_2 \<Rightarrow> real_alg_2" where
  "tighten_bounds_2 (Irrational n (p,l,r)) = (case tighten_poly_bounds p l r (sgn (ipoly p r))
    of (l',r',_) \<Rightarrow> Irrational n (p,l',r'))"
| "tighten_bounds_2 (Rational r) = Rational r"

lemma tighten_bounds_2: assumes inv: "invariant_2 x"
  shows "real_of_2 (tighten_bounds_2 x) = real_of_2 x" "invariant_2 (tighten_bounds_2 x)"
  "get_itvl_2 x = Interval l r \<Longrightarrow>
   get_itvl_2 (tighten_bounds_2 x) = Interval l' r' \<Longrightarrow> r' - l' = (r-l) / 2"
proof (atomize(full), cases x)
  case (Irrational n plr)
  show "real_of_2 (tighten_bounds_2 x) = real_of_2 x \<and>
       invariant_2 (tighten_bounds_2 x) \<and>
       (get_itvl_2 x = Interval l r \<longrightarrow>
        get_itvl_2 (tighten_bounds_2 x) = Interval l' r' \<longrightarrow> r' - l' = (r - l) / 2)"
  proof -
    obtain p l r where plr: "plr = (p,l,r)" by (cases plr, auto)
    let ?tb = "tighten_poly_bounds p l r (sgn (ipoly p r))"
    obtain l' r' sr' where tb: "?tb = (l',r',sr')" by (cases ?tb, auto)
    have id: "tighten_bounds_2 x = Irrational n (p,l',r')" unfolding Irrational plr
      using tb by auto
    from inv[unfolded Irrational plr] have inv: "invariant_1_2 (p, l, r)"
      "n = card {y. y \<le> real_of_1 (p, l, r) \<and> ipoly p y = 0}" by auto
    have rof: "real_of_2 x = real_of_1 (p, l, r)"
      "real_of_2 (tighten_bounds_2 x) = real_of_1 (p, l', r')" using Irrational plr id by auto
    from inv have inv1: "invariant_1 (p, l, r)" and "poly_cond2 p" by auto
    hence rc: "\<exists>!x. root_cond (p, l, r) x" "poly_cond2 p" by auto
    note tb' = tighten_poly_bounds[OF tb rc refl]
    have eq: "real_of_1 (p, l, r) = real_of_1 (p, l', r')" using tb' inv1
      using invariant_1_sub_interval(2) by presburger
    from inv1 tb' have "invariant_1 (p, l', r')" by (metis invariant_1_sub_interval(1))
    hence inv2: "invariant_2 (tighten_bounds_2 x)" unfolding id using inv eq by auto
    thus ?thesis unfolding rof eq unfolding id unfolding Irrational plr
      using tb'(1-4) arg_cong[OF tb'(5), of real_of_rat] by (auto simp: hom_distribs)
  qed
qed (auto simp: Let_def)

lift_definition tighten_bounds_3 :: "real_alg_3 \<Rightarrow> real_alg_3" is tighten_bounds_2
  using tighten_bounds_2 by auto

lemma tighten_bounds_3:
  "real_of_3 (tighten_bounds_3 x) = real_of_3 x"
  "get_itvl_3 x = Interval l r \<Longrightarrow>
   get_itvl_3 (tighten_bounds_3 x) = Interval l' r' \<Longrightarrow> r' - l' = (r-l) / 2"
  by (transfer, insert tighten_bounds_2, auto)+

partial_function (tailrec) filter_list_length
  :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  [code]: "filter_list_length f p n xs = (let ys = filter p xs
     in if length ys = n then ys else
     filter_list_length f p n (map f ys))"

lemma filter_list_length: assumes "length (filter P xs) = n"
  and "\<And> i x. x \<in> set xs \<Longrightarrow> P x \<Longrightarrow> p ((f ^^ i) x)"
  and "\<And> x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> \<exists> i. \<not> p ((f ^^ i) x)"
  and g: "\<And> x. g (f x) = g x"
  and P: "\<And> x. P (f x) = P x"
shows "map g (filter_list_length f p n xs) = map g (filter P xs)"
proof -
  from assms(3) have "\<forall> x. \<exists> i. x \<in> set xs \<longrightarrow> \<not> P x \<longrightarrow> \<not> p ((f ^^ i) x)"
    by auto
  from choice[OF this] obtain i where i: "\<And> x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> \<not> p ((f ^^ (i x)) x)"
    by auto
  define m where "m = max_list (map i xs)"
  have m: "\<And> x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> \<exists> i \<le> m. \<not> p ((f ^^ i) x)"
    using max_list[of _ "map i xs", folded m_def] i by auto
  show ?thesis using assms(1-2) m
  proof (induct m arbitrary: xs rule: less_induct)
    case (less m xs)
    define ys where "ys = filter p xs"
    have xs_ys: "filter P xs = filter P ys" unfolding ys_def filter_filter
      by (rule filter_cong[OF refl], insert less(3)[of _ 0], auto)
    have "filter (P \<circ> f) ys = filter P ys" using P unfolding o_def by auto
    hence id3: "filter P (map f ys) = map f (filter P ys)" unfolding filter_map by simp
    hence id2: "map g (filter P (map f ys)) = map g (filter P ys)" by (simp add: g)
    show ?case
    proof (cases "length ys = n")
      case True
      hence id: "filter_list_length f p n xs = ys" unfolding ys_def
        filter_list_length.simps[of _ _ _ xs] Let_def by auto
      show ?thesis using True unfolding id xs_ys using less(2)
        by (metis filter_id_conv length_filter_less less_le xs_ys)
    next
      case False
      {
        assume "m = 0"
        from less(4)[unfolded this] have Pp: "x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> \<not> p x" for x by auto
        with xs_ys False[folded less(2)] have False
          by (metis (mono_tags, lifting) filter_True mem_Collect_eq set_filter ys_def)
      } note m0 = this
      then obtain M where mM: "m = Suc M" by (cases m, auto)
      hence m: "M < m" by simp
      from False have id: "filter_list_length f p n xs = filter_list_length f p n (map f ys)"
        unfolding ys_def filter_list_length.simps[of _ _ _ xs] Let_def by auto
      show ?thesis unfolding id xs_ys id2[symmetric]
      proof (rule less(1)[OF m])
        fix y
        assume "y \<in> set (map f ys)"
        then obtain x where x: "x \<in> set xs" "p x" and y: "y = f x" unfolding ys_def by auto
        {
          assume "\<not> P y"
          hence "\<not> P x" unfolding y P .
          from less(4)[OF x(1) this] obtain i where i: "i \<le> m" and p: "\<not> p ((f ^^ i) x)" by auto
          with x obtain j where ij: "i = Suc j" by (cases i, auto)
          with i have j: "j \<le> M" unfolding mM by auto
          have "\<not> p ((f ^^ j) y)" using p unfolding ij y funpow_Suc_right by simp
          thus "\<exists>i\<le> M. \<not> p ((f ^^ i) y)" using j by auto
        }
        {
          fix i
          assume "P y"
          hence "P x" unfolding y P .
          from less(3)[OF x(1) this, of "Suc i"]
          show "p ((f ^^ i) y)" unfolding y funpow_Suc_right by simp
        }
      next
        show "length (filter P (map f ys)) = n" unfolding id3 length_map using xs_ys less(2) by auto
      qed
    qed
  qed
qed

definition complex_roots_of_int_poly3 :: "int poly \<Rightarrow> complex list" where
  "complex_roots_of_int_poly3 p \<equiv> let n = degree p;
    rrts = real_roots_of_int_poly p;
    nr = length rrts;
    crts = map (\<lambda> r. Complex r 0) rrts
    in
    if n = nr then crts
    else let nr_crts = n - nr in if nr_crts = 2 then
    let pp = real_of_int_poly p div (prod_list (map (\<lambda> x. [:-x,1:]) rrts));
        cpp = map_poly (\<lambda> r. Complex r 0) pp
      in crts @ croots2 cpp else
    let
        nr_pos_crts = nr_crts div 2;
        rxs = real_parts_3 p;
        ixs = pos_imaginary_parts_3 p;
        rts = [(rx, ix). rx <- rxs, ix <- ixs];
        crts' = map pair_to_complex
           (filter_list_length (map_prod tighten_bounds_3 tighten_bounds_3)
              (\<lambda> (r, i). 0 \<in>\<^sub>c ipoly_complex_interval p (Complex_Interval (get_itvl_3 r) (get_itvl_3 i))) nr_pos_crts rts)
    in crts @ (concat (map (\<lambda> x. [x, cnj x]) crts'))"

definition complex_roots_of_int_poly_all :: "int poly \<Rightarrow> complex list" where
  "complex_roots_of_int_poly_all p = (let n = degree p in
    if n \<ge> 3 then complex_roots_of_int_poly3 p
    else if n = 1 then [roots1 (map_poly of_int p)] else if n = 2 then croots2 (map_poly of_int p)
    else [])"

lemma in_real_itvl_get_bounds_tighten: "real_of_3 x \<in>\<^sub>i get_itvl_3 ((tighten_bounds_3 ^^ n) x)"
proof (induct n arbitrary: x)
  case 0
  thus ?case using get_itvl_3[of x] by simp
next
  case (Suc n x)
  have id: "(tighten_bounds_3 ^^ (Suc n)) x = (tighten_bounds_3 ^^ n) (tighten_bounds_3 x)"
    by (metis comp_apply funpow_Suc_right)
  show ?case unfolding id tighten_bounds_3(1)[of x, symmetric] by (rule Suc)
qed

lemma sandwitch_real:
 fixes l r :: "nat \<Rightarrow> real"
 assumes la: "l \<longlonglongrightarrow> a" and ra: "r \<longlonglongrightarrow> a"
 and lm: "\<And>i. l i \<le> m i" and mr: "\<And>i. m i \<le> r i"
shows "m \<longlonglongrightarrow> a"
proof (rule LIMSEQ_I)
  fix e :: real
  assume "0 < e"
  hence e: "0 < e / 2" by simp
  from LIMSEQ_D[OF la e] obtain n1 where n1: "\<And> n. n \<ge> n1 \<Longrightarrow> norm (l n - a) < e/2" by auto
  from LIMSEQ_D[OF ra e] obtain n2 where n2: "\<And> n. n \<ge> n2 \<Longrightarrow> norm (r n - a) < e/2" by auto
  show "\<exists>no. \<forall>n\<ge>no. norm (m n - a) < e"
  proof (rule exI[of _ "max n1 n2"], intro allI impI)
    fix n
    assume "max n1 n2 \<le> n"
    with n1 n2 have *: "norm (l n - a) < e/2" "norm (r n - a) < e/2" by auto
    from lm[of n] mr[of n] have "norm (m n - a) \<le> norm (l n - a) + norm (r n - a)" by simp
    with * show "norm (m n - a) < e" by auto
  qed
qed

definition lower_3 where "lower_3 x i \<equiv> interval.lower (get_itvl_3 ((tighten_bounds_3 ^^ i) x))"
definition upper_3 where "upper_3 x i \<equiv> interval.upper (get_itvl_3 ((tighten_bounds_3 ^^ i) x))"

lemma interval_size_3: "upper_3 x i - lower_3 x i = (upper_3 x 0 - lower_3 x 0)/2^i"
proof (induct i)
  case (Suc i)
  have "upper_3 x (Suc i) - lower_3 x (Suc i) = (upper_3 x i - lower_3 x i) / 2"
     unfolding upper_3_def lower_3_def using tighten_bounds_3 get_itvl_3 by auto
  with Suc show ?case by auto
qed auto

lemma interval_size_3_tendsto_0: "(\<lambda>i. (upper_3 x i - lower_3 x i)) \<longlonglongrightarrow> 0"
  by (subst interval_size_3, auto intro: LIMSEQ_divide_realpow_zero)

lemma dist_tendsto_0_imp_tendsto: "(\<lambda>i. \<bar>f i - a\<bar> :: real) \<longlonglongrightarrow> 0 \<Longrightarrow> f \<longlonglongrightarrow> a"
  using LIM_zero_cancel tendsto_rabs_zero_iff by blast

lemma upper_3_tendsto: "upper_3 x \<longlonglongrightarrow> real_of_3 x"
proof(rule dist_tendsto_0_imp_tendsto, rule sandwitch_real)
  fix i
  obtain l r where lr: "get_itvl_3 ((tighten_bounds_3 ^^ i) x) = Interval l r"
    by (metis interval.collapse)
  with get_itvl_3[of "(tighten_bounds_3 ^^ i) x"]
  show "\<bar>(upper_3 x) i - real_of_3 x\<bar> \<le> (upper_3 x i - lower_3 x i)"
    unfolding upper_3_def lower_3_def by auto
qed (insert interval_size_3_tendsto_0, auto)

lemma lower_3_tendsto: "lower_3 x \<longlonglongrightarrow> real_of_3 x"
proof(rule dist_tendsto_0_imp_tendsto, rule sandwitch_real)
  fix i
  obtain l r where lr: "get_itvl_3 ((tighten_bounds_3 ^^ i) x) = Interval l r"
    by (metis interval.collapse)
  with get_itvl_3[of "(tighten_bounds_3 ^^ i) x"]
  show "\<bar>lower_3 x i - real_of_3 x\<bar> \<le> (upper_3 x i - lower_3 x i)"
    unfolding upper_3_def lower_3_def by auto
qed (insert interval_size_3_tendsto_0, auto)

lemma tends_to_tight_bounds_3: "(\<lambda>x. get_itvl_3 ((tighten_bounds_3 ^^ x) y)) \<longlonglongrightarrow>\<^sub>i real_of_3 y"
  using lower_3_tendsto[of y] upper_3_tendsto[of y] unfolding lower_3_def upper_3_def
    interval_tendsto_def o_def by auto

lemma complex_roots_of_int_poly3: assumes p: "p \<noteq> 0" and sf: "square_free p"
  shows "set (complex_roots_of_int_poly3 p) = {x. ipoly p x = 0}" (is "?l = ?r")
    "distinct (complex_roots_of_int_poly3 p)"
proof -
  interpret map_poly_inj_idom_hom of_real..
  define q where "q = real_of_int_poly p"
  let ?q = "map_poly complex_of_real q"
  from p have q0: "q \<noteq> 0" unfolding q_def by auto
  hence q: "?q \<noteq> 0" by auto
  define rr where "rr = real_roots_of_int_poly p"
  define rrts where "rrts = map (\<lambda>r. Complex r 0) rr"
  note d = complex_roots_of_int_poly3_def[of p, unfolded Let_def, folded rr_def, folded rrts_def]
  have rr: "set rr = {x. ipoly p x = 0}" unfolding rr_def
    using real_roots_of_int_poly(1)[OF p] .
  have rrts: "set rrts = {x. poly ?q x = 0 \<and> x \<in> \<real>}" unfolding rrts_def set_map rr q_def
    complex_of_real_def[symmetric] by (auto elim: Reals_cases)
  have dist: "distinct rr" unfolding rr_def using real_roots_of_int_poly(2) .
  from dist have dist1: "distinct rrts" unfolding rrts_def distinct_map inj_on_def by auto
  have lrr: "length rr = card {x. poly (real_of_int_poly p) x = 0}"
    unfolding rr_def using real_roots_of_int_poly[of p] p distinct_card by fastforce
  have cr: "length rr = card {x. poly ?q x = 0 \<and> x \<in> \<real>}" unfolding lrr q_def[symmetric]
  proof -
    have "card {x. poly q x = 0} \<le> card {x. poly (map_poly complex_of_real q) x = 0 \<and> x \<in> \<real>}" (is "?l \<le> ?r")
      by (rule card_inj_on_le[of of_real], insert poly_roots_finite[OF q], auto simp: inj_on_def)
    moreover have "?l \<ge> ?r"
      by (rule card_inj_on_le[of Re, OF _ _ poly_roots_finite[OF q0]], auto simp: inj_on_def elim!: Reals_cases)
    ultimately show "?l = ?r" by simp
  qed
  have conv: "\<And> x. ipoly p x = 0 \<longleftrightarrow> poly ?q x = 0"
    unfolding q_def by (subst map_poly_map_poly, auto simp: o_def)
  have r: "?r = {x. poly ?q x = 0}" unfolding conv ..
  have "?l = {x. ipoly p x = 0} \<and> distinct (complex_roots_of_int_poly3 p)"
  proof (cases "degree p = length rr")
    case False note oFalse = this
    show ?thesis
    proof (cases "degree p - length rr = 2")
      case False
      let ?nr = "(degree p - length rr) div 2"
      define cpxI where "cpxI = pos_imaginary_parts_3 p"
      define cpxR where "cpxR = real_parts_3 p"
      let ?rts = "[(rx,ix). rx <- cpxR, ix <- cpxI]"
      define cpx where "cpx = map pair_to_complex (filter (\<lambda> c. ipoly p (pair_to_complex c) = 0)
         ?rts)"
      let ?LL = "cpx @ map cnj cpx"
      let ?LL' = "concat (map (\<lambda> x. [x,cnj x]) cpx)"
      let ?ll = "rrts @ ?LL"
      let ?ll' = "rrts @ ?LL'"
      have cpx: "set cpx \<subseteq> ?r" unfolding cpx_def by auto
      have ccpx: "cnj ` set cpx \<subseteq> ?r" using cpx unfolding r
        by (auto intro!: complex_conjugate_root[of ?q] simp: Reals_def)
      have "set ?ll \<subseteq> ?r" using rrts cpx ccpx unfolding r by auto
      moreover
      {
        fix x :: complex
        assume rt: "ipoly p x = 0"
        {
          fix x
          assume rt: "ipoly p x = 0"
            and gt: "Im x > 0"
          define rx where "rx = Re x"
          let ?x = "Complex rx (Im x)"
          have x: "x = ?x" by (cases x, auto simp: rx_def)
          from rt x have rt': "ipoly p ?x = 0" by auto
          from real_parts_3[OF p rt, folded rx_def] pos_imaginary_parts_3[OF p rt gt] rt'
          have "?x \<in> set cpx" unfolding cpx_def cpxI_def cpxR_def
            by (force simp: pair_to_complex_def[abs_def])
          hence "x \<in> set cpx" using x by simp
        } note gt = this
        have cases: "Im x = 0 \<or> Im x > 0 \<or> Im x < 0" by auto
        from rt have rt': "ipoly p (cnj x) = 0" unfolding conv
          by (intro complex_conjugate_root[of ?q x], auto simp: Reals_def)
        {
          assume "Im x > 0"
          from gt[OF rt this] have "x \<in> set ?ll" by auto
        }
        moreover
        {
          assume "Im x < 0"
          hence "Im (cnj x) > 0" by simp
          from gt[OF rt' this] have "cnj (cnj x) \<in> set ?ll" unfolding set_append set_map by blast
          hence "x \<in> set ?ll" by simp
        }
        moreover
        {
          assume "Im x = 0"
          hence "x \<in> \<real>" using complex_is_Real_iff by blast
          with rt rrts have "x \<in> set ?ll" unfolding conv by auto
        }
        ultimately have "x \<in> set ?ll" using cases by blast
      }
      ultimately have lr: "set ?ll = {x. ipoly p x = 0}" by blast
      let ?rr = "map real_of_3 cpxR"
      let ?pi = "map real_of_3 cpxI"
      have dist2: "distinct ?rr" unfolding cpxR_def by (rule distinct_real_parts_3)
      have dist3: "distinct ?pi" unfolding cpxI_def by (rule distinct_pos_imaginary_parts_3)
      have idd: "concat (map (map pair_to_complex) (map (\<lambda>rx. map (Pair rx) cpxI) cpxR))
        = concat (map (\<lambda>r. map (\<lambda> i. Complex (real_of_3 r) (real_of_3 i)) cpxI) cpxR)"
        unfolding pair_to_complex_def by (auto simp: o_def)
      have dist4: "distinct cpx" unfolding cpx_def
      proof (rule distinct_map_filter, unfold map_concat idd, unfold distinct_conv_nth, intro allI impI, goal_cases)
        case (1 i j)
        from nth_concat_diff[OF 1, unfolded length_map] dist2[unfolded distinct_conv_nth]
         dist3[unfolded distinct_conv_nth] show ?case by auto
      qed
      have dist5: "distinct (map cnj cpx)" using dist4 unfolding distinct_map by (auto simp: inj_on_def)
      {
        fix x :: complex
        have rrts: "x \<in> set rrts \<Longrightarrow> Im x = 0" unfolding rrts_def by auto
        have cpx: "\<And> x. x \<in> set cpx \<Longrightarrow> Im x > 0" unfolding cpx_def cpxI_def
          by (auto simp: pair_to_complex_def[abs_def] positive_pos_imaginary_parts_3)
        have cpx': "x \<in> cnj ` set cpx \<Longrightarrow> sgn (Im x) = -1" using cpx by auto
        have "x \<notin> set rrts \<inter> set cpx \<union> set rrts \<inter> cnj ` set cpx \<union> set cpx \<inter> cnj ` set cpx"
          using rrts cpx[of x] cpx' by auto
      } note dist6 = this
      have dist: "distinct ?ll"
        unfolding distinct_append using dist6 by (auto simp: dist1 dist4 dist5)
      let ?p = "complex_of_int_poly p"
      have pp: "?p \<noteq> 0" using p by auto
      from p square_free_of_int_poly[OF sf] square_free_rsquarefree
      have rsf:"rsquarefree ?p" by auto
      from dist lr have "length ?ll = card {x. poly ?p x = 0}"
        by (metis distinct_card)
      also have "\<dots> = degree p"
        using rsf unfolding rsquarefree_card_degree[OF pp] by simp
      finally have deg_len: "degree p = length ?ll" by simp
      let ?P = "\<lambda> c.  ipoly p (pair_to_complex c) = 0"
      let ?itvl = "\<lambda> r i. ipoly_complex_interval p (Complex_Interval (get_itvl_3 r) (get_itvl_3 i))"
      let ?itv = "\<lambda> (r,i). ?itvl r i"
      let ?p = "(\<lambda> (r,i). 0 \<in>\<^sub>c (?itvl r i))"
      let ?tb = tighten_bounds_3
      let ?f = "map_prod ?tb ?tb"
      have filter: "map pair_to_complex (filter_list_length ?f ?p ?nr ?rts) = map pair_to_complex (filter ?P ?rts)"
      proof (rule filter_list_length)
        have "length (filter ?P ?rts) = length cpx"
          unfolding cpx_def by simp
        also have "\<dots> = ?nr" unfolding deg_len by (simp add: rrts_def)
        finally show "length (filter ?P ?rts) = ?nr" by auto
      next
        fix n x
        assume x: "?P x"
        obtain r i where xri: "x = (r,i)" by force
        have id: "(?f ^^ n) x = ((?tb ^^ n) r, (?tb ^^ n) i)" unfolding xri
          by (induct n, auto)
        have px: "pair_to_complex x = Complex (real_of_3 r) (real_of_3 i)"
          unfolding xri pair_to_complex_def by auto
        show "?p ((?f ^^ n) x)"
          unfolding id split
          by (rule ipoly_complex_interval[of "pair_to_complex x" _ p, unfolded x], unfold px,
            auto simp: in_complex_interval_def in_real_itvl_get_bounds_tighten)
      next
        fix x
        assume x: "x \<in> set ?rts" "\<not> ?P x"
        let ?x = "pair_to_complex x"
        obtain r i where xri: "x = (r,i)" by force
        have id: "(?f ^^ n) x = ((?tb ^^ n) r, (?tb ^^ n) i)" for n unfolding xri
          by (induct n, auto)
        have px: "?x = Complex (real_of_3 r) (real_of_3 i)"
          unfolding xri pair_to_complex_def by auto
        have cvg: "(\<lambda> n. ?itv ((?f ^^ n) x)) \<longlonglongrightarrow>\<^sub>c ipoly p ?x"
          unfolding id split px
        proof (rule ipoly_complex_interval_tendsto)
          show "(\<lambda>ia. Complex_Interval (get_itvl_3 ((?tb ^^ ia) r)) (get_itvl_3 ((?tb ^^ ia) i))) \<longlonglongrightarrow>\<^sub>c
            Complex (real_of_3 r) (real_of_3 i)"
            unfolding complex_interval_tendsto_def by (simp add: tends_to_tight_bounds_3 o_def)
        qed
        from complex_interval_tendsto_neq[OF this x(2)]
        show "\<exists> i. \<not> ?p ((?f ^^ i) x)" unfolding id by auto
      next
        show "pair_to_complex (?f x) = pair_to_complex x" for x
          by (cases x, auto simp: pair_to_complex_def tighten_bounds_3(1))
      next
        show "?P (?f x) = ?P x" for x
          by (cases x, auto simp: pair_to_complex_def tighten_bounds_3(1))
      qed
      have l: "complex_roots_of_int_poly3 p = ?ll'"
        unfolding d filter cpx_def[symmetric] cpxI_def[symmetric] cpxR_def[symmetric] using False oFalse
        by auto
      have "distinct ?ll' = (distinct rrts \<and> distinct ?LL' \<and> set rrts \<inter> set ?LL' = {})"
        unfolding distinct_append ..
      also have "set ?LL' = set ?LL" by auto
      also have "distinct ?LL' = distinct ?LL" by (induct cpx, auto)
      finally have "distinct ?ll' = distinct ?ll" unfolding distinct_append by auto
      with dist have "distinct ?ll'" by auto
      with lr l show ?thesis by auto
    next
      case True
      let ?cr = "map_poly of_real :: real poly \<Rightarrow> complex poly"
      define pp where "pp = complex_of_int_poly p"
      have id: "pp = map_poly of_real q" unfolding q_def pp_def
        by (subst map_poly_map_poly, auto simp: o_def)
      let ?rts = "map (\<lambda> x. [:-x,1:]) rr"
      define rts where "rts = prod_list ?rts"
      let ?c2 = "?cr (q div rts)"
      have pq: "\<And> x. ipoly p x = 0 \<longleftrightarrow> poly q x = 0" unfolding q_def by simp
      from True have 2: "degree q - card {x. poly q x = 0} = 2" unfolding pq[symmetric] lrr
        unfolding q_def by simp
      from True have id: "degree p = length rr \<longleftrightarrow> False"
        "degree p - length rr = 2 \<longleftrightarrow> True" by auto
      have l: "?l = of_real ` {x. poly q x = 0} \<union> set (croots2 ?c2)"
        unfolding d rts_def id if_False if_True set_append rrts Reals_def
        by (fold complex_of_real_def q_def, auto)
      from dist
      have len_rr: "length rr = card {x. poly q x = 0}" unfolding rr[unfolded pq, symmetric]
        by (simp add: distinct_card)
      have rr': "\<And> r. r \<in> set rr \<Longrightarrow> poly q r = 0" using rr unfolding q_def by simp
      with dist have "q = q div prod_list ?rts * prod_list ?rts"
      proof (induct rr arbitrary: q)
        case (Cons r rr q)
        note dist = Cons(2)
        let ?p = "q div [:-r,1:]"
        from Cons.prems(2) have "poly q r = 0" by simp
        hence "[:-r,1:] dvd q" using poly_eq_0_iff_dvd by blast
        from dvd_mult_div_cancel[OF this]
        have "q = ?p * [:-r,1:]" by simp
        moreover have "?p = ?p div (\<Prod>x\<leftarrow>rr. [:- x, 1:]) * (\<Prod>x\<leftarrow>rr. [:- x, 1:])"
        proof (rule Cons.hyps)
          show "distinct rr" using dist by auto
          fix s
          assume "s \<in> set rr"
          with dist Cons(3) have "s \<noteq> r" "poly q s = 0" by auto
          hence "poly (?p * [:- 1 * r, 1:]) s = 0" using calculation by force
          thus "poly ?p s = 0" by (simp add: \<open>s \<noteq> r\<close>)
        qed
        ultimately have q: "q = ?p div (\<Prod>x\<leftarrow>rr. [:- x, 1:]) * (\<Prod>x\<leftarrow>rr. [:- x, 1:]) * [:-r,1:]"
          by auto
        also have "\<dots> = (?p div (\<Prod>x\<leftarrow>rr. [:- x, 1:])) * (\<Prod>x\<leftarrow>r # rr. [:- x, 1:])"
          unfolding mult.assoc by simp
        also have "?p div (\<Prod>x\<leftarrow>rr. [:- x, 1:]) = q div (\<Prod>x\<leftarrow>r # rr. [:- x, 1:])"
          unfolding poly_div_mult_right[symmetric] by simp
        finally show ?case .
      qed simp
      hence q_div: "q = q div rts * rts" unfolding rts_def .
      from q_div q0 have "q div rts \<noteq> 0" "rts \<noteq> 0" by auto
      from degree_mult_eq[OF this] have "degree q = degree (q div rts) + degree rts"
        using q_div by simp
      also have "degree rts = length rr" unfolding rts_def by (rule degree_linear_factors)
      also have "\<dots> = card {x. poly q x = 0}" unfolding len_rr by simp
      finally have deg2: "degree ?c2 = 2" using 2 by simp
      note croots2 = croots2[OF deg2, symmetric]
      have "?q = ?cr (q div rts * rts)" using q_div by simp
      also have "\<dots> = ?cr rts * ?c2" unfolding hom_distribs by simp
      finally have q_prod: "?q = ?cr rts * ?c2" .
      from croots2 l
      have l: "?l = of_real ` {x. poly q x = 0} \<union> {x. poly ?c2 x = 0}" by simp
      from r[unfolded q_prod]
      have r: "?r = {x. poly (?cr rts) x = 0} \<union> {x. poly ?c2 x = 0}" by auto
      also have "?cr rts = (\<Prod>x\<leftarrow>rr. ?cr [:- x, 1:])" by (simp add: rts_def o_def of_real_poly_hom.hom_prod_list)
      also have "{x. poly \<dots> x = 0} = of_real ` set rr"
        unfolding poly_prod_list_zero_iff by auto
      also have "set rr = {x. poly q x = 0}" unfolding rr q_def by simp
      finally have lr: "?l = ?r" unfolding l by simp
      show ?thesis
      proof (intro conjI[OF lr])
        from sf have sf: "square_free q" unfolding q_def by (rule square_free_of_int_poly)
        {
          interpret field_hom_0' complex_of_real ..
          from sf have "square_free ?q" unfolding square_free_map_poly .
        } note sf = this
        have l: "complex_roots_of_int_poly3 p = rrts @ croots2 ?c2"
          unfolding d rts_def id if_False if_True set_append rrts q_def complex_of_real_def by auto
        have dist2: "distinct (croots2 ?c2)" unfolding croots2_def Let_def by auto
        {
          fix x
          assume x: "x \<in> set (croots2 ?c2)" "x \<in> set rrts"
          from x(1)[unfolded croots2] have x1: "poly ?c2 x = 0" by auto
          from x(2) have x2: "poly (?cr rts) x = 0"
            unfolding rrts_def rts_def complex_of_real_def[symmetric]
            by (auto simp: poly_prod_list_zero_iff o_def)
          from square_free_multD(1)[OF sf[unfolded q_prod], of "[: -x, 1:]"]
            x1 x2 have False unfolding poly_eq_0_iff_dvd by auto
        } note dist3 = this
        show "distinct (complex_roots_of_int_poly3 p)" unfolding l distinct_append
          by (intro conjI dist1 dist2, insert dist3, auto)
      qed
    qed
  next
    case True
    have "card {x. poly ?q x = 0} \<le> degree ?q" by (rule poly_roots_degree[OF q])
    also have "\<dots> = degree p" unfolding q_def by simp
    also have "\<dots> = card {x. poly ?q x = 0 \<and> x \<in> \<real>}" using True cr by simp
    finally have le: "card {x. poly ?q x = 0} \<le> card {x. poly ?q x = 0 \<and> x \<in> \<real>}" by auto
    have "{x. poly ?q x = 0 \<and> x \<in> \<real>} = {x. poly ?q x = 0}"
      by (rule card_seteq[OF _ _ le], insert poly_roots_finite[OF q], auto)
    with True rrts dist1 show ?thesis unfolding r d by auto
  qed
  thus "distinct (complex_roots_of_int_poly3 p)" "?l = ?r" by auto
qed

lemma complex_roots_of_int_poly_all: assumes sf: "degree p \<ge> 3 \<Longrightarrow> square_free p"
  shows "p \<noteq> 0 \<Longrightarrow> set (complex_roots_of_int_poly_all p) = {x. ipoly p x = 0}" (is "_ \<Longrightarrow> set ?l = ?r")
    and "distinct (complex_roots_of_int_poly_all p)"
proof -
  note d = complex_roots_of_int_poly_all_def Let_def
  have "(p \<noteq> 0 \<longrightarrow> set ?l = ?r) \<and> (distinct (complex_roots_of_int_poly_all p))"
  proof (cases "degree p \<ge> 3")
    case True
    hence p: "p \<noteq> 0" by auto
    from True complex_roots_of_int_poly3[OF p] sf show ?thesis unfolding d by auto
  next
    case False
    let ?p = "map_poly (of_int :: int \<Rightarrow> complex) p"
    have deg: "degree ?p = degree p"
      by (simp add: degree_map_poly)
    show ?thesis
    proof (cases "degree p = 1")
      case True
      hence l: "?l = [roots1 ?p]" unfolding d by auto
      from True have "degree ?p = 1" unfolding deg by auto
      from roots1[OF this] show ?thesis unfolding l roots1_def by auto
    next
      case False
      show ?thesis
      proof (cases "degree p = 2")
        case True
        hence l: "?l = croots2 ?p" unfolding d by auto
        from True have "degree ?p = 2" unfolding deg by auto
        from croots2[OF this] show ?thesis unfolding l by (simp add: croots2_def Let_def)
      next
        case False
        with \<open>degree p \<noteq> 1\<close> \<open>degree p \<noteq> 2\<close> \<open>\<not> (degree p \<ge> 3)\<close> have True: "degree p = 0" by auto
        hence l: "?l = []" unfolding d by auto
        from True have "degree ?p = 0" unfolding deg by auto
        from roots0[OF _ this] show ?thesis unfolding l by simp
      qed
    qed
  qed
  thus "p \<noteq> 0 \<Longrightarrow> set ?l = ?r" "distinct (complex_roots_of_int_poly_all p)" by auto
qed

text \<open>It now comes the preferred function to compute complex roots of an integer polynomial.\<close>
definition complex_roots_of_int_poly :: "int poly \<Rightarrow> complex list" where
  "complex_roots_of_int_poly p = (
    let ps = (if degree p \<ge> 3 then factors_of_int_poly p else [p])
    in concat (map complex_roots_of_int_poly_all ps))"

definition complex_roots_of_rat_poly :: "rat poly \<Rightarrow> complex list" where
  "complex_roots_of_rat_poly p = complex_roots_of_int_poly (snd (rat_to_int_poly p))"

lemma complex_roots_of_int_poly:
  shows "p \<noteq> 0 \<Longrightarrow> set (complex_roots_of_int_poly p) = {x. ipoly p x = 0}" (is "_ \<Longrightarrow> ?l = ?r")
  and "distinct (complex_roots_of_int_poly p)"
proof -
  have "(p \<noteq> 0 \<longrightarrow> ?l = ?r) \<and> (distinct (complex_roots_of_int_poly p))"
  proof (cases "degree p \<ge> 3")
    case False
    hence "complex_roots_of_int_poly p = complex_roots_of_int_poly_all p"
      unfolding complex_roots_of_int_poly_def Let_def by auto
    with complex_roots_of_int_poly_all[of p] False show ?thesis by auto
  next
    case True
    {
      fix q
      assume "q \<in> set (factors_of_int_poly p)"
      from factors_of_int_poly(1)[OF refl this] irreducible_imp_square_free[of q]
      have 0: "q \<noteq> 0" and sf: "square_free q" by auto
      from complex_roots_of_int_poly_all(1)[OF sf 0] complex_roots_of_int_poly_all(2)[OF sf]
      have "set (complex_roots_of_int_poly_all q) = {x. ipoly q x = 0}"
        "distinct (complex_roots_of_int_poly_all q)" by auto
    } note all = this
    from True have
      "?l = (\<Union> ((\<lambda> p. set (complex_roots_of_int_poly_all p)) ` set (factors_of_int_poly p)))"
      unfolding complex_roots_of_int_poly_def Let_def by auto
    also have "\<dots> = (\<Union> ((\<lambda> p. {x. ipoly p x = 0}) ` set (factors_of_int_poly p)))"
      using all by blast
    finally have l: "?l = (\<Union> ((\<lambda> p. {x. ipoly p x = 0}) ` set (factors_of_int_poly p)))" .
    have lr: "p \<noteq> 0 \<longrightarrow> ?l = ?r" using l factors_of_int_poly(2)[OF refl, of p] by auto
    show ?thesis
    proof (rule conjI[OF lr])
      from True have id: "complex_roots_of_int_poly p =
          concat (map complex_roots_of_int_poly_all (factors_of_int_poly p))"
        unfolding complex_roots_of_int_poly_def Let_def by auto
      show "distinct (complex_roots_of_int_poly p)" unfolding id distinct_conv_nth
      proof (intro allI impI, goal_cases)
        case (1 i j)
        let ?fp = "factors_of_int_poly p"
        let ?rr = "complex_roots_of_int_poly_all"
        let ?cc = "concat (map ?rr (factors_of_int_poly p))"
        from nth_concat_diff[OF 1, unfolded length_map]
        obtain j1 k1 j2 k2 where
          *: "(j1,k1) \<noteq> (j2,k2)"
          "j1 < length ?fp" "j2 < length ?fp" and
          "k1 < length (map ?rr ?fp ! j1)"
          "k2 < length (map ?rr ?fp ! j2)"
          "?cc ! i = map ?rr ?fp ! j1 ! k1"
          "?cc ! j = map ?rr ?fp ! j2 ! k2" by blast
        hence **: "k1 < length (?rr (?fp ! j1))"
          "k2 < length (?rr (?fp ! j2))"
          "?cc ! i = ?rr (?fp ! j1) ! k1"
          "?cc ! j = ?rr (?fp ! j2) ! k2"
          by auto
        from * have mem: "?fp ! j1 \<in> set ?fp" "?fp ! j2 \<in> set ?fp" by auto
        show "?cc ! i \<noteq> ?cc ! j"
        proof (cases "j1 = j2")
          case True
          with * have "k1 \<noteq> k2" by auto
          with all(2)[OF mem(2)] **(1-2) show ?thesis unfolding **(3-4) unfolding True
            distinct_conv_nth by auto
        next
          case False
          from \<open>degree p \<ge> 3\<close> have p: "p \<noteq> 0" by auto
          note fip = factors_of_int_poly(2-3)[OF refl this]
          show ?thesis unfolding **(3-4)
          proof
            define x where "x = ?rr (?fp ! j2) ! k2"
            assume id: "?rr (?fp ! j1) ! k1 = ?rr (?fp ! j2) ! k2"
            from ** have x1: "x \<in> set (?rr (?fp ! j1))" unfolding x_def id[symmetric] by auto
            from ** have x2: "x \<in> set (?rr (?fp ! j2))" unfolding x_def by auto
            from all(1)[OF mem(1)] x1 have x1: "ipoly (?fp ! j1) x = 0" by auto
            from all(1)[OF mem(2)] x2 have x2: "ipoly (?fp ! j2) x = 0" by auto
            from False factors_of_int_poly(4)[OF refl, of p] have neq: "?fp ! j1 \<noteq> ?fp ! j2"
              using * unfolding distinct_conv_nth by auto
            have "poly (complex_of_int_poly p) x = 0" by (meson fip(1) mem(2) x2)
            from fip(2)[OF this] mem x1 x2 neq
            show False by blast
          qed
        qed
      qed
    qed
  qed
  thus "p \<noteq> 0 \<Longrightarrow> ?l = ?r" "distinct (complex_roots_of_int_poly p)" by auto
qed

lemma complex_roots_of_rat_poly:
  "p \<noteq> 0 \<Longrightarrow> set (complex_roots_of_rat_poly p) = {x. rpoly p x = 0}" (is "_ \<Longrightarrow> ?l = ?r")
  "distinct (complex_roots_of_rat_poly p)"
proof -
  obtain c q where cq: "rat_to_int_poly p = (c,q)" by force
  from rat_to_int_poly[OF this]
  have pq: "p = smult (inverse (of_int c)) (of_int_poly q)"
    and c: "c \<noteq> 0" by auto
  show "distinct (complex_roots_of_rat_poly p)" unfolding complex_roots_of_rat_poly_def
    using complex_roots_of_int_poly(2) .
  assume p: "p \<noteq> 0"
  with pq c have q: "q \<noteq> 0" by auto
  have id: "{x. rpoly p x = (0 :: complex)} = {x. ipoly q x = 0}"
    unfolding pq by (simp add: c of_rat_of_int_poly hom_distribs)
  show "?l = ?r" unfolding complex_roots_of_rat_poly_def cq snd_conv id
    complex_roots_of_int_poly(1)[OF q] ..
qed

lemma min_int_poly_complex_of_real[simp]: "min_int_poly (complex_of_real x) = min_int_poly x"
proof (cases "algebraic x")
  case False
  hence "\<not> algebraic (complex_of_real x)" unfolding algebraic_complex_iff by auto
  with False show ?thesis unfolding min_int_poly_def by auto
next
  case True
  from min_int_poly_represents[OF True]
  have "min_int_poly x represents x" by auto
  thus ?thesis
    by (intro min_int_poly_unique, auto simp: lead_coeff_min_int_poly_pos)
qed

text \<open>TODO: the implemention might be tuned, since the search process should be faster when
  using interval arithmetic to figure out the correct factor.
  (One might also implement the search via checking @{term "ipoly f x = 0"}, but because of complex-algebraic-number
   arithmetic, I think that search would be slower than the current one via "@{term "x \<in> set (complex_roots_of_int_poly f)"}\<close>
definition min_int_poly_complex :: "complex \<Rightarrow> int poly" where
  "min_int_poly_complex x = (if algebraic x then if Im x = 0 then min_int_poly_real (Re x)
     else the (find (\<lambda> f. x \<in> set (complex_roots_of_int_poly f)) (complex_poly (min_int_poly (Re x)) (min_int_poly (Im x))))
     else [:0,1:])"

lemma min_int_poly_complex[code_unfold]: "min_int_poly = min_int_poly_complex"
proof (standard)
  fix x
  define fs where "fs = complex_poly (min_int_poly (Re x)) (min_int_poly (Im x))"
  let ?f = "min_int_poly_complex x"
  show "min_int_poly x = ?f"
  proof (cases "algebraic x")
    case False
    thus ?thesis unfolding min_int_poly_def min_int_poly_complex_def by auto
  next
    case True
    show ?thesis
    proof (cases "Im x = 0")
      case *: True
      have id: "?f = min_int_poly_real (Re x)" unfolding min_int_poly_complex_def * using True by auto
      show ?thesis unfolding id min_int_poly_real_code_unfold[symmetric] min_int_poly_complex_of_real[symmetric]
        using * by (intro arg_cong[of _ _ min_int_poly] complex_eqI, auto)
    next
      case False
      from True[unfolded algebraic_complex_iff] have "algebraic (Re x)" "algebraic (Im x)" by auto
      from complex_poly[OF min_int_poly_represents[OF this(1)] min_int_poly_represents[OF this(2)]]
      have fs: "\<exists> f \<in> set fs. ipoly f x = 0" "\<And> f. f \<in> set fs \<Longrightarrow> poly_cond f" unfolding fs_def by auto
      let ?fs = "find (\<lambda> f. ipoly f x = 0) fs"
      let ?fs' = "find (\<lambda> f. x \<in> set (complex_roots_of_int_poly f)) fs"
      have "?f = the ?fs'" unfolding min_int_poly_complex_def fs_def
        using True False by auto
      also have "?fs' = ?fs"
        by (rule find_cong[OF refl], subst complex_roots_of_int_poly, insert fs, auto)
      finally have id: "?f = the ?fs" .
      from fs(1) have "?fs \<noteq> None" unfolding find_None_iff by auto
      then obtain f where Some: "?fs = Some f" by auto
      from find_Some_D[OF this] fs(2)[of f]
      show ?thesis unfolding id Some
        by (intro min_int_poly_unique, auto)
    qed
  qed
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_StoogeSort2Permutes
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun take :: "int => 'a list => 'a list" where
"take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun length :: "'a list => int" where
"length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun elem :: "'a => 'a list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "int => 'a list => 'a list" where
"drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function stooge2sort2 :: "int list => int list"
         and stoogesort2 :: "int list => int list"
         and stooge2sort1 :: "int list => int list" where
"stooge2sort2 y =
   (case splitAt ((op div) ((2 * (length y)) + 1) 3) y of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (stoogesort2 xs) xs"
  oops

end


theory Function
imports Main "HOL-Library.Adhoc_Overloading"
begin

fun exten_equal where
 "exten_equal (A, f, B) (A', g, B') =
   ((A \<inter> vimage f B = A' \<inter> vimage g B') \<and>  (B = B') \<and> (\<forall>x\<in>(A \<inter> vimage f B). f x  = g x) \<and> (\<forall>x\<in>(A' \<inter> vimage g B'). f x  = g x)) "

quotient_type ('a, 'b) p_function = "('a set \<times> ('a \<Rightarrow> 'b) \<times> 'b set)" / exten_equal
  apply (rule equivpI)
    apply (rule reflpI, clarsimp simp: )
   apply (rule sympI )
   apply (clarsimp)
  by (simp add: exten_equal.elims(2)  transp_def)

type_notation  p_function (infixr "\<rightharpoondown>" 0)

lift_definition restrict :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) p_function" is "\<lambda>f S S'. (S, f, S')"
  done

lift_definition app :: "('a, 'b) p_function \<Rightarrow> 'a \<Rightarrow> 'b" is
                      "\<lambda>(A, f, B) x. if x \<in> (A \<inter> vimage f B) then f x else undefined"
  apply (rule ext; clarsimp simp:)
  by blast

lift_definition dom :: "('a, 'b) p_function \<Rightarrow> 'a set" is "\<lambda>(A, f, B). A \<inter> (vimage f B)"
  by (clarsimp)

lift_definition cod :: "('a, 'b) p_function \<Rightarrow> 'b set" is "\<lambda>f. snd (snd f)"
  by (clarsimp)

abbreviation "total_f f == (restrict f UNIV UNIV)"

abbreviation "on_domain_f f A == (restrict f A UNIV)"

notation app (infixl "$" 54)

definition range :: "('a, 'b) p_function \<Rightarrow> 'b set"
  where "range f = {x. \<exists>y\<in>dom f. f $ y = x \<and> x \<in> cod f}"

lemma range_sub_cod: "range f \<subseteq> cod f"
  by (clarsimp simp: range_def)

syntax
  "_lam" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"  ("(3\<lambda>_\<in>_ \<rightarrow> _./ _)" [0,0,3] 3)
  "_lam_dom" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"  ("(3\<lambda>_\<in>_./ _)" [0,0,3] 3)
  "_lam_free" :: "pttrn \<Rightarrow>  ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"  ("(3\<lambda>_!./ _)" [0,3] 3)

translations
 "\<lambda>x!. f" \<rightleftharpoons> "CONST total_f (\<lambda>x. f) "
 "\<lambda>x\<in>A. f" \<rightleftharpoons> "CONST on_domain_f (\<lambda>x. f) A"
 "\<lambda>x\<in>A \<rightarrow> B. f" \<rightleftharpoons> "CONST restrict (\<lambda>x. f) A B"

lemma "dom f = dom g \<Longrightarrow> cod f = cod g  \<Longrightarrow> (\<And>x. x \<in> dom f \<Longrightarrow> f $ x = g $ x) \<Longrightarrow> range f = range g "
  by (simp add: range_def)

lemma ext_restrict: "dom f = dom g \<Longrightarrow> cod f = cod g  \<Longrightarrow>
   (\<And>x. x \<in> dom f \<Longrightarrow> f $ x = g $ x) \<Longrightarrow> f = g"
  apply (clarsimp simp: range_def)
  apply (transfer)
  apply (clarsimp)
  apply (subst (asm) set_eq_iff)
  apply (erule_tac x=x in allE, clarsimp)
  apply (atomize)
  apply (erule_tac x=x in allE, drule mp, clarsimp)
    apply (clarsimp)
  done

lemma app_subst[simp,trans]: "x \<in> A \<Longrightarrow> P (f x) \<Longrightarrow> P ((\<lambda>x\<in>A. f x) $ x)"
  by (transfer, clarsimp)

lemma app_subst'[simp,trans]: "x \<in> A \<Longrightarrow> f x \<in> B \<Longrightarrow>  P (f x) \<Longrightarrow> P ((\<lambda>x\<in>A \<rightarrow> B. f x) $ x)"
  by (transfer, clarsimp)

lemma app_subst''[simp,trans]: "x \<in> A \<Longrightarrow> f x \<in> B \<Longrightarrow>  P (f x) \<Longrightarrow> P ((\<lambda>x!. f x) $ x)"
  by (transfer, clarsimp)

lemma app_iff[simp]: "x \<in> A \<Longrightarrow> ((\<lambda>x\<in>A. f x) $ x) =  (f x) "
  by (transfer, clarsimp)

lemma app_iff'[simp]: "x \<in> A \<Longrightarrow> f x \<in> B \<Longrightarrow> ((\<lambda>x\<in>A \<rightarrow> B. f x) $ x) =  (f x) "
  by (transfer, clarsimp)

lemma app_iff''[simp]: " ((\<lambda>x!. f x) $ x) =  (f x) "
  by (transfer, clarsimp)

lemma app_ssubst: "x \<in> A \<Longrightarrow> P ((\<lambda>x\<in>A. f x) $ x) \<Longrightarrow> P (f x) "
  by (transfer, clarsimp)

lemma dom_simp[simp]: "dom (\<lambda>x\<in>A. f x) = A"
  by (transfer, clarsimp)

lemma dom_simp'[simp]: "dom (\<lambda>x\<in>A \<rightarrow> B. f x) = A \<inter> (vimage f B)"
  by (transfer, clarsimp)

definition add :: "nat \<rightharpoondown> nat \<rightharpoondown> nat" (* Addition on increasing pairs of natural numbers such that the first argument is less than 20 and the combination less than 50 *)
  where "add = (\<lambda>x\<in>{n. n \<le> 20}. \<lambda>y\<in>{n. (n :: nat) \<ge> x} \<rightarrow> {n. n \<le> 50}. x + y)"

lemma example: "(add $ 3) $ 5 = (add $ 2 $ 6)"
  by (unfold add_def, clarsimp)

lemma example': "(add $ 100) $ 5 = (add $ 99 $ 6)"
  apply (clarsimp simp: add_def)
  apply (subst app_iff) (* not in the domain *)
  oops

lemma total: "a \<in> dom f \<Longrightarrow> f $ a \<in> (cod f)"
  by (transfer, clarsimp)

definition const :: "'a set \<Rightarrow> 'b set \<Rightarrow> 'a \<rightharpoondown> 'b \<rightharpoondown> 'a"
  where "const A B = (\<lambda>x\<in>A.\<lambda>y\<in>B \<rightarrow> {x}. x)"

lemma const_is_const: "a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> const A B $ a $ b = a"
  by (clarsimp simp: const_def)

definition const_alt :: "'a set \<rightharpoondown> 'b set \<rightharpoondown> 'a \<rightharpoondown> 'b \<rightharpoondown> 'a" (* Unnecessary, but possible *)
  where "const_alt = (\<lambda>A!.\<lambda>B!. \<lambda>x\<in>A. \<lambda>y\<in>B \<rightarrow> {x}. x)"

definition compose :: "('a \<rightharpoondown> 'b) \<rightharpoondown> ('b \<rightharpoondown> 'c) \<rightharpoondown> ('a \<rightharpoondown> 'c)"
  where "compose = (\<lambda>f!.\<lambda>g\<in>{g. cod f \<subseteq> dom g}. \<lambda>x\<in>(dom f) \<rightarrow> (cod g). g $ (f $ x))"

abbreviation "cmp f g \<equiv> (compose $ f) $ g"

notation cmp (infixl "\<cdot>" 55)

term "f \<cdot> g $ x"

end


(*  Title:    HOL/Library/Nonpos_Ints.thy
    Author:   Manuel Eberl, TU München
*)

section \<open>Non-negative, non-positive integers and reals\<close>

theory Nonpos_Ints
imports Complex_Main
begin

subsection\<open>Non-positive integers\<close>
text \<open>
  The set of non-positive integers on a ring. (in analogy to the set of non-negative
  integers \<^term>\<open>\<nat>\<close>) This is useful e.g. for the Gamma function.
\<close>

definition nonpos_Ints ("\<int>\<^sub>\<le>\<^sub>0") where "\<int>\<^sub>\<le>\<^sub>0 = {of_int n |n. n \<le> 0}"

lemma zero_in_nonpos_Ints [simp,intro]: "0 \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "0::int"])

lemma neg_one_in_nonpos_Ints [simp,intro]: "-1 \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "-1::int"])

lemma neg_numeral_in_nonpos_Ints [simp,intro]: "-numeral n \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "-numeral n::int"])

lemma one_notin_nonpos_Ints [simp]: "(1 :: 'a :: ring_char_0) \<notin> \<int>\<^sub>\<le>\<^sub>0"
  by (auto simp: nonpos_Ints_def)

lemma numeral_notin_nonpos_Ints [simp]: "(numeral n :: 'a :: ring_char_0) \<notin> \<int>\<^sub>\<le>\<^sub>0"
  by (auto simp: nonpos_Ints_def)

lemma minus_of_nat_in_nonpos_Ints [simp, intro]: "- of_nat n \<in> \<int>\<^sub>\<le>\<^sub>0"
proof -
  have "- of_nat n = of_int (-int n)" by simp
  also have "-int n \<le> 0" by simp
  hence "of_int (-int n) \<in> \<int>\<^sub>\<le>\<^sub>0" unfolding nonpos_Ints_def by blast
  finally show ?thesis .
qed

lemma of_nat_in_nonpos_Ints_iff: "(of_nat n :: 'a :: {ring_1,ring_char_0}) \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> n = 0"
proof
  assume "(of_nat n :: 'a) \<in> \<int>\<^sub>\<le>\<^sub>0"
  then obtain m where "of_nat n = (of_int m :: 'a)" "m \<le> 0" by (auto simp: nonpos_Ints_def)
  hence "(of_int m :: 'a) = of_nat n" by simp
  also have "... = of_int (int n)" by simp
  finally have "m = int n" by (subst (asm) of_int_eq_iff)
  with \<open>m \<le> 0\<close> show "n = 0" by auto
qed simp

lemma nonpos_Ints_of_int: "n \<le> 0 \<Longrightarrow> of_int n \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by blast

lemma nonpos_IntsI:
  "x \<in> \<int> \<Longrightarrow> x \<le> 0 \<Longrightarrow> (x :: 'a :: linordered_idom) \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def Ints_def by auto

lemma nonpos_Ints_subset_Ints: "\<int>\<^sub>\<le>\<^sub>0 \<subseteq> \<int>"
  unfolding nonpos_Ints_def Ints_def by blast

lemma nonpos_Ints_nonpos [dest]: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<le> (0 :: 'a :: linordered_idom)"
  unfolding nonpos_Ints_def by auto

lemma nonpos_Ints_Int [dest]: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<in> \<int>"
  unfolding nonpos_Ints_def Ints_def by blast

lemma nonpos_Ints_cases:
  assumes "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  obtains n where "x = of_int n" "n \<le> 0"
  using assms unfolding nonpos_Ints_def by (auto elim!: Ints_cases)

lemma nonpos_Ints_cases':
  assumes "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  obtains n where "x = -of_nat n"
proof -
  from assms obtain m where "x = of_int m" and m: "m \<le> 0" by (auto elim!: nonpos_Ints_cases)
  hence "x = - of_int (-m)" by auto
  also from m have "(of_int (-m) :: 'a) = of_nat (nat (-m))" by simp_all
  finally show ?thesis by (rule that)
qed

lemma of_real_in_nonpos_Ints_iff: "(of_real x :: 'a :: real_algebra_1) \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<int>\<^sub>\<le>\<^sub>0"
proof
  assume "of_real x \<in> (\<int>\<^sub>\<le>\<^sub>0 :: 'a set)"
  then obtain n where "(of_real x :: 'a) = of_int n" "n \<le> 0" by (erule nonpos_Ints_cases)
  note \<open>of_real x = of_int n\<close>
  also have "of_int n = of_real (of_int n)" by (rule of_real_of_int_eq [symmetric])
  finally have "x = of_int n" by (subst (asm) of_real_eq_iff)
  with \<open>n \<le> 0\<close> show "x \<in> \<int>\<^sub>\<le>\<^sub>0" by (simp add: nonpos_Ints_of_int)
qed (auto elim!: nonpos_Ints_cases intro!: nonpos_Ints_of_int)

lemma nonpos_Ints_altdef: "\<int>\<^sub>\<le>\<^sub>0 = {n \<in> \<int>. (n :: 'a :: linordered_idom) \<le> 0}"
  by (auto intro!: nonpos_IntsI elim!: nonpos_Ints_cases)

lemma uminus_in_Nats_iff: "-x \<in> \<nat> \<longleftrightarrow> x \<in> \<int>\<^sub>\<le>\<^sub>0"
proof
  assume "-x \<in> \<nat>"
  then obtain n where "n \<ge> 0" "-x = of_int n" by (auto simp: Nats_altdef1)
  hence "-n \<le> 0" "x = of_int (-n)" by (simp_all add: eq_commute minus_equation_iff[of x])
  thus "x \<in> \<int>\<^sub>\<le>\<^sub>0" unfolding nonpos_Ints_def by blast
next
  assume "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  then obtain n where "n \<le> 0" "x = of_int n" by (auto simp: nonpos_Ints_def)
  hence "-n \<ge> 0" "-x = of_int (-n)" by (simp_all add: eq_commute minus_equation_iff[of x])
  thus "-x \<in> \<nat>" unfolding Nats_altdef1 by blast
qed

lemma uminus_in_nonpos_Ints_iff: "-x \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<nat>"
  using uminus_in_Nats_iff[of "-x"] by simp

lemma nonpos_Ints_mult: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x * y \<in> \<nat>"
  using Nats_mult[of "-x" "-y"] by (simp add: uminus_in_Nats_iff)

lemma Nats_mult_nonpos_Ints: "x \<in> \<nat> \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x * y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_mult[of x "-y"] by (simp add: uminus_in_Nats_iff)

lemma nonpos_Ints_mult_Nats:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<nat> \<Longrightarrow> x * y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_mult[of "-x" y] by (simp add: uminus_in_Nats_iff)

lemma nonpos_Ints_add:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x + y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_add[of "-x" "-y"] uminus_in_Nats_iff[of "y+x", simplified minus_add]
  by (simp add: uminus_in_Nats_iff add.commute)

lemma nonpos_Ints_diff_Nats:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<nat> \<Longrightarrow> x - y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_add[of "-x" "y"] uminus_in_Nats_iff[of "x-y", simplified minus_add]
  by (simp add: uminus_in_Nats_iff add.commute)

lemma Nats_diff_nonpos_Ints:
  "x \<in> \<nat> \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x - y \<in> \<nat>"
  using Nats_add[of "x" "-y"] by (simp add: uminus_in_Nats_iff add.commute)

lemma plus_of_nat_eq_0_imp: "z + of_nat n = 0 \<Longrightarrow> z \<in> \<int>\<^sub>\<le>\<^sub>0"
proof -
  assume "z + of_nat n = 0"
  hence A: "z = - of_nat n" by (simp add: eq_neg_iff_add_eq_0)
  show "z \<in> \<int>\<^sub>\<le>\<^sub>0" by (subst A) simp
qed

subsection\<open>Non-negative reals\<close>

definition nonneg_Reals :: "'a::real_algebra_1 set"  ("\<real>\<^sub>\<ge>\<^sub>0")
  where "\<real>\<^sub>\<ge>\<^sub>0 = {of_real r | r. r \<ge> 0}"

lemma nonneg_Reals_of_real_iff [simp]: "of_real r \<in> \<real>\<^sub>\<ge>\<^sub>0 \<longleftrightarrow> r \<ge> 0"
  by (force simp add: nonneg_Reals_def)

lemma nonneg_Reals_subset_Reals: "\<real>\<^sub>\<ge>\<^sub>0 \<subseteq> \<real>"
  unfolding nonneg_Reals_def Reals_def by blast

lemma nonneg_Reals_Real [dest]: "x \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> x \<in> \<real>"
  unfolding nonneg_Reals_def Reals_def by blast

lemma nonneg_Reals_of_nat_I [simp]: "of_nat n \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis nonneg_Reals_of_real_iff of_nat_0_le_iff of_real_of_nat_eq)

lemma nonneg_Reals_cases:
  assumes "x \<in> \<real>\<^sub>\<ge>\<^sub>0"
  obtains r where "x = of_real r" "r \<ge> 0"
  using assms unfolding nonneg_Reals_def by (auto elim!: Reals_cases)

lemma nonneg_Reals_zero_I [simp]: "0 \<in> \<real>\<^sub>\<ge>\<^sub>0"
  unfolding nonneg_Reals_def by auto

lemma nonneg_Reals_one_I [simp]: "1 \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis (mono_tags, lifting) nonneg_Reals_of_nat_I of_nat_1)

lemma nonneg_Reals_minus_one_I [simp]: "-1 \<notin> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis nonneg_Reals_of_real_iff le_minus_one_simps(3) of_real_1 of_real_def real_vector.scale_minus_left)

lemma nonneg_Reals_numeral_I [simp]: "numeral w \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis (no_types) nonneg_Reals_of_nat_I of_nat_numeral)

lemma nonneg_Reals_minus_numeral_I [simp]: "- numeral w \<notin> \<real>\<^sub>\<ge>\<^sub>0"
  using nonneg_Reals_of_real_iff not_zero_le_neg_numeral by fastforce

lemma nonneg_Reals_add_I [simp]: "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a + b \<in> \<real>\<^sub>\<ge>\<^sub>0"
apply (simp add: nonneg_Reals_def)
apply clarify
apply (rename_tac r s)
apply (rule_tac x="r+s" in exI, auto)
done

lemma nonneg_Reals_mult_I [simp]: "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a * b \<in> \<real>\<^sub>\<ge>\<^sub>0"
  unfolding nonneg_Reals_def  by (auto simp: of_real_def)

lemma nonneg_Reals_inverse_I [simp]:
  fixes a :: "'a::real_div_algebra"
  shows "a \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> inverse a \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (simp add: nonneg_Reals_def image_iff) (metis inverse_nonnegative_iff_nonnegative of_real_inverse)

lemma nonneg_Reals_divide_I [simp]:
  fixes a :: "'a::real_div_algebra"
  shows "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a / b \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (simp add: divide_inverse)

lemma nonneg_Reals_pow_I [simp]: "a \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> a^n \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (induction n) auto

lemma complex_nonneg_Reals_iff: "z \<in> \<real>\<^sub>\<ge>\<^sub>0 \<longleftrightarrow> Re z \<ge> 0 \<and> Im z = 0"
  by (auto simp: nonneg_Reals_def) (metis complex_of_real_def complex_surj)

lemma ii_not_nonneg_Reals [iff]: "\<i> \<notin> \<real>\<^sub>\<ge>\<^sub>0"
  by (simp add: complex_nonneg_Reals_iff)

subsection\<open>Non-positive reals\<close>

definition nonpos_Reals :: "'a::real_algebra_1 set"  ("\<real>\<^sub>\<le>\<^sub>0")
  where "\<real>\<^sub>\<le>\<^sub>0 = {of_real r | r. r \<le> 0}"

lemma nonpos_Reals_of_real_iff [simp]: "of_real r \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> r \<le> 0"
  by (force simp add: nonpos_Reals_def)

lemma nonpos_Reals_subset_Reals: "\<real>\<^sub>\<le>\<^sub>0 \<subseteq> \<real>"
  unfolding nonpos_Reals_def Reals_def by blast

lemma nonpos_Ints_subset_nonpos_Reals: "\<int>\<^sub>\<le>\<^sub>0 \<subseteq> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonpos_Ints_cases nonpos_Ints_nonpos nonpos_Ints_of_int
    nonpos_Reals_of_real_iff of_real_of_int_eq subsetI)

lemma nonpos_Reals_of_nat_iff [simp]: "of_nat n \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> n=0"
  by (metis nonpos_Reals_of_real_iff of_nat_le_0_iff of_real_of_nat_eq)

lemma nonpos_Reals_Real [dest]: "x \<in> \<real>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<in> \<real>"
  unfolding nonpos_Reals_def Reals_def by blast

lemma nonpos_Reals_cases:
  assumes "x \<in> \<real>\<^sub>\<le>\<^sub>0"
  obtains r where "x = of_real r" "r \<le> 0"
  using assms unfolding nonpos_Reals_def by (auto elim!: Reals_cases)

lemma uminus_nonneg_Reals_iff [simp]: "-x \<in> \<real>\<^sub>\<ge>\<^sub>0 \<longleftrightarrow> x \<in> \<real>\<^sub>\<le>\<^sub>0"
  apply (auto simp: nonpos_Reals_def nonneg_Reals_def)
  apply (metis nonpos_Reals_of_real_iff minus_minus neg_le_0_iff_le of_real_minus)
  done

lemma uminus_nonpos_Reals_iff [simp]: "-x \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis (no_types) minus_minus uminus_nonneg_Reals_iff)

lemma nonpos_Reals_zero_I [simp]: "0 \<in> \<real>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Reals_def by force

lemma nonpos_Reals_one_I [simp]: "1 \<notin> \<real>\<^sub>\<le>\<^sub>0"
  using nonneg_Reals_minus_one_I uminus_nonneg_Reals_iff by blast

lemma nonpos_Reals_numeral_I [simp]: "numeral w \<notin> \<real>\<^sub>\<le>\<^sub>0"
  using nonneg_Reals_minus_numeral_I uminus_nonneg_Reals_iff by blast

lemma nonpos_Reals_add_I [simp]: "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; b \<in> \<real>\<^sub>\<le>\<^sub>0\<rbrakk> \<Longrightarrow> a + b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_add_I add_uminus_conv_diff minus_diff_eq minus_minus uminus_nonpos_Reals_iff)

lemma nonpos_Reals_mult_I1: "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<le>\<^sub>0\<rbrakk> \<Longrightarrow> a * b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_mult_I mult_minus_right uminus_nonneg_Reals_iff)

lemma nonpos_Reals_mult_I2: "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a * b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_mult_I mult_minus_left uminus_nonneg_Reals_iff)

lemma nonpos_Reals_mult_of_nat_iff:
  fixes a:: "'a :: real_div_algebra" shows "a * of_nat n \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> a \<in> \<real>\<^sub>\<le>\<^sub>0 \<or> n=0"
  apply (auto intro: nonpos_Reals_mult_I2)
  apply (auto simp: nonpos_Reals_def)
  apply (rule_tac x="r/n" in exI)
  apply (auto simp: field_split_simps)
  done

lemma nonpos_Reals_inverse_I:
    fixes a :: "'a::real_div_algebra"
    shows "a \<in> \<real>\<^sub>\<le>\<^sub>0 \<Longrightarrow> inverse a \<in> \<real>\<^sub>\<le>\<^sub>0"
  using nonneg_Reals_inverse_I uminus_nonneg_Reals_iff by fastforce

lemma nonpos_Reals_divide_I1:
    fixes a :: "'a::real_div_algebra"
    shows "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<le>\<^sub>0\<rbrakk> \<Longrightarrow> a / b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (simp add: nonpos_Reals_inverse_I nonpos_Reals_mult_I1 divide_inverse)

lemma nonpos_Reals_divide_I2:
    fixes a :: "'a::real_div_algebra"
    shows "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a / b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_divide_I minus_divide_left uminus_nonneg_Reals_iff)

lemma nonpos_Reals_divide_of_nat_iff:
  fixes a:: "'a :: real_div_algebra" shows "a / of_nat n \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> a \<in> \<real>\<^sub>\<le>\<^sub>0 \<or> n=0"
  apply (auto intro: nonpos_Reals_divide_I2)
  apply (auto simp: nonpos_Reals_def)
  apply (rule_tac x="r*n" in exI)
  apply (auto simp: field_split_simps mult_le_0_iff)
  done

lemma nonpos_Reals_inverse_iff [simp]:
  fixes a :: "'a::real_div_algebra"
  shows "inverse a \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> a \<in> \<real>\<^sub>\<le>\<^sub>0"
  using nonpos_Reals_inverse_I by fastforce

lemma nonpos_Reals_pow_I: "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; odd n\<rbrakk> \<Longrightarrow> a^n \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_pow_I power_minus_odd uminus_nonneg_Reals_iff)

lemma complex_nonpos_Reals_iff: "z \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> Re z \<le> 0 \<and> Im z = 0"
   using complex_is_Real_iff by (force simp add: nonpos_Reals_def)

lemma ii_not_nonpos_Reals [iff]: "\<i> \<notin> \<real>\<^sub>\<le>\<^sub>0"
  by (simp add: complex_nonpos_Reals_iff)

end