diff --git a/src/HOL/Complex.thy b/src/HOL/Complex.thy
--- a/src/HOL/Complex.thy
+++ b/src/HOL/Complex.thy
@@ -1,1327 +1,1331 @@
 (*  Title:       HOL/Complex.thy
     Author:      Jacques D. Fleuriot, 2001 University of Edinburgh
     Author:      Lawrence C Paulson, 2003/4
 *)
 
 section \<open>Complex Numbers: Rectangular and Polar Representations\<close>
 
 theory Complex
 imports Transcendental
 begin
 
 text \<open>
   We use the \<^theory_text>\<open>codatatype\<close> command to define the type of complex numbers. This
   allows us to use \<^theory_text>\<open>primcorec\<close> to define complex functions by defining their
   real and imaginary result separately.
 \<close>
 
 codatatype complex = Complex (Re: real) (Im: real)
 
 lemma complex_surj: "Complex (Re z) (Im z) = z"
   by (rule complex.collapse)
 
 lemma complex_eqI [intro?]: "Re x = Re y \<Longrightarrow> Im x = Im y \<Longrightarrow> x = y"
   by (rule complex.expand) simp
 
 lemma complex_eq_iff: "x = y \<longleftrightarrow> Re x = Re y \<and> Im x = Im y"
   by (auto intro: complex.expand)
 
 
+
 subsection \<open>Addition and Subtraction\<close>
 
 instantiation complex :: ab_group_add
 begin
 
 primcorec zero_complex
   where
     "Re 0 = 0"
   | "Im 0 = 0"
 
 primcorec plus_complex
   where
     "Re (x + y) = Re x + Re y"
   | "Im (x + y) = Im x + Im y"
 
 primcorec uminus_complex
   where
     "Re (- x) = - Re x"
   | "Im (- x) = - Im x"
 
 primcorec minus_complex
   where
     "Re (x - y) = Re x - Re y"
   | "Im (x - y) = Im x - Im y"
 
 instance
   by standard (simp_all add: complex_eq_iff)
 
 end
 
 
 subsection \<open>Multiplication and Division\<close>
 
 instantiation complex :: field
 begin
 
 primcorec one_complex
   where
     "Re 1 = 1"
   | "Im 1 = 0"
 
 primcorec times_complex
   where
     "Re (x * y) = Re x * Re y - Im x * Im y"
   | "Im (x * y) = Re x * Im y + Im x * Re y"
 
 primcorec inverse_complex
   where
     "Re (inverse x) = Re x / ((Re x)\<^sup>2 + (Im x)\<^sup>2)"
   | "Im (inverse x) = - Im x / ((Re x)\<^sup>2 + (Im x)\<^sup>2)"
 
 definition "x div y = x * inverse y" for x y :: complex
 
 instance
   by standard
      (simp_all add: complex_eq_iff divide_complex_def
       distrib_left distrib_right right_diff_distrib left_diff_distrib
       power2_eq_square add_divide_distrib [symmetric])
 
 end
 
 lemma Re_divide: "Re (x / y) = (Re x * Re y + Im x * Im y) / ((Re y)\<^sup>2 + (Im y)\<^sup>2)"
   by (simp add: divide_complex_def add_divide_distrib)
 
 lemma Im_divide: "Im (x / y) = (Im x * Re y - Re x * Im y) / ((Re y)\<^sup>2 + (Im y)\<^sup>2)"
   by (simp add: divide_complex_def diff_divide_distrib)
 
 lemma Complex_divide:
     "(x / y) = Complex ((Re x * Re y + Im x * Im y) / ((Re y)\<^sup>2 + (Im y)\<^sup>2))
                        ((Im x * Re y - Re x * Im y) / ((Re y)\<^sup>2 + (Im y)\<^sup>2))"
   by (metis Im_divide Re_divide complex_surj)
 
 lemma Re_power2: "Re (x ^ 2) = (Re x)^2 - (Im x)^2"
   by (simp add: power2_eq_square)
 
 lemma Im_power2: "Im (x ^ 2) = 2 * Re x * Im x"
   by (simp add: power2_eq_square)
 
 lemma Re_power_real [simp]: "Im x = 0 \<Longrightarrow> Re (x ^ n) = Re x ^ n "
   by (induct n) simp_all
 
 lemma Im_power_real [simp]: "Im x = 0 \<Longrightarrow> Im (x ^ n) = 0"
   by (induct n) simp_all
 
 
 subsection \<open>Scalar Multiplication\<close>
 
 instantiation complex :: real_field
 begin
 
 primcorec scaleR_complex
   where
     "Re (scaleR r x) = r * Re x"
   | "Im (scaleR r x) = r * Im x"
 
 instance
 proof
   fix a b :: real and x y :: complex
   show "scaleR a (x + y) = scaleR a x + scaleR a y"
     by (simp add: complex_eq_iff distrib_left)
   show "scaleR (a + b) x = scaleR a x + scaleR b x"
     by (simp add: complex_eq_iff distrib_right)
   show "scaleR a (scaleR b x) = scaleR (a * b) x"
     by (simp add: complex_eq_iff mult.assoc)
   show "scaleR 1 x = x"
     by (simp add: complex_eq_iff)
   show "scaleR a x * y = scaleR a (x * y)"
     by (simp add: complex_eq_iff algebra_simps)
   show "x * scaleR a y = scaleR a (x * y)"
     by (simp add: complex_eq_iff algebra_simps)
 qed
 
 end
 
 
 subsection \<open>Numerals, Arithmetic, and Embedding from R\<close>
 
 abbreviation complex_of_real :: "real \<Rightarrow> complex"
   where "complex_of_real \<equiv> of_real"
 
 declare [[coercion "of_real :: real \<Rightarrow> complex"]]
 declare [[coercion "of_rat :: rat \<Rightarrow> complex"]]
 declare [[coercion "of_int :: int \<Rightarrow> complex"]]
 declare [[coercion "of_nat :: nat \<Rightarrow> complex"]]
 
 lemma complex_Re_of_nat [simp]: "Re (of_nat n) = of_nat n"
   by (induct n) simp_all
 
 lemma complex_Im_of_nat [simp]: "Im (of_nat n) = 0"
   by (induct n) simp_all
 
 lemma complex_Re_of_int [simp]: "Re (of_int z) = of_int z"
   by (cases z rule: int_diff_cases) simp
 
 lemma complex_Im_of_int [simp]: "Im (of_int z) = 0"
   by (cases z rule: int_diff_cases) simp
 
 lemma complex_Re_numeral [simp]: "Re (numeral v) = numeral v"
   using complex_Re_of_int [of "numeral v"] by simp
 
 lemma complex_Im_numeral [simp]: "Im (numeral v) = 0"
   using complex_Im_of_int [of "numeral v"] by simp
 
 lemma Re_complex_of_real [simp]: "Re (complex_of_real z) = z"
   by (simp add: of_real_def)
 
 lemma Im_complex_of_real [simp]: "Im (complex_of_real z) = 0"
   by (simp add: of_real_def)
 
 lemma Re_divide_numeral [simp]: "Re (z / numeral w) = Re z / numeral w"
   by (simp add: Re_divide sqr_conv_mult)
 
 lemma Im_divide_numeral [simp]: "Im (z / numeral w) = Im z / numeral w"
   by (simp add: Im_divide sqr_conv_mult)
 
 lemma Re_divide_of_nat [simp]: "Re (z / of_nat n) = Re z / of_nat n"
   by (cases n) (simp_all add: Re_divide field_split_simps power2_eq_square del: of_nat_Suc)
 
 lemma Im_divide_of_nat [simp]: "Im (z / of_nat n) = Im z / of_nat n"
   by (cases n) (simp_all add: Im_divide field_split_simps power2_eq_square del: of_nat_Suc)
 
 lemma of_real_Re [simp]: "z \<in> \<real> \<Longrightarrow> of_real (Re z) = z"
   by (auto simp: Reals_def)
 
 lemma complex_Re_fact [simp]: "Re (fact n) = fact n"
 proof -
   have "(fact n :: complex) = of_real (fact n)"
     by simp
   also have "Re \<dots> = fact n"
     by (subst Re_complex_of_real) simp_all
   finally show ?thesis .
 qed
 
 lemma complex_Im_fact [simp]: "Im (fact n) = 0"
   by (subst of_nat_fact [symmetric]) (simp only: complex_Im_of_nat)
 
 lemma Re_prod_Reals: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<real>) \<Longrightarrow> Re (prod f A) = prod (\<lambda>x. Re (f x)) A"
 proof (induction A rule: infinite_finite_induct)
   case (insert x A)
   hence "Re (prod f (insert x A)) = Re (f x) * Re (prod f A) - Im (f x) * Im (prod f A)"
     by simp
   also from insert.prems have "f x \<in> \<real>" by simp
   hence "Im (f x) = 0" by (auto elim!: Reals_cases)
   also have "Re (prod f A) = (\<Prod>x\<in>A. Re (f x))"
     by (intro insert.IH insert.prems) auto
   finally show ?case using insert.hyps by simp
 qed auto
 
 
 subsection \<open>The Complex Number $i$\<close>
 
 primcorec imaginary_unit :: complex  ("\<i>")
   where
     "Re \<i> = 0"
   | "Im \<i> = 1"
 
 lemma Complex_eq: "Complex a b = a + \<i> * b"
   by (simp add: complex_eq_iff)
 
 lemma complex_eq: "a = Re a + \<i> * Im a"
   by (simp add: complex_eq_iff)
 
 lemma fun_complex_eq: "f = (\<lambda>x. Re (f x) + \<i> * Im (f x))"
   by (simp add: fun_eq_iff complex_eq)
 
 lemma i_squared [simp]: "\<i> * \<i> = -1"
   by (simp add: complex_eq_iff)
 
 lemma power2_i [simp]: "\<i>\<^sup>2 = -1"
   by (simp add: power2_eq_square)
 
 lemma inverse_i [simp]: "inverse \<i> = - \<i>"
   by (rule inverse_unique) simp
 
 lemma divide_i [simp]: "x / \<i> = - \<i> * x"
   by (simp add: divide_complex_def)
 
 lemma complex_i_mult_minus [simp]: "\<i> * (\<i> * x) = - x"
   by (simp add: mult.assoc [symmetric])
 
 lemma complex_i_not_zero [simp]: "\<i> \<noteq> 0"
   by (simp add: complex_eq_iff)
 
 lemma complex_i_not_one [simp]: "\<i> \<noteq> 1"
   by (simp add: complex_eq_iff)
 
 lemma complex_i_not_numeral [simp]: "\<i> \<noteq> numeral w"
   by (simp add: complex_eq_iff)
 
 lemma complex_i_not_neg_numeral [simp]: "\<i> \<noteq> - numeral w"
   by (simp add: complex_eq_iff)
 
 lemma complex_split_polar: "\<exists>r a. z = complex_of_real r * (cos a + \<i> * sin a)"
   by (simp add: complex_eq_iff polar_Ex)
 
 lemma i_even_power [simp]: "\<i> ^ (n * 2) = (-1) ^ n"
   by (metis mult.commute power2_i power_mult)
 
 lemma Re_i_times [simp]: "Re (\<i> * z) = - Im z"
   by simp
 
 lemma Im_i_times [simp]: "Im (\<i> * z) = Re z"
   by simp
 
 lemma i_times_eq_iff: "\<i> * w = z \<longleftrightarrow> w = - (\<i> * z)"
   by auto
 
 lemma divide_numeral_i [simp]: "z / (numeral n * \<i>) = - (\<i> * z) / numeral n"
   by (metis divide_divide_eq_left divide_i mult.commute mult_minus_right)
 
 lemma imaginary_eq_real_iff [simp]:
   assumes "y \<in> Reals" "x \<in> Reals"
   shows "\<i> * y = x \<longleftrightarrow> x=0 \<and> y=0"
     using assms
     unfolding Reals_def
     apply clarify
       apply (rule iffI)
     apply (metis Im_complex_of_real Im_i_times Re_complex_of_real mult_eq_0_iff of_real_0)
     by simp
 
 lemma real_eq_imaginary_iff [simp]:
   assumes "y \<in> Reals" "x \<in> Reals"
   shows "x = \<i> * y  \<longleftrightarrow> x=0 \<and> y=0"
     using assms imaginary_eq_real_iff by fastforce
 
 subsection \<open>Vector Norm\<close>
 
 instantiation complex :: real_normed_field
 begin
 
 definition "norm z = sqrt ((Re z)\<^sup>2 + (Im z)\<^sup>2)"
 
 abbreviation cmod :: "complex \<Rightarrow> real"
   where "cmod \<equiv> norm"
 
 definition complex_sgn_def: "sgn x = x /\<^sub>R cmod x"
 
 definition dist_complex_def: "dist x y = cmod (x - y)"
 
 definition uniformity_complex_def [code del]:
   "(uniformity :: (complex \<times> complex) filter) = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"
 
 definition open_complex_def [code del]:
   "open (U :: complex set) \<longleftrightarrow> (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"
 
 instance
 proof
   fix r :: real and x y :: complex and S :: "complex set"
   show "(norm x = 0) = (x = 0)"
     by (simp add: norm_complex_def complex_eq_iff)
   show "norm (x + y) \<le> norm x + norm y"
     by (simp add: norm_complex_def complex_eq_iff real_sqrt_sum_squares_triangle_ineq)
   show "norm (scaleR r x) = \<bar>r\<bar> * norm x"
     by (simp add: norm_complex_def complex_eq_iff power_mult_distrib distrib_left [symmetric]
         real_sqrt_mult)
   show "norm (x * y) = norm x * norm y"
     by (simp add: norm_complex_def complex_eq_iff real_sqrt_mult [symmetric]
         power2_eq_square algebra_simps)
 qed (rule complex_sgn_def dist_complex_def open_complex_def uniformity_complex_def)+
 
 end
 
 declare uniformity_Abort[where 'a = complex, code]
 
 lemma norm_ii [simp]: "norm \<i> = 1"
   by (simp add: norm_complex_def)
 
 lemma cmod_unit_one: "cmod (cos a + \<i> * sin a) = 1"
   by (simp add: norm_complex_def)
 
 lemma cmod_complex_polar: "cmod (r * (cos a + \<i> * sin a)) = \<bar>r\<bar>"
   by (simp add: norm_mult cmod_unit_one)
 
 lemma complex_Re_le_cmod: "Re x \<le> cmod x"
   unfolding norm_complex_def by (rule real_sqrt_sum_squares_ge1)
 
 lemma complex_mod_minus_le_complex_mod: "- cmod x \<le> cmod x"
   by (rule order_trans [OF _ norm_ge_zero]) simp
 
 lemma complex_mod_triangle_ineq2: "cmod (b + a) - cmod b \<le> cmod a"
   by (rule ord_le_eq_trans [OF norm_triangle_ineq2]) simp
 
 lemma abs_Re_le_cmod: "\<bar>Re x\<bar> \<le> cmod x"
   by (simp add: norm_complex_def)
 
 lemma abs_Im_le_cmod: "\<bar>Im x\<bar> \<le> cmod x"
   by (simp add: norm_complex_def)
 
 lemma cmod_le: "cmod z \<le> \<bar>Re z\<bar> + \<bar>Im z\<bar>"
   apply (subst complex_eq)
   apply (rule order_trans)
    apply (rule norm_triangle_ineq)
   apply (simp add: norm_mult)
   done
 
 lemma cmod_eq_Re: "Im z = 0 \<Longrightarrow> cmod z = \<bar>Re z\<bar>"
   by (simp add: norm_complex_def)
 
 lemma cmod_eq_Im: "Re z = 0 \<Longrightarrow> cmod z = \<bar>Im z\<bar>"
   by (simp add: norm_complex_def)
 
 lemma cmod_power2: "(cmod z)\<^sup>2 = (Re z)\<^sup>2 + (Im z)\<^sup>2"
   by (simp add: norm_complex_def)
 
 lemma cmod_plus_Re_le_0_iff: "cmod z + Re z \<le> 0 \<longleftrightarrow> Re z = - cmod z"
   using abs_Re_le_cmod[of z] by auto
 
 lemma cmod_Re_le_iff: "Im x = Im y \<Longrightarrow> cmod x \<le> cmod y \<longleftrightarrow> \<bar>Re x\<bar> \<le> \<bar>Re y\<bar>"
   by (metis add.commute add_le_cancel_left norm_complex_def real_sqrt_abs real_sqrt_le_iff)
 
 lemma cmod_Im_le_iff: "Re x = Re y \<Longrightarrow> cmod x \<le> cmod y \<longleftrightarrow> \<bar>Im x\<bar> \<le> \<bar>Im y\<bar>"
   by (metis add_le_cancel_left norm_complex_def real_sqrt_abs real_sqrt_le_iff)
 
 lemma Im_eq_0: "\<bar>Re z\<bar> = cmod z \<Longrightarrow> Im z = 0"
   by (subst (asm) power_eq_iff_eq_base[symmetric, where n=2]) (auto simp add: norm_complex_def)
 
 lemma abs_sqrt_wlog: "(\<And>x. x \<ge> 0 \<Longrightarrow> P x (x\<^sup>2)) \<Longrightarrow> P \<bar>x\<bar> (x\<^sup>2)"
   for x::"'a::linordered_idom"
   by (metis abs_ge_zero power2_abs)
 
 lemma complex_abs_le_norm: "\<bar>Re z\<bar> + \<bar>Im z\<bar> \<le> sqrt 2 * norm z"
   unfolding norm_complex_def
   apply (rule abs_sqrt_wlog [where x="Re z"])
   apply (rule abs_sqrt_wlog [where x="Im z"])
   apply (rule power2_le_imp_le)
    apply (simp_all add: power2_sum add.commute sum_squares_bound real_sqrt_mult [symmetric])
   done
 
 lemma complex_unit_circle: "z \<noteq> 0 \<Longrightarrow> (Re z / cmod z)\<^sup>2 + (Im z / cmod z)\<^sup>2 = 1"
   by (simp add: norm_complex_def complex_eq_iff power2_eq_square add_divide_distrib [symmetric])
 
 
 text \<open>Properties of complex signum.\<close>
 
 lemma sgn_eq: "sgn z = z / complex_of_real (cmod z)"
   by (simp add: sgn_div_norm divide_inverse scaleR_conv_of_real mult.commute)
 
 lemma Re_sgn [simp]: "Re(sgn z) = Re(z)/cmod z"
   by (simp add: complex_sgn_def divide_inverse)
 
 lemma Im_sgn [simp]: "Im(sgn z) = Im(z)/cmod z"
   by (simp add: complex_sgn_def divide_inverse)
 
 
 subsection \<open>Absolute value\<close>
 
 instantiation complex :: field_abs_sgn
 begin
 
 definition abs_complex :: "complex \<Rightarrow> complex"
   where "abs_complex = of_real \<circ> norm"
 
 instance
   apply standard
          apply (auto simp add: abs_complex_def complex_sgn_def norm_mult)
   apply (auto simp add: scaleR_conv_of_real field_simps)
   done
 
 end
 
 
 subsection \<open>Completeness of the Complexes\<close>
 
 lemma bounded_linear_Re: "bounded_linear Re"
   by (rule bounded_linear_intro [where K=1]) (simp_all add: norm_complex_def)
 
 lemma bounded_linear_Im: "bounded_linear Im"
   by (rule bounded_linear_intro [where K=1]) (simp_all add: norm_complex_def)
 
 lemmas Cauchy_Re = bounded_linear.Cauchy [OF bounded_linear_Re]
 lemmas Cauchy_Im = bounded_linear.Cauchy [OF bounded_linear_Im]
 lemmas tendsto_Re [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Re]
 lemmas tendsto_Im [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im]
 lemmas isCont_Re [simp] = bounded_linear.isCont [OF bounded_linear_Re]
 lemmas isCont_Im [simp] = bounded_linear.isCont [OF bounded_linear_Im]
 lemmas continuous_Re [simp] = bounded_linear.continuous [OF bounded_linear_Re]
 lemmas continuous_Im [simp] = bounded_linear.continuous [OF bounded_linear_Im]
 lemmas continuous_on_Re [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Re]
 lemmas continuous_on_Im [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im]
 lemmas has_derivative_Re [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Re]
 lemmas has_derivative_Im [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im]
 lemmas sums_Re = bounded_linear.sums [OF bounded_linear_Re]
 lemmas sums_Im = bounded_linear.sums [OF bounded_linear_Im]
 
 lemma tendsto_Complex [tendsto_intros]:
   "(f \<longlongrightarrow> a) F \<Longrightarrow> (g \<longlongrightarrow> b) F \<Longrightarrow> ((\<lambda>x. Complex (f x) (g x)) \<longlongrightarrow> Complex a b) F"
   unfolding Complex_eq by (auto intro!: tendsto_intros)
 
 lemma tendsto_complex_iff:
   "(f \<longlongrightarrow> x) F \<longleftrightarrow> (((\<lambda>x. Re (f x)) \<longlongrightarrow> Re x) F \<and> ((\<lambda>x. Im (f x)) \<longlongrightarrow> Im x) F)"
 proof safe
   assume "((\<lambda>x. Re (f x)) \<longlongrightarrow> Re x) F" "((\<lambda>x. Im (f x)) \<longlongrightarrow> Im x) F"
   from tendsto_Complex[OF this] show "(f \<longlongrightarrow> x) F"
     unfolding complex.collapse .
 qed (auto intro: tendsto_intros)
 
 lemma continuous_complex_iff:
   "continuous F f \<longleftrightarrow> continuous F (\<lambda>x. Re (f x)) \<and> continuous F (\<lambda>x. Im (f x))"
   by (simp only: continuous_def tendsto_complex_iff)
 
 lemma continuous_on_of_real_o_iff [simp]:
      "continuous_on S (\<lambda>x. complex_of_real (g x)) = continuous_on S g"
   using continuous_on_Re continuous_on_of_real  by fastforce
 
 lemma continuous_on_of_real_id [simp]:
      "continuous_on S (of_real :: real \<Rightarrow> 'a::real_normed_algebra_1)"
   by (rule continuous_on_of_real [OF continuous_on_id])
 
 lemma has_vector_derivative_complex_iff: "(f has_vector_derivative x) F \<longleftrightarrow>
     ((\<lambda>x. Re (f x)) has_field_derivative (Re x)) F \<and>
     ((\<lambda>x. Im (f x)) has_field_derivative (Im x)) F"
   by (simp add: has_vector_derivative_def has_field_derivative_def has_derivative_def
       tendsto_complex_iff algebra_simps bounded_linear_scaleR_left bounded_linear_mult_right)
 
 lemma has_field_derivative_Re[derivative_intros]:
   "(f has_vector_derivative D) F \<Longrightarrow> ((\<lambda>x. Re (f x)) has_field_derivative (Re D)) F"
   unfolding has_vector_derivative_complex_iff by safe
 
 lemma has_field_derivative_Im[derivative_intros]:
   "(f has_vector_derivative D) F \<Longrightarrow> ((\<lambda>x. Im (f x)) has_field_derivative (Im D)) F"
   unfolding has_vector_derivative_complex_iff by safe
 
 instance complex :: banach
 proof
   fix X :: "nat \<Rightarrow> complex"
   assume X: "Cauchy X"
   then have "(\<lambda>n. Complex (Re (X n)) (Im (X n))) \<longlonglongrightarrow>
     Complex (lim (\<lambda>n. Re (X n))) (lim (\<lambda>n. Im (X n)))"
     by (intro tendsto_Complex convergent_LIMSEQ_iff[THEN iffD1]
         Cauchy_convergent_iff[THEN iffD1] Cauchy_Re Cauchy_Im)
   then show "convergent X"
     unfolding complex.collapse by (rule convergentI)
 qed
 
 declare DERIV_power[where 'a=complex, unfolded of_nat_def[symmetric], derivative_intros]
 
 
 subsection \<open>Complex Conjugation\<close>
 
 primcorec cnj :: "complex \<Rightarrow> complex"
   where
     "Re (cnj z) = Re z"
   | "Im (cnj z) = - Im z"
 
 lemma complex_cnj_cancel_iff [simp]: "cnj x = cnj y \<longleftrightarrow> x = y"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_cnj [simp]: "cnj (cnj z) = z"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_zero [simp]: "cnj 0 = 0"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_zero_iff [iff]: "cnj z = 0 \<longleftrightarrow> z = 0"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_one_iff [simp]: "cnj z = 1 \<longleftrightarrow> z = 1"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_add [simp]: "cnj (x + y) = cnj x + cnj y"
   by (simp add: complex_eq_iff)
 
 lemma cnj_sum [simp]: "cnj (sum f s) = (\<Sum>x\<in>s. cnj (f x))"
   by (induct s rule: infinite_finite_induct) auto
 
 lemma complex_cnj_diff [simp]: "cnj (x - y) = cnj x - cnj y"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_minus [simp]: "cnj (- x) = - cnj x"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_one [simp]: "cnj 1 = 1"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_mult [simp]: "cnj (x * y) = cnj x * cnj y"
   by (simp add: complex_eq_iff)
 
 lemma cnj_prod [simp]: "cnj (prod f s) = (\<Prod>x\<in>s. cnj (f x))"
   by (induct s rule: infinite_finite_induct) auto
 
 lemma complex_cnj_inverse [simp]: "cnj (inverse x) = inverse (cnj x)"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_divide [simp]: "cnj (x / y) = cnj x / cnj y"
   by (simp add: divide_complex_def)
 
 lemma complex_cnj_power [simp]: "cnj (x ^ n) = cnj x ^ n"
   by (induct n) simp_all
 
 lemma complex_cnj_of_nat [simp]: "cnj (of_nat n) = of_nat n"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_of_int [simp]: "cnj (of_int z) = of_int z"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_numeral [simp]: "cnj (numeral w) = numeral w"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_neg_numeral [simp]: "cnj (- numeral w) = - numeral w"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_scaleR [simp]: "cnj (scaleR r x) = scaleR r (cnj x)"
   by (simp add: complex_eq_iff)
 
 lemma complex_mod_cnj [simp]: "cmod (cnj z) = cmod z"
   by (simp add: norm_complex_def)
 
 lemma complex_cnj_complex_of_real [simp]: "cnj (of_real x) = of_real x"
   by (simp add: complex_eq_iff)
 
 lemma complex_cnj_i [simp]: "cnj \<i> = - \<i>"
   by (simp add: complex_eq_iff)
 
 lemma complex_add_cnj: "z + cnj z = complex_of_real (2 * Re z)"
   by (simp add: complex_eq_iff)
 
 lemma complex_diff_cnj: "z - cnj z = complex_of_real (2 * Im z) * \<i>"
   by (simp add: complex_eq_iff)
 
 lemma Ints_cnj [intro]: "x \<in> \<int> \<Longrightarrow> cnj x \<in> \<int>"
   by (auto elim!: Ints_cases)
 
 lemma cnj_in_Ints_iff [simp]: "cnj x \<in> \<int> \<longleftrightarrow> x \<in> \<int>"
   using Ints_cnj[of x] Ints_cnj[of "cnj x"] by auto
 
 lemma complex_mult_cnj: "z * cnj z = complex_of_real ((Re z)\<^sup>2 + (Im z)\<^sup>2)"
   by (simp add: complex_eq_iff power2_eq_square)
 
 lemma cnj_add_mult_eq_Re: "z * cnj w + cnj z * w = 2 * Re (z * cnj w)"
   by (rule complex_eqI) auto
 
 lemma complex_mod_mult_cnj: "cmod (z * cnj z) = (cmod z)\<^sup>2"
   by (simp add: norm_mult power2_eq_square)
 
 lemma complex_mod_sqrt_Re_mult_cnj: "cmod z = sqrt (Re (z * cnj z))"
   by (simp add: norm_complex_def power2_eq_square)
 
 lemma complex_In_mult_cnj_zero [simp]: "Im (z * cnj z) = 0"
   by simp
 
 lemma complex_cnj_fact [simp]: "cnj (fact n) = fact n"
   by (subst of_nat_fact [symmetric], subst complex_cnj_of_nat) simp
 
 lemma complex_cnj_pochhammer [simp]: "cnj (pochhammer z n) = pochhammer (cnj z) n"
   by (induct n arbitrary: z) (simp_all add: pochhammer_rec)
 
 lemma bounded_linear_cnj: "bounded_linear cnj"
   using complex_cnj_add complex_cnj_scaleR by (rule bounded_linear_intro [where K=1]) simp
 
 lemma linear_cnj: "linear cnj"
   using bounded_linear.linear[OF bounded_linear_cnj] .
 
 lemmas tendsto_cnj [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_cnj]
   and isCont_cnj [simp] = bounded_linear.isCont [OF bounded_linear_cnj]
   and continuous_cnj [simp, continuous_intros] = bounded_linear.continuous [OF bounded_linear_cnj]
   and continuous_on_cnj [simp, continuous_intros] = bounded_linear.continuous_on [OF bounded_linear_cnj]
   and has_derivative_cnj [simp, derivative_intros] = bounded_linear.has_derivative [OF bounded_linear_cnj]
 
 lemma lim_cnj: "((\<lambda>x. cnj(f x)) \<longlongrightarrow> cnj l) F \<longleftrightarrow> (f \<longlongrightarrow> l) F"
   by (simp add: tendsto_iff dist_complex_def complex_cnj_diff [symmetric] del: complex_cnj_diff)
 
 lemma sums_cnj: "((\<lambda>x. cnj(f x)) sums cnj l) \<longleftrightarrow> (f sums l)"
   by (simp add: sums_def lim_cnj cnj_sum [symmetric] del: cnj_sum)
 
 lemma differentiable_cnj_iff:
   "(\<lambda>z. cnj (f z)) differentiable at x within A \<longleftrightarrow> f differentiable at x within A"
 proof
   assume "(\<lambda>z. cnj (f z)) differentiable at x within A"
   then obtain D where "((\<lambda>z. cnj (f z)) has_derivative D) (at x within A)"
     by (auto simp: differentiable_def)
   from has_derivative_cnj[OF this] show "f differentiable at x within A"
     by (auto simp: differentiable_def)
 next
   assume "f differentiable at x within A"
   then obtain D where "(f has_derivative D) (at x within A)"
     by (auto simp: differentiable_def)
   from has_derivative_cnj[OF this] show "(\<lambda>z. cnj (f z)) differentiable at x within A"
     by (auto simp: differentiable_def)
 qed
 
 lemma has_vector_derivative_cnj [derivative_intros]:
   assumes "(f has_vector_derivative f') (at z within A)"
   shows   "((\<lambda>z. cnj (f z)) has_vector_derivative cnj f') (at z within A)"
   using assms by (auto simp: has_vector_derivative_complex_iff intro: derivative_intros)
 
 
 subsection \<open>Basic Lemmas\<close>
 
+lemma complex_of_real_code[code_unfold]: "of_real = (\<lambda>x. Complex x 0)" 
+  by (intro ext, auto simp: complex_eq_iff)
+
 lemma complex_eq_0: "z=0 \<longleftrightarrow> (Re z)\<^sup>2 + (Im z)\<^sup>2 = 0"
   by (metis zero_complex.sel complex_eqI sum_power2_eq_zero_iff)
 
 lemma complex_neq_0: "z\<noteq>0 \<longleftrightarrow> (Re z)\<^sup>2 + (Im z)\<^sup>2 > 0"
   by (metis complex_eq_0 less_numeral_extra(3) sum_power2_gt_zero_iff)
 
 lemma complex_norm_square: "of_real ((norm z)\<^sup>2) = z * cnj z"
   by (cases z)
     (auto simp: complex_eq_iff norm_complex_def power2_eq_square[symmetric] of_real_power[symmetric]
       simp del: of_real_power)
 
 lemma complex_div_cnj: "a / b = (a * cnj b) / (norm b)\<^sup>2"
   using complex_norm_square by auto
 
 lemma Re_complex_div_eq_0: "Re (a / b) = 0 \<longleftrightarrow> Re (a * cnj b) = 0"
   by (auto simp add: Re_divide)
 
 lemma Im_complex_div_eq_0: "Im (a / b) = 0 \<longleftrightarrow> Im (a * cnj b) = 0"
   by (auto simp add: Im_divide)
 
 lemma complex_div_gt_0: "(Re (a / b) > 0 \<longleftrightarrow> Re (a * cnj b) > 0) \<and> (Im (a / b) > 0 \<longleftrightarrow> Im (a * cnj b) > 0)"
 proof (cases "b = 0")
   case True
   then show ?thesis by auto
 next
   case False
   then have "0 < (Re b)\<^sup>2 + (Im b)\<^sup>2"
     by (simp add: complex_eq_iff sum_power2_gt_zero_iff)
   then show ?thesis
     by (simp add: Re_divide Im_divide zero_less_divide_iff)
 qed
 
 lemma Re_complex_div_gt_0: "Re (a / b) > 0 \<longleftrightarrow> Re (a * cnj b) > 0"
   and Im_complex_div_gt_0: "Im (a / b) > 0 \<longleftrightarrow> Im (a * cnj b) > 0"
   using complex_div_gt_0 by auto
 
 lemma Re_complex_div_ge_0: "Re (a / b) \<ge> 0 \<longleftrightarrow> Re (a * cnj b) \<ge> 0"
   by (metis le_less Re_complex_div_eq_0 Re_complex_div_gt_0)
 
 lemma Im_complex_div_ge_0: "Im (a / b) \<ge> 0 \<longleftrightarrow> Im (a * cnj b) \<ge> 0"
   by (metis Im_complex_div_eq_0 Im_complex_div_gt_0 le_less)
 
 lemma Re_complex_div_lt_0: "Re (a / b) < 0 \<longleftrightarrow> Re (a * cnj b) < 0"
   by (metis less_asym neq_iff Re_complex_div_eq_0 Re_complex_div_gt_0)
 
 lemma Im_complex_div_lt_0: "Im (a / b) < 0 \<longleftrightarrow> Im (a * cnj b) < 0"
   by (metis Im_complex_div_eq_0 Im_complex_div_gt_0 less_asym neq_iff)
 
 lemma Re_complex_div_le_0: "Re (a / b) \<le> 0 \<longleftrightarrow> Re (a * cnj b) \<le> 0"
   by (metis not_le Re_complex_div_gt_0)
 
 lemma Im_complex_div_le_0: "Im (a / b) \<le> 0 \<longleftrightarrow> Im (a * cnj b) \<le> 0"
   by (metis Im_complex_div_gt_0 not_le)
 
 lemma Re_divide_of_real [simp]: "Re (z / of_real r) = Re z / r"
   by (simp add: Re_divide power2_eq_square)
 
 lemma Im_divide_of_real [simp]: "Im (z / of_real r) = Im z / r"
   by (simp add: Im_divide power2_eq_square)
 
 lemma Re_divide_Reals [simp]: "r \<in> \<real> \<Longrightarrow> Re (z / r) = Re z / Re r"
   by (metis Re_divide_of_real of_real_Re)
 
 lemma Im_divide_Reals [simp]: "r \<in> \<real> \<Longrightarrow> Im (z / r) = Im z / Re r"
   by (metis Im_divide_of_real of_real_Re)
 
 lemma Re_sum[simp]: "Re (sum f s) = (\<Sum>x\<in>s. Re (f x))"
   by (induct s rule: infinite_finite_induct) auto
 
 lemma Im_sum[simp]: "Im (sum f s) = (\<Sum>x\<in>s. Im(f x))"
   by (induct s rule: infinite_finite_induct) auto
 
 lemma sums_complex_iff: "f sums x \<longleftrightarrow> ((\<lambda>x. Re (f x)) sums Re x) \<and> ((\<lambda>x. Im (f x)) sums Im x)"
   unfolding sums_def tendsto_complex_iff Im_sum Re_sum ..
 
 lemma summable_complex_iff: "summable f \<longleftrightarrow> summable (\<lambda>x. Re (f x)) \<and>  summable (\<lambda>x. Im (f x))"
   unfolding summable_def sums_complex_iff[abs_def] by (metis complex.sel)
 
 lemma summable_complex_of_real [simp]: "summable (\<lambda>n. complex_of_real (f n)) \<longleftrightarrow> summable f"
   unfolding summable_complex_iff by simp
 
 lemma summable_Re: "summable f \<Longrightarrow> summable (\<lambda>x. Re (f x))"
   unfolding summable_complex_iff by blast
 
 lemma summable_Im: "summable f \<Longrightarrow> summable (\<lambda>x. Im (f x))"
   unfolding summable_complex_iff by blast
 
 lemma complex_is_Nat_iff: "z \<in> \<nat> \<longleftrightarrow> Im z = 0 \<and> (\<exists>i. Re z = of_nat i)"
   by (auto simp: Nats_def complex_eq_iff)
 
 lemma complex_is_Int_iff: "z \<in> \<int> \<longleftrightarrow> Im z = 0 \<and> (\<exists>i. Re z = of_int i)"
   by (auto simp: Ints_def complex_eq_iff)
 
 lemma complex_is_Real_iff: "z \<in> \<real> \<longleftrightarrow> Im z = 0"
   by (auto simp: Reals_def complex_eq_iff)
 
 lemma Reals_cnj_iff: "z \<in> \<real> \<longleftrightarrow> cnj z = z"
   by (auto simp: complex_is_Real_iff complex_eq_iff)
 
 lemma in_Reals_norm: "z \<in> \<real> \<Longrightarrow> norm z = \<bar>Re z\<bar>"
   by (simp add: complex_is_Real_iff norm_complex_def)
 
 lemma Re_Reals_divide: "r \<in> \<real> \<Longrightarrow> Re (r / z) = Re r * Re z / (norm z)\<^sup>2"
   by (simp add: Re_divide complex_is_Real_iff cmod_power2)
 
 lemma Im_Reals_divide: "r \<in> \<real> \<Longrightarrow> Im (r / z) = -Re r * Im z / (norm z)\<^sup>2"
   by (simp add: Im_divide complex_is_Real_iff cmod_power2)
 
 lemma series_comparison_complex:
   fixes f:: "nat \<Rightarrow> 'a::banach"
   assumes sg: "summable g"
     and "\<And>n. g n \<in> \<real>" "\<And>n. Re (g n) \<ge> 0"
     and fg: "\<And>n. n \<ge> N \<Longrightarrow> norm(f n) \<le> norm(g n)"
   shows "summable f"
 proof -
   have g: "\<And>n. cmod (g n) = Re (g n)"
     using assms by (metis abs_of_nonneg in_Reals_norm)
   show ?thesis
     apply (rule summable_comparison_test' [where g = "\<lambda>n. norm (g n)" and N=N])
     using sg
      apply (auto simp: summable_def)
      apply (rule_tac x = "Re s" in exI)
      apply (auto simp: g sums_Re)
     apply (metis fg g)
     done
 qed
 
 
 subsection \<open>Polar Form for Complex Numbers\<close>
 
 lemma complex_unimodular_polar:
   assumes "norm z = 1"
   obtains t where "0 \<le> t" "t < 2 * pi" "z = Complex (cos t) (sin t)"
   by (metis cmod_power2 one_power2 complex_surj sincos_total_2pi [of "Re z" "Im z"] assms)
 
 
 subsubsection \<open>$\cos \theta + i \sin \theta$\<close>
 
 primcorec cis :: "real \<Rightarrow> complex"
   where
     "Re (cis a) = cos a"
   | "Im (cis a) = sin a"
 
 lemma cis_zero [simp]: "cis 0 = 1"
   by (simp add: complex_eq_iff)
 
 lemma norm_cis [simp]: "norm (cis a) = 1"
   by (simp add: norm_complex_def)
 
 lemma sgn_cis [simp]: "sgn (cis a) = cis a"
   by (simp add: sgn_div_norm)
 
 lemma cis_2pi [simp]: "cis (2 * pi) = 1"
   by (simp add: cis.ctr complex_eq_iff)
 
 lemma cis_neq_zero [simp]: "cis a \<noteq> 0"
   by (metis norm_cis norm_zero zero_neq_one)
 
 lemma cis_cnj: "cnj (cis t) = cis (-t)"
   by (simp add: complex_eq_iff)
 
 lemma cis_mult: "cis a * cis b = cis (a + b)"
   by (simp add: complex_eq_iff cos_add sin_add)
 
 lemma DeMoivre: "(cis a) ^ n = cis (real n * a)"
   by (induct n) (simp_all add: algebra_simps cis_mult)
 
 lemma cis_inverse [simp]: "inverse (cis a) = cis (- a)"
   by (simp add: complex_eq_iff)
 
 lemma cis_divide: "cis a / cis b = cis (a - b)"
   by (simp add: divide_complex_def cis_mult)
 
 lemma cos_n_Re_cis_pow_n: "cos (real n * a) = Re (cis a ^ n)"
   by (auto simp add: DeMoivre)
 
 lemma sin_n_Im_cis_pow_n: "sin (real n * a) = Im (cis a ^ n)"
   by (auto simp add: DeMoivre)
 
 lemma cis_pi [simp]: "cis pi = -1"
   by (simp add: complex_eq_iff)
 
 lemma cis_pi_half[simp]: "cis (pi / 2) = \<i>"
   by (simp add: cis.ctr complex_eq_iff)
 
 lemma cis_minus_pi_half[simp]: "cis (-(pi / 2)) = -\<i>"
   by (simp add: cis.ctr complex_eq_iff)
 
 lemma cis_multiple_2pi[simp]: "n \<in> \<int> \<Longrightarrow> cis (2 * pi * n) = 1"
   by (auto elim!: Ints_cases simp: cis.ctr one_complex.ctr)
 
 
 subsubsection \<open>$r(\cos \theta + i \sin \theta)$\<close>
 
 definition rcis :: "real \<Rightarrow> real \<Rightarrow> complex"
   where "rcis r a = complex_of_real r * cis a"
 
 lemma Re_rcis [simp]: "Re(rcis r a) = r * cos a"
   by (simp add: rcis_def)
 
 lemma Im_rcis [simp]: "Im(rcis r a) = r * sin a"
   by (simp add: rcis_def)
 
 lemma rcis_Ex: "\<exists>r a. z = rcis r a"
   by (simp add: complex_eq_iff polar_Ex)
 
 lemma complex_mod_rcis [simp]: "cmod (rcis r a) = \<bar>r\<bar>"
   by (simp add: rcis_def norm_mult)
 
 lemma cis_rcis_eq: "cis a = rcis 1 a"
   by (simp add: rcis_def)
 
 lemma rcis_mult: "rcis r1 a * rcis r2 b = rcis (r1 * r2) (a + b)"
   by (simp add: rcis_def cis_mult)
 
 lemma rcis_zero_mod [simp]: "rcis 0 a = 0"
   by (simp add: rcis_def)
 
 lemma rcis_zero_arg [simp]: "rcis r 0 = complex_of_real r"
   by (simp add: rcis_def)
 
 lemma rcis_eq_zero_iff [simp]: "rcis r a = 0 \<longleftrightarrow> r = 0"
   by (simp add: rcis_def)
 
 lemma DeMoivre2: "(rcis r a) ^ n = rcis (r ^ n) (real n * a)"
   by (simp add: rcis_def power_mult_distrib DeMoivre)
 
 lemma rcis_inverse: "inverse(rcis r a) = rcis (1 / r) (- a)"
   by (simp add: divide_inverse rcis_def)
 
 lemma rcis_divide: "rcis r1 a / rcis r2 b = rcis (r1 / r2) (a - b)"
   by (simp add: rcis_def cis_divide [symmetric])
 
 subsubsection \<open>Complex exponential\<close>
 
 lemma exp_Reals_eq:
   assumes "z \<in> \<real>"
   shows   "exp z = of_real (exp (Re z))"
   using assms by (auto elim!: Reals_cases simp: exp_of_real)
 
 lemma cis_conv_exp: "cis b = exp (\<i> * b)"
 proof -
   have "(\<i> * complex_of_real b) ^ n /\<^sub>R fact n =
       of_real (cos_coeff n * b^n) + \<i> * of_real (sin_coeff n * b^n)"
     for n :: nat
   proof -
     have "\<i> ^ n = fact n *\<^sub>R (cos_coeff n + \<i> * sin_coeff n)"
       by (induct n)
         (simp_all add: sin_coeff_Suc cos_coeff_Suc complex_eq_iff Re_divide Im_divide field_simps
           power2_eq_square add_nonneg_eq_0_iff)
     then show ?thesis
       by (simp add: field_simps)
   qed
   then show ?thesis
     using sin_converges [of b] cos_converges [of b]
     by (auto simp add: Complex_eq cis.ctr exp_def simp del: of_real_mult
         intro!: sums_unique sums_add sums_mult sums_of_real)
 qed
 
 lemma exp_eq_polar: "exp z = exp (Re z) * cis (Im z)"
   unfolding cis_conv_exp exp_of_real [symmetric] mult_exp_exp
   by (cases z) (simp add: Complex_eq)
 
 lemma Re_exp: "Re (exp z) = exp (Re z) * cos (Im z)"
   unfolding exp_eq_polar by simp
 
 lemma Im_exp: "Im (exp z) = exp (Re z) * sin (Im z)"
   unfolding exp_eq_polar by simp
 
 lemma norm_cos_sin [simp]: "norm (Complex (cos t) (sin t)) = 1"
   by (simp add: norm_complex_def)
 
 lemma norm_exp_eq_Re [simp]: "norm (exp z) = exp (Re z)"
   by (simp add: cis.code cmod_complex_polar exp_eq_polar Complex_eq)
 
 lemma complex_exp_exists: "\<exists>a r. z = complex_of_real r * exp a"
   apply (insert rcis_Ex [of z])
   apply (auto simp add: exp_eq_polar rcis_def mult.assoc [symmetric])
   apply (rule_tac x = "\<i> * complex_of_real a" in exI)
   apply auto
   done
 
 lemma exp_pi_i [simp]: "exp (of_real pi * \<i>) = -1"
   by (metis cis_conv_exp cis_pi mult.commute)
 
 lemma exp_pi_i' [simp]: "exp (\<i> * of_real pi) = -1"
   using cis_conv_exp cis_pi by auto
 
 lemma exp_two_pi_i [simp]: "exp (2 * of_real pi * \<i>) = 1"
   by (simp add: exp_eq_polar complex_eq_iff)
 
 lemma exp_two_pi_i' [simp]: "exp (\<i> * (of_real pi * 2)) = 1"
   by (metis exp_two_pi_i mult.commute)
 
 lemma continuous_on_cis [continuous_intros]:
   "continuous_on A f \<Longrightarrow> continuous_on A (\<lambda>x. cis (f x))"
   by (auto simp: cis_conv_exp intro!: continuous_intros)
 
 
 subsubsection \<open>Complex argument\<close>
 
 definition Arg :: "complex \<Rightarrow> real"
   where "Arg z = (if z = 0 then 0 else (SOME a. sgn z = cis a \<and> - pi < a \<and> a \<le> pi))"
 
 lemma Arg_zero: "Arg 0 = 0"
   by (simp add: Arg_def)
 
 lemma cis_Arg_unique:
   assumes "sgn z = cis x" and "-pi < x" and "x \<le> pi"
   shows "Arg z = x"
 proof -
   from assms have "z \<noteq> 0" by auto
   have "(SOME a. sgn z = cis a \<and> -pi < a \<and> a \<le> pi) = x"
   proof
     fix a
     define d where "d = a - x"
     assume a: "sgn z = cis a \<and> - pi < a \<and> a \<le> pi"
     from a assms have "- (2*pi) < d \<and> d < 2*pi"
       unfolding d_def by simp
     moreover
     from a assms have "cos a = cos x" and "sin a = sin x"
       by (simp_all add: complex_eq_iff)
     then have cos: "cos d = 1"
       by (simp add: d_def cos_diff)
     moreover from cos have "sin d = 0"
       by (rule cos_one_sin_zero)
     ultimately have "d = 0"
       by (auto simp: sin_zero_iff elim!: evenE dest!: less_2_cases)
     then show "a = x"
       by (simp add: d_def)
   qed (simp add: assms del: Re_sgn Im_sgn)
   with \<open>z \<noteq> 0\<close> show "Arg z = x"
     by (simp add: Arg_def)
 qed
 
 lemma Arg_correct:
   assumes "z \<noteq> 0"
   shows "sgn z = cis (Arg z) \<and> -pi < Arg z \<and> Arg z \<le> pi"
 proof (simp add: Arg_def assms, rule someI_ex)
   obtain r a where z: "z = rcis r a"
     using rcis_Ex by fast
   with assms have "r \<noteq> 0" by auto
   define b where "b = (if 0 < r then a else a + pi)"
   have b: "sgn z = cis b"
     using \<open>r \<noteq> 0\<close> by (simp add: z b_def rcis_def of_real_def sgn_scaleR sgn_if complex_eq_iff)
   have cis_2pi_nat: "cis (2 * pi * real_of_nat n) = 1" for n
     by (induct n) (simp_all add: distrib_left cis_mult [symmetric] complex_eq_iff)
   have cis_2pi_int: "cis (2 * pi * real_of_int x) = 1" for x
     by (cases x rule: int_diff_cases)
       (simp add: right_diff_distrib cis_divide [symmetric] cis_2pi_nat)
   define c where "c = b - 2 * pi * of_int \<lceil>(b - pi) / (2 * pi)\<rceil>"
   have "sgn z = cis c"
     by (simp add: b c_def cis_divide [symmetric] cis_2pi_int)
   moreover have "- pi < c \<and> c \<le> pi"
     using ceiling_correct [of "(b - pi) / (2*pi)"]
     by (simp add: c_def less_divide_eq divide_le_eq algebra_simps del: le_of_int_ceiling)
   ultimately show "\<exists>a. sgn z = cis a \<and> -pi < a \<and> a \<le> pi"
     by fast
 qed
 
 lemma Arg_bounded: "- pi < Arg z \<and> Arg z \<le> pi"
   by (cases "z = 0") (simp_all add: Arg_zero Arg_correct)
 
 lemma cis_Arg: "z \<noteq> 0 \<Longrightarrow> cis (Arg z) = sgn z"
   by (simp add: Arg_correct)
 
 lemma rcis_cmod_Arg: "rcis (cmod z) (Arg z) = z"
   by (cases "z = 0") (simp_all add: rcis_def cis_Arg sgn_div_norm of_real_def)
 
 lemma rcis_cnj:
   shows "cnj a = rcis (cmod a) (- Arg a)"
   by (metis cis_cnj complex_cnj_complex_of_real complex_cnj_mult rcis_cmod_Arg rcis_def)
 
 lemma cos_Arg_i_mult_zero [simp]: "y \<noteq> 0 \<Longrightarrow> Re y = 0 \<Longrightarrow> cos (Arg y) = 0"
   using cis_Arg [of y] by (simp add: complex_eq_iff)
 
 lemma Arg_ii [simp]: "Arg \<i> = pi/2"
   by (rule cis_Arg_unique; simp add: sgn_eq)
 
 lemma Arg_minus_ii [simp]: "Arg (-\<i>) = -pi/2"
 proof (rule cis_Arg_unique)
   show "sgn (- \<i>) = cis (- pi / 2)"
     by (simp add: sgn_eq)
   show "- pi / 2 \<le> pi"
     using pi_not_less_zero by linarith
 qed auto
 
 subsection \<open>Complex n-th roots\<close>
 
 lemma bij_betw_roots_unity:
   assumes "n > 0"
   shows   "bij_betw (\<lambda>k. cis (2 * pi * real k / real n)) {..<n} {z. z ^ n = 1}"
     (is "bij_betw ?f _ _")
   unfolding bij_betw_def
 proof (intro conjI)
   show inj: "inj_on ?f {..<n}" unfolding inj_on_def
   proof (safe, goal_cases)
     case (1 k l)
     hence kl: "k < n" "l < n" by simp_all
     from 1 have "1 = ?f k / ?f l" by simp
     also have "\<dots> = cis (2*pi*(real k - real l)/n)"
       using assms by (simp add: field_simps cis_divide)
     finally have "cos (2*pi*(real k - real l) / n) = 1"
       by (simp add: complex_eq_iff)
     then obtain m :: int where "2 * pi * (real k - real l) / real n = real_of_int m * 2 * pi"
       by (subst (asm) cos_one_2pi_int) blast
     hence "real_of_int (int k - int l) = real_of_int (m * int n)"
       unfolding of_int_diff of_int_mult using assms
       by (simp add: nonzero_divide_eq_eq)
     also note of_int_eq_iff
     finally have *: "abs m * n = abs (int k - int l)" by (simp add: abs_mult)
     also have "\<dots> < int n" using kl by linarith
     finally have "m = 0" using assms by simp
     with * show "k = l" by simp
   qed
 
   have subset: "?f ` {..<n} \<subseteq> {z. z ^ n = 1}"
   proof safe
     fix k :: nat
     have "cis (2 * pi * real k / real n) ^ n = cis (2 * pi) ^ k"
       using assms by (simp add: DeMoivre mult_ac)
     also have "cis (2 * pi) = 1" by (simp add: complex_eq_iff)
     finally show "?f k ^ n = 1" by simp
   qed
 
   have "n = card {..<n}" by simp
   also from assms and subset have "\<dots> \<le> card {z::complex. z ^ n = 1}"
     by (intro card_inj_on_le[OF inj]) (auto simp: finite_roots_unity)
   finally have card: "card {z::complex. z ^ n = 1} = n"
     using assms by (intro antisym card_roots_unity) auto
 
   have "card (?f ` {..<n}) = card {z::complex. z ^ n = 1}"
     using card inj by (subst card_image) auto
   with subset and assms show "?f ` {..<n} = {z::complex. z ^ n = 1}"
     by (intro card_subset_eq finite_roots_unity) auto
 qed
 
 lemma card_roots_unity_eq:
   assumes "n > 0"
   shows   "card {z::complex. z ^ n = 1} = n"
   using bij_betw_same_card [OF bij_betw_roots_unity [OF assms]] by simp
 
 lemma bij_betw_nth_root_unity:
   fixes c :: complex and n :: nat
   assumes c: "c \<noteq> 0" and n: "n > 0"
   defines "c' \<equiv> root n (norm c) * cis (Arg c / n)"
   shows "bij_betw (\<lambda>z. c' * z) {z. z ^ n = 1} {z. z ^ n = c}"
 proof -
   have "c' ^ n = of_real (root n (norm c) ^ n) * cis (Arg c)"
     unfolding of_real_power using n by (simp add: c'_def power_mult_distrib DeMoivre)
   also from n have "root n (norm c) ^ n = norm c" by simp
   also from c have "of_real \<dots> * cis (Arg c) = c" by (simp add: cis_Arg Complex.sgn_eq)
   finally have [simp]: "c' ^ n = c" .
 
   show ?thesis unfolding bij_betw_def inj_on_def
   proof safe
     fix z :: complex assume "z ^ n = 1"
     hence "(c' * z) ^ n = c' ^ n" by (simp add: power_mult_distrib)
     also have "c' ^ n = of_real (root n (norm c) ^ n) * cis (Arg c)"
       unfolding of_real_power using n by (simp add: c'_def power_mult_distrib DeMoivre)
     also from n have "root n (norm c) ^ n = norm c" by simp
     also from c have "\<dots> * cis (Arg c) = c" by (simp add: cis_Arg Complex.sgn_eq)
     finally show "(c' * z) ^ n = c" .
   next
     fix z assume z: "c = z ^ n"
     define z' where "z' = z / c'"
     from c and n have "c' \<noteq> 0" by (auto simp: c'_def)
     with n c have "z = c' * z'" and "z' ^ n = 1"
       by (auto simp: z'_def power_divide z)
     thus "z \<in> (\<lambda>z. c' * z) ` {z. z ^ n = 1}" by blast
   qed (insert c n, auto simp: c'_def)
 qed
 
 lemma finite_nth_roots [intro]:
   assumes "n > 0"
   shows   "finite {z::complex. z ^ n = c}"
 proof (cases "c = 0")
   case True
   with assms have "{z::complex. z ^ n = c} = {0}" by auto
   thus ?thesis by simp
 next
   case False
   from assms have "finite {z::complex. z ^ n = 1}" by (intro finite_roots_unity) simp_all
   also have "?this \<longleftrightarrow> ?thesis"
     by (rule bij_betw_finite, rule bij_betw_nth_root_unity) fact+
   finally show ?thesis .
 qed
 
 lemma card_nth_roots:
   assumes "c \<noteq> 0" "n > 0"
   shows   "card {z::complex. z ^ n = c} = n"
 proof -
   have "card {z. z ^ n = c} = card {z::complex. z ^ n = 1}"
     by (rule sym, rule bij_betw_same_card, rule bij_betw_nth_root_unity) fact+
   also have "\<dots> = n" by (rule card_roots_unity_eq) fact+
   finally show ?thesis .
 qed
 
 lemma sum_roots_unity:
   assumes "n > 1"
   shows   "\<Sum>{z::complex. z ^ n = 1} = 0"
 proof -
   define \<omega> where "\<omega> = cis (2 * pi / real n)"
   have [simp]: "\<omega> \<noteq> 1"
   proof
     assume "\<omega> = 1"
     with assms obtain k :: int where "2 * pi / real n = 2 * pi * of_int k"
       by (auto simp: \<omega>_def complex_eq_iff cos_one_2pi_int)
     with assms have "real n * of_int k = 1" by (simp add: field_simps)
     also have "real n * of_int k = of_int (int n * k)" by simp
     also have "1 = (of_int 1 :: real)" by simp
     also note of_int_eq_iff
     finally show False using assms by (auto simp: zmult_eq_1_iff)
   qed
 
   have "(\<Sum>z | z ^ n = 1. z :: complex) = (\<Sum>k<n. cis (2 * pi * real k / real n))"
     using assms by (intro sum.reindex_bij_betw [symmetric] bij_betw_roots_unity) auto
   also have "\<dots> = (\<Sum>k<n. \<omega> ^ k)"
     by (intro sum.cong refl) (auto simp: \<omega>_def DeMoivre mult_ac)
   also have "\<dots> = (\<omega> ^ n - 1) / (\<omega> - 1)"
     by (subst geometric_sum) auto
   also have "\<omega> ^ n - 1 = cis (2 * pi) - 1" using assms by (auto simp: \<omega>_def DeMoivre)
   also have "\<dots> = 0" by (simp add: complex_eq_iff)
   finally show ?thesis by simp
 qed
 
 lemma sum_nth_roots:
   assumes "n > 1"
   shows   "\<Sum>{z::complex. z ^ n = c} = 0"
 proof (cases "c = 0")
   case True
   with assms have "{z::complex. z ^ n = c} = {0}" by auto
   also have "\<Sum>\<dots> = 0" by simp
   finally show ?thesis .
 next
   case False
   define c' where "c' = root n (norm c) * cis (Arg c / n)"
   from False and assms have "(\<Sum>{z. z ^ n = c}) = (\<Sum>z | z ^ n = 1. c' * z)"
     by (subst sum.reindex_bij_betw [OF bij_betw_nth_root_unity, symmetric])
        (auto simp: sum_distrib_left finite_roots_unity c'_def)
   also from assms have "\<dots> = 0"
     by (simp add: sum_distrib_left [symmetric] sum_roots_unity)
   finally show ?thesis .
 qed
 
 subsection \<open>Square root of complex numbers\<close>
 
 primcorec csqrt :: "complex \<Rightarrow> complex"
   where
     "Re (csqrt z) = sqrt ((cmod z + Re z) / 2)"
   | "Im (csqrt z) = (if Im z = 0 then 1 else sgn (Im z)) * sqrt ((cmod z - Re z) / 2)"
 
 lemma csqrt_of_real_nonneg [simp]: "Im x = 0 \<Longrightarrow> Re x \<ge> 0 \<Longrightarrow> csqrt x = sqrt (Re x)"
   by (simp add: complex_eq_iff norm_complex_def)
 
 lemma csqrt_of_real_nonpos [simp]: "Im x = 0 \<Longrightarrow> Re x \<le> 0 \<Longrightarrow> csqrt x = \<i> * sqrt \<bar>Re x\<bar>"
   by (simp add: complex_eq_iff norm_complex_def)
 
 lemma of_real_sqrt: "x \<ge> 0 \<Longrightarrow> of_real (sqrt x) = csqrt (of_real x)"
   by (simp add: complex_eq_iff norm_complex_def)
 
 lemma csqrt_0 [simp]: "csqrt 0 = 0"
   by simp
 
 lemma csqrt_1 [simp]: "csqrt 1 = 1"
   by simp
 
 lemma csqrt_ii [simp]: "csqrt \<i> = (1 + \<i>) / sqrt 2"
   by (simp add: complex_eq_iff Re_divide Im_divide real_sqrt_divide real_div_sqrt)
 
 lemma power2_csqrt[simp,algebra]: "(csqrt z)\<^sup>2 = z"
 proof (cases "Im z = 0")
   case True
   then show ?thesis
     using real_sqrt_pow2[of "Re z"] real_sqrt_pow2[of "- Re z"]
     by (cases "0::real" "Re z" rule: linorder_cases)
       (simp_all add: complex_eq_iff Re_power2 Im_power2 power2_eq_square cmod_eq_Re)
 next
   case False
   moreover have "cmod z * cmod z - Re z * Re z = Im z * Im z"
     by (simp add: norm_complex_def power2_eq_square)
   moreover have "\<bar>Re z\<bar> \<le> cmod z"
     by (simp add: norm_complex_def)
   ultimately show ?thesis
     by (simp add: Re_power2 Im_power2 complex_eq_iff real_sgn_eq
         field_simps real_sqrt_mult[symmetric] real_sqrt_divide)
 qed
 
 lemma csqrt_eq_0 [simp]: "csqrt z = 0 \<longleftrightarrow> z = 0"
   by auto (metis power2_csqrt power_eq_0_iff)
 
 lemma csqrt_eq_1 [simp]: "csqrt z = 1 \<longleftrightarrow> z = 1"
   by auto (metis power2_csqrt power2_eq_1_iff)
 
 lemma csqrt_principal: "0 < Re (csqrt z) \<or> Re (csqrt z) = 0 \<and> 0 \<le> Im (csqrt z)"
   by (auto simp add: not_less cmod_plus_Re_le_0_iff Im_eq_0)
 
 lemma Re_csqrt: "0 \<le> Re (csqrt z)"
   by (metis csqrt_principal le_less)
 
 lemma csqrt_square:
   assumes "0 < Re b \<or> (Re b = 0 \<and> 0 \<le> Im b)"
   shows "csqrt (b^2) = b"
 proof -
   have "csqrt (b^2) = b \<or> csqrt (b^2) = - b"
     by (simp add: power2_eq_iff[symmetric])
   moreover have "csqrt (b^2) \<noteq> -b \<or> b = 0"
     using csqrt_principal[of "b ^ 2"] assms
     by (intro disjCI notI) (auto simp: complex_eq_iff)
   ultimately show ?thesis
     by auto
 qed
 
 lemma csqrt_unique: "w\<^sup>2 = z \<Longrightarrow> 0 < Re w \<or> Re w = 0 \<and> 0 \<le> Im w \<Longrightarrow> csqrt z = w"
   by (auto simp: csqrt_square)
 
 lemma csqrt_minus [simp]:
   assumes "Im x < 0 \<or> (Im x = 0 \<and> 0 \<le> Re x)"
   shows "csqrt (- x) = \<i> * csqrt x"
 proof -
   have "csqrt ((\<i> * csqrt x)^2) = \<i> * csqrt x"
   proof (rule csqrt_square)
     have "Im (csqrt x) \<le> 0"
       using assms by (auto simp add: cmod_eq_Re mult_le_0_iff field_simps complex_Re_le_cmod)
     then show "0 < Re (\<i> * csqrt x) \<or> Re (\<i> * csqrt x) = 0 \<and> 0 \<le> Im (\<i> * csqrt x)"
       by (auto simp add: Re_csqrt simp del: csqrt.simps)
   qed
   also have "(\<i> * csqrt x)^2 = - x"
     by (simp add: power_mult_distrib)
   finally show ?thesis .
 qed
 
 
 text \<open>Legacy theorem names\<close>
 
 lemmas cmod_def = norm_complex_def
 
 lemma legacy_Complex_simps:
   shows Complex_eq_0: "Complex a b = 0 \<longleftrightarrow> a = 0 \<and> b = 0"
     and complex_add: "Complex a b + Complex c d = Complex (a + c) (b + d)"
     and complex_minus: "- (Complex a b) = Complex (- a) (- b)"
     and complex_diff: "Complex a b - Complex c d = Complex (a - c) (b - d)"
     and Complex_eq_1: "Complex a b = 1 \<longleftrightarrow> a = 1 \<and> b = 0"
     and Complex_eq_neg_1: "Complex a b = - 1 \<longleftrightarrow> a = - 1 \<and> b = 0"
     and complex_mult: "Complex a b * Complex c d = Complex (a * c - b * d) (a * d + b * c)"
     and complex_inverse: "inverse (Complex a b) = Complex (a / (a\<^sup>2 + b\<^sup>2)) (- b / (a\<^sup>2 + b\<^sup>2))"
     and Complex_eq_numeral: "Complex a b = numeral w \<longleftrightarrow> a = numeral w \<and> b = 0"
     and Complex_eq_neg_numeral: "Complex a b = - numeral w \<longleftrightarrow> a = - numeral w \<and> b = 0"
     and complex_scaleR: "scaleR r (Complex a b) = Complex (r * a) (r * b)"
     and Complex_eq_i: "Complex x y = \<i> \<longleftrightarrow> x = 0 \<and> y = 1"
     and i_mult_Complex: "\<i> * Complex a b = Complex (- b) a"
     and Complex_mult_i: "Complex a b * \<i> = Complex (- b) a"
     and i_complex_of_real: "\<i> * complex_of_real r = Complex 0 r"
     and complex_of_real_i: "complex_of_real r * \<i> = Complex 0 r"
     and Complex_add_complex_of_real: "Complex x y + complex_of_real r = Complex (x+r) y"
     and complex_of_real_add_Complex: "complex_of_real r + Complex x y = Complex (r+x) y"
     and Complex_mult_complex_of_real: "Complex x y * complex_of_real r = Complex (x*r) (y*r)"
     and complex_of_real_mult_Complex: "complex_of_real r * Complex x y = Complex (r*x) (r*y)"
     and complex_eq_cancel_iff2: "(Complex x y = complex_of_real xa) = (x = xa \<and> y = 0)"
     and complex_cnj: "cnj (Complex a b) = Complex a (- b)"
     and Complex_sum': "sum (\<lambda>x. Complex (f x) 0) s = Complex (sum f s) 0"
     and Complex_sum: "Complex (sum f s) 0 = sum (\<lambda>x. Complex (f x) 0) s"
     and complex_of_real_def: "complex_of_real r = Complex r 0"
     and complex_norm: "cmod (Complex x y) = sqrt (x\<^sup>2 + y\<^sup>2)"
   by (simp_all add: norm_complex_def field_simps complex_eq_iff Re_divide Im_divide)
 
 lemma Complex_in_Reals: "Complex x 0 \<in> \<real>"
   by (metis Reals_of_real complex_of_real_def)
 
 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,2526 +1,2538 @@
 (*  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_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: "finite A \<Longrightarrow> x \<in> A \<Longrightarrow> card (A - {x}) = card A - 1"
-  by (simp add: card_Suc_Diff1 [symmetric])
+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:
-  "finite A \<Longrightarrow> card (A - {x}) = (if x \<in> A then card A - 1 else card A)"
+  "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 "finite A" and "a \<in> A" and "a \<notin> B"
+  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: "finite A \<Longrightarrow> card A \<le> card (insert x A)"
-  by (simp add: card_insert_if)
+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: "finite A \<Longrightarrow> card (A - {x}) \<le> card A"
-  by (cases "x \<in> A") (simp_all add: card_Diff1_less less_imp_le)
+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  (* somewhat slow *)
+  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/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,409 +1,415 @@
 (*  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_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>
   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)
 
 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