(*
   File:     HOL/Analysis/Ball_Volume.thy
   Author:   Manuel Eberl, TU München
*)

section \<open>The Volume of an \<open>n\<close>-Dimensional Ball\<close>

theory Ball_Volume
  imports Gamma_Function Lebesgue_Integral_Substitution
begin

text \<open>
  We define the volume of the unit ball in terms of the Gamma function. Note that the
  dimension need not be an integer; we also allow fractional dimensions, although we do
  not use this case or prove anything about it for now.
\<close>
definition\<^marker>\<open>tag important\<close> unit_ball_vol :: "real \<Rightarrow> real" where
  "unit_ball_vol n = pi powr (n / 2) / Gamma (n / 2 + 1)"

lemma unit_ball_vol_pos [simp]: "n \<ge> 0 \<Longrightarrow> unit_ball_vol n > 0"
  by (force simp: unit_ball_vol_def intro: divide_nonneg_pos)

lemma unit_ball_vol_nonneg [simp]: "n \<ge> 0 \<Longrightarrow> unit_ball_vol n \<ge> 0"
  by (simp add: dual_order.strict_implies_order)

text \<open>
  We first need the value of the following integral, which is at the core of
  computing the measure of an \<open>n + 1\<close>-dimensional ball in terms of the measure of an
  \<open>n\<close>-dimensional one.
\<close>
lemma emeasure_cball_aux_integral:
  "(\<integral>\<^sup>+x. indicator {-1..1} x * sqrt (1 - x\<^sup>2) ^ n \<partial>lborel) =
      ennreal (Beta (1 / 2) (real n / 2 + 1))"
proof -
  have "((\<lambda>t. t powr (-1 / 2) * (1 - t) powr (real n / 2)) has_integral
          Beta (1 / 2) (real n / 2 + 1)) {0..1}"
    using has_integral_Beta_real[of "1/2" "n / 2 + 1"] by simp
  from nn_integral_has_integral_lebesgue[OF _ this] have
     "ennreal (Beta (1 / 2) (real n / 2 + 1)) =
        nn_integral lborel (\<lambda>t. ennreal (t powr (-1 / 2) * (1 - t) powr (real n / 2) *
                                indicator {0^2..1^2} t))"
    by (simp add: mult_ac ennreal_mult' ennreal_indicator)
  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (x\<^sup>2 powr - (1 / 2) * (1 - x\<^sup>2) powr (real n / 2) * (2 * x) *
                          indicator {0..1} x) \<partial>lborel)"
    by (subst nn_integral_substitution[where g = "\<lambda>x. x ^ 2" and g' = "\<lambda>x. 2 * x"])
       (auto intro!: derivative_eq_intros continuous_intros simp: set_borel_measurable_def)
  also have "\<dots> = (\<integral>\<^sup>+ x. 2 * ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {0..1} x) \<partial>lborel)"
    by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"])
       (auto simp: indicator_def powr_minus powr_half_sqrt field_split_simps ennreal_mult')
  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {0..1} x) \<partial>lborel) +
                    (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {0..1} x) \<partial>lborel)"
    (is "_ = ?I + _") by (simp add: mult_2 nn_integral_add)
  also have "?I = (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {-1..0} x) \<partial>lborel)"
    by (subst nn_integral_real_affine[of _ "-1" 0])
       (auto simp: indicator_def intro!: nn_integral_cong)
  hence "?I + ?I = \<dots> + ?I" by simp
  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) *
                    (indicator {-1..0} x + indicator{0..1} x)) \<partial>lborel)"
    by (subst nn_integral_add [symmetric]) (auto simp: algebra_simps)
  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {-1..1} x) \<partial>lborel)"
    by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"]) (auto simp: indicator_def)
  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (indicator {-1..1} x * sqrt (1 - x\<^sup>2) ^ n) \<partial>lborel)"
    by (intro nn_integral_cong_AE AE_I[of _ _ "{1, -1}"])
       (auto simp: powr_half_sqrt [symmetric] indicator_def abs_square_le_1
          abs_square_eq_1 powr_def exp_of_nat_mult [symmetric] emeasure_lborel_countable)
  finally show ?thesis ..
qed

lemma real_sqrt_le_iff': "x \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> sqrt x \<le> y \<longleftrightarrow> x \<le> y ^ 2"
  using real_le_lsqrt sqrt_le_D by blast

text \<open>
  Isabelle's type system makes it very difficult to do an induction over the dimension
  of a Euclidean space type, because the type would change in the inductive step. To avoid
  this problem, we instead formulate the problem in a more concrete way by unfolding the
  definition of the Euclidean norm.
\<close>
lemma emeasure_cball_aux:
  assumes "finite A" "r > 0"
  shows   "emeasure (Pi\<^sub>M A (\<lambda>_. lborel))
             ({f. sqrt (\<Sum>i\<in>A. (f i)\<^sup>2) \<le> r} \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))) =
             ennreal (unit_ball_vol (real (card A)) * r ^ card A)"
  using assms
proof (induction arbitrary: r)
  case (empty r)
  thus ?case
    by (simp add: unit_ball_vol_def space_PiM)
next
  case (insert i A r)
  interpret product_sigma_finite "\<lambda>_. lborel"
    by standard
  have "emeasure (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))
            ({f. sqrt (\<Sum>i\<in>insert i A. (f i)\<^sup>2) \<le> r} \<inter> space (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))) =
        nn_integral (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))
          (indicator ({f. sqrt (\<Sum>i\<in>insert i A. (f i)\<^sup>2) \<le> r} \<inter>
          space (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))))"
    by (subst nn_integral_indicator) auto
  also have "\<dots> = (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. indicator ({f. sqrt ((f i)\<^sup>2 + (\<Sum>i\<in>A. (f i)\<^sup>2)) \<le> r} \<inter>
                                space (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))) (x(i := y))
                   \<partial>Pi\<^sub>M A (\<lambda>_. lborel) \<partial>lborel)"
    using insert.prems insert.hyps by (subst product_nn_integral_insert_rev) auto
  also have "\<dots> = (\<integral>\<^sup>+ (y::real). \<integral>\<^sup>+ x. indicator {-r..r} y * indicator ({f. sqrt ((\<Sum>i\<in>A. (f i)\<^sup>2)) \<le>
               sqrt (r ^ 2 - y ^ 2)} \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))) x \<partial>Pi\<^sub>M A (\<lambda>_. lborel) \<partial>lborel)"
  proof (intro nn_integral_cong, goal_cases)
    case (1 y f)
    have *: "y \<in> {-r..r}" if "y ^ 2 + c \<le> r ^ 2" "c \<ge> 0" for c
    proof -
      have "y ^ 2 \<le> y ^ 2 + c" using that by simp
      also have "\<dots> \<le> r ^ 2" by fact
      finally show ?thesis
        using \<open>r > 0\<close> by (simp add: power2_le_iff_abs_le abs_if split: if_splits)
    qed
    have "(\<Sum>x\<in>A. (if x = i then y else f x)\<^sup>2) = (\<Sum>x\<in>A. (f x)\<^sup>2)"
      using insert.hyps by (intro sum.cong) auto
    thus ?case using 1 \<open>r > 0\<close>
      by (auto simp: sum_nonneg real_sqrt_le_iff' indicator_def PiE_def space_PiM dest!: *)
  qed
  also have "\<dots> = (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * (\<integral>\<^sup>+ x. indicator ({f. sqrt ((\<Sum>i\<in>A. (f i)\<^sup>2))
                                   \<le> sqrt (r ^ 2 - y ^ 2)} \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))) x
                  \<partial>Pi\<^sub>M A (\<lambda>_. lborel)) \<partial>lborel)" by (subst nn_integral_cmult) auto
  also have "\<dots> = (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * emeasure (PiM A (\<lambda>_. lborel))
      ({f. sqrt ((\<Sum>i\<in>A. (f i)\<^sup>2)) \<le> sqrt (r ^ 2 - y ^ 2)} \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))) \<partial>lborel)"
    using \<open>finite A\<close> by (intro nn_integral_cong, subst nn_integral_indicator) auto
  also have "\<dots> = (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * ennreal (unit_ball_vol (real (card A)) *
                                  (sqrt (r ^ 2 - y ^ 2)) ^ card A) \<partial>lborel)"
  proof (intro nn_integral_cong_AE, goal_cases)
    case 1
    have "AE y in lborel. y \<notin> {-r,r}"
      by (intro AE_not_in countable_imp_null_set_lborel) auto
    thus ?case
    proof eventually_elim
      case (elim y)
      show ?case
      proof (cases "y \<in> {-r<..<r}")
        case True
        hence "y\<^sup>2 < r\<^sup>2" by (subst real_sqrt_less_iff [symmetric]) auto
        thus ?thesis by (subst insert.IH) (auto)
      qed (insert elim, auto)
    qed
  qed
  also have "\<dots> = ennreal (unit_ball_vol (real (card A))) *
                    (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * (sqrt (r ^ 2 - y ^ 2)) ^ card A \<partial>lborel)"
    by (subst nn_integral_cmult [symmetric])
       (auto simp: mult_ac ennreal_mult' [symmetric] indicator_def intro!: nn_integral_cong)
  also have "(\<integral>\<^sup>+ (y::real). indicator {-r..r} y * (sqrt (r ^ 2 - y ^ 2)) ^ card A \<partial>lborel) =
               (\<integral>\<^sup>+ (y::real). r ^ card A * indicator {-1..1} y * (sqrt (1 - y ^ 2)) ^ card A
               \<partial>(distr lborel borel ((*) (1/r))))" using \<open>r > 0\<close>
    by (subst nn_integral_distr)
       (auto simp: indicator_def field_simps real_sqrt_divide intro!: nn_integral_cong)
  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (r ^ Suc (card A)) *
               (indicator {- 1..1} x * sqrt (1 - x\<^sup>2) ^ card A) \<partial>lborel)" using \<open>r > 0\<close>
    by (subst lborel_distr_mult) (auto simp: nn_integral_density ennreal_mult' [symmetric] mult_ac)
  also have "\<dots> = ennreal (r ^ Suc (card A)) * (\<integral>\<^sup>+ x. indicator {- 1..1} x *
                    sqrt (1 - x\<^sup>2) ^ card A \<partial>lborel)"
    by (subst nn_integral_cmult) auto
  also note emeasure_cball_aux_integral
  also have "ennreal (unit_ball_vol (real (card A))) * (ennreal (r ^ Suc (card A)) *
                 ennreal (Beta (1/2) (card A / 2 + 1))) =
               ennreal (unit_ball_vol (card A) * Beta (1/2) (card A / 2 + 1) * r ^ Suc (card A))"
    using \<open>r > 0\<close> by (simp add: ennreal_mult' [symmetric] mult_ac)
  also have "unit_ball_vol (card A) * Beta (1/2) (card A / 2 + 1) = unit_ball_vol (Suc (card A))"
    by (auto simp: unit_ball_vol_def Beta_def Gamma_eq_zero_iff field_simps
          Gamma_one_half_real powr_half_sqrt [symmetric] powr_add [symmetric])
  also have "Suc (card A) = card (insert i A)" using insert.hyps by simp
  finally show ?case .
qed

text \<open>
  We now get the main theorem very easily by just applying the above lemma.
\<close>
context
  fixes c :: "'a :: euclidean_space" and r :: real
  assumes r: "r \<ge> 0"
begin

theorem\<^marker>\<open>tag unimportant\<close> emeasure_cball:
  "emeasure lborel (cball c r) = ennreal (unit_ball_vol (DIM('a)) * r ^ DIM('a))"
proof (cases "r = 0")
  case False
  with r have r: "r > 0" by simp
  have "(lborel :: 'a measure) =
          distr (Pi\<^sub>M Basis (\<lambda>_. lborel)) borel (\<lambda>f. \<Sum>b\<in>Basis. f b *\<^sub>R b)"
    by (rule lborel_eq)
  also have "emeasure \<dots> (cball 0 r) =
               emeasure (Pi\<^sub>M Basis (\<lambda>_. lborel))
               ({y. dist 0 (\<Sum>b\<in>Basis. y b *\<^sub>R b :: 'a) \<le> r} \<inter> space (Pi\<^sub>M Basis (\<lambda>_. lborel)))"
    by (subst emeasure_distr) (auto simp: cball_def)
  also have "{f. dist 0 (\<Sum>b\<in>Basis. f b *\<^sub>R b :: 'a) \<le> r} = {f. sqrt (\<Sum>i\<in>Basis. (f i)\<^sup>2) \<le> r}"
    by (subst euclidean_dist_l2) (auto simp: L2_set_def)
  also have "emeasure (Pi\<^sub>M Basis (\<lambda>_. lborel)) (\<dots> \<inter> space (Pi\<^sub>M Basis (\<lambda>_. lborel))) =
               ennreal (unit_ball_vol (real DIM('a)) * r ^ DIM('a))"
    using r by (subst emeasure_cball_aux) simp_all
  also have "emeasure lborel (cball 0 r :: 'a set) =
               emeasure (distr lborel borel (\<lambda>x. c + x)) (cball c r)"
    by (subst emeasure_distr) (auto simp: cball_def dist_norm norm_minus_commute)
  also have "distr lborel borel (\<lambda>x. c + x) = lborel"
    using lborel_affine[of 1 c] by (simp add: density_1)
  finally show ?thesis .
qed auto

corollary\<^marker>\<open>tag unimportant\<close> content_cball:
  "content (cball c r) = unit_ball_vol (DIM('a)) * r ^ DIM('a)"
  by (simp add: measure_def emeasure_cball r)

corollary\<^marker>\<open>tag unimportant\<close> emeasure_ball:
  "emeasure lborel (ball c r) = ennreal (unit_ball_vol (DIM('a)) * r ^ DIM('a))"
proof -
  from negligible_sphere[of c r] have "sphere c r \<in> null_sets lborel"
    by (auto simp: null_sets_completion_iff negligible_iff_null_sets negligible_convex_frontier)
  hence "emeasure lborel (ball c r \<union> sphere c r :: 'a set) = emeasure lborel (ball c r :: 'a set)"
    by (intro emeasure_Un_null_set) auto
  also have "ball c r \<union> sphere c r = (cball c r :: 'a set)" by auto
  also have "emeasure lborel \<dots> = ennreal (unit_ball_vol (real DIM('a)) * r ^ DIM('a))"
    by (rule emeasure_cball)
  finally show ?thesis ..
qed

corollary\<^marker>\<open>tag important\<close> content_ball:
  "content (ball c r) = unit_ball_vol (DIM('a)) * r ^ DIM('a)"
  by (simp add: measure_def r emeasure_ball)

end

text \<open>
  Lastly, we now prove some nicer explicit formulas for the volume of the unit balls in
  the cases of even and odd integer dimensions.
\<close>
lemma unit_ball_vol_even:
  "unit_ball_vol (real (2 * n)) = pi ^ n / fact n"
  by (simp add: unit_ball_vol_def add_ac powr_realpow Gamma_fact)

lemma unit_ball_vol_odd':
        "unit_ball_vol (real (2 * n + 1)) = pi ^ n / pochhammer (1 / 2) (Suc n)"
  and unit_ball_vol_odd:
        "unit_ball_vol (real (2 * n + 1)) =
           (2 ^ (2 * Suc n) * fact (Suc n)) / fact (2 * Suc n) * pi ^ n"
proof -
  have "unit_ball_vol (real (2 * n + 1)) =
          pi powr (real n + 1 / 2) / Gamma (1 / 2 + real (Suc n))"
    by (simp add: unit_ball_vol_def field_simps)
  also have "pochhammer (1 / 2) (Suc n) = Gamma (1 / 2 + real (Suc n)) / Gamma (1 / 2)"
    by (intro pochhammer_Gamma) auto
  hence "Gamma (1 / 2 + real (Suc n)) = sqrt pi * pochhammer (1 / 2) (Suc n)"
    by (simp add: Gamma_one_half_real)
  also have "pi powr (real n + 1 / 2) / \<dots> = pi ^ n / pochhammer (1 / 2) (Suc n)"
    by (simp add: powr_add powr_half_sqrt powr_realpow)
  finally show "unit_ball_vol (real (2 * n + 1)) = \<dots>" .
  also have "pochhammer (1 / 2 :: real) (Suc n) =
               fact (2 * Suc n) / (2 ^ (2 * Suc n) * fact (Suc n))"
    using fact_double[of "Suc n", where ?'a = real] by (simp add: divide_simps mult_ac)
  also have "pi ^n / \<dots> = (2 ^ (2 * Suc n) * fact (Suc n)) / fact (2 * Suc n) * pi ^ n"
    by simp
  finally show "unit_ball_vol (real (2 * n + 1)) = \<dots>" .
qed

lemma unit_ball_vol_numeral:
  "unit_ball_vol (numeral (Num.Bit0 n)) = pi ^ numeral n / fact (numeral n)" (is ?th1)
  "unit_ball_vol (numeral (Num.Bit1 n)) = 2 ^ (2 * Suc (numeral n)) * fact (Suc (numeral n)) /
    fact (2 * Suc (numeral n)) * pi ^ numeral n" (is ?th2)
proof -
  have "numeral (Num.Bit0 n) = (2 * numeral n :: nat)"
    by (simp only: numeral_Bit0 mult_2 ring_distribs)
  also have "unit_ball_vol \<dots> = pi ^ numeral n / fact (numeral n)"
    by (rule unit_ball_vol_even)
  finally show ?th1 by simp
next
  have "numeral (Num.Bit1 n) = (2 * numeral n + 1 :: nat)"
    by (simp only: numeral_Bit1 mult_2)
  also have "unit_ball_vol \<dots> = 2 ^ (2 * Suc (numeral n)) * fact (Suc (numeral n)) /
                                  fact (2 * Suc (numeral n)) * pi ^ numeral n"
    by (rule unit_ball_vol_odd)
  finally show ?th2 by simp
qed

lemmas eval_unit_ball_vol = unit_ball_vol_numeral fact_numeral

text \<open>
  Just for fun, we compute the volume of unit balls for a few dimensions.
\<close>
lemma unit_ball_vol_0 [simp]: "unit_ball_vol 0 = 1"
  using unit_ball_vol_even[of 0] by simp

lemma unit_ball_vol_1 [simp]: "unit_ball_vol 1 = 2"
  using unit_ball_vol_odd[of 0] by simp

corollary\<^marker>\<open>tag unimportant\<close>
          unit_ball_vol_2: "unit_ball_vol 2 = pi"
      and unit_ball_vol_3: "unit_ball_vol 3 = 4 / 3 * pi"
      and unit_ball_vol_4: "unit_ball_vol 4 = pi\<^sup>2 / 2"
      and unit_ball_vol_5: "unit_ball_vol 5 = 8 / 15 * pi\<^sup>2"
  by (simp_all add: eval_unit_ball_vol)

corollary\<^marker>\<open>tag unimportant\<close> circle_area:
  "r \<ge> 0 \<Longrightarrow> content (ball c r :: (real ^ 2) set) = r ^ 2 * pi"
  by (simp add: content_ball unit_ball_vol_2)

corollary\<^marker>\<open>tag unimportant\<close> sphere_volume:
  "r \<ge> 0 \<Longrightarrow> content (ball c r :: (real ^ 3) set) = 4 / 3 * r ^ 3 * pi"
  by (simp add: content_ball unit_ball_vol_3)

text \<open>
  Useful equivalent forms
\<close>
corollary\<^marker>\<open>tag unimportant\<close> content_ball_eq_0_iff [simp]: "content (ball c r) = 0 \<longleftrightarrow> r \<le> 0"
proof -
  have "r > 0 \<Longrightarrow> content (ball c r) > 0"
    by (simp add: content_ball unit_ball_vol_def)
  then show ?thesis
    by (fastforce simp: ball_empty)
qed

corollary\<^marker>\<open>tag unimportant\<close> content_ball_gt_0_iff [simp]: "0 < content (ball z r) \<longleftrightarrow> 0 < r"
  by (auto simp: zero_less_measure_iff)

corollary\<^marker>\<open>tag unimportant\<close> content_cball_eq_0_iff [simp]: "content (cball c r) = 0 \<longleftrightarrow> r \<le> 0"
proof (cases "r = 0")
  case False
  moreover have "r > 0 \<Longrightarrow> content (cball c r) > 0"
    by (simp add: content_cball unit_ball_vol_def)
  ultimately show ?thesis
    by fastforce
qed auto

corollary\<^marker>\<open>tag unimportant\<close> content_cball_gt_0_iff [simp]: "0 < content (cball z r) \<longleftrightarrow> 0 < r"
  by (auto simp: zero_less_measure_iff)

end


(*  Title:      HOL/Decision_Procs/Polynomial_List.thy
    Author:     Amine Chaieb
*)

section \<open>Univariate Polynomials as lists\<close>

theory Polynomial_List
imports Complex_Main
begin

text \<open>Application of polynomial as a function.\<close>

primrec (in semiring_0) poly :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a"
where
  poly_Nil: "poly [] x = 0"
| poly_Cons: "poly (h # t) x = h + x * poly t x"

subsection \<open>Arithmetic Operations on Polynomials\<close>

text \<open>Addition\<close>
primrec (in semiring_0) padd :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"  (infixl "+++" 65)
where
  padd_Nil: "[] +++ l2 = l2"
| padd_Cons: "(h # t) +++ l2 = (if l2 = [] then h # t else (h + hd l2) # (t +++ tl l2))"

text \<open>Multiplication by a constant\<close>
primrec (in semiring_0) cmult :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"  (infixl "%*" 70) where
  cmult_Nil: "c %* [] = []"
| cmult_Cons: "c %* (h#t) = (c * h)#(c %* t)"

text \<open>Multiplication by a polynomial\<close>
primrec (in semiring_0) pmult :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"  (infixl "***" 70)
where
  pmult_Nil: "[] *** l2 = []"
| pmult_Cons: "(h # t) *** l2 = (if t = [] then h %* l2 else (h %* l2) +++ (0 # (t *** l2)))"

text \<open>Repeated multiplication by a polynomial\<close>
primrec (in semiring_0) mulexp :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a  list \<Rightarrow> 'a list"
where
  mulexp_zero: "mulexp 0 p q = q"
| mulexp_Suc: "mulexp (Suc n) p q = p *** mulexp n p q"

text \<open>Exponential\<close>
primrec (in semiring_1) pexp :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list"  (infixl "%^" 80)
where
  pexp_0: "p %^ 0 = [1]"
| pexp_Suc: "p %^ (Suc n) = p *** (p %^ n)"

text \<open>Quotient related value of dividing a polynomial by x + a.
  Useful for divisor properties in inductive proofs.\<close>
primrec (in field) "pquot" :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
where
  pquot_Nil: "pquot [] a = []"
| pquot_Cons: "pquot (h # t) a =
    (if t = [] then [h] else (inverse a * (h - hd( pquot t a))) # pquot t a)"

text \<open>Normalization of polynomials (remove extra 0 coeff).\<close>
primrec (in semiring_0) pnormalize :: "'a list \<Rightarrow> 'a list"
where
  pnormalize_Nil: "pnormalize [] = []"
| pnormalize_Cons: "pnormalize (h # p) =
    (if pnormalize p = [] then (if h = 0 then [] else [h]) else h # pnormalize p)"

definition (in semiring_0) "pnormal p \<longleftrightarrow> pnormalize p = p \<and> p \<noteq> []"
definition (in semiring_0) "nonconstant p \<longleftrightarrow> pnormal p \<and> (\<forall>x. p \<noteq> [x])"

text \<open>Other definitions.\<close>

definition (in ring_1) poly_minus :: "'a list \<Rightarrow> 'a list" ("-- _" [80] 80)
  where "-- p = (- 1) %* p"

definition (in semiring_0) divides :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"  (infixl "divides" 70)
  where "p1 divides p2 \<longleftrightarrow> (\<exists>q. poly p2 = poly(p1 *** q))"

lemma (in semiring_0) dividesI: "poly p2 = poly (p1 *** q) \<Longrightarrow> p1 divides p2"
  by (auto simp add: divides_def)

lemma (in semiring_0) dividesE:
  assumes "p1 divides p2"
  obtains q where "poly p2 = poly (p1 *** q)"
  using assms by (auto simp add: divides_def)

\<comment> \<open>order of a polynomial\<close>
definition (in ring_1) order :: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
  where "order a p = (SOME n. ([-a, 1] %^ n) divides p \<and> \<not> (([-a, 1] %^ (Suc n)) divides p))"

\<comment> \<open>degree of a polynomial\<close>
definition (in semiring_0) degree :: "'a list \<Rightarrow> nat"
  where "degree p = length (pnormalize p) - 1"

\<comment> \<open>squarefree polynomials --- NB with respect to real roots only\<close>
definition (in ring_1) rsquarefree :: "'a list \<Rightarrow> bool"
  where "rsquarefree p \<longleftrightarrow> poly p \<noteq> poly [] \<and> (\<forall>a. order a p = 0 \<or> order a p = 1)"

context semiring_0
begin

lemma padd_Nil2[simp]: "p +++ [] = p"
  by (induct p) auto

lemma padd_Cons_Cons: "(h1 # p1) +++ (h2 # p2) = (h1 + h2) # (p1 +++ p2)"
  by auto

lemma pminus_Nil: "-- [] = []"
  by (simp add: poly_minus_def)

lemma pmult_singleton: "[h1] *** p1 = h1 %* p1" by simp

end

lemma (in semiring_1) poly_ident_mult[simp]: "1 %* t = t"
  by (induct t) auto

lemma (in semiring_0) poly_simple_add_Cons[simp]: "[a] +++ (0 # t) = a # t"
  by simp

text \<open>Handy general properties.\<close>

lemma (in comm_semiring_0) padd_commut: "b +++ a = a +++ b"
proof (induct b arbitrary: a)
  case Nil
  then show ?case
    by auto
next
  case (Cons b bs a)
  then show ?case
    by (cases a) (simp_all add: add.commute)
qed

lemma (in comm_semiring_0) padd_assoc: "(a +++ b) +++ c = a +++ (b +++ c)"
proof (induct a arbitrary: b c)
  case Nil
  then show ?case
    by simp
next
  case Cons
  then show ?case
    by (cases b) (simp_all add: ac_simps)
qed

lemma (in semiring_0) poly_cmult_distr: "a %* (p +++ q) = a %* p +++ a %* q"
proof (induct p arbitrary: q)
  case Nil
  then show ?case
    by simp
next
  case Cons
  then show ?case
    by (cases q) (simp_all add: distrib_left)
qed

lemma (in ring_1) pmult_by_x[simp]: "[0, 1] *** t = 0 # t"
proof (induct t)
  case Nil
  then show ?case
    by simp
next
  case (Cons a t)
  then show ?case
    by (cases t) (auto simp add: padd_commut)
qed

text \<open>Properties of evaluation of polynomials.\<close>

lemma (in semiring_0) poly_add: "poly (p1 +++ p2) x = poly p1 x + poly p2 x"
proof (induct p1 arbitrary: p2)
  case Nil
  then show ?case
    by simp
next
  case (Cons a as p2)
  then show ?case
    by (cases p2) (simp_all add: ac_simps distrib_left)
qed

lemma (in comm_semiring_0) poly_cmult: "poly (c %* p) x = c * poly p x"
proof (induct p)
  case Nil
  then show ?case
    by simp
next
  case Cons
  then show ?case
    by (cases "x = zero") (auto simp add: distrib_left ac_simps)
qed

lemma (in comm_semiring_0) poly_cmult_map: "poly (map (op * c) p) x = c * poly p x"
  by (induct p) (auto simp add: distrib_left ac_simps)

lemma (in comm_ring_1) poly_minus: "poly (-- p) x = - (poly p x)"
  by (simp add: poly_minus_def) (auto simp add: poly_cmult)

lemma (in comm_semiring_0) poly_mult: "poly (p1 *** p2) x = poly p1 x * poly p2 x"
proof (induct p1 arbitrary: p2)
  case Nil
  then show ?case
    by simp
next
  case (Cons a as)
  then show ?case
    by (cases as) (simp_all add: poly_cmult poly_add distrib_right distrib_left ac_simps)
qed

class idom_char_0 = idom + ring_char_0

subclass (in field_char_0) idom_char_0 ..

lemma (in comm_ring_1) poly_exp: "poly (p %^ n) x = (poly p x) ^ n"
  by (induct n) (auto simp add: poly_cmult poly_mult)

text \<open>More Polynomial Evaluation lemmas.\<close>

lemma (in semiring_0) poly_add_rzero[simp]: "poly (a +++ []) x = poly a x"
  by simp

lemma (in comm_semiring_0) poly_mult_assoc: "poly ((a *** b) *** c) x = poly (a *** (b *** c)) x"
  by (simp add: poly_mult mult.assoc)

lemma (in semiring_0) poly_mult_Nil2[simp]: "poly (p *** []) x = 0"
  by (induct p) auto

lemma (in comm_semiring_1) poly_exp_add: "poly (p %^ (n + d)) x = poly (p %^ n *** p %^ d) x"
  by (induct n) (auto simp add: poly_mult mult.assoc)

subsection \<open>Key Property: if @{term "f a = 0"} then @{term "(x - a)"} divides @{term "p(x)"}.\<close>

lemma (in comm_ring_1) lemma_poly_linear_rem: "\<exists>q r. h#t = [r] +++ [-a, 1] *** q"
proof (induct t arbitrary: h)
  case Nil
  have "[h] = [h] +++ [- a, 1] *** []" by simp
  then show ?case by blast
next
  case (Cons  x xs)
  have "\<exists>q r. h # x # xs = [r] +++ [-a, 1] *** q"
  proof -
    from Cons obtain q r where qr: "x # xs = [r] +++ [- a, 1] *** q"
      by blast
    have "h # x # xs = [a * r + h] +++ [-a, 1] *** (r # q)"
      using qr by (cases q) (simp_all add: algebra_simps)
    then show ?thesis by blast
  qed
  then show ?case by blast
qed

lemma (in comm_ring_1) poly_linear_rem: "\<exists>q r. h#t = [r] +++ [-a, 1] *** q"
  using lemma_poly_linear_rem [where t = t and a = a] by auto

lemma (in comm_ring_1) poly_linear_divides: "poly p a = 0 \<longleftrightarrow> p = [] \<or> (\<exists>q. p = [-a, 1] *** q)"
proof (cases p)
  case Nil
  then show ?thesis by simp
next
  case (Cons x xs)
  have "poly p a = 0" if "p = [-a, 1] *** q" for q
    using that by (simp add: poly_add poly_cmult)
  moreover
  have "\<exists>q. p = [- a, 1] *** q" if p0: "poly p a = 0"
  proof -
    from poly_linear_rem[of x xs a] obtain q r where qr: "x#xs = [r] +++ [- a, 1] *** q"
      by blast
    have "r = 0"
      using p0 by (simp only: Cons qr poly_mult poly_add) simp
    with Cons qr show ?thesis
      apply -
      apply (rule exI[where x = q])
      apply auto
      apply (cases q)
      apply auto
      done
  qed
  ultimately show ?thesis using Cons by blast
qed

lemma (in semiring_0) lemma_poly_length_mult[simp]:
  "length (k %* p +++  (h # (a %* p))) = Suc (length p)"
  by (induct p arbitrary: h k a) auto

lemma (in semiring_0) lemma_poly_length_mult2[simp]:
  "length (k %* p +++  (h # p)) = Suc (length p)"
  by (induct p arbitrary: h k) auto

lemma (in ring_1) poly_length_mult[simp]: "length([-a,1] *** q) = Suc (length q)"
  by auto

subsection \<open>Polynomial length\<close>

lemma (in semiring_0) poly_cmult_length[simp]: "length (a %* p) = length p"
  by (induct p) auto

lemma (in semiring_0) poly_add_length: "length (p1 +++ p2) = max (length p1) (length p2)"
  by (induct p1 arbitrary: p2) auto

lemma (in semiring_0) poly_root_mult_length[simp]: "length ([a, b] *** p) = Suc (length p)"
  by (simp add: poly_add_length)

lemma (in idom) poly_mult_not_eq_poly_Nil[simp]:
  "poly (p *** q) x \<noteq> poly [] x \<longleftrightarrow> poly p x \<noteq> poly [] x \<and> poly q x \<noteq> poly [] x"
  by (auto simp add: poly_mult)

lemma (in idom) poly_mult_eq_zero_disj: "poly (p *** q) x = 0 \<longleftrightarrow> poly p x = 0 \<or> poly q x = 0"
  by (auto simp add: poly_mult)

text \<open>Normalisation Properties.\<close>

lemma (in semiring_0) poly_normalized_nil: "pnormalize p = [] \<longrightarrow> poly p x = 0"
  by (induct p) auto

text \<open>A nontrivial polynomial of degree n has no more than n roots.\<close>
lemma (in idom) poly_roots_index_lemma:
  assumes "poly p x \<noteq> poly [] x"
    and "length p = n"
  shows "\<exists>i. \<forall>x. poly p x = 0 \<longrightarrow> (\<exists>m\<le>n. x = i m)"
  using assms
proof (induct n arbitrary: p x)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have False if C: "\<And>i. \<exists>x. poly p x = 0 \<and> (\<forall>m\<le>Suc n. x \<noteq> i m)"
  proof -
    from Suc.prems have p0: "poly p x \<noteq> 0" "p \<noteq> []"
      by auto
    from p0(1)[unfolded poly_linear_divides[of p x]]
    have "\<forall>q. p \<noteq> [- x, 1] *** q"
      by blast
    from C obtain a where a: "poly p a = 0"
      by blast
    from a[unfolded poly_linear_divides[of p a]] p0(2) obtain q where q: "p = [-a, 1] *** q"
      by blast
    have lg: "length q = n"
      using q Suc.prems(2) by simp
    from q p0 have qx: "poly q x \<noteq> poly [] x"
      by (auto simp add: poly_mult poly_add poly_cmult)
    from Suc.hyps[OF qx lg] obtain i where i: "\<And>x. poly q x = 0 \<longrightarrow> (\<exists>m\<le>n. x = i m)"
      by blast
    let ?i = "\<lambda>m. if m = Suc n then a else i m"
    from C[of ?i] obtain y where y: "poly p y = 0" "\<forall>m\<le> Suc n. y \<noteq> ?i m"
      by blast
    from y have "y = a \<or> poly q y = 0"
      by (simp only: q poly_mult_eq_zero_disj poly_add) (simp add: algebra_simps)
    with i[of y] y(1) y(2) show ?thesis
      apply auto
      apply (erule_tac x = "m" in allE)
      apply auto
      done
  qed
  then show ?case by blast
qed

lemma (in idom) poly_roots_index_length:
  "poly p x \<noteq> poly [] x \<Longrightarrow> \<exists>i. \<forall>x. poly p x = 0 \<longrightarrow> (\<exists>n. n \<le> length p \<and> x = i n)"
  by (blast intro: poly_roots_index_lemma)

lemma (in idom) poly_roots_finite_lemma1:
  "poly p x \<noteq> poly [] x \<Longrightarrow> \<exists>N i. \<forall>x. poly p x = 0 \<longrightarrow> (\<exists>n::nat. n < N \<and> x = i n)"
  apply (drule poly_roots_index_length)
  apply safe
  apply (rule_tac x = "Suc (length p)" in exI)
  apply (rule_tac x = i in exI)
  apply (simp add: less_Suc_eq_le)
  done

lemma (in idom) idom_finite_lemma:
  assumes "\<forall>x. P x \<longrightarrow> (\<exists>n. n < length j \<and> x = j!n)"
  shows "finite {x. P x}"
proof -
  from assms have "{x. P x} \<subseteq> set j"
    by auto
  then show ?thesis
    using finite_subset by auto
qed

lemma (in idom) poly_roots_finite_lemma2:
  "poly p x \<noteq> poly [] x \<Longrightarrow> \<exists>i. \<forall>x. poly p x = 0 \<longrightarrow> x \<in> set i"
  apply (drule poly_roots_index_length)
  apply safe
  apply (rule_tac x = "map (\<lambda>n. i n) [0 ..< Suc (length p)]" in exI)
  apply (auto simp add: image_iff)
  apply (erule_tac x="x" in allE)
  apply clarsimp
  apply (case_tac "n = length p")
  apply (auto simp add: order_le_less)
  done

lemma (in ring_char_0) UNIV_ring_char_0_infinte: "\<not> finite (UNIV :: 'a set)"
proof
  assume F: "finite (UNIV :: 'a set)"
  have "finite (UNIV :: nat set)"
  proof (rule finite_imageD)
    have "of_nat ` UNIV \<subseteq> UNIV"
      by simp
    then show "finite (of_nat ` UNIV :: 'a set)"
      using F by (rule finite_subset)
    show "inj (of_nat :: nat \<Rightarrow> 'a)"
      by (simp add: inj_on_def)
  qed
  with infinite_UNIV_nat show False ..
qed

lemma (in idom_char_0) poly_roots_finite: "poly p \<noteq> poly [] \<longleftrightarrow> finite {x. poly p x = 0}"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  show ?rhs if ?lhs
    using that
    apply -
    apply (erule contrapos_np)
    apply (rule ext)
    apply (rule ccontr)
    apply (clarify dest!: poly_roots_finite_lemma2)
    using finite_subset
  proof -
    fix x i
    assume F: "\<not> finite {x. poly p x = 0}"
      and P: "\<forall>x. poly p x = 0 \<longrightarrow> x \<in> set i"
    from P have "{x. poly p x = 0} \<subseteq> set i"
      by auto
    with finite_subset F show False
      by auto
  qed
  show ?lhs if ?rhs
    using UNIV_ring_char_0_infinte that by auto
qed

text \<open>Entirety and Cancellation for polynomials\<close>

lemma (in idom_char_0) poly_entire_lemma2:
  assumes p0: "poly p \<noteq> poly []"
    and q0: "poly q \<noteq> poly []"
  shows "poly (p***q) \<noteq> poly []"
proof -
  let ?S = "\<lambda>p. {x. poly p x = 0}"
  have "?S (p *** q) = ?S p \<union> ?S q"
    by (auto simp add: poly_mult)
  with p0 q0 show ?thesis
    unfolding poly_roots_finite by auto
qed

lemma (in idom_char_0) poly_entire:
  "poly (p *** q) = poly [] \<longleftrightarrow> poly p = poly [] \<or> poly q = poly []"
  using poly_entire_lemma2[of p q]
  by (auto simp add: fun_eq_iff poly_mult)

lemma (in idom_char_0) poly_entire_neg:
  "poly (p *** q) \<noteq> poly [] \<longleftrightarrow> poly p \<noteq> poly [] \<and> poly q \<noteq> poly []"
  by (simp add: poly_entire)

lemma (in comm_ring_1) poly_add_minus_zero_iff:
  "poly (p +++ -- q) = poly [] \<longleftrightarrow> poly p = poly q"
  by (auto simp add: algebra_simps poly_add poly_minus_def fun_eq_iff poly_cmult)

lemma (in comm_ring_1) poly_add_minus_mult_eq:
  "poly (p *** q +++ --(p *** r)) = poly (p *** (q +++ -- r))"
  by (auto simp add: poly_add poly_minus_def fun_eq_iff poly_mult poly_cmult algebra_simps)

subclass (in idom_char_0) comm_ring_1 ..

lemma (in idom_char_0) poly_mult_left_cancel:
  "poly (p *** q) = poly (p *** r) \<longleftrightarrow> poly p = poly [] \<or> poly q = poly r"
proof -
  have "poly (p *** q) = poly (p *** r) \<longleftrightarrow> poly (p *** q +++ -- (p *** r)) = poly []"
    by (simp only: poly_add_minus_zero_iff)
  also have "\<dots> \<longleftrightarrow> poly p = poly [] \<or> poly q = poly r"
    by (auto intro: simp add: poly_add_minus_mult_eq poly_entire poly_add_minus_zero_iff)
  finally show ?thesis .
qed

lemma (in idom) poly_exp_eq_zero[simp]: "poly (p %^ n) = poly [] \<longleftrightarrow> poly p = poly [] \<and> n \<noteq> 0"
  apply (simp only: fun_eq_iff add: HOL.all_simps [symmetric])
  apply (rule arg_cong [where f = All])
  apply (rule ext)
  apply (induct n)
  apply (auto simp add: poly_exp poly_mult)
  done

lemma (in comm_ring_1) poly_prime_eq_zero[simp]: "poly [a, 1] \<noteq> poly []"
  apply (simp add: fun_eq_iff)
  apply (rule_tac x = "minus one a" in exI)
  apply (simp add: add.commute [of a])
  done

lemma (in idom) poly_exp_prime_eq_zero: "poly ([a, 1] %^ n) \<noteq> poly []"
  by auto

text \<open>A more constructive notion of polynomials being trivial.\<close>

lemma (in idom_char_0) poly_zero_lemma': "poly (h # t) = poly [] \<Longrightarrow> h = 0 \<and> poly t = poly []"
  apply (simp add: fun_eq_iff)
  apply (case_tac "h = zero")
  apply (drule_tac [2] x = zero in spec)
  apply auto
  apply (cases "poly t = poly []")
  apply simp
proof -
  fix x
  assume H: "\<forall>x. x = 0 \<or> poly t x = 0"
  assume pnz: "poly t \<noteq> poly []"
  let ?S = "{x. poly t x = 0}"
  from H have "\<forall>x. x \<noteq> 0 \<longrightarrow> poly t x = 0"
    by blast
  then have th: "?S \<supseteq> UNIV - {0}"
    by auto
  from poly_roots_finite pnz have th': "finite ?S"
    by blast
  from finite_subset[OF th th'] UNIV_ring_char_0_infinte show "poly t x = 0"
    by simp
qed

lemma (in idom_char_0) poly_zero: "poly p = poly [] \<longleftrightarrow> (\<forall>c \<in> set p. c = 0)"
proof (induct p)
  case Nil
  then show ?case by simp
next
  case Cons
  show ?case
    apply (rule iffI)
    apply (drule poly_zero_lemma')
    using Cons
    apply auto
    done
qed

lemma (in idom_char_0) poly_0: "\<forall>c \<in> set p. c = 0 \<Longrightarrow> poly p x = 0"
  unfolding poly_zero[symmetric] by simp

text \<open>Basics of divisibility.\<close>

lemma (in idom) poly_primes: "[a, 1] divides (p *** q) \<longleftrightarrow> [a, 1] divides p \<or> [a, 1] divides q"
  apply (auto simp add: divides_def fun_eq_iff poly_mult poly_add poly_cmult distrib_right [symmetric])
  apply (drule_tac x = "uminus a" in spec)
  apply (simp add: poly_linear_divides poly_add poly_cmult distrib_right [symmetric])
  apply (cases "p = []")
  apply (rule exI[where x="[]"])
  apply simp
  apply (cases "q = []")
  apply (erule allE[where x="[]"])
  apply simp

  apply clarsimp
  apply (cases "\<exists>q. p = a %* q +++ (0 # q)")
  apply (clarsimp simp add: poly_add poly_cmult)
  apply (rule_tac x = qa in exI)
  apply (simp add: distrib_right [symmetric])
  apply clarsimp

  apply (auto simp add: poly_linear_divides poly_add poly_cmult distrib_right [symmetric])
  apply (rule_tac x = "pmult qa q" in exI)
  apply (rule_tac [2] x = "pmult p qa" in exI)
  apply (auto simp add: poly_add poly_mult poly_cmult ac_simps)
  done

lemma (in comm_semiring_1) poly_divides_refl[simp]: "p divides p"
  apply (simp add: divides_def)
  apply (rule_tac x = "[one]" in exI)
  apply (auto simp add: poly_mult fun_eq_iff)
  done

lemma (in comm_semiring_1) poly_divides_trans: "p divides q \<Longrightarrow> q divides r \<Longrightarrow> p divides r"
  apply (simp add: divides_def)
  apply safe
  apply (rule_tac x = "pmult qa qaa" in exI)
  apply (auto simp add: poly_mult fun_eq_iff mult.assoc)
  done

lemma (in comm_semiring_1) poly_divides_exp: "m \<le> n \<Longrightarrow> (p %^ m) divides (p %^ n)"
  by (auto simp: le_iff_add divides_def poly_exp_add fun_eq_iff)

lemma (in comm_semiring_1) poly_exp_divides: "(p %^ n) divides q \<Longrightarrow> m \<le> n \<Longrightarrow> (p %^ m) divides q"
  by (blast intro: poly_divides_exp poly_divides_trans)

lemma (in comm_semiring_0) poly_divides_add: "p divides q \<Longrightarrow> p divides r \<Longrightarrow> p divides (q +++ r)"
  apply (auto simp add: divides_def)
  apply (rule_tac x = "padd qa qaa" in exI)
  apply (auto simp add: poly_add fun_eq_iff poly_mult distrib_left)
  done

lemma (in comm_ring_1) poly_divides_diff: "p divides q \<Longrightarrow> p divides (q +++ r) \<Longrightarrow> p divides r"
  apply (auto simp add: divides_def)
  apply (rule_tac x = "padd qaa (poly_minus qa)" in exI)
  apply (auto simp add: poly_add fun_eq_iff poly_mult poly_minus algebra_simps)
  done

lemma (in comm_ring_1) poly_divides_diff2: "p divides r \<Longrightarrow> p divides (q +++ r) \<Longrightarrow> p divides q"
  apply (erule poly_divides_diff)
  apply (auto simp add: poly_add fun_eq_iff poly_mult divides_def ac_simps)
  done

lemma (in semiring_0) poly_divides_zero: "poly p = poly [] \<Longrightarrow> q divides p"
  apply (simp add: divides_def)
  apply (rule exI[where x = "[]"])
  apply (auto simp add: fun_eq_iff poly_mult)
  done

lemma (in semiring_0) poly_divides_zero2 [simp]: "q divides []"
  apply (simp add: divides_def)
  apply (rule_tac x = "[]" in exI)
  apply (auto simp add: fun_eq_iff)
  done

text \<open>At last, we can consider the order of a root.\<close>

lemma (in idom_char_0) poly_order_exists_lemma:
  assumes "length p = d"
    and "poly p \<noteq> poly []"
  shows "\<exists>n q. p = mulexp n [-a, 1] q \<and> poly q a \<noteq> 0"
  using assms
proof (induct d arbitrary: p)
  case 0
  then show ?case by simp
next
  case (Suc n p)
  show ?case
  proof (cases "poly p a = 0")
    case True
    from Suc.prems have h: "length p = Suc n" "poly p \<noteq> poly []"
      by auto
    then have pN: "p \<noteq> []"
      by auto
    from True[unfolded poly_linear_divides] pN obtain q where q: "p = [-a, 1] *** q"
      by blast
    from q h True have qh: "length q = n" "poly q \<noteq> poly []"
      apply simp_all
      apply (simp only: fun_eq_iff)
      apply (rule ccontr)
      apply (simp add: fun_eq_iff poly_add poly_cmult)
      done
    from Suc.hyps[OF qh] obtain m r where mr: "q = mulexp m [-a,1] r" "poly r a \<noteq> 0"
      by blast
    from mr q have "p = mulexp (Suc m) [-a,1] r \<and> poly r a \<noteq> 0"
      by simp
    then show ?thesis by blast
  next
    case False
    then show ?thesis
      using Suc.prems
      apply simp
      apply (rule exI[where x="0::nat"])
      apply simp
      done
  qed
qed

lemma (in comm_semiring_1) poly_mulexp: "poly (mulexp n p q) x = (poly p x) ^ n * poly q x"
  by (induct n) (auto simp add: poly_mult ac_simps)

lemma (in comm_semiring_1) divides_left_mult:
  assumes "(p *** q) divides r"
  shows "p divides r \<and> q divides r"
proof-
  from assms obtain t where "poly r = poly (p *** q *** t)"
    unfolding divides_def by blast
  then have "poly r = poly (p *** (q *** t))" and "poly r = poly (q *** (p *** t))"
    by (auto simp add: fun_eq_iff poly_mult ac_simps)
  then show ?thesis
    unfolding divides_def by blast
qed

(* FIXME: Tidy up *)

lemma (in semiring_1) zero_power_iff: "0 ^ n = (if n = 0 then 1 else 0)"
  by (induct n) simp_all

lemma (in idom_char_0) poly_order_exists:
  assumes "length p = d"
    and "poly p \<noteq> poly []"
  shows "\<exists>n. [- a, 1] %^ n divides p \<and> \<not> [- a, 1] %^ Suc n divides p"
proof -
  from assms have "\<exists>n q. p = mulexp n [- a, 1] q \<and> poly q a \<noteq> 0"
    by (rule poly_order_exists_lemma)
  then obtain n q where p: "p = mulexp n [- a, 1] q" and "poly q a \<noteq> 0"
    by blast
  have "[- a, 1] %^ n divides mulexp n [- a, 1] q"
  proof (rule dividesI)
    show "poly (mulexp n [- a, 1] q) = poly ([- a, 1] %^ n *** q)"
      by (induct n) (simp_all add: poly_add poly_cmult poly_mult algebra_simps)
  qed
  moreover have "\<not> [- a, 1] %^ Suc n divides mulexp n [- a, 1] q"
  proof
    assume "[- a, 1] %^ Suc n divides mulexp n [- a, 1] q"
    then obtain m where "poly (mulexp n [- a, 1] q) = poly ([- a, 1] %^ Suc n *** m)"
      by (rule dividesE)
    moreover have "poly (mulexp n [- a, 1] q) \<noteq> poly ([- a, 1] %^ Suc n *** m)"
    proof (induct n)
      case 0
      show ?case
      proof (rule ccontr)
        assume "\<not> ?thesis"
        then have "poly q a = 0"
          by (simp add: poly_add poly_cmult)
        with \<open>poly q a \<noteq> 0\<close> show False
          by simp
      qed
    next
      case (Suc n)
      show ?case
        by (rule pexp_Suc [THEN ssubst])
          (simp add: poly_mult_left_cancel poly_mult_assoc Suc del: pmult_Cons pexp_Suc)
    qed
    ultimately show False by simp
  qed
  ultimately show ?thesis
    by (auto simp add: p)
qed

lemma (in semiring_1) poly_one_divides[simp]: "[1] divides p"
  by (auto simp add: divides_def)

lemma (in idom_char_0) poly_order:
  "poly p \<noteq> poly [] \<Longrightarrow> \<exists>!n. ([-a, 1] %^ n) divides p \<and> \<not> (([-a, 1] %^ Suc n) divides p)"
  apply (auto intro: poly_order_exists simp add: less_linear simp del: pmult_Cons pexp_Suc)
  apply (cut_tac x = y and y = n in less_linear)
  apply (drule_tac m = n in poly_exp_divides)
  apply (auto dest: Suc_le_eq [THEN iffD2, THEN [2] poly_exp_divides]
    simp del: pmult_Cons pexp_Suc)
  done

text \<open>Order\<close>

lemma some1_equalityD: "n = (SOME n. P n) \<Longrightarrow> \<exists>!n. P n \<Longrightarrow> P n"
  by (blast intro: someI2)

lemma (in idom_char_0) order:
  "([-a, 1] %^ n) divides p \<and> \<not> (([-a, 1] %^ Suc n) divides p) \<longleftrightarrow>
    n = order a p \<and> poly p \<noteq> poly []"
  unfolding order_def
  apply (rule iffI)
  apply (blast dest: poly_divides_zero intro!: some1_equality [symmetric] poly_order)
  apply (blast intro!: poly_order [THEN [2] some1_equalityD])
  done

lemma (in idom_char_0) order2:
  "poly p \<noteq> poly [] \<Longrightarrow>
    ([-a, 1] %^ (order a p)) divides p \<and> \<not> ([-a, 1] %^ Suc (order a p)) divides p"
  by (simp add: order del: pexp_Suc)

lemma (in idom_char_0) order_unique:
  "poly p \<noteq> poly [] \<Longrightarrow> ([-a, 1] %^ n) divides p \<Longrightarrow> \<not> ([-a, 1] %^ (Suc n)) divides p \<Longrightarrow>
    n = order a p"
  using order [of a n p] by auto

lemma (in idom_char_0) order_unique_lemma:
  "poly p \<noteq> poly [] \<and> ([-a, 1] %^ n) divides p \<and> \<not> ([-a, 1] %^ (Suc n)) divides p \<Longrightarrow>
    n = order a p"
  by (blast intro: order_unique)

lemma (in ring_1) order_poly: "poly p = poly q \<Longrightarrow> order a p = order a q"
  by (auto simp add: fun_eq_iff divides_def poly_mult order_def)

lemma (in semiring_1) pexp_one[simp]: "p %^ (Suc 0) = p"
  by (induct p) auto

lemma (in comm_ring_1) lemma_order_root:
  "0 < n \<and> [- a, 1] %^ n divides p \<and> \<not> [- a, 1] %^ (Suc n) divides p \<Longrightarrow> poly p a = 0"
  by (induct n arbitrary: a p) (auto simp add: divides_def poly_mult simp del: pmult_Cons)

lemma (in idom_char_0) order_root: "poly p a = 0 \<longleftrightarrow> poly p = poly [] \<or> order a p \<noteq> 0"
  apply (cases "poly p = poly []")
  apply auto
  apply (simp add: poly_linear_divides del: pmult_Cons)
  apply safe
  apply (drule_tac [!] a = a in order2)
  apply (rule ccontr)
  apply (simp add: divides_def poly_mult fun_eq_iff del: pmult_Cons)
  apply blast
  using neq0_conv apply (blast intro: lemma_order_root)
  done

lemma (in idom_char_0) order_divides:
  "([-a, 1] %^ n) divides p \<longleftrightarrow> poly p = poly [] \<or> n \<le> order a p"
  apply (cases "poly p = poly []")
  apply auto
  apply (simp add: divides_def fun_eq_iff poly_mult)
  apply (rule_tac x = "[]" in exI)
  apply (auto dest!: order2 [where a=a] intro: poly_exp_divides simp del: pexp_Suc)
  done

lemma (in idom_char_0) order_decomp:
  "poly p \<noteq> poly [] \<Longrightarrow> \<exists>q. poly p = poly (([-a, 1] %^ order a p) *** q) \<and> \<not> [-a, 1] divides q"
  unfolding divides_def
  apply (drule order2 [where a = a])
  apply (simp add: divides_def del: pexp_Suc pmult_Cons)
  apply safe
  apply (rule_tac x = q in exI)
  apply safe
  apply (drule_tac x = qa in spec)
  apply (auto simp add: poly_mult fun_eq_iff poly_exp ac_simps simp del: pmult_Cons)
  done

text \<open>Important composition properties of orders.\<close>
lemma order_mult:
  fixes a :: "'a::idom_char_0"
  shows "poly (p *** q) \<noteq> poly [] \<Longrightarrow> order a (p *** q) = order a p + order a q"
  apply (cut_tac a = a and p = "p *** q" and n = "order a p + order a q" in order)
  apply (auto simp add: poly_entire simp del: pmult_Cons)
  apply (drule_tac a = a in order2)+
  apply safe
  apply (simp add: divides_def fun_eq_iff poly_exp_add poly_mult del: pmult_Cons, safe)
  apply (rule_tac x = "qa *** qaa" in exI)
  apply (simp add: poly_mult ac_simps del: pmult_Cons)
  apply (drule_tac a = a in order_decomp)+
  apply safe
  apply (subgoal_tac "[-a, 1] divides (qa *** qaa) ")
  apply (simp add: poly_primes del: pmult_Cons)
  apply (auto simp add: divides_def simp del: pmult_Cons)
  apply (rule_tac x = qb in exI)
  apply (subgoal_tac "poly ([-a, 1] %^ (order a p) *** (qa *** qaa)) =
    poly ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))")
  apply (drule poly_mult_left_cancel [THEN iffD1])
  apply force
  apply (subgoal_tac "poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** (qa *** qaa))) =
    poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))) ")
  apply (drule poly_mult_left_cancel [THEN iffD1])
  apply force
  apply (simp add: fun_eq_iff poly_exp_add poly_mult ac_simps del: pmult_Cons)
  done

lemma (in idom_char_0) order_mult:
  assumes "poly (p *** q) \<noteq> poly []"
  shows "order a (p *** q) = order a p + order a q"
  using assms
  apply (cut_tac a = a and p = "pmult p q" and n = "order a p + order a q" in order)
  apply (auto simp add: poly_entire simp del: pmult_Cons)
  apply (drule_tac a = a in order2)+
  apply safe
  apply (simp add: divides_def fun_eq_iff poly_exp_add poly_mult del: pmult_Cons)
  apply safe
  apply (rule_tac x = "pmult qa qaa" in exI)
  apply (simp add: poly_mult ac_simps del: pmult_Cons)
  apply (drule_tac a = a in order_decomp)+
  apply safe
  apply (subgoal_tac "[uminus a, one] divides pmult qa qaa")
  apply (simp add: poly_primes del: pmult_Cons)
  apply (auto simp add: divides_def simp del: pmult_Cons)
  apply (rule_tac x = qb in exI)
  apply (subgoal_tac "poly (pmult (pexp [uminus a, one] (order a p)) (pmult qa qaa)) =
    poly (pmult (pexp [uminus a, one] (order a p)) (pmult [uminus a, one] qb))")
  apply (drule poly_mult_left_cancel [THEN iffD1], force)
  apply (subgoal_tac "poly (pmult (pexp [uminus a, one] (order a q))
      (pmult (pexp [uminus a, one] (order a p)) (pmult qa qaa))) =
    poly (pmult (pexp [uminus a, one] (order a q))
      (pmult (pexp [uminus a, one] (order a p)) (pmult [uminus a, one] qb)))")
  apply (drule poly_mult_left_cancel [THEN iffD1], force)
  apply (simp add: fun_eq_iff poly_exp_add poly_mult ac_simps del: pmult_Cons)
  done

lemma (in idom_char_0) order_root2: "poly p \<noteq> poly [] \<Longrightarrow> poly p a = 0 \<longleftrightarrow> order a p \<noteq> 0"
  by (rule order_root [THEN ssubst]) auto

lemma (in semiring_1) pmult_one[simp]: "[1] *** p = p"
  by auto

lemma (in semiring_0) poly_Nil_zero: "poly [] = poly [0]"
  by (simp add: fun_eq_iff)

lemma (in idom_char_0) rsquarefree_decomp:
  "rsquarefree p \<Longrightarrow> poly p a = 0 \<Longrightarrow> \<exists>q. poly p = poly ([-a, 1] *** q) \<and> poly q a \<noteq> 0"
  apply (simp add: rsquarefree_def)
  apply safe
  apply (frule_tac a = a in order_decomp)
  apply (drule_tac x = a in spec)
  apply (drule_tac a = a in order_root2 [symmetric])
  apply (auto simp del: pmult_Cons)
  apply (rule_tac x = q in exI, safe)
  apply (simp add: poly_mult fun_eq_iff)
  apply (drule_tac p1 = q in poly_linear_divides [THEN iffD1])
  apply (simp add: divides_def del: pmult_Cons, safe)
  apply (drule_tac x = "[]" in spec)
  apply (auto simp add: fun_eq_iff)
  done

text \<open>Normalization of a polynomial.\<close>

lemma (in semiring_0) poly_normalize[simp]: "poly (pnormalize p) = poly p"
  by (induct p) (auto simp add: fun_eq_iff)

text \<open>The degree of a polynomial.\<close>

lemma (in semiring_0) lemma_degree_zero: "(\<forall>c \<in> set p. c = 0) \<longleftrightarrow> pnormalize p = []"
  by (induct p) auto

lemma (in idom_char_0) degree_zero:
  assumes "poly p = poly []"
  shows "degree p = 0"
  using assms
  by (cases "pnormalize p = []") (auto simp add: degree_def poly_zero lemma_degree_zero)

lemma (in semiring_0) pnormalize_sing: "pnormalize [x] = [x] \<longleftrightarrow> x \<noteq> 0"
  by simp

lemma (in semiring_0) pnormalize_pair: "y \<noteq> 0 \<longleftrightarrow> pnormalize [x, y] = [x, y]"
  by simp

lemma (in semiring_0) pnormal_cons: "pnormal p \<Longrightarrow> pnormal (c # p)"
  unfolding pnormal_def by simp

lemma (in semiring_0) pnormal_tail: "p \<noteq> [] \<Longrightarrow> pnormal (c # p) \<Longrightarrow> pnormal p"
  unfolding pnormal_def by (auto split: if_split_asm)

lemma (in semiring_0) pnormal_last_nonzero: "pnormal p \<Longrightarrow> last p \<noteq> 0"
  by (induct p) (simp_all add: pnormal_def split: if_split_asm)

lemma (in semiring_0) pnormal_length: "pnormal p \<Longrightarrow> 0 < length p"
  unfolding pnormal_def length_greater_0_conv by blast

lemma (in semiring_0) pnormal_last_length: "0 < length p \<Longrightarrow> last p \<noteq> 0 \<Longrightarrow> pnormal p"
  by (induct p) (auto simp: pnormal_def  split: if_split_asm)

lemma (in semiring_0) pnormal_id: "pnormal p \<longleftrightarrow> 0 < length p \<and> last p \<noteq> 0"
  using pnormal_last_length pnormal_length pnormal_last_nonzero by blast

lemma (in idom_char_0) poly_Cons_eq: "poly (c # cs) = poly (d # ds) \<longleftrightarrow> c = d \<and> poly cs = poly ds"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  show ?rhs if ?lhs
  proof -
    from that have "poly ((c # cs) +++ -- (d # ds)) x = 0" for x
      by (simp only: poly_minus poly_add algebra_simps) (simp add: algebra_simps)
    then have "poly ((c # cs) +++ -- (d # ds)) = poly []"
      by (simp add: fun_eq_iff)
    then have "c = d" and "\<forall>x \<in> set (cs +++ -- ds). x = 0"
      unfolding poly_zero by (simp_all add: poly_minus_def algebra_simps)
    from this(2) have "poly (cs +++ -- ds) x = 0" for x
      unfolding poly_zero[symmetric] by simp
    with \<open>c = d\<close> show ?thesis
      by (simp add: poly_minus poly_add algebra_simps fun_eq_iff)
  qed
  show ?lhs if ?rhs
    using that by (simp add:fun_eq_iff)
qed

lemma (in idom_char_0) pnormalize_unique: "poly p = poly q \<Longrightarrow> pnormalize p = pnormalize q"
proof (induct q arbitrary: p)
  case Nil
  then show ?case
    by (simp only: poly_zero lemma_degree_zero) simp
next
  case (Cons c cs p)
  then show ?case
  proof (induct p)
    case Nil
    then have "poly [] = poly (c # cs)"
      by blast
    then have "poly (c#cs) = poly []"
      by simp
    then show ?case
      by (simp only: poly_zero lemma_degree_zero) simp
  next
    case (Cons d ds)
    then have eq: "poly (d # ds) = poly (c # cs)"
      by blast
    then have eq': "\<And>x. poly (d # ds) x = poly (c # cs) x"
      by simp
    then have "poly (d # ds) 0 = poly (c # cs) 0"
      by blast
    then have dc: "d = c"
      by auto
    with eq have "poly ds = poly cs"
      unfolding  poly_Cons_eq by simp
    with Cons.prems have "pnormalize ds = pnormalize cs"
      by blast
    with dc show ?case
      by simp
  qed
qed

lemma (in idom_char_0) degree_unique:
  assumes pq: "poly p = poly q"
  shows "degree p = degree q"
  using pnormalize_unique[OF pq] unfolding degree_def by simp

lemma (in semiring_0) pnormalize_length: "length (pnormalize p) \<le> length p"
  by (induct p) auto

lemma (in semiring_0) last_linear_mul_lemma:
  "last ((a %* p) +++ (x # (b %* p))) = (if p = [] then x else b * last p)"
  apply (induct p arbitrary: a x b)
  apply auto
  subgoal for a p c x b
    apply (subgoal_tac "padd (cmult c p) (times b a # cmult b p) \<noteq> []")
    apply simp
    apply (induct p)
    apply auto
    done
  done

lemma (in semiring_1) last_linear_mul:
  assumes p: "p \<noteq> []"
  shows "last ([a, 1] *** p) = last p"
proof -
  from p obtain c cs where cs: "p = c # cs"
    by (cases p) auto
  from cs have eq: "[a, 1] *** p = (a %* (c # cs)) +++ (0 # (1 %* (c # cs)))"
    by (simp add: poly_cmult_distr)
  show ?thesis
    using cs unfolding eq last_linear_mul_lemma by simp
qed

lemma (in semiring_0) pnormalize_eq: "last p \<noteq> 0 \<Longrightarrow> pnormalize p = p"
  by (induct p) (auto split: if_split_asm)

lemma (in semiring_0) last_pnormalize: "pnormalize p \<noteq> [] \<Longrightarrow> last (pnormalize p) \<noteq> 0"
  by (induct p) auto

lemma (in semiring_0) pnormal_degree: "last p \<noteq> 0 \<Longrightarrow> degree p = length p - 1"
  using pnormalize_eq[of p] unfolding degree_def by simp

lemma (in semiring_0) poly_Nil_ext: "poly [] = (\<lambda>x. 0)"
  by auto

lemma (in idom_char_0) linear_mul_degree:
  assumes p: "poly p \<noteq> poly []"
  shows "degree ([a, 1] *** p) = degree p + 1"
proof -
  from p have pnz: "pnormalize p \<noteq> []"
    unfolding poly_zero lemma_degree_zero .

  from last_linear_mul[OF pnz, of a] last_pnormalize[OF pnz]
  have l0: "last ([a, 1] *** pnormalize p) \<noteq> 0" by simp

  from last_pnormalize[OF pnz] last_linear_mul[OF pnz, of a]
    pnormal_degree[OF l0] pnormal_degree[OF last_pnormalize[OF pnz]] pnz
  have th: "degree ([a,1] *** pnormalize p) = degree (pnormalize p) + 1"
    by simp

  have eqs: "poly ([a,1] *** pnormalize p) = poly ([a,1] *** p)"
    by (rule ext) (simp add: poly_mult poly_add poly_cmult)
  from degree_unique[OF eqs] th show ?thesis
    by (simp add: degree_unique[OF poly_normalize])
qed

lemma (in idom_char_0) linear_pow_mul_degree:
  "degree([a,1] %^n *** p) = (if poly p = poly [] then 0 else degree p + n)"
proof (induct n arbitrary: a p)
  case (0 a p)
  show ?case
  proof (cases "poly p = poly []")
    case True
    then show ?thesis
      using degree_unique[OF True] by (simp add: degree_def)
  next
    case False
    then show ?thesis
      by (auto simp add: poly_Nil_ext)
  qed
next
  case (Suc n a p)
  have eq: "poly ([a, 1] %^(Suc n) *** p) = poly ([a, 1] %^ n *** ([a, 1] *** p))"
    apply (rule ext)
    apply (simp add: poly_mult poly_add poly_cmult)
    apply (simp add: ac_simps distrib_left)
    done
  note deq = degree_unique[OF eq]
  show ?case
  proof (cases "poly p = poly []")
    case True
    with eq have eq': "poly ([a, 1] %^(Suc n) *** p) = poly []"
      by (auto simp add: poly_mult poly_cmult poly_add)
    from degree_unique[OF eq'] True show ?thesis
      by (simp add: degree_def)
  next
    case False
    then have ap: "poly ([a,1] *** p) \<noteq> poly []"
      using poly_mult_not_eq_poly_Nil unfolding poly_entire by auto
    have eq: "poly ([a, 1] %^(Suc n) *** p) = poly ([a, 1]%^n *** ([a, 1] *** p))"
      by (auto simp add: poly_mult poly_add poly_exp poly_cmult algebra_simps)
    from ap have ap': "poly ([a, 1] *** p) = poly [] \<longleftrightarrow> False"
      by blast
    have th0: "degree ([a, 1]%^n *** ([a, 1] *** p)) = degree ([a, 1] *** p) + n"
      apply (simp only: Suc.hyps[of a "pmult [a,one] p"] ap')
      apply simp
      done
    from degree_unique[OF eq] ap False th0 linear_mul_degree[OF False, of a]
    show ?thesis
      by (auto simp del: poly.simps)
  qed
qed

lemma (in idom_char_0) order_degree:
  assumes p0: "poly p \<noteq> poly []"
  shows "order a p \<le> degree p"
proof -
  from order2[OF p0, unfolded divides_def]
  obtain q where q: "poly p = poly ([- a, 1]%^ (order a p) *** q)"
    by blast
  with q p0 have "poly q \<noteq> poly []"
    by (simp add: poly_mult poly_entire)
  with degree_unique[OF q, unfolded linear_pow_mul_degree] show ?thesis
    by auto
qed

text \<open>Tidier versions of finiteness of roots.\<close>
lemma (in idom_char_0) poly_roots_finite_set:
  "poly p \<noteq> poly [] \<Longrightarrow> finite {x. poly p x = 0}"
  unfolding poly_roots_finite .

text \<open>Bound for polynomial.\<close>
lemma poly_mono:
  fixes x :: "'a::linordered_idom"
  shows "\<bar>x\<bar> \<le> k \<Longrightarrow> \<bar>poly p x\<bar> \<le> poly (map abs p) k"
proof (induct p)
  case Nil
  then show ?case by simp
next
  case (Cons a p)
  then show ?case
    apply auto
    apply (rule_tac y = "\<bar>a\<bar> + \<bar>x * poly p x\<bar>" in order_trans)
    apply (rule abs_triangle_ineq)
    apply (auto intro!: mult_mono simp add: abs_mult)
    done
qed

lemma (in semiring_0) poly_Sing: "poly [c] x = c"
  by simp

end


theory auxiliary0
imports axioms_base
begin

text{* Proving rules for proofs about class equality. *}

lemma equalityI: "\<lbrakk>X \<subseteq> Y; Y \<subseteq> X\<rbrakk> \<Longrightarrow> X = Y"
by (simp add: Prop4_1_a)

lemma equalityE: "X = Y \<Longrightarrow> X \<subseteq> Y"
by (simp add: Prop4_1_a)

lemma Ex_Set: "\<lbrakk>\<And>u :: Set. u \<in> X \<longleftrightarrow> u \<in> Y\<rbrakk> \<Longrightarrow> X = Y"
by (metis Abs_Set_inverse extensionality mem_Collect_eq set_predicate_def universe)

text{* Two proving rules and a lemma about subclasses *}

lemma subsetI: "(\<And>x::Set. x \<in> X \<Longrightarrow> x \<in> Y) \<Longrightarrow> X \<subseteq> Y"
by (metis Abs_Set_inverse CollectI set_predicate_def subclass'_def universe)

lemma subclassI: "(\<And>x. x \<in> X \<Longrightarrow> x \<in> Y) \<Longrightarrow> X \<subseteq> Y"
using subclass'_def by blast

text{* The empty class is unique. *}

lemma empty_is_unique: "\<lbrakk>\<forall>y. y \<notin> x\<rbrakk> \<Longrightarrow> x = \<emptyset>"
using empty_set extensionality by blast

text{* Lemmas/proving rules about singletons. *}

lemma singletonE: "x \<in> {y} \<Longrightarrow> x = y"
  using pairing by simp

lemma singletonE2: "x \<in> {x}"
  using pairing by simp

lemma singletonI: "\<forall>x. x \<in> {y} \<longleftrightarrow> x = y"
  using pairing by simp

lemma subset_of_singleton:
    fixes b c
  assumes "b \<subseteq> {c}"
    shows "b=\<emptyset> \<or> b={c}"
proof -
  {assume "b \<noteq> \<emptyset>"
   then obtain d where "d\<in>b" by (metis empty_is_unique)
   hence "d\<in>{c}"using assms using subclass'_def by blast
   hence "d=c" using singletonE by blast
   hence "b={c}" by (metis \<open>d\<in>b\<close> assms equalityI pairing subsetI)}
  thus ?thesis by auto
qed

end


(*  Title:      HOL/Number_Theory/Eratosthenes.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section {* The sieve of Eratosthenes *}

theory Eratosthenes
imports Main Primes
begin

subsection {* Preliminary: strict divisibility *}

context dvd
begin

abbreviation dvd_strict :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "dvd'_strict" 50)
where
  "b dvd_strict a \<equiv> b dvd a \<and> \<not> a dvd b"

end

subsection {* Main corpus *}

text {* The sieve is modelled as a list of booleans, where @{const False} means \emph{marked out}. *}

type_synonym marks = "bool list"

definition numbers_of_marks :: "nat \<Rightarrow> marks \<Rightarrow> nat set"
where
  "numbers_of_marks n bs = fst ` {x \<in> set (enumerate n bs). snd x}"

lemma numbers_of_marks_simps [simp, code]:
  "numbers_of_marks n [] = {}"
  "numbers_of_marks n (True # bs) = insert n (numbers_of_marks (Suc n) bs)"
  "numbers_of_marks n (False # bs) = numbers_of_marks (Suc n) bs"
  by (auto simp add: numbers_of_marks_def intro!: image_eqI)

lemma numbers_of_marks_Suc:
  "numbers_of_marks (Suc n) bs = Suc ` numbers_of_marks n bs"
  by (auto simp add: numbers_of_marks_def enumerate_Suc_eq image_iff Bex_def)

lemma numbers_of_marks_replicate_False [simp]:
  "numbers_of_marks n (replicate m False) = {}"
  by (auto simp add: numbers_of_marks_def enumerate_replicate_eq)

lemma numbers_of_marks_replicate_True [simp]:
  "numbers_of_marks n (replicate m True) = {n..<n+m}"
  by (auto simp add: numbers_of_marks_def enumerate_replicate_eq image_def)

lemma in_numbers_of_marks_eq:
  "m \<in> numbers_of_marks n bs \<longleftrightarrow> m \<in> {n..<n + length bs} \<and> bs ! (m - n)"
  by (simp add: numbers_of_marks_def in_set_enumerate_eq image_iff add.commute)

lemma sorted_list_of_set_numbers_of_marks:
  "sorted_list_of_set (numbers_of_marks n bs) = map fst (filter snd (enumerate n bs))"
  by (auto simp add: numbers_of_marks_def distinct_map
    intro!: sorted_filter distinct_filter inj_onI sorted_distinct_set_unique)

text {* Marking out multiples in a sieve  *}

definition mark_out :: "nat \<Rightarrow> marks \<Rightarrow> marks"
where
  "mark_out n bs = map (\<lambda>(q, b). b \<and> \<not> Suc n dvd Suc (Suc q)) (enumerate n bs)"

lemma mark_out_Nil [simp]:
  "mark_out n [] = []"
  by (simp add: mark_out_def)

lemma length_mark_out [simp]:
  "length (mark_out n bs) = length bs"
  by (simp add: mark_out_def)

lemma numbers_of_marks_mark_out:
  "numbers_of_marks n (mark_out m bs) = {q \<in> numbers_of_marks n bs. \<not> Suc m dvd Suc q - n}"
  by (auto simp add: numbers_of_marks_def mark_out_def in_set_enumerate_eq image_iff
    nth_enumerate_eq less_eq_dvd_minus)

text {* Auxiliary operation for efficient implementation  *}

definition mark_out_aux :: "nat \<Rightarrow> nat \<Rightarrow> marks \<Rightarrow> marks"
where
  "mark_out_aux n m bs =
    map (\<lambda>(q, b). b \<and> (q < m + n \<or> \<not> Suc n dvd Suc (Suc q) + (n - m mod Suc n))) (enumerate n bs)"

lemma mark_out_code [code]:
  "mark_out n bs = mark_out_aux n n bs"
proof -
  { fix a
    assume A: "Suc n dvd Suc (Suc a)"
      and B: "a < n + n"
      and C: "n \<le> a"
    have False
    proof (cases "n = 0")
      case True with A B C show False by simp
    next
      def m \<equiv> "Suc n" then have "m > 0" by simp
      case False then have "n > 0" by simp
      from A obtain q where q: "Suc (Suc a) = Suc n * q" by (rule dvdE)
      have "q > 0"
      proof (rule ccontr)
        assume "\<not> q > 0"
        with q show False by simp
      qed
      with `n > 0` have "Suc n * q \<ge> 2" by (auto simp add: gr0_conv_Suc)
      with q have a: "a = Suc n * q - 2" by simp
      with B have "q + n * q < n + n + 2"
        by auto
      then have "m * q < m * 2" by (simp add: m_def)
      with `m > 0` have "q < 2" by simp
      with `q > 0` have "q = 1" by simp
      with a have "a = n - 1" by simp
      with `n > 0` C show False by simp
    qed
  } note aux = this
  show ?thesis
    by (auto simp add: mark_out_def mark_out_aux_def in_set_enumerate_eq intro: aux)
qed

lemma mark_out_aux_simps [simp, code]:
  "mark_out_aux n m [] = []" (is ?thesis1)
  "mark_out_aux n 0 (b # bs) = False # mark_out_aux n n bs" (is ?thesis2)
  "mark_out_aux n (Suc m) (b # bs) = b # mark_out_aux n m bs" (is ?thesis3)
proof -
  show ?thesis1
    by (simp add: mark_out_aux_def)
  show ?thesis2
    by (auto simp add: mark_out_code [symmetric] mark_out_aux_def mark_out_def
      enumerate_Suc_eq in_set_enumerate_eq less_eq_dvd_minus)
  { def v \<equiv> "Suc m" and w \<equiv> "Suc n"
    fix q
    assume "m + n \<le> q"
    then obtain r where q: "q = m + n + r" by (auto simp add: le_iff_add)
    { fix u
      from w_def have "u mod w < w" by simp
      then have "u + (w - u mod w) = w + (u - u mod w)"
        by simp
      then have "u + (w - u mod w) = w + u div w * w"
        by (simp add: div_mod_equality' [symmetric])
    }
    then have "w dvd v + w + r + (w - v mod w) \<longleftrightarrow> w dvd m + w + r + (w - m mod w)"
      by (simp add: add.assoc add.left_commute [of m] add.left_commute [of v]
        dvd_add_left_iff dvd_add_right_iff)
    moreover from q have "Suc q = m + w + r" by (simp add: w_def)
    moreover from q have "Suc (Suc q) = v + w + r" by (simp add: v_def w_def)
    ultimately have "w dvd Suc (Suc (q + (w - v mod w))) \<longleftrightarrow> w dvd Suc (q + (w - m mod w))"
      by (simp only: add_Suc [symmetric])
    then have "Suc n dvd Suc (Suc (Suc (q + n) - Suc m mod Suc n)) \<longleftrightarrow>
      Suc n dvd Suc (Suc (q + n - m mod Suc n))"
      by (simp add: v_def w_def Suc_diff_le trans_le_add2)
  }
  then show ?thesis3
    by (auto simp add: mark_out_aux_def
      enumerate_Suc_eq in_set_enumerate_eq not_less)
qed

text {* Main entry point to sieve *}

fun sieve :: "nat \<Rightarrow> marks \<Rightarrow> marks"
where
  "sieve n [] = []"
| "sieve n (False # bs) = False # sieve (Suc n) bs"
| "sieve n (True # bs) = True # sieve (Suc n) (mark_out n bs)"

text {*
  There are the following possible optimisations here:

  \begin{itemize}

    \item @{const sieve} can abort as soon as @{term n} is too big to let
      @{const mark_out} have any effect.

    \item Search for further primes can be given up as soon as the search
      position exceeds the square root of the maximum candidate.

  \end{itemize}

  This is left as an constructive exercise to the reader.
*}

lemma numbers_of_marks_sieve:
  "numbers_of_marks (Suc n) (sieve n bs) =
    {q \<in> numbers_of_marks (Suc n) bs. \<forall>m \<in> numbers_of_marks (Suc n) bs. \<not> m dvd_strict q}"
proof (induct n bs rule: sieve.induct)
  case 1 show ?case by simp
next
  case 2 then show ?case by simp
next
  case (3 n bs)
  have aux: "\<And>M n. n \<in> Suc ` M \<longleftrightarrow> n > 0 \<and> n - 1 \<in> M"
  proof
    fix M and n
    assume "n \<in> Suc ` M" then show "n > 0 \<and> n - 1 \<in> M" by auto
  next
    fix M and n :: nat
    assume "n > 0 \<and> n - 1 \<in> M"
    then have "n > 0" and "n - 1 \<in> M" by auto
    then have "Suc (n - 1) \<in> Suc ` M" by blast
    with `n > 0` show "n \<in> Suc ` M" by simp
  qed
  { fix m :: nat
    assume "Suc (Suc n) \<le> m" and "m dvd Suc n"
    from `m dvd Suc n` obtain q where "Suc n = m * q" ..
    with `Suc (Suc n) \<le> m` have "Suc (m * q) \<le> m" by simp
    then have "m * q < m" by arith
    then have "q = 0" by simp
    with `Suc n = m * q` have False by simp
  } note aux1 = this
  { fix m q :: nat
    assume "\<forall>q>0. 1 < q \<longrightarrow> Suc n < q \<longrightarrow> q \<le> Suc (n + length bs)
      \<longrightarrow> bs ! (q - Suc (Suc n)) \<longrightarrow> \<not> Suc n dvd q \<longrightarrow> q dvd m \<longrightarrow> m dvd q"
    then have *: "\<And>q. Suc n < q \<Longrightarrow> q \<le> Suc (n + length bs)
      \<Longrightarrow> bs ! (q - Suc (Suc n)) \<Longrightarrow> \<not> Suc n dvd q \<Longrightarrow> q dvd m \<Longrightarrow> m dvd q"
      by auto
    assume "\<not> Suc n dvd m" and "q dvd m"
    then have "\<not> Suc n dvd q" by (auto elim: dvdE)
    moreover assume "Suc n < q" and "q \<le> Suc (n + length bs)"
      and "bs ! (q - Suc (Suc n))"
    moreover note `q dvd m`
    ultimately have "m dvd q" by (auto intro: *)
  } note aux2 = this
  from 3 show ?case
    apply (simp_all add: numbers_of_marks_mark_out numbers_of_marks_Suc Compr_image_eq inj_image_eq_iff
      in_numbers_of_marks_eq Ball_def imp_conjL aux)
    apply safe
    apply (simp_all add: less_diff_conv2 le_diff_conv2 dvd_minus_self not_less)
    apply (clarsimp dest!: aux1)
    apply (simp add: Suc_le_eq less_Suc_eq_le)
    apply (rule aux2) apply (clarsimp dest!: aux1)+
    done
qed

text {* Relation of the sieve algorithm to actual primes *}

definition primes_upto :: "nat \<Rightarrow> nat list"
where
  "primes_upto n = sorted_list_of_set {m. m \<le> n \<and> prime m}"

lemma set_primes_upto:
  "set (primes_upto n) = {m. m \<le> n \<and> prime m}"
  by (simp add: primes_upto_def)

lemma sorted_primes_upto [iff]:
  "sorted (primes_upto n)"
  by (simp add: primes_upto_def)

lemma distinct_primes_upto [iff]:
  "distinct (primes_upto n)"
  by (simp add: primes_upto_def)

lemma set_primes_upto_sieve:
  "set (primes_upto n) = numbers_of_marks 2 (sieve 1 (replicate (n - 1) True))"
proof (cases "n > 1")
  case False then have "n = 0 \<or> n = 1" by arith
  then show ?thesis
    by (auto simp add: numbers_of_marks_sieve numeral_2_eq_2 set_primes_upto dest: prime_gt_Suc_0_nat)
next
  { fix m q
    assume "Suc (Suc 0) \<le> q"
      and "q < Suc n"
      and "m dvd q"
    then have "m < Suc n" by (auto dest: dvd_imp_le)
    assume *: "\<forall>m\<in>{Suc (Suc 0)..<Suc n}. m dvd q \<longrightarrow> q dvd m"
      and "m dvd q" and "m \<noteq> 1"
    have "m = q" proof (cases "m = 0")
      case True with `m dvd q` show ?thesis by simp
    next
      case False with `m \<noteq> 1` have "Suc (Suc 0) \<le> m" by arith
      with `m < Suc n` * `m dvd q` have "q dvd m" by simp
      with `m dvd q` show ?thesis by (simp add: dvd.eq_iff)
    qed
  }
  then have aux: "\<And>m q. Suc (Suc 0) \<le> q \<Longrightarrow>
    q < Suc n \<Longrightarrow>
    m dvd q \<Longrightarrow>
    \<forall>m\<in>{Suc (Suc 0)..<Suc n}. m dvd q \<longrightarrow> q dvd m \<Longrightarrow>
    m dvd q \<Longrightarrow> m \<noteq> q \<Longrightarrow> m = 1" by auto
  case True then show ?thesis
    apply (auto simp add: One_nat_def numbers_of_marks_sieve numeral_2_eq_2 set_primes_upto
        dest: prime_gt_Suc_0_nat)
    apply (metis One_nat_def Suc_le_eq less_not_refl prime_nat_def)
    apply (metis One_nat_def Suc_le_eq aux prime_nat_def)
    done
qed

lemma primes_upto_sieve [code]:
  "primes_upto n = map fst (filter snd (enumerate 2 (sieve 1 (replicate (n - 1) True))))"
proof -
  have "primes_upto n = sorted_list_of_set (numbers_of_marks 2 (sieve 1 (replicate (n - 1) True)))"
    apply (rule sorted_distinct_set_unique)
    apply (simp_all only: set_primes_upto_sieve numbers_of_marks_def)
    apply auto
    done
  then show ?thesis by (simp add: sorted_list_of_set_numbers_of_marks)
qed

lemma prime_in_primes_upto:
  "prime n \<longleftrightarrow> n \<in> set (primes_upto n)"
  by (simp add: set_primes_upto)

subsection {* Application: smallest prime beyond a certain number *}

definition smallest_prime_beyond :: "nat \<Rightarrow> nat"
where
  "smallest_prime_beyond n = (LEAST p. prime p \<and> p \<ge> n)"

lemma
  prime_smallest_prime_beyond [iff]: "prime (smallest_prime_beyond n)" (is ?P)
  and smallest_prime_beyond_le [iff]: "smallest_prime_beyond n \<ge> n" (is ?Q)
proof -
  let ?least = "LEAST p. prime p \<and> p \<ge> n"
  from primes_infinite obtain q where "prime q \<and> q \<ge> n"
    by (metis finite_nat_set_iff_bounded_le mem_Collect_eq nat_le_linear)
  then have "prime ?least \<and> ?least \<ge> n" by (rule LeastI)
  then show ?P and ?Q by (simp_all add: smallest_prime_beyond_def)
qed

lemma smallest_prime_beyond_smallest:
  "prime p \<Longrightarrow> p \<ge> n \<Longrightarrow> smallest_prime_beyond n \<le> p"
  by (simp only: smallest_prime_beyond_def) (auto intro: Least_le)

lemma smallest_prime_beyond_eq:
  "prime p \<Longrightarrow> p \<ge> n \<Longrightarrow> (\<And>q. prime q \<Longrightarrow> q \<ge> n \<Longrightarrow> q \<ge> p) \<Longrightarrow> smallest_prime_beyond n = p"
  by (simp only: smallest_prime_beyond_def) (auto intro: Least_equality)

definition smallest_prime_between :: "nat \<Rightarrow> nat \<Rightarrow> nat option"
where
  "smallest_prime_between m n =
    (if (\<exists>p. prime p \<and> m \<le> p \<and> p \<le> n) then Some (smallest_prime_beyond m) else None)"

lemma smallest_prime_between_None:
  "smallest_prime_between m n = None \<longleftrightarrow> (\<forall>q. m \<le> q \<and> q \<le> n \<longrightarrow> \<not> prime q)"
  by (auto simp add: smallest_prime_between_def)

lemma smallest_prime_betwen_Some:
  "smallest_prime_between m n = Some p \<longleftrightarrow> smallest_prime_beyond m = p \<and> p \<le> n"
  by (auto simp add: smallest_prime_between_def dest: smallest_prime_beyond_smallest [of _ m])

definition smallest_prime_beyond_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "smallest_prime_beyond_aux k n = smallest_prime_beyond n"

lemma [code]:
  "smallest_prime_beyond_aux k n =
    (case smallest_prime_between n (k * n)
     of Some p \<Rightarrow> p
      | None \<Rightarrow> smallest_prime_beyond_aux (Suc k) n)"
  by (simp add: smallest_prime_beyond_aux_def smallest_prime_betwen_Some split: option.split)

lemma [code]:
  "smallest_prime_beyond n = smallest_prime_beyond_aux 2 n"
  by (simp add: smallest_prime_beyond_aux_def)

end


theory tmpl02_aexp
  imports Main
begin

type_synonym vname = string
type_synonym state = "string \<Rightarrow> int"
type_synonym val = "int"

declare algebra_simps[simp]

datatype aexp = N int | V vname | Plus aexp aexp | Mult int aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s" |
"aval (Mult i a) s = i * aval a s"

text \<open>
  \textbf{Step A} Implement the function @{text normal} which returns @{const True} only when the
  arithmetic expression is normalized.
\<close>

fun normal :: "aexp \<Rightarrow> bool" where
  "normal a = undefined"

text \<open>
  \textbf{Step B} Implement the function @{text normallize} which translates an arbitrary arithmetic
  expression intro a normalized arithmetic expression.
\<close>

fun normalize :: "aexp \<Rightarrow> aexp" where
  "normalize a = undefined"

text \<open>
  \textbf{Step C} Prove that @{const normalize} does not change the result of the arithmetic
  expression.
\<close>

lemma "aval (normalize a) s = aval a s"
  oops

text \<open>
  \textbf{Step D} Prove that @{const normalize} does indeed return a normalized arithmetic
  expression.
\<close>

lemma "normal (normalize a)"
  oops

end


theory HSV_tasks_2021 imports Complex_Main begin

section \<open>Task 1: Factorising circuits.\<close>

(* Datatype for representing simple circuits. *)
datatype "circuit" =
  NOT "circuit"
| AND "circuit" "circuit"
| OR "circuit" "circuit"
| TRUE
| FALSE
| INPUT "int"

(* Simulates a circuit given a valuation for each input wire. *)
fun simulate where
  "simulate (AND c1 c2) \<rho> = ((simulate c1 \<rho>) \<and> (simulate c2 \<rho>))"
| "simulate (OR c1 c2) \<rho> = ((simulate c1 \<rho>) \<or> (simulate c2 \<rho>))"
| "simulate (NOT c) \<rho> = (\<not> (simulate c \<rho>))"
| "simulate TRUE \<rho> = True"
| "simulate FALSE \<rho> = False"
| "simulate (INPUT i) \<rho> = \<rho> i"

(* Equivalence between circuits. *)
fun circuits_equiv (infix "\<sim>" 50) (* the "50" indicates the operator precedence *) where
  "c1 \<sim> c2 = (\<forall>\<rho>. simulate c1 \<rho> = simulate c2 \<rho>)"

(* An optimisation that exploits the following Boolean identities:
  `(a | b) & (a | c) = a | (b & c)`
  `(a | b) & (c | a) = a | (b & c)`
  `(a | b) & (b | c) = b | (a & c)`
  `(a | b) & (c | b) = b | (a & c)`
 *)
fun factorise where
  "factorise (NOT c) = NOT (factorise c)"
| "factorise (AND (OR c1 c2) (OR c3 c4)) = (
    let c1' = factorise c1; c2' = factorise c2; c3' = factorise c3; c4' = factorise c4 in
    if c1' = c3' then OR c1' (AND c2' c4')
    else if c1' = c4' then OR c1' (AND c2' c3')
    else if c2' = c3' then OR c2' (AND c1' c4')
    else if c2' = c4' then OR c2' (AND c1' c3')
    else AND (OR c1' c2') (OR c3' c4'))"
| "factorise (AND c1 c2) = AND (factorise c1) (factorise c2)"
| "factorise (OR c1 c2) = OR (factorise c1) (factorise c2)"
| "factorise TRUE = TRUE"
| "factorise FALSE = FALSE"
| "factorise (INPUT i) = INPUT i"

lemma (* test case *)
 "factorise (AND TRUE TRUE) = AND TRUE TRUE"
  by eval
lemma (* test case *)
  "factorise (AND (OR (INPUT 1) FALSE) (OR TRUE (INPUT 1))) =
  OR (INPUT 1) (AND FALSE TRUE)"
  by eval
lemma (* test case *)
  "factorise (NOT (AND (OR FALSE (INPUT 2)) (OR TRUE (INPUT 2)))) =
  NOT (OR (INPUT 2) (AND FALSE TRUE))"
  by eval

theorem factorise_is_sound: "factorise c \<sim> c"
  sorry

fun factorise2 where "factorise2 c = c" (* dummy definition *)

lemma (* test case *)
  "factorise2 (OR (AND (INPUT 1) (INPUT 2)) (AND TRUE (INPUT 1))) =
  AND (INPUT 1) (OR (INPUT 2) TRUE)"
  sorry

theorem factorise2_is_sound: "factorise2 c \<sim> c"
  sorry

section \<open>Task 2: A theorem about divisibility.\<close>

(* NB: Without the "::int" annotation, Isabelle will try to prove a
   slightly more general theorem where "a" and "b" can be either ints
   or nats. That more general theorem is a little harder to prove. *)
theorem plus_dvd_odd_power:
  "(a::int) + b dvd a ^ (2 * n + 1) + b ^ (2 * n + 1)"
  sorry

section \<open>Task 3: Proving that the shift-and-add-3 algorithm is correct.\<close>

subsection \<open>Binary and its conversion to nat\<close>

type_synonym bit = "bool"

abbreviation B0 where "B0 == False"
abbreviation B1 where "B1 == True"

fun binary_to_nat :: "bit list \<Rightarrow> nat"
where
  "binary_to_nat [] = 0"
| "binary_to_nat (b # bs) = (if b then 2 ^ length bs else 0) + binary_to_nat bs"

lemma (* test case *) "binary_to_nat [B0, B1, B0, B1] = 5" by eval
lemma (* test case *) "binary_to_nat [B0, B0, B1, B0, B1] = 5" by eval
lemma (* test case *) "binary_to_nat [B1] = 1" by eval
lemma (* test case *) "binary_to_nat [B0] = 0" by eval

subsection \<open>BCD and its conversion to nat\<close>

type_synonym nibble = "bit * bit * bit * bit"

fun nibble_to_nat :: "nibble \<Rightarrow> nat"
where
  "nibble_to_nat (B0,B0,B0,B0) = 0"
| "nibble_to_nat (B0,B0,B0,B1) = 1"
| "nibble_to_nat (B0,B0,B1,B0) = 2"
| "nibble_to_nat (B0,B0,B1,B1) = 3"
| "nibble_to_nat (B0,B1,B0,B0) = 4"
| "nibble_to_nat (B0,B1,B0,B1) = 5"
| "nibble_to_nat (B0,B1,B1,B0) = 6"
| "nibble_to_nat (B0,B1,B1,B1) = 7"
| "nibble_to_nat (B1,B0,B0,B0) = 8"
| "nibble_to_nat (B1,B0,B0,B1) = 9"
| "nibble_to_nat (B1,B0,B1,B0) = 10"
| "nibble_to_nat (B1,B0,B1,B1) = 11"
| "nibble_to_nat (B1,B1,B0,B0) = 12"
| "nibble_to_nat (B1,B1,B0,B1) = 13"
| "nibble_to_nat (B1,B1,B1,B0) = 14"
| "nibble_to_nat (B1,B1,B1,B1) = 15"

fun bcd_to_nat :: "nibble list \<Rightarrow> nat"
where
  "bcd_to_nat [] = 0"
| "bcd_to_nat (n # ns) = bcd_to_nat ns + nibble_to_nat n * 10 ^ length ns"

lemma (* test case *) "bcd_to_nat [(B0,B1,B1,B0)] = 6" by eval
lemma (* test case *) "bcd_to_nat [(B0,B1,B1,B0),(B1,B0,B0,B1)] = 69" by eval
lemma (* test case *) "bcd_to_nat [(B0,B0,B0,B0),(B1,B0,B0,B1)] = 9" by eval
lemma (* test case *) "bcd_to_nat [(B0,B0,B1,B1),(B0,B0,B0,B0)] = 30" by eval

subsection \<open>Converting binary to BCD\<close>

fun binary_to_bcd :: "bit list \<Rightarrow> nibble list"
where
  "binary_to_bcd bs = []" (* dummy definition *)

lemma (* test case *)
  "binary_to_bcd [B1,B0,B1,B0,B1,B0,B1] = [(B1,B0,B0,B0), (B0,B1,B0,B1)]"
  sorry

subsection \<open>Checking that nibbles correspond to valid BCD digits\<close>

fun valid_nibble :: "nibble \<Rightarrow> bool"
where
  "valid_nibble (B0,B0,B0,B0) = True"
| "valid_nibble (B0,B0,B0,B1) = True"
| "valid_nibble (B0,B0,B1,B0) = True"
| "valid_nibble (B0,B0,B1,B1) = True"
| "valid_nibble (B0,B1,B0,B0) = True"
| "valid_nibble (B0,B1,B0,B1) = True"
| "valid_nibble (B0,B1,B1,B0) = True"
| "valid_nibble (B0,B1,B1,B1) = True"
| "valid_nibble (B1,B0,B0,B0) = True"
| "valid_nibble (B1,B0,B0,B1) = True"
| "valid_nibble (B1,B0,B1,B0) = False"
| "valid_nibble (B1,B0,B1,B1) = False"
| "valid_nibble (B1,B1,B0,B0) = False"
| "valid_nibble (B1,B1,B0,B1) = False"
| "valid_nibble (B1,B1,B1,B0) = False"
| "valid_nibble (B1,B1,B1,B1) = False"

theorem binary_to_bcd_valid:
  "list_all valid_nibble (binary_to_bcd bs)"
  sorry

subsection \<open>Proof that the binary_to_bcd translation is correct.\<close>

theorem binary_to_bcd_correct:
  "bcd_to_nat (binary_to_bcd bs) = binary_to_nat bs"
  sorry

end


(*  Title:      HOL/Number_Theory/Fib.thy
    Author:     Lawrence C. Paulson
    Author:     Jeremy Avigad
    Author:     Manuel Eberl
*)

section \<open>The fibonacci function\<close>

theory Fib
  imports Complex_Main
begin

subsection \<open>Fibonacci numbers\<close>

fun fib :: "nat \<Rightarrow> nat"
  where
    fib0: "fib 0 = 0"
  | fib1: "fib (Suc 0) = 1"
  | fib2: "fib (Suc (Suc n)) = fib (Suc n) + fib n"

subsection \<open>Basic Properties\<close>

lemma fib_1 [simp]: "fib 1 = 1"
  by (metis One_nat_def fib1)

lemma fib_2 [simp]: "fib 2 = 1"
  using fib.simps(3) [of 0] by (simp add: numeral_2_eq_2)

lemma fib_plus_2: "fib (n + 2) = fib (n + 1) + fib n"
  by (metis Suc_eq_plus1 add_2_eq_Suc' fib.simps(3))

lemma fib_add: "fib (Suc (n + k)) = fib (Suc k) * fib (Suc n) + fib k * fib n"
  by (induct n rule: fib.induct) (auto simp add: field_simps)

lemma fib_neq_0_nat: "n > 0 \<Longrightarrow> fib n > 0"
  by (induct n rule: fib.induct) auto

lemma fib_Suc_mono: "fib m \<le> fib (Suc m)"
by(induction m) auto

lemma fib_mono: "m \<le> n \<Longrightarrow> fib m \<le> fib n"
by (simp add: fib_Suc_mono lift_Suc_mono_le)

subsection \<open>More efficient code\<close>

text \<open>
  The naive approach is very inefficient since the branching recursion leads to many
  values of \<^term>\<open>fib\<close> being computed multiple times. We can avoid this by ``remembering''
  the last two values in the sequence, yielding a tail-recursive version.
  This is far from optimal (it takes roughly $O(n\cdot M(n))$ time where $M(n)$ is the
  time required to multiply two $n$-bit integers), but much better than the naive version,
  which is exponential.
\<close>

fun gen_fib :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
  where
    "gen_fib a b 0 = a"
  | "gen_fib a b (Suc 0) = b"
  | "gen_fib a b (Suc (Suc n)) = gen_fib b (a + b) (Suc n)"

lemma gen_fib_recurrence: "gen_fib a b (Suc (Suc n)) = gen_fib a b n + gen_fib a b (Suc n)"
  by (induct a b n rule: gen_fib.induct) simp_all

lemma gen_fib_fib: "gen_fib (fib n) (fib (Suc n)) m = fib (n + m)"
  by (induct m rule: fib.induct) (simp_all del: gen_fib.simps(3) add: gen_fib_recurrence)

lemma fib_conv_gen_fib: "fib n = gen_fib 0 1 n"
  using gen_fib_fib[of 0 n] by simp

declare fib_conv_gen_fib [code]

subsection \<open>A Few Elementary Results\<close>

text \<open>
  \<^medskip> Concrete Mathematics, page 278: Cassini's identity.  The proof is
  much easier using integers, not natural numbers!
\<close>

lemma fib_Cassini_int: "int (fib (Suc (Suc n)) * fib n) - int((fib (Suc n))\<^sup>2) = - ((-1)^n)"
  by (induct n rule: fib.induct) (auto simp add: field_simps power2_eq_square power_add)

lemma fib_Cassini_nat:
  "fib (Suc (Suc n)) * fib n =
     (if even n then (fib (Suc n))\<^sup>2 - 1 else (fib (Suc n))\<^sup>2 + 1)"
  using fib_Cassini_int [of n] by (auto simp del: of_nat_mult of_nat_power)

subsection \<open>Law 6.111 of Concrete Mathematics\<close>

lemma coprime_fib_Suc_nat: "coprime (fib n) (fib (Suc n))"
  apply (induct n rule: fib.induct)
    apply (simp_all add: coprime_iff_gcd_eq_1 algebra_simps)
  apply (simp add: add.assoc [symmetric])
  done

lemma gcd_fib_add:
  "gcd (fib m) (fib (n + m)) = gcd (fib m) (fib n)"
proof (cases m)
  case 0
  then show ?thesis
    by simp
next
  case (Suc q)
  from coprime_fib_Suc_nat [of q]
  have "coprime (fib (Suc q)) (fib q)"
    by (simp add: ac_simps)
  have "gcd (fib q) (fib (Suc q)) = Suc 0"
    using coprime_fib_Suc_nat [of q] by simp
  then have *: "gcd (fib n * fib q) (fib n * fib (Suc q)) = fib n"
    by (simp add: gcd_mult_distrib_nat [symmetric])
  moreover have "gcd (fib (Suc q)) (fib n * fib q + fib (Suc n) * fib (Suc q)) =
    gcd (fib (Suc q)) (fib n * fib q)"
    using gcd_add_mult [of "fib (Suc q)"] by (simp add: ac_simps)
  moreover have "gcd (fib (Suc q)) (fib n * fib (Suc q)) = fib (Suc q)"
    by simp
  ultimately show ?thesis
    using Suc \<open>coprime (fib (Suc q)) (fib q)\<close>
    by (auto simp add: fib_add algebra_simps gcd_mult_right_right_cancel)
qed

lemma gcd_fib_diff: "m \<le> n \<Longrightarrow> gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)"
  by (simp add: gcd_fib_add [symmetric, of _ "n-m"])

lemma gcd_fib_mod: "0 < m \<Longrightarrow> gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
proof (induct n rule: less_induct)
  case (less n)
  show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
  proof (cases "m < n")
    case True
    then have "m \<le> n" by auto
    with \<open>0 < m\<close> have "0 < n" by auto
    with \<open>0 < m\<close> \<open>m < n\<close> have *: "n - m < n" by auto
    have "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib ((n - m) mod m))"
      by (simp add: mod_if [of n]) (use \<open>m < n\<close> in auto)
    also have "\<dots> = gcd (fib m)  (fib (n - m))"
      by (simp add: less.hyps * \<open>0 < m\<close>)
    also have "\<dots> = gcd (fib m) (fib n)"
      by (simp add: gcd_fib_diff \<open>m \<le> n\<close>)
    finally show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" .
  next
    case False
    then show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
      by (cases "m = n") auto
  qed
qed

lemma fib_gcd: "fib (gcd m n) = gcd (fib m) (fib n)"  \<comment> \<open>Law 6.111\<close>
  by (induct m n rule: gcd_nat_induct) (simp_all add: gcd_non_0_nat gcd.commute gcd_fib_mod)

theorem fib_mult_eq_sum_nat: "fib (Suc n) * fib n = (\<Sum>k \<in> {..n}. fib k * fib k)"
  by (induct n rule: nat.induct) (auto simp add:  field_simps)

subsection \<open>Closed form\<close>

lemma fib_closed_form:
  fixes \<phi> \<psi> :: real
  defines "\<phi> \<equiv> (1 + sqrt 5) / 2"
    and "\<psi> \<equiv> (1 - sqrt 5) / 2"
  shows "of_nat (fib n) = (\<phi> ^ n - \<psi> ^ n) / sqrt 5"
proof (induct n rule: fib.induct)
  fix n :: nat
  assume IH1: "of_nat (fib n) = (\<phi> ^ n - \<psi> ^ n) / sqrt 5"
  assume IH2: "of_nat (fib (Suc n)) = (\<phi> ^ Suc n - \<psi> ^ Suc n) / sqrt 5"
  have "of_nat (fib (Suc (Suc n))) = of_nat (fib (Suc n)) + of_nat (fib n)" by simp
  also have "\<dots> = (\<phi>^n * (\<phi> + 1) - \<psi>^n * (\<psi> + 1)) / sqrt 5"
    by (simp add: IH1 IH2 field_simps)
  also have "\<phi> + 1 = \<phi>\<^sup>2" by (simp add: \<phi>_def field_simps power2_eq_square)
  also have "\<psi> + 1 = \<psi>\<^sup>2" by (simp add: \<psi>_def field_simps power2_eq_square)
  also have "\<phi>^n * \<phi>\<^sup>2 - \<psi>^n * \<psi>\<^sup>2 = \<phi> ^ Suc (Suc n) - \<psi> ^ Suc (Suc n)"
    by (simp add: power2_eq_square)
  finally show "of_nat (fib (Suc (Suc n))) = (\<phi> ^ Suc (Suc n) - \<psi> ^ Suc (Suc n)) / sqrt 5" .
qed (simp_all add: \<phi>_def \<psi>_def field_simps)

lemma fib_closed_form':
  fixes \<phi> \<psi> :: real
  defines "\<phi> \<equiv> (1 + sqrt 5) / 2"
    and "\<psi> \<equiv> (1 - sqrt 5) / 2"
  assumes "n > 0"
  shows "fib n = round (\<phi> ^ n / sqrt 5)"
proof (rule sym, rule round_unique')
  have "\<bar>\<phi> ^ n / sqrt 5 - of_int (int (fib n))\<bar> = \<bar>\<psi>\<bar> ^ n / sqrt 5"
    by (simp add: fib_closed_form[folded \<phi>_def \<psi>_def] field_simps power_abs)
  also {
    from assms have "\<bar>\<psi>\<bar>^n \<le> \<bar>\<psi>\<bar>^1"
      by (intro power_decreasing) (simp_all add: algebra_simps real_le_lsqrt)
    also have "\<dots> < sqrt 5 / 2" by (simp add: \<psi>_def field_simps)
    finally have "\<bar>\<psi>\<bar>^n / sqrt 5 < 1/2" by (simp add: field_simps)
  }
  finally show "\<bar>\<phi> ^ n / sqrt 5 - of_int (int (fib n))\<bar> < 1/2" .
qed

lemma fib_asymptotics:
  fixes \<phi> :: real
  defines "\<phi> \<equiv> (1 + sqrt 5) / 2"
  shows "(\<lambda>n. real (fib n) / (\<phi> ^ n / sqrt 5)) \<longlonglongrightarrow> 1"
proof -
  define \<psi> :: real where "\<psi> \<equiv> (1 - sqrt 5) / 2"
  have "\<phi> > 1" by (simp add: \<phi>_def)
  then have *: "\<phi> \<noteq> 0" by auto
  have "(\<lambda>n. (\<psi> / \<phi>) ^ n) \<longlonglongrightarrow> 0"
    by (rule LIMSEQ_power_zero) (simp_all add: \<phi>_def \<psi>_def field_simps add_pos_pos)
  then have "(\<lambda>n. 1 - (\<psi> / \<phi>) ^ n) \<longlonglongrightarrow> 1 - 0"
    by (intro tendsto_diff tendsto_const)
  with * have "(\<lambda>n. (\<phi> ^ n - \<psi> ^ n) / \<phi> ^ n) \<longlonglongrightarrow> 1"
    by (simp add: field_simps)
  then show ?thesis
    by (simp add: fib_closed_form \<phi>_def \<psi>_def)
qed

subsection \<open>Divide-and-Conquer recurrence\<close>

text \<open>
  The following divide-and-conquer recurrence allows for a more efficient computation
  of Fibonacci numbers; however, it requires memoisation of values to be reasonably
  efficient, cutting the number of values to be computed to logarithmically many instead of
  linearly many. The vast majority of the computation time is then actually spent on the
  multiplication, since the output number is exponential in the input number.
\<close>

lemma fib_rec_odd:
  fixes \<phi> \<psi> :: real
  defines "\<phi> \<equiv> (1 + sqrt 5) / 2"
    and "\<psi> \<equiv> (1 - sqrt 5) / 2"
  shows "fib (Suc (2 * n)) = fib n^2 + fib (Suc n)^2"
proof -
  have "of_nat (fib n^2 + fib (Suc n)^2) = ((\<phi> ^ n - \<psi> ^ n)\<^sup>2 + (\<phi> * \<phi> ^ n - \<psi> * \<psi> ^ n)\<^sup>2)/5"
    by (simp add: fib_closed_form[folded \<phi>_def \<psi>_def] field_simps power2_eq_square)
  also
  let ?A = "\<phi>^(2 * n) + \<psi>^(2 * n) - 2*(\<phi> * \<psi>)^n + \<phi>^(2 * n + 2) + \<psi>^(2 * n + 2) - 2*(\<phi> * \<psi>)^(n + 1)"
  have "(\<phi> ^ n - \<psi> ^ n)\<^sup>2 + (\<phi> * \<phi> ^ n - \<psi> * \<psi> ^ n)\<^sup>2 = ?A"
    by (simp add: power2_eq_square algebra_simps power_mult power_mult_distrib)
  also have "\<phi> * \<psi> = -1"
    by (simp add: \<phi>_def \<psi>_def field_simps)
  then have "?A = \<phi>^(2 * n + 1) * (\<phi> + inverse \<phi>) + \<psi>^(2 * n + 1) * (\<psi> + inverse \<psi>)"
    by (auto simp: field_simps power2_eq_square)
  also have "1 + sqrt 5 > 0"
    by (auto intro: add_pos_pos)
  then have "\<phi> + inverse \<phi> = sqrt 5"
    by (simp add: \<phi>_def field_simps)
  also have "\<psi> + inverse \<psi> = -sqrt 5"
    by (simp add: \<psi>_def field_simps)
  also have "(\<phi> ^ (2 * n + 1) * sqrt 5 + \<psi> ^ (2 * n + 1) * - sqrt 5) / 5 =
    (\<phi> ^ (2 * n + 1) - \<psi> ^ (2 * n + 1)) * (sqrt 5 / 5)"
    by (simp add: field_simps)
  also have "sqrt 5 / 5 = inverse (sqrt 5)"
    by (simp add: field_simps)
  also have "(\<phi> ^ (2 * n + 1) - \<psi> ^ (2 * n + 1)) * \<dots> = of_nat (fib (Suc (2 * n)))"
    by (simp add: fib_closed_form[folded \<phi>_def \<psi>_def] divide_inverse)
  finally show ?thesis
    by (simp only: of_nat_eq_iff)
qed

lemma fib_rec_even: "fib (2 * n) = (fib (n - 1) + fib (n + 1)) * fib n"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  let ?rfib = "\<lambda>x. real (fib x)"
  have "2 * (Suc n) = Suc (Suc (2 * n))" by simp
  also have "real (fib \<dots>) = ?rfib n^2 + ?rfib (Suc n)^2 + (?rfib (n - 1) + ?rfib (n + 1)) * ?rfib n"
    by (simp add: fib_rec_odd Suc)
  also have "(?rfib (n - 1) + ?rfib (n + 1)) * ?rfib n = (2 * ?rfib (n + 1) - ?rfib n) * ?rfib n"
    by (cases n) simp_all
  also have "?rfib n^2 + ?rfib (Suc n)^2 + \<dots> = (?rfib (Suc n) + 2 * ?rfib n) * ?rfib (Suc n)"
    by (simp add: algebra_simps power2_eq_square)
  also have "\<dots> = real ((fib (Suc n - 1) + fib (Suc n + 1)) * fib (Suc n))" by simp
  finally show ?case by (simp only: of_nat_eq_iff)
qed

lemma fib_rec_even': "fib (2 * n) = (2 * fib (n - 1) + fib n) * fib n"
  by (subst fib_rec_even, cases n) simp_all

lemma fib_rec:
  "fib n =
    (if n = 0 then 0 else if n = 1 then 1
     else if even n then let n' = n div 2; fn = fib n' in (2 * fib (n' - 1) + fn) * fn
     else let n' = n div 2 in fib n' ^ 2 + fib (Suc n') ^ 2)"
  by (auto elim: evenE oddE simp: fib_rec_odd fib_rec_even' Let_def)

subsection \<open>Fibonacci and Binomial Coefficients\<close>

lemma sum_drop_zero: "(\<Sum>k = 0..Suc n. if 0<k then (f (k - 1)) else 0) = (\<Sum>j = 0..n. f j)"
  by (induct n) auto

lemma sum_choose_drop_zero:
  "(\<Sum>k = 0..Suc n. if k = 0 then 0 else (Suc n - k) choose (k - 1)) =
    (\<Sum>j = 0..n. (n-j) choose j)"
  by (rule trans [OF sum.cong sum_drop_zero]) auto

lemma ne_diagonal_fib: "(\<Sum>k = 0..n. (n-k) choose k) = fib (Suc n)"
proof (induct n rule: fib.induct)
  case 1
  show ?case by simp
next
  case 2
  show ?case by simp
next
  case (3 n)
  have "(\<Sum>k = 0..Suc n. Suc (Suc n) - k choose k) =
     (\<Sum>k = 0..Suc n. (Suc n - k choose k) + (if k = 0 then 0 else (Suc n - k choose (k - 1))))"
    by (rule sum.cong) (simp_all add: choose_reduce_nat)
  also have "\<dots> =
    (\<Sum>k = 0..Suc n. Suc n - k choose k) +
    (\<Sum>k = 0..Suc n. if k=0 then 0 else (Suc n - k choose (k - 1)))"
    by (simp add: sum.distrib)
  also have "\<dots> = (\<Sum>k = 0..Suc n. Suc n - k choose k) + (\<Sum>j = 0..n. n - j choose j)"
    by (metis sum_choose_drop_zero)
  finally show ?case using 3
    by simp
qed

end