theory P25 imports Main begin

datatype bintree = Tip | Node bintree nat bintree

fun tge :: "nat \<Rightarrow> bintree \<Rightarrow> bool" where
"tge n Tip = True" |
"tge n (Node l m r) = ((tge n l) \<and> (n \<ge> m) \<and> (tge n r))"

fun tle :: "nat \<Rightarrow> bintree \<Rightarrow> bool" where
"tle n Tip = True" |
"tle n (Node l m r) = ((tle n l) \<and> (n \<le> m) \<and> (tle n r))"

fun tsorted :: "bintree \<Rightarrow> bool" where
"tsorted Tip = True" |
"tsorted (Node l m r) = ((tsorted l) \<and> (tsorted r) \<and> (tge m l) \<and> (tle m r))"

fun ins :: "nat \<Rightarrow> bintree \<Rightarrow> bintree" where
"ins n Tip = (Node Tip n Tip)" |
"ins n (Node l m r) = (if (n \<le> m) then (Node (ins n l) m r) else (Node l m (ins n r)))"

definition tree_of :: "nat list \<Rightarrow> bintree" where
"tree_of xs = (foldr ins xs Tip)"

lemma tge_inva: "tge x xt \<Longrightarrow> a \<le> x \<Longrightarrow> tge x (ins a xt)"
  apply (induct xt)
   apply auto
  done

lemma tle_inva: "tle x xt \<Longrightarrow> \<not>(a \<le> x) \<Longrightarrow> tle x (ins a xt)"
  apply (induct xt)
   apply auto
  done

theorem [simp]: "tsorted (tree_of xs)"
  apply (induct xs)
   apply (auto simp add: tree_of_def)
  done

primrec count :: "nat list => nat => nat" where
"count [] y = 0" |
"count (x#xs) y = (if x=y then Suc(count xs y) else count xs y)"

lemma [simp]: "count (a # xs) x = (count xs x) + (if (x=a) then 1 else 0)"
  apply (induct xs)
   apply auto
  done

fun tcount :: "bintree \<Rightarrow> nat \<Rightarrow> nat" where
"tcount Tip n = 0" |
"tcount (Node l x r) n = (tcount l n) + (tcount r n) + (if (x=n) then 1 else 0)"

lemma [simp]: "tcount (ins a xs) x = (tcount xs x) + (if x=a then 1 else 0)"
  apply (induct xs)
   apply auto
  done

lemma [simp]: "tcount (tree_of (a # xs)) x = (tcount (tree_of xs) x + (if (x=a) then 1 else 0))"
  apply (induct xs)
   apply (auto simp add: tree_of_def)
  done

theorem "tcount (tree_of xs) x = count xs x"
proof (induct xs)
case Nil
then show ?case by (simp add: tree_of_def)
next
  case (Cons a xs)
  then show ?case by simp
qed

primrec le :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
"le n Nil = True" |
"le n (x # xs) = (n \<le> x \<and> le n xs)"

primrec ge :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
"ge n Nil = True" |
"ge n (x # xs) = (x \<le> n \<and> ge n xs)"

primrec sorted :: "nat list \<Rightarrow> bool" where
"sorted [] = True"
| "sorted (x#xs) = (le x xs & sorted xs)"

lemma [simp]: "le x (a@b) = (le x a \<and> le x b)"
  apply (induct a)
  apply auto
  done

lemma [simp]: "ge x (a@b) = (ge x a \<and> ge x b)"
  apply (induct a)
  apply auto
  done

lemma [simp]: "x \<le> y \<Longrightarrow> le y xs \<Longrightarrow> le x xs"
  apply (induct xs)
  apply auto
  done

lemma [simp]: "sorted (a@x#b) = (sorted a \<and> sorted b \<and> ge x a \<and> le x b)"
  apply (induct a)
  apply auto
  done

fun list_of :: "bintree \<Rightarrow> nat list" where
"list_of Tip = Nil" |
"list_of (Node l x r) = (list_of l) @ [x] @ (list_of r)"

lemma [simp]: "ge n (list_of t) = tge n t"
  apply (induct t)
  apply auto
  done

lemma [simp]: "le n (list_of t) = tle n t"
  apply (induct t)
   apply auto
  done

lemma [simp]: "sorted (list_of t) = tsorted t"
  apply (induct t)
  apply auto
  done

theorem "sorted (list_of (tree_of xs))"
  apply (induct xs)
   apply (auto simp add: tree_of_def)
  done

lemma count_append [simp]: "count (a@b) n = count a n + count b n"
  apply (induct a)
  apply auto
  done

lemma [simp]: "count (list_of b) n = tcount b n"
  apply (induct b)
  apply auto
  done

theorem "count (list_of (tree_of xs)) n = count xs n"
  apply (induct xs)
   apply (auto simp add: tree_of_def)
  done

end


(*
  File:    Descartes_Sign_Rule.thy
  Author:  Manuel Eberl <eberlm@in.tum.de>

  Descartes' Rule of Signs, which relates the number of positive real roots of a polynomial
  with the number of sign changes in its coefficient list.
*)
section \<open>Sign changes and Descartes' Rule of Signs\<close>

theory Descartes_Sign_Rule
imports
  Complex_Main
  "HOL-Computational_Algebra.Polynomial"
begin

lemma filter_dropWhile:
  "filter (\<lambda>x. \<not>P x) (dropWhile P xs) = filter (\<lambda>x. \<not>P x) xs"
  by (induction xs) simp_all

subsection \<open>Polynomials\<close>

text\<open>
  A real polynomial whose leading and constant coefficients have opposite
  non-zero signs must have a positive root.
\<close>
lemma pos_root_exI:
  assumes "poly p 0 * lead_coeff p < (0 :: real)"
  obtains x where "x > 0" "poly p x = 0"
proof -
  have P: "\<exists>x>0. poly p x = (0::real)" if "lead_coeff p > 0" "poly p 0 < 0" for p
  proof -
    note that(1)
    also from poly_pinfty_gt_lc[OF \<open>lead_coeff p > 0\<close>] obtain x0
      where "\<And>x. x \<ge> x0 \<Longrightarrow> poly p x \<ge> lead_coeff p" by auto
    hence "poly p (max x0 1) \<ge> lead_coeff p" by auto
    finally have "poly p (max x0 1) > 0" .
    with that have "\<exists>x. x > 0 \<and> x < max x0 1 \<and> poly p x = 0"
      by (intro poly_IVT mult_neg_pos) auto
    thus "\<exists>x>0. poly p x = 0"  by auto
  qed

  show ?thesis
  proof (cases "lead_coeff p > 0")
    case True
    with assms have "poly p 0 < 0"
      by (auto simp: mult_less_0_iff)
    from P[OF True this] that show ?thesis
      by blast
  next
    case False
    from False assms have "poly (-p) 0 < 0"
      by (auto simp: mult_less_0_iff)
    moreover from assms have "p \<noteq> 0"
      by auto
    with False have "lead_coeff (-p) > 0"
      by (cases rule: linorder_cases[of "lead_coeff p" 0])
         (simp_all add:)
    ultimately show ?thesis using that P[of "-p"] by auto
  qed
qed

text \<open>
  Substitute $X$ with $aX$ in a polynomial $p(X)$. This turns all the $X - a$ factors in $p$
  into factors of the form $X - 1$.
\<close>
definition reduce_root where
  "reduce_root a p = pcompose p [:0, a:]"

lemma reduce_root_pCons:
  "reduce_root a (pCons c p) = pCons c (smult a (reduce_root a p))"
  by (simp add: reduce_root_def pcompose_pCons)

lemma reduce_root_nonzero [simp]:
  "a \<noteq> 0 \<Longrightarrow> p \<noteq> 0 \<Longrightarrow> reduce_root a p \<noteq> (0 :: 'a :: idom poly)"
  unfolding reduce_root_def using pcompose_eq_0[of p "[:0, a:]"]
  by auto

subsection \<open>List of partial sums\<close>

text \<open>
  We first define, for a given list, the list of accumulated partial sums from left to right:
  the list @{term "psums xs"} has as its $i$-th entry $\sum_{j=0}^i \mathrm{xs}_i$.
\<close>

fun psums where
  "psums [] = []"
| "psums [x] = [x]"
| "psums (x#y#xs) = x # psums ((x+y) # xs)"

lemma length_psums [simp]: "length (psums xs) = length xs"
  by (induction xs rule: psums.induct) simp_all

lemma psums_Cons:
  "psums (x#xs) = (x :: 'a :: semigroup_add) # map ((+) x) (psums xs)"
  by (induction xs rule: psums.induct) (simp_all add: algebra_simps)

lemma last_psums:
  "(xs :: 'a :: monoid_add list) \<noteq> [] \<Longrightarrow> last (psums xs) = sum_list xs"
  by (induction xs rule: psums.induct)
     (auto simp add: add.assoc [symmetric] psums_Cons o_def)

lemma psums_0_Cons [simp]:
  "psums (0#xs :: 'a :: monoid_add list) = 0 # psums xs"
  by (induction xs rule: psums.induct) (simp_all add: algebra_simps)

lemma map_uminus_psums:
  fixes xs :: "'a :: ab_group_add list"
  shows "map uminus (psums xs) = psums (map uminus xs)"
  by (induction xs rule: psums.induct) (simp_all)

lemma psums_replicate_0_append:
  "psums (replicate n (0 :: 'a :: monoid_add) @ xs) =
     replicate n 0 @ psums xs"
  by (induction n) (simp_all add: psums_Cons op_plus_0)

lemma psums_nth: "n < length xs \<Longrightarrow> psums xs ! n = (\<Sum>i\<le>n. xs ! i)"
proof (induction xs arbitrary: n rule: psums.induct[case_names Nil sng rec])
  case (rec x y xs n)
  show ?case
  proof (cases n)
    case (Suc m)
    from Suc have "psums (x # y # xs) ! n = psums ((x+y) # xs) ! m" by simp
    also from rec.prems Suc have "\<dots> = (\<Sum>i\<le>m. ((x+y) # xs) ! i)"
      by (intro rec.IH) simp_all
    also have "\<dots> = x + y + (\<Sum>i=1..m. (y#xs) ! i)"
      by (auto simp: atLeast0AtMost [symmetric] sum.atLeast_Suc_atMost[of 0])
    also have "(\<Sum>i=1..m. (y#xs) ! i) = (\<Sum>i=Suc 1..Suc m. (x#y#xs) ! i)"
      by (subst sum.shift_bounds_cl_Suc_ivl) simp
    also from Suc have "x + y + \<dots> = (\<Sum>i\<le>n. (x#y#xs) ! i)"
      by (auto simp: atLeast0AtMost [symmetric] sum.atLeast_Suc_atMost add_ac)
    finally show ?thesis .
  qed simp
qed simp_all

subsection \<open>Sign changes in a list\<close>

text \<open>
  Next, we define the number of sign changes in a sequence. Intuitively, this is the number
  of times that, when passing through the list, a sign change between one element and the next
  element occurs (while ignoring all zero entries).

  We implement this by filtering all zeros from the list of signs, removing all adjacent equal
  elements and taking the length of the resulting list minus one.
\<close>
definition sign_changes :: "('a :: {sgn,zero} list) \<Rightarrow> nat" where
  "sign_changes xs = length (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map sgn xs))) - 1"

lemma sign_changes_Nil [simp]: "sign_changes [] = 0"
  by (simp add: sign_changes_def)

lemma sign_changes_singleton [simp]: "sign_changes [x] = 0"
  by (simp add: sign_changes_def)

lemma sign_changes_cong:
  assumes "map sgn xs = map sgn ys"
  shows   "sign_changes xs = sign_changes ys"
  using assms unfolding sign_changes_def by simp

lemma sign_changes_Cons_ge: "sign_changes (x # xs) \<ge> sign_changes xs"
  unfolding sign_changes_def by (simp add: remdups_adj_Cons split: list.split)

lemma sign_changes_Cons_Cons_different:
  fixes x y :: "'a :: linordered_idom"
  assumes "x * y < 0"
  shows "sign_changes (x # y # xs) = 1 + sign_changes (y # xs)"
proof -
  from assms have "sgn x = -1 \<and> sgn y = 1 \<or> sgn x = 1 \<and> sgn y = -1"
    by (auto simp: mult_less_0_iff)
  thus ?thesis by (fastforce simp: sign_changes_def)
qed

lemma sign_changes_Cons_Cons_same:
  fixes x y :: "'a :: linordered_idom"
  shows "x * y > 0 \<Longrightarrow> sign_changes (x # y # xs) = sign_changes (y # xs)"
  by (subst (asm) zero_less_mult_iff) (fastforce simp: sign_changes_def)

lemma sign_changes_0_Cons [simp]:
  "sign_changes (0 # xs :: 'a :: idom_abs_sgn list) = sign_changes xs"
  by (simp add: sign_changes_def)

lemma sign_changes_two:
  fixes x y :: "'a :: linordered_idom"
  shows "sign_changes [x,y] =
           (if x > 0 \<and> y < 0 \<or> x < 0 \<and> y > 0 then 1 else 0)"
  by (auto simp: sgn_if sign_changes_def mult_less_0_iff)

lemma sign_changes_induct [case_names nil sing zero nonzero]:
  assumes "P []" "\<And>x. P [x]" "\<And>xs. P xs \<Longrightarrow> P (0#xs)"
          "\<And>x y xs. x \<noteq> 0 \<Longrightarrow> P ((x + y) # xs) \<Longrightarrow> P (x # y # xs)"
  shows   "P xs"
proof (induction "length xs" arbitrary: xs rule: less_induct)
  case (less xs)
  show ?case
  proof (cases xs rule: psums.cases)
    fix x y xs' assume "xs = x # y # xs'"
    with assms less show ?thesis by (cases "x = 0") auto
  qed (insert less assms, auto)
qed

lemma sign_changes_filter:
  fixes xs :: "'a :: linordered_idom list"
  shows "sign_changes (filter (\<lambda>x. x \<noteq> 0) xs) = sign_changes xs"
  by (simp add: sign_changes_def filter_map o_def sgn_0_0)

lemma sign_changes_Cons_Cons_0:
  fixes xs :: "'a :: linordered_idom list"
  shows "sign_changes (x # 0 # xs) = sign_changes (x # xs)"
  by (subst (1 2) sign_changes_filter [symmetric]) simp_all

lemma sign_changes_uminus:
  fixes xs :: "'a :: linordered_idom list"
  shows   "sign_changes (map uminus xs) = sign_changes xs"
proof -
  have "sign_changes (map uminus xs) =
          length (remdups_adj [x\<leftarrow>map sgn (map uminus xs) . x \<noteq> 0]) - 1"
   unfolding sign_changes_def ..
  also have "map sgn (map uminus xs) = map uminus (map sgn xs)"
    by (auto simp: sgn_minus)
  also have "remdups_adj (filter (\<lambda>x. x \<noteq> 0) \<dots>) =
                 map uminus (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map sgn xs)))"
    by (subst filter_map, subst remdups_adj_map_injective)
       (simp_all add: o_def)
  also have "length \<dots> - 1 = sign_changes xs" by (simp add: sign_changes_def)
  finally show ?thesis .
qed

lemma sign_changes_replicate: "sign_changes (replicate n x) = 0"
  by (simp add: sign_changes_def remdups_adj_replicate filter_replicate)

lemma sign_changes_decompose:
  assumes "x \<noteq> (0 :: 'a :: linordered_idom)"
  shows   "sign_changes (xs @ x # ys) =
             sign_changes (xs @ [x]) + sign_changes (x # ys)"
proof -
  have "sign_changes (xs @ x # ys) =
            length (remdups_adj ([x\<leftarrow>map sgn xs . x \<noteq> 0] @
                      sgn x # [x\<leftarrow>map sgn ys . x \<noteq> 0])) - 1"
    by (simp add: sgn_0_0 assms sign_changes_def)
  also have "\<dots> = sign_changes (xs @ [x]) + sign_changes (x # ys)"
    by (subst remdups_adj_append) (simp add: sign_changes_def assms sgn_0_0)
  finally show ?thesis .
qed

text \<open>
  If the first and the last entry of a list are non-zero, its number of sign changes is even
  if and only if the first and the last element have the same sign. This will be important
  later to establish the base case of Descartes' Rule. (if there are no positive roots,
  the number of sign changes is even)
\<close>
lemma even_sign_changes_iff:
  assumes "xs \<noteq> ([] :: 'a :: linordered_idom list)" "hd xs \<noteq> 0" "last xs \<noteq> 0"
  shows   "even (sign_changes xs) \<longleftrightarrow> sgn (hd xs) = sgn (last xs)"
using assms
proof (induction "length xs" arbitrary: xs rule: less_induct)
  case (less xs)
  show ?case
  proof (cases xs)
    case (Cons x xs')
    note x = this
    show ?thesis
    proof (cases xs')
      case (Cons y xs'')
      note y = this
      show ?thesis
      proof (rule linorder_cases[of "x*y" 0])
        assume xy: "x*y = 0"
        with x y less(1,3,4) show ?thesis by (auto simp: sign_changes_Cons_Cons_0)
      next
        assume xy: "x*y > 0"
        with less(1,4) show ?thesis
          by (auto simp add: x y sign_changes_Cons_Cons_same zero_less_mult_iff)
      next
        assume xy: "x*y < 0"
        moreover from xy have "sgn x = - sgn y" by (auto simp: mult_less_0_iff)
        moreover have "even (sign_changes (y # xs'')) \<longleftrightarrow>
                         sgn (hd (y # xs'')) = sgn (last (y # xs''))"
          using xy less.prems by (intro less) (auto simp: x y)
        moreover from xy less.prems
          have "sgn y = sgn (last xs) \<longleftrightarrow> -sgn y \<noteq> sgn (last xs)"
          by (auto simp: sgn_if)
        ultimately show ?thesis by (auto simp: sign_changes_Cons_Cons_different x y)
      qed
    qed (auto simp: x)
  qed (insert less.prems, simp_all)
qed

subsection \<open>Arthan's lemma\<close>

context
begin

text \<open>
  We first prove an auxiliary lemma that allows us to assume w.l.o.g. that the first element of
  the list is non-negative, similarly to what Arthan does in his proof.
\<close>
private lemma arthan_wlog [consumes 3, case_names nonneg lift]:
  fixes xs :: "'a :: linordered_idom list"
  assumes "xs \<noteq> []" "last xs \<noteq> 0" "x + y + sum_list xs = 0"
  assumes "\<And>x y xs. xs \<noteq> [] \<Longrightarrow> last xs \<noteq> 0 \<Longrightarrow>
               x + y + sum_list xs = 0 \<Longrightarrow> x \<ge> 0 \<Longrightarrow> P x y xs"
  assumes "\<And>x y xs. xs \<noteq> [] \<Longrightarrow> P x y xs \<Longrightarrow> P (-x) (-y) (map uminus xs)"
  shows   "P x y xs"
proof (cases "x \<ge> 0")
  assume x: "\<not>(x \<ge> 0)"
  from assms have "map uminus xs \<noteq> []" by simp
  moreover from x assms(1,2,3) have"P (-x) (-y) (map uminus xs)"
    using uminus_sum_list_map[of "\<lambda>x. x" xs, symmetric]
    by (intro assms) (auto simp: last_map algebra_simps o_def neg_eq_iff_add_eq_0)
  ultimately have "P (- (-x)) (- (-y)) (map uminus (map uminus xs))" by (rule assms)
  thus ?thesis by (simp add: o_def)
qed (simp_all add: assms)

text \<open>
  We now show that the $\alpha$ and $\beta$ in Arthan's proof have the necessary properties:
  their difference is non-negative and even.
\<close>
private lemma arthan_aux1:
  fixes xs :: "'a :: {linordered_idom} list"
  assumes "xs \<noteq> []" "last xs \<noteq> 0" "x + y + sum_list xs = 0"
  defines "v \<equiv> \<lambda>xs. int (sign_changes xs)"
  shows "v (x # y # xs) - v ((x + y) # xs) \<ge>
             v (psums (x # y # xs)) - v (psums ((x + y) # xs)) \<and>
         even (v (x # y # xs) - v ((x + y) # xs) -
                  (v (psums (x # y # xs)) - v (psums ((x + y) # xs))))"
using assms(1-3)
proof (induction rule: arthan_wlog)
  have uminus_v: "v (map uminus xs) = v xs" for xs by (simp add: v_def sign_changes_uminus)

  case (lift x y xs)
  note lift(2)
  also have "v (psums (x#y#xs)) - v (psums ((x+y)#xs)) =
                 v (psums (- x # - y # map uminus xs)) -
                 v (psums ((- x + - y) # map uminus xs))"
    by (subst (1 2) uminus_v [symmetric]) (simp add: map_uminus_psums)
  also have "v (x # y # xs) - v ((x + y) # xs) =
                 v (-x # -y # map uminus xs) - v ((-x + -y) # map uminus xs)"
    by (subst (1 2) uminus_v [symmetric]) simp
  finally show ?case .
next
  case (nonneg x y xs)
  define p where "p = (LEAST n. xs ! n \<noteq> 0)"
  define xs1 :: "'a list" where "xs1 = replicate p 0"
  define xs2 where "xs2 = drop (Suc p) xs"
  from nonneg have "xs ! (length xs - 1) \<noteq> 0" by (simp add: last_conv_nth)
  hence p_nz: "xs ! p \<noteq> 0" unfolding p_def by (rule LeastI)
  {
    fix q assume "q < p" hence "xs ! q = 0"
      using Least_le[of "\<lambda>n. xs ! n \<noteq> 0" q] unfolding p_def by force
  } note less_p_zero = this
  from Least_le[of "\<lambda>n. xs ! n \<noteq> 0" "length xs - 1"] nonneg
    have "p \<le> length xs - 1" unfolding p_def by (auto simp: last_conv_nth)
  with nonneg have p_less_length: "p < length xs" by (cases xs) simp_all

  from p_less_length less_p_zero have "take p xs = replicate p 0"
    by (subst list_eq_iff_nth_eq) auto
  with p_less_length have xs_decompose: "xs = xs1 @ xs ! p # xs2"
    unfolding xs1_def xs2_def
    by (subst append_take_drop_id [of p, symmetric],
        subst Cons_nth_drop_Suc) simp_all

  have v_decompose: "v (xs' @ xs) = v (xs' @ [xs ! p]) + v (xs ! p # xs2)" for xs'
  proof -
    have "xs' @ xs = (xs' @ xs1) @ xs ! p # xs2" by (subst xs_decompose) simp
    also have "v \<dots> = v (xs' @ [xs ! p]) + v (xs ! p # xs2)" unfolding v_def
      by (subst sign_changes_decompose[OF p_nz],
          subst (1 2 3 4) sign_changes_filter [symmetric]) (simp_all add: xs1_def)
    finally show ?thesis .
  qed

  have psums_decompose: "psums xs = replicate p 0 @ psums (xs!p # xs2)"
    by (subst xs_decompose) (simp add: xs1_def psums_replicate_0_append)
  have v_psums_decompose: "sign_changes (xs' @ psums xs) = sign_changes (xs' @ [xs!p]) +
         sign_changes (xs!p # map ((+) (xs!p)) (psums xs2))" for xs'
  proof -
    fix xs' :: "'a list"
    have "sign_changes (xs' @ psums xs) =
            sign_changes (xs' @ xs ! p # map ((+) (xs!p)) (psums xs2))"
      by (subst psums_decompose, subst (1 2) sign_changes_filter [symmetric])
         (simp_all add: psums_Cons)
    also have "\<dots> = sign_changes (xs' @ [xs!p]) +
                      sign_changes (xs!p # map ((+) (xs!p)) (psums xs2))"
      by (subst sign_changes_decompose[OF p_nz]) simp_all
    finally show "sign_changes (xs' @ psums xs) = \<dots>" .
  qed

  show ?case
  proof (cases "x > 0")
    assume "\<not>(x > 0)"
    with nonneg show ?thesis by (auto simp: v_def)
  next
    assume x: "x > 0"
    show ?thesis
    proof (rule linorder_cases[of y 0])
      assume y: "y > 0"
      from x and this have xy: "x + y > 0" by (rule add_pos_pos)
      with y have "sign_changes ((x + y) # xs) = sign_changes (y # xs)"
        by (intro sign_changes_cong) auto
      moreover have "sign_changes (x # psums ((x + y) # xs)) =
                       sign_changes (psums ((x+y) # xs))"
        using x xy by (subst (1 2) psums_Cons) (simp_all add: sign_changes_Cons_Cons_same)
      ultimately show ?thesis using x y
        by (simp add: v_def algebra_simps sign_changes_Cons_Cons_same)
    next
      assume y: "y = 0"
      with x show ?thesis
        by (simp add: v_def sign_changes_Cons_Cons_0 psums_Cons
                      o_def sign_changes_Cons_Cons_same)
    next
      assume y: "y < 0"
      with x have different: "x * y < 0" by (rule mult_pos_neg)
      show ?thesis
      proof (rule linorder_cases[of "x + y" 0])
        assume xy: "x + y < 0"
        with x have different': "x * (x + y) < 0" by (rule mult_pos_neg)
        have "(\<lambda>t. t + (x + y)) = ((+) (x + y))" by (rule ext) simp
        moreover from y xy have "sign_changes ((x+y) # xs) = sign_changes (y # xs)"
          by (intro sign_changes_cong) auto
        ultimately show ?thesis using xy different different' y
          by (simp add: v_def sign_changes_Cons_Cons_different psums_Cons o_def add_ac)
      next
        assume xy: "x + y = 0"
        show ?case
        proof (cases "xs ! p > 0")
          assume p: "xs ! p > 0"
          from p y have different': "y * xs ! p < 0" by (intro mult_neg_pos)
          with v_decompose[of "[x, y]"] v_decompose[of "[x+y]"] x xy p different different'
               v_psums_decompose[of "[x]"] v_psums_decompose[of "[]"]
          show ?thesis by (auto simp add: algebra_simps v_def sign_changes_Cons_Cons_0
                             sign_changes_Cons_Cons_different sign_changes_Cons_Cons_same)
        next
          assume "\<not>(xs ! p > 0)"
          with p_nz have p: "xs ! p < 0" by simp
          from p y have same: "y * xs ! p > 0" by (intro mult_neg_neg)
          from p x have different': "x * xs ! p < 0" by (intro mult_pos_neg)
          from v_decompose[of "[x, y]"] v_decompose[of "[x+y]"] xy different different' same
               v_psums_decompose[of "[x]"] v_psums_decompose[of "[]"]
          show ?thesis by (auto simp add: algebra_simps v_def sign_changes_Cons_Cons_0
                             sign_changes_Cons_Cons_different sign_changes_Cons_Cons_same)
        qed
      next
        assume xy: "x + y > 0"
        from x and this have same: "x * (x + y) > 0" by (rule mult_pos_pos)
        show ?case
        proof (cases "xs ! p > 0")
          assume p: "xs ! p > 0"
          from xy p have same': "(x + y) * xs ! p > 0" by (intro mult_pos_pos)
          from p y have different': "y * xs ! p < 0" by (intro mult_neg_pos)
          have "(\<lambda>t. t + (x + y)) = ((+) (x + y))" by (rule ext) simp
          with v_decompose[of "[x, y]"] v_decompose[of "[x+y]"] different different' same same'
          show ?thesis by (auto simp add: algebra_simps v_def psums_Cons o_def
                             sign_changes_Cons_Cons_different sign_changes_Cons_Cons_same)
        next
          assume "\<not>(xs ! p > 0)"
          with p_nz have p: "xs ! p < 0" by simp
          from xy p have different': "(x + y) * xs ! p < 0" by (rule mult_pos_neg)
          from y p have same': "y * xs ! p > 0" by (rule mult_neg_neg)
          have "(\<lambda>t. t + (x + y)) = ((+) (x + y))" by (rule ext) simp
          with v_decompose[of "[x, y]"] v_decompose[of "[x+y]"] different different' same same'
          show ?thesis by (auto simp add: algebra_simps v_def psums_Cons o_def
                              sign_changes_Cons_Cons_different sign_changes_Cons_Cons_same)
        qed
      qed
    qed
  qed
qed

text \<open>
  Now we can prove the main lemma of the proof by induction over the list with our specialised
  induction rule for @{term "sign_changes"}. It states that for a non-empty list whose last element
  is non-zero and whose sum is zero, the difference of the sign changes in the list and in the list
  of its partial sums is odd and positive.
\<close>
lemma arthan:
  fixes xs :: "'a :: linordered_idom list"
  assumes "xs \<noteq> []" "last xs \<noteq> 0" "sum_list xs = 0"
  shows   "sign_changes xs > sign_changes (psums xs) \<and>
           odd (sign_changes xs - sign_changes (psums xs))"
using assms
proof (induction xs rule: sign_changes_induct)
  case (nonzero x y xs)
  show ?case
  proof (cases "xs = []")
    case False
    define \<alpha> where "\<alpha> = int (sign_changes (x # y # xs)) - int (sign_changes ((x + y) # xs))"
    define \<beta> where "\<beta> = int (sign_changes (psums (x # y # xs))) - int (sign_changes (psums ((x+y) # xs)))"
    from nonzero False have "\<alpha> \<ge> \<beta> \<and> even (\<alpha> - \<beta>)" unfolding \<alpha>_def \<beta>_def
      by (intro arthan_aux1) auto
    from False and nonzero.prems have
       "sign_changes (psums ((x + y) # xs)) < sign_changes ((x + y) # xs) \<and>
        odd (sign_changes ((x + y) # xs) - sign_changes (psums ((x + y) # xs)))"
      by (intro nonzero.IH) (auto simp: add.assoc)
    with arthan_aux1[of xs x y] nonzero(4,5) False(1) show ?thesis by force
  qed (insert nonzero.prems, auto split: if_split_asm simp: sign_changes_two add_eq_0_iff)
qed (auto split: if_split_asm simp: add_eq_0_iff)

end

subsection \<open>Roots of a polynomial with a certain property\<close>

text \<open>
  The set of roots of a polynomial @{term "p"} that fulfil a given property @{term "P"}:
\<close>
definition "roots_with P p = {x. P x \<and> poly p x = 0}"

text \<open>
  The number of roots of a polynomial @{term "p"} with a given property @{term "P"}, where
  multiple roots are counted multiple times.
 \<close>
definition "count_roots_with P p = (\<Sum>x\<in>roots_with P p. order x p)"

abbreviation "pos_roots \<equiv> roots_with (\<lambda>x. x > 0)"
abbreviation "count_pos_roots \<equiv> count_roots_with (\<lambda>x. x > 0)"

lemma finite_roots_with [simp]:
  "(p :: 'a :: linordered_idom poly) \<noteq> 0 \<Longrightarrow> finite (roots_with P p)"
  by (rule finite_subset[OF _ poly_roots_finite[of p]]) (auto simp: roots_with_def)

lemma count_roots_with_times_root:
  assumes "p \<noteq> 0" "P (a :: 'a :: linordered_idom)"
  shows   "count_roots_with P ([:a, -1:] * p) = Suc (count_roots_with P p)"
proof -
  define q where "q = [:a, -1:] * p"
  from assms have a: "a \<in> roots_with P q" by (simp_all add: roots_with_def q_def)
  have q_nz: "q \<noteq> 0" unfolding q_def by (rule no_zero_divisors) (simp_all add: assms)

  have "count_roots_with P q = (\<Sum>x\<in>roots_with P q. order x q)" by (simp add: count_roots_with_def)
  also from a q_nz have "\<dots> = order a q + (\<Sum>x\<in>roots_with P q - {a}. order x q)"
    by (subst sum.remove) simp_all
  also have "order a q = order a [:a, -1:] + order a p" unfolding q_def
    by (subst order_mult[OF no_zero_divisors]) (simp_all add: assms)
  also have "order a [:a, -1:] = 1"
    by (subst order_smult [of "-1", symmetric])
       (insert order_power_n_n[of a 1], simp_all add: order_1)
  also have "(\<Sum>x\<in>roots_with P q - {a}. order x q) = (\<Sum>x\<in>roots_with P q - {a}. order x p)"
  proof (intro sum.cong refl)
    fix x assume x: "x \<in> roots_with P q - {a}"
    from assms have "order x q = order x [:a, -1:] + order x p" unfolding q_def
      by (subst order_mult[OF no_zero_divisors]) (simp_all add: assms)
    also from x have "order x [:a, -1:] = 0" by (intro order_0I) simp_all
    finally show "order x q = order x p" by simp
  qed
  also from a q_nz have "1 + order a p + (\<Sum>x\<in>roots_with P q - {a}. order x p) =
                           1 + (\<Sum>x\<in>roots_with P q. order x p)"
    by (subst add.assoc, subst sum.remove[symmetric]) simp_all
  also from q_nz have "(\<Sum>x\<in>roots_with P q. order x p) = (\<Sum>x\<in>roots_with P p. order x p)"
  proof (intro sum.mono_neutral_right)
    show "roots_with P p \<subseteq> roots_with P q"
      by (auto simp: roots_with_def q_def simp del: mult_pCons_left)
    show "\<forall>x\<in>roots_with P q - roots_with P p. order x p = 0"
      by (auto simp: roots_with_def q_def order_root simp del: mult_pCons_left)
  qed simp_all
  finally show ?thesis by (simp add: q_def count_roots_with_def)
qed

subsection \<open>Coefficient sign changes of a polynomial\<close>

abbreviation (input) "coeff_sign_changes f \<equiv> sign_changes (coeffs f)"

text \<open>
  We first show that when building a polynomial from a coefficient list, the coefficient sign
  sign changes of the resulting polynomial are the same as the same sign changes in the list.

  Note that constructing a polynomial from a list removes all trailing zeros.
\<close>
lemma sign_changes_coeff_sign_changes:
  assumes "Poly xs = (p :: 'a :: linordered_idom poly)"
  shows   "sign_changes xs = coeff_sign_changes p"
proof -
  have "coeffs p = coeffs (Poly xs)" by (subst assms) (rule refl)
  also have "\<dots> = strip_while ((=) 0) xs" by simp
  also have "filter ((\<noteq>) 0) \<dots> = filter ((\<noteq>) 0) xs" unfolding strip_while_def o_def
    by (subst rev_filter [symmetric], subst filter_dropWhile) (simp_all add: rev_filter)
  also have "sign_changes \<dots> = sign_changes xs" by (simp add: sign_changes_filter)
  finally show ?thesis by (simp add: sign_changes_filter)
qed

text \<open>
  By applying @{term "reduce_root a"}, we can assume w.l.o.g. that the root in
  question is 1, since applying root reduction does not change the number of
  sign changes.
\<close>
lemma coeff_sign_changes_reduce_root:
  assumes "a > (0 :: 'a :: linordered_idom)"
  shows   "coeff_sign_changes (reduce_root a p) = coeff_sign_changes p"
proof (intro sign_changes_cong, induction p)
  case (pCons c p)
  have "map sgn (coeffs (reduce_root a (pCons c p))) =
             cCons (sgn c) (map sgn (coeffs (reduce_root a p)))"
    using assms by (auto simp add: cCons_def sgn_0_0 sgn_mult reduce_root_pCons coeffs_smult)
  also note pCons.IH
  also have "cCons (sgn c) (map sgn (coeffs p)) = map sgn (coeffs (pCons c p))"
    using assms by (auto simp add: cCons_def sgn_0_0)
  finally show ?case .
qed (simp_all add: reduce_root_def)

text \<open>
  Multiplying a polynomial with a positive constant also does not change the number
  of sign changes. (in fact, any non-zero constant would also work, but the proof
  is slightly more difficult and positive constants suffice in our use case)
\<close>
lemma coeff_sign_changes_smult:
  assumes "a > (0 :: 'a :: linordered_idom)"
  shows   "coeff_sign_changes (smult a p) = coeff_sign_changes p"
  using assms by (auto intro!: sign_changes_cong simp: sgn_mult coeffs_smult)

context
begin

text \<open>
  We now show that a polynomial with an odd number of sign changes contains a
  positive root. We first assume that the constant coefficient is non-zero. Then it is
  clear that the polynomial's sign at 0 will be the sign of the constant coefficient, whereas
  the polynomial's sign for sufficiently large inputs will be the sign of the leading coefficient.

  Moreover, we have shown before that in a list with an odd number of sign changes and
  non-zero initial and last coefficients, the initial coefficient and the last coefficient have
  opposite and non-zero signs. Then, the polynomial obviously has a positive root.
\<close>
private lemma odd_coeff_sign_changes_imp_pos_roots_aux:
  assumes [simp]: "p \<noteq> (0 :: real poly)" "poly p 0 \<noteq> 0"
  assumes "odd (coeff_sign_changes p)"
  obtains x where "x > 0" "poly p x = 0"
proof -
  from \<open>poly p 0 \<noteq> 0\<close>
  have [simp]: "hd (coeffs p) \<noteq> 0"
    by (induct p) auto
  from assms have  "\<not> even (coeff_sign_changes p)"
    by blast
  also have "even (coeff_sign_changes p) \<longleftrightarrow> sgn (hd (coeffs p)) = sgn (lead_coeff p)"
    by (auto simp add: even_sign_changes_iff last_coeffs_eq_coeff_degree)
  finally have "sgn (hd (coeffs p)) * sgn (lead_coeff p) < 0"
    by (auto simp: sgn_if split: if_split_asm)
  also from \<open>p \<noteq> 0\<close> have "hd (coeffs p) = poly p 0" by (induction p) auto
  finally have "poly p 0 * lead_coeff p < 0" by (auto simp: mult_less_0_iff)

  from pos_root_exI[OF this] that show ?thesis by blast
qed

text \<open>
  We can now show the statement without the restriction to a non-zero constant coefficient.
  We can do this by simply factoring $p$ into the form $p \cdot x^n$, where $n$ is chosen as
  large as possible. This corresponds to stripping all initial zeros of the coefficient list,
  which obviously changes neither the existence of positive roots nor the number of coefficient
  sign changes.
\<close>
lemma odd_coeff_sign_changes_imp_pos_roots:
  assumes "p \<noteq> (0 :: real poly)"
  assumes "odd (coeff_sign_changes p)"
  obtains x where "x > 0" "poly p x = 0"
proof -
  define s where "s = sgn (lead_coeff p)"
  define n where "n = order 0 p"
  define r where "r = p div [:0, 1:] ^ n"
  have p: "p = [:0, 1:] ^ n * r" unfolding r_def n_def
    using order_1[of 0 p] by (simp del: mult_pCons_left)
  from assms p have r_nz: "r \<noteq> 0" by auto

  obtain x where "x > 0" "poly r x = 0"
  proof (rule odd_coeff_sign_changes_imp_pos_roots_aux)
    show "r \<noteq> 0" by fact
    have "order 0 p = order 0 p + order 0 r"
      by (subst p, insert order_power_n_n[of "0::real" n] r_nz)
         (simp del: mult_pCons_left add: order_mult n_def)
    hence "order 0 r = 0" by simp
    with r_nz show nz: "poly r 0 \<noteq> 0" by (simp add: order_root)

    note \<open>odd (coeff_sign_changes p)\<close>
    also have "p = [:0, 1:] ^ n * r" by (simp add: p)
    also have "[:0, 1:] ^ n = monom 1 n"
      by (induction n) (simp_all add: monom_Suc monom_0)
    also have "coeffs (monom 1 n * r) = replicate n 0 @ coeffs r"
      by (induction n) (simp_all add: monom_Suc cCons_def r_nz monom_0)
    also have "sign_changes \<dots> = coeff_sign_changes r"
      by (subst (1 2) sign_changes_filter [symmetric]) simp
    finally show "odd (coeff_sign_changes r)" .
  qed
  thus ?thesis by (intro that[of x]) (simp_all add: p)
qed

end

subsection \<open>Proof of Descartes' sign rule\<close>

text \<open>
  For a polynomial $p(X) = a_0 + \ldots + a_n X^n$, we have
  $[X^i] (1-X)p(X) = (\sum\limits_{j=0}^i a_j)$.
\<close>
lemma coeff_poly_times_one_minus_x:
  fixes g :: "'a :: linordered_idom poly"
  shows "coeff g n = (\<Sum>i\<le>n. coeff (g * [:1, -1:]) i)"
  by (induction n) simp_all

text \<open>
  We apply the previous lemma to the coefficient list of a polynomial and show:
  given a polynomial $p(X)$ and $q(X) = (1 - X)p(X)$, the coefficient list of $p(X)$ is the
  list of partial sums of the coefficient list of $q(X)$.
\<close>
lemma Poly_times_one_minus_x_eq_psums:
  fixes xs :: "'a :: linordered_idom list"
  assumes [simp]: "length xs = length ys"
  assumes "Poly xs = Poly ys * [:1, -1:]"
  shows   "ys = psums xs"
proof (rule nth_equalityI; safe?)
  fix i assume i: "i < length ys"
  hence "ys ! i = coeff (Poly ys) i"
    by (simp add: nth_default_def)
  also from coeff_poly_times_one_minus_x[of "Poly ys" i] assms
    have "\<dots> = (\<Sum>j\<le>i. coeff (Poly xs) j)" by simp
    also from i have "\<dots> = psums xs ! i"
      by (auto simp: nth_default_def psums_nth)
  finally show "ys ! i = psums xs ! i" .
qed simp_all

text \<open>
  We can now apply our main lemma on the sign changes in lists to the coefficient lists of
  a nonzero polynomial $p(X)$ and $(1-X)p(X)$: the difference of the changes in the
  coefficient lists is odd and positive.
\<close>
lemma sign_changes_poly_times_one_minus_x:
  fixes g :: "'a :: linordered_idom poly" and a :: 'a
  assumes nz: "g \<noteq> 0"
  defines "v \<equiv> coeff_sign_changes"
  shows "v ([:1, -1:] * g) - v g > 0 \<and> odd (v ([:1, -1:] * g) - v g)"
proof -
  define xs where "xs = coeffs ([:1, -1:] * g)"
  define ys where "ys = coeffs g @ [0]"
  have ys: "ys = psums xs"
  proof (rule Poly_times_one_minus_x_eq_psums)
    show "length xs = length ys" unfolding xs_def ys_def
      by (simp add: length_coeffs nz degree_mult_eq no_zero_divisors del: mult_pCons_left)
    show "Poly xs = Poly ys * [:1, - 1:]" unfolding xs_def ys_def
      by (simp only: Poly_snoc Poly_coeffs) simp
  qed
  have "sign_changes (psums xs) < sign_changes xs \<and>
        odd (sign_changes xs - sign_changes (psums xs))"
  proof (rule arthan)
    show "xs \<noteq> []"
      by (auto simp: xs_def nz simp del: mult_pCons_left)
    then show "sum_list xs = 0" by (simp add: last_psums [symmetric] ys [symmetric] ys_def)
    show "last xs \<noteq> 0"
      by (auto simp: xs_def nz last_coeffs_eq_coeff_degree simp del: mult_pCons_left)
  qed
  with ys have "sign_changes ys < sign_changes xs \<and>
                odd (sign_changes xs - sign_changes ys)" by simp
  also have "sign_changes xs = v ([:1, -1:] * g)" unfolding v_def
    by (intro sign_changes_coeff_sign_changes) (simp_all add: xs_def)
  also have "sign_changes ys = v g" unfolding v_def
    by (intro sign_changes_coeff_sign_changes) (simp_all add: ys_def Poly_snoc)
  finally show ?thesis by simp
qed

text \<open>
  We can now lift the previous lemma to the case of $p(X)$ and $(a-X)p(X)$ by substituting $X$
  with $aX$, yielding the polynomials $p(aX)$ and $a \cdot (1-X) \cdot p(aX)$.
\<close>
lemma sign_changes_poly_times_root_minus_x:
  fixes g :: "'a :: linordered_idom poly" and a :: 'a
  assumes nz: "g \<noteq> 0" and pos: "a > 0"
  defines "v \<equiv> coeff_sign_changes"
  shows "v ([:a, -1:] * g) - v g > 0 \<and> odd (v ([:a, -1:] * g) - v g)"
proof -
  have "0 < v ([:1, - 1:] * reduce_root a g) - v (reduce_root a g) \<and>
            odd (v ([:1, - 1:] * reduce_root a g) - v (reduce_root a g))"
    using nz pos unfolding v_def by (intro sign_changes_poly_times_one_minus_x) simp_all
  also have "v ([:1, -1:] * reduce_root a g) = v (smult a ([:1, -1:] * reduce_root a g))"
    unfolding v_def by (simp add: coeff_sign_changes_smult pos)
  also have "smult a ([:1, -1:] * reduce_root a g) = [:a:] * [:1, -1:] * reduce_root a g"
    by (subst mult.assoc) simp
  also have "[:a:] * [:1, -1:] = reduce_root a [:a, -1:]"
    by (simp add: reduce_root_def pcompose_pCons)
  also have "\<dots> * reduce_root a g = reduce_root a ([:a, -1:] * g)"
    unfolding reduce_root_def by (simp only: pcompose_mult)
  also have "v \<dots> = v ([:a, -1:] * g)" by (simp add: v_def coeff_sign_changes_reduce_root pos)
  also have "v (reduce_root a g) = v g" by (simp add: v_def coeff_sign_changes_reduce_root pos)
  finally show ?thesis .
qed

text \<open>
  Finally, the difference of the number of coefficient sign changes and the number of
  positive roots is non-negative and even. This follows straightforwardly by induction
  over the roots.
\<close>
lemma descartes_sign_rule_aux:
  fixes p :: "real poly"
  assumes "p \<noteq> 0"
  shows   "coeff_sign_changes p \<ge> count_pos_roots p \<and>
           even (coeff_sign_changes p - count_pos_roots p)"
using assms
proof (induction p rule: poly_root_induct[where P = "\<lambda>a. a > 0"])
  case (root a p)
  define q where "q = [:a, -1:] * p"
  from root.prems have p: "p \<noteq> 0" by auto
  with root p sign_changes_poly_times_root_minus_x[of p a]
       count_roots_with_times_root[of p "\<lambda>x. x > 0" a] show ?case by (fold q_def) fastforce
next
  case (no_roots p)
  from no_roots have "pos_roots p = {}" by (auto simp: roots_with_def)
  hence [simp]: "count_pos_roots p = 0" by (simp add: count_roots_with_def)
  thus ?case using no_roots \<open>p \<noteq> 0\<close> odd_coeff_sign_changes_imp_pos_roots[of p]
    by (auto simp: roots_with_def)
qed simp_all

text \<open>
  The main theorem is then an obvious consequence
\<close>
theorem descartes_sign_rule:
  fixes p :: "real poly"
  assumes "p \<noteq> 0"
  shows "\<exists>d. even d \<and> coeff_sign_changes p = count_pos_roots p + d"
proof
  define d where "d = coeff_sign_changes p - count_pos_roots p"
  show "even d \<and> coeff_sign_changes p = count_pos_roots p + d"
    unfolding d_def using descartes_sign_rule_aux[OF assms] by auto
qed

end


theory Palindrome
imports Main
begin
(*
  Palindromes are words that read the same backward as forward.

  Lemma: Exactly the palindromes can be constructed by the following rules
*)

inductive pal :: "'a list \<Rightarrow> bool" where
  empty: "pal []"
| single: "pal [x]"
| append: "pal xs \<Longrightarrow> pal (x#xs@[x])"

(* One direction of the proof is easy. *)
lemma pal_sound: "pal xs \<Longrightarrow> rev xs = xs" by (induction rule: pal.induct) auto

(* Let's focus on the other direction *)
lemma pal_complete:
  assumes "rev xs = xs"
  shows "pal xs"
  oops
(*
  Proof sketch

    induction on length of xs
      PREM: rev xs = xs
      IH: for all ys shorter than xs and with rev ys = ys, we have pal ys
      To show: pal xs

      If xs is empty or the singleton list, the goal follows by empty/single rule
      So assume xs = x#zs@[y].
      From PREM, we get that y=x and rev zs = zs.
      Moreover, zs is shorter than xs
      hence, by IH, we have pal zs
      and, by pal.append, we get pal (x#zs@[x])
      with the equalities form above, we have xs = x#zs@[x], and thus pal xs.
      QED

*)

lemma pal_complete:
  assumes "rev xs = xs"
  shows "pal xs"
  using assms
proof (induction xs rule: length_induct)
  case (1 xs)

  note IH="1.IH" note PREM="1.prems"

  show ?case proof (cases xs)
    case Nil
    then show ?thesis
      by (simp add: pal.empty)
  next
    case (Cons x ys)
    then show ?thesis proof (cases ys rule: rev_cases)
      case Nil
      then show ?thesis
        using Cons by (simp add: pal.single)
    next
      case (snoc zs y)
      from PREM have "y=x" "rev zs = zs"
        by (auto simp: local.Cons snoc snoc_eq_iff_butlast)
        (* Simplifier loops, used sledgehammer to find the following proof *)
        (*apply (simp add: Cons snoc)
        apply (unfold snoc) *)

      moreover have "length zs < length xs" by (simp add: Cons snoc)
      ultimately have "pal zs" using IH by blast
      hence "pal (x#zs@[x])" by (rule pal.append)
      then show ?thesis by (simp add: Cons snoc \<open>y=x\<close>)
    qed
  qed
qed

(* Same lemma, but adding simplifier setup *)

(* Adding a reasonable simplifier setup *)
lemmas [simp]  = pal.empty pal.single

lemma
  assumes "rev xs = xs"
  shows "pal xs"
  using assms
proof (induction xs rule: length_induct)
  case (1 xs)

  note IH="1.IH" note PREM="1.prems"

  show ?case proof (cases xs)
    case Nil
    then show ?thesis by simp
  next
    case [simp]: (Cons x ys) (* Adding local simp-lemma *)
    then show ?thesis proof (cases ys rule: rev_cases)
      case Nil
      then show ?thesis by (simp)
    next
      case [simp]: (snoc zs y)
      from PREM have [simp]: "y=x" and "rev zs = zs"
        (* Names and attributes apply only to their part in "and" list, i.e.,
          the above declares \<open>y=x\<close> as simp lemma, but not \<open>rev zs = zs\<close> *)
        by (auto simp: snoc_eq_iff_butlast)
      moreover have "length zs < length xs" by simp
      ultimately have "pal zs" using IH by blast
      hence "pal (x#zs@[x])" by (rule pal.append)
      then show ?thesis by simp
    qed
  qed
qed

lemma pal_correct: "pal xs \<longleftrightarrow> rev xs = xs"
  using pal_sound pal_complete by auto

end


(*  Title       : Series.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 1998  University of Cambridge

Converted to Isar and polished by lcp
Converted to setsum and polished yet more by TNN
Additional contributions by Jeremy Avigad
*)

section {* Infinite Series *}

theory Series
imports Limits
begin

subsection {* Definition of infinite summability *}

definition
  sums :: "(nat \<Rightarrow> 'a::{topological_space, comm_monoid_add}) \<Rightarrow> 'a \<Rightarrow> bool"
  (infixr "sums" 80)
where
  "f sums s \<longleftrightarrow> (\<lambda>n. \<Sum>i<n. f i) ----> s"

definition summable :: "(nat \<Rightarrow> 'a::{topological_space, comm_monoid_add}) \<Rightarrow> bool" where
   "summable f \<longleftrightarrow> (\<exists>s. f sums s)"

definition
  suminf :: "(nat \<Rightarrow> 'a::{topological_space, comm_monoid_add}) \<Rightarrow> 'a"
  (binder "\<Sum>" 10)
where
  "suminf f = (THE s. f sums s)"

subsection {* Infinite summability on topological monoids *}

lemma sums_subst[trans]: "f = g \<Longrightarrow> g sums z \<Longrightarrow> f sums z"
  by simp

lemma sums_summable: "f sums l \<Longrightarrow> summable f"
  by (simp add: sums_def summable_def, blast)

lemma summable_iff_convergent: "summable f \<longleftrightarrow> convergent (\<lambda>n. \<Sum>i<n. f i)"
  by (simp add: summable_def sums_def convergent_def)

lemma suminf_eq_lim: "suminf f = lim (\<lambda>n. \<Sum>i<n. f i)"
  by (simp add: suminf_def sums_def lim_def)

lemma sums_zero[simp, intro]: "(\<lambda>n. 0) sums 0"
  unfolding sums_def by simp

lemma summable_zero[simp, intro]: "summable (\<lambda>n. 0)"
  by (rule sums_zero [THEN sums_summable])

lemma sums_group: "f sums s \<Longrightarrow> 0 < k \<Longrightarrow> (\<lambda>n. setsum f {n * k ..< n * k + k}) sums s"
  apply (simp only: sums_def setsum_nat_group tendsto_def eventually_sequentially)
  apply safe
  apply (erule_tac x=S in allE)
  apply safe
  apply (rule_tac x="N" in exI, safe)
  apply (drule_tac x="n*k" in spec)
  apply (erule mp)
  apply (erule order_trans)
  apply simp
  done

lemma sums_finite:
  assumes [simp]: "finite N" and f: "\<And>n. n \<notin> N \<Longrightarrow> f n = 0"
  shows "f sums (\<Sum>n\<in>N. f n)"
proof -
  { fix n
    have "setsum f {..<n + Suc (Max N)} = setsum f N"
    proof cases
      assume "N = {}"
      with f have "f = (\<lambda>x. 0)" by auto
      then show ?thesis by simp
    next
      assume [simp]: "N \<noteq> {}"
      show ?thesis
      proof (safe intro!: setsum.mono_neutral_right f)
        fix i assume "i \<in> N"
        then have "i \<le> Max N" by simp
        then show "i < n + Suc (Max N)" by simp
      qed
    qed }
  note eq = this
  show ?thesis unfolding sums_def
    by (rule LIMSEQ_offset[of _ "Suc (Max N)"])
       (simp add: eq atLeast0LessThan del: add_Suc_right)
qed

lemma summable_finite: "finite N \<Longrightarrow> (\<And>n. n \<notin> N \<Longrightarrow> f n = 0) \<Longrightarrow> summable f"
  by (rule sums_summable) (rule sums_finite)

lemma sums_If_finite_set: "finite A \<Longrightarrow> (\<lambda>r. if r \<in> A then f r else 0) sums (\<Sum>r\<in>A. f r)"
  using sums_finite[of A "(\<lambda>r. if r \<in> A then f r else 0)"] by simp

lemma summable_If_finite_set[simp, intro]: "finite A \<Longrightarrow> summable (\<lambda>r. if r \<in> A then f r else 0)"
  by (rule sums_summable) (rule sums_If_finite_set)

lemma sums_If_finite: "finite {r. P r} \<Longrightarrow> (\<lambda>r. if P r then f r else 0) sums (\<Sum>r | P r. f r)"
  using sums_If_finite_set[of "{r. P r}"] by simp

lemma summable_If_finite[simp, intro]: "finite {r. P r} \<Longrightarrow> summable (\<lambda>r. if P r then f r else 0)"
  by (rule sums_summable) (rule sums_If_finite)

lemma sums_single: "(\<lambda>r. if r = i then f r else 0) sums f i"
  using sums_If_finite[of "\<lambda>r. r = i"] by simp

lemma summable_single[simp, intro]: "summable (\<lambda>r. if r = i then f r else 0)"
  by (rule sums_summable) (rule sums_single)

context
  fixes f :: "nat \<Rightarrow> 'a::{t2_space, comm_monoid_add}"
begin

lemma summable_sums[intro]: "summable f \<Longrightarrow> f sums (suminf f)"
  by (simp add: summable_def sums_def suminf_def)
     (metis convergent_LIMSEQ_iff convergent_def lim_def)

lemma summable_LIMSEQ: "summable f \<Longrightarrow> (\<lambda>n. \<Sum>i<n. f i) ----> suminf f"
  by (rule summable_sums [unfolded sums_def])

lemma sums_unique: "f sums s \<Longrightarrow> s = suminf f"
  by (metis limI suminf_eq_lim sums_def)

lemma sums_iff: "f sums x \<longleftrightarrow> summable f \<and> (suminf f = x)"
  by (metis summable_sums sums_summable sums_unique)

lemma suminf_finite:
  assumes N: "finite N" and f: "\<And>n. n \<notin> N \<Longrightarrow> f n = 0"
  shows "suminf f = (\<Sum>n\<in>N. f n)"
  using sums_finite[OF assms, THEN sums_unique] by simp

end

lemma suminf_zero[simp]: "suminf (\<lambda>n. 0::'a::{t2_space, comm_monoid_add}) = 0"
  by (rule sums_zero [THEN sums_unique, symmetric])

subsection {* Infinite summability on ordered, topological monoids *}

lemma sums_le:
  fixes f g :: "nat \<Rightarrow> 'a::{ordered_comm_monoid_add, linorder_topology}"
  shows "\<forall>n. f n \<le> g n \<Longrightarrow> f sums s \<Longrightarrow> g sums t \<Longrightarrow> s \<le> t"
  by (rule LIMSEQ_le) (auto intro: setsum_mono simp: sums_def)

context
  fixes f :: "nat \<Rightarrow> 'a::{ordered_comm_monoid_add, linorder_topology}"
begin

lemma suminf_le: "\<lbrakk>\<forall>n. f n \<le> g n; summable f; summable g\<rbrakk> \<Longrightarrow> suminf f \<le> suminf g"
  by (auto dest: sums_summable intro: sums_le)

lemma setsum_le_suminf: "summable f \<Longrightarrow> \<forall>m\<ge>n. 0 \<le> f m \<Longrightarrow> setsum f {..<n} \<le> suminf f"
  by (rule sums_le[OF _ sums_If_finite_set summable_sums]) auto

lemma suminf_nonneg: "summable f \<Longrightarrow> \<forall>n. 0 \<le> f n \<Longrightarrow> 0 \<le> suminf f"
  using setsum_le_suminf[of 0] by simp

lemma setsum_less_suminf2: "summable f \<Longrightarrow> \<forall>m\<ge>n. 0 \<le> f m \<Longrightarrow> n \<le> i \<Longrightarrow> 0 < f i \<Longrightarrow> setsum f {..<n} < suminf f"
  using
    setsum_le_suminf[of "Suc i"]
    add_strict_increasing[of "f i" "setsum f {..<n}" "setsum f {..<i}"]
    setsum_mono2[of "{..<i}" "{..<n}" f]
  by (auto simp: less_imp_le ac_simps)

lemma setsum_less_suminf: "summable f \<Longrightarrow> \<forall>m\<ge>n. 0 < f m \<Longrightarrow> setsum f {..<n} < suminf f"
  using setsum_less_suminf2[of n n] by (simp add: less_imp_le)

lemma suminf_pos2: "summable f \<Longrightarrow> \<forall>n. 0 \<le> f n \<Longrightarrow> 0 < f i \<Longrightarrow> 0 < suminf f"
  using setsum_less_suminf2[of 0 i] by simp

lemma suminf_pos: "summable f \<Longrightarrow> \<forall>n. 0 < f n \<Longrightarrow> 0 < suminf f"
  using suminf_pos2[of 0] by (simp add: less_imp_le)

lemma suminf_le_const: "summable f \<Longrightarrow> (\<And>n. setsum f {..<n} \<le> x) \<Longrightarrow> suminf f \<le> x"
  by (metis LIMSEQ_le_const2 summable_LIMSEQ)

lemma suminf_eq_zero_iff: "summable f \<Longrightarrow> \<forall>n. 0 \<le> f n \<Longrightarrow> suminf f = 0 \<longleftrightarrow> (\<forall>n. f n = 0)"
proof
  assume "summable f" "suminf f = 0" and pos: "\<forall>n. 0 \<le> f n"
  then have f: "(\<lambda>n. \<Sum>i<n. f i) ----> 0"
    using summable_LIMSEQ[of f] by simp
  then have "\<And>i. (\<Sum>n\<in>{i}. f n) \<le> 0"
  proof (rule LIMSEQ_le_const)
    fix i show "\<exists>N. \<forall>n\<ge>N. (\<Sum>n\<in>{i}. f n) \<le> setsum f {..<n}"
      using pos by (intro exI[of _ "Suc i"] allI impI setsum_mono2) auto
  qed
  with pos show "\<forall>n. f n = 0"
    by (auto intro!: antisym)
qed (metis suminf_zero fun_eq_iff)

lemma suminf_pos_iff: "summable f \<Longrightarrow> \<forall>n. 0 \<le> f n \<Longrightarrow> 0 < suminf f \<longleftrightarrow> (\<exists>i. 0 < f i)"
  using setsum_le_suminf[of 0] suminf_eq_zero_iff by (simp add: less_le)

end

lemma summableI_nonneg_bounded:
  fixes f:: "nat \<Rightarrow> 'a::{ordered_comm_monoid_add, linorder_topology, conditionally_complete_linorder}"
  assumes pos[simp]: "\<And>n. 0 \<le> f n" and le: "\<And>n. (\<Sum>i<n. f i) \<le> x"
  shows "summable f"
  unfolding summable_def sums_def[abs_def]
proof (intro exI order_tendstoI)
  have [simp, intro]: "bdd_above (range (\<lambda>n. \<Sum>i<n. f i))"
    using le by (auto simp: bdd_above_def)
  { fix a assume "a < (SUP n. \<Sum>i<n. f i)"
    then obtain n where "a < (\<Sum>i<n. f i)"
      by (auto simp add: less_cSUP_iff)
    then have "\<And>m. n \<le> m \<Longrightarrow> a < (\<Sum>i<m. f i)"
      by (rule less_le_trans) (auto intro!: setsum_mono2)
    then show "eventually (\<lambda>n. a < (\<Sum>i<n. f i)) sequentially"
      by (auto simp: eventually_sequentially) }
  { fix a assume "(SUP n. \<Sum>i<n. f i) < a"
    moreover have "\<And>n. (\<Sum>i<n. f i) \<le> (SUP n. \<Sum>i<n. f i)"
      by (auto intro: cSUP_upper)
    ultimately show "eventually (\<lambda>n. (\<Sum>i<n. f i) < a) sequentially"
      by (auto intro: le_less_trans simp: eventually_sequentially) }
qed

subsection {* Infinite summability on real normed vector spaces *}

lemma sums_Suc_iff:
  fixes f :: "nat \<Rightarrow> 'a::real_normed_vector"
  shows "(\<lambda>n. f (Suc n)) sums s \<longleftrightarrow> f sums (s + f 0)"
proof -
  have "f sums (s + f 0) \<longleftrightarrow> (\<lambda>i. \<Sum>j<Suc i. f j) ----> s + f 0"
    by (subst LIMSEQ_Suc_iff) (simp add: sums_def)
  also have "\<dots> \<longleftrightarrow> (\<lambda>i. (\<Sum>j<i. f (Suc j)) + f 0) ----> s + f 0"
    by (simp add: ac_simps setsum.reindex image_iff lessThan_Suc_eq_insert_0)
  also have "\<dots> \<longleftrightarrow> (\<lambda>n. f (Suc n)) sums s"
  proof
    assume "(\<lambda>i. (\<Sum>j<i. f (Suc j)) + f 0) ----> s + f 0"
    with tendsto_add[OF this tendsto_const, of "- f 0"]
    show "(\<lambda>i. f (Suc i)) sums s"
      by (simp add: sums_def)
  qed (auto intro: tendsto_add simp: sums_def)
  finally show ?thesis ..
qed

context
  fixes f :: "nat \<Rightarrow> 'a::real_normed_vector"
begin

lemma sums_add: "f sums a \<Longrightarrow> g sums b \<Longrightarrow> (\<lambda>n. f n + g n) sums (a + b)"
  unfolding sums_def by (simp add: setsum.distrib tendsto_add)

lemma summable_add: "summable f \<Longrightarrow> summable g \<Longrightarrow> summable (\<lambda>n. f n + g n)"
  unfolding summable_def by (auto intro: sums_add)

lemma suminf_add: "summable f \<Longrightarrow> summable g \<Longrightarrow> suminf f + suminf g = (\<Sum>n. f n + g n)"
  by (intro sums_unique sums_add summable_sums)

lemma sums_diff: "f sums a \<Longrightarrow> g sums b \<Longrightarrow> (\<lambda>n. f n - g n) sums (a - b)"
  unfolding sums_def by (simp add: setsum_subtractf tendsto_diff)

lemma summable_diff: "summable f \<Longrightarrow> summable g \<Longrightarrow> summable (\<lambda>n. f n - g n)"
  unfolding summable_def by (auto intro: sums_diff)

lemma suminf_diff: "summable f \<Longrightarrow> summable g \<Longrightarrow> suminf f - suminf g = (\<Sum>n. f n - g n)"
  by (intro sums_unique sums_diff summable_sums)

lemma sums_minus: "f sums a \<Longrightarrow> (\<lambda>n. - f n) sums (- a)"
  unfolding sums_def by (simp add: setsum_negf tendsto_minus)

lemma summable_minus: "summable f \<Longrightarrow> summable (\<lambda>n. - f n)"
  unfolding summable_def by (auto intro: sums_minus)

lemma suminf_minus: "summable f \<Longrightarrow> (\<Sum>n. - f n) = - (\<Sum>n. f n)"
  by (intro sums_unique [symmetric] sums_minus summable_sums)

lemma sums_Suc: "(\<lambda> n. f (Suc n)) sums l \<Longrightarrow> f sums (l + f 0)"
  by (simp add: sums_Suc_iff)

lemma sums_iff_shift: "(\<lambda>i. f (i + n)) sums s \<longleftrightarrow> f sums (s + (\<Sum>i<n. f i))"
proof (induct n arbitrary: s)
  case (Suc n)
  moreover have "(\<lambda>i. f (Suc i + n)) sums s \<longleftrightarrow> (\<lambda>i. f (i + n)) sums (s + f n)"
    by (subst sums_Suc_iff) simp
  ultimately show ?case
    by (simp add: ac_simps)
qed simp

lemma summable_iff_shift: "summable (\<lambda>n. f (n + k)) \<longleftrightarrow> summable f"
  by (metis diff_add_cancel summable_def sums_iff_shift[abs_def])

lemma sums_split_initial_segment: "f sums s \<Longrightarrow> (\<lambda>i. f (i + n)) sums (s - (\<Sum>i<n. f i))"
  by (simp add: sums_iff_shift)

lemma summable_ignore_initial_segment: "summable f \<Longrightarrow> summable (\<lambda>n. f(n + k))"
  by (simp add: summable_iff_shift)

lemma suminf_minus_initial_segment: "summable f \<Longrightarrow> (\<Sum>n. f (n + k)) = (\<Sum>n. f n) - (\<Sum>i<k. f i)"
  by (rule sums_unique[symmetric]) (auto simp: sums_iff_shift)

lemma suminf_split_initial_segment: "summable f \<Longrightarrow> suminf f = (\<Sum>n. f(n + k)) + (\<Sum>i<k. f i)"
  by (auto simp add: suminf_minus_initial_segment)

lemma suminf_exist_split:
  fixes r :: real assumes "0 < r" and "summable f"
  shows "\<exists>N. \<forall>n\<ge>N. norm (\<Sum>i. f (i + n)) < r"
proof -
  from LIMSEQ_D[OF summable_LIMSEQ[OF `summable f`] `0 < r`]
  obtain N :: nat where "\<forall> n \<ge> N. norm (setsum f {..<n} - suminf f) < r" by auto
  thus ?thesis
    by (auto simp: norm_minus_commute suminf_minus_initial_segment[OF `summable f`])
qed

lemma summable_LIMSEQ_zero: "summable f \<Longrightarrow> f ----> 0"
  apply (drule summable_iff_convergent [THEN iffD1])
  apply (drule convergent_Cauchy)
  apply (simp only: Cauchy_iff LIMSEQ_iff, safe)
  apply (drule_tac x="r" in spec, safe)
  apply (rule_tac x="M" in exI, safe)
  apply (drule_tac x="Suc n" in spec, simp)
  apply (drule_tac x="n" in spec, simp)
  done

end

context
  fixes f :: "'i \<Rightarrow> nat \<Rightarrow> 'a::real_normed_vector" and I :: "'i set"
begin

lemma sums_setsum: "(\<And>i. i \<in> I \<Longrightarrow> (f i) sums (x i)) \<Longrightarrow> (\<lambda>n. \<Sum>i\<in>I. f i n) sums (\<Sum>i\<in>I. x i)"
  by (induct I rule: infinite_finite_induct) (auto intro!: sums_add)

lemma suminf_setsum: "(\<And>i. i \<in> I \<Longrightarrow> summable (f i)) \<Longrightarrow> (\<Sum>n. \<Sum>i\<in>I. f i n) = (\<Sum>i\<in>I. \<Sum>n. f i n)"
  using sums_unique[OF sums_setsum, OF summable_sums] by simp

lemma summable_setsum: "(\<And>i. i \<in> I \<Longrightarrow> summable (f i)) \<Longrightarrow> summable (\<lambda>n. \<Sum>i\<in>I. f i n)"
  using sums_summable[OF sums_setsum[OF summable_sums]] .

end

lemma (in bounded_linear) sums: "(\<lambda>n. X n) sums a \<Longrightarrow> (\<lambda>n. f (X n)) sums (f a)"
  unfolding sums_def by (drule tendsto, simp only: setsum)

lemma (in bounded_linear) summable: "summable (\<lambda>n. X n) \<Longrightarrow> summable (\<lambda>n. f (X n))"
  unfolding summable_def by (auto intro: sums)

lemma (in bounded_linear) suminf: "summable (\<lambda>n. X n) \<Longrightarrow> f (\<Sum>n. X n) = (\<Sum>n. f (X n))"
  by (intro sums_unique sums summable_sums)

lemmas sums_of_real = bounded_linear.sums [OF bounded_linear_of_real]
lemmas summable_of_real = bounded_linear.summable [OF bounded_linear_of_real]
lemmas suminf_of_real = bounded_linear.suminf [OF bounded_linear_of_real]

lemmas sums_scaleR_left = bounded_linear.sums[OF bounded_linear_scaleR_left]
lemmas summable_scaleR_left = bounded_linear.summable[OF bounded_linear_scaleR_left]
lemmas suminf_scaleR_left = bounded_linear.suminf[OF bounded_linear_scaleR_left]

lemmas sums_scaleR_right = bounded_linear.sums[OF bounded_linear_scaleR_right]
lemmas summable_scaleR_right = bounded_linear.summable[OF bounded_linear_scaleR_right]
lemmas suminf_scaleR_right = bounded_linear.suminf[OF bounded_linear_scaleR_right]

subsection {* Infinite summability on real normed algebras *}

context
  fixes f :: "nat \<Rightarrow> 'a::real_normed_algebra"
begin

lemma sums_mult: "f sums a \<Longrightarrow> (\<lambda>n. c * f n) sums (c * a)"
  by (rule bounded_linear.sums [OF bounded_linear_mult_right])

lemma summable_mult: "summable f \<Longrightarrow> summable (\<lambda>n. c * f n)"
  by (rule bounded_linear.summable [OF bounded_linear_mult_right])

lemma suminf_mult: "summable f \<Longrightarrow> suminf (\<lambda>n. c * f n) = c * suminf f"
  by (rule bounded_linear.suminf [OF bounded_linear_mult_right, symmetric])

lemma sums_mult2: "f sums a \<Longrightarrow> (\<lambda>n. f n * c) sums (a * c)"
  by (rule bounded_linear.sums [OF bounded_linear_mult_left])

lemma summable_mult2: "summable f \<Longrightarrow> summable (\<lambda>n. f n * c)"
  by (rule bounded_linear.summable [OF bounded_linear_mult_left])

lemma suminf_mult2: "summable f \<Longrightarrow> suminf f * c = (\<Sum>n. f n * c)"
  by (rule bounded_linear.suminf [OF bounded_linear_mult_left])

end

subsection {* Infinite summability on real normed fields *}

context
  fixes c :: "'a::real_normed_field"
begin

lemma sums_divide: "f sums a \<Longrightarrow> (\<lambda>n. f n / c) sums (a / c)"
  by (rule bounded_linear.sums [OF bounded_linear_divide])

lemma summable_divide: "summable f \<Longrightarrow> summable (\<lambda>n. f n / c)"
  by (rule bounded_linear.summable [OF bounded_linear_divide])

lemma suminf_divide: "summable f \<Longrightarrow> suminf (\<lambda>n. f n / c) = suminf f / c"
  by (rule bounded_linear.suminf [OF bounded_linear_divide, symmetric])

text{*Sum of a geometric progression.*}

lemma geometric_sums: "norm c < 1 \<Longrightarrow> (\<lambda>n. c^n) sums (1 / (1 - c))"
proof -
  assume less_1: "norm c < 1"
  hence neq_1: "c \<noteq> 1" by auto
  hence neq_0: "c - 1 \<noteq> 0" by simp
  from less_1 have lim_0: "(\<lambda>n. c^n) ----> 0"
    by (rule LIMSEQ_power_zero)
  hence "(\<lambda>n. c ^ n / (c - 1) - 1 / (c - 1)) ----> 0 / (c - 1) - 1 / (c - 1)"
    using neq_0 by (intro tendsto_intros)
  hence "(\<lambda>n. (c ^ n - 1) / (c - 1)) ----> 1 / (1 - c)"
    by (simp add: nonzero_minus_divide_right [OF neq_0] diff_divide_distrib)
  thus "(\<lambda>n. c ^ n) sums (1 / (1 - c))"
    by (simp add: sums_def geometric_sum neq_1)
qed

lemma summable_geometric: "norm c < 1 \<Longrightarrow> summable (\<lambda>n. c^n)"
  by (rule geometric_sums [THEN sums_summable])

lemma suminf_geometric: "norm c < 1 \<Longrightarrow> suminf (\<lambda>n. c^n) = 1 / (1 - c)"
  by (rule sums_unique[symmetric]) (rule geometric_sums)

end

lemma power_half_series: "(\<lambda>n. (1/2::real)^Suc n) sums 1"
proof -
  have 2: "(\<lambda>n. (1/2::real)^n) sums 2" using geometric_sums [of "1/2::real"]
    by auto
  have "(\<lambda>n. (1/2::real)^Suc n) = (\<lambda>n. (1 / 2) ^ n / 2)"
    by simp
  thus ?thesis using sums_divide [OF 2, of 2]
    by simp
qed

subsection {* Infinite summability on Banach spaces *}

text{*Cauchy-type criterion for convergence of series (c.f. Harrison)*}

lemma summable_Cauchy:
  fixes f :: "nat \<Rightarrow> 'a::banach"
  shows "summable f \<longleftrightarrow> (\<forall>e>0. \<exists>N. \<forall>m\<ge>N. \<forall>n. norm (setsum f {m..<n}) < e)"
  apply (simp only: summable_iff_convergent Cauchy_convergent_iff [symmetric] Cauchy_iff, safe)
  apply (drule spec, drule (1) mp)
  apply (erule exE, rule_tac x="M" in exI, clarify)
  apply (rule_tac x="m" and y="n" in linorder_le_cases)
  apply (frule (1) order_trans)
  apply (drule_tac x="n" in spec, drule (1) mp)
  apply (drule_tac x="m" in spec, drule (1) mp)
  apply (simp_all add: setsum_diff [symmetric])
  apply (drule spec, drule (1) mp)
  apply (erule exE, rule_tac x="N" in exI, clarify)
  apply (rule_tac x="m" and y="n" in linorder_le_cases)
  apply (subst norm_minus_commute)
  apply (simp_all add: setsum_diff [symmetric])
  done

context
  fixes f :: "nat \<Rightarrow> 'a::banach"
begin

text{*Absolute convergence imples normal convergence*}

lemma summable_norm_cancel: "summable (\<lambda>n. norm (f n)) \<Longrightarrow> summable f"
  apply (simp only: summable_Cauchy, safe)
  apply (drule_tac x="e" in spec, safe)
  apply (rule_tac x="N" in exI, safe)
  apply (drule_tac x="m" in spec, safe)
  apply (rule order_le_less_trans [OF norm_setsum])
  apply (rule order_le_less_trans [OF abs_ge_self])
  apply simp
  done

lemma summable_norm: "summable (\<lambda>n. norm (f n)) \<Longrightarrow> norm (suminf f) \<le> (\<Sum>n. norm (f n))"
  by (auto intro: LIMSEQ_le tendsto_norm summable_norm_cancel summable_LIMSEQ norm_setsum)

text {* Comparison tests *}

lemma summable_comparison_test: "\<exists>N. \<forall>n\<ge>N. norm (f n) \<le> g n \<Longrightarrow> summable g \<Longrightarrow> summable f"
  apply (simp add: summable_Cauchy, safe)
  apply (drule_tac x="e" in spec, safe)
  apply (rule_tac x = "N + Na" in exI, safe)
  apply (rotate_tac 2)
  apply (drule_tac x = m in spec)
  apply (auto, rotate_tac 2, drule_tac x = n in spec)
  apply (rule_tac y = "\<Sum>k=m..<n. norm (f k)" in order_le_less_trans)
  apply (rule norm_setsum)
  apply (rule_tac y = "setsum g {m..<n}" in order_le_less_trans)
  apply (auto intro: setsum_mono simp add: abs_less_iff)
  done

(*A better argument order*)
lemma summable_comparison_test': "summable g \<Longrightarrow> (\<And>n. n \<ge> N \<Longrightarrow> norm(f n) \<le> g n) \<Longrightarrow> summable f"
  by (rule summable_comparison_test) auto

subsection {* The Ratio Test*}

lemma summable_ratio_test:
  assumes "c < 1" "\<And>n. n \<ge> N \<Longrightarrow> norm (f (Suc n)) \<le> c * norm (f n)"
  shows "summable f"
proof cases
  assume "0 < c"
  show "summable f"
  proof (rule summable_comparison_test)
    show "\<exists>N'. \<forall>n\<ge>N'. norm (f n) \<le> (norm (f N) / (c ^ N)) * c ^ n"
    proof (intro exI allI impI)
      fix n assume "N \<le> n" then show "norm (f n) \<le> (norm (f N) / (c ^ N)) * c ^ n"
      proof (induct rule: inc_induct)
        case (step m)
        moreover have "norm (f (Suc m)) / c ^ Suc m * c ^ n \<le> norm (f m) / c ^ m * c ^ n"
          using `0 < c` `c < 1` assms(2)[OF `N \<le> m`] by (simp add: field_simps)
        ultimately show ?case by simp
      qed (insert `0 < c`, simp)
    qed
    show "summable (\<lambda>n. norm (f N) / c ^ N * c ^ n)"
      using `0 < c` `c < 1` by (intro summable_mult summable_geometric) simp
  qed
next
  assume c: "\<not> 0 < c"
  { fix n assume "n \<ge> N"
    then have "norm (f (Suc n)) \<le> c * norm (f n)"
      by fact
    also have "\<dots> \<le> 0"
      using c by (simp add: not_less mult_nonpos_nonneg)
    finally have "f (Suc n) = 0"
      by auto }
  then show "summable f"
    by (intro sums_summable[OF sums_finite, of "{.. Suc N}"]) (auto simp: not_le Suc_less_eq2)
qed

end

text{*Relations among convergence and absolute convergence for power series.*}

lemma abel_lemma:
  fixes a :: "nat \<Rightarrow> 'a::real_normed_vector"
  assumes r: "0 \<le> r" and r0: "r < r0" and M: "\<And>n. norm (a n) * r0^n \<le> M"
    shows "summable (\<lambda>n. norm (a n) * r^n)"
proof (rule summable_comparison_test')
  show "summable (\<lambda>n. M * (r / r0) ^ n)"
    using assms
    by (auto simp add: summable_mult summable_geometric)
next
  fix n
  show "norm (norm (a n) * r ^ n) \<le> M * (r / r0) ^ n"
    using r r0 M [of n]
    apply (auto simp add: abs_mult field_simps power_divide)
    apply (cases "r=0", simp)
    apply (cases n, auto)
    done
qed

text{*Summability of geometric series for real algebras*}

lemma complete_algebra_summable_geometric:
  fixes x :: "'a::{real_normed_algebra_1,banach}"
  shows "norm x < 1 \<Longrightarrow> summable (\<lambda>n. x ^ n)"
proof (rule summable_comparison_test)
  show "\<exists>N. \<forall>n\<ge>N. norm (x ^ n) \<le> norm x ^ n"
    by (simp add: norm_power_ineq)
  show "norm x < 1 \<Longrightarrow> summable (\<lambda>n. norm x ^ n)"
    by (simp add: summable_geometric)
qed

subsection {* Cauchy Product Formula *}

text {*
  Proof based on Analysis WebNotes: Chapter 07, Class 41
  @{url "http://www.math.unl.edu/~webnotes/classes/class41/prp77.htm"}
*}

lemma setsum_triangle_reindex:
  fixes n :: nat
  shows "(\<Sum>(i,j)\<in>{(i,j). i+j < n}. f i j) = (\<Sum>k<n. \<Sum>i\<le>k. f i (k - i))"
  apply (simp add: setsum.Sigma)
  apply (rule setsum.reindex_bij_witness[where j="\<lambda>(i, j). (i+j, i)" and i="\<lambda>(k, i). (i, k - i)"])
  apply auto
  done

lemma Cauchy_product_sums:
  fixes a b :: "nat \<Rightarrow> 'a::{real_normed_algebra,banach}"
  assumes a: "summable (\<lambda>k. norm (a k))"
  assumes b: "summable (\<lambda>k. norm (b k))"
  shows "(\<lambda>k. \<Sum>i\<le>k. a i * b (k - i)) sums ((\<Sum>k. a k) * (\<Sum>k. b k))"
proof -
  let ?S1 = "\<lambda>n::nat. {..<n} \<times> {..<n}"
  let ?S2 = "\<lambda>n::nat. {(i,j). i + j < n}"
  have S1_mono: "\<And>m n. m \<le> n \<Longrightarrow> ?S1 m \<subseteq> ?S1 n" by auto
  have S2_le_S1: "\<And>n. ?S2 n \<subseteq> ?S1 n" by auto
  have S1_le_S2: "\<And>n. ?S1 (n div 2) \<subseteq> ?S2 n" by auto
  have finite_S1: "\<And>n. finite (?S1 n)" by simp
  with S2_le_S1 have finite_S2: "\<And>n. finite (?S2 n)" by (rule finite_subset)

  let ?g = "\<lambda>(i,j). a i * b j"
  let ?f = "\<lambda>(i,j). norm (a i) * norm (b j)"
  have f_nonneg: "\<And>x. 0 \<le> ?f x" by (auto)
  hence norm_setsum_f: "\<And>A. norm (setsum ?f A) = setsum ?f A"
    unfolding real_norm_def
    by (simp only: abs_of_nonneg setsum_nonneg [rule_format])

  have "(\<lambda>n. (\<Sum>k<n. a k) * (\<Sum>k<n. b k)) ----> (\<Sum>k. a k) * (\<Sum>k. b k)"
    by (intro tendsto_mult summable_LIMSEQ summable_norm_cancel [OF a] summable_norm_cancel [OF b])
  hence 1: "(\<lambda>n. setsum ?g (?S1 n)) ----> (\<Sum>k. a k) * (\<Sum>k. b k)"
    by (simp only: setsum_product setsum.Sigma [rule_format] finite_lessThan)

  have "(\<lambda>n. (\<Sum>k<n. norm (a k)) * (\<Sum>k<n. norm (b k))) ----> (\<Sum>k. norm (a k)) * (\<Sum>k. norm (b k))"
    using a b by (intro tendsto_mult summable_LIMSEQ)
  hence "(\<lambda>n. setsum ?f (?S1 n)) ----> (\<Sum>k. norm (a k)) * (\<Sum>k. norm (b k))"
    by (simp only: setsum_product setsum.Sigma [rule_format] finite_lessThan)
  hence "convergent (\<lambda>n. setsum ?f (?S1 n))"
    by (rule convergentI)
  hence Cauchy: "Cauchy (\<lambda>n. setsum ?f (?S1 n))"
    by (rule convergent_Cauchy)
  have "Zfun (\<lambda>n. setsum ?f (?S1 n - ?S2 n)) sequentially"
  proof (rule ZfunI, simp only: eventually_sequentially norm_setsum_f)
    fix r :: real
    assume r: "0 < r"
    from CauchyD [OF Cauchy r] obtain N
    where "\<forall>m\<ge>N. \<forall>n\<ge>N. norm (setsum ?f (?S1 m) - setsum ?f (?S1 n)) < r" ..
    hence "\<And>m n. \<lbrakk>N \<le> n; n \<le> m\<rbrakk> \<Longrightarrow> norm (setsum ?f (?S1 m - ?S1 n)) < r"
      by (simp only: setsum_diff finite_S1 S1_mono)
    hence N: "\<And>m n. \<lbrakk>N \<le> n; n \<le> m\<rbrakk> \<Longrightarrow> setsum ?f (?S1 m - ?S1 n) < r"
      by (simp only: norm_setsum_f)
    show "\<exists>N. \<forall>n\<ge>N. setsum ?f (?S1 n - ?S2 n) < r"
    proof (intro exI allI impI)
      fix n assume "2 * N \<le> n"
      hence n: "N \<le> n div 2" by simp
      have "setsum ?f (?S1 n - ?S2 n) \<le> setsum ?f (?S1 n - ?S1 (n div 2))"
        by (intro setsum_mono2 finite_Diff finite_S1 f_nonneg
                  Diff_mono subset_refl S1_le_S2)
      also have "\<dots> < r"
        using n div_le_dividend by (rule N)
      finally show "setsum ?f (?S1 n - ?S2 n) < r" .
    qed
  qed
  hence "Zfun (\<lambda>n. setsum ?g (?S1 n - ?S2 n)) sequentially"
    apply (rule Zfun_le [rule_format])
    apply (simp only: norm_setsum_f)
    apply (rule order_trans [OF norm_setsum setsum_mono])
    apply (auto simp add: norm_mult_ineq)
    done
  hence 2: "(\<lambda>n. setsum ?g (?S1 n) - setsum ?g (?S2 n)) ----> 0"
    unfolding tendsto_Zfun_iff diff_0_right
    by (simp only: setsum_diff finite_S1 S2_le_S1)

  with 1 have "(\<lambda>n. setsum ?g (?S2 n)) ----> (\<Sum>k. a k) * (\<Sum>k. b k)"
    by (rule LIMSEQ_diff_approach_zero2)
  thus ?thesis by (simp only: sums_def setsum_triangle_reindex)
qed

lemma Cauchy_product:
  fixes a b :: "nat \<Rightarrow> 'a::{real_normed_algebra,banach}"
  assumes a: "summable (\<lambda>k. norm (a k))"
  assumes b: "summable (\<lambda>k. norm (b k))"
  shows "(\<Sum>k. a k) * (\<Sum>k. b k) = (\<Sum>k. \<Sum>i\<le>k. a i * b (k - i))"
  using a b
  by (rule Cauchy_product_sums [THEN sums_unique])

subsection {* Series on @{typ real}s *}

lemma summable_norm_comparison_test: "\<exists>N. \<forall>n\<ge>N. norm (f n) \<le> g n \<Longrightarrow> summable g \<Longrightarrow> summable (\<lambda>n. norm (f n))"
  by (rule summable_comparison_test) auto

lemma summable_rabs_comparison_test: "\<lbrakk>\<exists>N. \<forall>n\<ge>N. \<bar>f n\<bar> \<le> g n; summable g\<rbrakk> \<Longrightarrow> summable (\<lambda>n. \<bar>f n :: real\<bar>)"
  by (rule summable_comparison_test) auto

lemma summable_rabs_cancel: "summable (\<lambda>n. \<bar>f n :: real\<bar>) \<Longrightarrow> summable f"
  by (rule summable_norm_cancel) simp

lemma summable_rabs: "summable (\<lambda>n. \<bar>f n :: real\<bar>) \<Longrightarrow> \<bar>suminf f\<bar> \<le> (\<Sum>n. \<bar>f n\<bar>)"
  by (fold real_norm_def) (rule summable_norm)

lemma summable_power_series:
  fixes z :: real
  assumes le_1: "\<And>i. f i \<le> 1" and nonneg: "\<And>i. 0 \<le> f i" and z: "0 \<le> z" "z < 1"
  shows "summable (\<lambda>i. f i * z^i)"
proof (rule summable_comparison_test[OF _ summable_geometric])
  show "norm z < 1" using z by (auto simp: less_imp_le)
  show "\<And>n. \<exists>N. \<forall>na\<ge>N. norm (f na * z ^ na) \<le> z ^ na"
    using z by (auto intro!: exI[of _ 0] mult_left_le_one_le simp: abs_mult nonneg power_abs less_imp_le le_1)
qed

lemma
   fixes f :: "nat \<Rightarrow> real"
   assumes "summable f"
   and "inj g"
   and pos: "!!x. 0 \<le> f x"
   shows summable_reindex: "summable (f o g)"
   and suminf_reindex_mono: "suminf (f o g) \<le> suminf f"
   and suminf_reindex: "(\<And>x. x \<notin> range g \<Longrightarrow> f x = 0) \<Longrightarrow> suminf (f \<circ> g) = suminf f"
proof -
  from \<open>inj g\<close> have [simp]: "\<And>A. inj_on g A" by(rule subset_inj_on) simp

  have smaller: "\<forall>n. (\<Sum>i<n. (f \<circ> g) i) \<le> suminf f"
  proof
    fix n
    have "\<forall> n' \<in> (g ` {..<n}). n' < Suc (Max (g ` {..<n}))"
      by(metis Max_ge finite_imageI finite_lessThan not_le not_less_eq)
    then obtain m where n: "\<And>n'. n' < n \<Longrightarrow> g n' < m" by blast

    have "(\<Sum>i<n. f (g i)) = setsum f (g ` {..<n})"
      by (simp add: setsum.reindex)
    also have "\<dots> \<le> (\<Sum>i<m. f i)"
      by (rule setsum_mono3) (auto simp add: pos n[rule_format])
    also have "\<dots> \<le> suminf f"
      using `summable f`
      by (rule setsum_le_suminf) (simp add: pos)
    finally show "(\<Sum>i<n. (f \<circ>  g) i) \<le> suminf f" by simp
  qed

  have "incseq (\<lambda>n. \<Sum>i<n. (f \<circ> g) i)"
    by (rule incseq_SucI) (auto simp add: pos)
  then obtain  L where L: "(\<lambda> n. \<Sum>i<n. (f \<circ> g) i) ----> L"
    using smaller by(rule incseq_convergent)
  hence "(f \<circ> g) sums L" by (simp add: sums_def)
  thus "summable (f o g)" by (auto simp add: sums_iff)

  hence "(\<lambda>n. \<Sum>i<n. (f \<circ> g) i) ----> suminf (f \<circ> g)"
    by(rule summable_LIMSEQ)
  thus le: "suminf (f \<circ> g) \<le> suminf f"
    by(rule LIMSEQ_le_const2)(blast intro: smaller[rule_format])

  assume f: "\<And>x. x \<notin> range g \<Longrightarrow> f x = 0"

  from \<open>summable f\<close> have "suminf f \<le> suminf (f \<circ> g)"
  proof(rule suminf_le_const)
    fix n
    have "\<forall> n' \<in> (g -` {..<n}). n' < Suc (Max (g -` {..<n}))"
      by(auto intro: Max_ge simp add: finite_vimageI less_Suc_eq_le)
    then obtain m where n: "\<And>n'. g n' < n \<Longrightarrow> n' < m" by blast

    have "(\<Sum>i<n. f i) = (\<Sum>i\<in>{..<n} \<inter> range g. f i)"
      using f by(auto intro: setsum.mono_neutral_cong_right)
    also have "\<dots> = (\<Sum>i\<in>g -` {..<n}. (f \<circ> g) i)"
      by(rule setsum.reindex_cong[where l=g])(auto)
    also have "\<dots> \<le> (\<Sum>i<m. (f \<circ> g) i)"
      by(rule setsum_mono3)(auto simp add: pos n)
    also have "\<dots> \<le> suminf (f \<circ> g)"
      using \<open>summable (f o g)\<close>
      by(rule setsum_le_suminf)(simp add: pos)
    finally show "setsum f {..<n} \<le> suminf (f \<circ> g)" .
  qed
  with le show "suminf (f \<circ> g) = suminf f" by(rule antisym)
qed

end


(*  Title:      Sigma_Algebra.thy

    Author:     Stefan Richter, Markus Wenzel, TU Muenchen
    License:    LGPL

Changes for Accordance to Joe Hurd's conventions
and additions by Stefan Richter 2002
*)

subsection \<open>Sigma algebras \label{sec:sigma}\<close>

theory Sigma_Algebra imports Main begin

text \<open>The $\isacommand {theory}$ command commences a formal document and enumerates the
  theories it depends on. With the \<open>Main\<close> theory, a standard
  selection of useful HOL theories excluding the real
  numbers is loaded. This theory includes and builds upon a tiny theory of the
  same name by Markus Wenzel. This theory as well as \<open>Measure\<close>
  in \ref{sec:measure-spaces} is heavily
  influenced by Joe Hurd's thesis \cite{hurd2002} and has been designed to keep the terminology as
  consistent as possible with that work.

  Sigma algebras are an elementary concept in measure
  theory. To measure --- that is to integrate --- functions, we first have
  to measure sets. Unfortunately, when dealing with a large universe,
  it is often not possible to consistently assign a measure to every
  subset. Therefore it is necessary to define the set of measurable
  subsets of the universe. A sigma algebra is such a set that has
  three very natural and desirable properties.\<close>

definition
  sigma_algebra:: "'a set set \<Rightarrow> bool" where
  "sigma_algebra A \<longleftrightarrow>
  {} \<in> A \<and> (\<forall>a. a \<in> A \<longrightarrow> -a \<in> A) \<and>
  (\<forall>a. (\<forall> i::nat. a i \<in> A) \<longrightarrow> (\<Union>i. a i) \<in> A)"

text \<open>
  The $\isacommand {definition}$ command defines new constants, which
  are just named functions in HOL. Mind that the third condition
  expresses the fact that the union of countably many sets in $A$ is
  again a set in $A$ without explicitly defining the notion of
  countability.

  Sigma algebras can naturally be created as the closure of any set of
  sets with regard to the properties just postulated. Markus Wenzel
  wrote the following
  inductive definition of the $\isa {sigma}$ operator.\<close>

inductive_set
  sigma :: "'a set set \<Rightarrow> 'a set set"
  for A :: "'a set set"
  where
    basic: "a \<in> A \<Longrightarrow> a \<in> sigma A"
  | empty: "{} \<in> sigma A"
  | complement: "a \<in> sigma A \<Longrightarrow> -a \<in> sigma A"
  | Union: "(\<And>i::nat. a i \<in> sigma A) \<Longrightarrow> (\<Union>i. a i) \<in> sigma A"

text \<open>He also proved the following basic facts. The easy proofs are omitted.
\<close>

theorem sigma_UNIV: "UNIV \<in> sigma A"
(*<*)proof -
  have "{} \<in> sigma A" by (rule sigma.empty)
  hence "-{} \<in> sigma A" by (rule sigma.complement)
  also have "-{} = UNIV" by simp
  finally show ?thesis .
qed(*>*)

theorem sigma_Inter:
  "(\<And>i::nat. a i \<in> sigma A) \<Longrightarrow> (\<Inter>i. a i) \<in> sigma A"
(*<*) proof -
  assume "\<And>i::nat. a i \<in> sigma A"
  hence "\<And>i::nat. -(a i) \<in> sigma A" by (rule sigma.complement)
  hence "(\<Union>i. -(a i)) \<in> sigma A" by (rule sigma.Union)
  hence "-(\<Union>i. -(a i)) \<in> sigma A" by (rule sigma.complement)
  also have "-(\<Union>i. -(a i)) = (\<Inter>i. a i)" by simp
  finally show ?thesis .
qed(*>*)

text \<open>It is trivial to show the connection between our first
  definitions. We use the opportunity to introduce the proof syntax.\<close>

theorem assumes sa: "sigma_algebra A"
  \<comment> \<open>Named premises are introduced like this.\<close>

  shows sigma_sigma_algebra: "sigma A = A"
proof

  txt \<open>The $\isacommand {proof}$ command alone invokes a single standard rule to
    simplify the goal. Here the following two subgoals emerge.\<close>

  show "A \<subseteq> sigma A"
    \<comment> \<open>The $\isacommand {show}$ command starts the proof of a subgoal.\<close>

    by (auto simp add: sigma.basic)

  txt \<open>This is easy enough to be solved by an automatic step,
    indicated by the keyword $\isacommand {by}$. The method $\isacommand {auto}$ is stated in parentheses, with attributes to it following.  In
    this case, the first introduction rule for the $\isacommand {sigma}$
    operator is given as an extra simplification rule.\<close>

  show "sigma A \<subseteq> A"
  proof

    txt \<open>Because this goal is not quite as trivial, another proof is
      invoked, delimiting a block as in a programming language.\<close>

    fix x
    \<comment> \<open>A new named variable is introduced.\<close>

    assume "x \<in> sigma A"

    txt \<open>An assumption is made that must be justified by the current proof
      context. In this case the corresponding fact had been generated
      by a rule automatically invoked by the inner $\isacommand {proof}$
      command.\<close>

    from this sa show "x \<in> A"

      txt \<open>Named facts can explicitly be given to the proof methods using
        $\isacommand {from}$. A special name is \<open>this\<close>, which denotes
        current facts generated by the last command. Usually $\isacommand
        {from}$ \<open>this sa\<close> --- remember that \<open>sa\<close> is an assumption from above
        --- is abbreviated to $\isacommand {with}$ \<open>sa\<close>, but in this case the order of
        facts is relevant for the following method and $\isacommand
        {with}$
        would have put the current facts last.\<close>

      by (induct rule: sigma.induct) (auto simp add: sigma_algebra_def)

    txt \<open>Two methods may be carried out at $\isacommand {by}$. The first
      one applies induction here via the canonical rule generated by the
      inductive definition above, while the latter solves the
      resulting subgoals by an automatic step involving
      simplification.\<close>

  qed
qed

text "These two steps finish their respective proofs, checking
  that all subgoals have been proven."

text \<open>To end this theory we prove a special case of the \<open>sigma_Inter\<close> theorem above. It seems trivial that
  the fact holds for two sets as well as for countably many.
  We get a first taste of the cost of formal reasoning here, however. The
  idea must be made precise by exhibiting a concrete sequence of
  sets.\<close>

primrec trivial_series:: "'a set \<Rightarrow> 'a set \<Rightarrow> (nat \<Rightarrow> 'a set)"
where
  "trivial_series a b 0 = a"
| "trivial_series a b (Suc n) = b"

text \<open>Using $\isacommand {primrec}$, primitive recursive functions over
  inductively defined data types --- the natural numbers in this case ---
  may be constructed.\<close>

theorem assumes s: "sigma_algebra A" and a: "a \<in> A" and b: "b \<in> A"
  shows sigma_algebra_inter: "a \<inter> b \<in> A"
proof -
    \<comment> \<open>This form of $\isacommand {proof}$ foregoes the application of a rule.\<close>

  have "a \<inter> b = (\<Inter>i::nat. trivial_series a b i)"

    txt \<open>Intermediate facts that do not solve any subgoals yet are established this way.\<close>

  proof (rule set_eqI)

    txt \<open>The  $\isacommand {proof}$ command may also take one explicit method
      as an argument like the single rule application in this instance.\<close>

    fix x

    {
      fix i
      assume "x \<in> a \<inter> b"
      hence "x \<in> trivial_series a b i" by (cases i) auto
        \<comment> \<open>This is just an abbreviation for $\isacommand {"from this have"}$.\<close>
    }

    txt \<open>Curly braces can be used to explicitly delimit
      blocks. In conjunction with $\isacommand {fix}$, universal
      quantification over the fixed variable $i$ is achieved
      for the last statement in the block, which is exported to the
      enclosing block.\<close>

    hence "x \<in> a \<inter> b \<Longrightarrow> \<forall>i. x \<in> trivial_series a b i"
      by fast
    also

    txt \<open>The statement $\isacommand {also}$ introduces calculational
      reasoning. This basically amounts to collecting facts. With
      $\isacommand {also}$, the current fact is added to a special list of
      theorems called the calculation and
      an automatically selected transitivity rule
      is additionally applied from the second collected fact on.\<close>

    { assume "\<And>i. x \<in> trivial_series a b i"
      hence "x \<in> trivial_series a b 0" and "x \<in> trivial_series a b 1"
        by this+
      hence "x \<in> a \<inter> b"
        by simp
    }
    hence "\<forall>i. x \<in> trivial_series a b i \<Longrightarrow> x \<in> a \<inter> b"
      by blast

    ultimately have "x \<in> a \<inter> b = (\<forall>i::nat. x \<in> trivial_series a b i)" ..

    txt \<open>The accumulated calculational facts including the current one
      are exposed to the next statement by  $\isacommand {ultimately}$ and
      the calculation list is then erased. The two dots after the
      statement here indicate proof by a single automatically
      selected rule.\<close>

    also have "\<dots> =  (x \<in> (\<Inter>i::nat. trivial_series a b i))"
      by simp
    finally show "x \<in> a \<inter> b = (x \<in> (\<Inter>i::nat. trivial_series a b i))" .

    txt \<open>The $\isacommand {finally}$ directive behaves like $\isacommand {ultimately}$
      with the addition of a further transitivity rule application. A
      single dot stands for proof by assumption.\<close>

  qed

  moreover have "(\<Inter>i::nat. trivial_series a b i) \<in> A"
  proof -
    { fix i
      from a b have "trivial_series a b i \<in> A"
        by (cases i) auto
    }
    hence "\<And>i. trivial_series a b i \<in> sigma A"
      by (simp only: sigma.basic)
    hence "(\<Inter>i::nat. trivial_series a b i) \<in> sigma A"
      by (simp only: sigma_Inter)
    with s show ?thesis
      by (simp only: sigma_sigma_algebra)
  qed

  ultimately show ?thesis by simp
qed

text \<open>Of course, a like theorem holds for union instead of
  intersection.  But as we will not need it in what follows, the
  theory is finished with the following easy properties instead.
  Note that the former is a kind of generalization of the last result and
  could be used to  shorten its proof. Unfortunately, this one was needed ---
  and therefore found --- only late in the development.
\<close>

theorem sigma_INTER:
  assumes a:"(\<And>i::nat. i \<in> S \<Longrightarrow> a i \<in> sigma A)"
  shows "(\<Inter>i\<in>S. a i) \<in> sigma A"(*<*)
proof -
  from a have "\<And>i. (if i\<in>S then {} else UNIV) \<union> a i \<in> sigma A"
    by (simp add: sigma.intros sigma_UNIV)
  hence "(\<Inter>i. (if i\<in>S then {} else UNIV) \<union> a i) \<in> sigma A"
    by (rule sigma_Inter)
  also have "(\<Inter>i. (if i\<in>S then {} else UNIV) \<union> a i) = (\<Inter>i\<in>S. a i)"
    by force
  finally show ?thesis .
qed(*>*)

lemma assumes s: "sigma_algebra a" shows sigma_algebra_UNIV: "UNIV \<in> a"(*<*)
proof -
  from s have "{}\<in>a" by (unfold sigma_algebra_def) blast
  with s show ?thesis by (unfold sigma_algebra_def) auto
qed(*>*)

end


(*  Title:      HOL/ex/Set_Theory.thy
    Author:     Tobias Nipkow and Lawrence C Paulson
    Copyright   1991  University of Cambridge
*)

section \<open>Set Theory examples: Cantor's Theorem, Schröder-Bernstein Theorem, etc.\<close>

theory Set_Theory
imports Main
begin

text\<open>
  These two are cited in Benzmueller and Kohlhase's system description
  of LEO, CADE-15, 1998 (pages 139-143) as theorems LEO could not
  prove.
\<close>

lemma "(X = Y \<union> Z) =
    (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
  by blast

lemma "(X = Y \<inter> Z) =
    (X \<subseteq> Y \<and> X \<subseteq> Z \<and> (\<forall>V. V \<subseteq> Y \<and> V \<subseteq> Z \<longrightarrow> V \<subseteq> X))"
  by blast

text \<open>
  Trivial example of term synthesis: apparently hard for some provers!
\<close>

schematic_goal "a \<noteq> b \<Longrightarrow> a \<in> ?X \<and> b \<notin> ?X"
  by blast

subsection \<open>Examples for the \<open>blast\<close> paper\<close>

lemma "(\<Union>x \<in> C. f x \<union> g x) = \<Union>(f ` C)  \<union>  \<Union>(g ` C)"
  \<comment> \<open>Union-image, called \<open>Un_Union_image\<close> in Main HOL\<close>
  by blast

lemma "(\<Inter>x \<in> C. f x \<inter> g x) = \<Inter>(f ` C) \<inter> \<Inter>(g ` C)"
  \<comment> \<open>Inter-image, called \<open>Int_Inter_image\<close> in Main HOL\<close>
  by blast

lemma singleton_example_1:
     "\<And>S::'a set set. \<forall>x \<in> S. \<forall>y \<in> S. x \<subseteq> y \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  by blast

lemma singleton_example_2:
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  \<comment> \<open>Variant of the problem above.\<close>
  by blast

lemma "\<exists>!x. f (g x) = x \<Longrightarrow> \<exists>!y. g (f y) = y"
  \<comment> \<open>A unique fixpoint theorem --- \<open>fast\<close>/\<open>best\<close>/\<open>meson\<close> all fail.\<close>
  by metis

subsection \<open>Cantor's Theorem: There is no surjection from a set to its powerset\<close>

lemma cantor1: "\<not> (\<exists>f:: 'a \<Rightarrow> 'a set. \<forall>S. \<exists>x. f x = S)"
  \<comment> \<open>Requires best-first search because it is undirectional.\<close>
  by best

schematic_goal "\<forall>f:: 'a \<Rightarrow> 'a set. \<forall>x. f x \<noteq> ?S f"
  \<comment> \<open>This form displays the diagonal term.\<close>
  by best

schematic_goal "?S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  \<comment> \<open>This form exploits the set constructs.\<close>
  by (rule notI, erule rangeE, best)

schematic_goal "?S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  \<comment> \<open>Or just this!\<close>
  by best

subsection \<open>The Schröder-Bernstein Theorem\<close>

lemma disj_lemma: "- (f ` X) = g' ` (-X) \<Longrightarrow> f a = g' b \<Longrightarrow> a \<in> X \<Longrightarrow> b \<in> X"
  by blast

lemma surj_if_then_else:
  "-(f ` X) = g' ` (-X) \<Longrightarrow> surj (\<lambda>z. if z \<in> X then f z else g' z)"
  by (simp add: surj_def) blast

lemma bij_if_then_else:
  "inj_on f X \<Longrightarrow> inj_on g' (-X) \<Longrightarrow> -(f ` X) = g' ` (-X) \<Longrightarrow>
    h = (\<lambda>z. if z \<in> X then f z else g' z) \<Longrightarrow> inj h \<and> surj h"
  apply (unfold inj_on_def)
  apply (simp add: surj_if_then_else)
  apply (blast dest: disj_lemma sym)
  done

lemma decomposition: "\<exists>X. X = - (g ` (- (f ` X)))"
  apply (rule exI)
  apply (rule lfp_unfold)
  apply (rule monoI, blast)
  done

theorem Schroeder_Bernstein:
  "inj (f :: 'a \<Rightarrow> 'b) \<Longrightarrow> inj (g :: 'b \<Rightarrow> 'a)
    \<Longrightarrow> \<exists>h:: 'a \<Rightarrow> 'b. inj h \<and> surj h"
  apply (rule decomposition [where f=f and g=g, THEN exE])
  apply (rule_tac x = "(\<lambda>z. if z \<in> x then f z else inv g z)" in exI)
    \<comment> \<open>The term above can be synthesized by a sufficiently detailed proof.\<close>
  apply (rule bij_if_then_else)
     apply (rule_tac [4] refl)
    apply (rule_tac [2] inj_on_inv_into)
    apply (erule subset_inj_on [OF _ subset_UNIV])
   apply blast
  apply (erule ssubst, subst double_complement, erule image_inv_f_f [symmetric])
  done

subsection \<open>A simple party theorem\<close>

text\<open>\emph{At any party there are two people who know the same
number of people}. Provided the party consists of at least two people
and the knows relation is symmetric. Knowing yourself does not count
--- otherwise knows needs to be reflexive. (From Freek Wiedijk's talk
at TPHOLs 2007.)\<close>

lemma equal_number_of_acquaintances:
assumes "Domain R <= A" and "sym R" and "card A \<ge> 2"
shows "\<not> inj_on (%a. card(R `` {a} - {a})) A"
proof -
  let ?N = "%a. card(R `` {a} - {a})"
  let ?n = "card A"
  have "finite A" using \<open>card A \<ge> 2\<close> by(auto intro:ccontr)
  have 0: "R `` A <= A" using \<open>sym R\<close> \<open>Domain R <= A\<close>
    unfolding Domain_unfold sym_def by blast
  have h: "\<forall>a\<in>A. R `` {a} <= A" using 0 by blast
  hence 1: "\<forall>a\<in>A. finite(R `` {a})" using \<open>finite A\<close>
    by(blast intro: finite_subset)
  have sub: "?N ` A <= {0..<?n}"
  proof -
    have "\<forall>a\<in>A. R `` {a} - {a} < A" using h by blast
    thus ?thesis using psubset_card_mono[OF \<open>finite A\<close>] by auto
  qed
  show "~ inj_on ?N A" (is "~ ?I")
  proof
    assume ?I
    hence "?n = card(?N ` A)" by(rule card_image[symmetric])
    with sub \<open>finite A\<close> have 2[simp]: "?N ` A = {0..<?n}"
      using subset_card_intvl_is_intvl[of _ 0] by(auto)
    have "0 \<in> ?N ` A" and "?n - 1 \<in> ?N ` A"  using \<open>card A \<ge> 2\<close> by simp+
    then obtain a b where ab: "a\<in>A" "b\<in>A" and Na: "?N a = 0" and Nb: "?N b = ?n - 1"
      by (auto simp del: 2)
    have "a \<noteq> b" using Na Nb \<open>card A \<ge> 2\<close> by auto
    have "R `` {a} - {a} = {}" by (metis 1 Na ab card_eq_0_iff finite_Diff)
    hence "b \<notin> R `` {a}" using \<open>a\<noteq>b\<close> by blast
    hence "a \<notin> R `` {b}" by (metis Image_singleton_iff assms(2) sym_def)
    hence 3: "R `` {b} - {b} <= A - {a,b}" using 0 ab by blast
    have 4: "finite (A - {a,b})" using \<open>finite A\<close> by simp
    have "?N b <= ?n - 2" using ab \<open>a\<noteq>b\<close> \<open>finite A\<close> card_mono[OF 4 3] by simp
    then show False using Nb \<open>card A \<ge>  2\<close> by arith
  qed
qed

text \<open>
  From W. W. Bledsoe and Guohui Feng, SET-VAR. JAR 11 (3), 1993, pages
  293-314.

  Isabelle can prove the easy examples without any special mechanisms,
  but it can't prove the hard ones.
\<close>

lemma "\<exists>A. (\<forall>x \<in> A. x \<le> (0::int))"
  \<comment> \<open>Example 1, page 295.\<close>
  by force

lemma "D \<in> F \<Longrightarrow> \<exists>G. \<forall>A \<in> G. \<exists>B \<in> F. A \<subseteq> B"
  \<comment> \<open>Example 2.\<close>
  by force

lemma "P a \<Longrightarrow> \<exists>A. (\<forall>x \<in> A. P x) \<and> (\<exists>y. y \<in> A)"
  \<comment> \<open>Example 3.\<close>
  by force

lemma "a < b \<and> b < (c::int) \<Longrightarrow> \<exists>A. a \<notin> A \<and> b \<in> A \<and> c \<notin> A"
  \<comment> \<open>Example 4.\<close>
  by auto \<comment> \<open>slow\<close>

lemma "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
  \<comment> \<open>Example 5, page 298.\<close>
  by force

lemma "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
  \<comment> \<open>Example 6.\<close>
  by force

lemma "\<exists>A. a \<notin> A"
  \<comment> \<open>Example 7.\<close>
  by force

lemma "(\<forall>u v. u < (0::int) \<longrightarrow> u \<noteq> \<bar>v\<bar>)
    \<longrightarrow> (\<exists>A::int set. -2 \<in> A & (\<forall>y. \<bar>y\<bar> \<notin> A))"
  \<comment> \<open>Example 8 needs a small hint.\<close>
  by force
    \<comment> \<open>not \<open>blast\<close>, which can't simplify \<open>-2 < 0\<close>\<close>

text \<open>Example 9 omitted (requires the reals).\<close>

text \<open>The paper has no Example 10!\<close>

lemma "(\<forall>A. 0 \<in> A \<and> (\<forall>x \<in> A. Suc x \<in> A) \<longrightarrow> n \<in> A) \<and>
  P 0 \<and> (\<forall>x. P x \<longrightarrow> P (Suc x)) \<longrightarrow> P n"
  \<comment> \<open>Example 11: needs a hint.\<close>
by(metis nat.induct)

lemma
  "(\<forall>A. (0, 0) \<in> A \<and> (\<forall>x y. (x, y) \<in> A \<longrightarrow> (Suc x, Suc y) \<in> A) \<longrightarrow> (n, m) \<in> A)
    \<and> P n \<longrightarrow> P m"
  \<comment> \<open>Example 12.\<close>
  by auto

lemma
  "(\<forall>x. (\<exists>u. x = 2 * u) = (\<not> (\<exists>v. Suc x = 2 * v))) \<longrightarrow>
    (\<exists>A. \<forall>x. (x \<in> A) = (Suc x \<notin> A))"
  \<comment> \<open>Example EO1: typo in article, and with the obvious fix it seems
      to require arithmetic reasoning.\<close>
  apply clarify
  apply (rule_tac x = "{x. \<exists>u. x = 2 * u}" in exI, auto)
   apply metis+
  done

end