diff --git a/src/HOL/Analysis/Ball_Volume.thy b/src/HOL/Analysis/Ball_Volume.thy
--- a/src/HOL/Analysis/Ball_Volume.thy
+++ b/src/HOL/Analysis/Ball_Volume.thy
@@ -1,333 +1,330 @@
-(*  
+(*
    File:     HOL/Analysis/Ball_Volume.thy
    Author:   Manuel Eberl, TU München
 *)
 
 section \<open>The Volume of an \<open>n\<close>-Dimensional Ball\<close>
 
 theory Ball_Volume
   imports Gamma_Function Lebesgue_Integral_Substitution
 begin
 
 text \<open>
   We define the volume of the unit ball in terms of the Gamma function. Note that the
   dimension need not be an integer; we also allow fractional dimensions, although we do
   not use this case or prove anything about it for now.
 \<close>
 definition\<^marker>\<open>tag important\<close> unit_ball_vol :: "real \<Rightarrow> real" where
   "unit_ball_vol n = pi powr (n / 2) / Gamma (n / 2 + 1)"
 
 lemma unit_ball_vol_pos [simp]: "n \<ge> 0 \<Longrightarrow> unit_ball_vol n > 0"
   by (force simp: unit_ball_vol_def intro: divide_nonneg_pos)
 
 lemma unit_ball_vol_nonneg [simp]: "n \<ge> 0 \<Longrightarrow> unit_ball_vol n \<ge> 0"
   by (simp add: dual_order.strict_implies_order)
 
 text \<open>
   We first need the value of the following integral, which is at the core of
-  computing the measure of an \<open>n + 1\<close>-dimensional ball in terms of the measure of an 
+  computing the measure of an \<open>n + 1\<close>-dimensional ball in terms of the measure of an
   \<open>n\<close>-dimensional one.
 \<close>
 lemma emeasure_cball_aux_integral:
-  "(\<integral>\<^sup>+x. indicator {-1..1} x * sqrt (1 - x\<^sup>2) ^ n \<partial>lborel) = 
+  "(\<integral>\<^sup>+x. indicator {-1..1} x * sqrt (1 - x\<^sup>2) ^ n \<partial>lborel) =
       ennreal (Beta (1 / 2) (real n / 2 + 1))"
 proof -
   have "((\<lambda>t. t powr (-1 / 2) * (1 - t) powr (real n / 2)) has_integral
           Beta (1 / 2) (real n / 2 + 1)) {0..1}"
     using has_integral_Beta_real[of "1/2" "n / 2 + 1"] by simp
   from nn_integral_has_integral_lebesgue[OF _ this] have
      "ennreal (Beta (1 / 2) (real n / 2 + 1)) =
-        nn_integral lborel (\<lambda>t. ennreal (t powr (-1 / 2) * (1 - t) powr (real n / 2) * 
+        nn_integral lborel (\<lambda>t. ennreal (t powr (-1 / 2) * (1 - t) powr (real n / 2) *
                                 indicator {0^2..1^2} t))"
     by (simp add: mult_ac ennreal_mult' ennreal_indicator)
   also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (x\<^sup>2 powr - (1 / 2) * (1 - x\<^sup>2) powr (real n / 2) * (2 * x) *
                           indicator {0..1} x) \<partial>lborel)"
     by (subst nn_integral_substitution[where g = "\<lambda>x. x ^ 2" and g' = "\<lambda>x. 2 * x"])
        (auto intro!: derivative_eq_intros continuous_intros simp: set_borel_measurable_def)
   also have "\<dots> = (\<integral>\<^sup>+ x. 2 * ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {0..1} x) \<partial>lborel)"
-    by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"]) 
+    by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"])
        (auto simp: indicator_def powr_minus powr_half_sqrt field_split_simps ennreal_mult')
   also have "\<dots> = (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {0..1} x) \<partial>lborel) +
                     (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {0..1} x) \<partial>lborel)"
     (is "_ = ?I + _") by (simp add: mult_2 nn_integral_add)
   also have "?I = (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {-1..0} x) \<partial>lborel)"
     by (subst nn_integral_real_affine[of _ "-1" 0])
        (auto simp: indicator_def intro!: nn_integral_cong)
   hence "?I + ?I = \<dots> + ?I" by simp
-  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) * 
+  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) *
                     (indicator {-1..0} x + indicator{0..1} x)) \<partial>lborel)"
     by (subst nn_integral_add [symmetric]) (auto simp: algebra_simps)
   also have "\<dots> = (\<integral>\<^sup>+ x. ennreal ((1 - x\<^sup>2) powr (real n / 2) * indicator {-1..1} x) \<partial>lborel)"
     by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"]) (auto simp: indicator_def)
   also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (indicator {-1..1} x * sqrt (1 - x\<^sup>2) ^ n) \<partial>lborel)"
     by (intro nn_integral_cong_AE AE_I[of _ _ "{1, -1}"])
        (auto simp: powr_half_sqrt [symmetric] indicator_def abs_square_le_1
           abs_square_eq_1 powr_def exp_of_nat_mult [symmetric] emeasure_lborel_countable)
   finally show ?thesis ..
 qed
 
 lemma real_sqrt_le_iff': "x \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> sqrt x \<le> y \<longleftrightarrow> x \<le> y ^ 2"
   using real_le_lsqrt sqrt_le_D by blast
 
-lemma power2_le_iff_abs_le: "y \<ge> 0 \<Longrightarrow> (x::real) ^ 2 \<le> y ^ 2 \<longleftrightarrow> abs x \<le> y"
-  by (subst real_sqrt_le_iff' [symmetric]) auto
-
 text \<open>
-  Isabelle's type system makes it very difficult to do an induction over the dimension 
-  of a Euclidean space type, because the type would change in the inductive step. To avoid 
-  this problem, we instead formulate the problem in a more concrete way by unfolding the 
+  Isabelle's type system makes it very difficult to do an induction over the dimension
+  of a Euclidean space type, because the type would change in the inductive step. To avoid
+  this problem, we instead formulate the problem in a more concrete way by unfolding the
   definition of the Euclidean norm.
 \<close>
 lemma emeasure_cball_aux:
   assumes "finite A" "r > 0"
   shows   "emeasure (Pi\<^sub>M A (\<lambda>_. lborel))
              ({f. sqrt (\<Sum>i\<in>A. (f i)\<^sup>2) \<le> r} \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))) =
              ennreal (unit_ball_vol (real (card A)) * r ^ card A)"
   using assms
 proof (induction arbitrary: r)
   case (empty r)
   thus ?case
     by (simp add: unit_ball_vol_def space_PiM)
 next
   case (insert i A r)
   interpret product_sigma_finite "\<lambda>_. lborel"
     by standard
-  have "emeasure (Pi\<^sub>M (insert i A) (\<lambda>_. lborel)) 
+  have "emeasure (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))
             ({f. sqrt (\<Sum>i\<in>insert i A. (f i)\<^sup>2) \<le> r} \<inter> space (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))) =
         nn_integral (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))
           (indicator ({f. sqrt (\<Sum>i\<in>insert i A. (f i)\<^sup>2) \<le> r} \<inter>
           space (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))))"
     by (subst nn_integral_indicator) auto
-  also have "\<dots> = (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. indicator ({f. sqrt ((f i)\<^sup>2 + (\<Sum>i\<in>A. (f i)\<^sup>2)) \<le> r} \<inter> 
-                                space (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))) (x(i := y)) 
+  also have "\<dots> = (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. indicator ({f. sqrt ((f i)\<^sup>2 + (\<Sum>i\<in>A. (f i)\<^sup>2)) \<le> r} \<inter>
+                                space (Pi\<^sub>M (insert i A) (\<lambda>_. lborel))) (x(i := y))
                    \<partial>Pi\<^sub>M A (\<lambda>_. lborel) \<partial>lborel)"
     using insert.prems insert.hyps by (subst product_nn_integral_insert_rev) auto
-  also have "\<dots> = (\<integral>\<^sup>+ (y::real). \<integral>\<^sup>+ x. indicator {-r..r} y * indicator ({f. sqrt ((\<Sum>i\<in>A. (f i)\<^sup>2)) \<le> 
+  also have "\<dots> = (\<integral>\<^sup>+ (y::real). \<integral>\<^sup>+ x. indicator {-r..r} y * indicator ({f. sqrt ((\<Sum>i\<in>A. (f i)\<^sup>2)) \<le>
                sqrt (r ^ 2 - y ^ 2)} \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))) x \<partial>Pi\<^sub>M A (\<lambda>_. lborel) \<partial>lborel)"
   proof (intro nn_integral_cong, goal_cases)
     case (1 y f)
     have *: "y \<in> {-r..r}" if "y ^ 2 + c \<le> r ^ 2" "c \<ge> 0" for c
     proof -
       have "y ^ 2 \<le> y ^ 2 + c" using that by simp
       also have "\<dots> \<le> r ^ 2" by fact
       finally show ?thesis
         using \<open>r > 0\<close> by (simp add: power2_le_iff_abs_le abs_if split: if_splits)
     qed
     have "(\<Sum>x\<in>A. (if x = i then y else f x)\<^sup>2) = (\<Sum>x\<in>A. (f x)\<^sup>2)"
       using insert.hyps by (intro sum.cong) auto
     thus ?case using 1 \<open>r > 0\<close>
       by (auto simp: sum_nonneg real_sqrt_le_iff' indicator_def PiE_def space_PiM dest!: *)
   qed
-  also have "\<dots> = (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * (\<integral>\<^sup>+ x. indicator ({f. sqrt ((\<Sum>i\<in>A. (f i)\<^sup>2)) 
+  also have "\<dots> = (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * (\<integral>\<^sup>+ x. indicator ({f. sqrt ((\<Sum>i\<in>A. (f i)\<^sup>2))
                                    \<le> sqrt (r ^ 2 - y ^ 2)} \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))) x
                   \<partial>Pi\<^sub>M A (\<lambda>_. lborel)) \<partial>lborel)" by (subst nn_integral_cmult) auto
-  also have "\<dots> = (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * emeasure (PiM A (\<lambda>_. lborel)) 
+  also have "\<dots> = (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * emeasure (PiM A (\<lambda>_. lborel))
       ({f. sqrt ((\<Sum>i\<in>A. (f i)\<^sup>2)) \<le> sqrt (r ^ 2 - y ^ 2)} \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))) \<partial>lborel)"
     using \<open>finite A\<close> by (intro nn_integral_cong, subst nn_integral_indicator) auto
-  also have "\<dots> = (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * ennreal (unit_ball_vol (real (card A)) * 
+  also have "\<dots> = (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * ennreal (unit_ball_vol (real (card A)) *
                                   (sqrt (r ^ 2 - y ^ 2)) ^ card A) \<partial>lborel)"
   proof (intro nn_integral_cong_AE, goal_cases)
     case 1
     have "AE y in lborel. y \<notin> {-r,r}"
       by (intro AE_not_in countable_imp_null_set_lborel) auto
     thus ?case
     proof eventually_elim
       case (elim y)
       show ?case
       proof (cases "y \<in> {-r<..<r}")
         case True
         hence "y\<^sup>2 < r\<^sup>2" by (subst real_sqrt_less_iff [symmetric]) auto
         thus ?thesis by (subst insert.IH) (auto)
       qed (insert elim, auto)
     qed
   qed
-  also have "\<dots> = ennreal (unit_ball_vol (real (card A))) * 
+  also have "\<dots> = ennreal (unit_ball_vol (real (card A))) *
                     (\<integral>\<^sup>+ (y::real). indicator {-r..r} y * (sqrt (r ^ 2 - y ^ 2)) ^ card A \<partial>lborel)"
     by (subst nn_integral_cmult [symmetric])
        (auto simp: mult_ac ennreal_mult' [symmetric] indicator_def intro!: nn_integral_cong)
   also have "(\<integral>\<^sup>+ (y::real). indicator {-r..r} y * (sqrt (r ^ 2 - y ^ 2)) ^ card A \<partial>lborel) =
-               (\<integral>\<^sup>+ (y::real). r ^ card A * indicator {-1..1} y * (sqrt (1 - y ^ 2)) ^ card A  
+               (\<integral>\<^sup>+ (y::real). r ^ card A * indicator {-1..1} y * (sqrt (1 - y ^ 2)) ^ card A
                \<partial>(distr lborel borel ((*) (1/r))))" using \<open>r > 0\<close>
     by (subst nn_integral_distr)
        (auto simp: indicator_def field_simps real_sqrt_divide intro!: nn_integral_cong)
-  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (r ^ Suc (card A)) * 
+  also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (r ^ Suc (card A)) *
                (indicator {- 1..1} x * sqrt (1 - x\<^sup>2) ^ card A) \<partial>lborel)" using \<open>r > 0\<close>
     by (subst lborel_distr_mult) (auto simp: nn_integral_density ennreal_mult' [symmetric] mult_ac)
-  also have "\<dots> = ennreal (r ^ Suc (card A)) * (\<integral>\<^sup>+ x. indicator {- 1..1} x * 
+  also have "\<dots> = ennreal (r ^ Suc (card A)) * (\<integral>\<^sup>+ x. indicator {- 1..1} x *
                     sqrt (1 - x\<^sup>2) ^ card A \<partial>lborel)"
     by (subst nn_integral_cmult) auto
   also note emeasure_cball_aux_integral
   also have "ennreal (unit_ball_vol (real (card A))) * (ennreal (r ^ Suc (card A)) *
-                 ennreal (Beta (1/2) (card A / 2 + 1))) = 
+                 ennreal (Beta (1/2) (card A / 2 + 1))) =
                ennreal (unit_ball_vol (card A) * Beta (1/2) (card A / 2 + 1) * r ^ Suc (card A))"
     using \<open>r > 0\<close> by (simp add: ennreal_mult' [symmetric] mult_ac)
   also have "unit_ball_vol (card A) * Beta (1/2) (card A / 2 + 1) = unit_ball_vol (Suc (card A))"
-    by (auto simp: unit_ball_vol_def Beta_def Gamma_eq_zero_iff field_simps 
+    by (auto simp: unit_ball_vol_def Beta_def Gamma_eq_zero_iff field_simps
           Gamma_one_half_real powr_half_sqrt [symmetric] powr_add [symmetric])
   also have "Suc (card A) = card (insert i A)" using insert.hyps by simp
   finally show ?case .
 qed
 
 
 text \<open>
   We now get the main theorem very easily by just applying the above lemma.
 \<close>
 context
   fixes c :: "'a :: euclidean_space" and r :: real
   assumes r: "r \<ge> 0"
 begin
 
 theorem\<^marker>\<open>tag unimportant\<close> emeasure_cball:
   "emeasure lborel (cball c r) = ennreal (unit_ball_vol (DIM('a)) * r ^ DIM('a))"
 proof (cases "r = 0")
   case False
   with r have r: "r > 0" by simp
-  have "(lborel :: 'a measure) = 
+  have "(lborel :: 'a measure) =
           distr (Pi\<^sub>M Basis (\<lambda>_. lborel)) borel (\<lambda>f. \<Sum>b\<in>Basis. f b *\<^sub>R b)"
     by (rule lborel_eq)
-  also have "emeasure \<dots> (cball 0 r) = 
-               emeasure (Pi\<^sub>M Basis (\<lambda>_. lborel)) 
+  also have "emeasure \<dots> (cball 0 r) =
+               emeasure (Pi\<^sub>M Basis (\<lambda>_. lborel))
                ({y. dist 0 (\<Sum>b\<in>Basis. y b *\<^sub>R b :: 'a) \<le> r} \<inter> space (Pi\<^sub>M Basis (\<lambda>_. lborel)))"
     by (subst emeasure_distr) (auto simp: cball_def)
   also have "{f. dist 0 (\<Sum>b\<in>Basis. f b *\<^sub>R b :: 'a) \<le> r} = {f. sqrt (\<Sum>i\<in>Basis. (f i)\<^sup>2) \<le> r}"
     by (subst euclidean_dist_l2) (auto simp: L2_set_def)
   also have "emeasure (Pi\<^sub>M Basis (\<lambda>_. lborel)) (\<dots> \<inter> space (Pi\<^sub>M Basis (\<lambda>_. lborel))) =
                ennreal (unit_ball_vol (real DIM('a)) * r ^ DIM('a))"
     using r by (subst emeasure_cball_aux) simp_all
   also have "emeasure lborel (cball 0 r :: 'a set) =
                emeasure (distr lborel borel (\<lambda>x. c + x)) (cball c r)"
     by (subst emeasure_distr) (auto simp: cball_def dist_norm norm_minus_commute)
   also have "distr lborel borel (\<lambda>x. c + x) = lborel"
     using lborel_affine[of 1 c] by (simp add: density_1)
   finally show ?thesis .
 qed auto
 
 corollary\<^marker>\<open>tag unimportant\<close> content_cball:
   "content (cball c r) = unit_ball_vol (DIM('a)) * r ^ DIM('a)"
   by (simp add: measure_def emeasure_cball r)
 
 corollary\<^marker>\<open>tag unimportant\<close> emeasure_ball:
   "emeasure lborel (ball c r) = ennreal (unit_ball_vol (DIM('a)) * r ^ DIM('a))"
 proof -
   from negligible_sphere[of c r] have "sphere c r \<in> null_sets lborel"
     by (auto simp: null_sets_completion_iff negligible_iff_null_sets negligible_convex_frontier)
   hence "emeasure lborel (ball c r \<union> sphere c r :: 'a set) = emeasure lborel (ball c r :: 'a set)"
     by (intro emeasure_Un_null_set) auto
   also have "ball c r \<union> sphere c r = (cball c r :: 'a set)" by auto
   also have "emeasure lborel \<dots> = ennreal (unit_ball_vol (real DIM('a)) * r ^ DIM('a))"
     by (rule emeasure_cball)
   finally show ?thesis ..
 qed
 
 corollary\<^marker>\<open>tag important\<close> content_ball:
   "content (ball c r) = unit_ball_vol (DIM('a)) * r ^ DIM('a)"
   by (simp add: measure_def r emeasure_ball)
 
 end
 
 
 text \<open>
-  Lastly, we now prove some nicer explicit formulas for the volume of the unit balls in 
+  Lastly, we now prove some nicer explicit formulas for the volume of the unit balls in
   the cases of even and odd integer dimensions.
 \<close>
 lemma unit_ball_vol_even:
   "unit_ball_vol (real (2 * n)) = pi ^ n / fact n"
   by (simp add: unit_ball_vol_def add_ac powr_realpow Gamma_fact)
 
 lemma unit_ball_vol_odd':
         "unit_ball_vol (real (2 * n + 1)) = pi ^ n / pochhammer (1 / 2) (Suc n)"
   and unit_ball_vol_odd:
         "unit_ball_vol (real (2 * n + 1)) =
            (2 ^ (2 * Suc n) * fact (Suc n)) / fact (2 * Suc n) * pi ^ n"
 proof -
-  have "unit_ball_vol (real (2 * n + 1)) = 
+  have "unit_ball_vol (real (2 * n + 1)) =
           pi powr (real n + 1 / 2) / Gamma (1 / 2 + real (Suc n))"
     by (simp add: unit_ball_vol_def field_simps)
   also have "pochhammer (1 / 2) (Suc n) = Gamma (1 / 2 + real (Suc n)) / Gamma (1 / 2)"
     by (intro pochhammer_Gamma) auto
   hence "Gamma (1 / 2 + real (Suc n)) = sqrt pi * pochhammer (1 / 2) (Suc n)"
     by (simp add: Gamma_one_half_real)
   also have "pi powr (real n + 1 / 2) / \<dots> = pi ^ n / pochhammer (1 / 2) (Suc n)"
     by (simp add: powr_add powr_half_sqrt powr_realpow)
   finally show "unit_ball_vol (real (2 * n + 1)) = \<dots>" .
-  also have "pochhammer (1 / 2 :: real) (Suc n) = 
+  also have "pochhammer (1 / 2 :: real) (Suc n) =
                fact (2 * Suc n) / (2 ^ (2 * Suc n) * fact (Suc n))"
     using fact_double[of "Suc n", where ?'a = real] by (simp add: divide_simps mult_ac)
   also have "pi ^n / \<dots> = (2 ^ (2 * Suc n) * fact (Suc n)) / fact (2 * Suc n) * pi ^ n"
     by simp
   finally show "unit_ball_vol (real (2 * n + 1)) = \<dots>" .
 qed
 
 lemma unit_ball_vol_numeral:
   "unit_ball_vol (numeral (Num.Bit0 n)) = pi ^ numeral n / fact (numeral n)" (is ?th1)
   "unit_ball_vol (numeral (Num.Bit1 n)) = 2 ^ (2 * Suc (numeral n)) * fact (Suc (numeral n)) /
     fact (2 * Suc (numeral n)) * pi ^ numeral n" (is ?th2)
 proof -
-  have "numeral (Num.Bit0 n) = (2 * numeral n :: nat)" 
+  have "numeral (Num.Bit0 n) = (2 * numeral n :: nat)"
     by (simp only: numeral_Bit0 mult_2 ring_distribs)
   also have "unit_ball_vol \<dots> = pi ^ numeral n / fact (numeral n)"
     by (rule unit_ball_vol_even)
   finally show ?th1 by simp
 next
   have "numeral (Num.Bit1 n) = (2 * numeral n + 1 :: nat)"
     by (simp only: numeral_Bit1 mult_2)
   also have "unit_ball_vol \<dots> = 2 ^ (2 * Suc (numeral n)) * fact (Suc (numeral n)) /
                                   fact (2 * Suc (numeral n)) * pi ^ numeral n"
     by (rule unit_ball_vol_odd)
   finally show ?th2 by simp
 qed
 
 lemmas eval_unit_ball_vol = unit_ball_vol_numeral fact_numeral
 
 
 text \<open>
   Just for fun, we compute the volume of unit balls for a few dimensions.
 \<close>
 lemma unit_ball_vol_0 [simp]: "unit_ball_vol 0 = 1"
   using unit_ball_vol_even[of 0] by simp
 
 lemma unit_ball_vol_1 [simp]: "unit_ball_vol 1 = 2"
   using unit_ball_vol_odd[of 0] by simp
 
 corollary\<^marker>\<open>tag unimportant\<close>
           unit_ball_vol_2: "unit_ball_vol 2 = pi"
       and unit_ball_vol_3: "unit_ball_vol 3 = 4 / 3 * pi"
       and unit_ball_vol_4: "unit_ball_vol 4 = pi\<^sup>2 / 2"
       and unit_ball_vol_5: "unit_ball_vol 5 = 8 / 15 * pi\<^sup>2"
   by (simp_all add: eval_unit_ball_vol)
 
 corollary\<^marker>\<open>tag unimportant\<close> circle_area:
   "r \<ge> 0 \<Longrightarrow> content (ball c r :: (real ^ 2) set) = r ^ 2 * pi"
   by (simp add: content_ball unit_ball_vol_2)
 
 corollary\<^marker>\<open>tag unimportant\<close> sphere_volume:
   "r \<ge> 0 \<Longrightarrow> content (ball c r :: (real ^ 3) set) = 4 / 3 * r ^ 3 * pi"
   by (simp add: content_ball unit_ball_vol_3)
 
 text \<open>
   Useful equivalent forms
 \<close>
 corollary\<^marker>\<open>tag unimportant\<close> content_ball_eq_0_iff [simp]: "content (ball c r) = 0 \<longleftrightarrow> r \<le> 0"
 proof -
   have "r > 0 \<Longrightarrow> content (ball c r) > 0"
     by (simp add: content_ball unit_ball_vol_def)
   then show ?thesis
     by (fastforce simp: ball_empty)
 qed
 
 corollary\<^marker>\<open>tag unimportant\<close> content_ball_gt_0_iff [simp]: "0 < content (ball z r) \<longleftrightarrow> 0 < r"
   by (auto simp: zero_less_measure_iff)
 
 corollary\<^marker>\<open>tag unimportant\<close> content_cball_eq_0_iff [simp]: "content (cball c r) = 0 \<longleftrightarrow> r \<le> 0"
 proof (cases "r = 0")
   case False
   moreover have "r > 0 \<Longrightarrow> content (cball c r) > 0"
     by (simp add: content_cball unit_ball_vol_def)
   ultimately show ?thesis
     by fastforce
 qed auto
 
 corollary\<^marker>\<open>tag unimportant\<close> content_cball_gt_0_iff [simp]: "0 < content (cball z r) \<longleftrightarrow> 0 < r"
   by (auto simp: zero_less_measure_iff)
 
 end
diff --git a/src/HOL/Finite_Set.thy b/src/HOL/Finite_Set.thy
--- a/src/HOL/Finite_Set.thy
+++ b/src/HOL/Finite_Set.thy
@@ -1,2538 +1,2549 @@
 (*  Title:      HOL/Finite_Set.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
     Author:     Jeremy Avigad
     Author:     Andrei Popescu
 *)
 
 section \<open>Finite sets\<close>
 
 theory Finite_Set
   imports Product_Type Sum_Type Fields
 begin
 
 subsection \<open>Predicate for finite sets\<close>
 
 context notes [[inductive_internals]]
 begin
 
 inductive finite :: "'a set \<Rightarrow> bool"
   where
     emptyI [simp, intro!]: "finite {}"
   | insertI [simp, intro!]: "finite A \<Longrightarrow> finite (insert a A)"
 
 end
 
 simproc_setup finite_Collect ("finite (Collect P)") = \<open>K Set_Comprehension_Pointfree.simproc\<close>
 
 declare [[simproc del: finite_Collect]]
 
 lemma finite_induct [case_names empty insert, induct set: finite]:
   \<comment> \<open>Discharging \<open>x \<notin> F\<close> entails extra work.\<close>
   assumes "finite F"
   assumes "P {}"
     and insert: "\<And>x F. finite F \<Longrightarrow> x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)"
   shows "P F"
   using \<open>finite F\<close>
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume F: "finite F" and P: "P F"
   show "P (insert x F)"
   proof cases
     assume "x \<in> F"
     then have "insert x F = F" by (rule insert_absorb)
     with P show ?thesis by (simp only:)
   next
     assume "x \<notin> F"
     from F this P show ?thesis by (rule insert)
   qed
 qed
 
 lemma infinite_finite_induct [case_names infinite empty insert]:
   assumes infinite: "\<And>A. \<not> finite A \<Longrightarrow> P A"
     and empty: "P {}"
     and insert: "\<And>x F. finite F \<Longrightarrow> x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)"
   shows "P A"
 proof (cases "finite A")
   case False
   with infinite show ?thesis .
 next
   case True
   then show ?thesis by (induct A) (fact empty insert)+
 qed
 
 
 subsubsection \<open>Choice principles\<close>
 
 lemma ex_new_if_finite: \<comment> \<open>does not depend on def of finite at all\<close>
   assumes "\<not> finite (UNIV :: 'a set)" and "finite A"
   shows "\<exists>a::'a. a \<notin> A"
 proof -
   from assms have "A \<noteq> UNIV" by blast
   then show ?thesis by blast
 qed
 
 text \<open>A finite choice principle. Does not need the SOME choice operator.\<close>
 
 lemma finite_set_choice: "finite A \<Longrightarrow> \<forall>x\<in>A. \<exists>y. P x y \<Longrightarrow> \<exists>f. \<forall>x\<in>A. P x (f x)"
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert a A)
   then obtain f b where f: "\<forall>x\<in>A. P x (f x)" and ab: "P a b"
     by auto
   show ?case (is "\<exists>f. ?P f")
   proof
     show "?P (\<lambda>x. if x = a then b else f x)"
       using f ab by auto
   qed
 qed
 
 
 subsubsection \<open>Finite sets are the images of initial segments of natural numbers\<close>
 
 lemma finite_imp_nat_seg_image_inj_on:
   assumes "finite A"
   shows "\<exists>(n::nat) f. A = f ` {i. i < n} \<and> inj_on f {i. i < n}"
   using assms
 proof induct
   case empty
   show ?case
   proof
     show "\<exists>f. {} = f ` {i::nat. i < 0} \<and> inj_on f {i. i < 0}"
       by simp
   qed
 next
   case (insert a A)
   have notinA: "a \<notin> A" by fact
   from insert.hyps obtain n f where "A = f ` {i::nat. i < n}" "inj_on f {i. i < n}"
     by blast
   then have "insert a A = f(n:=a) ` {i. i < Suc n}" and "inj_on (f(n:=a)) {i. i < Suc n}"
     using notinA by (auto simp add: image_def Ball_def inj_on_def less_Suc_eq)
   then show ?case by blast
 qed
 
 lemma nat_seg_image_imp_finite: "A = f ` {i::nat. i < n} \<Longrightarrow> finite A"
 proof (induct n arbitrary: A)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   let ?B = "f ` {i. i < n}"
   have finB: "finite ?B" by (rule Suc.hyps[OF refl])
   show ?case
   proof (cases "\<exists>k<n. f n = f k")
     case True
     then have "A = ?B"
       using Suc.prems by (auto simp:less_Suc_eq)
     then show ?thesis
       using finB by simp
   next
     case False
     then have "A = insert (f n) ?B"
       using Suc.prems by (auto simp:less_Suc_eq)
     then show ?thesis using finB by simp
   qed
 qed
 
 lemma finite_conv_nat_seg_image: "finite A \<longleftrightarrow> (\<exists>n f. A = f ` {i::nat. i < n})"
   by (blast intro: nat_seg_image_imp_finite dest: finite_imp_nat_seg_image_inj_on)
 
 lemma finite_imp_inj_to_nat_seg:
   assumes "finite A"
   shows "\<exists>f n. f ` A = {i::nat. i < n} \<and> inj_on f A"
 proof -
   from finite_imp_nat_seg_image_inj_on [OF \<open>finite A\<close>]
   obtain f and n :: nat where bij: "bij_betw f {i. i<n} A"
     by (auto simp: bij_betw_def)
   let ?f = "the_inv_into {i. i<n} f"
   have "inj_on ?f A \<and> ?f ` A = {i. i<n}"
     by (fold bij_betw_def) (rule bij_betw_the_inv_into[OF bij])
   then show ?thesis by blast
 qed
 
 lemma finite_Collect_less_nat [iff]: "finite {n::nat. n < k}"
   by (fastforce simp: finite_conv_nat_seg_image)
 
 lemma finite_Collect_le_nat [iff]: "finite {n::nat. n \<le> k}"
   by (simp add: le_eq_less_or_eq Collect_disj_eq)
 
 
 subsection \<open>Finiteness and common set operations\<close>
 
 lemma rev_finite_subset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> finite A"
 proof (induct arbitrary: A rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F A)
   have A: "A \<subseteq> insert x F" and r: "A - {x} \<subseteq> F \<Longrightarrow> finite (A - {x})"
     by fact+
   show "finite A"
   proof cases
     assume x: "x \<in> A"
     with A have "A - {x} \<subseteq> F" by (simp add: subset_insert_iff)
     with r have "finite (A - {x})" .
     then have "finite (insert x (A - {x}))" ..
     also have "insert x (A - {x}) = A"
       using x by (rule insert_Diff)
     finally show ?thesis .
   next
     show ?thesis when "A \<subseteq> F"
       using that by fact
     assume "x \<notin> A"
     with A show "A \<subseteq> F"
       by (simp add: subset_insert_iff)
   qed
 qed
 
 lemma finite_subset: "A \<subseteq> B \<Longrightarrow> finite B \<Longrightarrow> finite A"
   by (rule rev_finite_subset)
 
 lemma finite_UnI:
   assumes "finite F" and "finite G"
   shows "finite (F \<union> G)"
   using assms by induct simp_all
 
 lemma finite_Un [iff]: "finite (F \<union> G) \<longleftrightarrow> finite F \<and> finite G"
   by (blast intro: finite_UnI finite_subset [of _ "F \<union> G"])
 
 lemma finite_insert [simp]: "finite (insert a A) \<longleftrightarrow> finite A"
 proof -
   have "finite {a} \<and> finite A \<longleftrightarrow> finite A" by simp
   then have "finite ({a} \<union> A) \<longleftrightarrow> finite A" by (simp only: finite_Un)
   then show ?thesis by simp
 qed
 
 lemma finite_Int [simp, intro]: "finite F \<or> finite G \<Longrightarrow> finite (F \<inter> G)"
   by (blast intro: finite_subset)
 
 lemma finite_Collect_conjI [simp, intro]:
   "finite {x. P x} \<or> finite {x. Q x} \<Longrightarrow> finite {x. P x \<and> Q x}"
   by (simp add: Collect_conj_eq)
 
 lemma finite_Collect_disjI [simp]:
   "finite {x. P x \<or> Q x} \<longleftrightarrow> finite {x. P x} \<and> finite {x. Q x}"
   by (simp add: Collect_disj_eq)
 
 lemma finite_Diff [simp, intro]: "finite A \<Longrightarrow> finite (A - B)"
   by (rule finite_subset, rule Diff_subset)
 
 lemma finite_Diff2 [simp]:
   assumes "finite B"
   shows "finite (A - B) \<longleftrightarrow> finite A"
 proof -
   have "finite A \<longleftrightarrow> finite ((A - B) \<union> (A \<inter> B))"
     by (simp add: Un_Diff_Int)
   also have "\<dots> \<longleftrightarrow> finite (A - B)"
     using \<open>finite B\<close> by simp
   finally show ?thesis ..
 qed
 
 lemma finite_Diff_insert [iff]: "finite (A - insert a B) \<longleftrightarrow> finite (A - B)"
 proof -
   have "finite (A - B) \<longleftrightarrow> finite (A - B - {a})" by simp
   moreover have "A - insert a B = A - B - {a}" by auto
   ultimately show ?thesis by simp
 qed
 
 lemma finite_compl [simp]:
   "finite (A :: 'a set) \<Longrightarrow> finite (- A) \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp add: Compl_eq_Diff_UNIV)
 
 lemma finite_Collect_not [simp]:
   "finite {x :: 'a. P x} \<Longrightarrow> finite {x. \<not> P x} \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp add: Collect_neg_eq)
 
 lemma finite_Union [simp, intro]:
   "finite A \<Longrightarrow> (\<And>M. M \<in> A \<Longrightarrow> finite M) \<Longrightarrow> finite (\<Union>A)"
   by (induct rule: finite_induct) simp_all
 
 lemma finite_UN_I [intro]:
   "finite A \<Longrightarrow> (\<And>a. a \<in> A \<Longrightarrow> finite (B a)) \<Longrightarrow> finite (\<Union>a\<in>A. B a)"
   by (induct rule: finite_induct) simp_all
 
 lemma finite_UN [simp]: "finite A \<Longrightarrow> finite (\<Union>(B ` A)) \<longleftrightarrow> (\<forall>x\<in>A. finite (B x))"
   by (blast intro: finite_subset)
 
 lemma finite_Inter [intro]: "\<exists>A\<in>M. finite A \<Longrightarrow> finite (\<Inter>M)"
   by (blast intro: Inter_lower finite_subset)
 
 lemma finite_INT [intro]: "\<exists>x\<in>I. finite (A x) \<Longrightarrow> finite (\<Inter>x\<in>I. A x)"
   by (blast intro: INT_lower finite_subset)
 
 lemma finite_imageI [simp, intro]: "finite F \<Longrightarrow> finite (h ` F)"
   by (induct rule: finite_induct) simp_all
 
 lemma finite_image_set [simp]: "finite {x. P x} \<Longrightarrow> finite {f x |x. P x}"
   by (simp add: image_Collect [symmetric])
 
 lemma finite_image_set2:
   "finite {x. P x} \<Longrightarrow> finite {y. Q y} \<Longrightarrow> finite {f x y |x y. P x \<and> Q y}"
   by (rule finite_subset [where B = "\<Union>x \<in> {x. P x}. \<Union>y \<in> {y. Q y}. {f x y}"]) auto
 
 lemma finite_imageD:
   assumes "finite (f ` A)" and "inj_on f A"
   shows "finite A"
   using assms
 proof (induct "f ` A" arbitrary: A)
   case empty
   then show ?case by simp
 next
   case (insert x B)
   then have B_A: "insert x B = f ` A"
     by simp
   then obtain y where "x = f y" and "y \<in> A"
     by blast
   from B_A \<open>x \<notin> B\<close> have "B = f ` A - {x}"
     by blast
   with B_A \<open>x \<notin> B\<close> \<open>x = f y\<close> \<open>inj_on f A\<close> \<open>y \<in> A\<close> have "B = f ` (A - {y})"
     by (simp add: inj_on_image_set_diff)
   moreover from \<open>inj_on f A\<close> have "inj_on f (A - {y})"
     by (rule inj_on_diff)
   ultimately have "finite (A - {y})"
     by (rule insert.hyps)
   then show "finite A"
     by simp
 qed
 
 lemma finite_image_iff: "inj_on f A \<Longrightarrow> finite (f ` A) \<longleftrightarrow> finite A"
   using finite_imageD by blast
 
 lemma finite_surj: "finite A \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> finite B"
   by (erule finite_subset) (rule finite_imageI)
 
 lemma finite_range_imageI: "finite (range g) \<Longrightarrow> finite (range (\<lambda>x. f (g x)))"
   by (drule finite_imageI) (simp add: range_composition)
 
 lemma finite_subset_image:
   assumes "finite B"
   shows "B \<subseteq> f ` A \<Longrightarrow> \<exists>C\<subseteq>A. finite C \<and> B = f ` C"
   using assms
 proof induct
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case
     by (clarsimp simp del: image_insert simp add: image_insert [symmetric]) blast
 qed
 
 lemma all_subset_image: "(\<forall>B. B \<subseteq> f ` A \<longrightarrow> P B) \<longleftrightarrow> (\<forall>B. B \<subseteq> A \<longrightarrow> P(f ` B))"
   by (safe elim!: subset_imageE) (use image_mono in \<open>blast+\<close>) (* slow *)
 
 lemma all_finite_subset_image:
   "(\<forall>B. finite B \<and> B \<subseteq> f ` A \<longrightarrow> P B) \<longleftrightarrow> (\<forall>B. finite B \<and> B \<subseteq> A \<longrightarrow> P (f ` B))"
 proof safe
   fix B :: "'a set"
   assume B: "finite B" "B \<subseteq> f ` A" and P: "\<forall>B. finite B \<and> B \<subseteq> A \<longrightarrow> P (f ` B)"
   show "P B"
     using finite_subset_image [OF B] P by blast
 qed blast
 
 lemma ex_finite_subset_image:
   "(\<exists>B. finite B \<and> B \<subseteq> f ` A \<and> P B) \<longleftrightarrow> (\<exists>B. finite B \<and> B \<subseteq> A \<and> P (f ` B))"
 proof safe
   fix B :: "'a set"
   assume B: "finite B" "B \<subseteq> f ` A" and "P B"
   show "\<exists>B. finite B \<and> B \<subseteq> A \<and> P (f ` B)"
     using finite_subset_image [OF B] \<open>P B\<close> by blast
 qed blast
 
 lemma finite_vimage_IntI: "finite F \<Longrightarrow> inj_on h A \<Longrightarrow> finite (h -` F \<inter> A)"
 proof (induct rule: finite_induct)
   case (insert x F)
   then show ?case
     by (simp add: vimage_insert [of h x F] finite_subset [OF inj_on_vimage_singleton] Int_Un_distrib2)
 qed simp
 
 lemma finite_finite_vimage_IntI:
   assumes "finite F"
     and "\<And>y. y \<in> F \<Longrightarrow> finite ((h -` {y}) \<inter> A)"
   shows "finite (h -` F \<inter> A)"
 proof -
   have *: "h -` F \<inter> A = (\<Union> y\<in>F. (h -` {y}) \<inter> A)"
     by blast
   show ?thesis
     by (simp only: * assms finite_UN_I)
 qed
 
 lemma finite_vimageI: "finite F \<Longrightarrow> inj h \<Longrightarrow> finite (h -` F)"
   using finite_vimage_IntI[of F h UNIV] by auto
 
 lemma finite_vimageD': "finite (f -` A) \<Longrightarrow> A \<subseteq> range f \<Longrightarrow> finite A"
   by (auto simp add: subset_image_iff intro: finite_subset[rotated])
 
 lemma finite_vimageD: "finite (h -` F) \<Longrightarrow> surj h \<Longrightarrow> finite F"
   by (auto dest: finite_vimageD')
 
 lemma finite_vimage_iff: "bij h \<Longrightarrow> finite (h -` F) \<longleftrightarrow> finite F"
   unfolding bij_def by (auto elim: finite_vimageD finite_vimageI)
 
+lemma finite_inverse_image_gen:
+  assumes "finite A" "inj_on f D"
+  shows "finite {j\<in>D. f j \<in> A}"
+  using finite_vimage_IntI [OF assms]
+  by (simp add: Collect_conj_eq inf_commute vimage_def)
+
+lemma finite_inverse_image:
+  assumes "finite A" "inj f"
+  shows "finite {j. f j \<in> A}"
+  using finite_inverse_image_gen [OF assms] by simp
+
 lemma finite_Collect_bex [simp]:
   assumes "finite A"
   shows "finite {x. \<exists>y\<in>A. Q x y} \<longleftrightarrow> (\<forall>y\<in>A. finite {x. Q x y})"
 proof -
   have "{x. \<exists>y\<in>A. Q x y} = (\<Union>y\<in>A. {x. Q x y})" by auto
   with assms show ?thesis by simp
 qed
 
 lemma finite_Collect_bounded_ex [simp]:
   assumes "finite {y. P y}"
   shows "finite {x. \<exists>y. P y \<and> Q x y} \<longleftrightarrow> (\<forall>y. P y \<longrightarrow> finite {x. Q x y})"
 proof -
   have "{x. \<exists>y. P y \<and> Q x y} = (\<Union>y\<in>{y. P y}. {x. Q x y})"
     by auto
   with assms show ?thesis
     by simp
 qed
 
 lemma finite_Plus: "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A <+> B)"
   by (simp add: Plus_def)
 
 lemma finite_PlusD:
   fixes A :: "'a set" and B :: "'b set"
   assumes fin: "finite (A <+> B)"
   shows "finite A" "finite B"
 proof -
   have "Inl ` A \<subseteq> A <+> B"
     by auto
   then have "finite (Inl ` A :: ('a + 'b) set)"
     using fin by (rule finite_subset)
   then show "finite A"
     by (rule finite_imageD) (auto intro: inj_onI)
 next
   have "Inr ` B \<subseteq> A <+> B"
     by auto
   then have "finite (Inr ` B :: ('a + 'b) set)"
     using fin by (rule finite_subset)
   then show "finite B"
     by (rule finite_imageD) (auto intro: inj_onI)
 qed
 
 lemma finite_Plus_iff [simp]: "finite (A <+> B) \<longleftrightarrow> finite A \<and> finite B"
   by (auto intro: finite_PlusD finite_Plus)
 
 lemma finite_Plus_UNIV_iff [simp]:
   "finite (UNIV :: ('a + 'b) set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
   by (subst UNIV_Plus_UNIV [symmetric]) (rule finite_Plus_iff)
 
 lemma finite_SigmaI [simp, intro]:
   "finite A \<Longrightarrow> (\<And>a. a\<in>A \<Longrightarrow> finite (B a)) \<Longrightarrow> finite (SIGMA a:A. B a)"
   unfolding Sigma_def by blast
 
 lemma finite_SigmaI2:
   assumes "finite {x\<in>A. B x \<noteq> {}}"
   and "\<And>a. a \<in> A \<Longrightarrow> finite (B a)"
   shows "finite (Sigma A B)"
 proof -
   from assms have "finite (Sigma {x\<in>A. B x \<noteq> {}} B)"
     by auto
   also have "Sigma {x:A. B x \<noteq> {}} B = Sigma A B"
     by auto
   finally show ?thesis .
 qed
 
 lemma finite_cartesian_product: "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A \<times> B)"
   by (rule finite_SigmaI)
 
 lemma finite_Prod_UNIV:
   "finite (UNIV :: 'a set) \<Longrightarrow> finite (UNIV :: 'b set) \<Longrightarrow> finite (UNIV :: ('a \<times> 'b) set)"
   by (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product)
 
 lemma finite_cartesian_productD1:
   assumes "finite (A \<times> B)" and "B \<noteq> {}"
   shows "finite A"
 proof -
   from assms obtain n f where "A \<times> B = f ` {i::nat. i < n}"
     by (auto simp add: finite_conv_nat_seg_image)
   then have "fst ` (A \<times> B) = fst ` f ` {i::nat. i < n}"
     by simp
   with \<open>B \<noteq> {}\<close> have "A = (fst \<circ> f) ` {i::nat. i < n}"
     by (simp add: image_comp)
   then have "\<exists>n f. A = f ` {i::nat. i < n}"
     by blast
   then show ?thesis
     by (auto simp add: finite_conv_nat_seg_image)
 qed
 
 lemma finite_cartesian_productD2:
   assumes "finite (A \<times> B)" and "A \<noteq> {}"
   shows "finite B"
 proof -
   from assms obtain n f where "A \<times> B = f ` {i::nat. i < n}"
     by (auto simp add: finite_conv_nat_seg_image)
   then have "snd ` (A \<times> B) = snd ` f ` {i::nat. i < n}"
     by simp
   with \<open>A \<noteq> {}\<close> have "B = (snd \<circ> f) ` {i::nat. i < n}"
     by (simp add: image_comp)
   then have "\<exists>n f. B = f ` {i::nat. i < n}"
     by blast
   then show ?thesis
     by (auto simp add: finite_conv_nat_seg_image)
 qed
 
 lemma finite_cartesian_product_iff:
   "finite (A \<times> B) \<longleftrightarrow> (A = {} \<or> B = {} \<or> (finite A \<and> finite B))"
   by (auto dest: finite_cartesian_productD1 finite_cartesian_productD2 finite_cartesian_product)
 
 lemma finite_prod:
   "finite (UNIV :: ('a \<times> 'b) set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
   using finite_cartesian_product_iff[of UNIV UNIV] by simp
 
 lemma finite_Pow_iff [iff]: "finite (Pow A) \<longleftrightarrow> finite A"
 proof
   assume "finite (Pow A)"
   then have "finite ((\<lambda>x. {x}) ` A)"
     by (blast intro: finite_subset)  (* somewhat slow *)
   then show "finite A"
     by (rule finite_imageD [unfolded inj_on_def]) simp
 next
   assume "finite A"
   then show "finite (Pow A)"
     by induct (simp_all add: Pow_insert)
 qed
 
 corollary finite_Collect_subsets [simp, intro]: "finite A \<Longrightarrow> finite {B. B \<subseteq> A}"
   by (simp add: Pow_def [symmetric])
 
 lemma finite_set: "finite (UNIV :: 'a set set) \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp only: finite_Pow_iff Pow_UNIV[symmetric])
 
 lemma finite_UnionD: "finite (\<Union>A) \<Longrightarrow> finite A"
   by (blast intro: finite_subset [OF subset_Pow_Union])
 
 lemma finite_bind:
   assumes "finite S"
   assumes "\<forall>x \<in> S. finite (f x)"
   shows "finite (Set.bind S f)"
 using assms by (simp add: bind_UNION)
 
 lemma finite_filter [simp]: "finite S \<Longrightarrow> finite (Set.filter P S)"
 unfolding Set.filter_def by simp
 
 lemma finite_set_of_finite_funs:
   assumes "finite A" "finite B"
   shows "finite {f. \<forall>x. (x \<in> A \<longrightarrow> f x \<in> B) \<and> (x \<notin> A \<longrightarrow> f x = d)}" (is "finite ?S")
 proof -
   let ?F = "\<lambda>f. {(a,b). a \<in> A \<and> b = f a}"
   have "?F ` ?S \<subseteq> Pow(A \<times> B)"
     by auto
   from finite_subset[OF this] assms have 1: "finite (?F ` ?S)"
     by simp
   have 2: "inj_on ?F ?S"
     by (fastforce simp add: inj_on_def set_eq_iff fun_eq_iff)  (* somewhat slow *)
   show ?thesis
     by (rule finite_imageD [OF 1 2])
 qed
 
 lemma not_finite_existsD:
   assumes "\<not> finite {a. P a}"
   shows "\<exists>a. P a"
 proof (rule classical)
   assume "\<not> ?thesis"
   with assms show ?thesis by auto
 qed
 
 
 subsection \<open>Further induction rules on finite sets\<close>
 
 lemma finite_ne_induct [case_names singleton insert, consumes 2]:
   assumes "finite F" and "F \<noteq> {}"
   assumes "\<And>x. P {x}"
     and "\<And>x F. finite F \<Longrightarrow> F \<noteq> {} \<Longrightarrow> x \<notin> F \<Longrightarrow> P F  \<Longrightarrow> P (insert x F)"
   shows "P F"
   using assms
 proof induct
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case by cases auto
 qed
 
 lemma finite_subset_induct [consumes 2, case_names empty insert]:
   assumes "finite F" and "F \<subseteq> A"
     and empty: "P {}"
     and insert: "\<And>a F. finite F \<Longrightarrow> a \<in> A \<Longrightarrow> a \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert a F)"
   shows "P F"
   using \<open>finite F\<close> \<open>F \<subseteq> A\<close>
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume "finite F" and "x \<notin> F" and P: "F \<subseteq> A \<Longrightarrow> P F" and i: "insert x F \<subseteq> A"
   show "P (insert x F)"
   proof (rule insert)
     from i show "x \<in> A" by blast
     from i have "F \<subseteq> A" by blast
     with P show "P F" .
     show "finite F" by fact
     show "x \<notin> F" by fact
   qed
 qed
 
 lemma finite_empty_induct:
   assumes "finite A"
     and "P A"
     and remove: "\<And>a A. finite A \<Longrightarrow> a \<in> A \<Longrightarrow> P A \<Longrightarrow> P (A - {a})"
   shows "P {}"
 proof -
   have "P (A - B)" if "B \<subseteq> A" for B :: "'a set"
   proof -
     from \<open>finite A\<close> that have "finite B"
       by (rule rev_finite_subset)
     from this \<open>B \<subseteq> A\<close> show "P (A - B)"
     proof induct
       case empty
       from \<open>P A\<close> show ?case by simp
     next
       case (insert b B)
       have "P (A - B - {b})"
       proof (rule remove)
         from \<open>finite A\<close> show "finite (A - B)"
           by induct auto
         from insert show "b \<in> A - B"
           by simp
         from insert show "P (A - B)"
           by simp
       qed
       also have "A - B - {b} = A - insert b B"
         by (rule Diff_insert [symmetric])
       finally show ?case .
     qed
   qed
   then have "P (A - A)" by blast
   then show ?thesis by simp
 qed
 
 lemma finite_update_induct [consumes 1, case_names const update]:
   assumes finite: "finite {a. f a \<noteq> c}"
     and const: "P (\<lambda>a. c)"
     and update: "\<And>a b f. finite {a. f a \<noteq> c} \<Longrightarrow> f a = c \<Longrightarrow> b \<noteq> c \<Longrightarrow> P f \<Longrightarrow> P (f(a := b))"
   shows "P f"
   using finite
 proof (induct "{a. f a \<noteq> c}" arbitrary: f)
   case empty
   with const show ?case by simp
 next
   case (insert a A)
   then have "A = {a'. (f(a := c)) a' \<noteq> c}" and "f a \<noteq> c"
     by auto
   with \<open>finite A\<close> have "finite {a'. (f(a := c)) a' \<noteq> c}"
     by simp
   have "(f(a := c)) a = c"
     by simp
   from insert \<open>A = {a'. (f(a := c)) a' \<noteq> c}\<close> have "P (f(a := c))"
     by simp
   with \<open>finite {a'. (f(a := c)) a' \<noteq> c}\<close> \<open>(f(a := c)) a = c\<close> \<open>f a \<noteq> c\<close>
   have "P ((f(a := c))(a := f a))"
     by (rule update)
   then show ?case by simp
 qed
 
 lemma finite_subset_induct' [consumes 2, case_names empty insert]:
   assumes "finite F" and "F \<subseteq> A"
     and empty: "P {}"
     and insert: "\<And>a F. \<lbrakk>finite F; a \<in> A; F \<subseteq> A; a \<notin> F; P F \<rbrakk> \<Longrightarrow> P (insert a F)"
   shows "P F"
   using assms(1,2)
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume "finite F" and "x \<notin> F" and
     P: "F \<subseteq> A \<Longrightarrow> P F" and i: "insert x F \<subseteq> A"
   show "P (insert x F)"
   proof (rule insert)
     from i show "x \<in> A" by blast
     from i have "F \<subseteq> A" by blast
     with P show "P F" .
     show "finite F" by fact
     show "x \<notin> F" by fact
     show "F \<subseteq> A" by fact
   qed
 qed
 
 
 subsection \<open>Class \<open>finite\<close>\<close>
 
 class finite =
   assumes finite_UNIV: "finite (UNIV :: 'a set)"
 begin
 
 lemma finite [simp]: "finite (A :: 'a set)"
   by (rule subset_UNIV finite_UNIV finite_subset)+
 
 lemma finite_code [code]: "finite (A :: 'a set) \<longleftrightarrow> True"
   by simp
 
 end
 
 instance prod :: (finite, finite) finite
   by standard (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product finite)
 
 lemma inj_graph: "inj (\<lambda>f. {(x, y). y = f x})"
   by (rule inj_onI) (auto simp add: set_eq_iff fun_eq_iff)
 
 instance "fun" :: (finite, finite) finite
 proof
   show "finite (UNIV :: ('a \<Rightarrow> 'b) set)"
   proof (rule finite_imageD)
     let ?graph = "\<lambda>f::'a \<Rightarrow> 'b. {(x, y). y = f x}"
     have "range ?graph \<subseteq> Pow UNIV"
       by simp
     moreover have "finite (Pow (UNIV :: ('a * 'b) set))"
       by (simp only: finite_Pow_iff finite)
     ultimately show "finite (range ?graph)"
       by (rule finite_subset)
     show "inj ?graph"
       by (rule inj_graph)
   qed
 qed
 
 instance bool :: finite
   by standard (simp add: UNIV_bool)
 
 instance set :: (finite) finite
   by standard (simp only: Pow_UNIV [symmetric] finite_Pow_iff finite)
 
 instance unit :: finite
   by standard (simp add: UNIV_unit)
 
 instance sum :: (finite, finite) finite
   by standard (simp only: UNIV_Plus_UNIV [symmetric] finite_Plus finite)
 
 
 subsection \<open>A basic fold functional for finite sets\<close>
 
 text \<open>
   The intended behaviour is \<open>fold f z {x\<^sub>1, \<dots>, x\<^sub>n} = f x\<^sub>1 (\<dots> (f x\<^sub>n z)\<dots>)\<close>
   if \<open>f\<close> is ``left-commutative''.
   The commutativity requirement is relativised to the carrier set \<open>S\<close>:
 \<close>
 
 locale comp_fun_commute_on =
   fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   assumes comp_fun_commute_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma fun_left_comm: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y (f x z) = f x (f y z)"
   using comp_fun_commute_on by (simp add: fun_eq_iff)
 
 lemma commute_left_comp: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y \<circ> (f x \<circ> g) = f x \<circ> (f y \<circ> g)"
   by (simp add: o_assoc comp_fun_commute_on)
 
 end
 
 inductive fold_graph :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> bool"
   for f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: 'b
   where
     emptyI [intro]: "fold_graph f z {} z"
   | insertI [intro]: "x \<notin> A \<Longrightarrow> fold_graph f z A y \<Longrightarrow> fold_graph f z (insert x A) (f x y)"
 
 inductive_cases empty_fold_graphE [elim!]: "fold_graph f z {} x"
 
 lemma fold_graph_closed_lemma:
   "fold_graph f z A x \<and> x \<in> B"
   if "fold_graph g z A x"
     "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
     "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
     "z \<in> B"
   using that(1-3)
 proof (induction rule: fold_graph.induct)
   case (insertI x A y)
   have "fold_graph f z A y" "y \<in> B"
     unfolding atomize_conj
     by (rule insertI.IH) (auto intro: insertI.prems)
   then have "g x y \<in> B" and f_eq: "f x y = g x y"
     by (auto simp: insertI.prems)
   moreover have "fold_graph f z (insert x A) (f x y)"
     by (rule fold_graph.insertI; fact)
   ultimately
   show ?case
     by (simp add: f_eq)
 qed (auto intro!: that)
 
 lemma fold_graph_closed_eq:
   "fold_graph f z A = fold_graph g z A"
   if "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
      "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
      "z \<in> B"
   using fold_graph_closed_lemma[of f z A _ B g] fold_graph_closed_lemma[of g z A _ B f] that
   by auto
 
 definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b"
   where "fold f z A = (if finite A then (THE y. fold_graph f z A y) else z)"
 
 lemma fold_closed_eq: "fold f z A = fold g z A"
   if "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
      "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
      "z \<in> B"
   unfolding Finite_Set.fold_def
   by (subst fold_graph_closed_eq[where B=B and g=g]) (auto simp: that)
 
 text \<open>
   A tempting alternative for the definition is
   \<^term>\<open>if finite A then THE y. fold_graph f z A y else e\<close>.
   It allows the removal of finiteness assumptions from the theorems
   \<open>fold_comm\<close>, \<open>fold_reindex\<close> and \<open>fold_distrib\<close>.
   The proofs become ugly. It is not worth the effort. (???)
 \<close>
 
 lemma finite_imp_fold_graph: "finite A \<Longrightarrow> \<exists>x. fold_graph f z A x"
   by (induct rule: finite_induct) auto
 
 
 subsubsection \<open>From \<^const>\<open>fold_graph\<close> to \<^term>\<open>fold\<close>\<close>
 
 context comp_fun_commute_on
 begin
 
 lemma fold_graph_finite:
   assumes "fold_graph f z A y"
   shows "finite A"
   using assms by induct simp_all
 
 lemma fold_graph_insertE_aux:
   assumes "A \<subseteq> S"
   assumes "fold_graph f z A y" "a \<in> A"
   shows "\<exists>y'. y = f a y' \<and> fold_graph f z (A - {a}) y'"
   using assms(2-,1)
 proof (induct set: fold_graph)
   case emptyI
   then show ?case by simp
 next
   case (insertI x A y)
   show ?case
   proof (cases "x = a")
     case True
     with insertI show ?thesis by auto
   next
     case False
     then obtain y' where y: "y = f a y'" and y': "fold_graph f z (A - {a}) y'"
       using insertI by auto
     from insertI have "x \<in> S" "a \<in> S" by auto
     then have "f x y = f a (f x y')"
       unfolding y by (intro fun_left_comm; simp)
     moreover have "fold_graph f z (insert x A - {a}) (f x y')"
       using y' and \<open>x \<noteq> a\<close> and \<open>x \<notin> A\<close>
       by (simp add: insert_Diff_if fold_graph.insertI)
     ultimately show ?thesis
       by fast
   qed
 qed
 
 lemma fold_graph_insertE:
   assumes "insert x A \<subseteq> S"
   assumes "fold_graph f z (insert x A) v" and "x \<notin> A"
   obtains y where "v = f x y" and "fold_graph f z A y"
   using assms by (auto dest: fold_graph_insertE_aux[OF \<open>insert x A \<subseteq> S\<close> _ insertI1])
 
 lemma fold_graph_determ:
   assumes "A \<subseteq> S"
   assumes "fold_graph f z A x" "fold_graph f z A y"
   shows "y = x"
   using assms(2-,1)
 proof (induct arbitrary: y set: fold_graph)
   case emptyI
   then show ?case by fast
 next
   case (insertI x A y v)
   from \<open>insert x A \<subseteq> S\<close> and \<open>fold_graph f z (insert x A) v\<close> and \<open>x \<notin> A\<close>
   obtain y' where "v = f x y'" and "fold_graph f z A y'"
     by (rule fold_graph_insertE)
   from \<open>fold_graph f z A y'\<close> insertI have "y' = y"
     by simp
   with \<open>v = f x y'\<close> show "v = f x y"
     by simp
 qed
 
 lemma fold_equality: "A \<subseteq> S \<Longrightarrow> fold_graph f z A y \<Longrightarrow> fold f z A = y"
   by (cases "finite A") (auto simp add: fold_def intro: fold_graph_determ dest: fold_graph_finite)
 
 lemma fold_graph_fold:
   assumes "A \<subseteq> S"
   assumes "finite A"
   shows "fold_graph f z A (fold f z A)"
 proof -
   from \<open>finite A\<close> have "\<exists>x. fold_graph f z A x"
     by (rule finite_imp_fold_graph)
   moreover note fold_graph_determ[OF \<open>A \<subseteq> S\<close>]
   ultimately have "\<exists>!x. fold_graph f z A x"
     by (rule ex_ex1I)
   then have "fold_graph f z A (The (fold_graph f z A))"
     by (rule theI')
   with assms show ?thesis
     by (simp add: fold_def)
 qed
 
 text \<open>The base case for \<open>fold\<close>:\<close>
 
 lemma (in -) fold_infinite [simp]: "\<not> finite A \<Longrightarrow> fold f z A = z"
   by (auto simp: fold_def)
 
 lemma (in -) fold_empty [simp]: "fold f z {} = z"
   by (auto simp: fold_def)
 
 text \<open>The various recursion equations for \<^const>\<open>fold\<close>:\<close>
 
 lemma fold_insert [simp]:
   assumes "insert x A \<subseteq> S"
   assumes "finite A" and "x \<notin> A"
   shows "fold f z (insert x A) = f x (fold f z A)"
 proof (rule fold_equality[OF \<open>insert x A \<subseteq> S\<close>])
   fix z
   from \<open>insert x A \<subseteq> S\<close> \<open>finite A\<close> have "fold_graph f z A (fold f z A)"
     by (blast intro: fold_graph_fold)
   with \<open>x \<notin> A\<close> have "fold_graph f z (insert x A) (f x (fold f z A))"
     by (rule fold_graph.insertI)
   then show "fold_graph f z (insert x A) (f x (fold f z A))"
     by simp
 qed
 
 declare (in -) empty_fold_graphE [rule del] fold_graph.intros [rule del]
   \<comment> \<open>No more proofs involve these.\<close>
 
 lemma fold_fun_left_comm:
   assumes "insert x A \<subseteq> S" "finite A" 
   shows "f x (fold f z A) = fold f (f x z) A"
   using assms(2,1)
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert y F)
   then have "fold f (f x z) (insert y F) = f y (fold f (f x z) F)"
     by simp
   also have "\<dots> = f x (f y (fold f z F))"
     using insert by (simp add: fun_left_comm[where ?y=x])
   also have "\<dots> = f x (fold f z (insert y F))"
   proof -
     from insert have "insert y F \<subseteq> S" by simp
     from fold_insert[OF this] insert show ?thesis by simp
   qed
   finally show ?case ..
 qed
 
 lemma fold_insert2:
   "insert x A \<subseteq> S \<Longrightarrow> finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> fold f z (insert x A)  = fold f (f x z) A"
   by (simp add: fold_fun_left_comm)
 
 lemma fold_rec:
   assumes "A \<subseteq> S"
   assumes "finite A" and "x \<in> A"
   shows "fold f z A = f x (fold f z (A - {x}))"
 proof -
   have A: "A = insert x (A - {x})"
     using \<open>x \<in> A\<close> by blast
   then have "fold f z A = fold f z (insert x (A - {x}))"
     by simp
   also have "\<dots> = f x (fold f z (A - {x}))"
     by (rule fold_insert) (use assms in \<open>auto\<close>)
   finally show ?thesis .
 qed
 
 lemma fold_insert_remove:
   assumes "insert x A \<subseteq> S"
   assumes "finite A"
   shows "fold f z (insert x A) = f x (fold f z (A - {x}))"
 proof -
   from \<open>finite A\<close> have "finite (insert x A)"
     by auto
   moreover have "x \<in> insert x A"
     by auto
   ultimately have "fold f z (insert x A) = f x (fold f z (insert x A - {x}))"
     using \<open>insert x A \<subseteq> S\<close> by (blast intro: fold_rec)
   then show ?thesis
     by simp
 qed
 
 lemma fold_set_union_disj:
   assumes "A \<subseteq> S" "B \<subseteq> S"
   assumes "finite A" "finite B" "A \<inter> B = {}"
   shows "Finite_Set.fold f z (A \<union> B) = Finite_Set.fold f (Finite_Set.fold f z A) B"
   using \<open>finite B\<close> assms(1,2,3,5)
 proof induct
   case (insert x F)
   have "fold f z (A \<union> insert x F) = f x (fold f (fold f z A) F)"
     using insert by auto
   also have "\<dots> = fold f (fold f z A) (insert x F)"
     using insert by (blast intro: fold_insert[symmetric])
   finally show ?case .
 qed simp
 
 
 end
 
 text \<open>Other properties of \<^const>\<open>fold\<close>:\<close>
 
 lemma fold_graph_image:
   assumes "inj_on g A"
   shows "fold_graph f z (g ` A) = fold_graph (f \<circ> g) z A"
 proof
   fix w
   show "fold_graph f z (g ` A) w = fold_graph (f o g) z A w"
   proof
     assume "fold_graph f z (g ` A) w"
     then show "fold_graph (f \<circ> g) z A w"
       using assms
     proof (induct "g ` A" w arbitrary: A)
       case emptyI
       then show ?case by (auto intro: fold_graph.emptyI)
     next
       case (insertI x A r B)
       from \<open>inj_on g B\<close> \<open>x \<notin> A\<close> \<open>insert x A = image g B\<close> obtain x' A'
         where "x' \<notin> A'" and [simp]: "B = insert x' A'" "x = g x'" "A = g ` A'"
         by (rule inj_img_insertE)
       from insertI.prems have "fold_graph (f \<circ> g) z A' r"
         by (auto intro: insertI.hyps)
       with \<open>x' \<notin> A'\<close> have "fold_graph (f \<circ> g) z (insert x' A') ((f \<circ> g) x' r)"
         by (rule fold_graph.insertI)
       then show ?case
         by simp
     qed
   next
     assume "fold_graph (f \<circ> g) z A w"
     then show "fold_graph f z (g ` A) w"
       using assms
     proof induct
       case emptyI
       then show ?case
         by (auto intro: fold_graph.emptyI)
     next
       case (insertI x A r)
       from \<open>x \<notin> A\<close> insertI.prems have "g x \<notin> g ` A"
         by auto
       moreover from insertI have "fold_graph f z (g ` A) r"
         by simp
       ultimately have "fold_graph f z (insert (g x) (g ` A)) (f (g x) r)"
         by (rule fold_graph.insertI)
       then show ?case
         by simp
     qed
   qed
 qed
 
 lemma fold_image:
   assumes "inj_on g A"
   shows "fold f z (g ` A) = fold (f \<circ> g) z A"
 proof (cases "finite A")
   case False
   with assms show ?thesis
     by (auto dest: finite_imageD simp add: fold_def)
 next
   case True
   then show ?thesis
     by (auto simp add: fold_def fold_graph_image[OF assms])
 qed
 
 lemma fold_cong:
   assumes "comp_fun_commute_on S f" "comp_fun_commute_on S g"
     and "A \<subseteq> S" "finite A"
     and cong: "\<And>x. x \<in> A \<Longrightarrow> f x = g x"
     and "s = t" and "A = B"
   shows "fold f s A = fold g t B"
 proof -
   have "fold f s A = fold g s A"
     using \<open>finite A\<close> \<open>A \<subseteq> S\<close> cong
   proof (induct A)
     case empty
     then show ?case by simp
   next
     case insert
     interpret f: comp_fun_commute_on S f by (fact \<open>comp_fun_commute_on S f\<close>)
     interpret g: comp_fun_commute_on S g by (fact \<open>comp_fun_commute_on S g\<close>)
     from insert show ?case by simp
   qed
   with assms show ?thesis by simp
 qed
 
 
 text \<open>A simplified version for idempotent functions:\<close>
 
 locale comp_fun_idem_on = comp_fun_commute_on +
   assumes comp_fun_idem_on: "x \<in> S \<Longrightarrow> f x \<circ> f x = f x"
 begin
 
 lemma fun_left_idem: "x \<in> S \<Longrightarrow> f x (f x z) = f x z"
   using comp_fun_idem_on by (simp add: fun_eq_iff)
 
 lemma fold_insert_idem:
   assumes "insert x A \<subseteq> S"
   assumes fin: "finite A"
   shows "fold f z (insert x A)  = f x (fold f z A)"
 proof cases
   assume "x \<in> A"
   then obtain B where "A = insert x B" and "x \<notin> B"
     by (rule set_insert)
   then show ?thesis
     using assms by (simp add: comp_fun_idem_on fun_left_idem)
 next
   assume "x \<notin> A"
   then show ?thesis
     using assms by auto
 qed
 
 declare fold_insert [simp del] fold_insert_idem [simp]
 
 lemma fold_insert_idem2: "insert x A \<subseteq> S \<Longrightarrow> finite A \<Longrightarrow> fold f z (insert x A) = fold f (f x z) A"
   by (simp add: fold_fun_left_comm)
 
 end
 
 
 subsubsection \<open>Liftings to \<open>comp_fun_commute_on\<close> etc.\<close>
                    
 lemma (in comp_fun_commute_on) comp_comp_fun_commute_on:
   "range g \<subseteq> S \<Longrightarrow> comp_fun_commute_on R (f \<circ> g)"
   by standard (force intro: comp_fun_commute_on)
 
 lemma (in comp_fun_idem_on) comp_comp_fun_idem_on:
   assumes "range g \<subseteq> S"
   shows "comp_fun_idem_on R (f \<circ> g)"
 proof
   interpret f_g: comp_fun_commute_on R "f o g"
     by (fact comp_comp_fun_commute_on[OF \<open>range g \<subseteq> S\<close>])
   show "x \<in> R \<Longrightarrow> y \<in> R \<Longrightarrow> (f \<circ> g) y \<circ> (f \<circ> g) x = (f \<circ> g) x \<circ> (f \<circ> g) y" for x y
     by (fact f_g.comp_fun_commute_on)
 qed (use \<open>range g \<subseteq> S\<close> in \<open>force intro: comp_fun_idem_on\<close>)
 
 lemma (in comp_fun_commute_on) comp_fun_commute_on_funpow:
   "comp_fun_commute_on S (\<lambda>x. f x ^^ g x)"
 proof
   fix x y assume "x \<in> S" "y \<in> S"
   show "f y ^^ g y \<circ> f x ^^ g x = f x ^^ g x \<circ> f y ^^ g y"
   proof (cases "x = y")
     case True
     then show ?thesis by simp
   next
     case False
     show ?thesis
     proof (induct "g x" arbitrary: g)
       case 0
       then show ?case by simp
     next
       case (Suc n g)
       have hyp1: "f y ^^ g y \<circ> f x = f x \<circ> f y ^^ g y"
       proof (induct "g y" arbitrary: g)
         case 0
         then show ?case by simp
       next
         case (Suc n g)
         define h where "h z = g z - 1" for z
         with Suc have "n = h y"
           by simp
         with Suc have hyp: "f y ^^ h y \<circ> f x = f x \<circ> f y ^^ h y"
           by auto
         from Suc h_def have "g y = Suc (h y)"
           by simp
         with \<open>x \<in> S\<close> \<open>y \<in> S\<close> show ?case
           by (simp add: comp_assoc hyp) (simp add: o_assoc comp_fun_commute_on)
       qed
       define h where "h z = (if z = x then g x - 1 else g z)" for z
       with Suc have "n = h x"
         by simp
       with Suc have "f y ^^ h y \<circ> f x ^^ h x = f x ^^ h x \<circ> f y ^^ h y"
         by auto
       with False h_def have hyp2: "f y ^^ g y \<circ> f x ^^ h x = f x ^^ h x \<circ> f y ^^ g y"
         by simp
       from Suc h_def have "g x = Suc (h x)"
         by simp
       then show ?case
         by (simp del: funpow.simps add: funpow_Suc_right o_assoc hyp2) (simp add: comp_assoc hyp1)
     qed
   qed
 qed
 
 
 subsubsection \<open>\<^term>\<open>UNIV\<close> as carrier set\<close>
 
 locale comp_fun_commute =
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma (in -) comp_fun_commute_def': "comp_fun_commute f = comp_fun_commute_on UNIV f"
   unfolding comp_fun_commute_def comp_fun_commute_on_def by blast
 
 text \<open>
   We abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale comp_fun_commute_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "comp_fun_commute_on UNIV f"
     by standard  (simp add: comp_fun_commute)
 qed simp_all
 
 end
 
 lemma (in comp_fun_commute) comp_comp_fun_commute: "comp_fun_commute (f o g)"
   unfolding comp_fun_commute_def' by (fact comp_comp_fun_commute_on)
 
 lemma (in comp_fun_commute) comp_fun_commute_funpow: "comp_fun_commute (\<lambda>x. f x ^^ g x)"
   unfolding comp_fun_commute_def' by (fact comp_fun_commute_on_funpow)
 
 locale comp_fun_idem = comp_fun_commute +
   assumes comp_fun_idem: "f x o f x = f x"
 begin
 
 lemma (in -) comp_fun_idem_def': "comp_fun_idem f = comp_fun_idem_on UNIV f"
   unfolding comp_fun_idem_on_def comp_fun_idem_def comp_fun_commute_def'
   unfolding comp_fun_idem_axioms_def comp_fun_idem_on_axioms_def
   by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale comp_fun_idem_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "comp_fun_idem_on UNIV f"
     by standard (simp_all add: comp_fun_idem comp_fun_commute)
 qed simp_all
 
 end
 
 lemma (in comp_fun_idem) comp_comp_fun_idem: "comp_fun_idem (f o g)"
   unfolding comp_fun_idem_def' by (fact comp_comp_fun_idem_on)
 
 
 subsubsection \<open>Expressing set operations via \<^const>\<open>fold\<close>\<close>
 
 lemma comp_fun_commute_const: "comp_fun_commute (\<lambda>_. f)"
   by standard rule
 
 lemma comp_fun_idem_insert: "comp_fun_idem insert"
   by standard auto
 
 lemma comp_fun_idem_remove: "comp_fun_idem Set.remove"
   by standard auto
 
 lemma (in semilattice_inf) comp_fun_idem_inf: "comp_fun_idem inf"
   by standard (auto simp add: inf_left_commute)
 
 lemma (in semilattice_sup) comp_fun_idem_sup: "comp_fun_idem sup"
   by standard (auto simp add: sup_left_commute)
 
 lemma union_fold_insert:
   assumes "finite A"
   shows "A \<union> B = fold insert B A"
 proof -
   interpret comp_fun_idem insert
     by (fact comp_fun_idem_insert)
   from \<open>finite A\<close> show ?thesis
     by (induct A arbitrary: B) simp_all
 qed
 
 lemma minus_fold_remove:
   assumes "finite A"
   shows "B - A = fold Set.remove B A"
 proof -
   interpret comp_fun_idem Set.remove
     by (fact comp_fun_idem_remove)
   from \<open>finite A\<close> have "fold Set.remove B A = B - A"
     by (induct A arbitrary: B) auto  (* slow *)
   then show ?thesis ..
 qed
 
 lemma comp_fun_commute_filter_fold:
   "comp_fun_commute (\<lambda>x A'. if P x then Set.insert x A' else A')"
 proof -
   interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert)
   show ?thesis by standard (auto simp: fun_eq_iff)
 qed
 
 lemma Set_filter_fold:
   assumes "finite A"
   shows "Set.filter P A = fold (\<lambda>x A'. if P x then Set.insert x A' else A') {} A"
   using assms
 proof -
   interpret commute_insert: comp_fun_commute "(\<lambda>x A'. if P x then Set.insert x A' else A')"
     by (fact comp_fun_commute_filter_fold)
   from \<open>finite A\<close> show ?thesis
     by induct (auto simp add: Set.filter_def)
 qed
 
 lemma inter_Set_filter:
   assumes "finite B"
   shows "A \<inter> B = Set.filter (\<lambda>x. x \<in> A) B"
   using assms
   by induct (auto simp: Set.filter_def)
 
 lemma image_fold_insert:
   assumes "finite A"
   shows "image f A = fold (\<lambda>k A. Set.insert (f k) A) {} A"
 proof -
   interpret comp_fun_commute "\<lambda>k A. Set.insert (f k) A"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma Ball_fold:
   assumes "finite A"
   shows "Ball A P = fold (\<lambda>k s. s \<and> P k) True A"
 proof -
   interpret comp_fun_commute "\<lambda>k s. s \<and> P k"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma Bex_fold:
   assumes "finite A"
   shows "Bex A P = fold (\<lambda>k s. s \<or> P k) False A"
 proof -
   interpret comp_fun_commute "\<lambda>k s. s \<or> P k"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma comp_fun_commute_Pow_fold: "comp_fun_commute (\<lambda>x A. A \<union> Set.insert x ` A)"
   by (clarsimp simp: fun_eq_iff comp_fun_commute_def) blast
 
 lemma Pow_fold:
   assumes "finite A"
   shows "Pow A = fold (\<lambda>x A. A \<union> Set.insert x ` A) {{}} A"
 proof -
   interpret comp_fun_commute "\<lambda>x A. A \<union> Set.insert x ` A"
     by (rule comp_fun_commute_Pow_fold)
   show ?thesis
     using assms by (induct A) (auto simp: Pow_insert)
 qed
 
 lemma fold_union_pair:
   assumes "finite B"
   shows "(\<Union>y\<in>B. {(x, y)}) \<union> A = fold (\<lambda>y. Set.insert (x, y)) A B"
 proof -
   interpret comp_fun_commute "\<lambda>y. Set.insert (x, y)"
     by standard auto
   show ?thesis
     using assms by (induct arbitrary: A) simp_all
 qed
 
 lemma comp_fun_commute_product_fold:
   "finite B \<Longrightarrow> comp_fun_commute (\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B)"
   by standard (auto simp: fold_union_pair [symmetric])
 
 lemma product_fold:
   assumes "finite A" "finite B"
   shows "A \<times> B = fold (\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B) {} A"
 proof -
   interpret commute_product: comp_fun_commute "(\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B)"
     by (fact comp_fun_commute_product_fold[OF \<open>finite B\<close>])
   from assms show ?thesis unfolding Sigma_def
     by (induct A) (simp_all add: fold_union_pair)
 qed
 
 context complete_lattice
 begin
 
 lemma inf_Inf_fold_inf:
   assumes "finite A"
   shows "inf (Inf A) B = fold inf B A"
 proof -
   interpret comp_fun_idem inf
     by (fact comp_fun_idem_inf)
   from \<open>finite A\<close> fold_fun_left_comm show ?thesis
     by (induct A arbitrary: B) (simp_all add: inf_commute fun_eq_iff)
 qed
 
 lemma sup_Sup_fold_sup:
   assumes "finite A"
   shows "sup (Sup A) B = fold sup B A"
 proof -
   interpret comp_fun_idem sup
     by (fact comp_fun_idem_sup)
   from \<open>finite A\<close> fold_fun_left_comm show ?thesis
     by (induct A arbitrary: B) (simp_all add: sup_commute fun_eq_iff)
 qed
 
 lemma Inf_fold_inf: "finite A \<Longrightarrow> Inf A = fold inf top A"
   using inf_Inf_fold_inf [of A top] by (simp add: inf_absorb2)
 
 lemma Sup_fold_sup: "finite A \<Longrightarrow> Sup A = fold sup bot A"
   using sup_Sup_fold_sup [of A bot] by (simp add: sup_absorb2)
 
 lemma inf_INF_fold_inf:
   assumes "finite A"
   shows "inf B (\<Sqinter>(f ` A)) = fold (inf \<circ> f) B A" (is "?inf = ?fold")
 proof -
   interpret comp_fun_idem inf by (fact comp_fun_idem_inf)
   interpret comp_fun_idem "inf \<circ> f" by (fact comp_comp_fun_idem)
   from \<open>finite A\<close> have "?fold = ?inf"
     by (induct A arbitrary: B) (simp_all add: inf_left_commute)
   then show ?thesis ..
 qed
 
 lemma sup_SUP_fold_sup:
   assumes "finite A"
   shows "sup B (\<Squnion>(f ` A)) = fold (sup \<circ> f) B A" (is "?sup = ?fold")
 proof -
   interpret comp_fun_idem sup by (fact comp_fun_idem_sup)
   interpret comp_fun_idem "sup \<circ> f" by (fact comp_comp_fun_idem)
   from \<open>finite A\<close> have "?fold = ?sup"
     by (induct A arbitrary: B) (simp_all add: sup_left_commute)
   then show ?thesis ..
 qed
 
 lemma INF_fold_inf: "finite A \<Longrightarrow> \<Sqinter>(f ` A) = fold (inf \<circ> f) top A"
   using inf_INF_fold_inf [of A top] by simp
 
 lemma SUP_fold_sup: "finite A \<Longrightarrow> \<Squnion>(f ` A) = fold (sup \<circ> f) bot A"
   using sup_SUP_fold_sup [of A bot] by simp
 
 lemma finite_Inf_in:
   assumes "finite A" "A\<noteq>{}" and inf: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> inf x y \<in> A"
   shows "Inf A \<in> A"
 proof -
   have "Inf B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
     using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
   by (induction B) (use inf in \<open>force+\<close>)
   then show ?thesis
     by (simp add: assms)
 qed
 
 lemma finite_Sup_in:
   assumes "finite A" "A\<noteq>{}" and sup: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> sup x y \<in> A"
   shows "Sup A \<in> A"
 proof -
   have "Sup B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
     using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
   by (induction B) (use sup in \<open>force+\<close>)
   then show ?thesis
     by (simp add: assms)
 qed
 
 end
 
 
 subsection \<open>Locales as mini-packages for fold operations\<close>
 
 subsubsection \<open>The natural case\<close>
 
 locale folding_on =
   fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: "'b"
   assumes comp_fun_commute_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y o f x = f x o f y"
 begin
 
 interpretation fold?: comp_fun_commute_on S f
   by standard (simp add: comp_fun_commute_on)
 
 definition F :: "'a set \<Rightarrow> 'b"
   where eq_fold: "F A = Finite_Set.fold f z A"
 
 lemma empty [simp]: "F {} = z"
   by (simp add: eq_fold)
 
 lemma infinite [simp]: "\<not> finite A \<Longrightarrow> F A = z"
   by (simp add: eq_fold)
 
 lemma insert [simp]:
   assumes "insert x A \<subseteq> S" and "finite A" and "x \<notin> A"
   shows "F (insert x A) = f x (F A)"
 proof -
   from fold_insert assms
   have "Finite_Set.fold f z (insert x A) 
       = f x (Finite_Set.fold f z A)"
     by simp
   with \<open>finite A\<close> show ?thesis by (simp add: eq_fold fun_eq_iff)
 qed
 
 lemma remove:
   assumes "A \<subseteq> S" and "finite A" and "x \<in> A"
   shows "F A = f x (F (A - {x}))"
 proof -
   from \<open>x \<in> A\<close> obtain B where A: "A = insert x B" and "x \<notin> B"
     by (auto dest: mk_disjoint_insert)
   moreover from \<open>finite A\<close> A have "finite B" by simp
   ultimately show ?thesis
     using \<open>A \<subseteq> S\<close> by auto
 qed
 
 lemma insert_remove:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "F (insert x A) = f x (F (A - {x}))"
   using assms by (cases "x \<in> A") (simp_all add: remove insert_absorb)
 
 end
 
 
 subsubsection \<open>With idempotency\<close>
 
 locale folding_idem_on = folding_on +
   assumes comp_fun_idem_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f x \<circ> f x = f x"
 begin
 
 declare insert [simp del]
 
 interpretation fold?: comp_fun_idem_on S f
   by standard (simp_all add: comp_fun_commute_on comp_fun_idem_on)
 
 lemma insert_idem [simp]:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "F (insert x A) = f x (F A)"
 proof -
   from fold_insert_idem assms
   have "fold f z (insert x A) = f x (fold f z A)" by simp
   with \<open>finite A\<close> show ?thesis by (simp add: eq_fold fun_eq_iff)
 qed
 
 end
 
 subsubsection \<open>\<^term>\<open>UNIV\<close> as the carrier set\<close>
 
 locale folding =
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: "'b"
   assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma (in -) folding_def': "folding f = folding_on UNIV f"
   unfolding folding_def folding_on_def by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale folding_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "folding_on UNIV f"
     by standard (simp add: comp_fun_commute)
 qed simp_all
 
 end
 
 locale folding_idem = folding +
   assumes comp_fun_idem: "f x \<circ> f x = f x"
 begin
 
 lemma (in -) folding_idem_def': "folding_idem f = folding_idem_on UNIV f"
   unfolding folding_idem_def folding_def' folding_idem_on_def
   unfolding folding_idem_axioms_def folding_idem_on_axioms_def
   by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale folding_idem_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "folding_idem_on UNIV f"
     by standard (simp add: comp_fun_idem)
 qed simp_all
 
 end
 
 
 subsection \<open>Finite cardinality\<close>
 
 text \<open>
   The traditional definition
   \<^prop>\<open>card A \<equiv> LEAST n. \<exists>f. A = {f i |i. i < n}\<close>
   is ugly to work with.
   But now that we have \<^const>\<open>fold\<close> things are easy:
 \<close>
 
 global_interpretation card: folding "\<lambda>_. Suc" 0
   defines card = "folding_on.F (\<lambda>_. Suc) 0"
   by standard rule
 
 lemma card_insert_disjoint: "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> card (insert x A) = Suc (card A)"
   by (fact card.insert)
 
 lemma card_insert_if: "finite A \<Longrightarrow> card (insert x A) = (if x \<in> A then card A else Suc (card A))"
   by auto (simp add: card.insert_remove card.remove)
 
 lemma card_ge_0_finite: "card A > 0 \<Longrightarrow> finite A"
   by (rule ccontr) simp
 
 lemma card_0_eq [simp]: "finite A \<Longrightarrow> card A = 0 \<longleftrightarrow> A = {}"
   by (auto dest: mk_disjoint_insert)
 
 lemma finite_UNIV_card_ge_0: "finite (UNIV :: 'a set) \<Longrightarrow> card (UNIV :: 'a set) > 0"
   by (rule ccontr) simp
 
 lemma card_eq_0_iff: "card A = 0 \<longleftrightarrow> A = {} \<or> \<not> finite A"
   by auto
 
 lemma card_range_greater_zero: "finite (range f) \<Longrightarrow> card (range f) > 0"
   by (rule ccontr) (simp add: card_eq_0_iff)
 
 lemma card_gt_0_iff: "0 < card A \<longleftrightarrow> A \<noteq> {} \<and> finite A"
   by (simp add: neq0_conv [symmetric] card_eq_0_iff)
 
 lemma card_Suc_Diff1:
   assumes "finite A" "x \<in> A" shows "Suc (card (A - {x})) = card A"
 proof -
   have "Suc (card (A - {x})) = card (insert x (A - {x}))"
     using assms by (simp add: card.insert_remove)
   also have "... = card A"
     using assms by (simp add: card_insert_if)
   finally show ?thesis .
 qed
 
 lemma card_insert_le_m1:
   assumes "n > 0" "card y \<le> n - 1" shows  "card (insert x y) \<le> n"
   using assms
   by (cases "finite y") (auto simp: card_insert_if)
 
 lemma card_Diff_singleton:
   assumes "x \<in> A" shows "card (A - {x}) = card A - 1"
 proof (cases "finite A")
   case True
   with assms show ?thesis
     by (simp add: card_Suc_Diff1 [symmetric])
 qed auto
 
 lemma card_Diff_singleton_if:
   "card (A - {x}) = (if x \<in> A then card A - 1 else card A)"
   by (simp add: card_Diff_singleton)
 
 lemma card_Diff_insert[simp]:
   assumes "a \<in> A" and "a \<notin> B"
   shows "card (A - insert a B) = card (A - B) - 1"
 proof -
   have "A - insert a B = (A - B) - {a}"
     using assms by blast
   then show ?thesis
     using assms by (simp add: card_Diff_singleton)
 qed
 
 lemma card_insert_le: "card A \<le> card (insert x A)"
 proof (cases "finite A")
   case True
   then show ?thesis   by (simp add: card_insert_if)
 qed auto
 
 lemma card_Collect_less_nat[simp]: "card {i::nat. i < n} = n"
   by (induct n) (simp_all add:less_Suc_eq Collect_disj_eq)
 
 lemma card_Collect_le_nat[simp]: "card {i::nat. i \<le> n} = Suc n"
   using card_Collect_less_nat[of "Suc n"] by (simp add: less_Suc_eq_le)
 
 lemma card_mono:
   assumes "finite B" and "A \<subseteq> B"
   shows "card A \<le> card B"
 proof -
   from assms have "finite A"
     by (auto intro: finite_subset)
   then show ?thesis
     using assms
   proof (induct A arbitrary: B)
     case empty
     then show ?case by simp
   next
     case (insert x A)
     then have "x \<in> B"
       by simp
     from insert have "A \<subseteq> B - {x}" and "finite (B - {x})"
       by auto
     with insert.hyps have "card A \<le> card (B - {x})"
       by auto
     with \<open>finite A\<close> \<open>x \<notin> A\<close> \<open>finite B\<close> \<open>x \<in> B\<close> show ?case
       by simp (simp only: card.remove)
   qed
 qed
 
 lemma card_seteq: 
   assumes "finite B" and A: "A \<subseteq> B" "card B \<le> card A"
   shows "A = B"
   using assms
 proof (induction arbitrary: A rule: finite_induct)
   case (insert b B)
   then have A: "finite A" "A - {b} \<subseteq> B" 
     by force+
   then have "card B \<le> card (A - {b})"
     using insert by (auto simp add: card_Diff_singleton_if)
   then have "A - {b} = B"
     using A insert.IH by auto
   then show ?case 
     using insert.hyps insert.prems by auto
 qed auto
 
 lemma psubset_card_mono: "finite B \<Longrightarrow> A < B \<Longrightarrow> card A < card B"
   using card_seteq [of B A] by (auto simp add: psubset_eq)
 
 lemma card_Un_Int:
   assumes "finite A" "finite B"
   shows "card A + card B = card (A \<union> B) + card (A \<inter> B)"
   using assms
 proof (induct A)
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case
     by (auto simp add: insert_absorb Int_insert_left)
 qed
 
 lemma card_Un_disjoint: "finite A \<Longrightarrow> finite B \<Longrightarrow> A \<inter> B = {} \<Longrightarrow> card (A \<union> B) = card A + card B"
   using card_Un_Int [of A B] by simp
 
 lemma card_Un_disjnt: "\<lbrakk>finite A; finite B; disjnt A B\<rbrakk> \<Longrightarrow> card (A \<union> B) = card A + card B"
   by (simp add: card_Un_disjoint disjnt_def)
 
 lemma card_Un_le: "card (A \<union> B) \<le> card A + card B"
 proof (cases "finite A \<and> finite B")
   case True
   then show ?thesis
     using le_iff_add card_Un_Int [of A B] by auto
 qed auto
 
 lemma card_Diff_subset:
   assumes "finite B"
     and "B \<subseteq> A"
   shows "card (A - B) = card A - card B"
   using assms
 proof (cases "finite A")
   case False
   with assms show ?thesis
     by simp
 next
   case True
   with assms show ?thesis
     by (induct B arbitrary: A) simp_all
 qed
 
 lemma card_Diff_subset_Int:
   assumes "finite (A \<inter> B)"
   shows "card (A - B) = card A - card (A \<inter> B)"
 proof -
   have "A - B = A - A \<inter> B" by auto
   with assms show ?thesis
     by (simp add: card_Diff_subset)
 qed
 
 lemma diff_card_le_card_Diff:
   assumes "finite B"
   shows "card A - card B \<le> card (A - B)"
 proof -
   have "card A - card B \<le> card A - card (A \<inter> B)"
     using card_mono[OF assms Int_lower2, of A] by arith
   also have "\<dots> = card (A - B)"
     using assms by (simp add: card_Diff_subset_Int)
   finally show ?thesis .
 qed
 
 lemma card_le_sym_Diff:
   assumes "finite A" "finite B" "card A \<le> card B"
   shows "card(A - B) \<le> card(B - A)"
 proof -
   have "card(A - B) = card A - card (A \<inter> B)" using assms(1,2) by(simp add: card_Diff_subset_Int)
   also have "\<dots> \<le> card B - card (A \<inter> B)" using assms(3) by linarith
   also have "\<dots> = card(B - A)" using assms(1,2) by(simp add: card_Diff_subset_Int Int_commute)
   finally show ?thesis .
 qed
 
 lemma card_less_sym_Diff:
   assumes "finite A" "finite B" "card A < card B"
   shows "card(A - B) < card(B - A)"
 proof -
   have "card(A - B) = card A - card (A \<inter> B)" using assms(1,2) by(simp add: card_Diff_subset_Int)
   also have "\<dots> < card B - card (A \<inter> B)" using assms(1,3) by (simp add: card_mono diff_less_mono)
   also have "\<dots> = card(B - A)" using assms(1,2) by(simp add: card_Diff_subset_Int Int_commute)
   finally show ?thesis .
 qed
 
 lemma card_Diff1_less_iff: "card (A - {x}) < card A \<longleftrightarrow> finite A \<and> x \<in> A"
 proof (cases "finite A \<and> x \<in> A")
   case True
   then show ?thesis
     by (auto simp: card_gt_0_iff intro: diff_less)
 qed auto
 
 lemma card_Diff1_less: "finite A \<Longrightarrow> x \<in> A \<Longrightarrow> card (A - {x}) < card A"
   unfolding card_Diff1_less_iff by auto
 
 lemma card_Diff2_less:
   assumes "finite A" "x \<in> A" "y \<in> A" shows "card (A - {x} - {y}) < card A"
 proof (cases "x = y")
   case True
   with assms show ?thesis
     by (simp add: card_Diff1_less del: card_Diff_insert)
 next
   case False
   then have "card (A - {x} - {y}) < card (A - {x})" "card (A - {x}) < card A"
     using assms by (intro card_Diff1_less; simp)+
   then show ?thesis
     by (blast intro: less_trans)
 qed
 
 lemma card_Diff1_le: "card (A - {x}) \<le> card A"
 proof (cases "finite A")
   case True
   then show ?thesis  
     by (cases "x \<in> A") (simp_all add: card_Diff1_less less_imp_le)
 qed auto
 
 lemma card_psubset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> card A < card B \<Longrightarrow> A < B"
   by (erule psubsetI) blast
 
 lemma card_le_inj:
   assumes fA: "finite A"
     and fB: "finite B"
     and c: "card A \<le> card B"
   shows "\<exists>f. f ` A \<subseteq> B \<and> inj_on f A"
   using fA fB c
 proof (induct arbitrary: B rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x s t)
   then show ?case
   proof (induct rule: finite_induct [OF insert.prems(1)])
     case 1
     then show ?case by simp
   next
     case (2 y t)
     from "2.prems"(1,2,5) "2.hyps"(1,2) have cst: "card s \<le> card t"
       by simp
     from "2.prems"(3) [OF "2.hyps"(1) cst]
     obtain f where "f ` s \<subseteq> t" "inj_on f s"
       by blast
     with "2.prems"(2) "2.hyps"(2) show ?case
       unfolding inj_on_def
       by (rule_tac x = "\<lambda>z. if z = x then y else f z" in exI) auto
   qed
 qed
 
 lemma card_subset_eq:
   assumes fB: "finite B"
     and AB: "A \<subseteq> B"
     and c: "card A = card B"
   shows "A = B"
 proof -
   from fB AB have fA: "finite A"
     by (auto intro: finite_subset)
   from fA fB have fBA: "finite (B - A)"
     by auto
   have e: "A \<inter> (B - A) = {}"
     by blast
   have eq: "A \<union> (B - A) = B"
     using AB by blast
   from card_Un_disjoint[OF fA fBA e, unfolded eq c] have "card (B - A) = 0"
     by arith
   then have "B - A = {}"
     unfolding card_eq_0_iff using fA fB by simp
   with AB show "A = B"
     by blast
 qed
 
 lemma insert_partition:
   "x \<notin> F \<Longrightarrow> \<forall>c1 \<in> insert x F. \<forall>c2 \<in> insert x F. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {} \<Longrightarrow> x \<inter> \<Union>F = {}"
   by auto
 
 lemma finite_psubset_induct [consumes 1, case_names psubset]:
   assumes finite: "finite A"
     and major: "\<And>A. finite A \<Longrightarrow> (\<And>B. B \<subset> A \<Longrightarrow> P B) \<Longrightarrow> P A"
   shows "P A"
   using finite
 proof (induct A taking: card rule: measure_induct_rule)
   case (less A)
   have fin: "finite A" by fact
   have ih: "card B < card A \<Longrightarrow> finite B \<Longrightarrow> P B" for B by fact
   have "P B" if "B \<subset> A" for B
   proof -
     from that have "card B < card A"
       using psubset_card_mono fin by blast
     moreover
     from that have "B \<subseteq> A"
       by auto
     then have "finite B"
       using fin finite_subset by blast
     ultimately show ?thesis using ih by simp
   qed
   with fin show "P A" using major by blast
 qed
 
 lemma finite_induct_select [consumes 1, case_names empty select]:
   assumes "finite S"
     and "P {}"
     and select: "\<And>T. T \<subset> S \<Longrightarrow> P T \<Longrightarrow> \<exists>s\<in>S - T. P (insert s T)"
   shows "P S"
 proof -
   have "0 \<le> card S" by simp
   then have "\<exists>T \<subseteq> S. card T = card S \<and> P T"
   proof (induct rule: dec_induct)
     case base with \<open>P {}\<close>
     show ?case
       by (intro exI[of _ "{}"]) auto
   next
     case (step n)
     then obtain T where T: "T \<subseteq> S" "card T = n" "P T"
       by auto
     with \<open>n < card S\<close> have "T \<subset> S" "P T"
       by auto
     with select[of T] obtain s where "s \<in> S" "s \<notin> T" "P (insert s T)"
       by auto
     with step(2) T \<open>finite S\<close> show ?case
       by (intro exI[of _ "insert s T"]) (auto dest: finite_subset)
   qed
   with \<open>finite S\<close> show "P S"
     by (auto dest: card_subset_eq)
 qed
 
 lemma remove_induct [case_names empty infinite remove]:
   assumes empty: "P ({} :: 'a set)"
     and infinite: "\<not> finite B \<Longrightarrow> P B"
     and remove: "\<And>A. finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P (A - {x})) \<Longrightarrow> P A"
   shows "P B"
 proof (cases "finite B")
   case False
   then show ?thesis by (rule infinite)
 next
   case True
   define A where "A = B"
   with True have "finite A" "A \<subseteq> B"
     by simp_all
   then show "P A"
   proof (induct "card A" arbitrary: A)
     case 0
     then have "A = {}" by auto
     with empty show ?case by simp
   next
     case (Suc n A)
     from \<open>A \<subseteq> B\<close> and \<open>finite B\<close> have "finite A"
       by (rule finite_subset)
     moreover from Suc.hyps have "A \<noteq> {}" by auto
     moreover note \<open>A \<subseteq> B\<close>
     moreover have "P (A - {x})" if x: "x \<in> A" for x
       using x Suc.prems \<open>Suc n = card A\<close> by (intro Suc) auto
     ultimately show ?case by (rule remove)
   qed
 qed
 
 lemma finite_remove_induct [consumes 1, case_names empty remove]:
   fixes P :: "'a set \<Rightarrow> bool"
   assumes "finite B"
     and "P {}"
     and "\<And>A. finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P (A - {x})) \<Longrightarrow> P A"
   defines "B' \<equiv> B"
   shows "P B'"
   by (induct B' rule: remove_induct) (simp_all add: assms)
 
 
 text \<open>Main cardinality theorem.\<close>
 lemma card_partition [rule_format]:
   "finite C \<Longrightarrow> finite (\<Union>C) \<Longrightarrow> (\<forall>c\<in>C. card c = k) \<Longrightarrow>
     (\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}) \<Longrightarrow>
     k * card C = card (\<Union>C)"
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case
     by (simp add: card_Un_disjoint insert_partition finite_subset [of _ "\<Union>(insert _ _)"])
 qed
 
 lemma card_eq_UNIV_imp_eq_UNIV:
   assumes fin: "finite (UNIV :: 'a set)"
     and card: "card A = card (UNIV :: 'a set)"
   shows "A = (UNIV :: 'a set)"
 proof
   show "A \<subseteq> UNIV" by simp
   show "UNIV \<subseteq> A"
   proof
     show "x \<in> A" for x
     proof (rule ccontr)
       assume "x \<notin> A"
       then have "A \<subset> UNIV" by auto
       with fin have "card A < card (UNIV :: 'a set)"
         by (fact psubset_card_mono)
       with card show False by simp
     qed
   qed
 qed
 
 text \<open>The form of a finite set of given cardinality\<close>
 
 lemma card_eq_SucD:
   assumes "card A = Suc k"
   shows "\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> (k = 0 \<longrightarrow> B = {})"
 proof -
   have fin: "finite A"
     using assms by (auto intro: ccontr)
   moreover have "card A \<noteq> 0"
     using assms by auto
   ultimately obtain b where b: "b \<in> A"
     by auto
   show ?thesis
   proof (intro exI conjI)
     show "A = insert b (A - {b})"
       using b by blast
     show "b \<notin> A - {b}"
       by blast
     show "card (A - {b}) = k" and "k = 0 \<longrightarrow> A - {b} = {}"
       using assms b fin by (fastforce dest: mk_disjoint_insert)+
   qed
 qed
 
 lemma card_Suc_eq:
   "card A = Suc k \<longleftrightarrow>
     (\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> (k = 0 \<longrightarrow> B = {}))"
   by (auto simp: card_insert_if card_gt_0_iff elim!: card_eq_SucD)
 
 lemma card_Suc_eq_finite:
   "card A = Suc k \<longleftrightarrow> (\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> finite B)"
   unfolding card_Suc_eq using card_gt_0_iff by fastforce
 
 lemma card_1_singletonE:
   assumes "card A = 1"
   obtains x where "A = {x}"
   using assms by (auto simp: card_Suc_eq)
 
 lemma is_singleton_altdef: "is_singleton A \<longleftrightarrow> card A = 1"
   unfolding is_singleton_def
   by (auto elim!: card_1_singletonE is_singletonE simp del: One_nat_def)
 
 lemma card_1_singleton_iff: "card A = Suc 0 \<longleftrightarrow> (\<exists>x. A = {x})"
   by (simp add: card_Suc_eq)
 
 lemma card_le_Suc0_iff_eq:
   assumes "finite A"
   shows "card A \<le> Suc 0 \<longleftrightarrow> (\<forall>a1 \<in> A. \<forall>a2 \<in> A. a1 = a2)" (is "?C = ?A")
 proof
   assume ?C thus ?A using assms by (auto simp: le_Suc_eq dest: card_eq_SucD)
 next
   assume ?A
   show ?C
   proof cases
     assume "A = {}" thus ?C using \<open>?A\<close> by simp
   next
     assume "A \<noteq> {}"
     then obtain a where "A = {a}" using \<open>?A\<close> by blast
     thus ?C by simp
   qed
 qed
 
 lemma card_le_Suc_iff:
   "Suc n \<le> card A = (\<exists>a B. A = insert a B \<and> a \<notin> B \<and> n \<le> card B \<and> finite B)"
 proof (cases "finite A")
   case True
   then show ?thesis
     by (fastforce simp: card_Suc_eq less_eq_nat.simps split: nat.splits)
 qed auto
 
 lemma finite_fun_UNIVD2:
   assumes fin: "finite (UNIV :: ('a \<Rightarrow> 'b) set)"
   shows "finite (UNIV :: 'b set)"
 proof -
   from fin have "finite (range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary))" for arbitrary
     by (rule finite_imageI)
   moreover have "UNIV = range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary)" for arbitrary
     by (rule UNIV_eq_I) auto
   ultimately show "finite (UNIV :: 'b set)"
     by simp
 qed
 
 lemma card_UNIV_unit [simp]: "card (UNIV :: unit set) = 1"
   unfolding UNIV_unit by simp
 
 lemma infinite_arbitrarily_large:
   assumes "\<not> finite A"
   shows "\<exists>B. finite B \<and> card B = n \<and> B \<subseteq> A"
 proof (induction n)
   case 0
   show ?case by (intro exI[of _ "{}"]) auto
 next
   case (Suc n)
   then obtain B where B: "finite B \<and> card B = n \<and> B \<subseteq> A" ..
   with \<open>\<not> finite A\<close> have "A \<noteq> B" by auto
   with B have "B \<subset> A" by auto
   then have "\<exists>x. x \<in> A - B"
     by (elim psubset_imp_ex_mem)
   then obtain x where x: "x \<in> A - B" ..
   with B have "finite (insert x B) \<and> card (insert x B) = Suc n \<and> insert x B \<subseteq> A"
     by auto
   then show "\<exists>B. finite B \<and> card B = Suc n \<and> B \<subseteq> A" ..
 qed
 
 text \<open>Sometimes, to prove that a set is finite, it is convenient to work with finite subsets
 and to show that their cardinalities are uniformly bounded. This possibility is formalized in
 the next criterion.\<close>
 
 lemma finite_if_finite_subsets_card_bdd:
   assumes "\<And>G. G \<subseteq> F \<Longrightarrow> finite G \<Longrightarrow> card G \<le> C"
   shows "finite F \<and> card F \<le> C"
 proof (cases "finite F")
   case False
   obtain n::nat where n: "n > max C 0" by auto
   obtain G where G: "G \<subseteq> F" "card G = n" using infinite_arbitrarily_large[OF False] by auto
   hence "finite G" using \<open>n > max C 0\<close> using card.infinite gr_implies_not0 by blast
   hence False using assms G n not_less by auto
   thus ?thesis ..
 next
   case True thus ?thesis using assms[of F] by auto
 qed
 
 
 subsubsection \<open>Cardinality of image\<close>
 
 lemma card_image_le: "finite A \<Longrightarrow> card (f ` A) \<le> card A"
   by (induct rule: finite_induct) (simp_all add: le_SucI card_insert_if)
 
 lemma card_image: "inj_on f A \<Longrightarrow> card (f ` A) = card A"
 proof (induct A rule: infinite_finite_induct)
   case (infinite A)
   then have "\<not> finite (f ` A)" by (auto dest: finite_imageD)
   with infinite show ?case by simp
 qed simp_all
 
 lemma bij_betw_same_card: "bij_betw f A B \<Longrightarrow> card A = card B"
   by (auto simp: card_image bij_betw_def)
 
 lemma endo_inj_surj: "finite A \<Longrightarrow> f ` A \<subseteq> A \<Longrightarrow> inj_on f A \<Longrightarrow> f ` A = A"
   by (simp add: card_seteq card_image)
 
 lemma eq_card_imp_inj_on:
   assumes "finite A" "card(f ` A) = card A"
   shows "inj_on f A"
   using assms
 proof (induct rule:finite_induct)
   case empty
   show ?case by simp
 next
   case (insert x A)
   then show ?case
     using card_image_le [of A f] by (simp add: card_insert_if split: if_splits)
 qed
 
 lemma inj_on_iff_eq_card: "finite A \<Longrightarrow> inj_on f A \<longleftrightarrow> card (f ` A) = card A"
   by (blast intro: card_image eq_card_imp_inj_on)
 
 lemma card_inj_on_le:
   assumes "inj_on f A" "f ` A \<subseteq> B" "finite B"
   shows "card A \<le> card B"
 proof -
   have "finite A"
     using assms by (blast intro: finite_imageD dest: finite_subset)
   then show ?thesis
     using assms by (force intro: card_mono simp: card_image [symmetric])
 qed
 
 lemma inj_on_iff_card_le:
   "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> (\<exists>f. inj_on f A \<and> f ` A \<le> B) = (card A \<le> card B)"
 using card_inj_on_le[of _ A B] card_le_inj[of A B] by blast
 
 lemma surj_card_le: "finite A \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> card B \<le> card A"
   by (blast intro: card_image_le card_mono le_trans)
 
 lemma card_bij_eq:
   "inj_on f A \<Longrightarrow> f ` A \<subseteq> B \<Longrightarrow> inj_on g B \<Longrightarrow> g ` B \<subseteq> A \<Longrightarrow> finite A \<Longrightarrow> finite B
     \<Longrightarrow> card A = card B"
   by (auto intro: le_antisym card_inj_on_le)
 
 lemma bij_betw_finite: "bij_betw f A B \<Longrightarrow> finite A \<longleftrightarrow> finite B"
   unfolding bij_betw_def using finite_imageD [of f A] by auto
 
 lemma inj_on_finite: "inj_on f A \<Longrightarrow> f ` A \<le> B \<Longrightarrow> finite B \<Longrightarrow> finite A"
   using finite_imageD finite_subset by blast
 
 lemma card_vimage_inj: "inj f \<Longrightarrow> A \<subseteq> range f \<Longrightarrow> card (f -` A) = card A"
   by (auto 4 3 simp: subset_image_iff inj_vimage_image_eq
       intro: card_image[symmetric, OF subset_inj_on])
 
 
 subsubsection \<open>Pigeonhole Principles\<close>
 
 lemma pigeonhole: "card A > card (f ` A) \<Longrightarrow> \<not> inj_on f A "
   by (auto dest: card_image less_irrefl_nat)
 
 lemma pigeonhole_infinite:
   assumes "\<not> finite A" and "finite (f`A)"
   shows "\<exists>a0\<in>A. \<not> finite {a\<in>A. f a = f a0}"
   using assms(2,1)
 proof (induct "f`A" arbitrary: A rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert b F)
   show ?case
   proof (cases "finite {a\<in>A. f a = b}")
     case True
     with \<open>\<not> finite A\<close> have "\<not> finite (A - {a\<in>A. f a = b})"
       by simp
     also have "A - {a\<in>A. f a = b} = {a\<in>A. f a \<noteq> b}"
       by blast
     finally have "\<not> finite {a\<in>A. f a \<noteq> b}" .
     from insert(3)[OF _ this] insert(2,4) show ?thesis
       by simp (blast intro: rev_finite_subset)
   next
     case False
     then have "{a \<in> A. f a = b} \<noteq> {}" by force
     with False show ?thesis by blast
   qed
 qed
 
 lemma pigeonhole_infinite_rel:
   assumes "\<not> finite A"
     and "finite B"
     and "\<forall>a\<in>A. \<exists>b\<in>B. R a b"
   shows "\<exists>b\<in>B. \<not> finite {a:A. R a b}"
 proof -
   let ?F = "\<lambda>a. {b\<in>B. R a b}"
   from finite_Pow_iff[THEN iffD2, OF \<open>finite B\<close>] have "finite (?F ` A)"
     by (blast intro: rev_finite_subset)
   from pigeonhole_infinite [where f = ?F, OF assms(1) this]
   obtain a0 where "a0 \<in> A" and infinite: "\<not> finite {a\<in>A. ?F a = ?F a0}" ..
   obtain b0 where "b0 \<in> B" and "R a0 b0"
     using \<open>a0 \<in> A\<close> assms(3) by blast
   have "finite {a\<in>A. ?F a = ?F a0}" if "finite {a\<in>A. R a b0}"
     using \<open>b0 \<in> B\<close> \<open>R a0 b0\<close> that by (blast intro: rev_finite_subset)
   with infinite \<open>b0 \<in> B\<close> show ?thesis
     by blast
 qed
 
 
 subsubsection \<open>Cardinality of sums\<close>
 
 lemma card_Plus:
   assumes "finite A" "finite B"
   shows "card (A <+> B) = card A + card B"
 proof -
   have "Inl`A \<inter> Inr`B = {}" by fast
   with assms show ?thesis
     by (simp add: Plus_def card_Un_disjoint card_image)
 qed
 
 lemma card_Plus_conv_if:
   "card (A <+> B) = (if finite A \<and> finite B then card A + card B else 0)"
   by (auto simp add: card_Plus)
 
 text \<open>Relates to equivalence classes.  Based on a theorem of F. Kammüller.\<close>
 
 lemma dvd_partition:
   assumes f: "finite (\<Union>C)"
     and "\<forall>c\<in>C. k dvd card c" "\<forall>c1\<in>C. \<forall>c2\<in>C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}"
   shows "k dvd card (\<Union>C)"
 proof -
   have "finite C"
     by (rule finite_UnionD [OF f])
   then show ?thesis
     using assms
   proof (induct rule: finite_induct)
     case empty
     show ?case by simp
   next
     case (insert c C)
     then have "c \<inter> \<Union>C = {}"
       by auto
     with insert show ?case
       by (simp add: card_Un_disjoint)
   qed
 qed
 
 subsubsection \<open>Finite orders\<close>
 
 context order
 begin
 
 lemma finite_has_maximal:
   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. \<forall> b \<in> A. m \<le> b \<longrightarrow> m = b"
 proof (induction rule: finite_psubset_induct)
   case (psubset A)
   from \<open>A \<noteq> {}\<close> obtain a where "a \<in> A" by auto
   let ?B = "{b \<in> A. a < b}"
   show ?case
   proof cases
     assume "?B = {}"
     hence "\<forall> b \<in> A. a \<le> b \<longrightarrow> a = b" using le_neq_trans by blast
     thus ?thesis using \<open>a \<in> A\<close> by blast
   next
     assume "?B \<noteq> {}"
     have "a \<notin> ?B" by auto
     hence "?B \<subset> A" using \<open>a \<in> A\<close> by blast
     from psubset.IH[OF this \<open>?B \<noteq> {}\<close>] show ?thesis using order.strict_trans2 by blast
   qed
 qed
 
 lemma finite_has_maximal2:
   "\<lbrakk> finite A; a \<in> A \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. a \<le> m \<and> (\<forall> b \<in> A. m \<le> b \<longrightarrow> m = b)"
 using finite_has_maximal[of "{b \<in> A. a \<le> b}"] by fastforce
 
 lemma finite_has_minimal:
   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. \<forall> b \<in> A. b \<le> m \<longrightarrow> m = b"
 proof (induction rule: finite_psubset_induct)
   case (psubset A)
   from \<open>A \<noteq> {}\<close> obtain a where "a \<in> A" by auto
   let ?B = "{b \<in> A. b < a}"
   show ?case
   proof cases
     assume "?B = {}"
     hence "\<forall> b \<in> A. b \<le> a \<longrightarrow> a = b" using le_neq_trans by blast
     thus ?thesis using \<open>a \<in> A\<close> by blast
   next
     assume "?B \<noteq> {}"
     have "a \<notin> ?B" by auto
     hence "?B \<subset> A" using \<open>a \<in> A\<close> by blast
     from psubset.IH[OF this \<open>?B \<noteq> {}\<close>] show ?thesis using order.strict_trans1 by blast
   qed
 qed
 
 lemma finite_has_minimal2:
   "\<lbrakk> finite A; a \<in> A \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. m \<le> a \<and> (\<forall> b \<in> A. b \<le> m \<longrightarrow> m = b)"
 using finite_has_minimal[of "{b \<in> A. b \<le> a}"] by fastforce
 
 end
 
 subsubsection \<open>Relating injectivity and surjectivity\<close>
 
 lemma finite_surj_inj:
   assumes "finite A" "A \<subseteq> f ` A"
   shows "inj_on f A"
 proof -
   have "f ` A = A"
     by (rule card_seteq [THEN sym]) (auto simp add: assms card_image_le)
   then show ?thesis using assms
     by (simp add: eq_card_imp_inj_on)
 qed
 
 lemma finite_UNIV_surj_inj: "finite(UNIV:: 'a set) \<Longrightarrow> surj f \<Longrightarrow> inj f"
   for f :: "'a \<Rightarrow> 'a"
   by (blast intro: finite_surj_inj subset_UNIV)
 
 lemma finite_UNIV_inj_surj: "finite(UNIV:: 'a set) \<Longrightarrow> inj f \<Longrightarrow> surj f"
   for f :: "'a \<Rightarrow> 'a"
   by (fastforce simp:surj_def dest!: endo_inj_surj)
 
 lemma surjective_iff_injective_gen:
   assumes fS: "finite S"
     and fT: "finite T"
     and c: "card S = card T"
     and ST: "f ` S \<subseteq> T"
   shows "(\<forall>y \<in> T. \<exists>x \<in> S. f x = y) \<longleftrightarrow> inj_on f S"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume h: "?lhs"
   {
     fix x y
     assume x: "x \<in> S"
     assume y: "y \<in> S"
     assume f: "f x = f y"
     from x fS have S0: "card S \<noteq> 0"
       by auto
     have "x = y"
     proof (rule ccontr)
       assume xy: "\<not> ?thesis"
       have th: "card S \<le> card (f ` (S - {y}))"
         unfolding c
       proof (rule card_mono)
         show "finite (f ` (S - {y}))"
           by (simp add: fS)
         have "\<lbrakk>x \<noteq> y; x \<in> S; z \<in> S; f x = f y\<rbrakk>
          \<Longrightarrow> \<exists>x \<in> S. x \<noteq> y \<and> f z = f x" for z
           by (case_tac "z = y \<longrightarrow> z = x") auto
         then show "T \<subseteq> f ` (S - {y})"
           using h xy x y f by fastforce
       qed
       also have " \<dots> \<le> card (S - {y})"
         by (simp add: card_image_le fS)
       also have "\<dots> \<le> card S - 1" using y fS by simp
       finally show False using S0 by arith
     qed
   }
   then show ?rhs
     unfolding inj_on_def by blast
 next
   assume h: ?rhs
   have "f ` S = T"
     by (simp add: ST c card_image card_subset_eq fT h)
   then show ?lhs by blast
 qed
 
 hide_const (open) Finite_Set.fold
 
 
 subsection \<open>Infinite Sets\<close>
 
 text \<open>
   Some elementary facts about infinite sets, mostly by Stephan Merz.
   Beware! Because "infinite" merely abbreviates a negation, these
   lemmas may not work well with \<open>blast\<close>.
 \<close>
 
 abbreviation infinite :: "'a set \<Rightarrow> bool"
   where "infinite S \<equiv> \<not> finite S"
 
 text \<open>
   Infinite sets are non-empty, and if we remove some elements from an
   infinite set, the result is still infinite.
 \<close>
 
 lemma infinite_UNIV_nat [iff]: "infinite (UNIV :: nat set)"
 proof
   assume "finite (UNIV :: nat set)"
   with finite_UNIV_inj_surj [of Suc] show False
     by simp (blast dest: Suc_neq_Zero surjD)
 qed
 
 lemma infinite_UNIV_char_0: "infinite (UNIV :: 'a::semiring_char_0 set)"
 proof
   assume "finite (UNIV :: 'a set)"
   with subset_UNIV have "finite (range of_nat :: 'a set)"
     by (rule finite_subset)
   moreover have "inj (of_nat :: nat \<Rightarrow> 'a)"
     by (simp add: inj_on_def)
   ultimately have "finite (UNIV :: nat set)"
     by (rule finite_imageD)
   then show False
     by simp
 qed
 
 lemma infinite_imp_nonempty: "infinite S \<Longrightarrow> S \<noteq> {}"
   by auto
 
 lemma infinite_remove: "infinite S \<Longrightarrow> infinite (S - {a})"
   by simp
 
 lemma Diff_infinite_finite:
   assumes "finite T" "infinite S"
   shows "infinite (S - T)"
   using \<open>finite T\<close>
 proof induct
   from \<open>infinite S\<close> show "infinite (S - {})"
     by auto
 next
   fix T x
   assume ih: "infinite (S - T)"
   have "S - (insert x T) = (S - T) - {x}"
     by (rule Diff_insert)
   with ih show "infinite (S - (insert x T))"
     by (simp add: infinite_remove)
 qed
 
 lemma Un_infinite: "infinite S \<Longrightarrow> infinite (S \<union> T)"
   by simp
 
 lemma infinite_Un: "infinite (S \<union> T) \<longleftrightarrow> infinite S \<or> infinite T"
   by simp
 
 lemma infinite_super:
   assumes "S \<subseteq> T"
     and "infinite S"
   shows "infinite T"
 proof
   assume "finite T"
   with \<open>S \<subseteq> T\<close> have "finite S" by (simp add: finite_subset)
   with \<open>infinite S\<close> show False by simp
 qed
 
 proposition infinite_coinduct [consumes 1, case_names infinite]:
   assumes "X A"
     and step: "\<And>A. X A \<Longrightarrow> \<exists>x\<in>A. X (A - {x}) \<or> infinite (A - {x})"
   shows "infinite A"
 proof
   assume "finite A"
   then show False
     using \<open>X A\<close>
   proof (induction rule: finite_psubset_induct)
     case (psubset A)
     then obtain x where "x \<in> A" "X (A - {x}) \<or> infinite (A - {x})"
       using local.step psubset.prems by blast
     then have "X (A - {x})"
       using psubset.hyps by blast
     show False
     proof (rule psubset.IH [where B = "A - {x}"])
       show "A - {x} \<subset> A"
         using \<open>x \<in> A\<close> by blast
     qed fact
   qed
 qed
 
 text \<open>
   For any function with infinite domain and finite range there is some
   element that is the image of infinitely many domain elements.  In
   particular, any infinite sequence of elements from a finite set
   contains some element that occurs infinitely often.
 \<close>
 
 lemma inf_img_fin_dom':
   assumes img: "finite (f ` A)"
     and dom: "infinite A"
   shows "\<exists>y \<in> f ` A. infinite (f -` {y} \<inter> A)"
 proof (rule ccontr)
   have "A \<subseteq> (\<Union>y\<in>f ` A. f -` {y} \<inter> A)" by auto
   moreover assume "\<not> ?thesis"
   with img have "finite (\<Union>y\<in>f ` A. f -` {y} \<inter> A)" by blast
   ultimately have "finite A" by (rule finite_subset)
   with dom show False by contradiction
 qed
 
 lemma inf_img_fin_domE':
   assumes "finite (f ` A)" and "infinite A"
   obtains y where "y \<in> f`A" and "infinite (f -` {y} \<inter> A)"
   using assms by (blast dest: inf_img_fin_dom')
 
 lemma inf_img_fin_dom:
   assumes img: "finite (f`A)" and dom: "infinite A"
   shows "\<exists>y \<in> f`A. infinite (f -` {y})"
   using inf_img_fin_dom'[OF assms] by auto
 
 lemma inf_img_fin_domE:
   assumes "finite (f`A)" and "infinite A"
   obtains y where "y \<in> f`A" and "infinite (f -` {y})"
   using assms by (blast dest: inf_img_fin_dom)
 
 proposition finite_image_absD: "finite (abs ` S) \<Longrightarrow> finite S"
   for S :: "'a::linordered_ring set"
   by (rule ccontr) (auto simp: abs_eq_iff vimage_def dest: inf_img_fin_dom)
 
 
 subsection \<open>The finite powerset operator\<close>
 
 definition Fpow :: "'a set \<Rightarrow> 'a set set"
 where "Fpow A \<equiv> {X. X \<subseteq> A \<and> finite X}"
 
 lemma Fpow_mono: "A \<subseteq> B \<Longrightarrow> Fpow A \<subseteq> Fpow B"
 unfolding Fpow_def by auto
 
 lemma empty_in_Fpow: "{} \<in> Fpow A"
 unfolding Fpow_def by auto
 
 lemma Fpow_not_empty: "Fpow A \<noteq> {}"
 using empty_in_Fpow by blast
 
 lemma Fpow_subset_Pow: "Fpow A \<subseteq> Pow A"
 unfolding Fpow_def by auto
 
 lemma Fpow_Pow_finite: "Fpow A = Pow A Int {A. finite A}"
 unfolding Fpow_def Pow_def by blast
 
 lemma inj_on_image_Fpow:
   assumes "inj_on f A"
   shows "inj_on (image f) (Fpow A)"
   using assms Fpow_subset_Pow[of A] subset_inj_on[of "image f" "Pow A"]
     inj_on_image_Pow by blast
 
 lemma image_Fpow_mono:
   assumes "f ` A \<subseteq> B"
   shows "(image f) ` (Fpow A) \<subseteq> Fpow B"
   using assms by(unfold Fpow_def, auto)
 
 end
diff --git a/src/HOL/Groups_Big.thy b/src/HOL/Groups_Big.thy
--- a/src/HOL/Groups_Big.thy
+++ b/src/HOL/Groups_Big.thy
@@ -1,1673 +1,1687 @@
 (*  Title:      HOL/Groups_Big.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
     Author:     Jeremy Avigad
 *)
 
 section \<open>Big sum and product over finite (non-empty) sets\<close>
 
 theory Groups_Big
   imports Power
 begin
 
 subsection \<open>Generic monoid operation over a set\<close>
 
 locale comm_monoid_set = comm_monoid
 begin
 
 subsubsection \<open>Standard sum or product indexed by a finite set\<close>
 
 interpretation comp_fun_commute f
   by standard (simp add: fun_eq_iff left_commute)
 
 interpretation comp?: comp_fun_commute "f \<circ> g"
   by (fact comp_comp_fun_commute)
 
 definition F :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'a"
   where eq_fold: "F g A = Finite_Set.fold (f \<circ> g) \<^bold>1 A"
 
 lemma infinite [simp]: "\<not> finite A \<Longrightarrow> F g A = \<^bold>1"
   by (simp add: eq_fold)
 
 lemma empty [simp]: "F g {} = \<^bold>1"
   by (simp add: eq_fold)
 
 lemma insert [simp]: "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> F g (insert x A) = g x \<^bold>* F g A"
   by (simp add: eq_fold)
 
 lemma remove:
   assumes "finite A" and "x \<in> A"
   shows "F g A = g x \<^bold>* F g (A - {x})"
 proof -
   from \<open>x \<in> A\<close> obtain B where B: "A = insert x B" and "x \<notin> B"
     by (auto dest: mk_disjoint_insert)
   moreover from \<open>finite A\<close> B have "finite B" by simp
   ultimately show ?thesis by simp
 qed
 
 lemma insert_remove: "finite A \<Longrightarrow> F g (insert x A) = g x \<^bold>* F g (A - {x})"
   by (cases "x \<in> A") (simp_all add: remove insert_absorb)
 
 lemma insert_if: "finite A \<Longrightarrow> F g (insert x A) = (if x \<in> A then F g A else g x \<^bold>* F g A)"
   by (cases "x \<in> A") (simp_all add: insert_absorb)
 
 lemma neutral: "\<forall>x\<in>A. g x = \<^bold>1 \<Longrightarrow> F g A = \<^bold>1"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma neutral_const [simp]: "F (\<lambda>_. \<^bold>1) A = \<^bold>1"
   by (simp add: neutral)
 
 lemma union_inter:
   assumes "finite A" and "finite B"
   shows "F g (A \<union> B) \<^bold>* F g (A \<inter> B) = F g A \<^bold>* F g B"
   \<comment> \<open>The reversed orientation looks more natural, but LOOPS as a simprule!\<close>
   using assms
 proof (induct A)
   case empty
   then show ?case by simp
 next
   case (insert x A)
   then show ?case
     by (auto simp: insert_absorb Int_insert_left commute [of _ "g x"] assoc left_commute)
 qed
 
 corollary union_inter_neutral:
   assumes "finite A" and "finite B"
     and "\<forall>x \<in> A \<inter> B. g x = \<^bold>1"
   shows "F g (A \<union> B) = F g A \<^bold>* F g B"
   using assms by (simp add: union_inter [symmetric] neutral)
 
 corollary union_disjoint:
   assumes "finite A" and "finite B"
   assumes "A \<inter> B = {}"
   shows "F g (A \<union> B) = F g A \<^bold>* F g B"
   using assms by (simp add: union_inter_neutral)
 
 lemma union_diff2:
   assumes "finite A" and "finite B"
   shows "F g (A \<union> B) = F g (A - B) \<^bold>* F g (B - A) \<^bold>* F g (A \<inter> B)"
 proof -
   have "A \<union> B = A - B \<union> (B - A) \<union> A \<inter> B"
     by auto
   with assms show ?thesis
     by simp (subst union_disjoint, auto)+
 qed
 
 lemma subset_diff:
   assumes "B \<subseteq> A" and "finite A"
   shows "F g A = F g (A - B) \<^bold>* F g B"
 proof -
   from assms have "finite (A - B)" by auto
   moreover from assms have "finite B" by (rule finite_subset)
   moreover from assms have "(A - B) \<inter> B = {}" by auto
   ultimately have "F g (A - B \<union> B) = F g (A - B) \<^bold>* F g B" by (rule union_disjoint)
   moreover from assms have "A \<union> B = A" by auto
   ultimately show ?thesis by simp
 qed
 
 lemma Int_Diff:
   assumes "finite A"
   shows "F g A = F g (A \<inter> B) \<^bold>* F g (A - B)"
   by (subst subset_diff [where B = "A - B"]) (auto simp:  Diff_Diff_Int assms)
 
 lemma setdiff_irrelevant:
   assumes "finite A"
   shows "F g (A - {x. g x = z}) = F g A"
   using assms by (induct A) (simp_all add: insert_Diff_if)
 
 lemma not_neutral_contains_not_neutral:
   assumes "F g A \<noteq> \<^bold>1"
   obtains a where "a \<in> A" and "g a \<noteq> \<^bold>1"
 proof -
   from assms have "\<exists>a\<in>A. g a \<noteq> \<^bold>1"
   proof (induct A rule: infinite_finite_induct)
     case infinite
     then show ?case by simp
   next
     case empty
     then show ?case by simp
   next
     case (insert a A)
     then show ?case by fastforce
   qed
   with that show thesis by blast
 qed
 
 lemma reindex:
   assumes "inj_on h A"
   shows "F g (h ` A) = F (g \<circ> h) A"
 proof (cases "finite A")
   case True
   with assms show ?thesis
     by (simp add: eq_fold fold_image comp_assoc)
 next
   case False
   with assms have "\<not> finite (h ` A)" by (blast dest: finite_imageD)
   with False show ?thesis by simp
 qed
 
 lemma cong [fundef_cong]:
   assumes "A = B"
   assumes g_h: "\<And>x. x \<in> B \<Longrightarrow> g x = h x"
   shows "F g A = F h B"
   using g_h unfolding \<open>A = B\<close>
   by (induct B rule: infinite_finite_induct) auto
 
 lemma cong_simp [cong]:
   "\<lbrakk> A = B;  \<And>x. x \<in> B =simp=> g x = h x \<rbrakk> \<Longrightarrow> F (\<lambda>x. g x) A = F (\<lambda>x. h x) B"
 by (rule cong) (simp_all add: simp_implies_def)
 
 lemma reindex_cong:
   assumes "inj_on l B"
   assumes "A = l ` B"
   assumes "\<And>x. x \<in> B \<Longrightarrow> g (l x) = h x"
   shows "F g A = F h B"
   using assms by (simp add: reindex)
 
 lemma image_eq:
   assumes "inj_on g A"  
   shows "F (\<lambda>x. x) (g ` A) = F g A"
   using assms reindex_cong by fastforce
 
 lemma UNION_disjoint:
   assumes "finite I" and "\<forall>i\<in>I. finite (A i)"
     and "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}"
   shows "F g (\<Union>(A ` I)) = F (\<lambda>x. F g (A x)) I"
   using assms
 proof (induction rule: finite_induct)
   case (insert i I)
   then have "\<forall>j\<in>I. j \<noteq> i"
     by blast
   with insert.prems have "A i \<inter> \<Union>(A ` I) = {}"
     by blast
   with insert show ?case
     by (simp add: union_disjoint)
 qed auto
 
 lemma Union_disjoint:
   assumes "\<forall>A\<in>C. finite A" "\<forall>A\<in>C. \<forall>B\<in>C. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
   shows "F g (\<Union>C) = (F \<circ> F) g C"
 proof (cases "finite C")
   case True
   from UNION_disjoint [OF this assms] show ?thesis by simp
 next
   case False
   then show ?thesis by (auto dest: finite_UnionD intro: infinite)
 qed
 
 lemma distrib: "F (\<lambda>x. g x \<^bold>* h x) A = F g A \<^bold>* F h A"
   by (induct A rule: infinite_finite_induct) (simp_all add: assoc commute left_commute)
 
 lemma Sigma:
   assumes "finite A" "\<forall>x\<in>A. finite (B x)"
   shows "F (\<lambda>x. F (g x) (B x)) A = F (case_prod g) (SIGMA x:A. B x)"
   unfolding Sigma_def
 proof (subst UNION_disjoint)
   show "F (\<lambda>x. F (g x) (B x)) A = F (\<lambda>x. F (\<lambda>(x, y). g x y) (\<Union>y\<in>B x. {(x, y)})) A"
   proof (rule cong [OF refl])
     show "F (g x) (B x) = F (\<lambda>(x, y). g x y) (\<Union>y\<in>B x. {(x, y)})"
       if "x \<in> A" for x
       using that assms by (simp add: UNION_disjoint)
   qed
 qed (use assms in auto)
 
 lemma related:
   assumes Re: "R \<^bold>1 \<^bold>1"
     and Rop: "\<forall>x1 y1 x2 y2. R x1 x2 \<and> R y1 y2 \<longrightarrow> R (x1 \<^bold>* y1) (x2 \<^bold>* y2)"
     and fin: "finite S"
     and R_h_g: "\<forall>x\<in>S. R (h x) (g x)"
   shows "R (F h S) (F g S)"
   using fin by (rule finite_subset_induct) (use assms in auto)
 
 lemma mono_neutral_cong_left:
   assumes "finite T"
     and "S \<subseteq> T"
     and "\<forall>i \<in> T - S. h i = \<^bold>1"
     and "\<And>x. x \<in> S \<Longrightarrow> g x = h x"
   shows "F g S = F h T"
 proof-
   have eq: "T = S \<union> (T - S)" using \<open>S \<subseteq> T\<close> by blast
   have d: "S \<inter> (T - S) = {}" using \<open>S \<subseteq> T\<close> by blast
   from \<open>finite T\<close> \<open>S \<subseteq> T\<close> have f: "finite S" "finite (T - S)"
     by (auto intro: finite_subset)
   show ?thesis using assms(4)
     by (simp add: union_disjoint [OF f d, unfolded eq [symmetric]] neutral [OF assms(3)])
 qed
 
 lemma mono_neutral_cong_right:
   "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> g x = h x) \<Longrightarrow>
     F g T = F h S"
   by (auto intro!: mono_neutral_cong_left [symmetric])
 
 lemma mono_neutral_left: "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> F g S = F g T"
   by (blast intro: mono_neutral_cong_left)
 
 lemma mono_neutral_right: "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> F g T = F g S"
   by (blast intro!: mono_neutral_left [symmetric])
 
 lemma mono_neutral_cong:
   assumes [simp]: "finite T" "finite S"
     and *: "\<And>i. i \<in> T - S \<Longrightarrow> h i = \<^bold>1" "\<And>i. i \<in> S - T \<Longrightarrow> g i = \<^bold>1"
     and gh: "\<And>x. x \<in> S \<inter> T \<Longrightarrow> g x = h x"
  shows "F g S = F h T"
 proof-
   have "F g S = F g (S \<inter> T)"
     by(rule mono_neutral_right)(auto intro: *)
   also have "\<dots> = F h (S \<inter> T)" using refl gh by(rule cong)
   also have "\<dots> = F h T"
     by(rule mono_neutral_left)(auto intro: *)
   finally show ?thesis .
 qed
 
 lemma reindex_bij_betw: "bij_betw h S T \<Longrightarrow> F (\<lambda>x. g (h x)) S = F g T"
   by (auto simp: bij_betw_def reindex)
 
 lemma reindex_bij_witness:
   assumes witness:
     "\<And>a. a \<in> S \<Longrightarrow> i (j a) = a"
     "\<And>a. a \<in> S \<Longrightarrow> j a \<in> T"
     "\<And>b. b \<in> T \<Longrightarrow> j (i b) = b"
     "\<And>b. b \<in> T \<Longrightarrow> i b \<in> S"
   assumes eq:
     "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
   shows "F g S = F h T"
 proof -
   have "bij_betw j S T"
     using bij_betw_byWitness[where A=S and f=j and f'=i and A'=T] witness by auto
   moreover have "F g S = F (\<lambda>x. h (j x)) S"
     by (intro cong) (auto simp: eq)
   ultimately show ?thesis
     by (simp add: reindex_bij_betw)
 qed
 
 lemma reindex_bij_betw_not_neutral:
   assumes fin: "finite S'" "finite T'"
   assumes bij: "bij_betw h (S - S') (T - T')"
   assumes nn:
     "\<And>a. a \<in> S' \<Longrightarrow> g (h a) = z"
     "\<And>b. b \<in> T' \<Longrightarrow> g b = z"
   shows "F (\<lambda>x. g (h x)) S = F g T"
 proof -
   have [simp]: "finite S \<longleftrightarrow> finite T"
     using bij_betw_finite[OF bij] fin by auto
   show ?thesis
   proof (cases "finite S")
     case True
     with nn have "F (\<lambda>x. g (h x)) S = F (\<lambda>x. g (h x)) (S - S')"
       by (intro mono_neutral_cong_right) auto
     also have "\<dots> = F g (T - T')"
       using bij by (rule reindex_bij_betw)
     also have "\<dots> = F g T"
       using nn \<open>finite S\<close> by (intro mono_neutral_cong_left) auto
     finally show ?thesis .
   next
     case False
     then show ?thesis by simp
   qed
 qed
 
 lemma reindex_nontrivial:
   assumes "finite A"
     and nz: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> h x = h y \<Longrightarrow> g (h x) = \<^bold>1"
   shows "F g (h ` A) = F (g \<circ> h) A"
 proof (subst reindex_bij_betw_not_neutral [symmetric])
   show "bij_betw h (A - {x \<in> A. (g \<circ> h) x = \<^bold>1}) (h ` A - h ` {x \<in> A. (g \<circ> h) x = \<^bold>1})"
     using nz by (auto intro!: inj_onI simp: bij_betw_def)
 qed (use \<open>finite A\<close> in auto)
 
 lemma reindex_bij_witness_not_neutral:
   assumes fin: "finite S'" "finite T'"
   assumes witness:
     "\<And>a. a \<in> S - S' \<Longrightarrow> i (j a) = a"
     "\<And>a. a \<in> S - S' \<Longrightarrow> j a \<in> T - T'"
     "\<And>b. b \<in> T - T' \<Longrightarrow> j (i b) = b"
     "\<And>b. b \<in> T - T' \<Longrightarrow> i b \<in> S - S'"
   assumes nn:
     "\<And>a. a \<in> S' \<Longrightarrow> g a = z"
     "\<And>b. b \<in> T' \<Longrightarrow> h b = z"
   assumes eq:
     "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
   shows "F g S = F h T"
 proof -
   have bij: "bij_betw j (S - (S' \<inter> S)) (T - (T' \<inter> T))"
     using witness by (intro bij_betw_byWitness[where f'=i]) auto
   have F_eq: "F g S = F (\<lambda>x. h (j x)) S"
     by (intro cong) (auto simp: eq)
   show ?thesis
     unfolding F_eq using fin nn eq
     by (intro reindex_bij_betw_not_neutral[OF _ _ bij]) auto
 qed
 
 lemma delta_remove:
   assumes fS: "finite S"
   shows "F (\<lambda>k. if k = a then b k else c k) S = (if a \<in> S then b a \<^bold>* F c (S-{a}) else F c (S-{a}))"
 proof -
   let ?f = "(\<lambda>k. if k = a then b k else c k)"
   show ?thesis
   proof (cases "a \<in> S")
     case False
     then have "\<forall>k\<in>S. ?f k = c k" by simp
     with False show ?thesis by simp
   next
     case True
     let ?A = "S - {a}"
     let ?B = "{a}"
     from True have eq: "S = ?A \<union> ?B" by blast
     have dj: "?A \<inter> ?B = {}" by simp
     from fS have fAB: "finite ?A" "finite ?B" by auto
     have "F ?f S = F ?f ?A \<^bold>* F ?f ?B"
       using union_disjoint [OF fAB dj, of ?f, unfolded eq [symmetric]] by simp
     with True show ?thesis
       using comm_monoid_set.remove comm_monoid_set_axioms fS by fastforce
   qed
 qed
 
 lemma delta [simp]:
   assumes fS: "finite S"
   shows "F (\<lambda>k. if k = a then b k else \<^bold>1) S = (if a \<in> S then b a else \<^bold>1)"
   by (simp add: delta_remove [OF assms])
 
 lemma delta' [simp]:
   assumes fin: "finite S"
   shows "F (\<lambda>k. if a = k then b k else \<^bold>1) S = (if a \<in> S then b a else \<^bold>1)"
   using delta [OF fin, of a b, symmetric] by (auto intro: cong)
 
 lemma If_cases:
   fixes P :: "'b \<Rightarrow> bool" and g h :: "'b \<Rightarrow> 'a"
   assumes fin: "finite A"
   shows "F (\<lambda>x. if P x then h x else g x) A = F h (A \<inter> {x. P x}) \<^bold>* F g (A \<inter> - {x. P x})"
 proof -
   have a: "A = A \<inter> {x. P x} \<union> A \<inter> -{x. P x}" "(A \<inter> {x. P x}) \<inter> (A \<inter> -{x. P x}) = {}"
     by blast+
   from fin have f: "finite (A \<inter> {x. P x})" "finite (A \<inter> -{x. P x})" by auto
   let ?g = "\<lambda>x. if P x then h x else g x"
   from union_disjoint [OF f a(2), of ?g] a(1) show ?thesis
     by (subst (1 2) cong) simp_all
 qed
 
 lemma cartesian_product: "F (\<lambda>x. F (g x) B) A = F (case_prod g) (A \<times> B)"
 proof (cases "A = {} \<or> B = {}")
   case True
   then show ?thesis
     by auto
 next
   case False
   then have "A \<noteq> {}" "B \<noteq> {}" by auto
   show ?thesis
   proof (cases "finite A \<and> finite B")
     case True
     then show ?thesis
       by (simp add: Sigma)
   next
     case False
     then consider "infinite A" | "infinite B" by auto
     then have "infinite (A \<times> B)"
       by cases (use \<open>A \<noteq> {}\<close> \<open>B \<noteq> {}\<close> in \<open>auto dest: finite_cartesian_productD1 finite_cartesian_productD2\<close>)
     then show ?thesis
       using False by auto
   qed
 qed
 
 lemma inter_restrict:
   assumes "finite A"
   shows "F g (A \<inter> B) = F (\<lambda>x. if x \<in> B then g x else \<^bold>1) A"
 proof -
   let ?g = "\<lambda>x. if x \<in> A \<inter> B then g x else \<^bold>1"
   have "\<forall>i\<in>A - A \<inter> B. (if i \<in> A \<inter> B then g i else \<^bold>1) = \<^bold>1" by simp
   moreover have "A \<inter> B \<subseteq> A" by blast
   ultimately have "F ?g (A \<inter> B) = F ?g A"
     using \<open>finite A\<close> by (intro mono_neutral_left) auto
   then show ?thesis by simp
 qed
 
 lemma inter_filter:
   "finite A \<Longrightarrow> F g {x \<in> A. P x} = F (\<lambda>x. if P x then g x else \<^bold>1) A"
   by (simp add: inter_restrict [symmetric, of A "{x. P x}" g, simplified mem_Collect_eq] Int_def)
 
 lemma Union_comp:
   assumes "\<forall>A \<in> B. finite A"
     and "\<And>A1 A2 x. A1 \<in> B \<Longrightarrow> A2 \<in> B \<Longrightarrow> A1 \<noteq> A2 \<Longrightarrow> x \<in> A1 \<Longrightarrow> x \<in> A2 \<Longrightarrow> g x = \<^bold>1"
   shows "F g (\<Union>B) = (F \<circ> F) g B"
   using assms
 proof (induct B rule: infinite_finite_induct)
   case (infinite A)
   then have "\<not> finite (\<Union>A)" by (blast dest: finite_UnionD)
   with infinite show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert A B)
   then have "finite A" "finite B" "finite (\<Union>B)" "A \<notin> B"
     and "\<forall>x\<in>A \<inter> \<Union>B. g x = \<^bold>1"
     and H: "F g (\<Union>B) = (F \<circ> F) g B" by auto
   then have "F g (A \<union> \<Union>B) = F g A \<^bold>* F g (\<Union>B)"
     by (simp add: union_inter_neutral)
   with \<open>finite B\<close> \<open>A \<notin> B\<close> show ?case
     by (simp add: H)
 qed
 
 lemma swap: "F (\<lambda>i. F (g i) B) A = F (\<lambda>j. F (\<lambda>i. g i j) A) B"
   unfolding cartesian_product
   by (rule reindex_bij_witness [where i = "\<lambda>(i, j). (j, i)" and j = "\<lambda>(i, j). (j, i)"]) auto
 
 lemma swap_restrict:
   "finite A \<Longrightarrow> finite B \<Longrightarrow>
     F (\<lambda>x. F (g x) {y. y \<in> B \<and> R x y}) A = F (\<lambda>y. F (\<lambda>x. g x y) {x. x \<in> A \<and> R x y}) B"
   by (simp add: inter_filter) (rule swap)
 
 lemma image_gen:
   assumes fin: "finite S"
   shows "F h S = F (\<lambda>y. F h {x. x \<in> S \<and> g x = y}) (g ` S)"
 proof -
   have "{y. y\<in> g`S \<and> g x = y} = {g x}" if "x \<in> S" for x
     using that by auto
   then have "F h S = F (\<lambda>x. F (\<lambda>y. h x) {y. y\<in> g`S \<and> g x = y}) S"
     by simp
   also have "\<dots> = F (\<lambda>y. F h {x. x \<in> S \<and> g x = y}) (g ` S)"
     by (rule swap_restrict [OF fin finite_imageI [OF fin]])
   finally show ?thesis .
 qed
 
 lemma group:
   assumes fS: "finite S" and fT: "finite T" and fST: "g ` S \<subseteq> T"
   shows "F (\<lambda>y. F h {x. x \<in> S \<and> g x = y}) T = F h S"
   unfolding image_gen[OF fS, of h g]
   by (auto intro: neutral mono_neutral_right[OF fT fST])
 
 lemma Plus:
   fixes A :: "'b set" and B :: "'c set"
   assumes fin: "finite A" "finite B"
   shows "F g (A <+> B) = F (g \<circ> Inl) A \<^bold>* F (g \<circ> Inr) B"
 proof -
   have "A <+> B = Inl ` A \<union> Inr ` B" by auto
   moreover from fin have "finite (Inl ` A)" "finite (Inr ` B)" by auto
   moreover have "Inl ` A \<inter> Inr ` B = {}" by auto
   moreover have "inj_on Inl A" "inj_on Inr B" by (auto intro: inj_onI)
   ultimately show ?thesis
     using fin by (simp add: union_disjoint reindex)
 qed
 
 lemma same_carrier:
   assumes "finite C"
   assumes subset: "A \<subseteq> C" "B \<subseteq> C"
   assumes trivial: "\<And>a. a \<in> C - A \<Longrightarrow> g a = \<^bold>1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = \<^bold>1"
   shows "F g A = F h B \<longleftrightarrow> F g C = F h C"
 proof -
   have "finite A" and "finite B" and "finite (C - A)" and "finite (C - B)"
     using \<open>finite C\<close> subset by (auto elim: finite_subset)
   from subset have [simp]: "A - (C - A) = A" by auto
   from subset have [simp]: "B - (C - B) = B" by auto
   from subset have "C = A \<union> (C - A)" by auto
   then have "F g C = F g (A \<union> (C - A))" by simp
   also have "\<dots> = F g (A - (C - A)) \<^bold>* F g (C - A - A) \<^bold>* F g (A \<inter> (C - A))"
     using \<open>finite A\<close> \<open>finite (C - A)\<close> by (simp only: union_diff2)
   finally have *: "F g C = F g A" using trivial by simp
   from subset have "C = B \<union> (C - B)" by auto
   then have "F h C = F h (B \<union> (C - B))" by simp
   also have "\<dots> = F h (B - (C - B)) \<^bold>* F h (C - B - B) \<^bold>* F h (B \<inter> (C - B))"
     using \<open>finite B\<close> \<open>finite (C - B)\<close> by (simp only: union_diff2)
   finally have "F h C = F h B"
     using trivial by simp
   with * show ?thesis by simp
 qed
 
 lemma same_carrierI:
   assumes "finite C"
   assumes subset: "A \<subseteq> C" "B \<subseteq> C"
   assumes trivial: "\<And>a. a \<in> C - A \<Longrightarrow> g a = \<^bold>1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = \<^bold>1"
   assumes "F g C = F h C"
   shows "F g A = F h B"
   using assms same_carrier [of C A B] by simp
 
 lemma eq_general:
   assumes B: "\<And>y. y \<in> B \<Longrightarrow> \<exists>!x. x \<in> A \<and> h x = y" and A: "\<And>x. x \<in> A \<Longrightarrow> h x \<in> B \<and> \<gamma>(h x) = \<phi> x"
   shows "F \<phi> A = F \<gamma> B"
 proof -
   have eq: "B = h ` A"
     by (auto dest: assms)
   have h: "inj_on h A"
     using assms by (blast intro: inj_onI)
   have "F \<phi> A = F (\<gamma> \<circ> h) A"
     using A by auto
   also have "\<dots> = F \<gamma> B"
     by (simp add: eq reindex h)
   finally show ?thesis .
 qed
 
 lemma eq_general_inverses:
   assumes B: "\<And>y. y \<in> B \<Longrightarrow> k y \<in> A \<and> h(k y) = y" and A: "\<And>x. x \<in> A \<Longrightarrow> h x \<in> B \<and> k(h x) = x \<and> \<gamma>(h x) = \<phi> x"
   shows "F \<phi> A = F \<gamma> B"
   by (rule eq_general [where h=h]) (force intro: dest: A B)+
 
 subsubsection \<open>HOL Light variant: sum/product indexed by the non-neutral subset\<close>
 text \<open>NB only a subset of the properties above are proved\<close>
 
 definition G :: "['b \<Rightarrow> 'a,'b set] \<Rightarrow> 'a"
   where "G p I \<equiv> if finite {x \<in> I. p x \<noteq> \<^bold>1} then F p {x \<in> I. p x \<noteq> \<^bold>1} else \<^bold>1"
 
 lemma finite_Collect_op:
   shows "\<lbrakk>finite {i \<in> I. x i \<noteq> \<^bold>1}; finite {i \<in> I. y i \<noteq> \<^bold>1}\<rbrakk> \<Longrightarrow> finite {i \<in> I. x i \<^bold>* y i \<noteq> \<^bold>1}"
   apply (rule finite_subset [where B = "{i \<in> I. x i \<noteq> \<^bold>1} \<union> {i \<in> I. y i \<noteq> \<^bold>1}"]) 
   using left_neutral by force+
 
 lemma empty' [simp]: "G p {} = \<^bold>1"
   by (auto simp: G_def)
 
 lemma eq_sum [simp]: "finite I \<Longrightarrow> G p I = F p I"
   by (auto simp: G_def intro: mono_neutral_cong_left)
 
 lemma insert' [simp]:
   assumes "finite {x \<in> I. p x \<noteq> \<^bold>1}"
   shows "G p (insert i I) = (if i \<in> I then G p I else p i \<^bold>* G p I)"
 proof -
   have "{x. x = i \<and> p x \<noteq> \<^bold>1 \<or> x \<in> I \<and> p x \<noteq> \<^bold>1} = (if p i = \<^bold>1 then {x \<in> I. p x \<noteq> \<^bold>1} else insert i {x \<in> I. p x \<noteq> \<^bold>1})"
     by auto
   then show ?thesis
     using assms by (simp add: G_def conj_disj_distribR insert_absorb)
 qed
 
 lemma distrib_triv':
   assumes "finite I"
   shows "G (\<lambda>i. g i \<^bold>* h i) I = G g I \<^bold>* G h I"
   by (simp add: assms local.distrib)
 
 lemma non_neutral': "G g {x \<in> I. g x \<noteq> \<^bold>1} = G g I"
   by (simp add: G_def)
 
 lemma distrib':
   assumes "finite {x \<in> I. g x \<noteq> \<^bold>1}" "finite {x \<in> I. h x \<noteq> \<^bold>1}"
   shows "G (\<lambda>i. g i \<^bold>* h i) I = G g I \<^bold>* G h I"
 proof -
   have "a \<^bold>* a \<noteq> a \<Longrightarrow> a \<noteq> \<^bold>1" for a
     by auto
   then have "G (\<lambda>i. g i \<^bold>* h i) I = G (\<lambda>i. g i \<^bold>* h i) ({i \<in> I. g i \<noteq> \<^bold>1} \<union> {i \<in> I. h i \<noteq> \<^bold>1})"
     using assms  by (force simp: G_def finite_Collect_op intro!: mono_neutral_cong)
   also have "\<dots> = G g I \<^bold>* G h I"
   proof -
     have "F g ({i \<in> I. g i \<noteq> \<^bold>1} \<union> {i \<in> I. h i \<noteq> \<^bold>1}) = G g I"
          "F h ({i \<in> I. g i \<noteq> \<^bold>1} \<union> {i \<in> I. h i \<noteq> \<^bold>1}) = G h I"
       by (auto simp: G_def assms intro: mono_neutral_right)
     then show ?thesis
       using assms by (simp add: distrib)
   qed
   finally show ?thesis .
 qed
 
 lemma cong':
   assumes "A = B"
   assumes g_h: "\<And>x. x \<in> B \<Longrightarrow> g x = h x"
   shows "G g A = G h B"
   using assms by (auto simp: G_def cong: conj_cong intro: cong)
 
 
 lemma mono_neutral_cong_left':
   assumes "S \<subseteq> T"
     and "\<And>i. i \<in> T - S \<Longrightarrow> h i = \<^bold>1"
     and "\<And>x. x \<in> S \<Longrightarrow> g x = h x"
   shows "G g S = G h T"
 proof -
   have *: "{x \<in> S. g x \<noteq> \<^bold>1} = {x \<in> T. h x \<noteq> \<^bold>1}"
     using assms by (metis DiffI subset_eq) 
   then have "finite {x \<in> S. g x \<noteq> \<^bold>1} = finite {x \<in> T. h x \<noteq> \<^bold>1}"
     by simp
   then show ?thesis
     using assms by (auto simp add: G_def * intro: cong)
 qed
 
 lemma mono_neutral_cong_right':
   "S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> g x = h x) \<Longrightarrow>
     G g T = G h S"
   by (auto intro!: mono_neutral_cong_left' [symmetric])
 
 lemma mono_neutral_left': "S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> G g S = G g T"
   by (blast intro: mono_neutral_cong_left')
 
 lemma mono_neutral_right': "S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> G g T = G g S"
   by (blast intro!: mono_neutral_left' [symmetric])
 
 end
 
 
 subsection \<open>Generalized summation over a set\<close>
 
 context comm_monoid_add
 begin
 
 sublocale sum: comm_monoid_set plus 0
   defines sum = sum.F and sum' = sum.G ..
 
 abbreviation Sum ("\<Sum>")
   where "\<Sum> \<equiv> sum (\<lambda>x. x)"
 
 end
 
 text \<open>Now: lots of fancy syntax. First, \<^term>\<open>sum (\<lambda>x. e) A\<close> is written \<open>\<Sum>x\<in>A. e\<close>.\<close>
 
 syntax (ASCII)
   "_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(3SUM (_/:_)./ _)" [0, 51, 10] 10)
 syntax
   "_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(2\<Sum>(_/\<in>_)./ _)" [0, 51, 10] 10)
 translations \<comment> \<open>Beware of argument permutation!\<close>
   "\<Sum>i\<in>A. b" \<rightleftharpoons> "CONST sum (\<lambda>i. b) A"
 
 text \<open>Instead of \<^term>\<open>\<Sum>x\<in>{x. P}. e\<close> we introduce the shorter \<open>\<Sum>x|P. e\<close>.\<close>
 
 syntax (ASCII)
   "_qsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(3SUM _ |/ _./ _)" [0, 0, 10] 10)
 syntax
   "_qsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(2\<Sum>_ | (_)./ _)" [0, 0, 10] 10)
 translations
   "\<Sum>x|P. t" => "CONST sum (\<lambda>x. t) {x. P}"
 
 print_translation \<open>
 let
   fun sum_tr' [Abs (x, Tx, t), Const (\<^const_syntax>\<open>Collect\<close>, _) $ Abs (y, Ty, P)] =
         if x <> y then raise Match
         else
           let
             val x' = Syntax_Trans.mark_bound_body (x, Tx);
             val t' = subst_bound (x', t);
             val P' = subst_bound (x', P);
           in
             Syntax.const \<^syntax_const>\<open>_qsum\<close> $ Syntax_Trans.mark_bound_abs (x, Tx) $ P' $ t'
           end
     | sum_tr' _ = raise Match;
 in [(\<^const_syntax>\<open>sum\<close>, K sum_tr')] end
 \<close>
 
 
 subsubsection \<open>Properties in more restricted classes of structures\<close>
 
 lemma sum_Un:
   "finite A \<Longrightarrow> finite B \<Longrightarrow> sum f (A \<union> B) = sum f A + sum f B - sum f (A \<inter> B)"
   for f :: "'b \<Rightarrow> 'a::ab_group_add"
   by (subst sum.union_inter [symmetric]) (auto simp add: algebra_simps)
 
 lemma sum_Un2:
   assumes "finite (A \<union> B)"
   shows "sum f (A \<union> B) = sum f (A - B) + sum f (B - A) + sum f (A \<inter> B)"
 proof -
   have "A \<union> B = A - B \<union> (B - A) \<union> A \<inter> B"
     by auto
   with assms show ?thesis
     by simp (subst sum.union_disjoint, auto)+
 qed
 
 lemma sum_diff1:
   fixes f :: "'b \<Rightarrow> 'a::ab_group_add"
   assumes "finite A"
   shows "sum f (A - {a}) = (if a \<in> A then sum f A - f a else sum f A)"
   using assms by induct (auto simp: insert_Diff_if)
 
 lemma sum_diff:
   fixes f :: "'b \<Rightarrow> 'a::ab_group_add"
   assumes "finite A" "B \<subseteq> A"
   shows "sum f (A - B) = sum f A - sum f B"
 proof -
   from assms(2,1) have "finite B" by (rule finite_subset)
   from this \<open>B \<subseteq> A\<close>
   show ?thesis
   proof induct
     case empty
     thus ?case by simp
   next
     case (insert x F)
     with \<open>finite A\<close> \<open>finite B\<close> show ?case
       by (simp add: Diff_insert[where a=x and B=F] sum_diff1 insert_absorb)
   qed
 qed
 
 lemma sum_diff1'_aux:
   fixes f :: "'a \<Rightarrow> 'b::ab_group_add"
   assumes "finite F" "{i \<in> I. f i \<noteq> 0} \<subseteq> F"
   shows "sum' f (I - {i}) = (if i \<in> I then sum' f I - f i else sum' f I)"
   using assms
 proof induct
   case (insert x F)
   have 1: "finite {x \<in> I. f x \<noteq> 0} \<Longrightarrow> finite {x \<in> I. x \<noteq> i \<and> f x \<noteq> 0}"
     by (erule rev_finite_subset) auto
   have 2: "finite {x \<in> I. x \<noteq> i \<and> f x \<noteq> 0} \<Longrightarrow> finite {x \<in> I. f x \<noteq> 0}"
     apply (drule finite_insert [THEN iffD2])
     by (erule rev_finite_subset) auto
   have 3: "finite {i \<in> I. f i \<noteq> 0}"
     using finite_subset insert by blast
   show ?case
     using insert sum_diff1 [of "{i \<in> I. f i \<noteq> 0}" f i]
     by (auto simp: sum.G_def 1 2 3 set_diff_eq conj_ac)
 qed (simp add: sum.G_def)
 
 lemma sum_diff1':
   fixes f :: "'a \<Rightarrow> 'b::ab_group_add"
   assumes "finite {i \<in> I. f i \<noteq> 0}"
   shows "sum' f (I - {i}) = (if i \<in> I then sum' f I - f i else sum' f I)"
   by (rule sum_diff1'_aux [OF assms order_refl])
 
 lemma (in ordered_comm_monoid_add) sum_mono:
   "(\<And>i. i\<in>K \<Longrightarrow> f i \<le> g i) \<Longrightarrow> (\<Sum>i\<in>K. f i) \<le> (\<Sum>i\<in>K. g i)"
   by (induct K rule: infinite_finite_induct) (use add_mono in auto)
 
 lemma (in strict_ordered_comm_monoid_add) sum_strict_mono:
   assumes "finite A" "A \<noteq> {}"
     and "\<And>x. x \<in> A \<Longrightarrow> f x < g x"
   shows "sum f A < sum g A"
   using assms
 proof (induct rule: finite_ne_induct)
   case singleton
   then show ?case by simp
 next
   case insert
   then show ?case by (auto simp: add_strict_mono)
 qed
 
 lemma sum_strict_mono_ex1:
   fixes f g :: "'i \<Rightarrow> 'a::ordered_cancel_comm_monoid_add"
   assumes "finite A"
     and "\<forall>x\<in>A. f x \<le> g x"
     and "\<exists>a\<in>A. f a < g a"
   shows "sum f A < sum g A"
 proof-
   from assms(3) obtain a where a: "a \<in> A" "f a < g a" by blast
   have "sum f A = sum f ((A - {a}) \<union> {a})"
     by(simp add: insert_absorb[OF \<open>a \<in> A\<close>])
   also have "\<dots> = sum f (A - {a}) + sum f {a}"
     using \<open>finite A\<close> by(subst sum.union_disjoint) auto
   also have "sum f (A - {a}) \<le> sum g (A - {a})"
     by (rule sum_mono) (simp add: assms(2))
   also from a have "sum f {a} < sum g {a}" by simp
   also have "sum g (A - {a}) + sum g {a} = sum g((A - {a}) \<union> {a})"
     using \<open>finite A\<close> by (subst sum.union_disjoint[symmetric]) auto
   also have "\<dots> = sum g A" by (simp add: insert_absorb[OF \<open>a \<in> A\<close>])
   finally show ?thesis
     by (auto simp add: add_right_mono add_strict_left_mono)
 qed
 
 lemma sum_mono_inv:
   fixes f g :: "'i \<Rightarrow> 'a :: ordered_cancel_comm_monoid_add"
   assumes eq: "sum f I = sum g I"
   assumes le: "\<And>i. i \<in> I \<Longrightarrow> f i \<le> g i"
   assumes i: "i \<in> I"
   assumes I: "finite I"
   shows "f i = g i"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   with le[OF i] have "f i < g i" by simp
   with i have "\<exists>i\<in>I. f i < g i" ..
   from sum_strict_mono_ex1[OF I _ this] le have "sum f I < sum g I"
     by blast
   with eq show False by simp
 qed
 
 lemma member_le_sum:
   fixes f :: "_ \<Rightarrow> 'b::{semiring_1, ordered_comm_monoid_add}"
   assumes "i \<in> A"
     and le: "\<And>x. x \<in> A - {i} \<Longrightarrow> 0 \<le> f x"
     and "finite A"
   shows "f i \<le> sum f A"
 proof -
   have "f i \<le> sum f (A \<inter> {i})"
     by (simp add: assms)
   also have "... = (\<Sum>x\<in>A. if x \<in> {i} then f x else 0)"
     using assms sum.inter_restrict by blast
   also have "... \<le> sum f A"
     apply (rule sum_mono)
     apply (auto simp: le)
     done
   finally show ?thesis .
 qed
 
 lemma sum_negf: "(\<Sum>x\<in>A. - f x) = - (\<Sum>x\<in>A. f x)"
   for f :: "'b \<Rightarrow> 'a::ab_group_add"
   by (induct A rule: infinite_finite_induct) auto
 
 lemma sum_subtractf: "(\<Sum>x\<in>A. f x - g x) = (\<Sum>x\<in>A. f x) - (\<Sum>x\<in>A. g x)"
   for f g :: "'b \<Rightarrow>'a::ab_group_add"
   using sum.distrib [of f "- g" A] by (simp add: sum_negf)
 
 lemma sum_subtractf_nat:
   "(\<And>x. x \<in> A \<Longrightarrow> g x \<le> f x) \<Longrightarrow> (\<Sum>x\<in>A. f x - g x) = (\<Sum>x\<in>A. f x) - (\<Sum>x\<in>A. g x)"
   for f g :: "'a \<Rightarrow> nat"
   by (induct A rule: infinite_finite_induct) (auto simp: sum_mono)
 
 context ordered_comm_monoid_add
 begin
 
 lemma sum_nonneg: "(\<And>x. x \<in> A \<Longrightarrow> 0 \<le> f x) \<Longrightarrow> 0 \<le> sum f A"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then have "0 + 0 \<le> f x + sum f F" by (blast intro: add_mono)
   with insert show ?case by simp
 qed
 
 lemma sum_nonpos: "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> 0) \<Longrightarrow> sum f A \<le> 0"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then have "f x + sum f F \<le> 0 + 0" by (blast intro: add_mono)
   with insert show ?case by simp
 qed
 
 lemma sum_nonneg_eq_0_iff:
   "finite A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> 0 \<le> f x) \<Longrightarrow> sum f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
   by (induct set: finite) (simp_all add: add_nonneg_eq_0_iff sum_nonneg)
 
 lemma sum_nonneg_0:
   "finite s \<Longrightarrow> (\<And>i. i \<in> s \<Longrightarrow> f i \<ge> 0) \<Longrightarrow> (\<Sum> i \<in> s. f i) = 0 \<Longrightarrow> i \<in> s \<Longrightarrow> f i = 0"
   by (simp add: sum_nonneg_eq_0_iff)
 
 lemma sum_nonneg_leq_bound:
   assumes "finite s" "\<And>i. i \<in> s \<Longrightarrow> f i \<ge> 0" "(\<Sum>i \<in> s. f i) = B" "i \<in> s"
   shows "f i \<le> B"
 proof -
   from assms have "f i \<le> f i + (\<Sum>i \<in> s - {i}. f i)"
     by (intro add_increasing2 sum_nonneg) auto
   also have "\<dots> = B"
     using sum.remove[of s i f] assms by simp
   finally show ?thesis by auto
 qed
 
 lemma sum_mono2:
   assumes fin: "finite B"
     and sub: "A \<subseteq> B"
     and nn: "\<And>b. b \<in> B-A \<Longrightarrow> 0 \<le> f b"
   shows "sum f A \<le> sum f B"
 proof -
   have "sum f A \<le> sum f A + sum f (B-A)"
     by (auto intro: add_increasing2 [OF sum_nonneg] nn)
   also from fin finite_subset[OF sub fin] have "\<dots> = sum f (A \<union> (B-A))"
     by (simp add: sum.union_disjoint del: Un_Diff_cancel)
   also from sub have "A \<union> (B-A) = B" by blast
   finally show ?thesis .
 qed
 
 lemma sum_le_included:
   assumes "finite s" "finite t"
   and "\<forall>y\<in>t. 0 \<le> g y" "(\<forall>x\<in>s. \<exists>y\<in>t. i y = x \<and> f x \<le> g y)"
   shows "sum f s \<le> sum g t"
 proof -
   have "sum f s \<le> sum (\<lambda>y. sum g {x. x\<in>t \<and> i x = y}) s"
   proof (rule sum_mono)
     fix y
     assume "y \<in> s"
     with assms obtain z where z: "z \<in> t" "y = i z" "f y \<le> g z" by auto
     with assms show "f y \<le> sum g {x \<in> t. i x = y}" (is "?A y \<le> ?B y")
       using order_trans[of "?A (i z)" "sum g {z}" "?B (i z)", intro]
       by (auto intro!: sum_mono2)
   qed
   also have "\<dots> \<le> sum (\<lambda>y. sum g {x. x\<in>t \<and> i x = y}) (i ` t)"
     using assms(2-4) by (auto intro!: sum_mono2 sum_nonneg)
   also have "\<dots> \<le> sum g t"
     using assms by (auto simp: sum.image_gen[symmetric])
   finally show ?thesis .
 qed
 
 end
 
 lemma (in canonically_ordered_monoid_add) sum_eq_0_iff [simp]:
   "finite F \<Longrightarrow> (sum f F = 0) = (\<forall>a\<in>F. f a = 0)"
   by (intro ballI sum_nonneg_eq_0_iff zero_le)
 
 context semiring_0
 begin
 
 lemma sum_distrib_left: "r * sum f A = (\<Sum>n\<in>A. r * f n)"
   by (induct A rule: infinite_finite_induct) (simp_all add: algebra_simps)
 
 lemma sum_distrib_right: "sum f A * r = (\<Sum>n\<in>A. f n * r)"
   by (induct A rule: infinite_finite_induct) (simp_all add: algebra_simps)
 
 end
 
 lemma sum_divide_distrib: "sum f A / r = (\<Sum>n\<in>A. f n / r)"
   for r :: "'a::field"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case by (simp add: add_divide_distrib)
 qed
 
 lemma sum_abs[iff]: "\<bar>sum f A\<bar> \<le> sum (\<lambda>i. \<bar>f i\<bar>) A"
   for f :: "'a \<Rightarrow> 'b::ordered_ab_group_add_abs"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case by (auto intro: abs_triangle_ineq order_trans)
 qed
 
 lemma sum_abs_ge_zero[iff]: "0 \<le> sum (\<lambda>i. \<bar>f i\<bar>) A"
   for f :: "'a \<Rightarrow> 'b::ordered_ab_group_add_abs"
   by (simp add: sum_nonneg)
 
 lemma abs_sum_abs[simp]: "\<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar> = (\<Sum>a\<in>A. \<bar>f a\<bar>)"
   for f :: "'a \<Rightarrow> 'b::ordered_ab_group_add_abs"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert a A)
   then have "\<bar>\<Sum>a\<in>insert a A. \<bar>f a\<bar>\<bar> = \<bar>\<bar>f a\<bar> + (\<Sum>a\<in>A. \<bar>f a\<bar>)\<bar>" by simp
   also from insert have "\<dots> = \<bar>\<bar>f a\<bar> + \<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar>\<bar>" by simp
   also have "\<dots> = \<bar>f a\<bar> + \<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar>" by (simp del: abs_of_nonneg)
   also from insert have "\<dots> = (\<Sum>a\<in>insert a A. \<bar>f a\<bar>)" by simp
   finally show ?case .
 qed
 
 lemma sum_product:
   fixes f :: "'a \<Rightarrow> 'b::semiring_0"
   shows "sum f A * sum g B = (\<Sum>i\<in>A. \<Sum>j\<in>B. f i * g j)"
   by (simp add: sum_distrib_left sum_distrib_right) (rule sum.swap)
 
 lemma sum_mult_sum_if_inj:
   fixes f :: "'a \<Rightarrow> 'b::semiring_0"
   shows "inj_on (\<lambda>(a, b). f a * g b) (A \<times> B) \<Longrightarrow>
     sum f A * sum g B = sum id {f a * g b |a b. a \<in> A \<and> b \<in> B}"
   by(auto simp: sum_product sum.cartesian_product intro!: sum.reindex_cong[symmetric])
 
 lemma sum_SucD: "sum f A = Suc n \<Longrightarrow> \<exists>a\<in>A. 0 < f a"
   by (induct A rule: infinite_finite_induct) auto
 
 lemma sum_eq_Suc0_iff:
   "finite A \<Longrightarrow> sum f A = Suc 0 \<longleftrightarrow> (\<exists>a\<in>A. f a = Suc 0 \<and> (\<forall>b\<in>A. a \<noteq> b \<longrightarrow> f b = 0))"
   by (induct A rule: finite_induct) (auto simp add: add_is_1)
 
 lemmas sum_eq_1_iff = sum_eq_Suc0_iff[simplified One_nat_def[symmetric]]
 
 lemma sum_Un_nat:
   "finite A \<Longrightarrow> finite B \<Longrightarrow> sum f (A \<union> B) = sum f A + sum f B - sum f (A \<inter> B)"
   for f :: "'a \<Rightarrow> nat"
   \<comment> \<open>For the natural numbers, we have subtraction.\<close>
   by (subst sum.union_inter [symmetric]) (auto simp: algebra_simps)
 
 lemma sum_diff1_nat: "sum f (A - {a}) = (if a \<in> A then sum f A - f a else sum f A)"
   for f :: "'a \<Rightarrow> nat"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case
     apply (auto simp: insert_Diff_if)
     apply (drule mk_disjoint_insert)
     apply auto
     done
 qed
 
 lemma sum_diff_nat:
   fixes f :: "'a \<Rightarrow> nat"
   assumes "finite B" and "B \<subseteq> A"
   shows "sum f (A - B) = sum f A - sum f B"
   using assms
 proof induct
   case empty
   then show ?case by simp
 next
   case (insert x F)
   note IH = \<open>F \<subseteq> A \<Longrightarrow> sum f (A - F) = sum f A - sum f F\<close>
   from \<open>x \<notin> F\<close> \<open>insert x F \<subseteq> A\<close> have "x \<in> A - F" by simp
   then have A: "sum f ((A - F) - {x}) = sum f (A - F) - f x"
     by (simp add: sum_diff1_nat)
   from \<open>insert x F \<subseteq> A\<close> have "F \<subseteq> A" by simp
   with IH have "sum f (A - F) = sum f A - sum f F" by simp
   with A have B: "sum f ((A - F) - {x}) = sum f A - sum f F - f x"
     by simp
   from \<open>x \<notin> F\<close> have "A - insert x F = (A - F) - {x}" by auto
   with B have C: "sum f (A - insert x F) = sum f A - sum f F - f x"
     by simp
   from \<open>finite F\<close> \<open>x \<notin> F\<close> have "sum f (insert x F) = sum f F + f x"
     by simp
   with C have "sum f (A - insert x F) = sum f A - sum f (insert x F)"
     by simp
   then show ?case by simp
 qed
 
 lemma sum_comp_morphism:
   "h 0 = 0 \<Longrightarrow> (\<And>x y. h (x + y) = h x + h y) \<Longrightarrow> sum (h \<circ> g) A = h (sum g A)"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma (in comm_semiring_1) dvd_sum: "(\<And>a. a \<in> A \<Longrightarrow> d dvd f a) \<Longrightarrow> d dvd sum f A"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma (in ordered_comm_monoid_add) sum_pos:
   "finite I \<Longrightarrow> I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> 0 < f i) \<Longrightarrow> 0 < sum f I"
   by (induct I rule: finite_ne_induct) (auto intro: add_pos_pos)
 
 lemma (in ordered_comm_monoid_add) sum_pos2:
   assumes I: "finite I" "i \<in> I" "0 < f i" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> f i"
   shows "0 < sum f I"
 proof -
   have "0 < f i + sum f (I - {i})"
     using assms by (intro add_pos_nonneg sum_nonneg) auto
   also have "\<dots> = sum f I"
     using assms by (simp add: sum.remove)
   finally show ?thesis .
 qed
 
 lemma sum_strict_mono2:
   fixes f :: "'a \<Rightarrow> 'b::ordered_cancel_comm_monoid_add"
   assumes "finite B" "A \<subseteq> B" "b \<in> B-A" "f b > 0" and "\<And>x. x \<in> B \<Longrightarrow> f x \<ge> 0"
   shows "sum f A < sum f B"
 proof -
   have "B - A \<noteq> {}"
     using assms(3) by blast
   have "sum f (B-A) > 0"
     by (rule sum_pos2) (use assms in auto)
   moreover have "sum f B = sum f (B-A) + sum f A"
     by (rule sum.subset_diff) (use assms in auto)
   ultimately show ?thesis
     using add_strict_increasing by auto
 qed
 
 lemma sum_cong_Suc:
   assumes "0 \<notin> A" "\<And>x. Suc x \<in> A \<Longrightarrow> f (Suc x) = g (Suc x)"
   shows "sum f A = sum g A"
 proof (rule sum.cong)
   fix x
   assume "x \<in> A"
   with assms(1) show "f x = g x"
     by (cases x) (auto intro!: assms(2))
 qed simp_all
 
 
 subsubsection \<open>Cardinality as special case of \<^const>\<open>sum\<close>\<close>
 
 lemma card_eq_sum: "card A = sum (\<lambda>x. 1) A"
 proof -
   have "plus \<circ> (\<lambda>_. Suc 0) = (\<lambda>_. Suc)"
     by (simp add: fun_eq_iff)
   then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) = Finite_Set.fold (\<lambda>_. Suc)"
     by (rule arg_cong)
   then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) 0 A = Finite_Set.fold (\<lambda>_. Suc) 0 A"
     by (blast intro: fun_cong)
   then show ?thesis
     by (simp add: card.eq_fold sum.eq_fold)
 qed
 
 context semiring_1
 begin
 
 lemma sum_constant [simp]:
   "(\<Sum>x \<in> A. y) = of_nat (card A) * y"
   by (induct A rule: infinite_finite_induct) (simp_all add: algebra_simps)
 
 context
   fixes A
   assumes \<open>finite A\<close>
 begin
 
 lemma sum_of_bool_eq [simp]:
   \<open>(\<Sum>x \<in> A. of_bool (P x)) = of_nat (card (A \<inter> {x. P x}))\<close> if \<open>finite A\<close>
   using \<open>finite A\<close> by induction simp_all
 
 lemma sum_mult_of_bool_eq [simp]:
   \<open>(\<Sum>x \<in> A. f x * of_bool (P x)) = (\<Sum>x \<in> (A \<inter> {x. P x}). f x)\<close>
   by (rule sum.mono_neutral_cong) (use \<open>finite A\<close> in auto)
 
 lemma sum_of_bool_mult_eq [simp]:
   \<open>(\<Sum>x \<in> A. of_bool (P x) * f x) = (\<Sum>x \<in> (A \<inter> {x. P x}). f x)\<close>
   by (rule sum.mono_neutral_cong) (use \<open>finite A\<close> in auto)
 
 end
 
 end
 
 lemma sum_Suc: "sum (\<lambda>x. Suc(f x)) A = sum f A + card A"
   using sum.distrib[of f "\<lambda>_. 1" A] by simp
 
 lemma sum_bounded_above:
   fixes K :: "'a::{semiring_1,ordered_comm_monoid_add}"
   assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> K"
   shows "sum f A \<le> of_nat (card A) * K"
 proof (cases "finite A")
   case True
   then show ?thesis
     using le sum_mono[where K=A and g = "\<lambda>x. K"] by simp
 next
   case False
   then show ?thesis by simp
 qed
 
 lemma sum_bounded_above_divide:
   fixes K :: "'a::linordered_field"
   assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> K / of_nat (card A)" and fin: "finite A" "A \<noteq> {}"
   shows "sum f A \<le> K"
   using sum_bounded_above [of A f "K / of_nat (card A)", OF le] fin by simp
 
 lemma sum_bounded_above_strict:
   fixes K :: "'a::{ordered_cancel_comm_monoid_add,semiring_1}"
   assumes "\<And>i. i\<in>A \<Longrightarrow> f i < K" "card A > 0"
   shows "sum f A < of_nat (card A) * K"
   using assms sum_strict_mono[where A=A and g = "\<lambda>x. K"]
   by (simp add: card_gt_0_iff)
 
 lemma sum_bounded_below:
   fixes K :: "'a::{semiring_1,ordered_comm_monoid_add}"
   assumes le: "\<And>i. i\<in>A \<Longrightarrow> K \<le> f i"
   shows "of_nat (card A) * K \<le> sum f A"
 proof (cases "finite A")
   case True
   then show ?thesis
     using le sum_mono[where K=A and f = "\<lambda>x. K"] by simp
 next
   case False
   then show ?thesis by simp
 qed
 
 lemma convex_sum_bound_le:
   fixes x :: "'a \<Rightarrow> 'b::linordered_idom"
   assumes 0: "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> x i" and 1: "sum x I = 1"
       and \<delta>: "\<And>i. i \<in> I \<Longrightarrow> \<bar>a i - b\<bar> \<le> \<delta>"
     shows "\<bar>(\<Sum>i\<in>I. a i * x i) - b\<bar> \<le> \<delta>"
 proof -
   have [simp]: "(\<Sum>i\<in>I. c * x i) = c" for c
     by (simp flip: sum_distrib_left 1)
   then have "\<bar>(\<Sum>i\<in>I. a i * x i) - b\<bar> = \<bar>\<Sum>i\<in>I. (a i - b) * x i\<bar>"
     by (simp add: sum_subtractf left_diff_distrib)
   also have "\<dots> \<le> (\<Sum>i\<in>I. \<bar>(a i - b) * x i\<bar>)"
     using abs_abs abs_of_nonneg by blast
   also have "\<dots> \<le> (\<Sum>i\<in>I. \<bar>(a i - b)\<bar> * x i)"
     by (simp add: abs_mult 0)
   also have "\<dots> \<le> (\<Sum>i\<in>I. \<delta> * x i)"
     by (rule sum_mono) (use \<delta> "0" mult_right_mono in blast)
   also have "\<dots> = \<delta>"
     by simp
   finally show ?thesis .
 qed
 
 lemma card_UN_disjoint:
   assumes "finite I" and "\<forall>i\<in>I. finite (A i)"
     and "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}"
   shows "card (\<Union>(A ` I)) = (\<Sum>i\<in>I. card(A i))"
 proof -
   have "(\<Sum>i\<in>I. card (A i)) = (\<Sum>i\<in>I. \<Sum>x\<in>A i. 1)"
     by simp
   with assms show ?thesis
     by (simp add: card_eq_sum sum.UNION_disjoint del: sum_constant)
 qed
 
 lemma card_Union_disjoint:
   assumes "pairwise disjnt C" and fin: "\<And>A. A \<in> C \<Longrightarrow> finite A"
   shows "card (\<Union>C) = sum card C"
 proof (cases "finite C")
   case True
   then show ?thesis
     using card_UN_disjoint [OF True, of "\<lambda>x. x"] assms
     by (simp add: disjnt_def fin pairwise_def)
 next
   case False
   then show ?thesis
     using assms card_eq_0_iff finite_UnionD by fastforce
 qed
 
 lemma card_Union_le_sum_card:
   fixes U :: "'a set set"
   assumes "\<forall>u \<in> U. finite u"
   shows "card (\<Union>U) \<le> sum card U"
 proof (cases "finite U")
   case False
   then show "card (\<Union>U) \<le> sum card U"
     using card_eq_0_iff finite_UnionD by auto
 next
   case True
   then show "card (\<Union>U) \<le> sum card U"
   proof (induct U rule: finite_induct)
     case empty
     then show ?case by auto
   next
     case (insert x F)
     then have "card(\<Union>(insert x F)) \<le> card(x) + card (\<Union>F)" using card_Un_le by auto
     also have "... \<le> card(x) + sum card F" using insert.hyps by auto
     also have "... = sum card (insert x F)" using sum.insert_if and insert.hyps by auto
     finally show ?case .
   qed
 qed
 
 lemma card_UN_le:
   assumes "finite I"
   shows "card(\<Union>i\<in>I. A i) \<le> (\<Sum>i\<in>I. card(A i))"
   using assms
 proof induction
   case (insert i I)
   then show ?case
     using card_Un_le nat_add_left_cancel_le by (force intro: order_trans) 
 qed auto
 
 lemma sum_multicount_gen:
   assumes "finite s" "finite t" "\<forall>j\<in>t. (card {i\<in>s. R i j} = k j)"
   shows "sum (\<lambda>i. (card {j\<in>t. R i j})) s = sum k t"
     (is "?l = ?r")
 proof-
   have "?l = sum (\<lambda>i. sum (\<lambda>x.1) {j\<in>t. R i j}) s"
     by auto
   also have "\<dots> = ?r"
     unfolding sum.swap_restrict [OF assms(1-2)]
     using assms(3) by auto
   finally show ?thesis .
 qed
 
 lemma sum_multicount:
   assumes "finite S" "finite T" "\<forall>j\<in>T. (card {i\<in>S. R i j} = k)"
   shows "sum (\<lambda>i. card {j\<in>T. R i j}) S = k * card T" (is "?l = ?r")
 proof-
   have "?l = sum (\<lambda>i. k) T"
     by (rule sum_multicount_gen) (auto simp: assms)
   also have "\<dots> = ?r" by (simp add: mult.commute)
   finally show ?thesis by auto
 qed
 
 lemma sum_card_image:
   assumes "finite A"
   assumes "pairwise (\<lambda>s t. disjnt (f s) (f t)) A"
   shows "sum card (f ` A) = sum (\<lambda>a. card (f a)) A"
 using assms
 proof (induct A)
   case (insert a A)
   show ?case
   proof cases
     assume "f a = {}"
     with insert show ?case
       by (subst sum.mono_neutral_right[where S="f ` A"]) (auto simp: pairwise_insert)
   next
     assume "f a \<noteq> {}"
     then have "sum card (insert (f a) (f ` A)) = card (f a) + sum card (f ` A)"
       using insert
       by (subst sum.insert) (auto simp: pairwise_insert)
     with insert show ?case by (simp add: pairwise_insert)
   qed
 qed simp
 
 
 subsubsection \<open>Cardinality of products\<close>
 
 lemma card_SigmaI [simp]:
   "finite A \<Longrightarrow> \<forall>a\<in>A. finite (B a) \<Longrightarrow> card (SIGMA x: A. B x) = (\<Sum>a\<in>A. card (B a))"
   by (simp add: card_eq_sum sum.Sigma del: sum_constant)
 
 (*
 lemma SigmaI_insert: "y \<notin> A ==>
   (SIGMA x:(insert y A). B x) = (({y} \<times> (B y)) \<union> (SIGMA x: A. B x))"
   by auto
 *)
 
 lemma card_cartesian_product: "card (A \<times> B) = card A * card B"
   by (cases "finite A \<and> finite B")
     (auto simp add: card_eq_0_iff dest: finite_cartesian_productD1 finite_cartesian_productD2)
 
 lemma card_cartesian_product_singleton:  "card ({x} \<times> A) = card A"
   by (simp add: card_cartesian_product)
 
 
 subsection \<open>Generalized product over a set\<close>
 
 context comm_monoid_mult
 begin
 
 sublocale prod: comm_monoid_set times 1
   defines prod = prod.F and prod' = prod.G ..
 
 abbreviation Prod ("\<Prod>_" [1000] 999)
   where "\<Prod>A \<equiv> prod (\<lambda>x. x) A"
 
 end
 
 syntax (ASCII)
   "_prod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(4PROD (_/:_)./ _)" [0, 51, 10] 10)
 syntax
   "_prod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(2\<Prod>(_/\<in>_)./ _)" [0, 51, 10] 10)
 translations \<comment> \<open>Beware of argument permutation!\<close>
   "\<Prod>i\<in>A. b" == "CONST prod (\<lambda>i. b) A"
 
 text \<open>Instead of \<^term>\<open>\<Prod>x\<in>{x. P}. e\<close> we introduce the shorter \<open>\<Prod>x|P. e\<close>.\<close>
 
 syntax (ASCII)
   "_qprod" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(4PROD _ |/ _./ _)" [0, 0, 10] 10)
 syntax
   "_qprod" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(2\<Prod>_ | (_)./ _)" [0, 0, 10] 10)
 translations
   "\<Prod>x|P. t" => "CONST prod (\<lambda>x. t) {x. P}"
 
 context comm_monoid_mult
 begin
 
 lemma prod_dvd_prod: "(\<And>a. a \<in> A \<Longrightarrow> f a dvd g a) \<Longrightarrow> prod f A dvd prod g A"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by (auto intro: dvdI)
 next
   case empty
   then show ?case by (auto intro: dvdI)
 next
   case (insert a A)
   then have "f a dvd g a" and "prod f A dvd prod g A"
     by simp_all
   then obtain r s where "g a = f a * r" and "prod g A = prod f A * s"
     by (auto elim!: dvdE)
   then have "g a * prod g A = f a * prod f A * (r * s)"
     by (simp add: ac_simps)
   with insert.hyps show ?case
     by (auto intro: dvdI)
 qed
 
 lemma prod_dvd_prod_subset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> prod f A dvd prod f B"
   by (auto simp add: prod.subset_diff ac_simps intro: dvdI)
 
 end
 
 
 subsubsection \<open>Properties in more restricted classes of structures\<close>
 
 context linordered_nonzero_semiring
 begin
 
 lemma prod_ge_1: "(\<And>x. x \<in> A \<Longrightarrow> 1 \<le> f x) \<Longrightarrow> 1 \<le> prod f A"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert x F)
   have "1 * 1 \<le> f x * prod f F"
     by (rule mult_mono') (use insert in auto)
   with insert show ?case by simp
 qed
 
 lemma prod_le_1:
   fixes f :: "'b \<Rightarrow> 'a"
   assumes "\<And>x. x \<in> A \<Longrightarrow> 0 \<le> f x \<and> f x \<le> 1"
   shows "prod f A \<le> 1"
     using assms
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case by (force simp: mult.commute intro: dest: mult_le_one)
 qed
 
 end
 
 context comm_semiring_1
 begin
 
 lemma dvd_prod_eqI [intro]:
   assumes "finite A" and "a \<in> A" and "b = f a"
   shows "b dvd prod f A"
 proof -
   from \<open>finite A\<close> have "prod f (insert a (A - {a})) = f a * prod f (A - {a})"
     by (intro prod.insert) auto
   also from \<open>a \<in> A\<close> have "insert a (A - {a}) = A"
     by blast
   finally have "prod f A = f a * prod f (A - {a})" .
   with \<open>b = f a\<close> show ?thesis
     by simp
 qed
 
 lemma dvd_prodI [intro]: "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> f a dvd prod f A"
   by auto
 
 lemma prod_zero:
   assumes "finite A" and "\<exists>a\<in>A. f a = 0"
   shows "prod f A = 0"
   using assms
 proof (induct A)
   case empty
   then show ?case by simp
 next
   case (insert a A)
   then have "f a = 0 \<or> (\<exists>a\<in>A. f a = 0)" by simp
   then have "f a * prod f A = 0" by rule (simp_all add: insert)
   with insert show ?case by simp
 qed
 
 lemma prod_dvd_prod_subset2:
   assumes "finite B" and "A \<subseteq> B" and "\<And>a. a \<in> A \<Longrightarrow> f a dvd g a"
   shows "prod f A dvd prod g B"
 proof -
   from assms have "prod f A dvd prod g A"
     by (auto intro: prod_dvd_prod)
   moreover from assms have "prod g A dvd prod g B"
     by (auto intro: prod_dvd_prod_subset)
   ultimately show ?thesis by (rule dvd_trans)
 qed
 
 end
 
 lemma (in semidom) prod_zero_iff [simp]:
   fixes f :: "'b \<Rightarrow> 'a"
   assumes "finite A"
   shows "prod f A = 0 \<longleftrightarrow> (\<exists>a\<in>A. f a = 0)"
   using assms by (induct A) (auto simp: no_zero_divisors)
 
 lemma (in semidom_divide) prod_diff1:
   assumes "finite A" and "f a \<noteq> 0"
   shows "prod f (A - {a}) = (if a \<in> A then prod f A div f a else prod f A)"
 proof (cases "a \<notin> A")
   case True
   then show ?thesis by simp
 next
   case False
   with assms show ?thesis
   proof induct
     case empty
     then show ?case by simp
   next
     case (insert b B)
     then show ?case
     proof (cases "a = b")
       case True
       with insert show ?thesis by simp
     next
       case False
       with insert have "a \<in> B" by simp
       define C where "C = B - {a}"
       with \<open>finite B\<close> \<open>a \<in> B\<close> have "B = insert a C" "finite C" "a \<notin> C"
         by auto
       with insert show ?thesis
         by (auto simp add: insert_commute ac_simps)
     qed
   qed
 qed
 
 lemma sum_zero_power [simp]: "(\<Sum>i\<in>A. c i * 0^i) = (if finite A \<and> 0 \<in> A then c 0 else 0)"
   for c :: "nat \<Rightarrow> 'a::division_ring"
   by (induct A rule: infinite_finite_induct) auto
 
 lemma sum_zero_power' [simp]:
   "(\<Sum>i\<in>A. c i * 0^i / d i) = (if finite A \<and> 0 \<in> A then c 0 / d 0 else 0)"
   for c :: "nat \<Rightarrow> 'a::field"
   using sum_zero_power [of "\<lambda>i. c i / d i" A] by auto
 
 lemma (in field) prod_inversef: "prod (inverse \<circ> f) A = inverse (prod f A)"
  proof (cases "finite A")
    case True
    then show ?thesis
      by (induct A rule: finite_induct) simp_all
  next
    case False
    then show ?thesis
      by auto
  qed
 
 lemma (in field) prod_dividef: "(\<Prod>x\<in>A. f x / g x) = prod f A / prod g A"
   using prod_inversef [of g A] by (simp add: divide_inverse prod.distrib)
 
 lemma prod_Un:
   fixes f :: "'b \<Rightarrow> 'a :: field"
   assumes "finite A" and "finite B"
     and "\<forall>x\<in>A \<inter> B. f x \<noteq> 0"
   shows "prod f (A \<union> B) = prod f A * prod f B / prod f (A \<inter> B)"
 proof -
   from assms have "prod f A * prod f B = prod f (A \<union> B) * prod f (A \<inter> B)"
     by (simp add: prod.union_inter [symmetric, of A B])
   with assms show ?thesis
     by simp
 qed
 
 context linordered_semidom
 begin
 
 lemma prod_nonneg: "(\<forall>a\<in>A. 0 \<le> f a) \<Longrightarrow> 0 \<le> prod f A"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma prod_pos: "(\<forall>a\<in>A. 0 < f a) \<Longrightarrow> 0 < prod f A"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma prod_mono:
   "(\<And>i. i \<in> A \<Longrightarrow> 0 \<le> f i \<and> f i \<le> g i) \<Longrightarrow> prod f A \<le> prod g A"
   by (induct A rule: infinite_finite_induct) (force intro!: prod_nonneg mult_mono)+
 
 lemma prod_mono_strict:
   assumes "finite A" "\<And>i. i \<in> A \<Longrightarrow> 0 \<le> f i \<and> f i < g i" "A \<noteq> {}"
   shows "prod f A < prod g A"
   using assms
 proof (induct A rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case by (force intro: mult_strict_mono' prod_nonneg)
 qed
 
+lemma prod_le_power:
+  assumes A: "\<And>i. i \<in> A \<Longrightarrow> 0 \<le> f i \<and> f i \<le> n" "card A \<le> k" and "n \<ge> 1"
+  shows "prod f A \<le> n ^ k"
+  using A
+proof (induction A arbitrary: k rule: infinite_finite_induct)
+  case (insert i A)
+  then obtain k' where k': "card A \<le> k'" "k = Suc k'"
+    using Suc_le_D by force
+  have "f i * prod f A \<le> n * n ^ k'"
+    using insert \<open>n \<ge> 1\<close> k' by (intro prod_nonneg mult_mono; force)
+  then show ?case 
+    by (auto simp: \<open>k = Suc k'\<close> insert.hyps)
+qed (use \<open>n \<ge> 1\<close> in auto)
+
 end
 
 lemma prod_mono2:
   fixes f :: "'a \<Rightarrow> 'b :: linordered_idom"
   assumes fin: "finite B"
     and sub: "A \<subseteq> B"
     and nn: "\<And>b. b \<in> B-A \<Longrightarrow> 1 \<le> f b"
     and A: "\<And>a. a \<in> A \<Longrightarrow> 0 \<le> f a"
   shows "prod f A \<le> prod f B"
 proof -
   have "prod f A \<le> prod f A * prod f (B-A)"
     by (metis prod_ge_1 A mult_le_cancel_left1 nn not_less prod_nonneg)
   also from fin finite_subset[OF sub fin] have "\<dots> = prod f (A \<union> (B-A))"
     by (simp add: prod.union_disjoint del: Un_Diff_cancel)
   also from sub have "A \<union> (B-A) = B" by blast
   finally show ?thesis .
 qed
 
 lemma less_1_prod:
   fixes f :: "'a \<Rightarrow> 'b::linordered_idom"
   shows "finite I \<Longrightarrow> I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> 1 < f i) \<Longrightarrow> 1 < prod f I"
   by (induct I rule: finite_ne_induct) (auto intro: less_1_mult)
 
 lemma less_1_prod2:
   fixes f :: "'a \<Rightarrow> 'b::linordered_idom"
   assumes I: "finite I" "i \<in> I" "1 < f i" "\<And>i. i \<in> I \<Longrightarrow> 1 \<le> f i"
   shows "1 < prod f I"
 proof -
   have "1 < f i * prod f (I - {i})"
     using assms
     by (meson DiffD1 leI less_1_mult less_le_trans mult_le_cancel_left1 prod_ge_1)
   also have "\<dots> = prod f I"
     using assms by (simp add: prod.remove)
   finally show ?thesis .
 qed
 
 lemma (in linordered_field) abs_prod: "\<bar>prod f A\<bar> = (\<Prod>x\<in>A. \<bar>f x\<bar>)"
   by (induct A rule: infinite_finite_induct) (simp_all add: abs_mult)
 
 lemma prod_eq_1_iff [simp]: "finite A \<Longrightarrow> prod f A = 1 \<longleftrightarrow> (\<forall>a\<in>A. f a = 1)"
   for f :: "'a \<Rightarrow> nat"
   by (induct A rule: finite_induct) simp_all
 
 lemma prod_pos_nat_iff [simp]: "finite A \<Longrightarrow> prod f A > 0 \<longleftrightarrow> (\<forall>a\<in>A. f a > 0)"
   for f :: "'a \<Rightarrow> nat"
   using prod_zero_iff by (simp del: neq0_conv add: zero_less_iff_neq_zero)
 
 lemma prod_constant [simp]: "(\<Prod>x\<in> A. y) = y ^ card A"
   for y :: "'a::comm_monoid_mult"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma prod_power_distrib: "prod f A ^ n = prod (\<lambda>x. (f x) ^ n) A"
   for f :: "'a \<Rightarrow> 'b::comm_semiring_1"
   by (induct A rule: infinite_finite_induct) (auto simp add: power_mult_distrib)
 
 lemma power_sum: "c ^ (\<Sum>a\<in>A. f a) = (\<Prod>a\<in>A. c ^ f a)"
   by (induct A rule: infinite_finite_induct) (simp_all add: power_add)
 
 lemma prod_gen_delta:
   fixes b :: "'b \<Rightarrow> 'a::comm_monoid_mult"
   assumes fin: "finite S"
   shows "prod (\<lambda>k. if k = a then b k else c) S =
     (if a \<in> S then b a * c ^ (card S - 1) else c ^ card S)"
 proof -
   let ?f = "(\<lambda>k. if k=a then b k else c)"
   show ?thesis
   proof (cases "a \<in> S")
     case False
     then have "\<forall> k\<in> S. ?f k = c" by simp
     with False show ?thesis by (simp add: prod_constant)
   next
     case True
     let ?A = "S - {a}"
     let ?B = "{a}"
     from True have eq: "S = ?A \<union> ?B" by blast
     have disjoint: "?A \<inter> ?B = {}" by simp
     from fin have fin': "finite ?A" "finite ?B" by auto
     have f_A0: "prod ?f ?A = prod (\<lambda>i. c) ?A"
       by (rule prod.cong) auto
     from fin True have card_A: "card ?A = card S - 1" by auto
     have f_A1: "prod ?f ?A = c ^ card ?A"
       unfolding f_A0 by (rule prod_constant)
     have "prod ?f ?A * prod ?f ?B = prod ?f S"
       using prod.union_disjoint[OF fin' disjoint, of ?f, unfolded eq[symmetric]]
       by simp
     with True card_A show ?thesis
       by (simp add: f_A1 field_simps cong add: prod.cong cong del: if_weak_cong)
   qed
 qed
 
 lemma sum_image_le:
   fixes g :: "'a \<Rightarrow> 'b::ordered_comm_monoid_add"
   assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> g(f i)"
     shows "sum g (f ` I) \<le> sum (g \<circ> f) I"
   using assms
 proof induction
   case empty
   then show ?case by auto
 next
   case (insert x F)
   from insertI1 have "0 \<le> g (f x)" by (rule insert)
   hence 1: "sum g (f ` F) \<le> g (f x) + sum g (f ` F)" using add_increasing by blast
   have 2: "sum g (f ` F) \<le> sum (g \<circ> f) F" using insert by blast
   have "sum g (f ` insert x F) = sum g (insert (f x) (f ` F))" by simp
   also have "\<dots> \<le> g (f x) + sum g (f ` F)" by (simp add: 1 insert sum.insert_if)
   also from 2 have "\<dots> \<le> g (f x) + sum (g \<circ> f) F" by (rule add_left_mono)
   also from insert(1, 2) have "\<dots> = sum (g \<circ> f) (insert x F)" by (simp add: sum.insert_if)
   finally show ?case .
 qed
 
 end
diff --git a/src/HOL/Library/Countable_Set.thy b/src/HOL/Library/Countable_Set.thy
--- a/src/HOL/Library/Countable_Set.thy
+++ b/src/HOL/Library/Countable_Set.thy
@@ -1,451 +1,470 @@
 (*  Title:      HOL/Library/Countable_Set.thy
     Author:     Johannes Hölzl
     Author:     Andrei Popescu
 *)
 
 section \<open>Countable sets\<close>
 
 theory Countable_Set
 imports Countable Infinite_Set
 begin
 
 subsection \<open>Predicate for countable sets\<close>
 
 definition countable :: "'a set \<Rightarrow> bool" where
   "countable S \<longleftrightarrow> (\<exists>f::'a \<Rightarrow> nat. inj_on f S)"
 
 lemma countableE:
   assumes S: "countable S" obtains f :: "'a \<Rightarrow> nat" where "inj_on f S"
   using S by (auto simp: countable_def)
 
 lemma countableI: "inj_on (f::'a \<Rightarrow> nat) S \<Longrightarrow> countable S"
   by (auto simp: countable_def)
 
 lemma countableI': "inj_on (f::'a \<Rightarrow> 'b::countable) S \<Longrightarrow> countable S"
   using comp_inj_on[of f S to_nat] by (auto intro: countableI)
 
 lemma countableE_bij:
   assumes S: "countable S" obtains f :: "nat \<Rightarrow> 'a" and C :: "nat set" where "bij_betw f C S"
   using S by (blast elim: countableE dest: inj_on_imp_bij_betw bij_betw_inv)
 
 lemma countableI_bij: "bij_betw f (C::nat set) S \<Longrightarrow> countable S"
   by (blast intro: countableI bij_betw_inv_into bij_betw_imp_inj_on)
 
 lemma countable_finite: "finite S \<Longrightarrow> countable S"
   by (blast dest: finite_imp_inj_to_nat_seg countableI)
 
 lemma countableI_bij1: "bij_betw f A B \<Longrightarrow> countable A \<Longrightarrow> countable B"
   by (blast elim: countableE_bij intro: bij_betw_trans countableI_bij)
 
 lemma countableI_bij2: "bij_betw f B A \<Longrightarrow> countable A \<Longrightarrow> countable B"
   by (blast elim: countableE_bij intro: bij_betw_trans bij_betw_inv_into countableI_bij)
 
 lemma countable_iff_bij[simp]: "bij_betw f A B \<Longrightarrow> countable A \<longleftrightarrow> countable B"
   by (blast intro: countableI_bij1 countableI_bij2)
 
 lemma countable_subset: "A \<subseteq> B \<Longrightarrow> countable B \<Longrightarrow> countable A"
   by (auto simp: countable_def intro: subset_inj_on)
 
 lemma countableI_type[intro, simp]: "countable (A:: 'a :: countable set)"
   using countableI[of to_nat A] by auto
 
 subsection \<open>Enumerate a countable set\<close>
 
 lemma countableE_infinite:
   assumes "countable S" "infinite S"
   obtains e :: "'a \<Rightarrow> nat" where "bij_betw e S UNIV"
 proof -
   obtain f :: "'a \<Rightarrow> nat" where "inj_on f S"
     using \<open>countable S\<close> by (rule countableE)
   then have "bij_betw f S (f`S)"
     unfolding bij_betw_def by simp
   moreover
   from \<open>inj_on f S\<close> \<open>infinite S\<close> have inf_fS: "infinite (f`S)"
     by (auto dest: finite_imageD)
   then have "bij_betw (the_inv_into UNIV (enumerate (f`S))) (f`S) UNIV"
     by (intro bij_betw_the_inv_into bij_enumerate)
   ultimately have "bij_betw (the_inv_into UNIV (enumerate (f`S)) \<circ> f) S UNIV"
     by (rule bij_betw_trans)
   then show thesis ..
 qed
 
 lemma countable_infiniteE':
   assumes "countable A" "infinite A"
   obtains g where "bij_betw g (UNIV :: nat set) A"
   using bij_betw_inv[OF countableE_infinite[OF assms]] that by blast
 
 lemma countable_enum_cases:
   assumes "countable S"
   obtains (finite) f :: "'a \<Rightarrow> nat" where "finite S" "bij_betw f S {..<card S}"
         | (infinite) f :: "'a \<Rightarrow> nat" where "infinite S" "bij_betw f S UNIV"
   using ex_bij_betw_finite_nat[of S] countableE_infinite \<open>countable S\<close>
   by (cases "finite S") (auto simp add: atLeast0LessThan)
 
 definition to_nat_on :: "'a set \<Rightarrow> 'a \<Rightarrow> nat" where
   "to_nat_on S = (SOME f. if finite S then bij_betw f S {..< card S} else bij_betw f S UNIV)"
 
 definition from_nat_into :: "'a set \<Rightarrow> nat \<Rightarrow> 'a" where
   "from_nat_into S n = (if n \<in> to_nat_on S ` S then inv_into S (to_nat_on S) n else SOME s. s\<in>S)"
 
 lemma to_nat_on_finite: "finite S \<Longrightarrow> bij_betw (to_nat_on S) S {..< card S}"
   using ex_bij_betw_finite_nat unfolding to_nat_on_def
   by (intro someI2_ex[where Q="\<lambda>f. bij_betw f S {..<card S}"]) (auto simp add: atLeast0LessThan)
 
 lemma to_nat_on_infinite: "countable S \<Longrightarrow> infinite S \<Longrightarrow> bij_betw (to_nat_on S) S UNIV"
   using countableE_infinite unfolding to_nat_on_def
   by (intro someI2_ex[where Q="\<lambda>f. bij_betw f S UNIV"]) auto
 
 lemma bij_betw_from_nat_into_finite: "finite S \<Longrightarrow> bij_betw (from_nat_into S) {..< card S} S"
   unfolding from_nat_into_def[abs_def]
   using to_nat_on_finite[of S]
   apply (subst bij_betw_cong)
   apply (split if_split)
   apply (simp add: bij_betw_def)
   apply (auto cong: bij_betw_cong
               intro: bij_betw_inv_into to_nat_on_finite)
   done
 
 lemma bij_betw_from_nat_into: "countable S \<Longrightarrow> infinite S \<Longrightarrow> bij_betw (from_nat_into S) UNIV S"
   unfolding from_nat_into_def[abs_def]
   using to_nat_on_infinite[of S, unfolded bij_betw_def]
   by (auto cong: bij_betw_cong intro: bij_betw_inv_into to_nat_on_infinite)
 
+text \<open>
+  The sum/product over the enumeration of a finite set equals simply the sum/product over the set
+\<close>
+context comm_monoid_set
+begin
+
+lemma card_from_nat_into:
+  "F (\<lambda>i. h (from_nat_into A i)) {..<card A} = F h A"
+proof (cases "finite A")
+  case True
+  have "F (\<lambda>i. h (from_nat_into A i)) {..<card A} = F h (from_nat_into A ` {..<card A})"
+    by (metis True bij_betw_def bij_betw_from_nat_into_finite reindex_cong)
+  also have "... = F h A"
+    by (metis True bij_betw_def bij_betw_from_nat_into_finite)
+  finally show ?thesis .
+qed auto
+
+end
+
 lemma countable_as_injective_image:
   assumes "countable A" "infinite A"
   obtains f :: "nat \<Rightarrow> 'a" where "A = range f" "inj f"
 by (metis bij_betw_def bij_betw_from_nat_into [OF assms])
 
 lemma inj_on_to_nat_on[intro]: "countable A \<Longrightarrow> inj_on (to_nat_on A) A"
   using to_nat_on_infinite[of A] to_nat_on_finite[of A]
   by (cases "finite A") (auto simp: bij_betw_def)
 
 lemma to_nat_on_inj[simp]:
   "countable A \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> to_nat_on A a = to_nat_on A b \<longleftrightarrow> a = b"
   using inj_on_to_nat_on[of A] by (auto dest: inj_onD)
 
 lemma from_nat_into_to_nat_on[simp]: "countable A \<Longrightarrow> a \<in> A \<Longrightarrow> from_nat_into A (to_nat_on A a) = a"
   by (auto simp: from_nat_into_def intro!: inv_into_f_f)
 
 lemma subset_range_from_nat_into: "countable A \<Longrightarrow> A \<subseteq> range (from_nat_into A)"
   by (auto intro: from_nat_into_to_nat_on[symmetric])
 
 lemma from_nat_into: "A \<noteq> {} \<Longrightarrow> from_nat_into A n \<in> A"
   unfolding from_nat_into_def by (metis equals0I inv_into_into someI_ex)
 
 lemma range_from_nat_into_subset: "A \<noteq> {} \<Longrightarrow> range (from_nat_into A) \<subseteq> A"
   using from_nat_into[of A] by auto
 
 lemma range_from_nat_into[simp]: "A \<noteq> {} \<Longrightarrow> countable A \<Longrightarrow> range (from_nat_into A) = A"
   by (metis equalityI range_from_nat_into_subset subset_range_from_nat_into)
 
 lemma image_to_nat_on: "countable A \<Longrightarrow> infinite A \<Longrightarrow> to_nat_on A ` A = UNIV"
   using to_nat_on_infinite[of A] by (simp add: bij_betw_def)
 
 lemma to_nat_on_surj: "countable A \<Longrightarrow> infinite A \<Longrightarrow> \<exists>a\<in>A. to_nat_on A a = n"
   by (metis (no_types) image_iff iso_tuple_UNIV_I image_to_nat_on)
 
 lemma to_nat_on_from_nat_into[simp]: "n \<in> to_nat_on A ` A \<Longrightarrow> to_nat_on A (from_nat_into A n) = n"
   by (simp add: f_inv_into_f from_nat_into_def)
 
 lemma to_nat_on_from_nat_into_infinite[simp]:
   "countable A \<Longrightarrow> infinite A \<Longrightarrow> to_nat_on A (from_nat_into A n) = n"
   by (metis image_iff to_nat_on_surj to_nat_on_from_nat_into)
 
 lemma from_nat_into_inj:
   "countable A \<Longrightarrow> m \<in> to_nat_on A ` A \<Longrightarrow> n \<in> to_nat_on A ` A \<Longrightarrow>
     from_nat_into A m = from_nat_into A n \<longleftrightarrow> m = n"
   by (subst to_nat_on_inj[symmetric, of A]) auto
 
 lemma from_nat_into_inj_infinite[simp]:
   "countable A \<Longrightarrow> infinite A \<Longrightarrow> from_nat_into A m = from_nat_into A n \<longleftrightarrow> m = n"
   using image_to_nat_on[of A] from_nat_into_inj[of A m n] by simp
 
 lemma eq_from_nat_into_iff:
   "countable A \<Longrightarrow> x \<in> A \<Longrightarrow> i \<in> to_nat_on A ` A \<Longrightarrow> x = from_nat_into A i \<longleftrightarrow> i = to_nat_on A x"
   by auto
 
 lemma from_nat_into_surj: "countable A \<Longrightarrow> a \<in> A \<Longrightarrow> \<exists>n. from_nat_into A n = a"
   by (rule exI[of _ "to_nat_on A a"]) simp
 
 lemma from_nat_into_inject[simp]:
   "A \<noteq> {} \<Longrightarrow> countable A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> countable B \<Longrightarrow> from_nat_into A = from_nat_into B \<longleftrightarrow> A = B"
   by (metis range_from_nat_into)
 
 lemma inj_on_from_nat_into: "inj_on from_nat_into ({A. A \<noteq> {} \<and> countable A})"
   unfolding inj_on_def by auto
 
 subsection \<open>Closure properties of countability\<close>
 
 lemma countable_SIGMA[intro, simp]:
   "countable I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> countable (A i)) \<Longrightarrow> countable (SIGMA i : I. A i)"
   by (intro countableI'[of "\<lambda>(i, a). (to_nat_on I i, to_nat_on (A i) a)"]) (auto simp: inj_on_def)
 
 lemma countable_image[intro, simp]:
   assumes "countable A"
   shows "countable (f`A)"
 proof -
   obtain g :: "'a \<Rightarrow> nat" where "inj_on g A"
     using assms by (rule countableE)
   moreover have "inj_on (inv_into A f) (f`A)" "inv_into A f ` f ` A \<subseteq> A"
     by (auto intro: inj_on_inv_into inv_into_into)
   ultimately show ?thesis
     by (blast dest: comp_inj_on subset_inj_on intro: countableI)
 qed
 
 lemma countable_image_inj_on: "countable (f ` A) \<Longrightarrow> inj_on f A \<Longrightarrow> countable A"
   by (metis countable_image the_inv_into_onto)
 
 lemma countable_image_inj_Int_vimage:
    "\<lbrakk>inj_on f S; countable A\<rbrakk> \<Longrightarrow> countable (S \<inter> f -` A)"
   by (meson countable_image_inj_on countable_subset image_subset_iff_subset_vimage inf_le2 inj_on_Int)
 
 lemma countable_image_inj_gen:
    "\<lbrakk>inj_on f S; countable A\<rbrakk> \<Longrightarrow> countable {x \<in> S. f x \<in> A}"
   using countable_image_inj_Int_vimage
   by (auto simp: vimage_def Collect_conj_eq)
 
 lemma countable_image_inj_eq:
    "inj_on f S \<Longrightarrow> countable(f ` S) \<longleftrightarrow> countable S"
   using countable_image_inj_on by blast
 
 lemma countable_image_inj:
    "\<lbrakk>countable A; inj f\<rbrakk> \<Longrightarrow> countable {x. f x \<in> A}"
   by (metis (mono_tags, lifting) countable_image_inj_eq countable_subset image_Collect_subsetI inj_on_inverseI the_inv_f_f)
 
 lemma countable_UN[intro, simp]:
   fixes I :: "'i set" and A :: "'i => 'a set"
   assumes I: "countable I"
   assumes A: "\<And>i. i \<in> I \<Longrightarrow> countable (A i)"
   shows "countable (\<Union>i\<in>I. A i)"
 proof -
   have "(\<Union>i\<in>I. A i) = snd ` (SIGMA i : I. A i)" by (auto simp: image_iff)
   then show ?thesis by (simp add: assms)
 qed
 
 lemma countable_Un[intro]: "countable A \<Longrightarrow> countable B \<Longrightarrow> countable (A \<union> B)"
   by (rule countable_UN[of "{True, False}" "\<lambda>True \<Rightarrow> A | False \<Rightarrow> B", simplified])
      (simp split: bool.split)
 
 lemma countable_Un_iff[simp]: "countable (A \<union> B) \<longleftrightarrow> countable A \<and> countable B"
   by (metis countable_Un countable_subset inf_sup_ord(3,4))
 
 lemma countable_Plus[intro, simp]:
   "countable A \<Longrightarrow> countable B \<Longrightarrow> countable (A <+> B)"
   by (simp add: Plus_def)
 
 lemma countable_empty[intro, simp]: "countable {}"
   by (blast intro: countable_finite)
 
 lemma countable_insert[intro, simp]: "countable A \<Longrightarrow> countable (insert a A)"
   using countable_Un[of "{a}" A] by (auto simp: countable_finite)
 
 lemma countable_Int1[intro, simp]: "countable A \<Longrightarrow> countable (A \<inter> B)"
   by (force intro: countable_subset)
 
 lemma countable_Int2[intro, simp]: "countable B \<Longrightarrow> countable (A \<inter> B)"
   by (blast intro: countable_subset)
 
 lemma countable_INT[intro, simp]: "i \<in> I \<Longrightarrow> countable (A i) \<Longrightarrow> countable (\<Inter>i\<in>I. A i)"
   by (blast intro: countable_subset)
 
 lemma countable_Diff[intro, simp]: "countable A \<Longrightarrow> countable (A - B)"
   by (blast intro: countable_subset)
 
 lemma countable_insert_eq [simp]: "countable (insert x A) = countable A"
     by auto (metis Diff_insert_absorb countable_Diff insert_absorb)
 
 lemma countable_vimage: "B \<subseteq> range f \<Longrightarrow> countable (f -` B) \<Longrightarrow> countable B"
   by (metis Int_absorb2 countable_image image_vimage_eq)
 
 lemma surj_countable_vimage: "surj f \<Longrightarrow> countable (f -` B) \<Longrightarrow> countable B"
   by (metis countable_vimage top_greatest)
 
 lemma countable_Collect[simp]: "countable A \<Longrightarrow> countable {a \<in> A. \<phi> a}"
   by (metis Collect_conj_eq Int_absorb Int_commute Int_def countable_Int1)
 
 lemma countable_Image:
   assumes "\<And>y. y \<in> Y \<Longrightarrow> countable (X `` {y})"
   assumes "countable Y"
   shows "countable (X `` Y)"
 proof -
   have "countable (X `` (\<Union>y\<in>Y. {y}))"
     unfolding Image_UN by (intro countable_UN assms)
   then show ?thesis by simp
 qed
 
 lemma countable_relpow:
   fixes X :: "'a rel"
   assumes Image_X: "\<And>Y. countable Y \<Longrightarrow> countable (X `` Y)"
   assumes Y: "countable Y"
   shows "countable ((X ^^ i) `` Y)"
   using Y by (induct i arbitrary: Y) (auto simp: relcomp_Image Image_X)
 
 lemma countable_funpow:
   fixes f :: "'a set \<Rightarrow> 'a set"
   assumes "\<And>A. countable A \<Longrightarrow> countable (f A)"
   and "countable A"
   shows "countable ((f ^^ n) A)"
 by(induction n)(simp_all add: assms)
 
 lemma countable_rtrancl:
   "(\<And>Y. countable Y \<Longrightarrow> countable (X `` Y)) \<Longrightarrow> countable Y \<Longrightarrow> countable (X\<^sup>* `` Y)"
   unfolding rtrancl_is_UN_relpow UN_Image by (intro countable_UN countableI_type countable_relpow)
 
 lemma countable_lists[intro, simp]:
   assumes A: "countable A" shows "countable (lists A)"
 proof -
   have "countable (lists (range (from_nat_into A)))"
     by (auto simp: lists_image)
   with A show ?thesis
     by (auto dest: subset_range_from_nat_into countable_subset lists_mono)
 qed
 
 lemma Collect_finite_eq_lists: "Collect finite = set ` lists UNIV"
   using finite_list by auto
 
 lemma countable_Collect_finite: "countable (Collect (finite::'a::countable set\<Rightarrow>bool))"
   by (simp add: Collect_finite_eq_lists)
 
 lemma countable_int: "countable \<int>"
   unfolding Ints_def by auto
 
 lemma countable_rat: "countable \<rat>"
   unfolding Rats_def by auto
 
 lemma Collect_finite_subset_eq_lists: "{A. finite A \<and> A \<subseteq> T} = set ` lists T"
   using finite_list by (auto simp: lists_eq_set)
 
 lemma countable_Collect_finite_subset:
   "countable T \<Longrightarrow> countable {A. finite A \<and> A \<subseteq> T}"
   unfolding Collect_finite_subset_eq_lists by auto
 
 lemma countable_Fpow: "countable S \<Longrightarrow> countable (Fpow S)"
   using countable_Collect_finite_subset
   by (force simp add: Fpow_def conj_commute)
 
 lemma countable_set_option [simp]: "countable (set_option x)"
   by (cases x) auto
 
 subsection \<open>Misc lemmas\<close>
 
 lemma countable_subset_image:
    "countable B \<and> B \<subseteq> (f ` A) \<longleftrightarrow> (\<exists>A'. countable A' \<and> A' \<subseteq> A \<and> (B = f ` A'))"
    (is "?lhs = ?rhs")
 proof
   assume ?lhs
   show ?rhs
     by (rule exI [where x="inv_into A f ` B"])
       (use \<open>?lhs\<close> in \<open>auto simp: f_inv_into_f subset_iff image_inv_into_cancel inv_into_into\<close>)
 next
   assume ?rhs
   then show ?lhs by force
 qed
 
 lemma ex_subset_image_inj:
    "(\<exists>T. T \<subseteq> f ` S \<and> P T) \<longleftrightarrow> (\<exists>T. T \<subseteq> S \<and> inj_on f T \<and> P (f ` T))"
   by (auto simp: subset_image_inj)
 
 lemma all_subset_image_inj:
    "(\<forall>T. T \<subseteq> f ` S \<longrightarrow> P T) \<longleftrightarrow> (\<forall>T. T \<subseteq> S \<and> inj_on f T \<longrightarrow> P(f ` T))"
   by (metis subset_image_inj)
 
 lemma ex_countable_subset_image_inj:
    "(\<exists>T. countable T \<and> T \<subseteq> f ` S \<and> P T) \<longleftrightarrow>
     (\<exists>T. countable T \<and> T \<subseteq> S \<and> inj_on f T \<and> P (f ` T))"
   by (metis countable_image_inj_eq subset_image_inj)
 
 lemma all_countable_subset_image_inj:
    "(\<forall>T. countable T \<and> T \<subseteq> f ` S \<longrightarrow> P T) \<longleftrightarrow> (\<forall>T. countable T \<and> T \<subseteq> S \<and> inj_on f T \<longrightarrow>P(f ` T))"
   by (metis countable_image_inj_eq subset_image_inj)
 
 lemma ex_countable_subset_image:
    "(\<exists>T. countable T \<and> T \<subseteq> f ` S \<and> P T) \<longleftrightarrow> (\<exists>T. countable T \<and> T \<subseteq> S \<and> P (f ` T))"
   by (metis countable_subset_image)
 
 lemma all_countable_subset_image:
    "(\<forall>T. countable T \<and> T \<subseteq> f ` S \<longrightarrow> P T) \<longleftrightarrow> (\<forall>T. countable T \<and> T \<subseteq> S \<longrightarrow> P(f ` T))"
   by (metis countable_subset_image)
 
 lemma countable_image_eq:
    "countable(f ` S) \<longleftrightarrow> (\<exists>T. countable T \<and> T \<subseteq> S \<and> f ` S = f ` T)"
   by (metis countable_image countable_image_inj_eq order_refl subset_image_inj)
 
 lemma countable_image_eq_inj:
    "countable(f ` S) \<longleftrightarrow> (\<exists>T. countable T \<and> T \<subseteq> S \<and> f ` S = f ` T \<and> inj_on f T)"
   by (metis countable_image_inj_eq order_refl subset_image_inj)
 
 lemma infinite_countable_subset':
   assumes X: "infinite X" shows "\<exists>C\<subseteq>X. countable C \<and> infinite C"
 proof -
   obtain f :: "nat \<Rightarrow> 'a" where "inj f" "range f \<subseteq> X"
     using infinite_countable_subset [OF X] by blast
   then show ?thesis
     by (intro exI[of _ "range f"]) (auto simp: range_inj_infinite)
 qed
 
 lemma countable_all:
   assumes S: "countable S"
   shows "(\<forall>s\<in>S. P s) \<longleftrightarrow> (\<forall>n::nat. from_nat_into S n \<in> S \<longrightarrow> P (from_nat_into S n))"
   using S[THEN subset_range_from_nat_into] by auto
 
 lemma finite_sequence_to_countable_set:
   assumes "countable X"
   obtains F where "\<And>i. F i \<subseteq> X" "\<And>i. F i \<subseteq> F (Suc i)" "\<And>i. finite (F i)" "(\<Union>i. F i) = X"
 proof -
   show thesis
     apply (rule that[of "\<lambda>i. if X = {} then {} else from_nat_into X ` {..i}"])
        apply (auto simp add: image_iff intro: from_nat_into split: if_splits)
     using assms from_nat_into_surj by (fastforce cong: image_cong)
 qed
 
 lemma transfer_countable[transfer_rule]:
   "bi_unique R \<Longrightarrow> rel_fun (rel_set R) (=) countable countable"
   by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
      (auto dest: countable_image_inj_on)
 
 subsection \<open>Uncountable\<close>
 
 abbreviation uncountable where
   "uncountable A \<equiv> \<not> countable A"
 
 lemma uncountable_def: "uncountable A \<longleftrightarrow> A \<noteq> {} \<and> \<not> (\<exists>f::(nat \<Rightarrow> 'a). range f = A)"
   by (auto intro: inj_on_inv_into simp: countable_def)
      (metis all_not_in_conv inj_on_iff_surj subset_UNIV)
 
 lemma uncountable_bij_betw: "bij_betw f A B \<Longrightarrow> uncountable B \<Longrightarrow> uncountable A"
   unfolding bij_betw_def by (metis countable_image)
 
 lemma uncountable_infinite: "uncountable A \<Longrightarrow> infinite A"
   by (metis countable_finite)
 
 lemma uncountable_minus_countable:
   "uncountable A \<Longrightarrow> countable B \<Longrightarrow> uncountable (A - B)"
   using countable_Un[of B "A - B"] by auto
 
 lemma countable_Diff_eq [simp]: "countable (A - {x}) = countable A"
   by (meson countable_Diff countable_empty countable_insert uncountable_minus_countable)
 
 text \<open>Every infinite set can be covered by a pairwise disjoint family of infinite sets.
       This version doesn't achieve equality, as it only covers a countable subset\<close>
 lemma infinite_infinite_partition:
   assumes "infinite A"
   obtains C :: "nat \<Rightarrow> 'a set" 
     where "pairwise (\<lambda>i j. disjnt (C i) (C j)) UNIV" "(\<Union>i. C i) \<subseteq> A" "\<And>i. infinite (C i)"
 proof -
   obtain f :: "nat\<Rightarrow>'a" where "range f \<subseteq> A" "inj f"
     using assms infinite_countable_subset by blast
   let ?C = "\<lambda>i. range (\<lambda>j. f (prod_encode (i,j)))"
   show thesis
   proof
     show "pairwise (\<lambda>i j. disjnt (?C i) (?C j)) UNIV"
       by (auto simp: pairwise_def disjnt_def inj_on_eq_iff [OF \<open>inj f\<close>] inj_on_eq_iff [OF inj_prod_encode, of _ UNIV])
     show "(\<Union>i. ?C i) \<subseteq> A"
       using \<open>range f \<subseteq> A\<close> by blast
     have "infinite (range (\<lambda>j. f (prod_encode (i, j))))" for i
       by (rule range_inj_infinite) (meson Pair_inject \<open>inj f\<close> inj_def prod_encode_eq)
     then show "\<And>i. infinite (?C i)"
       using that by auto
   qed
 qed
 
 end
diff --git a/src/HOL/Library/Disjoint_Sets.thy b/src/HOL/Library/Disjoint_Sets.thy
--- a/src/HOL/Library/Disjoint_Sets.thy
+++ b/src/HOL/Library/Disjoint_Sets.thy
@@ -1,415 +1,453 @@
 (*  Author:     Johannes Hölzl, TU München
 *)
 
 section \<open>Partitions and Disjoint Sets\<close>
 
 theory Disjoint_Sets
   imports Main
 begin
 
 lemma range_subsetD: "range f \<subseteq> B \<Longrightarrow> f i \<in> B"
   by blast
 
 lemma Int_Diff_disjoint: "A \<inter> B \<inter> (A - B) = {}"
   by blast
 
 lemma Int_Diff_Un: "A \<inter> B \<union> (A - B) = A"
   by blast
 
 lemma mono_Un: "mono A \<Longrightarrow> (\<Union>i\<le>n. A i) = A n"
   unfolding mono_def by auto
 
 lemma disjnt_equiv_class: "equiv A r \<Longrightarrow> disjnt (r``{a}) (r``{b}) \<longleftrightarrow> (a, b) \<notin> r"
   by (auto dest: equiv_class_self simp: equiv_class_eq_iff disjnt_def)
 
 subsection \<open>Set of Disjoint Sets\<close>
 
 abbreviation disjoint :: "'a set set \<Rightarrow> bool" where "disjoint \<equiv> pairwise disjnt"
 
 lemma disjoint_def: "disjoint A \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b\<in>A. a \<noteq> b \<longrightarrow> a \<inter> b = {})"
   unfolding pairwise_def disjnt_def by auto
 
 lemma disjointI:
   "(\<And>a b. a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> a \<inter> b = {}) \<Longrightarrow> disjoint A"
   unfolding disjoint_def by auto
 
 lemma disjointD:
   "disjoint A \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> a \<inter> b = {}"
   unfolding disjoint_def by auto
 
 lemma disjoint_image: "inj_on f (\<Union>A) \<Longrightarrow> disjoint A \<Longrightarrow> disjoint ((`) f ` A)"
   unfolding inj_on_def disjoint_def by blast
 
 lemma assumes "disjoint (A \<union> B)"
       shows   disjoint_unionD1: "disjoint A" and disjoint_unionD2: "disjoint B"
   using assms by (simp_all add: disjoint_def)
   
 lemma disjoint_INT:
   assumes *: "\<And>i. i \<in> I \<Longrightarrow> disjoint (F i)"
   shows "disjoint {\<Inter>i\<in>I. X i | X. \<forall>i\<in>I. X i \<in> F i}"
 proof (safe intro!: disjointI del: equalityI)
   fix A B :: "'a \<Rightarrow> 'b set" assume "(\<Inter>i\<in>I. A i) \<noteq> (\<Inter>i\<in>I. B i)"
   then obtain i where "A i \<noteq> B i" "i \<in> I"
     by auto
   moreover assume "\<forall>i\<in>I. A i \<in> F i" "\<forall>i\<in>I. B i \<in> F i"
   ultimately show "(\<Inter>i\<in>I. A i) \<inter> (\<Inter>i\<in>I. B i) = {}"
     using *[OF \<open>i\<in>I\<close>, THEN disjointD, of "A i" "B i"]
     by (auto simp flip: INT_Int_distrib)
 qed
 
 lemma diff_Union_pairwise_disjoint:
   assumes "pairwise disjnt \<A>" "\<B> \<subseteq> \<A>"
   shows "\<Union>\<A> - \<Union>\<B> = \<Union>(\<A> - \<B>)"
 proof -
   have "False"
     if x: "x \<in> A" "x \<in> B" and AB: "A \<in> \<A>" "A \<notin> \<B>" "B \<in> \<B>" for x A B
   proof -
     have "A \<inter> B = {}"
       using assms disjointD AB by blast
   with x show ?thesis
     by blast
   qed
   then show ?thesis by auto
 qed
 
 lemma Int_Union_pairwise_disjoint:
   assumes "pairwise disjnt (\<A> \<union> \<B>)"
   shows "\<Union>\<A> \<inter> \<Union>\<B> = \<Union>(\<A> \<inter> \<B>)"
 proof -
   have "False"
     if x: "x \<in> A" "x \<in> B" and AB: "A \<in> \<A>" "A \<notin> \<B>" "B \<in> \<B>" for x A B
   proof -
     have "A \<inter> B = {}"
       using assms disjointD AB by blast
   with x show ?thesis
     by blast
   qed
   then show ?thesis by auto
 qed
 
 lemma psubset_Union_pairwise_disjoint:
   assumes \<B>: "pairwise disjnt \<B>" and "\<A> \<subset> \<B> - {{}}"
   shows "\<Union>\<A> \<subset> \<Union>\<B>"
   unfolding psubset_eq
 proof
   show "\<Union>\<A> \<subseteq> \<Union>\<B>"
     using assms by blast
   have "\<A> \<subseteq> \<B>" "\<Union>(\<B> - \<A> \<inter> (\<B> - {{}})) \<noteq> {}"
     using assms by blast+
   then show "\<Union>\<A> \<noteq> \<Union>\<B>"
     using diff_Union_pairwise_disjoint [OF \<B>] by blast
 qed
 
 subsubsection "Family of Disjoint Sets"
 
 definition disjoint_family_on :: "('i \<Rightarrow> 'a set) \<Rightarrow> 'i set \<Rightarrow> bool" where
   "disjoint_family_on A S \<longleftrightarrow> (\<forall>m\<in>S. \<forall>n\<in>S. m \<noteq> n \<longrightarrow> A m \<inter> A n = {})"
 
 abbreviation "disjoint_family A \<equiv> disjoint_family_on A UNIV"
 
 lemma disjoint_family_elem_disjnt:
   assumes "infinite A" "finite C"
       and df: "disjoint_family_on B A"
   obtains x where "x \<in> A" "disjnt C (B x)"
 proof -
   have "False" if *: "\<forall>x \<in> A. \<exists>y. y \<in> C \<and> y \<in> B x"
   proof -
     obtain g where g: "\<forall>x \<in> A. g x \<in> C \<and> g x \<in> B x"
       using * by metis
     with df have "inj_on g A"
       by (fastforce simp add: inj_on_def disjoint_family_on_def)
     then have "infinite (g ` A)"
       using \<open>infinite A\<close> finite_image_iff by blast
     then show False
       by (meson \<open>finite C\<close> finite_subset g image_subset_iff)
   qed
   then show ?thesis
     by (force simp: disjnt_iff intro: that)
 qed
 
 lemma disjoint_family_onD:
   "disjoint_family_on A I \<Longrightarrow> i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> i \<noteq> j \<Longrightarrow> A i \<inter> A j = {}"
   by (auto simp: disjoint_family_on_def)
 
 lemma disjoint_family_subset: "disjoint_family A \<Longrightarrow> (\<And>x. B x \<subseteq> A x) \<Longrightarrow> disjoint_family B"
   by (force simp add: disjoint_family_on_def)
 
 lemma disjoint_family_on_bisimulation:
   assumes "disjoint_family_on f S"
   and "\<And>n m. n \<in> S \<Longrightarrow> m \<in> S \<Longrightarrow> n \<noteq> m \<Longrightarrow> f n \<inter> f m = {} \<Longrightarrow> g n \<inter> g m = {}"
   shows "disjoint_family_on g S"
   using assms unfolding disjoint_family_on_def by auto
 
 lemma disjoint_family_on_mono:
   "A \<subseteq> B \<Longrightarrow> disjoint_family_on f B \<Longrightarrow> disjoint_family_on f A"
   unfolding disjoint_family_on_def by auto
 
 lemma disjoint_family_Suc:
   "(\<And>n. A n \<subseteq> A (Suc n)) \<Longrightarrow> disjoint_family (\<lambda>i. A (Suc i) - A i)"
   using lift_Suc_mono_le[of A]
   by (auto simp add: disjoint_family_on_def)
      (metis insert_absorb insert_subset le_SucE le_antisym not_le_imp_less less_imp_le)
 
 lemma disjoint_family_on_disjoint_image:
   "disjoint_family_on A I \<Longrightarrow> disjoint (A ` I)"
   unfolding disjoint_family_on_def disjoint_def by force
  
 lemma disjoint_family_on_vimageI: "disjoint_family_on F I \<Longrightarrow> disjoint_family_on (\<lambda>i. f -` F i) I"
   by (auto simp: disjoint_family_on_def)
 
 lemma disjoint_image_disjoint_family_on:
   assumes d: "disjoint (A ` I)" and i: "inj_on A I"
   shows "disjoint_family_on A I"
   unfolding disjoint_family_on_def
 proof (intro ballI impI)
   fix n m assume nm: "m \<in> I" "n \<in> I" and "n \<noteq> m"
   with i[THEN inj_onD, of n m] show "A n \<inter> A m = {}"
     by (intro disjointD[OF d]) auto
 qed
 
+lemma disjoint_family_on_iff_disjoint_image:
+  assumes "\<And>i. i \<in> I \<Longrightarrow> A i \<noteq> {}"
+  shows "disjoint_family_on A I \<longleftrightarrow> disjoint (A ` I) \<and> inj_on A I"
+proof
+  assume "disjoint_family_on A I"
+  then show "disjoint (A ` I) \<and> inj_on A I"
+    by (metis (mono_tags, lifting) assms disjoint_family_onD disjoint_family_on_disjoint_image inf.idem inj_onI)
+qed (use disjoint_image_disjoint_family_on in metis)
+
+lemma card_UN_disjoint':
+  assumes "disjoint_family_on A I" "\<And>i. i \<in> I \<Longrightarrow> finite (A i)" "finite I"
+  shows "card (\<Union>i\<in>I. A i) = (\<Sum>i\<in>I. card (A i))"
+  using assms   by (simp add: card_UN_disjoint disjoint_family_on_def)
+
 lemma disjoint_UN:
   assumes F: "\<And>i. i \<in> I \<Longrightarrow> disjoint (F i)" and *: "disjoint_family_on (\<lambda>i. \<Union>(F i)) I"
   shows "disjoint (\<Union>i\<in>I. F i)"
 proof (safe intro!: disjointI del: equalityI)
   fix A B i j assume "A \<noteq> B" "A \<in> F i" "i \<in> I" "B \<in> F j" "j \<in> I"
   show "A \<inter> B = {}"
   proof cases
     assume "i = j" with F[of i] \<open>i \<in> I\<close> \<open>A \<in> F i\<close> \<open>B \<in> F j\<close> \<open>A \<noteq> B\<close> show "A \<inter> B = {}"
       by (auto dest: disjointD)
   next
     assume "i \<noteq> j"
     with * \<open>i\<in>I\<close> \<open>j\<in>I\<close> have "(\<Union>(F i)) \<inter> (\<Union>(F j)) = {}"
       by (rule disjoint_family_onD)
     with \<open>A\<in>F i\<close> \<open>i\<in>I\<close> \<open>B\<in>F j\<close> \<open>j\<in>I\<close>
     show "A \<inter> B = {}"
       by auto
   qed
 qed
 
 lemma distinct_list_bind: 
   assumes "distinct xs" "\<And>x. x \<in> set xs \<Longrightarrow> distinct (f x)" 
           "disjoint_family_on (set \<circ> f) (set xs)"
   shows   "distinct (List.bind xs f)"
   using assms
   by (induction xs)
      (auto simp: disjoint_family_on_def distinct_map inj_on_def set_list_bind)
 
 lemma bij_betw_UNION_disjoint:
   assumes disj: "disjoint_family_on A' I"
   assumes bij: "\<And>i. i \<in> I \<Longrightarrow> bij_betw f (A i) (A' i)"
   shows   "bij_betw f (\<Union>i\<in>I. A i) (\<Union>i\<in>I. A' i)"
 unfolding bij_betw_def
 proof
   from bij show eq: "f ` \<Union>(A ` I) = \<Union>(A' ` I)"
     by (auto simp: bij_betw_def image_UN)
   show "inj_on f (\<Union>(A ` I))"
   proof (rule inj_onI, clarify)
     fix i j x y assume A: "i \<in> I" "j \<in> I" "x \<in> A i" "y \<in> A j" and B: "f x = f y"
     from A bij[of i] bij[of j] have "f x \<in> A' i" "f y \<in> A' j"
       by (auto simp: bij_betw_def)
     with B have "A' i \<inter> A' j \<noteq> {}" by auto
     with disj A have "i = j" unfolding disjoint_family_on_def by blast
     with A B bij[of i] show "x = y" by (auto simp: bij_betw_def dest: inj_onD)
   qed
 qed
 
 lemma disjoint_union: "disjoint C \<Longrightarrow> disjoint B \<Longrightarrow> \<Union>C \<inter> \<Union>B = {} \<Longrightarrow> disjoint (C \<union> B)"
   using disjoint_UN[of "{C, B}" "\<lambda>x. x"] by (auto simp add: disjoint_family_on_def)
 
 text \<open>
+  Sum/product of the union of a finite disjoint family
+\<close>
+context comm_monoid_set
+begin
+
+lemma UNION_disjoint_family:
+  assumes "finite I" and "\<forall>i\<in>I. finite (A i)"
+    and "disjoint_family_on A I"
+  shows "F g (\<Union>(A ` I)) = F (\<lambda>x. F g (A x)) I"
+  using assms unfolding disjoint_family_on_def  by (rule UNION_disjoint)
+
+lemma Union_disjoint_sets:
+  assumes "\<forall>A\<in>C. finite A" and "disjoint C"
+  shows "F g (\<Union>C) = (F \<circ> F) g C"
+  using assms unfolding disjoint_def  by (rule Union_disjoint)
+
+end
+
+text \<open>
   The union of an infinite disjoint family of non-empty sets is infinite.
 \<close>
 lemma infinite_disjoint_family_imp_infinite_UNION:
   assumes "\<not>finite A" "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> {}" "disjoint_family_on f A"
   shows   "\<not>finite (\<Union>(f ` A))"
 proof -
   define g where "g x = (SOME y. y \<in> f x)" for x
   have g: "g x \<in> f x" if "x \<in> A" for x
     unfolding g_def by (rule someI_ex, insert assms(2) that) blast
   have inj_on_g: "inj_on g A"
   proof (rule inj_onI, rule ccontr)
     fix x y assume A: "x \<in> A" "y \<in> A" "g x = g y" "x \<noteq> y"
     with g[of x] g[of y] have "g x \<in> f x" "g x \<in> f y" by auto
     with A \<open>x \<noteq> y\<close> assms show False
       by (auto simp: disjoint_family_on_def inj_on_def)
   qed
   from g have "g ` A \<subseteq> \<Union>(f ` A)" by blast
   moreover from inj_on_g \<open>\<not>finite A\<close> have "\<not>finite (g ` A)"
     using finite_imageD by blast
   ultimately show ?thesis using finite_subset by blast
 qed  
   
 
 subsection \<open>Construct Disjoint Sequences\<close>
 
 definition disjointed :: "(nat \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a set" where
   "disjointed A n = A n - (\<Union>i\<in>{0..<n}. A i)"
 
 lemma finite_UN_disjointed_eq: "(\<Union>i\<in>{0..<n}. disjointed A i) = (\<Union>i\<in>{0..<n}. A i)"
 proof (induct n)
   case 0 show ?case by simp
 next
   case (Suc n)
   thus ?case by (simp add: atLeastLessThanSuc disjointed_def)
 qed
 
 lemma UN_disjointed_eq: "(\<Union>i. disjointed A i) = (\<Union>i. A i)"
   by (rule UN_finite2_eq [where k=0])
      (simp add: finite_UN_disjointed_eq)
 
 lemma less_disjoint_disjointed: "m < n \<Longrightarrow> disjointed A m \<inter> disjointed A n = {}"
   by (auto simp add: disjointed_def)
 
 lemma disjoint_family_disjointed: "disjoint_family (disjointed A)"
   by (simp add: disjoint_family_on_def)
      (metis neq_iff Int_commute less_disjoint_disjointed)
 
 lemma disjointed_subset: "disjointed A n \<subseteq> A n"
   by (auto simp add: disjointed_def)
 
 lemma disjointed_0[simp]: "disjointed A 0 = A 0"
   by (simp add: disjointed_def)
 
 lemma disjointed_mono: "mono A \<Longrightarrow> disjointed A (Suc n) = A (Suc n) - A n"
   using mono_Un[of A] by (simp add: disjointed_def atLeastLessThanSuc_atLeastAtMost atLeast0AtMost)
 
 subsection \<open>Partitions\<close>
 
 text \<open>
   Partitions \<^term>\<open>P\<close> of a set \<^term>\<open>A\<close>. We explicitly disallow empty sets.
 \<close>
 
 definition partition_on :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool"
 where
   "partition_on A P \<longleftrightarrow> \<Union>P = A \<and> disjoint P \<and> {} \<notin> P"
 
 lemma partition_onI:
   "\<Union>P = A \<Longrightarrow> (\<And>p q. p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> p \<noteq> q \<Longrightarrow> disjnt p q) \<Longrightarrow> {} \<notin> P \<Longrightarrow> partition_on A P"
   by (auto simp: partition_on_def pairwise_def)
 
 lemma partition_onD1: "partition_on A P \<Longrightarrow> A = \<Union>P"
   by (auto simp: partition_on_def)
 
 lemma partition_onD2: "partition_on A P \<Longrightarrow> disjoint P"
   by (auto simp: partition_on_def)
 
 lemma partition_onD3: "partition_on A P \<Longrightarrow> {} \<notin> P"
   by (auto simp: partition_on_def)
 
 subsection \<open>Constructions of partitions\<close>
 
 lemma partition_on_empty: "partition_on {} P \<longleftrightarrow> P = {}"
   unfolding partition_on_def by fastforce
 
 lemma partition_on_space: "A \<noteq> {} \<Longrightarrow> partition_on A {A}"
   by (auto simp: partition_on_def disjoint_def)
 
 lemma partition_on_singletons: "partition_on A ((\<lambda>x. {x}) ` A)"
   by (auto simp: partition_on_def disjoint_def)
 
 lemma partition_on_transform:
   assumes P: "partition_on A P"
   assumes F_UN: "\<Union>(F ` P) = F (\<Union>P)" and F_disjnt: "\<And>p q. p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> disjnt p q \<Longrightarrow> disjnt (F p) (F q)"
   shows "partition_on (F A) (F ` P - {{}})"
 proof -
   have "\<Union>(F ` P - {{}}) = F A"
     unfolding P[THEN partition_onD1] F_UN[symmetric] by auto
   with P show ?thesis
     by (auto simp add: partition_on_def pairwise_def intro!: F_disjnt)
 qed
 
 lemma partition_on_restrict: "partition_on A P \<Longrightarrow> partition_on (B \<inter> A) ((\<inter>) B ` P - {{}})"
   by (intro partition_on_transform) (auto simp: disjnt_def)
 
 lemma partition_on_vimage: "partition_on A P \<Longrightarrow> partition_on (f -` A) ((-`) f ` P - {{}})"
   by (intro partition_on_transform) (auto simp: disjnt_def)
 
 lemma partition_on_inj_image:
   assumes P: "partition_on A P" and f: "inj_on f A"
   shows "partition_on (f ` A) ((`) f ` P - {{}})"
 proof (rule partition_on_transform[OF P])
   show "p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> disjnt p q \<Longrightarrow> disjnt (f ` p) (f ` q)" for p q
     using f[THEN inj_onD] P[THEN partition_onD1] by (auto simp: disjnt_def)
 qed auto
 
 lemma partition_on_insert:
   assumes "disjnt p (\<Union>P)"
   shows "partition_on A (insert p P) \<longleftrightarrow> partition_on (A-p) P \<and> p \<subseteq> A \<and> p \<noteq> {}"
   using assms
   by (auto simp: partition_on_def disjnt_iff pairwise_insert)
 
 subsection \<open>Finiteness of partitions\<close>
 
 lemma finitely_many_partition_on:
   assumes "finite A"
   shows "finite {P. partition_on A P}"
 proof (rule finite_subset)
   show "{P. partition_on A P} \<subseteq> Pow (Pow A)"
     unfolding partition_on_def by auto
   show "finite (Pow (Pow A))"
     using assms by simp
 qed
 
 lemma finite_elements: "finite A \<Longrightarrow> partition_on A P \<Longrightarrow> finite P"
   using partition_onD1[of A P] by (simp add: finite_UnionD)
 
+lemma product_partition:
+  assumes "partition_on A P" and "\<And>p. p \<in> P \<Longrightarrow> finite p" 
+  shows "card A = (\<Sum>p\<in>P. card p)"
+  using assms unfolding partition_on_def  by (meson card_Union_disjoint)
+
 subsection \<open>Equivalence of partitions and equivalence classes\<close>
 
 lemma partition_on_quotient:
   assumes r: "equiv A r"
   shows "partition_on A (A // r)"
 proof (rule partition_onI)
   from r have "refl_on A r"
     by (auto elim: equivE)
   then show "\<Union>(A // r) = A" "{} \<notin> A // r"
     by (auto simp: refl_on_def quotient_def)
 
   fix p q assume "p \<in> A // r" "q \<in> A // r" "p \<noteq> q"
   then obtain x y where "x \<in> A" "y \<in> A" "p = r `` {x}" "q = r `` {y}"
     by (auto simp: quotient_def)
   with r equiv_class_eq_iff[OF r, of x y] \<open>p \<noteq> q\<close> show "disjnt p q"
     by (auto simp: disjnt_equiv_class)
 qed
 
 lemma equiv_partition_on:
   assumes P: "partition_on A P"
   shows "equiv A {(x, y). \<exists>p \<in> P. x \<in> p \<and> y \<in> p}"
 proof (rule equivI)
   have "A = \<Union>P" "disjoint P" "{} \<notin> P"
     using P by (auto simp: partition_on_def)
   then show "refl_on A {(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p}"
     unfolding refl_on_def by auto
   show "trans {(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p}"
     using \<open>disjoint P\<close> by (auto simp: trans_def disjoint_def)
 qed (auto simp: sym_def)
 
 lemma partition_on_eq_quotient:
   assumes P: "partition_on A P"
   shows "A // {(x, y). \<exists>p \<in> P. x \<in> p \<and> y \<in> p} = P"
   unfolding quotient_def
 proof safe
   fix x assume "x \<in> A"
   then obtain p where "p \<in> P" "x \<in> p" "\<And>q. q \<in> P \<Longrightarrow> x \<in> q \<Longrightarrow> p = q"
     using P by (auto simp: partition_on_def disjoint_def)
   then have "{y. \<exists>p\<in>P. x \<in> p \<and> y \<in> p} = p"
     by (safe intro!: bexI[of _ p]) simp
   then show "{(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p} `` {x} \<in> P"
     by (simp add: \<open>p \<in> P\<close>)
 next
   fix p assume "p \<in> P"
   then have "p \<noteq> {}"
     using P by (auto simp: partition_on_def)
   then obtain x where "x \<in> p"
     by auto
   then have "x \<in> A" "\<And>q. q \<in> P \<Longrightarrow> x \<in> q \<Longrightarrow> p = q"
     using P \<open>p \<in> P\<close> by (auto simp: partition_on_def disjoint_def)
   with \<open>p\<in>P\<close> \<open>x \<in> p\<close> have "{y. \<exists>p\<in>P. x \<in> p \<and> y \<in> p} = p"
     by (safe intro!: bexI[of _ p]) simp
   then show "p \<in> (\<Union>x\<in>A. {{(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p} `` {x}})"
     by (auto intro: \<open>x \<in> A\<close>)
 qed
 
 lemma partition_on_alt: "partition_on A P \<longleftrightarrow> (\<exists>r. equiv A r \<and> P = A // r)"
   by (auto simp: partition_on_eq_quotient intro!: partition_on_quotient intro: equiv_partition_on)
 
 end
diff --git a/src/HOL/Power.thy b/src/HOL/Power.thy
--- a/src/HOL/Power.thy
+++ b/src/HOL/Power.thy
@@ -1,1021 +1,1025 @@
 (*  Title:      HOL/Power.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1997  University of Cambridge
 *)
 
 section \<open>Exponentiation\<close>
 
 theory Power
   imports Num
 begin
 
 subsection \<open>Powers for Arbitrary Monoids\<close>
 
 class power = one + times
 begin
 
 primrec power :: "'a \<Rightarrow> nat \<Rightarrow> 'a"  (infixr "^" 80)
   where
     power_0: "a ^ 0 = 1"
   | power_Suc: "a ^ Suc n = a * a ^ n"
 
 notation (latex output)
   power ("(_\<^bsup>_\<^esup>)" [1000] 1000)
 
 text \<open>Special syntax for squares.\<close>
 abbreviation power2 :: "'a \<Rightarrow> 'a"  ("(_\<^sup>2)" [1000] 999)
   where "x\<^sup>2 \<equiv> x ^ 2"
 
 end
 
 context
   includes lifting_syntax
 begin
 
 lemma power_transfer [transfer_rule]:
   \<open>(R ===> (=) ===> R) (^) (^)\<close>
     if [transfer_rule]: \<open>R 1 1\<close>
       \<open>(R ===> R ===> R) (*) (*)\<close>
     for R :: \<open>'a::power \<Rightarrow> 'b::power \<Rightarrow> bool\<close>
   by (simp only: power_def [abs_def]) transfer_prover
 
 end
 
 context monoid_mult
 begin
 
 subclass power .
 
 lemma power_one [simp]: "1 ^ n = 1"
   by (induct n) simp_all
 
 lemma power_one_right [simp]: "a ^ 1 = a"
   by simp
 
 lemma power_Suc0_right [simp]: "a ^ Suc 0 = a"
   by simp
 
 lemma power_commutes: "a ^ n * a = a * a ^ n"
   by (induct n) (simp_all add: mult.assoc)
 
 lemma power_Suc2: "a ^ Suc n = a ^ n * a"
   by (simp add: power_commutes)
 
 lemma power_add: "a ^ (m + n) = a ^ m * a ^ n"
   by (induct m) (simp_all add: algebra_simps)
 
 lemma power_mult: "a ^ (m * n) = (a ^ m) ^ n"
   by (induct n) (simp_all add: power_add)
 
 lemma power_even_eq: "a ^ (2 * n) = (a ^ n)\<^sup>2"
   by (subst mult.commute) (simp add: power_mult)
 
 lemma power_odd_eq: "a ^ Suc (2*n) = a * (a ^ n)\<^sup>2"
   by (simp add: power_even_eq)
 
 lemma power_numeral_even: "z ^ numeral (Num.Bit0 w) = (let w = z ^ (numeral w) in w * w)"
   by (simp only: numeral_Bit0 power_add Let_def)
 
 lemma power_numeral_odd: "z ^ numeral (Num.Bit1 w) = (let w = z ^ (numeral w) in z * w * w)"
   by (simp only: numeral_Bit1 One_nat_def add_Suc_right add_0_right
       power_Suc power_add Let_def mult.assoc)
 
 lemma power2_eq_square: "a\<^sup>2 = a * a"
   by (simp add: numeral_2_eq_2)
 
 lemma power3_eq_cube: "a ^ 3 = a * a * a"
   by (simp add: numeral_3_eq_3 mult.assoc)
 
 lemma power4_eq_xxxx: "x^4 = x * x * x * x"
   by (simp add: mult.assoc power_numeral_even)
 
 lemma funpow_times_power: "(times x ^^ f x) = times (x ^ f x)"
 proof (induct "f x" arbitrary: f)
   case 0
   then show ?case by (simp add: fun_eq_iff)
 next
   case (Suc n)
   define g where "g x = f x - 1" for x
   with Suc have "n = g x" by simp
   with Suc have "times x ^^ g x = times (x ^ g x)" by simp
   moreover from Suc g_def have "f x = g x + 1" by simp
   ultimately show ?case
     by (simp add: power_add funpow_add fun_eq_iff mult.assoc)
 qed
 
 lemma power_commuting_commutes:
   assumes "x * y = y * x"
   shows "x ^ n * y = y * x ^n"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   have "x ^ Suc n * y = x ^ n * y * x"
     by (subst power_Suc2) (simp add: assms ac_simps)
   also have "\<dots> = y * x ^ Suc n"
     by (simp only: Suc power_Suc2) (simp add: ac_simps)
   finally show ?case .
 qed
 
 lemma power_minus_mult: "0 < n \<Longrightarrow> a ^ (n - 1) * a = a ^ n"
   by (simp add: power_commutes split: nat_diff_split)
 
 lemma left_right_inverse_power:
   assumes "x * y = 1"
   shows   "x ^ n * y ^ n = 1"
 proof (induct n)
   case (Suc n)
   moreover have "x ^ Suc n * y ^ Suc n = x^n * (x * y) * y^n"
     by (simp add: power_Suc2[symmetric] mult.assoc[symmetric])
   ultimately show ?case by (simp add: assms)
 qed simp
 
 end
 
 context comm_monoid_mult
 begin
 
 lemma power_mult_distrib [algebra_simps, algebra_split_simps, field_simps, field_split_simps, divide_simps]:
   "(a * b) ^ n = (a ^ n) * (b ^ n)"
   by (induction n) (simp_all add: ac_simps)
 
 end
 
 text \<open>Extract constant factors from powers.\<close>
 declare power_mult_distrib [where a = "numeral w" for w, simp]
 declare power_mult_distrib [where b = "numeral w" for w, simp]
 
 lemma power_add_numeral [simp]: "a^numeral m * a^numeral n = a^numeral (m + n)"
   for a :: "'a::monoid_mult"
   by (simp add: power_add [symmetric])
 
 lemma power_add_numeral2 [simp]: "a^numeral m * (a^numeral n * b) = a^numeral (m + n) * b"
   for a :: "'a::monoid_mult"
   by (simp add: mult.assoc [symmetric])
 
 lemma power_mult_numeral [simp]: "(a^numeral m)^numeral n = a^numeral (m * n)"
   for a :: "'a::monoid_mult"
   by (simp only: numeral_mult power_mult)
 
 context semiring_numeral
 begin
 
 lemma numeral_sqr: "numeral (Num.sqr k) = numeral k * numeral k"
   by (simp only: sqr_conv_mult numeral_mult)
 
 lemma numeral_pow: "numeral (Num.pow k l) = numeral k ^ numeral l"
   by (induct l)
     (simp_all only: numeral_class.numeral.simps pow.simps
       numeral_sqr numeral_mult power_add power_one_right)
 
 lemma power_numeral [simp]: "numeral k ^ numeral l = numeral (Num.pow k l)"
   by (rule numeral_pow [symmetric])
 
 end
 
 context semiring_1
 begin
 
 lemma of_nat_power [simp]: "of_nat (m ^ n) = of_nat m ^ n"
   by (induct n) simp_all
 
 lemma zero_power: "0 < n \<Longrightarrow> 0 ^ n = 0"
   by (cases n) simp_all
 
 lemma power_zero_numeral [simp]: "0 ^ numeral k = 0"
   by (simp add: numeral_eq_Suc)
 
 lemma zero_power2: "0\<^sup>2 = 0" (* delete? *)
   by (rule power_zero_numeral)
 
 lemma one_power2: "1\<^sup>2 = 1" (* delete? *)
   by (rule power_one)
 
 lemma power_0_Suc [simp]: "0 ^ Suc n = 0"
   by simp
 
 text \<open>It looks plausible as a simprule, but its effect can be strange.\<close>
 lemma power_0_left: "0 ^ n = (if n = 0 then 1 else 0)"
   by (cases n) simp_all
 
 end
 
 context semiring_char_0 begin
 
 lemma numeral_power_eq_of_nat_cancel_iff [simp]:
   "numeral x ^ n = of_nat y \<longleftrightarrow> numeral x ^ n = y"
   using of_nat_eq_iff by fastforce
 
 lemma real_of_nat_eq_numeral_power_cancel_iff [simp]:
   "of_nat y = numeral x ^ n \<longleftrightarrow> y = numeral x ^ n"
   using numeral_power_eq_of_nat_cancel_iff [of x n y] by (metis (mono_tags))
 
 lemma of_nat_eq_of_nat_power_cancel_iff[simp]: "(of_nat b) ^ w = of_nat x \<longleftrightarrow> b ^ w = x"
   by (metis of_nat_power of_nat_eq_iff)
 
 lemma of_nat_power_eq_of_nat_cancel_iff[simp]: "of_nat x = (of_nat b) ^ w \<longleftrightarrow> x = b ^ w"
   by (metis of_nat_eq_of_nat_power_cancel_iff)
 
 end
 
 context comm_semiring_1
 begin
 
 text \<open>The divides relation.\<close>
 
 lemma le_imp_power_dvd:
   assumes "m \<le> n"
   shows "a ^ m dvd a ^ n"
 proof
   from assms have "a ^ n = a ^ (m + (n - m))" by simp
   also have "\<dots> = a ^ m * a ^ (n - m)" by (rule power_add)
   finally show "a ^ n = a ^ m * a ^ (n - m)" .
 qed
 
 lemma power_le_dvd: "a ^ n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a ^ m dvd b"
   by (rule dvd_trans [OF le_imp_power_dvd])
 
 lemma dvd_power_same: "x dvd y \<Longrightarrow> x ^ n dvd y ^ n"
   by (induct n) (auto simp add: mult_dvd_mono)
 
 lemma dvd_power_le: "x dvd y \<Longrightarrow> m \<ge> n \<Longrightarrow> x ^ n dvd y ^ m"
   by (rule power_le_dvd [OF dvd_power_same])
 
 lemma dvd_power [simp]:
   fixes n :: nat
   assumes "n > 0 \<or> x = 1"
   shows "x dvd (x ^ n)"
   using assms
 proof
   assume "0 < n"
   then have "x ^ n = x ^ Suc (n - 1)" by simp
   then show "x dvd (x ^ n)" by simp
 next
   assume "x = 1"
   then show "x dvd (x ^ n)" by simp
 qed
 
 end
 
 context semiring_1_no_zero_divisors
 begin
 
 subclass power .
 
 lemma power_eq_0_iff [simp]: "a ^ n = 0 \<longleftrightarrow> a = 0 \<and> n > 0"
   by (induct n) auto
 
 lemma power_not_zero: "a \<noteq> 0 \<Longrightarrow> a ^ n \<noteq> 0"
   by (induct n) auto
 
 lemma zero_eq_power2 [simp]: "a\<^sup>2 = 0 \<longleftrightarrow> a = 0"
   unfolding power2_eq_square by simp
 
 end
 
 context ring_1
 begin
 
 lemma power_minus: "(- a) ^ n = (- 1) ^ n * a ^ n"
 proof (induct n)
   case 0
   show ?case by simp
 next
   case (Suc n)
   then show ?case
     by (simp del: power_Suc add: power_Suc2 mult.assoc)
 qed
 
 lemma power_minus': "NO_MATCH 1 x \<Longrightarrow> (-x) ^ n = (-1)^n * x ^ n"
   by (rule power_minus)
 
 lemma power_minus_Bit0: "(- x) ^ numeral (Num.Bit0 k) = x ^ numeral (Num.Bit0 k)"
   by (induct k, simp_all only: numeral_class.numeral.simps power_add
     power_one_right mult_minus_left mult_minus_right minus_minus)
 
 lemma power_minus_Bit1: "(- x) ^ numeral (Num.Bit1 k) = - (x ^ numeral (Num.Bit1 k))"
   by (simp only: eval_nat_numeral(3) power_Suc power_minus_Bit0 mult_minus_left)
 
 lemma power2_minus [simp]: "(- a)\<^sup>2 = a\<^sup>2"
   by (fact power_minus_Bit0)
 
 lemma power_minus1_even [simp]: "(- 1) ^ (2*n) = 1"
 proof (induct n)
   case 0
   show ?case by simp
 next
   case (Suc n)
   then show ?case by (simp add: power_add power2_eq_square)
 qed
 
 lemma power_minus1_odd: "(- 1) ^ Suc (2*n) = -1"
   by simp
 
 lemma power_minus_even [simp]: "(-a) ^ (2*n) = a ^ (2*n)"
   by (simp add: power_minus [of a])
 
 end
 
 context ring_1_no_zero_divisors
 begin
 
 lemma power2_eq_1_iff: "a\<^sup>2 = 1 \<longleftrightarrow> a = 1 \<or> a = - 1"
   using square_eq_1_iff [of a] by (simp add: power2_eq_square)
 
 end
 
 context idom
 begin
 
 lemma power2_eq_iff: "x\<^sup>2 = y\<^sup>2 \<longleftrightarrow> x = y \<or> x = - y"
   unfolding power2_eq_square by (rule square_eq_iff)
 
 end
 
 context semidom_divide
 begin
 
 lemma power_diff:
   "a ^ (m - n) = (a ^ m) div (a ^ n)" if "a \<noteq> 0" and "n \<le> m"
 proof -
   define q where "q = m - n"
   with \<open>n \<le> m\<close> have "m = q + n" by simp
   with \<open>a \<noteq> 0\<close> q_def show ?thesis
     by (simp add: power_add)
 qed
 
 end
 
 context algebraic_semidom
 begin
 
 lemma div_power: "b dvd a \<Longrightarrow> (a div b) ^ n = a ^ n div b ^ n"
   by (induct n) (simp_all add: div_mult_div_if_dvd dvd_power_same)
 
 lemma is_unit_power_iff: "is_unit (a ^ n) \<longleftrightarrow> is_unit a \<or> n = 0"
   by (induct n) (auto simp add: is_unit_mult_iff)
 
 lemma dvd_power_iff:
   assumes "x \<noteq> 0"
   shows   "x ^ m dvd x ^ n \<longleftrightarrow> is_unit x \<or> m \<le> n"
 proof
   assume *: "x ^ m dvd x ^ n"
   {
     assume "m > n"
     note *
     also have "x ^ n = x ^ n * 1" by simp
     also from \<open>m > n\<close> have "m = n + (m - n)" by simp
     also have "x ^ \<dots> = x ^ n * x ^ (m - n)" by (rule power_add)
     finally have "x ^ (m - n) dvd 1"
       by (subst (asm) dvd_times_left_cancel_iff) (insert assms, simp_all)
     with \<open>m > n\<close> have "is_unit x" by (simp add: is_unit_power_iff)
   }
   thus "is_unit x \<or> m \<le> n" by force
 qed (auto intro: unit_imp_dvd simp: is_unit_power_iff le_imp_power_dvd)
 
 
 end
 
 context normalization_semidom_multiplicative
 begin
 
 lemma normalize_power: "normalize (a ^ n) = normalize a ^ n"
   by (induct n) (simp_all add: normalize_mult)
 
 lemma unit_factor_power: "unit_factor (a ^ n) = unit_factor a ^ n"
   by (induct n) (simp_all add: unit_factor_mult)
 
 end
 
 context division_ring
 begin
 
 text \<open>Perhaps these should be simprules.\<close>
 lemma power_inverse [field_simps, field_split_simps, divide_simps]: "inverse a ^ n = inverse (a ^ n)"
 proof (cases "a = 0")
   case True
   then show ?thesis by (simp add: power_0_left)
 next
   case False
   then have "inverse (a ^ n) = inverse a ^ n"
     by (induct n) (simp_all add: nonzero_inverse_mult_distrib power_commutes)
   then show ?thesis by simp
 qed
 
 lemma power_one_over [field_simps, field_split_simps, divide_simps]: "(1 / a) ^ n = 1 / a ^ n"
   using power_inverse [of a] by (simp add: divide_inverse)
 
 end
 
 context field
 begin
 
 lemma power_divide [field_simps, field_split_simps, divide_simps]: "(a / b) ^ n = a ^ n / b ^ n"
   by (induct n) simp_all
 
 end
 
 
 subsection \<open>Exponentiation on ordered types\<close>
 
 context linordered_semidom
 begin
 
 lemma zero_less_power [simp]: "0 < a \<Longrightarrow> 0 < a ^ n"
   by (induct n) simp_all
 
 lemma zero_le_power [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> a ^ n"
   by (induct n) simp_all
 
 lemma power_mono: "a \<le> b \<Longrightarrow> 0 \<le> a \<Longrightarrow> a ^ n \<le> b ^ n"
   by (induct n) (auto intro: mult_mono order_trans [of 0 a b])
 
 lemma one_le_power [simp]: "1 \<le> a \<Longrightarrow> 1 \<le> a ^ n"
   using power_mono [of 1 a n] by simp
 
 lemma power_le_one: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ n \<le> 1"
   using power_mono [of a 1 n] by simp
 
 lemma power_gt1_lemma:
   assumes gt1: "1 < a"
   shows "1 < a * a ^ n"
 proof -
   from gt1 have "0 \<le> a"
     by (fact order_trans [OF zero_le_one less_imp_le])
   from gt1 have "1 * 1 < a * 1" by simp
   also from gt1 have "\<dots> \<le> a * a ^ n"
     by (simp only: mult_mono \<open>0 \<le> a\<close> one_le_power order_less_imp_le zero_le_one order_refl)
   finally show ?thesis by simp
 qed
 
 lemma power_gt1: "1 < a \<Longrightarrow> 1 < a ^ Suc n"
   by (simp add: power_gt1_lemma)
 
 lemma one_less_power [simp]: "1 < a \<Longrightarrow> 0 < n \<Longrightarrow> 1 < a ^ n"
   by (cases n) (simp_all add: power_gt1_lemma)
 
 lemma power_le_imp_le_exp:
   assumes gt1: "1 < a"
   shows "a ^ m \<le> a ^ n \<Longrightarrow> m \<le> n"
 proof (induct m arbitrary: n)
   case 0
   show ?case by simp
 next
   case (Suc m)
   show ?case
   proof (cases n)
     case 0
     with Suc have "a * a ^ m \<le> 1" by simp
     with gt1 show ?thesis
       by (force simp only: power_gt1_lemma not_less [symmetric])
   next
     case (Suc n)
     with Suc.prems Suc.hyps show ?thesis
       by (force dest: mult_left_le_imp_le simp add: less_trans [OF zero_less_one gt1])
   qed
 qed
 
 lemma of_nat_zero_less_power_iff [simp]: "of_nat x ^ n > 0 \<longleftrightarrow> x > 0 \<or> n = 0"
   by (induct n) auto
 
 text \<open>Surely we can strengthen this? It holds for \<open>0<a<1\<close> too.\<close>
 lemma power_inject_exp [simp]:
   \<open>a ^ m = a ^ n \<longleftrightarrow> m = n\<close> if \<open>1 < a\<close>
   using that by (force simp add: order_class.order.antisym power_le_imp_le_exp)
 
 text \<open>
   Can relax the first premise to \<^term>\<open>0<a\<close> in the case of the
   natural numbers.
 \<close>
 lemma power_less_imp_less_exp: "1 < a \<Longrightarrow> a ^ m < a ^ n \<Longrightarrow> m < n"
   by (simp add: order_less_le [of m n] less_le [of "a^m" "a^n"] power_le_imp_le_exp)
 
 lemma power_strict_mono [rule_format]: "a < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<longrightarrow> a ^ n < b ^ n"
   by (induct n) (auto simp: mult_strict_mono le_less_trans [of 0 a b])
 
 lemma power_mono_iff [simp]:
   shows "\<lbrakk>a \<ge> 0; b \<ge> 0; n>0\<rbrakk> \<Longrightarrow> a ^ n \<le> b ^ n \<longleftrightarrow> a \<le> b"
   using power_mono [of a b] power_strict_mono [of b a] not_le by auto
 
 text\<open>Lemma for \<open>power_strict_decreasing\<close>\<close>
 lemma power_Suc_less: "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a * a ^ n < a ^ n"
   by (induct n) (auto simp: mult_strict_left_mono)
 
 lemma power_strict_decreasing [rule_format]: "n < N \<Longrightarrow> 0 < a \<Longrightarrow> a < 1 \<longrightarrow> a ^ N < a ^ n"
 proof (induct N)
   case 0
   then show ?case by simp
 next
   case (Suc N)
   then show ?case
     apply (auto simp add: power_Suc_less less_Suc_eq)
     apply (subgoal_tac "a * a^N < 1 * a^n")
      apply simp
     apply (rule mult_strict_mono)
        apply auto
     done
 qed
 
 text \<open>Proof resembles that of \<open>power_strict_decreasing\<close>.\<close>
 lemma power_decreasing: "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ N \<le> a ^ n"
 proof (induct N)
   case 0
   then show ?case by simp
 next
   case (Suc N)
   then show ?case
     apply (auto simp add: le_Suc_eq)
     apply (subgoal_tac "a * a^N \<le> 1 * a^n")
      apply simp
     apply (rule mult_mono)
        apply auto
     done
 qed
 
 lemma power_decreasing_iff [simp]: "\<lbrakk>0 < b; b < 1\<rbrakk> \<Longrightarrow> b ^ m \<le> b ^ n \<longleftrightarrow> n \<le> m"
   using power_strict_decreasing [of m n b]
   by (auto intro: power_decreasing ccontr)
 
 lemma power_strict_decreasing_iff [simp]: "\<lbrakk>0 < b; b < 1\<rbrakk> \<Longrightarrow> b ^ m < b ^ n \<longleftrightarrow> n < m"
   using power_decreasing_iff [of b m n] unfolding le_less
   by (auto dest: power_strict_decreasing le_neq_implies_less)
 
 lemma power_Suc_less_one: "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a ^ Suc n < 1"
   using power_strict_decreasing [of 0 "Suc n" a] by simp
 
 text \<open>Proof again resembles that of \<open>power_strict_decreasing\<close>.\<close>
 lemma power_increasing: "n \<le> N \<Longrightarrow> 1 \<le> a \<Longrightarrow> a ^ n \<le> a ^ N"
 proof (induct N)
   case 0
   then show ?case by simp
 next
   case (Suc N)
   then show ?case
     apply (auto simp add: le_Suc_eq)
     apply (subgoal_tac "1 * a^n \<le> a * a^N")
      apply simp
     apply (rule mult_mono)
        apply (auto simp add: order_trans [OF zero_le_one])
     done
 qed
 
 text \<open>Lemma for \<open>power_strict_increasing\<close>.\<close>
 lemma power_less_power_Suc: "1 < a \<Longrightarrow> a ^ n < a * a ^ n"
   by (induct n) (auto simp: mult_strict_left_mono less_trans [OF zero_less_one])
 
 lemma power_strict_increasing: "n < N \<Longrightarrow> 1 < a \<Longrightarrow> a ^ n < a ^ N"
 proof (induct N)
   case 0
   then show ?case by simp
 next
   case (Suc N)
   then show ?case
     apply (auto simp add: power_less_power_Suc less_Suc_eq)
     apply (subgoal_tac "1 * a^n < a * a^N")
      apply simp
     apply (rule mult_strict_mono)
     apply (auto simp add: less_trans [OF zero_less_one] less_imp_le)
     done
 qed
 
 lemma power_increasing_iff [simp]: "1 < b \<Longrightarrow> b ^ x \<le> b ^ y \<longleftrightarrow> x \<le> y"
   by (blast intro: power_le_imp_le_exp power_increasing less_imp_le)
 
 lemma power_strict_increasing_iff [simp]: "1 < b \<Longrightarrow> b ^ x < b ^ y \<longleftrightarrow> x < y"
   by (blast intro: power_less_imp_less_exp power_strict_increasing)
 
 lemma power_le_imp_le_base:
   assumes le: "a ^ Suc n \<le> b ^ Suc n"
     and "0 \<le> b"
   shows "a \<le> b"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   then have "b < a" by (simp only: linorder_not_le)
   then have "b ^ Suc n < a ^ Suc n"
     by (simp only: assms(2) power_strict_mono)
   with le show False
     by (simp add: linorder_not_less [symmetric])
 qed
 
 lemma power_less_imp_less_base:
   assumes less: "a ^ n < b ^ n"
   assumes nonneg: "0 \<le> b"
   shows "a < b"
 proof (rule contrapos_pp [OF less])
   assume "\<not> ?thesis"
   then have "b \<le> a" by (simp only: linorder_not_less)
   from this nonneg have "b ^ n \<le> a ^ n" by (rule power_mono)
   then show "\<not> a ^ n < b ^ n" by (simp only: linorder_not_less)
 qed
 
 lemma power_inject_base: "a ^ Suc n = b ^ Suc n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a = b"
   by (blast intro: power_le_imp_le_base order.antisym eq_refl sym)
 
 lemma power_eq_imp_eq_base: "a ^ n = b ^ n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < n \<Longrightarrow> a = b"
   by (cases n) (simp_all del: power_Suc, rule power_inject_base)
 
 lemma power_eq_iff_eq_base: "0 < n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a ^ n = b ^ n \<longleftrightarrow> a = b"
   using power_eq_imp_eq_base [of a n b] by auto
 
 lemma power2_le_imp_le: "x\<^sup>2 \<le> y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y"
   unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)
 
 lemma power2_less_imp_less: "x\<^sup>2 < y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y"
   by (rule power_less_imp_less_base)
 
 lemma power2_eq_imp_eq: "x\<^sup>2 = y\<^sup>2 \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x = y"
   unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base) simp
 
 lemma power_Suc_le_self: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ Suc n \<le> a"
   using power_decreasing [of 1 "Suc n" a] by simp
 
 lemma power2_eq_iff_nonneg [simp]:
   assumes "0 \<le> x" "0 \<le> y"
   shows "(x ^ 2 = y ^ 2) \<longleftrightarrow> x = y"
 using assms power2_eq_imp_eq by blast
 
 lemma of_nat_less_numeral_power_cancel_iff[simp]:
   "of_nat x < numeral i ^ n \<longleftrightarrow> x < numeral i ^ n"
   using of_nat_less_iff[of x "numeral i ^ n", unfolded of_nat_numeral of_nat_power] .
 
 lemma of_nat_le_numeral_power_cancel_iff[simp]:
   "of_nat x \<le> numeral i ^ n \<longleftrightarrow> x \<le> numeral i ^ n"
   using of_nat_le_iff[of x "numeral i ^ n", unfolded of_nat_numeral of_nat_power] .
 
 lemma numeral_power_less_of_nat_cancel_iff[simp]:
   "numeral i ^ n < of_nat x \<longleftrightarrow> numeral i ^ n < x"
   using of_nat_less_iff[of "numeral i ^ n" x, unfolded of_nat_numeral of_nat_power] .
 
 lemma numeral_power_le_of_nat_cancel_iff[simp]:
   "numeral i ^ n \<le> of_nat x \<longleftrightarrow> numeral i ^ n \<le> x"
   using of_nat_le_iff[of "numeral i ^ n" x, unfolded of_nat_numeral of_nat_power] .
 
 lemma of_nat_le_of_nat_power_cancel_iff[simp]: "(of_nat b) ^ w \<le> of_nat x \<longleftrightarrow> b ^ w \<le> x"
   by (metis of_nat_le_iff of_nat_power)
 
 lemma of_nat_power_le_of_nat_cancel_iff[simp]: "of_nat x \<le> (of_nat b) ^ w \<longleftrightarrow> x \<le> b ^ w"
   by (metis of_nat_le_iff of_nat_power)
 
 lemma of_nat_less_of_nat_power_cancel_iff[simp]: "(of_nat b) ^ w < of_nat x \<longleftrightarrow> b ^ w < x"
   by (metis of_nat_less_iff of_nat_power)
 
 lemma of_nat_power_less_of_nat_cancel_iff[simp]: "of_nat x < (of_nat b) ^ w \<longleftrightarrow> x < b ^ w"
   by (metis of_nat_less_iff of_nat_power)
 
 end
 
 
 text \<open>Some @{typ nat}-specific lemmas:\<close>
 
 lemma mono_ge2_power_minus_self:
   assumes "k \<ge> 2" shows "mono (\<lambda>m. k ^ m - m)"
 unfolding mono_iff_le_Suc
 proof
   fix n
   have "k ^ n < k ^ Suc n" using power_strict_increasing_iff[of k "n" "Suc n"] assms by linarith
   thus "k ^ n - n \<le> k ^ Suc n - Suc n" by linarith
 qed
 
 lemma self_le_ge2_pow[simp]:
   assumes "k \<ge> 2" shows "m \<le> k ^ m"
 proof (induction m)
   case 0 show ?case by simp
 next
   case (Suc m)
   hence "Suc m \<le> Suc (k ^ m)" by simp
   also have "... \<le> k^m + k^m" using one_le_power[of k m] assms by linarith
   also have "... \<le> k * k^m" by (metis mult_2 mult_le_mono1[OF assms])
   finally show ?case by simp
 qed
 
 lemma diff_le_diff_pow[simp]:
   assumes "k \<ge> 2" shows "m - n \<le> k ^ m - k ^ n"
 proof (cases "n \<le> m")
   case True
   thus ?thesis
     using monoD[OF mono_ge2_power_minus_self[OF assms] True] self_le_ge2_pow[OF assms, of m]
     by (simp add: le_diff_conv le_diff_conv2)
 qed auto
 
 
 context linordered_ring_strict
 begin
 
 lemma sum_squares_eq_zero_iff: "x * x + y * y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   by (simp add: add_nonneg_eq_0_iff)
 
 lemma sum_squares_le_zero_iff: "x * x + y * y \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   by (simp add: le_less not_sum_squares_lt_zero sum_squares_eq_zero_iff)
 
 lemma sum_squares_gt_zero_iff: "0 < x * x + y * y \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
   by (simp add: not_le [symmetric] sum_squares_le_zero_iff)
 
 end
 
 context linordered_idom
 begin
 
 lemma zero_le_power2 [simp]: "0 \<le> a\<^sup>2"
   by (simp add: power2_eq_square)
 
 lemma zero_less_power2 [simp]: "0 < a\<^sup>2 \<longleftrightarrow> a \<noteq> 0"
   by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)
 
 lemma power2_less_0 [simp]: "\<not> a\<^sup>2 < 0"
   by (force simp add: power2_eq_square mult_less_0_iff)
 
 lemma power_abs: "\<bar>a ^ n\<bar> = \<bar>a\<bar> ^ n" \<comment> \<open>FIXME simp?\<close>
   by (induct n) (simp_all add: abs_mult)
 
 lemma power_sgn [simp]: "sgn (a ^ n) = sgn a ^ n"
   by (induct n) (simp_all add: sgn_mult)
 
 lemma abs_power_minus [simp]: "\<bar>(- a) ^ n\<bar> = \<bar>a ^ n\<bar>"
   by (simp add: power_abs)
 
 lemma zero_less_power_abs_iff [simp]: "0 < \<bar>a\<bar> ^ n \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
 proof (induct n)
   case 0
   show ?case by simp
 next
   case Suc
   then show ?case by (auto simp: zero_less_mult_iff)
 qed
 
 lemma zero_le_power_abs [simp]: "0 \<le> \<bar>a\<bar> ^ n"
   by (rule zero_le_power [OF abs_ge_zero])
 
 lemma power2_less_eq_zero_iff [simp]: "a\<^sup>2 \<le> 0 \<longleftrightarrow> a = 0"
   by (simp add: le_less)
 
 lemma abs_power2 [simp]: "\<bar>a\<^sup>2\<bar> = a\<^sup>2"
   by (simp add: power2_eq_square)
 
 lemma power2_abs [simp]: "\<bar>a\<bar>\<^sup>2 = a\<^sup>2"
   by (simp add: power2_eq_square)
 
 lemma odd_power_less_zero: "a < 0 \<Longrightarrow> a ^ Suc (2 * n) < 0"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
     by (simp add: ac_simps power_add power2_eq_square)
   then show ?case
     by (simp del: power_Suc add: Suc mult_less_0_iff mult_neg_neg)
 qed
 
 lemma odd_0_le_power_imp_0_le: "0 \<le> a ^ Suc (2 * n) \<Longrightarrow> 0 \<le> a"
   using odd_power_less_zero [of a n]
   by (force simp add: linorder_not_less [symmetric])
 
 lemma zero_le_even_power'[simp]: "0 \<le> a ^ (2 * n)"
 proof (induct n)
   case 0
   show ?case by simp
 next
   case (Suc n)
   have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
     by (simp add: ac_simps power_add power2_eq_square)
   then show ?case
     by (simp add: Suc zero_le_mult_iff)
 qed
 
 lemma sum_power2_ge_zero: "0 \<le> x\<^sup>2 + y\<^sup>2"
   by (intro add_nonneg_nonneg zero_le_power2)
 
 lemma not_sum_power2_lt_zero: "\<not> x\<^sup>2 + y\<^sup>2 < 0"
   unfolding not_less by (rule sum_power2_ge_zero)
 
 lemma sum_power2_eq_zero_iff: "x\<^sup>2 + y\<^sup>2 = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   unfolding power2_eq_square by (simp add: add_nonneg_eq_0_iff)
 
 lemma sum_power2_le_zero_iff: "x\<^sup>2 + y\<^sup>2 \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   by (simp add: le_less sum_power2_eq_zero_iff not_sum_power2_lt_zero)
 
 lemma sum_power2_gt_zero_iff: "0 < x\<^sup>2 + y\<^sup>2 \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
   unfolding not_le [symmetric] by (simp add: sum_power2_le_zero_iff)
 
 lemma abs_le_square_iff: "\<bar>x\<bar> \<le> \<bar>y\<bar> \<longleftrightarrow> x\<^sup>2 \<le> y\<^sup>2"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   then have "\<bar>x\<bar>\<^sup>2 \<le> \<bar>y\<bar>\<^sup>2" by (rule power_mono) simp
   then show ?rhs by simp
 next
   assume ?rhs
   then show ?lhs
     by (auto intro!: power2_le_imp_le [OF _ abs_ge_zero])
 qed
 
+lemma power2_le_iff_abs_le:
+  "y \<ge> 0 \<Longrightarrow> x\<^sup>2 \<le> y\<^sup>2 \<longleftrightarrow> \<bar>x\<bar> \<le> y"
+  by (metis abs_le_square_iff abs_of_nonneg)
+
 lemma abs_square_le_1:"x\<^sup>2 \<le> 1 \<longleftrightarrow> \<bar>x\<bar> \<le> 1"
   using abs_le_square_iff [of x 1] by simp
 
 lemma abs_square_eq_1: "x\<^sup>2 = 1 \<longleftrightarrow> \<bar>x\<bar> = 1"
   by (auto simp add: abs_if power2_eq_1_iff)
 
 lemma abs_square_less_1: "x\<^sup>2 < 1 \<longleftrightarrow> \<bar>x\<bar> < 1"
   using  abs_square_eq_1 [of x] abs_square_le_1 [of x] by (auto simp add: le_less)
 
 lemma square_le_1:
   assumes "- 1 \<le> x" "x \<le> 1"
   shows "x\<^sup>2 \<le> 1"
     using assms
     by (metis add.inverse_inverse linear mult_le_one neg_equal_0_iff_equal neg_le_iff_le power2_eq_square power_minus_Bit0)
 
 end
 
 
 subsection \<open>Miscellaneous rules\<close>
 
 lemma (in linordered_semidom) self_le_power: "1 \<le> a \<Longrightarrow> 0 < n \<Longrightarrow> a \<le> a ^ n"
   using power_increasing [of 1 n a] power_one_right [of a] by auto
 
 lemma (in power) power_eq_if: "p ^ m = (if m=0 then 1 else p * (p ^ (m - 1)))"
   unfolding One_nat_def by (cases m) simp_all
 
 lemma (in comm_semiring_1) power2_sum: "(x + y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 + 2 * x * y"
   by (simp add: algebra_simps power2_eq_square mult_2_right)
 
 context comm_ring_1
 begin
 
 lemma power2_diff: "(x - y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 - 2 * x * y"
   by (simp add: algebra_simps power2_eq_square mult_2_right)
 
 lemma power2_commute: "(x - y)\<^sup>2 = (y - x)\<^sup>2"
   by (simp add: algebra_simps power2_eq_square)
 
 lemma minus_power_mult_self: "(- a) ^ n * (- a) ^ n = a ^ (2 * n)"
   by (simp add: power_mult_distrib [symmetric])
     (simp add: power2_eq_square [symmetric] power_mult [symmetric])
 
 lemma minus_one_mult_self [simp]: "(- 1) ^ n * (- 1) ^ n = 1"
   using minus_power_mult_self [of 1 n] by simp
 
 lemma left_minus_one_mult_self [simp]: "(- 1) ^ n * ((- 1) ^ n * a) = a"
   by (simp add: mult.assoc [symmetric])
 
 end
 
 text \<open>Simprules for comparisons where common factors can be cancelled.\<close>
 
 lemmas zero_compare_simps =
   add_strict_increasing add_strict_increasing2 add_increasing
   zero_le_mult_iff zero_le_divide_iff
   zero_less_mult_iff zero_less_divide_iff
   mult_le_0_iff divide_le_0_iff
   mult_less_0_iff divide_less_0_iff
   zero_le_power2 power2_less_0
 
 
 subsection \<open>Exponentiation for the Natural Numbers\<close>
 
 lemma nat_one_le_power [simp]: "Suc 0 \<le> i \<Longrightarrow> Suc 0 \<le> i ^ n"
   by (rule one_le_power [of i n, unfolded One_nat_def])
 
 lemma nat_zero_less_power_iff [simp]: "x ^ n > 0 \<longleftrightarrow> x > 0 \<or> n = 0"
   for x :: nat
   by (induct n) auto
 
 lemma nat_power_eq_Suc_0_iff [simp]: "x ^ m = Suc 0 \<longleftrightarrow> m = 0 \<or> x = Suc 0"
   by (induct m) auto
 
 lemma power_Suc_0 [simp]: "Suc 0 ^ n = Suc 0"
   by simp
 
 text \<open>
   Valid for the naturals, but what if \<open>0 < i < 1\<close>? Premises cannot be
   weakened: consider the case where \<open>i = 0\<close>, \<open>m = 1\<close> and \<open>n = 0\<close>.
 \<close>
 
 lemma nat_power_less_imp_less:
   fixes i :: nat
   assumes nonneg: "0 < i"
   assumes less: "i ^ m < i ^ n"
   shows "m < n"
 proof (cases "i = 1")
   case True
   with less power_one [where 'a = nat] show ?thesis by simp
 next
   case False
   with nonneg have "1 < i" by auto
   from power_strict_increasing_iff [OF this] less show ?thesis ..
 qed
 
 lemma power_gt_expt: "n > Suc 0 \<Longrightarrow> n^k > k"
   by (induction k) (auto simp: less_trans_Suc n_less_m_mult_n)
 
 lemma less_exp [simp]:
   \<open>n < 2 ^ n\<close>
   by (simp add: power_gt_expt)
 
 lemma power_dvd_imp_le:
   fixes i :: nat
   assumes "i ^ m dvd i ^ n" "1 < i"
   shows "m \<le> n"
   using assms by (auto intro: power_le_imp_le_exp [OF \<open>1 < i\<close> dvd_imp_le])
 
 lemma dvd_power_iff_le:
   fixes k::nat
   shows "2 \<le> k \<Longrightarrow> ((k ^ m) dvd (k ^ n) \<longleftrightarrow> m \<le> n)"
   using le_imp_power_dvd power_dvd_imp_le by force
 
 lemma power2_nat_le_eq_le: "m\<^sup>2 \<le> n\<^sup>2 \<longleftrightarrow> m \<le> n"
   for m n :: nat
   by (auto intro: power2_le_imp_le power_mono)
 
 lemma power2_nat_le_imp_le:
   fixes m n :: nat
   assumes "m\<^sup>2 \<le> n"
   shows "m \<le> n"
 proof (cases m)
   case 0
   then show ?thesis by simp
 next
   case (Suc k)
   show ?thesis
   proof (rule ccontr)
     assume "\<not> ?thesis"
     then have "n < m" by simp
     with assms Suc show False
       by (simp add: power2_eq_square)
   qed
 qed
 
 lemma ex_power_ivl1: fixes b k :: nat assumes "b \<ge> 2"
 shows "k \<ge> 1 \<Longrightarrow> \<exists>n. b^n \<le> k \<and> k < b^(n+1)" (is "_ \<Longrightarrow> \<exists>n. ?P k n")
 proof(induction k)
   case 0 thus ?case by simp
 next
   case (Suc k)
   show ?case
   proof cases
     assume "k=0"
     hence "?P (Suc k) 0" using assms by simp
     thus ?case ..
   next
     assume "k\<noteq>0"
     with Suc obtain n where IH: "?P k n" by auto
     show ?case
     proof (cases "k = b^(n+1) - 1")
       case True
       hence "?P (Suc k) (n+1)" using assms
         by (simp add: power_less_power_Suc)
       thus ?thesis ..
     next
       case False
       hence "?P (Suc k) n" using IH by auto
       thus ?thesis ..
     qed
   qed
 qed
 
 lemma ex_power_ivl2: fixes b k :: nat assumes "b \<ge> 2" "k \<ge> 2"
   shows "\<exists>n. b^n < k \<and> k \<le> b^(n+1)"
 proof -
   have "1 \<le> k - 1" using assms(2) by arith
   from ex_power_ivl1[OF assms(1) this]
   obtain n where "b ^ n \<le> k - 1 \<and> k - 1 < b ^ (n + 1)" ..
   hence "b^n < k \<and> k \<le> b^(n+1)" using assms by auto
   thus ?thesis ..
 qed
 
 
 subsubsection \<open>Cardinality of the Powerset\<close>
 
 lemma card_UNIV_bool [simp]: "card (UNIV :: bool set) = 2"
   unfolding UNIV_bool by simp
 
 lemma card_Pow: "finite A \<Longrightarrow> card (Pow A) = 2 ^ card A"
 proof (induct rule: finite_induct)
   case empty
   show ?case by simp
 next
   case (insert x A)
   from \<open>x \<notin> A\<close> have disjoint: "Pow A \<inter> insert x ` Pow A = {}" by blast
   from \<open>x \<notin> A\<close> have inj_on: "inj_on (insert x) (Pow A)"
     unfolding inj_on_def by auto
 
   have "card (Pow (insert x A)) = card (Pow A \<union> insert x ` Pow A)"
     by (simp only: Pow_insert)
   also have "\<dots> = card (Pow A) + card (insert x ` Pow A)"
     by (rule card_Un_disjoint) (use \<open>finite A\<close> disjoint in simp_all)
   also from inj_on have "card (insert x ` Pow A) = card (Pow A)"
     by (rule card_image)
   also have "\<dots> + \<dots> = 2 * \<dots>" by (simp add: mult_2)
   also from insert(3) have "\<dots> = 2 ^ Suc (card A)" by simp
   also from insert(1,2) have "Suc (card A) = card (insert x A)"
     by (rule card_insert_disjoint [symmetric])
   finally show ?case .
 qed
 
 
 subsection \<open>Code generator tweak\<close>
 
 code_identifier
   code_module Power \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 end