# HG changeset patch
# User haftmann
# Date 1268314693 -3600
# Node ID 69419a09a7ff6d619ea23dae690a4ce3719bd068
# Parent  f7bbee848403d0ef278d450b723203af651b2364
moved cardinality to Finite_Set as far as appropriate; added locales for fold_image

diff -r f7bbee848403 -r 69419a09a7ff src/HOL/Big_Operators.thy
--- a/src/HOL/Big_Operators.thy	Thu Mar 11 14:38:09 2010 +0100
+++ b/src/HOL/Big_Operators.thy	Thu Mar 11 14:38:13 2010 +0100
@@ -6,7 +6,7 @@
 header {* Big operators and finite (non-empty) sets *}
 
 theory Big_Operators
-imports Finite_Set
+imports Plain
 begin
 
 subsection {* Generalized summation over a set *}
@@ -704,6 +704,80 @@
 by(auto simp: setsum_product setsum_cartesian_product
         intro!:  setsum_reindex_cong[symmetric])
 
+lemma setsum_constant [simp]: "(\<Sum>x \<in> A. y) = of_nat(card A) * y"
+apply (cases "finite A")
+apply (erule finite_induct)
+apply (auto simp add: algebra_simps)
+done
+
+lemma setsum_bounded:
+  assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> (K::'a::{semiring_1, ordered_ab_semigroup_add})"
+  shows "setsum f A \<le> of_nat(card A) * K"
+proof (cases "finite A")
+  case True
+  thus ?thesis using le setsum_mono[where K=A and g = "%x. K"] by simp
+next
+  case False thus ?thesis by (simp add: setsum_def)
+qed
+
+
+subsubsection {* Cardinality as special case of @{const setsum} *}
+
+lemma card_eq_setsum:
+  "card A = setsum (\<lambda>x. 1) A"
+  by (simp only: card_def setsum_def)
+
+lemma card_UN_disjoint:
+  "finite I ==> (ALL i:I. finite (A i)) ==>
+   (ALL i:I. ALL j:I. i \<noteq> j --> A i Int A j = {})
+   ==> card (UNION I A) = (\<Sum>i\<in>I. card(A i))"
+apply (simp add: card_eq_setsum del: setsum_constant)
+apply (subgoal_tac
+         "setsum (%i. card (A i)) I = setsum (%i. (setsum (%x. 1) (A i))) I")
+apply (simp add: setsum_UN_disjoint del: setsum_constant)
+apply (simp cong: setsum_cong)
+done
+
+lemma card_Union_disjoint:
+  "finite C ==> (ALL A:C. finite A) ==>
+   (ALL A:C. ALL B:C. A \<noteq> B --> A Int B = {})
+   ==> card (Union C) = setsum card C"
+apply (frule card_UN_disjoint [of C id])
+apply (unfold Union_def id_def, assumption+)
+done
+
+text{*The image of a finite set can be expressed using @{term fold_image}.*}
+lemma image_eq_fold_image:
+  "finite A ==> f ` A = fold_image (op Un) (%x. {f x}) {} A"
+proof (induct rule: finite_induct)
+  case empty then show ?case by simp
+next
+  interpret ab_semigroup_mult "op Un"
+    proof qed auto
+  case insert 
+  then show ?case by simp
+qed
+
+subsubsection {* Cardinality of products *}
+
+lemma card_SigmaI [simp]:
+  "\<lbrakk> finite A; ALL a:A. finite (B a) \<rbrakk>
+  \<Longrightarrow> card (SIGMA x: A. B x) = (\<Sum>a\<in>A. card (B a))"
+by(simp add: card_eq_setsum setsum_Sigma del:setsum_constant)
+
+(*
+lemma SigmaI_insert: "y \<notin> A ==>
+  (SIGMA x:(insert y A). B x) = (({y} <*> (B y)) \<union> (SIGMA x: A. B x))"
+  by auto
+*)
+
+lemma card_cartesian_product: "card (A <*> B) = card(A) * card(B)"
+  by (cases "finite A \<and> finite B")
+    (auto simp add: card_eq_0_iff dest: finite_cartesian_productD1 finite_cartesian_productD2)
+
+lemma card_cartesian_product_singleton:  "card({x} <*> A) = card(A)"
+by (simp add: card_cartesian_product)
+
 
 subsection {* Generalized product over a set *}
 
@@ -1016,230 +1090,6 @@
     by induct (auto simp add: field_simps abs_mult)
 qed auto
 
-
-subsection {* Finite cardinality *}
-
-text {* This definition, although traditional, is ugly to work with:
-@{text "card A == LEAST n. EX f. A = {f i | i. i < n}"}.
-But now that we have @{text setsum} things are easy:
-*}
-
-definition card :: "'a set \<Rightarrow> nat" where
-  "card A = setsum (\<lambda>x. 1) A"
-
-lemmas card_eq_setsum = card_def
-
-lemma card_empty [simp]: "card {} = 0"
-  by (simp add: card_def)
-
-lemma card_insert_disjoint [simp]:
-  "finite A ==> x \<notin> A ==> card (insert x A) = Suc(card A)"
-  by (simp add: card_def)
-
-lemma card_insert_if:
-  "finite A ==> card (insert x A) = (if x:A then card A else Suc(card(A)))"
-  by (simp add: insert_absorb)
-
-lemma card_infinite [simp]: "~ finite A ==> card A = 0"
-  by (simp add: card_def)
-
-lemma card_ge_0_finite:
-  "card A > 0 \<Longrightarrow> finite A"
-  by (rule ccontr) simp
-
-lemma card_0_eq [simp,noatp]: "finite A ==> (card A = 0) = (A = {})"
-  apply auto
-  apply (drule_tac a = x in mk_disjoint_insert, clarify, auto)
-  done
-
-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) = (A = {} | ~ finite A)"
-  by auto
-
-lemma card_gt_0_iff: "(0 < card A) = (A \<noteq> {} & finite A)"
-  by (simp add: neq0_conv [symmetric] card_eq_0_iff) 
-
-lemma card_Suc_Diff1: "finite A ==> x: A ==> Suc (card (A - {x})) = card A"
-apply(rule_tac t = A in insert_Diff [THEN subst], assumption)
-apply(simp del:insert_Diff_single)
-done
-
-lemma card_Diff_singleton:
-  "finite A ==> x: A ==> card (A - {x}) = card A - 1"
-by (simp add: card_Suc_Diff1 [symmetric])
-
-lemma card_Diff_singleton_if:
-  "finite A ==> card (A-{x}) = (if x : A then card A - 1 else card A)"
-by (simp add: card_Diff_singleton)
-
-lemma card_Diff_insert[simp]:
-assumes "finite A" and "a:A" and "a ~: 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: "finite A ==> card (insert x A) = Suc (card (A - {x}))"
-by (simp add: card_insert_if card_Suc_Diff1 del:card_Diff_insert)
-
-lemma card_insert_le: "finite A ==> card A <= card (insert x A)"
-by (simp add: card_insert_if)
-
-lemma card_mono: "\<lbrakk> finite B; A \<subseteq> B \<rbrakk> \<Longrightarrow> card A \<le> card B"
-by (simp add: card_def setsum_mono2)
-
-lemma card_seteq: "finite B ==> (!!A. A <= B ==> card B <= card A ==> A = B)"
-apply (induct set: finite, simp, clarify)
-apply (subgoal_tac "finite A & A - {x} <= F")
- prefer 2 apply (blast intro: finite_subset, atomize)
-apply (drule_tac x = "A - {x}" in spec)
-apply (simp add: card_Diff_singleton_if split add: split_if_asm)
-apply (case_tac "card A", auto)
-done
-
-lemma psubset_card_mono: "finite B ==> A < B ==> card A < card B"
-apply (simp add: psubset_eq linorder_not_le [symmetric])
-apply (blast dest: card_seteq)
-done
-
-lemma card_Un_Int: "finite A ==> finite B
-    ==> card A + card B = card (A Un B) + card (A Int B)"
-by(simp add:card_def setsum_Un_Int)
-
-lemma card_Un_disjoint: "finite A ==> finite B
-    ==> A Int B = {} ==> card (A Un B) = card A + card B"
-by (simp add: card_Un_Int)
-
-lemma card_Diff_subset:
-  "finite B ==> B <= A ==> card (A - B) = card A - card B"
-by(simp add:card_def setsum_diff_nat)
-
-lemma card_Diff_subset_Int:
-  assumes AB: "finite (A \<inter> B)" shows "card (A - B) = card A - card (A \<inter> B)"
-proof -
-  have "A - B = A - A \<inter> B" by auto
-  thus ?thesis
-    by (simp add: card_Diff_subset AB) 
-qed
-
-lemma card_Diff1_less: "finite A ==> x: A ==> card (A - {x}) < card A"
-apply (rule Suc_less_SucD)
-apply (simp add: card_Suc_Diff1 del:card_Diff_insert)
-done
-
-lemma card_Diff2_less:
-  "finite A ==> x: A ==> y: A ==> card (A - {x} - {y}) < card A"
-apply (case_tac "x = y")
- apply (simp add: card_Diff1_less del:card_Diff_insert)
-apply (rule less_trans)
- prefer 2 apply (auto intro!: card_Diff1_less simp del:card_Diff_insert)
-done
-
-lemma card_Diff1_le: "finite A ==> card (A - {x}) <= card A"
-apply (case_tac "x : A")
- apply (simp_all add: card_Diff1_less less_imp_le)
-done
-
-lemma card_psubset: "finite B ==> A \<subseteq> B ==> card A < card B ==> A < B"
-by (erule psubsetI, blast)
-
-lemma insert_partition:
-  "\<lbrakk> x \<notin> F; \<forall>c1 \<in> insert x F. \<forall>c2 \<in> insert x F. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {} \<rbrakk>
-  \<Longrightarrow> x \<inter> \<Union> F = {}"
-by auto
-
-lemma finite_psubset_induct[consumes 1, case_names psubset]:
-  assumes "finite A" and "!!A. finite A \<Longrightarrow> (!!B. finite B \<Longrightarrow> B \<subset> A \<Longrightarrow> P(B)) \<Longrightarrow> P(A)" shows "P A"
-using assms(1)
-proof (induct A rule: measure_induct_rule[where f=card])
-  case (less A)
-  show ?case
-  proof(rule assms(2)[OF less(2)])
-    fix B assume "finite B" "B \<subset> A"
-    show "P B" by(rule less(1)[OF psubset_card_mono[OF less(2) `B \<subset> A`] `finite B`])
-  qed
-qed
-
-text{* main cardinality theorem *}
-lemma card_partition [rule_format]:
-  "finite C ==>
-     finite (\<Union> C) -->
-     (\<forall>c\<in>C. card c = k) -->
-     (\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 --> c1 \<inter> c2 = {}) -->
-     k * card(C) = card (\<Union> C)"
-apply (erule finite_induct, simp)
-apply (simp add: card_Un_disjoint insert_partition 
-       finite_subset [of _ "\<Union> (insert x F)"])
-done
-
-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
-    fix x
-    show "x \<in> A"
-    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{*The form of a finite set of given cardinality*}
-
-lemma card_eq_SucD:
-assumes "card A = Suc k"
-shows "\<exists>b B. A = insert b B & b \<notin> B & card B = k & (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(fastsimp dest:mk_disjoint_insert)+
-  qed
-qed
-
-lemma card_Suc_eq:
-  "(card A = Suc k) =
-   (\<exists>b B. A = insert b B & b \<notin> B & card B = k & (k=0 \<longrightarrow> B={}))"
-apply(rule iffI)
- apply(erule card_eq_SucD)
-apply(auto)
-apply(subst card_insert)
- apply(auto intro:ccontr)
-done
-
-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))"
-    by(rule finite_imageI)
-  moreover have "UNIV = range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary)"
-    by(rule UNIV_eq_I) auto
-  ultimately show "finite (UNIV :: 'b set)" by simp
-qed
-
-lemma setsum_constant [simp]: "(\<Sum>x \<in> A. y) = of_nat(card A) * y"
-apply (cases "finite A")
-apply (erule finite_induct)
-apply (auto simp add: algebra_simps)
-done
-
 lemma setprod_constant: "finite A ==> (\<Prod>x\<in> A. (y::'a::{comm_monoid_mult})) = y^(card A)"
 apply (erule finite_induct)
 apply auto
@@ -1273,207 +1123,6 @@
 qed
 
 
-lemma setsum_bounded:
-  assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> (K::'a::{semiring_1, ordered_ab_semigroup_add})"
-  shows "setsum f A \<le> of_nat(card A) * K"
-proof (cases "finite A")
-  case True
-  thus ?thesis using le setsum_mono[where K=A and g = "%x. K"] by simp
-next
-  case False thus ?thesis by (simp add: setsum_def)
-qed
-
-
-lemma card_UNIV_unit: "card (UNIV :: unit set) = 1"
-  unfolding UNIV_unit by simp
-
-
-subsubsection {* Cardinality of unions *}
-
-lemma card_UN_disjoint:
-  "finite I ==> (ALL i:I. finite (A i)) ==>
-   (ALL i:I. ALL j:I. i \<noteq> j --> A i Int A j = {})
-   ==> card (UNION I A) = (\<Sum>i\<in>I. card(A i))"
-apply (simp add: card_def del: setsum_constant)
-apply (subgoal_tac
-         "setsum (%i. card (A i)) I = setsum (%i. (setsum (%x. 1) (A i))) I")
-apply (simp add: setsum_UN_disjoint del: setsum_constant)
-apply (simp cong: setsum_cong)
-done
-
-lemma card_Union_disjoint:
-  "finite C ==> (ALL A:C. finite A) ==>
-   (ALL A:C. ALL B:C. A \<noteq> B --> A Int B = {})
-   ==> card (Union C) = setsum card C"
-apply (frule card_UN_disjoint [of C id])
-apply (unfold Union_def id_def, assumption+)
-done
-
-
-subsubsection {* Cardinality of image *}
-
-text{*The image of a finite set can be expressed using @{term fold_image}.*}
-lemma image_eq_fold_image:
-  "finite A ==> f ` A = fold_image (op Un) (%x. {f x}) {} A"
-proof (induct rule: finite_induct)
-  case empty then show ?case by simp
-next
-  interpret ab_semigroup_mult "op Un"
-    proof qed auto
-  case insert 
-  then show ?case by simp
-qed
-
-lemma card_image_le: "finite A ==> card (f ` A) <= card A"
-apply (induct set: finite)
- apply simp
-apply (simp add: le_SucI card_insert_if)
-done
-
-lemma card_image: "inj_on f A ==> card (f ` A) = card A"
-by(simp add:card_def setsum_reindex o_def del:setsum_constant)
-
-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 ==> f ` A \<subseteq> A ==> inj_on f A ==> f ` A = A"
-by (simp add: card_seteq card_image)
-
-lemma eq_card_imp_inj_on:
-  "[| finite A; card(f ` A) = card A |] ==> inj_on f A"
-apply (induct rule:finite_induct)
-apply simp
-apply(frule card_image_le[where f = f])
-apply(simp add:card_insert_if split:if_splits)
-done
-
-lemma inj_on_iff_eq_card:
-  "finite A ==> inj_on f A = (card(f ` A) = card A)"
-by(blast intro: card_image eq_card_imp_inj_on)
-
-
-lemma card_inj_on_le:
-  "[|inj_on f A; f ` A \<subseteq> B; finite B |] ==> card A \<le> card B"
-apply (subgoal_tac "finite A") 
- apply (force intro: card_mono simp add: card_image [symmetric])
-apply (blast intro: finite_imageD dest: finite_subset) 
-done
-
-lemma card_bij_eq:
-  "[|inj_on f A; f ` A \<subseteq> B; inj_on g B; g ` B \<subseteq> A;
-     finite A; finite B |] ==> card A = card B"
-by (auto intro: le_antisym card_inj_on_le)
-
-
-subsubsection {* Cardinality of products *}
-
-(*
-lemma SigmaI_insert: "y \<notin> A ==>
-  (SIGMA x:(insert y A). B x) = (({y} <*> (B y)) \<union> (SIGMA x: A. B x))"
-  by auto
-*)
-
-lemma card_SigmaI [simp]:
-  "\<lbrakk> finite A; ALL a:A. finite (B a) \<rbrakk>
-  \<Longrightarrow> card (SIGMA x: A. B x) = (\<Sum>a\<in>A. card (B a))"
-by(simp add:card_def setsum_Sigma del:setsum_constant)
-
-lemma card_cartesian_product: "card (A <*> B) = card(A) * card(B)"
-apply (cases "finite A") 
-apply (cases "finite B") 
-apply (auto simp add: card_eq_0_iff
-            dest: finite_cartesian_productD1 finite_cartesian_productD2)
-done
-
-lemma card_cartesian_product_singleton:  "card({x} <*> A) = card(A)"
-by (simp add: card_cartesian_product)
-
-
-subsubsection {* Cardinality of sums *}
-
-lemma card_Plus:
-  assumes "finite A" and "finite B"
-  shows "card (A <+> B) = card A + card B"
-proof -
-  have "Inl`A \<inter> Inr`B = {}" by fast
-  with assms show ?thesis
-    unfolding Plus_def
-    by (simp add: 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: card_def setsum_Plus simp del: setsum_constant)
-
-
-subsubsection {* Cardinality of the Powerset *}
-
-lemma card_Pow: "finite A ==> card (Pow A) = Suc (Suc 0) ^ card A"  (* FIXME numeral 2 (!?) *)
-apply (induct set: finite)
- apply (simp_all add: Pow_insert)
-apply (subst card_Un_disjoint, blast)
-  apply (blast intro: finite_imageI, blast)
-apply (subgoal_tac "inj_on (insert x) (Pow F)")
- apply (simp add: card_image Pow_insert)
-apply (unfold inj_on_def)
-apply (blast elim!: equalityE)
-done
-
-text {* Relates to equivalence classes.  Based on a theorem of F. Kammüller.  *}
-
-lemma dvd_partition:
-  "finite (Union C) ==>
-    ALL c : C. k dvd card c ==>
-    (ALL c1: C. ALL c2: C. c1 \<noteq> c2 --> c1 Int c2 = {}) ==>
-  k dvd card (Union C)"
-apply(frule finite_UnionD)
-apply(rotate_tac -1)
-apply (induct set: finite, simp_all, clarify)
-apply (subst card_Un_disjoint)
-   apply (auto simp add: disjoint_eq_subset_Compl)
-done
-
-
-subsubsection {* Relating injectivity and surjectivity *}
-
-lemma finite_surj_inj: "finite(A) \<Longrightarrow> A <= f`A \<Longrightarrow> inj_on f A"
-apply(rule eq_card_imp_inj_on, assumption)
-apply(frule finite_imageI)
-apply(drule (1) card_seteq)
- apply(erule card_image_le)
-apply simp
-done
-
-lemma finite_UNIV_surj_inj: fixes f :: "'a \<Rightarrow> 'a"
-shows "finite(UNIV:: 'a set) \<Longrightarrow> surj f \<Longrightarrow> inj f"
-by (blast intro: finite_surj_inj subset_UNIV dest:surj_range)
-
-lemma finite_UNIV_inj_surj: fixes f :: "'a \<Rightarrow> 'a"
-shows "finite(UNIV:: 'a set) \<Longrightarrow> inj f \<Longrightarrow> surj f"
-by(fastsimp simp:surj_def dest!: endo_inj_surj)
-
-corollary infinite_UNIV_nat[iff]: "~finite(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
-
-(* Often leads to bogus ATP proofs because of reduced type information, hence noatp *)
-lemma infinite_UNIV_char_0[noatp]:
-  "\<not> finite (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
-
 subsubsection {* Fold1 in lattices with @{const inf} and @{const sup} *}
 
 text{*
diff -r f7bbee848403 -r 69419a09a7ff src/HOL/Finite_Set.thy
--- a/src/HOL/Finite_Set.thy	Thu Mar 11 14:38:09 2010 +0100
+++ b/src/HOL/Finite_Set.thy	Thu Mar 11 14:38:13 2010 +0100
@@ -1474,7 +1474,7 @@
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   fixes F :: "'a set \<Rightarrow> 'b \<Rightarrow> 'b"
   assumes commute_comp: "f x \<circ> f y = f y \<circ> f x"
-  assumes eq_fold: "F A s = Finite_Set.fold f s A"
+  assumes eq_fold: "finite A \<Longrightarrow> F A s = fold f s A"
 begin
 
 lemma fun_left_commute:
@@ -1496,8 +1496,8 @@
 proof -
   interpret fun_left_comm f by (fact fun_left_comm)
   from fold_insert2 assms
-  have "\<And>s. Finite_Set.fold f s (insert x A) = Finite_Set.fold f (f x s) A" .
-  then show ?thesis by (simp add: eq_fold expand_fun_eq)
+  have "\<And>s. fold f s (insert x A) = fold f (f x s) A" .
+  with `finite A` show ?thesis by (simp add: eq_fold expand_fun_eq)
 qed
 
 lemma remove:
@@ -1513,11 +1513,7 @@
 lemma insert_remove:
   assumes "finite A"
   shows "F (insert x A) = F (A - {x}) \<circ> f x"
-proof (cases "x \<in> A")
-  case True with assms show ?thesis by (simp add: remove insert_absorb)
-next
-  case False with assms show ?thesis by simp
-qed
+  using assms by (cases "x \<in> A") (simp_all add: remove insert_absorb)
 
 lemma commute_comp':
   assumes "finite A"
@@ -1572,8 +1568,8 @@
 proof -
   interpret fun_left_comm_idem f by (fact fun_left_comm_idem)
   from fold_insert_idem2 assms
-  have "\<And>s. Finite_Set.fold f s (insert x A) = Finite_Set.fold f (f x s) A" .
-  then show ?thesis by (simp add: eq_fold expand_fun_eq)
+  have "\<And>s. fold f s (insert x A) = fold f (f x s) A" .
+  with assms show ?thesis by (simp add: eq_fold expand_fun_eq)
 qed
 
 lemma union_idem:
@@ -1590,4 +1586,542 @@
 
 end
 
+no_notation (in times) times (infixl "*" 70)
+no_notation (in one) Groups.one ("1")
+
+locale folding_image_simple = comm_monoid +
+  fixes g :: "('b \<Rightarrow> 'a)"
+  fixes F :: "'b set \<Rightarrow> 'a"
+  assumes eq_fold: "finite A \<Longrightarrow> F A = fold_image f g 1 A"
+begin
+
+lemma empty [simp]:
+  "F {} = 1"
+  by (simp add: eq_fold)
+
+lemma insert [simp]:
+  assumes "finite A" and "x \<notin> A"
+  shows "F (insert x A) = g x * F A"
+proof -
+  interpret fun_left_comm "%x y. (g x) * y" proof
+  qed (simp add: ac_simps)
+  with assms have "fold_image (op *) g 1 (insert x A) = g x * fold_image (op *) g 1 A"
+    by (simp add: fold_image_def)
+  with `finite A` show ?thesis by (simp add: eq_fold)
+qed
+
+lemma remove:
+  assumes "finite A" and "x \<in> A"
+  shows "F A = g x * F (A - {x})"
+proof -
+  from `x \<in> A` obtain B where A: "A = insert x B" and "x \<notin> B"
+    by (auto dest: mk_disjoint_insert)
+  moreover from `finite A` this have "finite B" by simp
+  ultimately show ?thesis by simp
+qed
+
+lemma insert_remove:
+  assumes "finite A"
+  shows "F (insert x A) = g x * F (A - {x})"
+  using assms by (cases "x \<in> A") (simp_all add: remove insert_absorb)
+
+lemma union_inter:
+  assumes "finite A" and "finite B"
+  shows "F A * F B = F (A \<union> B) * F (A \<inter> B)"
+using assms proof (induct A)
+  case empty then show ?case by simp
+next
+  case (insert x A) then show ?case
+    by (auto simp add: insert_absorb Int_insert_left commute [of _ "g x"] assoc left_commute)
+qed
+
+corollary union_disjoint:
+  assumes "finite A" and "finite B"
+  assumes "A \<inter> B = {}"
+  shows "F (A \<union> B) = F A * F B"
+  using assms by (simp add: union_inter)
+
 end
+
+locale folding_image = comm_monoid +
+  fixes F :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'a"
+  assumes eq_fold: "\<And>g. finite A \<Longrightarrow> F g A = fold_image f g 1 A"
+
+sublocale folding_image < folding_image_simple "op *" 1 g "F g" proof
+qed (fact eq_fold)
+
+context folding_image
+begin
+
+lemma reindex:
+  assumes "finite A" and "inj_on h A"
+  shows "F g (h ` A) = F (g \<circ> h) A"
+  using assms by (induct A) auto
+
+lemma cong:
+  assumes "finite A" and "\<And>x. x \<in> A \<Longrightarrow> g x = h x"
+  shows "F g A = F h A"
+proof -
+  from assms have "ALL C. C <= A --> (ALL x:C. g x = h x) --> F g C = F h C"
+  apply - apply (erule finite_induct) apply simp
+  apply (simp add: subset_insert_iff, clarify)
+  apply (subgoal_tac "finite C")
+  prefer 2 apply (blast dest: finite_subset [COMP swap_prems_rl])
+  apply (subgoal_tac "C = insert x (C - {x})")
+  prefer 2 apply blast
+  apply (erule ssubst)
+  apply (drule spec)
+  apply (erule (1) notE impE)
+  apply (simp add: Ball_def del: insert_Diff_single)
+  done
+  with assms show ?thesis by simp
+qed
+
+lemma UNION_disjoint:
+  assumes "finite I" and "\<forall>i\<in>I. finite (A i)"
+  and "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}"
+  shows "F g (UNION I A) = F (F g \<circ> A) I"
+apply (insert assms)
+apply (induct set: finite, simp, atomize)
+apply (subgoal_tac "\<forall>i\<in>Fa. x \<noteq> i")
+ prefer 2 apply blast
+apply (subgoal_tac "A x Int UNION Fa A = {}")
+ prefer 2 apply blast
+apply (simp add: union_disjoint)
+done
+
+lemma distrib:
+  assumes "finite A"
+  shows "F (\<lambda>x. g x * h x) A = F g A * F h A"
+  using assms by (rule finite_induct) (simp_all add: assoc commute left_commute)
+
+lemma related: 
+  assumes Re: "R 1 1" 
+  and Rop: "\<forall>x1 y1 x2 y2. R x1 x2 \<and> R y1 y2 \<longrightarrow> R (x1 * y1) (x2 * y2)" 
+  and fS: "finite S" and Rfg: "\<forall>x\<in>S. R (h x) (g x)"
+  shows "R (F h S) (F g S)"
+  using fS by (rule finite_subset_induct) (insert assms, auto)
+
+lemma eq_general:
+  assumes fS: "finite S"
+  and h: "\<forall>y\<in>S'. \<exists>!x. x \<in> S \<and> h x = y" 
+  and f12:  "\<forall>x\<in>S. h x \<in> S' \<and> f2 (h x) = f1 x"
+  shows "F f1 S = F f2 S'"
+proof-
+  from h f12 have hS: "h ` S = S'" by blast
+  {fix x y assume H: "x \<in> S" "y \<in> S" "h x = h y"
+    from f12 h H  have "x = y" by auto }
+  hence hinj: "inj_on h S" unfolding inj_on_def Ex1_def by blast
+  from f12 have th: "\<And>x. x \<in> S \<Longrightarrow> (f2 \<circ> h) x = f1 x" by auto 
+  from hS have "F f2 S' = F f2 (h ` S)" by simp
+  also have "\<dots> = F (f2 o h) S" using reindex [OF fS hinj, of f2] .
+  also have "\<dots> = F f1 S " using th cong [OF fS, of "f2 o h" f1]
+    by blast
+  finally show ?thesis ..
+qed
+
+lemma eq_general_inverses:
+  assumes fS: "finite S" 
+  and kh: "\<And>y. y \<in> T \<Longrightarrow> k y \<in> S \<and> h (k y) = y"
+  and hk: "\<And>x. x \<in> S \<Longrightarrow> h x \<in> T \<and> k (h x) = x \<and> g (h x) = j x"
+  shows "F j S = F g T"
+  (* metis solves it, but not yet available here *)
+  apply (rule eq_general [OF fS, of T h g j])
+  apply (rule ballI)
+  apply (frule kh)
+  apply (rule ex1I[])
+  apply blast
+  apply clarsimp
+  apply (drule hk) apply simp
+  apply (rule sym)
+  apply (erule conjunct1[OF conjunct2[OF hk]])
+  apply (rule ballI)
+  apply (drule hk)
+  apply blast
+  done
+
+end
+
+notation (in times) times (infixl "*" 70)
+notation (in one) Groups.one ("1")
+
+
+subsection {* Finite cardinality *}
+
+text {* This definition, although traditional, is ugly to work with:
+@{text "card A == LEAST n. EX f. A = {f i | i. i < n}"}.
+But now that we have @{text fold_image} things are easy:
+*}
+
+definition card :: "'a set \<Rightarrow> nat" where
+  "card A = (if finite A then fold_image (op +) (\<lambda>x. 1) 0 A else 0)"
+
+interpretation card!: folding_image_simple "op +" 0 "\<lambda>x. 1" card proof
+qed (simp add: card_def)
+
+lemma card_infinite [simp]:
+  "\<not> finite A \<Longrightarrow> card A = 0"
+  by (simp add: card_def)
+
+lemma card_empty:
+  "card {} = 0"
+  by (fact card.empty)
+
+lemma card_insert_disjoint:
+  "finite A ==> x \<notin> A ==> card (insert x A) = Suc (card A)"
+  by simp
+
+lemma card_insert_if:
+  "finite A ==> 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, noatp]:
+  "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_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: "finite A ==> x: A ==> Suc (card (A - {x})) = card A"
+apply(rule_tac t = A in insert_Diff [THEN subst], assumption)
+apply(simp del:insert_Diff_single)
+done
+
+lemma card_Diff_singleton:
+  "finite A ==> x: A ==> card (A - {x}) = card A - 1"
+by (simp add: card_Suc_Diff1 [symmetric])
+
+lemma card_Diff_singleton_if:
+  "finite A ==> card (A-{x}) = (if x : A then card A - 1 else card A)"
+by (simp add: card_Diff_singleton)
+
+lemma card_Diff_insert[simp]:
+assumes "finite A" and "a:A" and "a ~: 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: "finite A ==> card (insert x A) = Suc (card (A - {x}))"
+by (simp add: card_insert_if card_Suc_Diff1 del:card_Diff_insert)
+
+lemma card_insert_le: "finite A ==> card A <= card (insert x A)"
+by (simp add: card_insert_if)
+
+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 `finite A` `x \<notin> A` `finite B` `x \<in> B` show ?case by simp (simp only: card.remove)
+  qed
+qed
+
+lemma card_seteq: "finite B ==> (!!A. A <= B ==> card B <= card A ==> A = B)"
+apply (induct set: finite, simp, clarify)
+apply (subgoal_tac "finite A & A - {x} <= F")
+ prefer 2 apply (blast intro: finite_subset, atomize)
+apply (drule_tac x = "A - {x}" in spec)
+apply (simp add: card_Diff_singleton_if split add: split_if_asm)
+apply (case_tac "card A", auto)
+done
+
+lemma psubset_card_mono: "finite B ==> A < B ==> card A < card B"
+apply (simp add: psubset_eq linorder_not_le [symmetric])
+apply (blast dest: card_seteq)
+done
+
+lemma card_Un_Int: "finite A ==> finite B
+    ==> card A + card B = card (A Un B) + card (A Int B)"
+  by (fact card.union_inter)
+
+lemma card_Un_disjoint: "finite A ==> finite B
+    ==> A Int B = {} ==> card (A Un B) = card A + card B"
+  by (fact card.union_disjoint)
+
+lemma card_Diff_subset:
+  assumes "finite B" and "B \<subseteq> A"
+  shows "card (A - B) = card A - card B"
+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 AB: "finite (A \<inter> B)" shows "card (A - B) = card A - card (A \<inter> B)"
+proof -
+  have "A - B = A - A \<inter> B" by auto
+  thus ?thesis
+    by (simp add: card_Diff_subset AB) 
+qed
+
+lemma card_Diff1_less: "finite A ==> x: A ==> card (A - {x}) < card A"
+apply (rule Suc_less_SucD)
+apply (simp add: card_Suc_Diff1 del:card_Diff_insert)
+done
+
+lemma card_Diff2_less:
+  "finite A ==> x: A ==> y: A ==> card (A - {x} - {y}) < card A"
+apply (case_tac "x = y")
+ apply (simp add: card_Diff1_less del:card_Diff_insert)
+apply (rule less_trans)
+ prefer 2 apply (auto intro!: card_Diff1_less simp del:card_Diff_insert)
+done
+
+lemma card_Diff1_le: "finite A ==> card (A - {x}) <= card A"
+apply (case_tac "x : A")
+ apply (simp_all add: card_Diff1_less less_imp_le)
+done
+
+lemma card_psubset: "finite B ==> A \<subseteq> B ==> card A < card B ==> A < B"
+by (erule psubsetI, blast)
+
+lemma insert_partition:
+  "\<lbrakk> x \<notin> F; \<forall>c1 \<in> insert x F. \<forall>c2 \<in> insert x F. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {} \<rbrakk>
+  \<Longrightarrow> x \<inter> \<Union> F = {}"
+by auto
+
+lemma finite_psubset_induct[consumes 1, case_names psubset]:
+  assumes "finite A" and "!!A. finite A \<Longrightarrow> (!!B. finite B \<Longrightarrow> B \<subset> A \<Longrightarrow> P(B)) \<Longrightarrow> P(A)" shows "P A"
+using assms(1)
+proof (induct A rule: measure_induct_rule[where f=card])
+  case (less A)
+  show ?case
+  proof(rule assms(2)[OF less(2)])
+    fix B assume "finite B" "B \<subset> A"
+    show "P B" by(rule less(1)[OF psubset_card_mono[OF less(2) `B \<subset> A`] `finite B`])
+  qed
+qed
+
+text{* main cardinality theorem *}
+lemma card_partition [rule_format]:
+  "finite C ==>
+     finite (\<Union> C) -->
+     (\<forall>c\<in>C. card c = k) -->
+     (\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 --> c1 \<inter> c2 = {}) -->
+     k * card(C) = card (\<Union> C)"
+apply (erule finite_induct, simp)
+apply (simp add: card_Un_disjoint insert_partition 
+       finite_subset [of _ "\<Union> (insert x F)"])
+done
+
+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
+    fix x
+    show "x \<in> A"
+    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{*The form of a finite set of given cardinality*}
+
+lemma card_eq_SucD:
+assumes "card A = Suc k"
+shows "\<exists>b B. A = insert b B & b \<notin> B & card B = k & (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(fastsimp dest:mk_disjoint_insert)+
+  qed
+qed
+
+lemma card_Suc_eq:
+  "(card A = Suc k) =
+   (\<exists>b B. A = insert b B & b \<notin> B & card B = k & (k=0 \<longrightarrow> B={}))"
+apply(rule iffI)
+ apply(erule card_eq_SucD)
+apply(auto)
+apply(subst card_insert)
+ apply(auto intro:ccontr)
+done
+
+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))"
+    by(rule finite_imageI)
+  moreover have "UNIV = range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary)"
+    by(rule UNIV_eq_I) auto
+  ultimately show "finite (UNIV :: 'b set)" by simp
+qed
+
+lemma card_UNIV_unit: "card (UNIV :: unit set) = 1"
+  unfolding UNIV_unit by simp
+
+
+subsubsection {* Cardinality of image *}
+
+lemma card_image_le: "finite A ==> card (f ` A) <= card A"
+apply (induct set: finite)
+ apply simp
+apply (simp add: le_SucI card_insert_if)
+done
+
+lemma card_image:
+  assumes "inj_on f A"
+  shows "card (f ` A) = card A"
+proof (cases "finite A")
+  case True then show ?thesis using assms by (induct A) simp_all
+next
+  case False then have "\<not> finite (f ` A)" using assms by (auto dest: finite_imageD)
+  with False show ?thesis by simp
+qed
+
+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 ==> f ` A \<subseteq> A ==> inj_on f A ==> f ` A = A"
+by (simp add: card_seteq card_image)
+
+lemma eq_card_imp_inj_on:
+  "[| finite A; card(f ` A) = card A |] ==> inj_on f A"
+apply (induct rule:finite_induct)
+apply simp
+apply(frule card_image_le[where f = f])
+apply(simp add:card_insert_if split:if_splits)
+done
+
+lemma inj_on_iff_eq_card:
+  "finite A ==> inj_on f A = (card(f ` A) = card A)"
+by(blast intro: card_image eq_card_imp_inj_on)
+
+
+lemma card_inj_on_le:
+  "[|inj_on f A; f ` A \<subseteq> B; finite B |] ==> card A \<le> card B"
+apply (subgoal_tac "finite A") 
+ apply (force intro: card_mono simp add: card_image [symmetric])
+apply (blast intro: finite_imageD dest: finite_subset) 
+done
+
+lemma card_bij_eq:
+  "[|inj_on f A; f ` A \<subseteq> B; inj_on g B; g ` B \<subseteq> A;
+     finite A; finite B |] ==> card A = card B"
+by (auto intro: le_antisym card_inj_on_le)
+
+
+subsubsection {* Cardinality of sums *}
+
+lemma card_Plus:
+  assumes "finite A" and "finite B"
+  shows "card (A <+> B) = card A + card B"
+proof -
+  have "Inl`A \<inter> Inr`B = {}" by fast
+  with assms show ?thesis
+    unfolding Plus_def
+    by (simp add: 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)
+
+
+subsubsection {* Cardinality of the Powerset *}
+
+lemma card_Pow: "finite A ==> card (Pow A) = Suc (Suc 0) ^ card A"  (* FIXME numeral 2 (!?) *)
+apply (induct set: finite)
+ apply (simp_all add: Pow_insert)
+apply (subst card_Un_disjoint, blast)
+  apply (blast intro: finite_imageI, blast)
+apply (subgoal_tac "inj_on (insert x) (Pow F)")
+ apply (simp add: card_image Pow_insert)
+apply (unfold inj_on_def)
+apply (blast elim!: equalityE)
+done
+
+text {* Relates to equivalence classes.  Based on a theorem of F. Kammüller.  *}
+
+lemma dvd_partition:
+  "finite (Union C) ==>
+    ALL c : C. k dvd card c ==>
+    (ALL c1: C. ALL c2: C. c1 \<noteq> c2 --> c1 Int c2 = {}) ==>
+  k dvd card (Union C)"
+apply(frule finite_UnionD)
+apply(rotate_tac -1)
+apply (induct set: finite, simp_all, clarify)
+apply (subst card_Un_disjoint)
+   apply (auto simp add: disjoint_eq_subset_Compl)
+done
+
+
+subsubsection {* Relating injectivity and surjectivity *}
+
+lemma finite_surj_inj: "finite(A) \<Longrightarrow> A <= f`A \<Longrightarrow> inj_on f A"
+apply(rule eq_card_imp_inj_on, assumption)
+apply(frule finite_imageI)
+apply(drule (1) card_seteq)
+ apply(erule card_image_le)
+apply simp
+done
+
+lemma finite_UNIV_surj_inj: fixes f :: "'a \<Rightarrow> 'a"
+shows "finite(UNIV:: 'a set) \<Longrightarrow> surj f \<Longrightarrow> inj f"
+by (blast intro: finite_surj_inj subset_UNIV dest:surj_range)
+
+lemma finite_UNIV_inj_surj: fixes f :: "'a \<Rightarrow> 'a"
+shows "finite(UNIV:: 'a set) \<Longrightarrow> inj f \<Longrightarrow> surj f"
+by(fastsimp simp:surj_def dest!: endo_inj_surj)
+
+corollary infinite_UNIV_nat[iff]: "~finite(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
+
+(* Often leads to bogus ATP proofs because of reduced type information, hence noatp *)
+lemma infinite_UNIV_char_0[noatp]:
+  "\<not> finite (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
+
+end