(*  Title:   HyperdualFunctionExtension.thy
    Authors: Jacques D. Fleuriot and Filip Smola, University of Edinburgh, 2021
*)

section \<open>Hyperdual Extension of Functions\<close>

theory HyperdualFunctionExtension
  imports Hyperdual TwiceFieldDifferentiable
begin

text\<open>The following is an important fact in the derivation of the hyperdual extension.\<close>
lemma
    fixes x :: "('a :: comm_ring_1) hyperdual" and n :: nat
  assumes "Base x = 0"
    shows "x ^ (n + 3) = 0"
proof (induct n)
  case 0
  then show ?case
    using assms hyperdual_power[of x 3] by simp
next
  case (Suc n)
  then show ?case
    using assms power_Suc[of x "n + 3"] mult_zero_right add_Suc by simp
qed

text\<open>We define the extension of a function to the hyperdual numbers.\<close>
primcorec hypext :: "(('a :: real_normed_field) \<Rightarrow> 'a) \<Rightarrow> 'a hyperdual \<Rightarrow> 'a hyperdual" (\<open>*h* _\<close> [80] 80)
  where
    "Base ((*h* f) x) = f (Base x)"
  | "Eps1 ((*h* f) x) = Eps1 x * deriv f (Base x)"
  | "Eps2 ((*h* f) x) = Eps2 x * deriv f (Base x)"
  | "Eps12 ((*h* f) x) = Eps12 x * deriv f (Base x) + Eps1 x * Eps2 x * deriv (deriv f) (Base x)"

text\<open>This has the expected behaviour when expressed in terms of the units.\<close>
lemma hypext_Hyperdual_eq:
  "(*h* f) (Hyperdual a b c d) =
     Hyperdual (f a) (b * deriv f a) (c * deriv f a) (d * deriv f a + b * c * deriv (deriv f) a)"
  by (simp add: hypext.code)

lemma hypext_Hyperdual_eq_parts:
  "(*h* f) (Hyperdual a b c d) =
      f a *\<^sub>H ba + (b * deriv f a) *\<^sub>H e1 + (c * deriv f a) *\<^sub>H e2 +
         (d * deriv f a + b * c * deriv (deriv f) a) *\<^sub>H e12 "
  by (metis Hyperdual_eq hypext_Hyperdual_eq)

text\<open>
  The extension can be used to extract the function value, and first and second derivatives at x
  when applied to @{term "x *\<^sub>H re + e1 + e2 + 0 *\<^sub>H e12"}, which we denote by @{term "\<beta> x"}.
\<close>
definition hyperdualx :: "('a :: real_normed_field) \<Rightarrow> 'a hyperdual" ("\<beta>")
  where "\<beta> x = (Hyperdual x 1 1 0)"

lemma hyperdualx_sel [simp]:
  shows "Base (\<beta> x) = x"
    and "Eps1 (\<beta> x) = 1"
    and "Eps2 (\<beta> x) = 1"
    and "Eps12 (\<beta> x) = 0"
  by (simp_all add: hyperdualx_def)

lemma hypext_extract_eq:
  "(*h* f) (\<beta> x) = f x *\<^sub>H ba + deriv f x *\<^sub>H e1 + deriv f x *\<^sub>H e2 + deriv (deriv f) x *\<^sub>H e12"
  by (simp add: hypext_Hyperdual_eq_parts hyperdualx_def)

lemma Base_hypext:
  "Base ((*h* f) (\<beta> x)) = f x"
  by (simp add: hyperdualx_def)

lemma Eps1_hypext:
  "Eps1 ((*h* f) (\<beta> x)) = deriv f x"
  by (simp add: hyperdualx_def)

lemma Eps2_hypext:
  "Eps2 ((*h* f) (\<beta> x)) = deriv f x"
  by (simp add: hyperdualx_def)

lemma Eps12_hypext:
  "Eps12 ((*h* f) (\<beta> x)) = deriv (deriv f) x"
  by (simp add: hyperdualx_def)

subsubsection\<open>Convenience Interface\<close>

text\<open>Define a datatype to hold the function value, and the first and second derivative values.\<close>
datatype ('a :: real_normed_field) derivs = Derivs (Value: 'a) (First: 'a) (Second: 'a)

text\<open>
  Then we convert a hyperdual number to derivative values by extracting the base component, one of
  the first-order components, and the second-order component.
\<close>
fun hyperdual_to_derivs :: "('a :: real_normed_field) hyperdual \<Rightarrow> 'a derivs"
  where "hyperdual_to_derivs x = Derivs (Base x) (Eps1 x) (Eps12 x)"

text\<open>
  Finally we define way of converting any compatible function into one that yields the value and the
  derivatives.
\<close>
fun autodiff :: "('a :: real_normed_field \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a derivs"
  where "autodiff f = (\<lambda>x. hyperdual_to_derivs ((*h* f) (\<beta> x)))"

lemma autodiff_sel:
  "Value (autodiff f x) = Base ((*h* f) (\<beta> x))"
  "First (autodiff f x) = Eps1 ((*h* f) (\<beta> x))"
  "Second (autodiff f x) = Eps12 ((*h* f) (\<beta> x))"
  by simp_all

text\<open>The result contains the expected values.\<close>
lemma autodiff_extract_value:
  "Value (autodiff f x) = f x"
  by (simp del: hypext.simps add: Base_hypext)

lemma autodiff_extract_first:
  "First (autodiff f x) = deriv f x"
  by (simp del: hypext.simps add: Eps1_hypext)

lemma autodiff_extract_second:
  "Second (autodiff f x) = deriv (deriv f) x"
  by (simp del: hypext.simps add: Eps12_hypext)

text\<open>
  The derivative components of the result are actual derivatives if the function is sufficiently
  differentiable on that argument.
\<close>
lemma autodiff_first_derivative:
  assumes "f field_differentiable (at x)"
  shows "(f has_field_derivative First (autodiff f x)) (at x)"
  by (simp add: autodiff_extract_first DERIV_deriv_iff_field_differentiable assms)

lemma autodiff_second_derivative:
  assumes "f twice_field_differentiable_at x"
  shows "((deriv f) has_field_derivative Second (autodiff f x)) (at x)"
  by (simp add: autodiff_extract_second DERIV_deriv_iff_field_differentiable assms deriv_field_differentiable_at)

subsubsection\<open>Composition\<close>

text\<open>Composition of hyperdual extensions is the hyperdual extension of composition:\<close>
lemma hypext_compose:
  assumes "f twice_field_differentiable_at (Base x)"
      and "g twice_field_differentiable_at (f (Base x))"
    shows "(*h* (\<lambda>x. g (f x))) x = (*h* g) ((*h* f) x)"
proof (simp add: hyperdual_eq_iff, intro conjI disjI2)
  show goal1: "deriv (\<lambda>x. g (f x)) (Base x) = deriv f (Base x) * deriv g (f (Base x))"
  proof -
    have "deriv (\<lambda>x. g (f x)) (Base x) = deriv (g \<circ> f) (Base x)"
      by (simp add: comp_def)
    also have "... = deriv g (f (Base x)) * deriv f (Base x)"
      using assms by (simp add: deriv_chain once_field_differentiable_at)
    finally show ?thesis
      by (simp add: mult.commute deriv_chain)
  qed
  then show "deriv (\<lambda>x. g (f x)) (Base x) = deriv f (Base x) * deriv g (f (Base x))" .

  have first_diff: "(\<lambda>x. deriv g (f x)) field_differentiable at (Base x)"
    by (metis DERIV_chain2 assms deriv_field_differentiable_at field_differentiable_def once_field_differentiable_at)

  have "deriv (deriv g \<circ> f) (Base x) = deriv (deriv g) (f (Base x)) * deriv f (Base x)"
    using deriv_chain assms once_field_differentiable_at deriv_field_differentiable_at
    by blast
  then have deriv_deriv_comp: "deriv (\<lambda>x. deriv g (f x)) (Base x) = deriv (deriv g) (f (Base x)) * deriv f (Base x)"
    by (simp add: comp_def)

  have "deriv (deriv (\<lambda>x. g (f x))) (Base x) = deriv ((\<lambda>x. deriv f x * deriv g (f x))) (Base x)"
    using assms eventually_deriv_compose'[of f "Base x" g]
    by (simp add: mult.commute deriv_cong_ev)
  also have "... = deriv f (Base x) * deriv (\<lambda>x. deriv g (f x)) (Base x) + deriv (deriv f) (Base x) * deriv g (f (Base x))"
    using assms(1) first_diff by (simp add: deriv_field_differentiable_at)
  also have "... = deriv f (Base x) * deriv (deriv g) (f (Base x)) * deriv f (Base x) + deriv (deriv f) (Base x) * deriv g (f (Base x))"
    using deriv_deriv_comp by simp
  finally show "Eps12 x * deriv (\<lambda>x. g (f x)) (Base x) + Eps1 x * Eps2 x * deriv (deriv (\<lambda>x. g (f x))) (Base x) =
    (Eps12 x * deriv f (Base x) + Eps1 x * Eps2 x * deriv (deriv f) (Base x)) * deriv g (f (Base x)) +
    Eps1 x * deriv f (Base x) * (Eps2 x * deriv f (Base x)) * deriv (deriv g) (f (Base x))"
    by (simp add: goal1 field_simps)
qed

subsection\<open>Concrete Instances\<close>

subsubsection\<open>Constant\<close>

text\<open>Component embedding is an extension of the constant function.\<close>
lemma hypext_const [simp]:
  "(*h* (\<lambda>x. a)) x = of_comp a"
  by (simp add: of_comp_def hyperdual_eq_iff)

lemma "autodiff (\<lambda>x. a) = (\<lambda>x. Derivs a 0 0)"
  by simp

subsubsection\<open>Identity\<close>

text\<open>Identity is an extension of the component identity.\<close>
lemma hypext_ident:
  "(*h* (\<lambda>x. x)) x = x"
  by (simp add: hyperdual_eq_iff)

subsubsection\<open>Component Scalar Multiplication\<close>

text\<open>Component scaling is an extension of component constant multiplication:\<close>
lemma hypext_scaleH:
  "(*h* (\<lambda>x. k * x)) x = k *\<^sub>H x"
  by (simp add: hyperdual_eq_iff)

lemma hypext_fun_scaleH:
  assumes "f twice_field_differentiable_at (Base x)"
  shows "(*h* (\<lambda>x. k * f x)) x = k *\<^sub>H (*h* f) x"
  using assms by (simp add: hypext_compose hypext_scaleH)

text\<open>Unary minus is just an instance of constant multiplication:\<close>
lemma hypext_uminus:
  "(*h* uminus) x = - x"
  using hypext_scaleH[of "-1" x] by simp

subsubsection\<open>Real Scalar Multiplication\<close>

text\<open>Real scaling is an extension of component real scaling:\<close>
lemma hypext_scaleR:
  "(*h* (\<lambda>x. k *\<^sub>R x)) x = k *\<^sub>R x"
  by (auto simp add: hyperdual_eq_iff)

lemma hypext_fun_scaleR:
  assumes "f twice_field_differentiable_at (Base x)"
  shows "(*h* (\<lambda>x. k *\<^sub>R f x)) x = k *\<^sub>R (*h* f) x"
  using assms by (simp add: hypext_compose hypext_scaleR)

subsubsection\<open>Addition\<close>

text\<open>Addition of hyperdual extensions is a hyperdual extension of addition of functions.\<close>
lemma hypext_fun_add:
  assumes "f twice_field_differentiable_at (Base x)"
      and "g twice_field_differentiable_at (Base x)"
    shows "(*h* (\<lambda>x. f x + g x)) x = (*h* f) x + (*h* g) x"
proof (simp add: hyperdual_eq_iff distrib_left[symmetric], intro conjI disjI2)
  show goal1: "deriv (\<lambda>x. f x + g x) (Base x) = deriv f (Base x) + deriv g (Base x)"
    by (simp add: assms once_field_differentiable_at distrib_left)
  then show "deriv (\<lambda>x. f x + g x) (Base x) = deriv f (Base x) + deriv g (Base x)" .

  have "deriv (deriv (\<lambda>x. f x + g x)) (Base x) = deriv (\<lambda>w. deriv f w + deriv g w) (Base x)"
    by (simp add: assms deriv_cong_ev eventually_deriv_add)
  moreover have "Eps12 x * deriv f (Base x) + Eps12 x * deriv g (Base x) = Eps12 x * deriv (\<lambda>x. f x + g x) (Base x)"
    by (metis distrib_left goal1)
  ultimately show "Eps12 x * deriv (\<lambda>x. f x + g x) (Base x) +
    Eps1 x * Eps2 x * deriv (deriv (\<lambda>x. f x + g x)) (Base x) =
    Eps12 x * deriv f (Base x) + Eps1 x * Eps2 x * deriv (deriv f) (Base x) +
    (Eps12 x * deriv g (Base x) + Eps1 x * Eps2 x * deriv (deriv g) (Base x))"
    using deriv_add[OF deriv_field_differentiable_at deriv_field_differentiable_at, OF assms]
    by (simp add: distrib_left add.left_commute)
qed

lemma hypext_cadd [simp]:
  "(*h* (\<lambda>x. x + a)) x = x + of_comp a"
  by (auto simp add: hyperdual_eq_iff of_comp_def)

lemma hypext_fun_cadd:
  assumes "f twice_field_differentiable_at (Base x)"
  shows "(*h* (\<lambda>x. f x + a)) x = (*h* f) x + of_comp a"
  using assms hypext_compose[of f x "\<lambda>x. x + a"] by simp

subsubsection\<open>Component Linear Function\<close>

text\<open>Hyperdual linear function is an extension of the component linear function:\<close>
lemma hypext_linear:
  "(*h* (\<lambda>x. k * x + a)) x = k *\<^sub>H x + of_comp a"
  using hypext_fun_add[of "(*) k" x "\<lambda>x. a"]
  by (simp add: hypext_scaleH)

lemma hypext_fun_linear:
  assumes "f twice_field_differentiable_at (Base x)"
    shows "(*h* (\<lambda>x. k * f x + a)) x = k *\<^sub>H (*h* f) x + of_comp a"
  using assms hypext_compose[of f x "\<lambda>x. k * x + a"] by (simp add: hypext_linear)

subsubsection\<open>Real Linear Function\<close>

text\<open>We have the same for real scaling instead of component multiplication:\<close>
lemma hypext_linearR:
  "(*h* (\<lambda>x. k *\<^sub>R x + a)) x = k *\<^sub>R x + of_comp a"
  using hypext_fun_add[of "(*\<^sub>R) k" x "\<lambda>x. a"]
  by (simp add: hypext_scaleR)

lemma hypext_fun_linearR:
  assumes "f twice_field_differentiable_at (Base x)"
    shows "(*h* (\<lambda>x. k *\<^sub>R f x + a)) x = k *\<^sub>R (*h* f) x + of_comp a"
  using assms hypext_compose[of f x "\<lambda>x. k *\<^sub>R x + a"] by (simp add: hypext_linearR)

subsubsection\<open>Multiplication\<close>

text\<open>Extension of multiplication is multiplication of the functions' extensions.\<close>
lemma hypext_fun_mult:
  assumes "f twice_field_differentiable_at (Base x)"
      and "g twice_field_differentiable_at (Base x)"
    shows "(*h* (\<lambda>z. f z * g z)) x = (*h* f) x * (*h* g) x"
proof (simp add: hyperdual_eq_iff distrib_left[symmetric], intro conjI)
  show "Eps1 x * deriv (\<lambda>z. f z * g z) (Base x) =
        f (Base x) * (Eps1 x * deriv g (Base x)) + Eps1 x * deriv f (Base x) * g (Base x)"
   and "Eps2 x * deriv (\<lambda>z. f z * g z) (Base x) =
        f (Base x) * (Eps2 x * deriv g (Base x)) + Eps2 x * deriv f (Base x) * g (Base x)"
    using assms by (simp_all add: once_field_differentiable_at distrib_left)

  have
    "deriv (deriv (\<lambda>z. f z * g z)) (Base x) =
     f (Base x) * deriv (deriv g) (Base x) + 2 * deriv f (Base x) * deriv g (Base x) + deriv (deriv f) (Base x) * g (Base x)"
  proof -
    have "deriv (deriv (\<lambda>z. f z * g z)) (Base x) = deriv (\<lambda>z. f z * deriv g z + deriv f z * g z) (Base x)"
      using assms by (simp add: eventually_deriv_mult deriv_cong_ev)
    also have "... = (\<lambda>z. f z * deriv (deriv g) z + deriv f z * deriv g z + deriv f z * deriv g z + deriv (deriv f) z * g z) (Base x)"
      by (simp add: assms deriv_field_differentiable_at field_differentiable_mult once_field_differentiable_at)
    finally show ?thesis
      by simp
  qed
  then show
    "Eps12 x * deriv (\<lambda>z. f z * g z) (Base x) + Eps1 x * Eps2 x * deriv (deriv (\<lambda>z. f z * g z)) (Base x) =
     2 * (Eps1 x * (Eps2 x * (deriv f (Base x) * deriv g (Base x)))) +
     f (Base x) * (Eps12 x * deriv g (Base x) + Eps1 x * Eps2 x * deriv (deriv g) (Base x)) +
     (Eps12 x * deriv f (Base x) + Eps1 x * Eps2 x * deriv (deriv f) (Base x)) * g (Base x)"
     using assms by (simp add: once_field_differentiable_at field_simps)
qed

subsubsection\<open>Sine and Cosine\<close>

text\<open>The extended sin and cos at an arbitrary hyperdual.\<close>

lemma hypext_sin_Hyperdual:
  "(*h* sin) (Hyperdual a b c d) = sin a *\<^sub>H ba + (b *cos a) *\<^sub>H e1 + (c * cos a) *\<^sub>H e2 + (d * cos a - b * c * sin a) *\<^sub>H e12 "
  by (simp add: hypext_Hyperdual_eq_parts)

lemma hypext_cos_Hyperdual:
  "(*h* cos) (Hyperdual a b c d) = cos a *\<^sub>H ba - (b * sin a) *\<^sub>H e1 - (c * sin a) *\<^sub>H e2 - (d * sin a + b * c * cos a) *\<^sub>H e12 "
proof -
  have "of_comp (- (d * sin a) - b * c * cos a) * e12 = - (of_comp (d * sin a + b * c * cos a) * e12)"
    by (metis add_uminus_conv_diff minus_add_distrib mult_minus_left of_comp_minus)
  then show ?thesis
    by (simp add: hypext_Hyperdual_eq_parts of_comp_minus scaleH_times)
qed

lemma Eps1_hypext_sin [simp]:
  "Eps1 ((*h* sin) x) = Eps1 x * cos (Base x)"
  by simp

lemma Eps2_hypext_sin [simp]:
  "Eps2 ((*h* sin) x) = Eps2 x * cos (Base x)"
  by simp

lemma Eps12_hypext_sin [simp]:
  "Eps12 ((*h* sin) x) = Eps12 x * cos (Base x) - Eps1 x * Eps2 x * sin (Base x)"
  by simp

lemma hypext_sin_e1 [simp]:
  "(*h* sin) (x * e1) = e1 * x"
  by (simp add: e1_def hyperdual_eq_iff one_hyperdual_def)

lemma hypext_sin_e2 [simp]:
  "(*h* sin) (x * e2) = e2 * x"
  by (simp add: e2_def hyperdual_eq_iff one_hyperdual_def)

lemma hypext_sin_e12 [simp]:
  "(*h* sin) (x * e12) = e12 * x"
  by (simp add: e12_def hyperdual_eq_iff one_hyperdual_def)

lemma hypext_cos_e1 [simp]:
  "(*h* cos) (x * e1) = 1"
  by (simp add: e1_def hyperdual_eq_iff one_hyperdual_def)

lemma hypext_cos_e2 [simp]:
  "(*h* cos) (x * e2) = 1"
  by (simp add: e2_def hyperdual_eq_iff one_hyperdual_def)

lemma hypext_cos_e12 [simp]:
  "(*h* cos) (x * e12) = 1"
  by (simp add: e12_def hyperdual_eq_iff one_hyperdual_def)

text\<open>The extended sin and cos at @{term "\<beta> x"}.\<close>

lemma hypext_sin_extract:
  "(*h* sin) (\<beta> x) = sin x *\<^sub>H ba + cos x *\<^sub>H e1 + cos x *\<^sub>H e2 - sin x *\<^sub>H e12"
  by (simp add: hypext_sin_Hyperdual of_comp_minus scaleH_times hyperdualx_def)

lemma hypext_cos_extract:
  "(*h* cos) (\<beta> x) = cos x *\<^sub>H ba - sin x *\<^sub>H e1 - sin x *\<^sub>H e2 - cos x *\<^sub>H e12"
  by (simp add: hypext_cos_Hyperdual hyperdualx_def)

text\<open>Extracting the extended sin components at @{term "\<beta> x"}.\<close>

lemma Base_hypext_sin_extract [simp]:
  "Base ((*h* sin) (\<beta> x)) = sin x"
  by (rule Base_hypext)

lemma Eps2_hypext_sin_extract [simp]:
  "Eps2 ((*h* sin) (\<beta> x)) = cos x"
  using Eps2_hypext[of sin] by simp

lemma Eps12_hypext_sin_extract [simp]:
  "Eps12 ((*h* sin) (\<beta> x)) = - sin x"
  using Eps12_hypext[of sin] by simp

text\<open>Extracting the extended cos components at @{term "\<beta> x"}.\<close>

lemma Base_hypext_cos_extract [simp]:
  "Base ((*h* cos) (\<beta> x)) = cos x"
  by (rule Base_hypext)

lemma Eps2_hypext_cos_extract [simp]:
  "Eps2 ((*h* cos) (\<beta> x)) = - sin x"
  using Eps2_hypext[of cos] by simp

lemma Eps12_hypext_cos_extract [simp]:
  "Eps12 ((*h* cos) (\<beta> x)) = - cos x"
  using Eps12_hypext[of cos] by simp

text\<open>We get one of the key trigonometric properties for the extensions of sin and cos.\<close>

lemma "((*h* sin) x)\<^sup>2 + ((*h* cos) x)\<^sup>2 = 1"
  by (simp add: hyperdual_eq_iff one_hyperdual_def power2_eq_square field_simps)

(* example *)
lemma "(*h* sin) x + (*h* cos) x = (*h* (\<lambda>x. sin x + cos x)) x"
  by (simp add: hypext_fun_add)

subsubsection\<open>Exponential\<close>

text\<open>The exponential function extension behaves as expected.\<close>

lemma hypext_exp_Hyperdual:
  "(*h* exp) (Hyperdual a b c d) =
       exp a *\<^sub>H ba + (b * exp a) *\<^sub>H e1 + (c * exp a) *\<^sub>H e2 + (d * exp a + b * c * exp a) *\<^sub>H e12"
  by (simp add: hypext_Hyperdual_eq_parts)

lemma hypext_exp_extract:
  "(*h* exp) (\<beta> x) = exp x *\<^sub>H ba + exp x *\<^sub>H e1 + exp x *\<^sub>H e2 + exp x *\<^sub>H e12"
  by (simp add: hypext_extract_eq)

lemma hypext_exp_e1 [simp]:
  "(*h* exp) (x * e1) = 1 + e1 * x"
  by (simp add: e1_def hyperdual_eq_iff)

lemma hypext_exp_e2 [simp]:
  "(*h* exp) (x * e2) = 1 + e2 * x"
  by (simp add: e2_def hyperdual_eq_iff)

lemma hypext_exp_e12 [simp]:
  "(*h* exp) (x * e12) = 1 + e12 * x"
  by (simp add: e12_def hyperdual_eq_iff)

text\<open>Extracting the parts for the exponential function extension.\<close>

lemma Eps1_hypext_exp_extract [simp]:
  "Eps1 ((*h* exp) (\<beta> x)) = exp x"
  using Eps1_hypext[of exp] by simp

lemma Eps2_hypext_exp_extract [simp]:
  "Eps2 ((*h* exp) (\<beta> x)) = exp x"
  using Eps2_hypext[of exp] by simp

lemma Eps12_hypext_exp_extract [simp]:
  "Eps12 ((*h* exp) (\<beta> x)) = exp x"
  using Eps12_hypext[of exp] by simp

subsubsection\<open>Square Root\<close>
text\<open>Square root function extension.\<close>

lemma hypext_sqrt_Hyperdual_Hyperdual:
  assumes "a > 0"
  shows "(*h* sqrt) (Hyperdual a b c d) =
         Hyperdual (sqrt a) (b * inverse (sqrt a) / 2) (c * inverse (sqrt a) / 2)
           (d * inverse (sqrt a) / 2 - b * c * inverse (sqrt a ^ 3) / 4)"
  by (simp add: assms hypext_Hyperdual_eq)

lemma hypext_sqrt_Hyperdual:
      "a > 0 \<Longrightarrow> (*h* sqrt) (Hyperdual a b c d) =
       sqrt a *\<^sub>H ba + (b * inverse (sqrt a) / 2) *\<^sub>H e1 + (c * inverse (sqrt a) / 2) *\<^sub>H e2 +
       (d * inverse (sqrt a) / 2 - b * c * inverse (sqrt a ^ 3) / 4) *\<^sub>H e12"
  by (auto simp add: hypext_Hyperdual_eq_parts)

lemma hypext_sqrt_extract:
  "x > 0 \<Longrightarrow> (*h* sqrt) (\<beta> x) = sqrt x *\<^sub>H ba + (inverse (sqrt x) / 2) *\<^sub>H e1 +
        (inverse (sqrt x) / 2) *\<^sub>H e2 - (inverse (sqrt x ^ 3) / 4) *\<^sub>H e12"
  by (simp add: hypext_sqrt_Hyperdual hyperdualx_def of_comp_minus scaleH_times)

text\<open>Extracting the parts for the square root extension.\<close>

lemma Eps1_hypext_sqrt_extract [simp]:
  "x > 0 \<Longrightarrow> Eps1 ((*h* sqrt) (\<beta> x)) = inverse (sqrt x) / 2"
  using Eps1_hypext[of sqrt] by simp

lemma Eps2_hypext_sqrt_extract [simp]:
  "x > 0 \<Longrightarrow> Eps2 ((*h* sqrt) (\<beta> x)) = inverse (sqrt x) / 2"
  using Eps2_hypext[of sqrt] by simp

lemma Eps12_hypext_sqrt_extract [simp]:
  "x > 0 \<Longrightarrow> Eps12 ((*h* sqrt) (\<beta> x)) = - (inverse (sqrt x ^ 3) / 4)"
  using Eps12_hypext[of sqrt] by simp

(* example *)
lemma "Base x > 0 \<Longrightarrow> (*h* sin) x + (*h* sqrt) x = (*h* (\<lambda>x. sin x + sqrt x)) x"
  by (simp add: hypext_fun_add)

subsubsection\<open>Natural Power\<close>

lemma hypext_power:
  "(*h* (\<lambda>x. x ^ n)) x = x ^ n"
  by (simp add: hyperdual_eq_iff hyperdual_power)

lemma hypext_fun_power:
  assumes "f twice_field_differentiable_at (Base x)"
    shows "(*h* (\<lambda>x. (f x) ^ n)) x = ((*h* f) x) ^ n"
  using assms hypext_compose[of f x "\<lambda>x. x ^ n"] by (simp add: hypext_power)

lemma hypext_power_Hyperdual:
  "(*h* (\<lambda>x. x ^ n)) (Hyperdual a b c d) =
        a ^ n *\<^sub>H ba + (of_nat n * b * a ^ (n - 1)) *\<^sub>H e1 + (of_nat n * c * a ^ (n - 1)) *\<^sub>H e2 +
        (d * (of_nat n * a ^ (n - 1)) + b * c * (of_nat n * of_nat (n - 1) * a ^ (n - 2))) *\<^sub>H e12"
  by (simp add: hypext_Hyperdual_eq_parts algebra_simps)

lemma hypext_power_Hyperdual_parts:
  "(*h* (\<lambda>x. x ^ n)) (a *\<^sub>H ba + b *\<^sub>H e1 + c *\<^sub>H e2 + d *\<^sub>H e12) =
        a ^ n *\<^sub>H ba + (of_nat n * b * a ^ (n - 1)) *\<^sub>H e1 + (of_nat n * c * a ^ (n - 1)) *\<^sub>H e2 +
        (d * (of_nat n * a ^ (n - 1)) + b * c * (of_nat n * of_nat (n - 1) * a ^ (n - 2))) *\<^sub>H e12"
  by (simp add: Hyperdual_eq [symmetric] hypext_power_Hyperdual)

lemma hypext_power_extract:
  "(*h* (\<lambda>x. x ^ n)) (\<beta> x) =
      x ^ n *\<^sub>H ba + (of_nat n * x ^ (n - 1)) *\<^sub>H e1 + (of_nat n * x ^ (n - 1)) *\<^sub>H e2 +
      (of_nat n * of_nat (n - 1) * x ^ (n - 2)) *\<^sub>H e12"
  by (simp add: hypext_extract_eq)

lemma Eps1_hypext_power [simp]:
  "Eps1 ((*h* (\<lambda>x. x ^ n)) x) = of_nat n * Eps1 x * (Base x) ^ (n - 1)"
  by simp

lemma Eps2_hypext_power [simp]:
  "Eps2 ((*h* (\<lambda>x. x ^ n)) x) = of_nat n * Eps2 x * (Base x) ^ (n - 1)"
  by simp

lemma Eps12_hypext_power [simp]:
  "Eps12 ((*h* (\<lambda>x. x ^ n)) x) =
   Eps12 x * (of_nat n * Base x ^ (n - 1)) + Eps1 x * Eps2 x * (of_nat n * of_nat (n - 1) * Base x ^ (n - 2))"
  by simp

subsubsection\<open>Inverse\<close>

lemma hypext_inverse:
  assumes "Base x \<noteq> 0"
  shows "(*h* inverse) x = inverse x"
  using assms by (simp add: hyperdual_eq_iff inverse_eq_divide)

lemma hypext_fun_inverse:
  assumes "f twice_field_differentiable_at (Base x)"
      and "f (Base x) \<noteq> 0"
    shows "(*h* (\<lambda>x. inverse (f x))) x = inverse ((*h* f) x)"
  using assms hypext_compose[of f x inverse] by (simp add: hypext_inverse)

lemma hypext_inverse_Hyperdual:
  "a \<noteq> 0 \<Longrightarrow>
    (*h* inverse) (Hyperdual a b c d) =
    Hyperdual (inverse a) (- (b / a\<^sup>2)) (- (c / a\<^sup>2)) (2 * b * c / (a ^ 3) - d / a\<^sup>2)"
  by (simp add: hypext_Hyperdual_eq divide_inverse)

lemma hypext_inverse_Hyperdual_parts:
  "a \<noteq> 0 \<Longrightarrow>
    (*h* inverse) (a *\<^sub>H ba + b *\<^sub>H e1 + c *\<^sub>H e2 + d *\<^sub>H e12) =
    inverse a *\<^sub>H ba + - (b / a\<^sup>2) *\<^sub>H e1 + - (c / a\<^sup>2) *\<^sub>H e2 + (2 * b * c / a ^ 3 - d / a\<^sup>2) *\<^sub>H e12"
  by (metis Hyperdual_eq hypext_inverse_Hyperdual)

lemma inverse_Hyperdual_parts:
  "(a::'a::real_normed_field) \<noteq> 0 \<Longrightarrow>
    inverse (a *\<^sub>H ba + b *\<^sub>H e1 + c *\<^sub>H e2 + d *\<^sub>H e12) =
    inverse a *\<^sub>H ba + - (b / a\<^sup>2) *\<^sub>H e1 + - (c / a\<^sup>2) *\<^sub>H e2 + (2 * b * c / a ^ 3 - d / a\<^sup>2) *\<^sub>H e12"
  by (metis Hyperdual_eq hyperdual.sel(1) hypext_inverse hypext_inverse_Hyperdual_parts)

lemma hypext_inverse_extract:
  "x \<noteq> 0 \<Longrightarrow> (*h* inverse) (\<beta> x) = inverse x *\<^sub>H ba - (1 / x\<^sup>2) *\<^sub>H e1 - (1 / x\<^sup>2) *\<^sub>H e2 + (2 / x ^ 3) *\<^sub>H e12"
  by (simp add: hypext_extract_eq divide_inverse of_comp_minus scaleH_times)

lemma inverse_extract:
  "x \<noteq> 0 \<Longrightarrow> inverse (\<beta> x) = inverse x *\<^sub>H ba - (1 / x\<^sup>2) *\<^sub>H e1 - (1 / x\<^sup>2) *\<^sub>H e2 + (2 / x ^ 3) *\<^sub>H e12"
  by (metis hyperdual.sel(1) hyperdualx_def hypext_inverse hypext_inverse_extract)

lemma Eps1_hypext_inverse [simp]:
  "Base x \<noteq> 0 \<Longrightarrow> Eps1 ((*h* inverse) x) = - Eps1 x * (1 / (Base x)\<^sup>2)"
  by simp
lemma Eps1_inverse [simp]:
  "Base (x::'a::real_normed_field hyperdual) \<noteq> 0 \<Longrightarrow> Eps1 (inverse x) = - Eps1 x * (1 / (Base x)\<^sup>2)"
  by simp

lemma Eps2_hypext_inverse [simp]:
  "Base (x::'a::real_normed_field hyperdual) \<noteq> 0 \<Longrightarrow> Eps2 (inverse x) = - Eps2 x * (1 / (Base x)\<^sup>2)"
  by simp

lemma Eps12_hypext_inverse [simp]:
  "Base  (x::'a::real_normed_field hyperdual) \<noteq> 0
   \<Longrightarrow> Eps12 (inverse x) = Eps1 x * Eps2 x * (2/ (Base x ^ 3)) - Eps12 x / (Base x)\<^sup>2"
  by simp

subsubsection\<open>Division\<close>

lemma hypext_fun_divide:
  assumes "f twice_field_differentiable_at (Base x)"
      and "g twice_field_differentiable_at (Base x)"
      and "g (Base x) \<noteq> 0"
    shows "(*h* (\<lambda>x. f x / g x)) x = (*h* f) x / (*h* g) x"
proof -
  have "(\<lambda>x. inverse (g x)) twice_field_differentiable_at Base x"
    by (simp add: assms(2) assms(3) twice_field_differentiable_at_compose)
  moreover have "(*h* f) x * (*h* (\<lambda>x. inverse (g x))) x = (*h* f) x * inverse ((*h* g) x)"
    by (simp add: assms(2) assms(3) hypext_fun_inverse)
  ultimately have "(*h* (\<lambda>x. f x * inverse (g x))) x = (*h* f) x * inverse ((*h* g) x)"
    by (simp add: assms(1) hypext_fun_mult)
  then show ?thesis
    by (simp add: divide_inverse hyp_divide_inverse)
qed

subsubsection\<open>Polynomial\<close>

lemma hypext_polyn:
  fixes coef :: "nat \<Rightarrow> 'a :: {real_normed_field}"
    and n :: nat
  shows "(*h* (\<lambda>x. \<Sum>i<n. coef i * x^i)) x = (\<Sum>i<n. (coef i) *\<^sub>H (x^i))"
proof (induction n)
  case 0
  then show ?case
    by (simp add: zero_hyperdual_def)
next
  case hyp: (Suc n)

  have "(\<lambda>x. \<Sum>i<Suc n. coef i * x ^ i) = (\<lambda>x. (\<Sum>i<n. coef i * x ^ i) + coef n * x ^ n)"
   and "(\<lambda>x. \<Sum>i<Suc n. coef i *\<^sub>H x ^ i) = (\<lambda>x. (\<Sum>i<n. coef i *\<^sub>H x ^ i) + coef n *\<^sub>H x ^ n)"
    by (simp_all add: field_simps)

  then show ?case
  proof (simp)
    have "(\<lambda>x. coef n * x ^ n) twice_field_differentiable_at Base x"
      using twice_field_differentiable_at_compose[of "\<lambda>x. x ^ n" "Base x" "(*) (coef n)"]
      by simp
    then have "(*h* (\<lambda>x. (\<Sum>i<n. coef i * x ^ i) + coef n * x ^ n)) x =
          (*h* (\<lambda>x. (\<Sum>i<n. coef i * x ^ i))) x + (*h* (\<lambda>x. coef n * x ^ n)) x"
      by (simp add: hypext_fun_add)
    moreover have "(*h* (\<lambda>x. coef n * x ^ n)) x = coef n *\<^sub>H x ^ n"
      by (simp add: hypext_fun_scaleH hypext_power)
    ultimately have "(*h* (\<lambda>x. (\<Sum>i<n. coef i * x ^ i) + coef n * x ^ n)) x = (\<Sum>i<n. coef i *\<^sub>H x ^ i) + coef n *\<^sub>H x ^ n"
      using hyp by simp
    then show "(*h* (\<lambda>x. (\<Sum>i<n. coef i * x ^ i) + coef n * x ^ n)) x = (\<Sum>i<n. coef i *\<^sub>H x ^ i) + coef n *\<^sub>H x ^ n"
      by simp
  qed
qed

lemma hypext_fun_polyn:
    fixes coef :: "nat \<Rightarrow> 'a :: {real_normed_field}"
      and n :: nat
  assumes "f twice_field_differentiable_at (Base x)"
    shows "(*h* (\<lambda>x. \<Sum>i<n. coef i * (f x)^i)) x = (\<Sum>i<n. (coef i) *\<^sub>H (((*h* f) x)^i))"
  using assms hypext_compose[of f x "\<lambda>x. (\<Sum>i<n. coef i * x^i)"] by (simp add: hypext_polyn)

end


theory VDMTypes
imports VDMToolkit
begin

(*********************************************************************************)
section \<open>Constants\<close>

text \<open>MAX is a reserved word in Isabelle,
values
	MAX: nat1 = 10;
\<close>
abbreviation
  LMAX :: "VDMNat1"
where
  "LMAX \<equiv> 10"

definition
  inv_LMAX :: "\<bool>"
  where
  "inv_LMAX \<equiv> inv_VDMNat1 LMAX"

(*********************************************************************************)
section \<open>Numeric types\<close>

text \<open>MyType = nat1 inv n == n <= LMAX"\<close>

type_synonym MyType = VDMNat1

definition
  inv_MyType :: "VDMNat1 \<Rightarrow> \<bool>"
  where
  "inv_MyType n \<equiv>
    inv_VDMNat1 n
  \<and> n \<le> LMAX"

text \<open>VDM ranges {1,...,10} can be represented as below. Isabelle also has open/closed ranges\<close>
value "{1..(10::nat)}"
value "{1..<(10::nat)}"
value "{1<..<(10::nat)}"

value "inv_MyType(0)"
value "inv_MyType(5)"
value "inv_MyType(10)"

(*********************************************************************************)
section \<open>Set types\<close>

text \<open>MySet = set of MyType inv s == s <> {};\<close>

type_synonym MySet0 = "VDMNat1 VDMSet"

definition
  inv_MySet0 :: "VDMNat1 VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MySet0 s \<equiv>
      inv_VDMSet s \<and>
      (\<forall> e . e \<in> s \<longrightarrow> e \<ge> 0 \<and> e \<le> LMAX) \<and>
      s \<noteq> {}"

type_synonym MySet = "MyType VDMSet"

definition
  inv_MySet :: "MyType VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MySet s \<equiv> inv_VDMSet s \<and>
                 inv_SetElems inv_MyType s \<and>
                 s \<noteq> {}"

value "inv_SetElems inv_MyType {1,2,3}"

value "inv_MySet {1,2,(3::MyType)}"

lemma "inv_MySet {1,2,3}"
  unfolding inv_MySet_def
  unfolding          inv_SetElems_def
          unfolding  inv_MyType_def
           unfolding inv_VDMNat1_def
           unfolding inv_VDMSet_def
  by simp

lemma "\<not> inv_MySet {1,2,20}"
  unfolding inv_MySet_def
            inv_SetElems_def
            inv_MyType_def
            inv_VDMNat1_def
            inv_VDMSet_def
  by simp

lemma "inv_MySet s"
  unfolding inv_MySet_def
            inv_SetElems_def
            inv_MyType_def
            inv_VDMNat1_def
            inv_VDMSet_def
  oops

definition
  inv_MySetExplicit :: "MyType VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MySetExplicit s \<equiv>
                 finite s \<and>
                 (\<forall> e \<in> s . e > 0 \<and> e \<le> LMAX) \<and>
                 s \<noteq> {}"

lemma "inv_MySetExplicit s = inv_MySet s"
  unfolding  inv_MySetExplicit_def inv_MySet_def
inv_SetElems_def
            inv_MyType_def
            inv_VDMNat1_def
            inv_VDMSet_def
  apply auto
  done (* found typo "e \<ge> 0", fixed e > 0! Better not be explicit *)

text \<open>MySet1 = set1 of MyType\<close>

type_synonym MySet1 = "VDMNat1 VDMSet1"

definition
  inv_MySet1 :: "MyType VDMSet1 \<Rightarrow> \<bool>"
  where
  "inv_MySet1 s \<equiv> inv_VDMSet1 s \<and>
                  inv_SetElems inv_MyType s"

lemma "inv_MySet1 s = inv_MySet s"
  unfolding  inv_MySet1_def inv_MySet_def
inv_SetElems_def
            inv_MyType_def
            inv_VDMNat1_def
            inv_VDMSet_def
            inv_VDMSet1_def
  by auto

(*********************************************************************************)
section \<open>Seq types\<close>

type_synonym MySeq0 = "VDMNat1 VDMSeq"

definition
  inv_MySeq0 :: "VDMNat1 VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeq0 s \<equiv> (\<forall> i \<in> inds s . s $ i \<le> LMAX) \<and>
                  (\<forall> e \<in> elems s . e \<le> LMAX) \<and>
                  vdm_card (elems s) = len s"

text\<open>MySeq = seq of MyType inv s == card elems s = len s;\<close>
type_synonym MySeq = "MyType VDMSeq"

definition
  inv_MySeq :: "MyType VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeq s \<equiv> inv_SeqElems inv_MyType s \<and>
                  vdm_card (elems s) = len s"

value "inv_MySeq [1, 2, 3]"

lemma "inv_MySeq [1,2,3]"
  unfolding inv_MySeq_def
  inv_SeqElems_def inv_MyType_def inv_VDMNat1_def elems_def len_def vdm_card_def inv_VDMSet_def
  by simp

lemma "\<not> inv_MySeq [1,1,3]"
  unfolding inv_MySeq_def
  inv_SeqElems_def inv_MyType_def inv_VDMNat1_def elems_def len_def vdm_card_def inv_VDMSet_def
  by simp

type_synonym MySeqSeq0 = "MyType VDMSeq VDMSeq"

definition
  inv_MySeqSeq0 :: "MyType VDMSeq VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeqSeq0 ss \<equiv>
    inv_SeqElems (inv_SeqElems inv_MyType) ss"

type_synonym MySeqX = "MyType VDMSeq"

definition
  inv_MySeqX :: "MyType  VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeqX s \<equiv>
    inv_SeqElems inv_MyType s"

type_synonym MySeqSeq = "MyType VDMSeq VDMSeq"

definition
  inv_MySeqSeq :: "MyType VDMSeq VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeqSeq ss \<equiv>
    inv_SeqElems inv_MySeqX ss"

(*********************************************************************************)
section \<open>Enum types\<close>

text\<open>Enum = <E1> | <E2>; \<close>

datatype Enum = E1 | E2

find_theorems name:"VDMTypes.Enum"

text \<open>Even when no invariant exists, it's good idea to define it in case one arises later\<close>
definition
  inv_Enum :: "Enum \<Rightarrow> \<bool>"
  where
  "inv_Enum e \<equiv> True"

(*********************************************************************************)
section \<open>Map types\<close>

text\<open>MyMap = map MyType to (nat1 * Enum) inv m == dom m subset {LMAX div 2,...,LMAX}<E1> | <E2>; \<close>

(* TODO: add differences between each type in English! *)

type_synonym MyMap = "MyType \<rightharpoonup> (VDMNat \<times> Enum) VDMSet"
typ MyMap

value "[ 5 \<mapsto> {(0, E1)} ]::MyMap"

text
\<open>Be very careful with div and mod. Their meaning is different in VDM and Isabelle when
 dealing with negative numbers. Have a look inside VDMToolkit for details/examples. If both
 left and right sides of div/mod are >= 0, then you are fine. Otherwise, you will have harder
 proofs to do. That means, make sure your invariants contain this if div/mod is used. In the case
 below, this is implicitly obvious given LMAX is 10 and both 10 and 2 are bigger than 0.\<close>

definition
  inv_MyMapRanElem :: "(MyType \<times> Enum) \<Rightarrow> \<bool>"
  where
  "inv_MyMapRanElem v \<equiv>
    let (n, e) = v in
      inv_MyType n \<and> inv_Enum e"

definition
  inv_MyMapRan :: "(MyType \<times> Enum) VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MyMapRan s \<equiv>  inv_SetElems inv_MyMapRanElem s"

definition
  inv_MyMap :: "MyMap \<Rightarrow> \<bool>"
where
  "inv_MyMap m \<equiv>
      inv_Map inv_MyType inv_MyMapRan m \<and>
      dom m \<subseteq> {LMAX vdmdiv 2 .. LMAX}"

lemma "inv_MyMap m"
  unfolding inv_MyMap_def
 unfolding     inv_Map_def
  unfolding inv_MyMapRan_def inv_MyMapRanElem_def
 unfolding     inv_MyType_def
  unfolding    inv_VDMNat1_def
 unfolding     inv_Enum_def
 unfolding     inv_SetElems_def
 unfolding     inv_VDMSet_def
  apply simp
  apply safe
  oops

type_synonym MyMapOld = "MyType \<rightharpoonup> Enum"

definition
  inv_MyMapOld :: "MyMapOld \<Rightarrow> \<bool>"
where
  "inv_MyMapOld m \<equiv>
      inv_Map inv_MyType inv_Enum m \<and>
      dom m \<subseteq> {LMAX vdmdiv 2 .. LMAX}"

text\<open>Map enumeration { 3 |-> <E1>, 2 |-> <E1>, 1 |-> <E2>, 4 |-> <E2> }\<close>

value
 "[ (3::MyType) |-> E1,
              2 \<mapsto> E1,
              1 \<mapsto> E2,
              4 \<mapsto> E2]
 "

value
 "dom
  [ (3::MyType) \<mapsto> E1,
              2 \<mapsto> E1,
              1 \<mapsto> E2,
              4 \<mapsto> E2]
 "

lemma
 "dom
  [ (3::MyType) \<mapsto> E1,
              2 \<mapsto> E1,
              1 \<mapsto> E2,
              4 \<mapsto> E2]
  = {1..4}
 "
  apply simp
  by auto

abbreviation
  mymap_test :: "MyType \<rightharpoonup> Enum"
  where
  "mymap_test \<equiv>
  [ (3::MyType) \<mapsto> E1,
              2 \<mapsto> E1,
              1 \<mapsto> E2,
              4 \<mapsto> E2]"
lemma
 "ran mymap_test = {E1, E2}"
  apply simp
  by auto

text\<open>Map applicaiton (the operator) + values outside domain\<close>

value "mymap_test 1"
value "mymap_test 2"
value "mymap_test 3"
value "mymap_test 4"
value "mymap_test 5"
value "mymap_test 565454235"
value "mymap_test 10"

value "mymap_test 1 = E2"
value "mymap_test 1 = Some E2"
value "the (mymap_test 1) = E2"
value "the (mymap_test 3) = E1"
value "the (mymap_test 5)"
value "mymap_test 5 = None"
value "5 \<notin> dom mymap_test"

text \<open>Map update\<close>

value "mymap_test(3 \<mapsto> E2) 3"
value "(mymap_test(3 \<mapsto> E2)) 3 = Some E2"
value "the((mymap_test(3 \<mapsto> E2)) 3) = E2"

lemma "dom Map.empty = {}" by simp

(*********************************************************************************)
section \<open>Record types\<close>

text\<open>
  MyRec ::
		x: MyType
		s: MySet
		l: MySeq
		m: MyMap
	inv mk_MyRec(x,s,l,m) ==
		x in set dom m inter elems l inter s
		and
		x in set dom m and x in set elems l and x in set s;
\<close>

text \<open>Record fields declare projection functions from record to field type\<close>
record MyRec =
  xfield :: MyType
  sfield :: MySet
  lfield :: MySeq
  mfield :: MyMap
print_theorems

term xfield
term sfield
term lfield

value "(|xfield = 5, sfield = {5}, lfield = [5], mfield = [ 5 |-> {(0,E1)} ]|)"
value "\<lparr>xfield = 5, sfield = {5}, lfield = [5], mfield = [ 5 \<mapsto> {(0,E1)} ]\<rparr>"
value "xfield \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = Map.empty\<rparr> = 3"
value "lfield \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = Map.empty\<rparr> = [3]"

text\<open>Have to check the type invariants of each field explicitly\<close>
definition
  inv_MyRec0 :: "MyRec \<Rightarrow> \<bool>"
  where
  "inv_MyRec0 r \<equiv> inv_MyType (xfield r) \<and>
                 inv_MySet (sfield r) \<and>
                 inv_MySeq (lfield r) \<and>
                 inv_MyMap (mfield r) \<and> True"

value "inv_MyRec0 \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = Map.empty\<rparr>"

lemma "inv_MyRec0 \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = Map.empty\<rparr>"
  unfolding inv_MyRec0_def
        inv_MyMap_def
        inv_MySeq_def
        inv_MySet_def
        inv_SeqElems_def
        inv_SetElems_def
        inv_Map_def
        inv_MyType_def
        inv_VDMSet_def
        inv_VDMNat1_def
  by simp

definition
  inv_MyRec :: "MyRec \<Rightarrow> \<bool>"
  where
  "inv_MyRec r \<equiv> (let x=(xfield r); s=(sfield r); l=(lfield r); m=(mfield r) in
                      inv_MyType x \<and>
                     inv_MySet s \<and>
                     inv_MySeq l \<and>
                     inv_MyMap m \<and>
                     x \<in> (dom m) \<inter> (elems l) \<inter> s
                     \<and>
                     x \<in> (dom m) \<and> x \<in> (elems l) \<and> x \<in> s)"

lemma "(let r=\<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = [3 \<mapsto> {(0,E1)}]\<rparr>;
            x=(xfield r); s=(sfield r); l=(lfield r); m=(mfield r) in x \<in> (dom m) \<inter> (elems l) \<inter> s)"
  by simp

lemma "inv_MyRec \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = [3 \<mapsto> {(1,E1)}]\<rparr>"
  unfolding inv_MyRec_def Let_def
  apply (simp,safe)
  unfolding inv_MyType_def inv_VDMNat1_def
     apply simp
  unfolding inv_MySet_def inv_VDMSet_def
    apply (simp add: inv_MyType_def inv_VDMNat1_def)
  unfolding inv_MySeq_def vdm_card_def elems_def inv_VDMSet_def
   apply simp
  apply (simp add: inv_MyType_def inv_VDMNat1_def l_inv_SeqElems_Cons)
  unfolding        inv_MyMap_def
  unfolding inv_MyMapRan_def inv_MyMapRanElem_def
  apply safe
   apply (simp add: inv_Enum_def inv_Map_def inv_MyType_def inv_VDMNat1_def)
  apply simp
  oops

lemma "inv_MyRec \<lparr>xfield = 5, sfield = {5}, lfield = [5], mfield = [5 \<mapsto> {(1,E1)}]\<rparr>"
  unfolding inv_MyRec_def
        inv_MyMap_def
        inv_MySeq_def
        inv_MySet_def
        inv_SeqElems_def
        inv_SetElems_def
        inv_MyType_def
        inv_VDMSet_def
        inv_VDMNat1_def
        inv_Enum_def
        inv_Map_def
        Let_def
        inv_MyMapRan_def
        inv_MyMapRanElem_def
  by simp_all

lemma "inv_MyRec r"
  unfolding inv_MyRec_def Let_def
 unfolding       inv_MyMap_def
        inv_MyMapRan_def
        inv_MyMapRanElem_def
        inv_Map_def
 unfolding       inv_MySeq_def
  unfolding       inv_MySet_def
 unfolding       inv_SeqElems_def
 unfolding       inv_SetElems_def
 unfolding      inv_MyType_def
 unfolding       inv_VDMSet_def
  unfolding      inv_VDMNat1_def
  unfolding inv_Enum_def
  apply simp
  oops

(*********************************************************************************)
section \<open>Union types\<close>

text\<open>MyUnion = MyRec | MyMap; \<close>

datatype MyUnion = R MyRec | M MyMap

definition
  inv_MyUnion :: "MyUnion \<Rightarrow> \<bool>"
  where
  "inv_MyUnion u \<equiv>
    case u of
      R r \<Rightarrow> inv_MyRec r
    | M m \<Rightarrow> inv_MyMap m"

(*****************************************************************)
section \<open> Some useful examples of various expressions \<close>

subsection \<open> Set translations: enumeration, comprehension, ranges \<close>

text \<open>Set comprehension\<close>

(* { expr | var . filter }, { var \<in> type . filter }, { var . filter } *)

value "{ x+x | x . x \<in> {(1::nat),2,3,4,5,6} }"
value "{ x+x | x . x \<in> {(1::nat),2,3} }"
value "{ x+x | x . x \<in> {(1::nat)..3} }" (* "not always work"*)
value "{ x*x | x . x \<in> {(1::int),2,3,5} }"

value "{0..(2::int)}"
value "{0..<(3::int)}"
value "{0<..<(3::int)}"

subsection \<open> Seq translations: enumeration, comprehension, ranges \<close>

(* List application (i.e. s(x)) is available in Isabelle, but is zero based *)
value "[A, B, C] ! 0"
value "[A, B, C] ! 1"
value "[A, B, C] ! 2"
value "[A, B, C] ! 3"
value "nth [A, B, C] 0"

value "applyVDMSeq [A, B] 0" \<comment> \<open>out of range\<close>
value "applyVDMSeq [A, B] 1"
value "applyVDMSeq [A, B] 2"
value "applyVDMSeq [A, B] 3" \<comment> \<open>out of range\<close>

value "[A,B,C,D] $ 0"
value "[A,B,C,D] $ 1"
value "[A,B,C,D] $ 2"
value "[A,B,C,D] $ 3"
value "[A,B,C,D] $ 4"
value "[A,B,C,D] $ 5"

text \<open>Seq comprehension\<close>

value "{ [A,B,C] ! i | i . i \<in> {0,1,2} }"
value "{ [A,B,C,D,E,F] ! i | i . i \<in> {0,2,4} }"
(* { s(i) | i in set inds s & i mod 2 = 0 } *)

value "{ [A,B,C] ! i | i . i \<in> {0,1,2} }"
value "[ x . x \<leftarrow> [0,1,(2::int)]]" (*avoid if possible... *)
value "[ x . x \<leftarrow> [0 .. 3] ]"

value "len [A, B, C]"
value "elems [A, B, C, A, B]"
value "elems [(0::nat), 1, 2]"
value "inds [A,B,C]"
value "inds_as_nat [A,B,C]"
value "card (elems [10, 20, 30, 1, 2, 3, 4, (5::nat), 10])"
value "len [10, 20, 30, 1, 2, 3, 4, (5::nat), 10]"

text \<open>Map comprehension (almost)\<close>

text \<open> Enumeration through sequences (or sequence comprehension) \<close>
value "[ [(3::nat),4,5] [\<mapsto>] [(4::nat),5,6,7] ] = [3 \<mapsto> 4, 4 \<mapsto> 5, 5 \<mapsto> 6]"

lemma "[ [(3::nat),4,5] [\<mapsto>] [(4::nat),5,6,7] ] = [3 \<mapsto> 4, 4 \<mapsto> 5, 5 \<mapsto> 6]"
  by simp

lemma "[ [(3::nat),4,5] [\<mapsto>] [(4::nat)] ] = [3 \<mapsto> 4]"
  by simp

lemma "[ [(3::nat),3,5] [\<mapsto>] [(4::nat),5,6,7] ] = [3 \<mapsto> 5, 5 \<mapsto> 6]"
  by simp

lemma "[[ x . x \<leftarrow> [0,1,(2::nat)] ] [\<mapsto>] [y . y \<leftarrow> [3,4,(5::nat)]] ] = [0 \<mapsto> 3, 1 \<mapsto> 4, 2 \<mapsto> 5]"
  by simp

end


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

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

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

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

lemma app_nil: "x y nil2 = y"
  by (induct y, auto)

lemma app_assoc: "x (x w y) z = x w (x y z)"
  by(induction w, auto)

lemma rev_app: "rev (x y z) = x (rev z) (rev y)"
  apply(induction y, simp add: app_nil)
  apply(simp add: app_assoc)
  done

lemma revrev: "rev (rev y) = y"
  apply(induct y rule: rev.induct, auto)
   apply(simp add: rev_app)
  done

theorem property0 :
  "((rev (x (rev y) (rev z))) = (x z y))"
  apply(induct y, auto)
   apply(simp add: app_nil revrev)
  apply(simp add: revrev rev_app)
  done

end


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

section \<open>Radius of Convergence and Summation Tests\<close>

theory Summation_Tests
imports
  Complex_Main
  "~~/src/HOL/Library/Extended_Real"
  "~~/src/HOL/Library/Liminf_Limsup"
begin

text \<open>
  The definition of the radius of convergence of a power series,
  various summability tests, lemmas to compute the radius of convergence etc.
\<close>

subsection \<open>Rounded dual logarithm\<close>

(* This is required for the Cauchy condensation criterion *)

definition "natlog2 n = (if n = 0 then 0 else nat \<lfloor>log 2 (real_of_nat n)\<rfloor>)"

lemma natlog2_0 [simp]: "natlog2 0 = 0" by (simp add: natlog2_def)
lemma natlog2_1 [simp]: "natlog2 1 = 0" by (simp add: natlog2_def)
lemma natlog2_eq_0_iff: "natlog2 n = 0 \<longleftrightarrow> n < 2" by (simp add: natlog2_def)

lemma natlog2_power_of_two [simp]: "natlog2 (2 ^ n) = n"
  by (simp add: natlog2_def log_nat_power)

lemma natlog2_mono: "m \<le> n \<Longrightarrow> natlog2 m \<le> natlog2 n"
  unfolding natlog2_def by (simp_all add: nat_mono floor_mono)

lemma pow_natlog2_le: "n > 0 \<Longrightarrow> 2 ^ natlog2 n \<le> n"
proof -
  assume n: "n > 0"
  from n have "of_nat (2 ^ natlog2 n) = 2 powr real_of_nat (nat \<lfloor>log 2 (real_of_nat n)\<rfloor>)"
    by (subst powr_realpow) (simp_all add: natlog2_def)
  also have "\<dots> = 2 powr of_int \<lfloor>log 2 (real_of_nat n)\<rfloor>" using n by simp
  also have "\<dots> \<le> 2 powr log 2 (real_of_nat n)" by (intro powr_mono) (linarith, simp_all)
  also have "\<dots> = of_nat n" using n by simp
  finally show ?thesis by simp
qed

lemma pow_natlog2_gt: "n > 0 \<Longrightarrow> 2 * 2 ^ natlog2 n > n"
  and pow_natlog2_ge: "n > 0 \<Longrightarrow> 2 * 2 ^ natlog2 n \<ge> n"
proof -
  assume n: "n > 0"
  from n have "of_nat n = 2 powr log 2 (real_of_nat n)" by simp
  also have "\<dots> < 2 powr (1 + of_int \<lfloor>log 2 (real_of_nat n)\<rfloor>)"
    by (intro powr_less_mono) (linarith, simp_all)
  also from n have "\<dots> = 2 powr (1 + real_of_nat (nat \<lfloor>log 2 (real_of_nat n)\<rfloor>))" by simp
  also from n have "\<dots> = of_nat (2 * 2 ^ natlog2 n)"
    by (simp_all add: natlog2_def powr_real_of_int powr_add)
  finally show "2 * 2 ^ natlog2 n > n" by (rule of_nat_less_imp_less)
  thus "2 * 2 ^ natlog2 n \<ge> n" by simp
qed

lemma natlog2_eqI:
  assumes "n > 0" "2^k \<le> n" "n < 2 * 2^k"
  shows   "natlog2 n = k"
proof -
  from assms have "of_nat (2 ^ k) \<le> real_of_nat n"  by (subst of_nat_le_iff) simp_all
  hence "real_of_int (int k) \<le> log (of_nat 2) (real_of_nat n)"
    by (subst le_log_iff) (simp_all add: powr_realpow assms del: of_nat_le_iff)
  moreover from assms have "real_of_nat n < of_nat (2 ^ Suc k)" by (subst of_nat_less_iff) simp_all
  hence "log 2 (real_of_nat n) < of_nat k + 1"
    by (subst log_less_iff) (simp_all add: assms powr_realpow powr_add)
  ultimately have "\<lfloor>log 2 (real_of_nat n)\<rfloor> = of_nat k" by (intro floor_unique) simp_all
  with assms show ?thesis by (simp add: natlog2_def)
qed

lemma natlog2_rec:
  assumes "n \<ge> 2"
  shows   "natlog2 n = 1 + natlog2 (n div 2)"
proof (rule natlog2_eqI)
  from assms have "2 ^ (1 + natlog2 (n div 2)) \<le> 2 * (n div 2)"
    by (simp add: pow_natlog2_le)
  also have "\<dots> \<le> n" by simp
  finally show "2 ^ (1 + natlog2 (n div 2)) \<le> n" .
next
  from assms have "n < 2 * (n div 2 + 1)" by simp
  also from assms have "(n div 2) < 2 ^ (1 + natlog2 (n div 2))"
    by (simp add: pow_natlog2_gt)
  hence "2 * (n div 2 + 1) \<le> 2 * (2 ^ (1 + natlog2 (n div 2)))"
    by (intro mult_left_mono) simp_all
  finally show "n < 2 * 2 ^ (1 + natlog2 (n div 2))" .
qed (insert assms, simp_all)

fun natlog2_aux where
  "natlog2_aux n acc = (if (n::nat) < 2 then acc else natlog2_aux (n div 2) (acc + 1))"

lemma natlog2_aux_correct:
  "natlog2_aux n acc = acc + natlog2 n"
  by (induction n acc rule: natlog2_aux.induct) (auto simp: natlog2_rec natlog2_eq_0_iff)

lemma natlog2_code [code]: "natlog2 n = natlog2_aux n 0"
  by (subst natlog2_aux_correct) simp

subsection \<open>Convergence tests for infinite sums\<close>

subsubsection \<open>Root test\<close>

lemma limsup_root_powser:
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  shows "limsup (\<lambda>n. ereal (root n (norm (f n * z ^ n)))) =
             limsup (\<lambda>n. ereal (root n (norm (f n)))) * ereal (norm z)"
proof -
  have A: "(\<lambda>n. ereal (root n (norm (f n * z ^ n)))) =
              (\<lambda>n. ereal (root n (norm (f n))) * ereal (norm z))" (is "?g = ?h")
  proof
    fix n show "?g n = ?h n"
    by (cases "n = 0") (simp_all add: norm_mult real_root_mult real_root_pos2 norm_power)
  qed
  show ?thesis by (subst A, subst limsup_ereal_mult_right) simp_all
qed

lemma limsup_root_limit:
  assumes "(\<lambda>n. ereal (root n (norm (f n)))) \<longlonglongrightarrow> l" (is "?g \<longlonglongrightarrow> _")
  shows   "limsup (\<lambda>n. ereal (root n (norm (f n)))) = l"
proof -
  from assms have "convergent ?g" "lim ?g = l"
    unfolding convergent_def by (blast intro: limI)+
  with convergent_limsup_cl show ?thesis by force
qed

lemma limsup_root_limit':
  assumes "(\<lambda>n. root n (norm (f n))) \<longlonglongrightarrow> l"
  shows   "limsup (\<lambda>n. ereal (root n (norm (f n)))) = ereal l"
  by (intro limsup_root_limit tendsto_ereal assms)

lemma root_test_convergence':
  fixes f :: "nat \<Rightarrow> 'a :: banach"
  defines "l \<equiv> limsup (\<lambda>n. ereal (root n (norm (f n))))"
  assumes l: "l < 1"
  shows   "summable f"
proof -
  have "0 = limsup (\<lambda>n. 0)" by (simp add: Limsup_const)
  also have "... \<le> l" unfolding l_def by (intro Limsup_mono) (simp_all add: real_root_ge_zero)
  finally have "l \<ge> 0" by simp
  with l obtain l' where l': "l = ereal l'" by (cases l) simp_all

  define c where "c = (1 - l') / 2"
  from l and \<open>l \<ge> 0\<close> have c: "l + c > l" "l' + c \<ge> 0" "l' + c < 1" unfolding c_def
    by (simp_all add: field_simps l')
  have "\<forall>C>l. eventually (\<lambda>n. ereal (root n (norm (f n))) < C) sequentially"
    by (subst Limsup_le_iff[symmetric]) (simp add: l_def)
  with c have "eventually (\<lambda>n. ereal (root n (norm (f n))) < l + ereal c) sequentially" by simp
  with eventually_gt_at_top[of "0::nat"]
    have "eventually (\<lambda>n. norm (f n) \<le> (l' + c) ^ n) sequentially"
  proof eventually_elim
    fix n :: nat assume n: "n > 0"
    assume "ereal (root n (norm (f n))) < l + ereal c"
    hence "root n (norm (f n)) \<le> l' + c" by (simp add: l')
    with c n have "root n (norm (f n)) ^ n \<le> (l' + c) ^ n"
      by (intro power_mono) (simp_all add: real_root_ge_zero)
    also from n have "root n (norm (f n)) ^ n = norm (f n)" by simp
    finally show "norm (f n) \<le> (l' + c) ^ n" by simp
  qed
  thus ?thesis
    by (rule summable_comparison_test_ev[OF _ summable_geometric]) (simp add: c)
qed

lemma root_test_divergence:
  fixes f :: "nat \<Rightarrow> 'a :: banach"
  defines "l \<equiv> limsup (\<lambda>n. ereal (root n (norm (f n))))"
  assumes l: "l > 1"
  shows   "\<not>summable f"
proof
  assume "summable f"
  hence bounded: "Bseq f" by (simp add: summable_imp_Bseq)

  have "0 = limsup (\<lambda>n. 0)" by (simp add: Limsup_const)
  also have "... \<le> l" unfolding l_def by (intro Limsup_mono) (simp_all add: real_root_ge_zero)
  finally have l_nonneg: "l \<ge> 0" by simp

  define c where "c = (if l = \<infinity> then 2 else 1 + (real_of_ereal l - 1) / 2)"
  from l l_nonneg consider "l = \<infinity>" | "\<exists>l'. l = ereal l'" by (cases l) simp_all
  hence c: "c > 1 \<and> ereal c < l" by cases (insert l, auto simp: c_def field_simps)

  have unbounded: "\<not>bdd_above {n. root n (norm (f n)) > c}"
  proof
    assume "bdd_above {n. root n (norm (f n)) > c}"
    then obtain N where "\<forall>n. root n (norm (f n)) > c \<longrightarrow> n \<le> N" unfolding bdd_above_def by blast
    hence "\<exists>N. \<forall>n\<ge>N. root n (norm (f n)) \<le> c"
      by (intro exI[of _ "N + 1"]) (force simp: not_less_eq_eq[symmetric])
    hence "eventually (\<lambda>n. root n (norm (f n)) \<le> c) sequentially"
      by (auto simp: eventually_at_top_linorder)
    hence "l \<le> c" unfolding l_def by (intro Limsup_bounded) simp_all
    with c show False by auto
  qed

  from bounded obtain K where K: "K > 0" "\<And>n. norm (f n) \<le> K" using BseqE by blast
  define n where "n = nat \<lceil>log c K\<rceil>"
  from unbounded have "\<exists>m>n. c < root m (norm (f m))" unfolding bdd_above_def
    by (auto simp: not_le)
  then guess m by (elim exE conjE) note m = this
  from c K have "K = c powr log c K" by (simp add: powr_def log_def)
  also from c have "c powr log c K \<le> c powr real n" unfolding n_def
    by (intro powr_mono, linarith, simp)
  finally have "K \<le> c ^ n" using c by (simp add: powr_realpow)
  also from c m have "c ^ n < c ^ m" by simp
  also from c m have "c ^ m < root m (norm (f m)) ^ m" by (intro power_strict_mono) simp_all
  also from m have "... = norm (f m)" by simp
  finally show False using K(2)[of m]  by simp
qed

subsubsection \<open>Cauchy's condensation test\<close>

context
fixes f :: "nat \<Rightarrow> real"
begin

private lemma condensation_inequality:
  assumes mono: "\<And>m n. 0 < m \<Longrightarrow> m \<le> n \<Longrightarrow> f n \<le> f m"
  shows   "(\<Sum>k=1..<n. f k) \<ge> (\<Sum>k=1..<n. f (2 * 2 ^ natlog2 k))" (is "?thesis1")
          "(\<Sum>k=1..<n. f k) \<le> (\<Sum>k=1..<n. f (2 ^ natlog2 k))" (is "?thesis2")
  by (intro sum_mono mono pow_natlog2_ge pow_natlog2_le, simp, simp)+

private lemma condensation_condense1: "(\<Sum>k=1..<2^n. f (2 ^ natlog2 k)) = (\<Sum>k<n. 2^k * f (2 ^ k))"
proof (induction n)
  case (Suc n)
  have "{1..<2^Suc n} = {1..<2^n} \<union> {2^n..<(2^Suc n :: nat)}" by auto
  also have "(\<Sum>k\<in>\<dots>. f (2 ^ natlog2 k)) =
                 (\<Sum>k<n. 2^k * f (2^k)) + (\<Sum>k = 2^n..<2^Suc n. f (2^natlog2 k))"
    by (subst sum.union_disjoint) (insert Suc, auto)
  also have "natlog2 k = n" if "k \<in> {2^n..<2^Suc n}" for k using that by (intro natlog2_eqI) simp_all
  hence "(\<Sum>k = 2^n..<2^Suc n. f (2^natlog2 k)) = (\<Sum>(_::nat) = 2^n..<2^Suc n. f (2^n))"
    by (intro sum.cong) simp_all
  also have "\<dots> = 2^n * f (2^n)" by (simp add: of_nat_power)
  finally show ?case by simp
qed simp

private lemma condensation_condense2: "(\<Sum>k=1..<2^n. f (2 * 2 ^ natlog2 k)) = (\<Sum>k<n. 2^k * f (2 ^ Suc k))"
proof (induction n)
  case (Suc n)
  have "{1..<2^Suc n} = {1..<2^n} \<union> {2^n..<(2^Suc n :: nat)}" by auto
  also have "(\<Sum>k\<in>\<dots>. f (2 * 2 ^ natlog2 k)) =
                 (\<Sum>k<n. 2^k * f (2^Suc k)) + (\<Sum>k = 2^n..<2^Suc n. f (2 * 2^natlog2 k))"
    by (subst sum.union_disjoint) (insert Suc, auto)
  also have "natlog2 k = n" if "k \<in> {2^n..<2^Suc n}" for k using that by (intro natlog2_eqI) simp_all
  hence "(\<Sum>k = 2^n..<2^Suc n. f (2*2^natlog2 k)) = (\<Sum>(_::nat) = 2^n..<2^Suc n. f (2^Suc n))"
    by (intro sum.cong) simp_all
  also have "\<dots> = 2^n * f (2^Suc n)" by (simp add: of_nat_power)
  finally show ?case by simp
qed simp

lemma condensation_test:
  assumes mono: "\<And>m. 0 < m \<Longrightarrow> f (Suc m) \<le> f m"
  assumes nonneg: "\<And>n. f n \<ge> 0"
  shows "summable f \<longleftrightarrow> summable (\<lambda>n. 2^n * f (2^n))"
proof -
  define f' where "f' n = (if n = 0 then 0 else f n)" for n
  from mono have mono': "decseq (\<lambda>n. f (Suc n))" by (intro decseq_SucI) simp
  hence mono': "f n \<le> f m" if "m \<le> n" "m > 0" for m n
    using that decseqD[OF mono', of "m - 1" "n - 1"] by simp

  have "(\<lambda>n. f (Suc n)) = (\<lambda>n. f' (Suc n))" by (intro ext) (simp add: f'_def)
  hence "summable f \<longleftrightarrow> summable f'"
    by (subst (1 2) summable_Suc_iff [symmetric]) (simp only:)
  also have "\<dots> \<longleftrightarrow> convergent (\<lambda>n. \<Sum>k<n. f' k)" unfolding summable_iff_convergent ..
  also have "monoseq (\<lambda>n. \<Sum>k<n. f' k)" unfolding f'_def
    by (intro mono_SucI1) (auto intro!: mult_nonneg_nonneg nonneg)
  hence "convergent (\<lambda>n. \<Sum>k<n. f' k) \<longleftrightarrow> Bseq (\<lambda>n. \<Sum>k<n. f' k)"
    by (rule monoseq_imp_convergent_iff_Bseq)
  also have "\<dots> \<longleftrightarrow> Bseq (\<lambda>n. \<Sum>k=1..<n. f' k)" unfolding One_nat_def
    by (subst sum_shift_lb_Suc0_0_upt) (simp_all add: f'_def atLeast0LessThan)
  also have "\<dots> \<longleftrightarrow> Bseq (\<lambda>n. \<Sum>k=1..<n. f k)" unfolding f'_def by simp
  also have "\<dots> \<longleftrightarrow> Bseq (\<lambda>n. \<Sum>k=1..<2^n. f k)"
    by (rule nonneg_incseq_Bseq_subseq_iff[symmetric])
       (auto intro!: sum_nonneg incseq_SucI nonneg simp: subseq_def)
  also have "\<dots> \<longleftrightarrow> Bseq (\<lambda>n. \<Sum>k<n. 2^k * f (2^k))"
  proof (intro iffI)
    assume A: "Bseq (\<lambda>n. \<Sum>k=1..<2^n. f k)"
    have "eventually (\<lambda>n. norm (\<Sum>k<n. 2^k * f (2^Suc k)) \<le> norm (\<Sum>k=1..<2^n. f k)) sequentially"
    proof (intro always_eventually allI)
      fix n :: nat
      have "norm (\<Sum>k<n. 2^k * f (2^Suc k)) = (\<Sum>k<n. 2^k * f (2^Suc k))" unfolding real_norm_def
        by (intro abs_of_nonneg sum_nonneg ballI mult_nonneg_nonneg nonneg) simp_all
      also have "\<dots> \<le> (\<Sum>k=1..<2^n. f k)"
        by (subst condensation_condense2 [symmetric]) (intro condensation_inequality mono')
      also have "\<dots> = norm \<dots>" unfolding real_norm_def
        by (intro abs_of_nonneg[symmetric] sum_nonneg ballI mult_nonneg_nonneg nonneg)
      finally show "norm (\<Sum>k<n. 2 ^ k * f (2 ^ Suc k)) \<le> norm (\<Sum>k=1..<2^n. f k)" .
    qed
    from this and A have "Bseq (\<lambda>n. \<Sum>k<n. 2^k * f (2^Suc k))" by (rule Bseq_eventually_mono)
    from Bseq_mult[OF Bfun_const[of 2] this] have "Bseq (\<lambda>n. \<Sum>k<n. 2^Suc k * f (2^Suc k))"
      by (simp add: sum_distrib_left sum_distrib_right mult_ac)
    hence "Bseq (\<lambda>n. (\<Sum>k=Suc 0..<Suc n. 2^k * f (2^k)) + f 1)"
      by (intro Bseq_add, subst sum_shift_bounds_Suc_ivl) (simp add: atLeast0LessThan)
    hence "Bseq (\<lambda>n. (\<Sum>k=0..<Suc n. 2^k * f (2^k)))"
      by (subst sum_head_upt_Suc) (simp_all add: add_ac)
    thus "Bseq (\<lambda>n. (\<Sum>k<n. 2^k * f (2^k)))"
      by (subst (asm) Bseq_Suc_iff) (simp add: atLeast0LessThan)
  next
    assume A: "Bseq (\<lambda>n. (\<Sum>k<n. 2^k * f (2^k)))"
    have "eventually (\<lambda>n. norm (\<Sum>k=1..<2^n. f k) \<le> norm (\<Sum>k<n. 2^k * f (2^k))) sequentially"
    proof (intro always_eventually allI)
      fix n :: nat
      have "norm (\<Sum>k=1..<2^n. f k) = (\<Sum>k=1..<2^n. f k)" unfolding real_norm_def
        by (intro abs_of_nonneg sum_nonneg ballI mult_nonneg_nonneg nonneg)
      also have "\<dots> \<le> (\<Sum>k<n. 2^k * f (2^k))"
        by (subst condensation_condense1 [symmetric]) (intro condensation_inequality mono')
      also have "\<dots> = norm \<dots>" unfolding real_norm_def
        by (intro abs_of_nonneg [symmetric] sum_nonneg ballI mult_nonneg_nonneg nonneg) simp_all
      finally show "norm (\<Sum>k=1..<2^n. f k) \<le> norm (\<Sum>k<n. 2^k * f (2^k))" .
    qed
    from this and A show "Bseq (\<lambda>n. \<Sum>k=1..<2^n. f k)" by (rule Bseq_eventually_mono)
  qed
  also have "monoseq (\<lambda>n. (\<Sum>k<n. 2^k * f (2^k)))"
    by (intro mono_SucI1) (auto intro!: mult_nonneg_nonneg nonneg)
  hence "Bseq (\<lambda>n. (\<Sum>k<n. 2^k * f (2^k))) \<longleftrightarrow> convergent (\<lambda>n. (\<Sum>k<n. 2^k * f (2^k)))"
    by (rule monoseq_imp_convergent_iff_Bseq [symmetric])
  also have "\<dots> \<longleftrightarrow> summable (\<lambda>k. 2^k * f (2^k))" by (simp only: summable_iff_convergent)
  finally show ?thesis .
qed

end

subsubsection \<open>Summability of powers\<close>

lemma abs_summable_complex_powr_iff:
    "summable (\<lambda>n. norm (exp (of_real (ln (of_nat n)) * s))) \<longleftrightarrow> Re s < -1"
proof (cases "Re s \<le> 0")
  let ?l = "\<lambda>n. complex_of_real (ln (of_nat n))"
  case False
  with eventually_gt_at_top[of "0::nat"]
    have "eventually (\<lambda>n. norm (1 :: real) \<le> norm (exp (?l n * s))) sequentially"
    by (auto intro!: ge_one_powr_ge_zero elim!: eventually_mono)
  from summable_comparison_test_ev[OF this] False show ?thesis by (auto simp: summable_const_iff)
next
  let ?l = "\<lambda>n. complex_of_real (ln (of_nat n))"
  case True
  hence "summable (\<lambda>n. norm (exp (?l n * s))) \<longleftrightarrow> summable (\<lambda>n. 2^n * norm (exp (?l (2^n) * s)))"
    by (intro condensation_test) (auto intro!: mult_right_mono_neg)
  also have "(\<lambda>n. 2^n * norm (exp (?l (2^n) * s))) = (\<lambda>n. (2 powr (Re s + 1)) ^ n)"
  proof
    fix n :: nat
    have "2^n * norm (exp (?l (2^n) * s)) = exp (real n * ln 2) * exp (real n * ln 2 * Re s)"
      using True by (subst exp_of_nat_mult) (simp add: ln_realpow algebra_simps)
    also have "\<dots> = exp (real n * (ln 2 * (Re s + 1)))"
      by (simp add: algebra_simps exp_add)
    also have "\<dots> = exp (ln 2 * (Re s + 1)) ^ n" by (subst exp_of_nat_mult) simp
    also have "exp (ln 2 * (Re s + 1)) = 2 powr (Re s + 1)" by (simp add: powr_def)
    finally show "2^n * norm (exp (?l (2^n) * s)) = (2 powr (Re s + 1)) ^ n" .
  qed
  also have "summable \<dots> \<longleftrightarrow> 2 powr (Re s + 1) < 2 powr 0"
    by (subst summable_geometric_iff) simp
  also have "\<dots> \<longleftrightarrow> Re s < -1" by (subst powr_less_cancel_iff) (simp, linarith)
  finally show ?thesis .
qed

lemma summable_complex_powr_iff:
  assumes "Re s < -1"
  shows   "summable (\<lambda>n. exp (of_real (ln (of_nat n)) * s))"
  by (rule summable_norm_cancel, subst abs_summable_complex_powr_iff) fact

lemma summable_real_powr_iff: "summable (\<lambda>n. of_nat n powr s :: real) \<longleftrightarrow> s < -1"
proof -
  from eventually_gt_at_top[of "0::nat"]
    have "summable (\<lambda>n. of_nat n powr s) \<longleftrightarrow> summable (\<lambda>n. exp (ln (of_nat n) * s))"
    by (intro summable_cong) (auto elim!: eventually_mono simp: powr_def)
  also have "\<dots> \<longleftrightarrow> s < -1" using abs_summable_complex_powr_iff[of "of_real s"] by simp
  finally show ?thesis .
qed

lemma inverse_power_summable:
  assumes s: "s \<ge> 2"
  shows "summable (\<lambda>n. inverse (of_nat n ^ s :: 'a :: {real_normed_div_algebra,banach}))"
proof (rule summable_norm_cancel, subst summable_cong)
  from eventually_gt_at_top[of "0::nat"]
    show "eventually (\<lambda>n. norm (inverse (of_nat n ^ s:: 'a)) = real_of_nat n powr (-real s)) at_top"
    by eventually_elim (simp add: norm_inverse norm_power powr_minus powr_realpow)
qed (insert s summable_real_powr_iff[of "-s"], simp_all)

lemma not_summable_harmonic: "\<not>summable (\<lambda>n. inverse (of_nat n) :: 'a :: real_normed_field)"
proof
  assume "summable (\<lambda>n. inverse (of_nat n) :: 'a)"
  hence "convergent (\<lambda>n. norm (of_real (\<Sum>k<n. inverse (of_nat k)) :: 'a))"
    by (simp add: summable_iff_convergent convergent_norm)
  hence "convergent (\<lambda>n. abs (\<Sum>k<n. inverse (of_nat k)) :: real)" by (simp only: norm_of_real)
  also have "(\<lambda>n. abs (\<Sum>k<n. inverse (of_nat k)) :: real) = (\<lambda>n. \<Sum>k<n. inverse (of_nat k))"
    by (intro ext abs_of_nonneg sum_nonneg) auto
  also have "convergent \<dots> \<longleftrightarrow> summable (\<lambda>k. inverse (of_nat k) :: real)"
    by (simp add: summable_iff_convergent)
  finally show False using summable_real_powr_iff[of "-1"] by (simp add: powr_minus)
qed

subsubsection \<open>Kummer's test\<close>

lemma kummers_test_convergence:
  fixes f p :: "nat \<Rightarrow> real"
  assumes pos_f: "eventually (\<lambda>n. f n > 0) sequentially"
  assumes nonneg_p: "eventually (\<lambda>n. p n \<ge> 0) sequentially"
  defines "l \<equiv> liminf (\<lambda>n. ereal (p n * f n / f (Suc n) - p (Suc n)))"
  assumes l: "l > 0"
  shows   "summable f"
  unfolding summable_iff_convergent'
proof -
  define r where "r = (if l = \<infinity> then 1 else real_of_ereal l / 2)"
  from l have "r > 0 \<and> of_real r < l" by (cases l) (simp_all add: r_def)
  hence r: "r > 0" "of_real r < l" by simp_all
  hence "eventually (\<lambda>n. p n * f n / f (Suc n) - p (Suc n) > r) sequentially"
    unfolding l_def by (force dest: less_LiminfD)
  moreover from pos_f have "eventually (\<lambda>n. f (Suc n) > 0) sequentially"
    by (subst eventually_sequentially_Suc)
  ultimately have "eventually (\<lambda>n. p n * f n - p (Suc n) * f (Suc n) > r * f (Suc n)) sequentially"
    by eventually_elim (simp add: field_simps)
  from eventually_conj[OF pos_f eventually_conj[OF nonneg_p this]]
    obtain m where m: "\<And>n. n \<ge> m \<Longrightarrow> f n > 0" "\<And>n. n \<ge> m \<Longrightarrow> p n \<ge> 0"
        "\<And>n. n \<ge> m \<Longrightarrow> p n * f n - p (Suc n) * f (Suc n) > r * f (Suc n)"
    unfolding eventually_at_top_linorder by blast

  let ?c = "(norm (\<Sum>k\<le>m. r * f k) + p m * f m) / r"
  have "Bseq (\<lambda>n. (\<Sum>k\<le>n + Suc m. f k))"
  proof (rule BseqI')
    fix k :: nat
    define n where "n = k + Suc m"
    have n: "n > m" by (simp add: n_def)

    from r have "r * norm (\<Sum>k\<le>n. f k) = norm (\<Sum>k\<le>n. r * f k)"
      by (simp add: sum_distrib_left[symmetric] abs_mult)
    also from n have "{..n} = {..m} \<union> {Suc m..n}" by auto
    hence "(\<Sum>k\<le>n. r * f k) = (\<Sum>k\<in>{..m} \<union> {Suc m..n}. r * f k)" by (simp only:)
    also have "\<dots> = (\<Sum>k\<le>m. r * f k) + (\<Sum>k=Suc m..n. r * f k)"
      by (subst sum.union_disjoint) auto
    also have "norm \<dots> \<le> norm (\<Sum>k\<le>m. r * f k) + norm (\<Sum>k=Suc m..n. r * f k)"
      by (rule norm_triangle_ineq)
    also from r less_imp_le[OF m(1)] have "(\<Sum>k=Suc m..n. r * f k) \<ge> 0"
      by (intro sum_nonneg) auto
    hence "norm (\<Sum>k=Suc m..n. r * f k) = (\<Sum>k=Suc m..n. r * f k)" by simp
    also have "(\<Sum>k=Suc m..n. r * f k) = (\<Sum>k=m..<n. r * f (Suc k))"
     by (subst sum_shift_bounds_Suc_ivl [symmetric])
          (simp only: atLeastLessThanSuc_atLeastAtMost)
    also from m have "\<dots> \<le> (\<Sum>k=m..<n. p k * f k - p (Suc k) * f (Suc k))"
      by (intro sum_mono[OF less_imp_le]) simp_all
    also have "\<dots> = -(\<Sum>k=m..<n. p (Suc k) * f (Suc k) - p k * f k)"
      by (simp add: sum_negf [symmetric] algebra_simps)
    also from n have "\<dots> = p m * f m - p n * f n"
      by (cases n, simp, simp only: atLeastLessThanSuc_atLeastAtMost, subst sum_Suc_diff) simp_all
    also from less_imp_le[OF m(1)] m(2) n have "\<dots> \<le> p m * f m" by simp
    finally show "norm (\<Sum>k\<le>n. f k) \<le> (norm (\<Sum>k\<le>m. r * f k) + p m * f m) / r" using r
      by (subst pos_le_divide_eq[OF r(1)]) (simp only: mult_ac)
  qed
  moreover have "(\<Sum>k\<le>n. f k) \<le> (\<Sum>k\<le>n'. f k)" if "Suc m \<le> n" "n \<le> n'" for n n'
    using less_imp_le[OF m(1)] that by (intro sum_mono2) auto
  ultimately show "convergent (\<lambda>n. \<Sum>k\<le>n. f k)" by (rule Bseq_monoseq_convergent'_inc)
qed

lemma kummers_test_divergence:
  fixes f p :: "nat \<Rightarrow> real"
  assumes pos_f: "eventually (\<lambda>n. f n > 0) sequentially"
  assumes pos_p: "eventually (\<lambda>n. p n > 0) sequentially"
  assumes divergent_p: "\<not>summable (\<lambda>n. inverse (p n))"
  defines "l \<equiv> limsup (\<lambda>n. ereal (p n * f n / f (Suc n) - p (Suc n)))"
  assumes l: "l < 0"
  shows   "\<not>summable f"
proof
  assume "summable f"
  from eventually_conj[OF pos_f eventually_conj[OF pos_p Limsup_lessD[OF l[unfolded l_def]]]]
    obtain N where N: "\<And>n. n \<ge> N \<Longrightarrow> p n > 0" "\<And>n. n \<ge> N \<Longrightarrow> f n > 0"
                      "\<And>n. n \<ge> N \<Longrightarrow> p n * f n / f (Suc n) - p (Suc n) < 0"
    by (auto simp: eventually_at_top_linorder)
  hence A: "p n * f n < p (Suc n) * f (Suc n)" if "n \<ge> N" for n using that N[of n] N[of "Suc n"]
    by (simp add: field_simps)
  have "p n * f n \<ge> p N * f N" if "n \<ge> N" for n using that and A
      by (induction n rule: dec_induct) (auto intro!: less_imp_le elim!: order.trans)
  from eventually_ge_at_top[of N] N this
    have "eventually (\<lambda>n. norm (p N * f N * inverse (p n)) \<le> f n) sequentially"
    by (auto elim!: eventually_mono simp: field_simps abs_of_pos)
  from this and \<open>summable f\<close> have "summable (\<lambda>n. p N * f N * inverse (p n))"
    by (rule summable_comparison_test_ev)
  from summable_mult[OF this, of "inverse (p N * f N)"] N[OF le_refl]
    have "summable (\<lambda>n. inverse (p n))" by (simp add: divide_simps)
  with divergent_p show False by contradiction
qed

subsubsection \<open>Ratio test\<close>

lemma ratio_test_convergence:
  fixes f :: "nat \<Rightarrow> real"
  assumes pos_f: "eventually (\<lambda>n. f n > 0) sequentially"
  defines "l \<equiv> liminf (\<lambda>n. ereal (f n / f (Suc n)))"
  assumes l: "l > 1"
  shows   "summable f"
proof (rule kummers_test_convergence[OF pos_f])
  note l
  also have "l = liminf (\<lambda>n. ereal (f n / f (Suc n) - 1)) + 1"
    by (subst Liminf_add_ereal_right[symmetric]) (simp_all add: minus_ereal_def l_def one_ereal_def)
  finally show "liminf (\<lambda>n. ereal (1 * f n / f (Suc n) - 1)) > 0"
    by (cases "liminf (\<lambda>n. ereal (1 * f n / f (Suc n) - 1))") simp_all
qed simp

lemma ratio_test_divergence:
  fixes f :: "nat \<Rightarrow> real"
  assumes pos_f: "eventually (\<lambda>n. f n > 0) sequentially"
  defines "l \<equiv> limsup (\<lambda>n. ereal (f n / f (Suc n)))"
  assumes l: "l < 1"
  shows   "\<not>summable f"
proof (rule kummers_test_divergence[OF pos_f])
  have "limsup (\<lambda>n. ereal (f n / f (Suc n) - 1)) + 1 = l"
    by (subst Limsup_add_ereal_right[symmetric]) (simp_all add: minus_ereal_def l_def one_ereal_def)
  also note l
  finally show "limsup (\<lambda>n. ereal (1 * f n / f (Suc n) - 1)) < 0"
    by (cases "limsup (\<lambda>n. ereal (1 * f n / f (Suc n) - 1))") simp_all
qed (simp_all add: summable_const_iff)

subsubsection \<open>Raabe's test\<close>

lemma raabes_test_convergence:
fixes f :: "nat \<Rightarrow> real"
  assumes pos: "eventually (\<lambda>n. f n > 0) sequentially"
  defines "l \<equiv> liminf (\<lambda>n. ereal (of_nat n * (f n / f (Suc n) - 1)))"
  assumes l: "l > 1"
  shows   "summable f"
proof (rule kummers_test_convergence)
  let ?l' = "liminf (\<lambda>n. ereal (of_nat n * f n / f (Suc n) - of_nat (Suc n)))"
  have "1 < l" by fact
  also have "l = liminf (\<lambda>n. ereal (of_nat n * f n / f (Suc n) - of_nat (Suc n)) + 1)"
    by (simp add: l_def algebra_simps)
  also have "\<dots> = ?l' + 1" by (subst Liminf_add_ereal_right) simp_all
  finally show "?l' > 0" by (cases ?l') (simp_all add: algebra_simps)
qed (simp_all add: pos)

lemma raabes_test_divergence:
fixes f :: "nat \<Rightarrow> real"
  assumes pos: "eventually (\<lambda>n. f n > 0) sequentially"
  defines "l \<equiv> limsup (\<lambda>n. ereal (of_nat n * (f n / f (Suc n) - 1)))"
  assumes l: "l < 1"
  shows   "\<not>summable f"
proof (rule kummers_test_divergence)
  let ?l' = "limsup (\<lambda>n. ereal (of_nat n * f n / f (Suc n) - of_nat (Suc n)))"
  note l
  also have "l = limsup (\<lambda>n. ereal (of_nat n * f n / f (Suc n) - of_nat (Suc n)) + 1)"
    by (simp add: l_def algebra_simps)
  also have "\<dots> = ?l' + 1" by (subst Limsup_add_ereal_right) simp_all
  finally show "?l' < 0" by (cases ?l') (simp_all add: algebra_simps)
qed (insert pos eventually_gt_at_top[of "0::nat"] not_summable_harmonic, simp_all)

subsection \<open>Radius of convergence\<close>

text \<open>
  The radius of convergence of a power series. This value always exists, ranges from
  @{term "0::ereal"} to @{term "\<infinity>::ereal"}, and the power series is guaranteed to converge for
  all inputs with a norm that is smaller than that radius and to diverge for all inputs with a
  norm that is greater.
\<close>
definition conv_radius :: "(nat \<Rightarrow> 'a :: banach) \<Rightarrow> ereal" where
  "conv_radius f = inverse (limsup (\<lambda>n. ereal (root n (norm (f n)))))"

lemma conv_radius_nonneg: "conv_radius f \<ge> 0"
proof -
  have "0 = limsup (\<lambda>n. 0)" by (subst Limsup_const) simp_all
  also have "\<dots> \<le> limsup (\<lambda>n. ereal (root n (norm (f n))))"
    by (intro Limsup_mono) (simp_all add: real_root_ge_zero)
  finally show ?thesis
    unfolding conv_radius_def by (auto simp: ereal_inverse_nonneg_iff)
qed

lemma conv_radius_zero [simp]: "conv_radius (\<lambda>_. 0) = \<infinity>"
  by (auto simp: conv_radius_def zero_ereal_def [symmetric] Limsup_const)

lemma conv_radius_cong:
  assumes "eventually (\<lambda>x. f x = g x) sequentially"
  shows   "conv_radius f = conv_radius g"
proof -
  have "eventually (\<lambda>n. ereal (root n (norm (f n))) = ereal (root n (norm (g n)))) sequentially"
    using assms by eventually_elim simp
  from Limsup_eq[OF this] show ?thesis unfolding conv_radius_def by simp
qed

lemma conv_radius_altdef:
  "conv_radius f = liminf (\<lambda>n. inverse (ereal (root n (norm (f n)))))"
  by (subst Liminf_inverse_ereal) (simp_all add: real_root_ge_zero conv_radius_def)

lemma abs_summable_in_conv_radius:
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  assumes "ereal (norm z) < conv_radius f"
  shows   "summable (\<lambda>n. norm (f n * z ^ n))"
proof (rule root_test_convergence')
  define l where "l = limsup (\<lambda>n. ereal (root n (norm (f n))))"
  have "0 = limsup (\<lambda>n. 0)" by (simp add: Limsup_const)
  also have "... \<le> l" unfolding l_def by (intro Limsup_mono) (simp_all add: real_root_ge_zero)
  finally have l_nonneg: "l \<ge> 0" .

  have "limsup (\<lambda>n. root n (norm (f n * z^n))) = l * ereal (norm z)" unfolding l_def
    by (rule limsup_root_powser)
  also from l_nonneg consider "l = 0" | "l = \<infinity>" | "\<exists>l'. l = ereal l' \<and> l' > 0"
    by (cases "l") (auto simp: less_le)
  hence "l * ereal (norm z) < 1"
  proof cases
    assume "l = \<infinity>"
    hence "conv_radius f = 0" unfolding conv_radius_def l_def by simp
    with assms show ?thesis by simp
  next
    assume "\<exists>l'. l = ereal l' \<and> l' > 0"
    then guess l' by (elim exE conjE) note l' = this
    hence "l \<noteq> \<infinity>" by auto
    have "l * ereal (norm z) < l * conv_radius f"
      by (intro ereal_mult_strict_left_mono) (simp_all add: l' assms)
    also have "conv_radius f = inverse l" by (simp add: conv_radius_def l_def)
    also from l' have "l * inverse l = 1" by simp
    finally show ?thesis .
  qed simp_all
  finally show "limsup (\<lambda>n. ereal (root n (norm (norm (f n * z ^ n))))) < 1" by simp
qed

lemma summable_in_conv_radius:
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  assumes "ereal (norm z) < conv_radius f"
  shows   "summable (\<lambda>n. f n * z ^ n)"
  by (rule summable_norm_cancel, rule abs_summable_in_conv_radius) fact+

lemma not_summable_outside_conv_radius:
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  assumes "ereal (norm z) > conv_radius f"
  shows   "\<not>summable (\<lambda>n. f n * z ^ n)"
proof (rule root_test_divergence)
  define l where "l = limsup (\<lambda>n. ereal (root n (norm (f n))))"
  have "0 = limsup (\<lambda>n. 0)" by (simp add: Limsup_const)
  also have "... \<le> l" unfolding l_def by (intro Limsup_mono) (simp_all add: real_root_ge_zero)
  finally have l_nonneg: "l \<ge> 0" .
  from assms have l_nz: "l \<noteq> 0" unfolding conv_radius_def l_def by auto

  have "limsup (\<lambda>n. ereal (root n (norm (f n * z^n)))) = l * ereal (norm z)"
    unfolding l_def by (rule limsup_root_powser)
  also have "... > 1"
  proof (cases l)
    assume "l = \<infinity>"
    with assms conv_radius_nonneg[of f] show ?thesis
      by (auto simp: zero_ereal_def[symmetric])
  next
    fix l' assume l': "l = ereal l'"
    from l_nonneg l_nz have "1 = l * inverse l" by (auto simp: l' field_simps)
    also from l_nz have "inverse l = conv_radius f"
      unfolding l_def conv_radius_def by auto
    also from l' l_nz l_nonneg assms have "l * \<dots> < l * ereal (norm z)"
      by (intro ereal_mult_strict_left_mono) (auto simp: l')
    finally show ?thesis .
  qed (insert l_nonneg, simp_all)
  finally show "limsup (\<lambda>n. ereal (root n (norm (f n * z^n)))) > 1" .
qed

lemma conv_radius_geI:
  assumes "summable (\<lambda>n. f n * z ^ n :: 'a :: {banach, real_normed_div_algebra})"
  shows   "conv_radius f \<ge> norm z"
  using not_summable_outside_conv_radius[of f z] assms by (force simp: not_le[symmetric])

lemma conv_radius_leI:
  assumes "\<not>summable (\<lambda>n. norm (f n * z ^ n :: 'a :: {banach, real_normed_div_algebra}))"
  shows   "conv_radius f \<le> norm z"
  using abs_summable_in_conv_radius[of z f] assms by (force simp: not_le[symmetric])

lemma conv_radius_leI':
  assumes "\<not>summable (\<lambda>n. f n * z ^ n :: 'a :: {banach, real_normed_div_algebra})"
  shows   "conv_radius f \<le> norm z"
  using summable_in_conv_radius[of z f] assms by (force simp: not_le[symmetric])

lemma conv_radius_geI_ex:
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  assumes "\<And>r. 0 < r \<Longrightarrow> ereal r < R \<Longrightarrow> \<exists>z. norm z = r \<and> summable (\<lambda>n. f n * z^n)"
  shows   "conv_radius f \<ge> R"
proof (rule linorder_cases[of "conv_radius f" R])
  assume R: "conv_radius f < R"
  with conv_radius_nonneg[of f] obtain conv_radius'
    where [simp]: "conv_radius f = ereal conv_radius'"
    by (cases "conv_radius f") simp_all
  define r where "r = (if R = \<infinity> then conv_radius' + 1 else (real_of_ereal R + conv_radius') / 2)"
  from R conv_radius_nonneg[of f] have "0 < r \<and> ereal r < R \<and> ereal r > conv_radius f"
    unfolding r_def by (cases R) (auto simp: r_def field_simps)
  with assms(1)[of r] obtain z where "norm z > conv_radius f" "summable (\<lambda>n. f n * z^n)" by auto
  with not_summable_outside_conv_radius[of f z] show ?thesis by simp
qed simp_all

lemma conv_radius_geI_ex':
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  assumes "\<And>r. 0 < r \<Longrightarrow> ereal r < R \<Longrightarrow> summable (\<lambda>n. f n * of_real r^n)"
  shows   "conv_radius f \<ge> R"
proof (rule conv_radius_geI_ex)
  fix r assume "0 < r" "ereal r < R"
  with assms[of r] show "\<exists>z. norm z = r \<and> summable (\<lambda>n. f n * z ^ n)"
    by (intro exI[of _ "of_real r :: 'a"]) auto
qed

lemma conv_radius_leI_ex:
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  assumes "R \<ge> 0"
  assumes "\<And>r. 0 < r \<Longrightarrow> ereal r > R \<Longrightarrow> \<exists>z. norm z = r \<and> \<not>summable (\<lambda>n. norm (f n * z^n))"
  shows   "conv_radius f \<le> R"
proof (rule linorder_cases[of "conv_radius f" R])
  assume R: "conv_radius f > R"
  from R assms(1) obtain R' where R': "R = ereal R'" by (cases R) simp_all
  define r where
    "r = (if conv_radius f = \<infinity> then R' + 1 else (R' + real_of_ereal (conv_radius f)) / 2)"
  from R conv_radius_nonneg[of f] have "r > R \<and> r < conv_radius f" unfolding r_def
    by (cases "conv_radius f") (auto simp: r_def field_simps R')
  with assms(1) assms(2)[of r] R'
    obtain z where "norm z < conv_radius f" "\<not>summable (\<lambda>n. norm (f n * z^n))" by auto
  with abs_summable_in_conv_radius[of z f] show ?thesis by auto
qed simp_all

lemma conv_radius_leI_ex':
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  assumes "R \<ge> 0"
  assumes "\<And>r. 0 < r \<Longrightarrow> ereal r > R \<Longrightarrow> \<not>summable (\<lambda>n. f n * of_real r^n)"
  shows   "conv_radius f \<le> R"
proof (rule conv_radius_leI_ex)
  fix r assume "0 < r" "ereal r > R"
  with assms(2)[of r] show "\<exists>z. norm z = r \<and> \<not>summable (\<lambda>n. norm (f n * z ^ n))"
    by (intro exI[of _ "of_real r :: 'a"]) (auto dest: summable_norm_cancel)
qed fact+

lemma conv_radius_eqI:
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  assumes "R \<ge> 0"
  assumes "\<And>r. 0 < r \<Longrightarrow> ereal r < R \<Longrightarrow> \<exists>z. norm z = r \<and> summable (\<lambda>n. f n * z^n)"
  assumes "\<And>r. 0 < r \<Longrightarrow> ereal r > R \<Longrightarrow> \<exists>z. norm z = r \<and> \<not>summable (\<lambda>n. norm (f n * z^n))"
  shows   "conv_radius f = R"
  by (intro antisym conv_radius_geI_ex conv_radius_leI_ex assms)

lemma conv_radius_eqI':
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  assumes "R \<ge> 0"
  assumes "\<And>r. 0 < r \<Longrightarrow> ereal r < R \<Longrightarrow> summable (\<lambda>n. f n * (of_real r)^n)"
  assumes "\<And>r. 0 < r \<Longrightarrow> ereal r > R \<Longrightarrow> \<not>summable (\<lambda>n. norm (f n * (of_real r)^n))"
  shows   "conv_radius f = R"
proof (intro conv_radius_eqI[OF assms(1)])
  fix r assume "0 < r" "ereal r < R" with assms(2)[OF this]
    show "\<exists>z. norm z = r \<and> summable (\<lambda>n. f n * z ^ n)" by force
next
  fix r assume "0 < r" "ereal r > R" with assms(3)[OF this]
    show "\<exists>z. norm z = r \<and> \<not>summable (\<lambda>n. norm (f n * z ^ n))" by force
qed

lemma conv_radius_zeroI:
  fixes f :: "nat \<Rightarrow> 'a :: {banach,real_normed_div_algebra}"
  assumes "\<And>z. z \<noteq> 0 \<Longrightarrow> \<not>summable (\<lambda>n. f n * z^n)"
  shows   "conv_radius f = 0"
proof (rule ccontr)
  assume "conv_radius f \<noteq> 0"
  with conv_radius_nonneg[of f] have pos: "conv_radius f > 0" by simp
  define r where "r = (if conv_radius f = \<infinity> then 1 else real_of_ereal (conv_radius f) / 2)"
  from pos have r: "ereal r > 0 \<and> ereal r < conv_radius f"
    by (cases "conv_radius f") (simp_all add: r_def)
  hence "summable (\<lambda>n. f n * of_real r ^ n)" by (intro summable_in_conv_radius) simp
  moreover from r and assms[of "of_real r"] have "\<not>summable (\<lambda>n. f n * of_real r ^ n)" by simp
  ultimately show False by contradiction
qed

lemma conv_radius_inftyI':
  fixes f :: "nat \<Rightarrow> 'a :: {banach,real_normed_div_algebra}"
  assumes "\<And>r. r > c \<Longrightarrow> \<exists>z. norm z = r \<and> summable (\<lambda>n. f n * z^n)"
  shows   "conv_radius f = \<infinity>"
proof -
  {
    fix r :: real
    have "max r (c + 1) > c" by (auto simp: max_def)
    from assms[OF this] obtain z where "norm z = max r (c + 1)" "summable (\<lambda>n. f n * z^n)" by blast
    from conv_radius_geI[OF this(2)] this(1) have "conv_radius f \<ge> r" by simp
  }
  from this[of "real_of_ereal (conv_radius f + 1)"] show "conv_radius f = \<infinity>"
    by (cases "conv_radius f") simp_all
qed

lemma conv_radius_inftyI:
  fixes f :: "nat \<Rightarrow> 'a :: {banach,real_normed_div_algebra}"
  assumes "\<And>r. \<exists>z. norm z = r \<and> summable (\<lambda>n. f n * z^n)"
  shows   "conv_radius f = \<infinity>"
  using assms by (rule conv_radius_inftyI')

lemma conv_radius_inftyI'':
  fixes f :: "nat \<Rightarrow> 'a :: {banach,real_normed_div_algebra}"
  assumes "\<And>z. summable (\<lambda>n. f n * z^n)"
  shows   "conv_radius f = \<infinity>"
proof (rule conv_radius_inftyI')
  fix r :: real assume "r > 0"
  with assms show "\<exists>z. norm z = r \<and> summable (\<lambda>n. f n * z^n)"
    by (intro exI[of _ "of_real r"]) simp
qed

lemma conv_radius_ratio_limit_ereal:
  fixes f :: "nat \<Rightarrow> 'a :: {banach,real_normed_div_algebra}"
  assumes nz:  "eventually (\<lambda>n. f n \<noteq> 0) sequentially"
  assumes lim: "(\<lambda>n. ereal (norm (f n) / norm (f (Suc n)))) \<longlonglongrightarrow> c"
  shows   "conv_radius f = c"
proof (rule conv_radius_eqI')
  show "c \<ge> 0" by (intro Lim_bounded2_ereal[OF lim]) simp_all
next
  fix r assume r: "0 < r" "ereal r < c"
  let ?l = "liminf (\<lambda>n. ereal (norm (f n * of_real r ^ n) / norm (f (Suc n) * of_real r ^ Suc n)))"
  have "?l = liminf (\<lambda>n. ereal (norm (f n) / (norm (f (Suc n)))) * ereal (inverse r))"
    using r by (simp add: norm_mult norm_power divide_simps)
  also from r have "\<dots> = liminf (\<lambda>n. ereal (norm (f n) / (norm (f (Suc n))))) * ereal (inverse r)"
    by (intro Liminf_ereal_mult_right) simp_all
  also have "liminf (\<lambda>n. ereal (norm (f n) / (norm (f (Suc n))))) = c"
    by (intro lim_imp_Liminf lim) simp
  finally have l: "?l = c * ereal (inverse r)" by simp
  from r have  l': "c * ereal (inverse r) > 1" by (cases c) (simp_all add: field_simps)
  show "summable (\<lambda>n. f n * of_real r^n)"
    by (rule summable_norm_cancel, rule ratio_test_convergence)
       (insert r nz l l', auto elim!: eventually_mono)
next
  fix r assume r: "0 < r" "ereal r > c"
  let ?l = "limsup (\<lambda>n. ereal (norm (f n * of_real r ^ n) / norm (f (Suc n) * of_real r ^ Suc n)))"
  have "?l = limsup (\<lambda>n. ereal (norm (f n) / (norm (f (Suc n)))) * ereal (inverse r))"
    using r by (simp add: norm_mult norm_power divide_simps)
  also from r have "\<dots> = limsup (\<lambda>n. ereal (norm (f n) / (norm (f (Suc n))))) * ereal (inverse r)"
    by (intro Limsup_ereal_mult_right) simp_all
  also have "limsup (\<lambda>n. ereal (norm (f n) / (norm (f (Suc n))))) = c"
    by (intro lim_imp_Limsup lim) simp
  finally have l: "?l = c * ereal (inverse r)" by simp
  from r have  l': "c * ereal (inverse r) < 1" by (cases c) (simp_all add: field_simps)
  show "\<not>summable (\<lambda>n. norm (f n * of_real r^n))"
    by (rule ratio_test_divergence) (insert r nz l l', auto elim!: eventually_mono)
qed

lemma conv_radius_ratio_limit_ereal_nonzero:
  fixes f :: "nat \<Rightarrow> 'a :: {banach,real_normed_div_algebra}"
  assumes nz:  "c \<noteq> 0"
  assumes lim: "(\<lambda>n. ereal (norm (f n) / norm (f (Suc n)))) \<longlonglongrightarrow> c"
  shows   "conv_radius f = c"
proof (rule conv_radius_ratio_limit_ereal[OF _ lim], rule ccontr)
  assume "\<not>eventually (\<lambda>n. f n \<noteq> 0) sequentially"
  hence "frequently (\<lambda>n. f n = 0) sequentially" by (simp add: frequently_def)
  hence "frequently (\<lambda>n. ereal (norm (f n) / norm (f (Suc n))) = 0) sequentially"
    by (force elim!: frequently_elim1)
  hence "c = 0" by (intro limit_frequently_eq[OF _ _ lim]) auto
  with nz show False by contradiction
qed

lemma conv_radius_ratio_limit:
  fixes f :: "nat \<Rightarrow> 'a :: {banach,real_normed_div_algebra}"
  assumes "c' = ereal c"
  assumes nz:  "eventually (\<lambda>n. f n \<noteq> 0) sequentially"
  assumes lim: "(\<lambda>n. norm (f n) / norm (f (Suc n))) \<longlonglongrightarrow> c"
  shows   "conv_radius f = c'"
  using assms by (intro conv_radius_ratio_limit_ereal) simp_all

lemma conv_radius_ratio_limit_nonzero:
  fixes f :: "nat \<Rightarrow> 'a :: {banach,real_normed_div_algebra}"
  assumes "c' = ereal c"
  assumes nz:  "c \<noteq> 0"
  assumes lim: "(\<lambda>n. norm (f n) / norm (f (Suc n))) \<longlonglongrightarrow> c"
  shows   "conv_radius f = c'"
  using assms by (intro conv_radius_ratio_limit_ereal_nonzero) simp_all

lemma conv_radius_mult_power:
  assumes "c \<noteq> (0 :: 'a :: {real_normed_div_algebra,banach})"
  shows   "conv_radius (\<lambda>n. c ^ n * f n) = conv_radius f / ereal (norm c)"
proof -
  have "limsup (\<lambda>n. ereal (root n (norm (c ^ n * f n)))) =
          limsup (\<lambda>n. ereal (norm c) * ereal (root n (norm (f n))))"
    using eventually_gt_at_top[of "0::nat"]
    by (intro Limsup_eq)
       (auto elim!: eventually_mono simp: norm_mult norm_power real_root_mult real_root_power)
  also have "\<dots> = ereal (norm c) * limsup (\<lambda>n. ereal (root n (norm (f n))))"
    using assms by (subst Limsup_ereal_mult_left[symmetric]) simp_all
  finally have A: "limsup (\<lambda>n. ereal (root n (norm (c ^ n * f n)))) =
                       ereal (norm c) * limsup (\<lambda>n. ereal (root n (norm (f n))))" .
  show ?thesis using assms
    apply (cases "limsup (\<lambda>n. ereal (root n (norm (f n)))) = 0")
    apply (simp add: A conv_radius_def)
    apply (unfold conv_radius_def A divide_ereal_def, simp add: mult.commute ereal_inverse_mult)
    done
qed

lemma conv_radius_mult_power_right:
  assumes "c \<noteq> (0 :: 'a :: {real_normed_div_algebra,banach})"
  shows   "conv_radius (\<lambda>n. f n * c ^ n) = conv_radius f / ereal (norm c)"
  using conv_radius_mult_power[OF assms, of f]
  unfolding conv_radius_def by (simp add: mult.commute norm_mult)

lemma conv_radius_divide_power:
  assumes "c \<noteq> (0 :: 'a :: {real_normed_div_algebra,banach})"
  shows   "conv_radius (\<lambda>n. f n / c^n) = conv_radius f * ereal (norm c)"
proof -
  from assms have "inverse c \<noteq> 0" by simp
  from conv_radius_mult_power_right[OF this, of f] show ?thesis
    by (simp add: divide_inverse divide_ereal_def assms norm_inverse power_inverse)
qed

lemma conv_radius_add_ge:
  "min (conv_radius f) (conv_radius g) \<le>
       conv_radius (\<lambda>x. f x + g x :: 'a :: {banach,real_normed_div_algebra})"
  by (rule conv_radius_geI_ex')
     (auto simp: algebra_simps intro!: summable_add summable_in_conv_radius)

lemma conv_radius_mult_ge:
  fixes f g :: "nat \<Rightarrow> ('a :: {banach,real_normed_div_algebra})"
  shows "conv_radius (\<lambda>x. \<Sum>i\<le>x. f i * g (x - i)) \<ge> min (conv_radius f) (conv_radius g)"
proof (rule conv_radius_geI_ex')
  fix r assume r: "r > 0" "ereal r < min (conv_radius f) (conv_radius g)"
  from r have "summable (\<lambda>n. (\<Sum>i\<le>n. (f i * of_real r^i) * (g (n - i) * of_real r^(n - i))))"
    by (intro summable_Cauchy_product abs_summable_in_conv_radius) simp_all
  thus "summable (\<lambda>n. (\<Sum>i\<le>n. f i * g (n - i)) * of_real r ^ n)"
    by (simp add: algebra_simps of_real_def power_add [symmetric] scaleR_sum_right)
qed

lemma le_conv_radius_iff:
  fixes a :: "nat \<Rightarrow> 'a::{real_normed_div_algebra,banach}"
  shows "r \<le> conv_radius a \<longleftrightarrow> (\<forall>x. norm (x-\<xi>) < r \<longrightarrow> summable (\<lambda>i. a i * (x - \<xi>) ^ i))"
apply (intro iffI allI impI summable_in_conv_radius conv_radius_geI_ex)
apply (meson less_ereal.simps(1) not_le order_trans)
apply (rule_tac x="of_real ra" in exI, simp)
apply (metis abs_of_nonneg add_diff_cancel_left' less_eq_real_def norm_of_real)
done

end


(* Author: Tobias Nipkow *)

section \<open>2-3 Trees\<close>

theory Tree23
imports Main
begin

class height =
fixes height :: "'a \<Rightarrow> nat"

datatype 'a tree23 =
  Leaf ("\<langle>\<rangle>") |
  Node2 "'a tree23" 'a "'a tree23"  ("\<langle>_, _, _\<rangle>") |
  Node3 "'a tree23" 'a "'a tree23" 'a "'a tree23"  ("\<langle>_, _, _, _, _\<rangle>")

fun inorder :: "'a tree23 \<Rightarrow> 'a list" where
"inorder Leaf = []" |
"inorder(Node2 l a r) = inorder l @ a # inorder r" |
"inorder(Node3 l a m b r) = inorder l @ a # inorder m @ b # inorder r"

instantiation tree23 :: (type)height
begin

fun height_tree23 :: "'a tree23 \<Rightarrow> nat" where
"height Leaf = 0" |
"height (Node2 l _ r) = Suc(max (height l) (height r))" |
"height (Node3 l _ m _ r) = Suc(max (height l) (max (height m) (height r)))"

instance ..

end

text \<open>Balanced:\<close>

fun complete :: "'a tree23 \<Rightarrow> bool" where
"complete Leaf = True" |
"complete (Node2 l _ r) = (complete l & complete r & height l = height r)" |
"complete (Node3 l _ m _ r) =
  (complete l & complete m & complete r & height l = height m & height m = height r)"

lemma ht_sz_if_complete: "complete t \<Longrightarrow> 2 ^ height t \<le> size t + 1"
by (induction t) auto

end