src/HOL/Finite_Set.thy
changeset 22262 96ba62dff413
parent 21733 131dd2a27137
child 22316 f662831459de
equal deleted inserted replaced
22261:9e185f78e7d4 22262:96ba62dff413
    10 imports Power Divides Inductive Lattices
    10 imports Power Divides Inductive Lattices
    11 begin
    11 begin
    12 
    12 
    13 subsection {* Definition and basic properties *}
    13 subsection {* Definition and basic properties *}
    14 
    14 
    15 consts Finites :: "'a set set"
    15 inductive2 finite :: "'a set => bool"
    16 abbreviation
    16   where
    17   "finite A == A : Finites"
    17     emptyI [simp, intro!]: "finite {}"
    18 
    18   | insertI [simp, intro!]: "finite A ==> finite (insert a A)"
    19 inductive Finites
       
    20   intros
       
    21     emptyI [simp, intro!]: "{} : Finites"
       
    22     insertI [simp, intro!]: "A : Finites ==> insert a A : Finites"
       
    23 
    19 
    24 axclass finite \<subseteq> type
    20 axclass finite \<subseteq> type
    25   finite: "finite UNIV"
    21   finite: "finite UNIV"
    26 
    22 
    27 lemma ex_new_if_finite: -- "does not depend on def of finite at all"
    23 lemma ex_new_if_finite: -- "does not depend on def of finite at all"
    30 proof -
    26 proof -
    31   from prems have "A \<noteq> UNIV" by blast
    27   from prems have "A \<noteq> UNIV" by blast
    32   thus ?thesis by blast
    28   thus ?thesis by blast
    33 qed
    29 qed
    34 
    30 
    35 lemma finite_induct [case_names empty insert, induct set: Finites]:
    31 lemma finite_induct [case_names empty insert, induct set: finite]:
    36   "finite F ==>
    32   "finite F ==>
    37     P {} ==> (!!x F. finite F ==> x \<notin> F ==> P F ==> P (insert x F)) ==> P F"
    33     P {} ==> (!!x F. finite F ==> x \<notin> F ==> P F ==> P (insert x F)) ==> P F"
    38   -- {* Discharging @{text "x \<notin> F"} entails extra work. *}
    34   -- {* Discharging @{text "x \<notin> F"} entails extra work. *}
    39 proof -
    35 proof -
    40   assume "P {}" and
    36   assume "P {}" and
   144 
   140 
   145 subsubsection{* Finiteness and set theoretic constructions *}
   141 subsubsection{* Finiteness and set theoretic constructions *}
   146 
   142 
   147 lemma finite_UnI: "finite F ==> finite G ==> finite (F Un G)"
   143 lemma finite_UnI: "finite F ==> finite G ==> finite (F Un G)"
   148   -- {* The union of two finite sets is finite. *}
   144   -- {* The union of two finite sets is finite. *}
   149   by (induct set: Finites) simp_all
   145   by (induct set: finite) simp_all
   150 
   146 
   151 lemma finite_subset: "A \<subseteq> B ==> finite B ==> finite A"
   147 lemma finite_subset: "A \<subseteq> B ==> finite B ==> finite A"
   152   -- {* Every subset of a finite set is finite. *}
   148   -- {* Every subset of a finite set is finite. *}
   153 proof -
   149 proof -
   154   assume "finite B"
   150   assume "finite B"
   242 
   238 
   243 text {* Image and Inverse Image over Finite Sets *}
   239 text {* Image and Inverse Image over Finite Sets *}
   244 
   240 
   245 lemma finite_imageI[simp]: "finite F ==> finite (h ` F)"
   241 lemma finite_imageI[simp]: "finite F ==> finite (h ` F)"
   246   -- {* The image of a finite set is finite. *}
   242   -- {* The image of a finite set is finite. *}
   247   by (induct set: Finites) simp_all
   243   by (induct set: finite) simp_all
   248 
   244 
   249 lemma finite_surj: "finite A ==> B <= f ` A ==> finite B"
   245 lemma finite_surj: "finite A ==> B <= f ` A ==> finite B"
   250   apply (frule finite_imageI)
   246   apply (frule finite_imageI)
   251   apply (erule finite_subset, assumption)
   247   apply (erule finite_subset, assumption)
   252   done
   248   done
   284   done
   280   done
   285 
   281 
   286 lemma finite_vimageI: "[|finite F; inj h|] ==> finite (h -` F)"
   282 lemma finite_vimageI: "[|finite F; inj h|] ==> finite (h -` F)"
   287   -- {* The inverse image of a finite set under an injective function
   283   -- {* The inverse image of a finite set under an injective function
   288          is finite. *}
   284          is finite. *}
   289   apply (induct set: Finites)
   285   apply (induct set: finite)
   290    apply simp_all
   286    apply simp_all
   291   apply (subst vimage_insert)
   287   apply (subst vimage_insert)
   292   apply (simp add: finite_Un finite_subset [OF inj_vimage_singleton])
   288   apply (simp add: finite_Un finite_subset [OF inj_vimage_singleton])
   293   done
   289   done
   294 
   290 
   295 
   291 
   296 text {* The finite UNION of finite sets *}
   292 text {* The finite UNION of finite sets *}
   297 
   293 
   298 lemma finite_UN_I: "finite A ==> (!!a. a:A ==> finite (B a)) ==> finite (UN a:A. B a)"
   294 lemma finite_UN_I: "finite A ==> (!!a. a:A ==> finite (B a)) ==> finite (UN a:A. B a)"
   299   by (induct set: Finites) simp_all
   295   by (induct set: finite) simp_all
   300 
   296 
   301 text {*
   297 text {*
   302   Strengthen RHS to
   298   Strengthen RHS to
   303   @{prop "((ALL x:A. finite (B x)) & finite {x. x:A & B x \<noteq> {}})"}?
   299   @{prop "((ALL x:A. finite (B x)) & finite {x. x:A & B x \<noteq> {}})"}?
   304 
   300 
   396 text {* \paragraph{Finiteness of transitive closure} (Thanks to Sidi
   392 text {* \paragraph{Finiteness of transitive closure} (Thanks to Sidi
   397 Ehmety) *}
   393 Ehmety) *}
   398 
   394 
   399 lemma finite_Field: "finite r ==> finite (Field r)"
   395 lemma finite_Field: "finite r ==> finite (Field r)"
   400   -- {* A finite relation has a finite field (@{text "= domain \<union> range"}. *}
   396   -- {* A finite relation has a finite field (@{text "= domain \<union> range"}. *}
   401   apply (induct set: Finites)
   397   apply (induct set: finite)
   402    apply (auto simp add: Field_def Domain_insert Range_insert)
   398    apply (auto simp add: Field_def Domain_insert Range_insert)
   403   done
   399   done
   404 
   400 
   405 lemma trancl_subset_Field2: "r^+ <= Field r \<times> Field r"
   401 lemma trancl_subset_Field2: "r^+ <= Field r \<times> Field r"
   406   apply clarify
   402   apply clarify
   425 @{text "fold f g z {x\<^isub>1, ..., x\<^isub>n} = f (g x\<^isub>1) (\<dots> (f (g x\<^isub>n) z)\<dots>)"}
   421 @{text "fold f g z {x\<^isub>1, ..., x\<^isub>n} = f (g x\<^isub>1) (\<dots> (f (g x\<^isub>n) z)\<dots>)"}
   426 if @{text f} is associative-commutative. For an application of @{text fold}
   422 if @{text f} is associative-commutative. For an application of @{text fold}
   427 se the definitions of sums and products over finite sets.
   423 se the definitions of sums and products over finite sets.
   428 *}
   424 *}
   429 
   425 
   430 consts
   426 inductive2
   431   foldSet :: "('a => 'a => 'a) => ('b => 'a) => 'a => ('b set \<times> 'a) set"
   427   foldSet :: "('a => 'a => 'a) => ('b => 'a) => 'a => 'b set => 'a => bool"
   432 
   428   for f ::  "'a => 'a => 'a"
   433 inductive "foldSet f g z"
   429   and g :: "'b => 'a"
   434 intros
   430   and z :: 'a
   435 emptyI [intro]: "({}, z) : foldSet f g z"
   431 where
   436 insertI [intro]:
   432   emptyI [intro]: "foldSet f g z {} z"
   437      "\<lbrakk> x \<notin> A; (A, y) : foldSet f g z \<rbrakk>
   433 | insertI [intro]:
   438       \<Longrightarrow> (insert x A, f (g x) y) : foldSet f g z"
   434      "\<lbrakk> x \<notin> A; foldSet f g z A y \<rbrakk>
   439 
   435       \<Longrightarrow> foldSet f g z (insert x A) (f (g x) y)"
   440 inductive_cases empty_foldSetE [elim!]: "({}, x) : foldSet f g z"
   436 
       
   437 inductive_cases2 empty_foldSetE [elim!]: "foldSet f g z {} x"
   441 
   438 
   442 constdefs
   439 constdefs
   443   fold :: "('a => 'a => 'a) => ('b => 'a) => 'a => 'b set => 'a"
   440   fold :: "('a => 'a => 'a) => ('b => 'a) => 'a => 'b set => 'a"
   444   "fold f g z A == THE x. (A, x) : foldSet f g z"
   441   "fold f g z A == THE x. foldSet f g z A x"
   445 
   442 
   446 text{*A tempting alternative for the definiens is
   443 text{*A tempting alternative for the definiens is
   447 @{term "if finite A then THE x. (A, x) : foldSet f g e else e"}.
   444 @{term "if finite A then THE x. foldSet f g e A x else e"}.
   448 It allows the removal of finiteness assumptions from the theorems
   445 It allows the removal of finiteness assumptions from the theorems
   449 @{text fold_commute}, @{text fold_reindex} and @{text fold_distrib}.
   446 @{text fold_commute}, @{text fold_reindex} and @{text fold_distrib}.
   450 The proofs become ugly, with @{text rule_format}. It is not worth the effort.*}
   447 The proofs become ugly, with @{text rule_format}. It is not worth the effort.*}
   451 
   448 
   452 
   449 
   453 lemma Diff1_foldSet:
   450 lemma Diff1_foldSet:
   454   "(A - {x}, y) : foldSet f g z ==> x: A ==> (A, f (g x) y) : foldSet f g z"
   451   "foldSet f g z (A - {x}) y ==> x: A ==> foldSet f g z A (f (g x) y)"
   455 by (erule insert_Diff [THEN subst], rule foldSet.intros, auto)
   452 by (erule insert_Diff [THEN subst], rule foldSet.intros, auto)
   456 
   453 
   457 lemma foldSet_imp_finite: "(A, x) : foldSet f g z ==> finite A"
   454 lemma foldSet_imp_finite: "foldSet f g z A x==> finite A"
   458   by (induct set: foldSet) auto
   455   by (induct set: foldSet) auto
   459 
   456 
   460 lemma finite_imp_foldSet: "finite A ==> EX x. (A, x) : foldSet f g z"
   457 lemma finite_imp_foldSet: "finite A ==> EX x. foldSet f g z A x"
   461   by (induct set: Finites) auto
   458   by (induct set: finite) auto
   462 
   459 
   463 
   460 
   464 subsubsection {* Commutative monoids *}
   461 subsubsection {* Commutative monoids *}
   465 
   462 
   466 locale ACf =
   463 locale ACf =
   552   qed
   549   qed
   553 qed
   550 qed
   554 
   551 
   555 lemma (in ACf) foldSet_determ_aux:
   552 lemma (in ACf) foldSet_determ_aux:
   556   "!!A x x' h. \<lbrakk> A = h`{i::nat. i<n}; inj_on h {i. i<n}; 
   553   "!!A x x' h. \<lbrakk> A = h`{i::nat. i<n}; inj_on h {i. i<n}; 
   557                 (A,x) : foldSet f g z; (A,x') : foldSet f g z \<rbrakk>
   554                 foldSet f g z A x; foldSet f g z A x' \<rbrakk>
   558    \<Longrightarrow> x' = x"
   555    \<Longrightarrow> x' = x"
   559 proof (induct n rule: less_induct)
   556 proof (induct n rule: less_induct)
   560   case (less n)
   557   case (less n)
   561     have IH: "!!m h A x x'. 
   558     have IH: "!!m h A x x'. 
   562                \<lbrakk>m<n; A = h ` {i. i<m}; inj_on h {i. i<m}; 
   559                \<lbrakk>m<n; A = h ` {i. i<m}; inj_on h {i. i<m}; 
   563                 (A,x) \<in> foldSet f g z; (A, x') \<in> foldSet f g z\<rbrakk> \<Longrightarrow> x' = x" .
   560                 foldSet f g z A x; foldSet f g z A x'\<rbrakk> \<Longrightarrow> x' = x" .
   564     have Afoldx: "(A,x) \<in> foldSet f g z" and Afoldx': "(A,x') \<in> foldSet f g z"
   561     have Afoldx: "foldSet f g z A x" and Afoldx': "foldSet f g z A x'"
   565      and A: "A = h`{i. i<n}" and injh: "inj_on h {i. i<n}" .
   562      and A: "A = h`{i. i<n}" and injh: "inj_on h {i. i<n}" .
   566     show ?case
   563     show ?case
   567     proof (rule foldSet.cases [OF Afoldx])
   564     proof (rule foldSet.cases [OF Afoldx])
   568       assume "(A, x) = ({}, z)"
   565       assume "A = {}" and "x = z"
   569       with Afoldx' show "x' = x" by blast
   566       with Afoldx' show "x' = x" by blast
   570     next
   567     next
   571       fix B b u
   568       fix B b u
   572       assume "(A,x) = (insert b B, g b \<cdot> u)" and notinB: "b \<notin> B"
   569       assume AbB: "A = insert b B" and x: "x = g b \<cdot> u"
   573          and Bu: "(B,u) \<in> foldSet f g z"
   570          and notinB: "b \<notin> B" and Bu: "foldSet f g z B u"
   574       hence AbB: "A = insert b B" and x: "x = g b \<cdot> u" by auto
       
   575       show "x'=x" 
   571       show "x'=x" 
   576       proof (rule foldSet.cases [OF Afoldx'])
   572       proof (rule foldSet.cases [OF Afoldx'])
   577         assume "(A, x') = ({}, z)"
   573         assume "A = {}" and "x' = z"
   578         with AbB show "x' = x" by blast
   574         with AbB show "x' = x" by blast
   579       next
   575       next
   580 	fix C c v
   576 	fix C c v
   581 	assume "(A,x') = (insert c C, g c \<cdot> v)" and notinC: "c \<notin> C"
   577 	assume AcC: "A = insert c C" and x': "x' = g c \<cdot> v"
   582 	   and Cv: "(C,v) \<in> foldSet f g z"
   578            and notinC: "c \<notin> C" and Cv: "foldSet f g z C v"
   583 	hence AcC: "A = insert c C" and x': "x' = g c \<cdot> v" by auto
       
   584 	from A AbB have Beq: "insert b B = h`{i. i<n}" by simp
   579 	from A AbB have Beq: "insert b B = h`{i. i<n}" by simp
   585         from insert_inj_onE [OF Beq notinB injh]
   580         from insert_inj_onE [OF Beq notinB injh]
   586         obtain hB mB where inj_onB: "inj_on hB {i. i < mB}" 
   581         obtain hB mB where inj_onB: "inj_on hB {i. i < mB}" 
   587                      and Beq: "B = hB ` {i. i < mB}"
   582                      and Beq: "B = hB ` {i. i < mB}"
   588                      and lessB: "mB < n" by auto 
   583                      and lessB: "mB < n" by auto 
   602 	  let ?D = "B - {c}"
   597 	  let ?D = "B - {c}"
   603 	  have B: "B = insert c ?D" and C: "C = insert b ?D"
   598 	  have B: "B = insert c ?D" and C: "C = insert b ?D"
   604 	    using AbB AcC notinB notinC diff by(blast elim!:equalityE)+
   599 	    using AbB AcC notinB notinC diff by(blast elim!:equalityE)+
   605 	  have "finite A" by(rule foldSet_imp_finite[OF Afoldx])
   600 	  have "finite A" by(rule foldSet_imp_finite[OF Afoldx])
   606 	  with AbB have "finite ?D" by simp
   601 	  with AbB have "finite ?D" by simp
   607 	  then obtain d where Dfoldd: "(?D,d) \<in> foldSet f g z"
   602 	  then obtain d where Dfoldd: "foldSet f g z ?D d"
   608 	    using finite_imp_foldSet by iprover
   603 	    using finite_imp_foldSet by iprover
   609 	  moreover have cinB: "c \<in> B" using B by auto
   604 	  moreover have cinB: "c \<in> B" using B by auto
   610 	  ultimately have "(B,g c \<cdot> d) \<in> foldSet f g z"
   605 	  ultimately have "foldSet f g z B (g c \<cdot> d)"
   611 	    by(rule Diff1_foldSet)
   606 	    by(rule Diff1_foldSet)
   612 	  hence "g c \<cdot> d = u" by (rule IH [OF lessB Beq inj_onB Bu]) 
   607 	  hence "g c \<cdot> d = u" by (rule IH [OF lessB Beq inj_onB Bu]) 
   613           moreover have "g b \<cdot> d = v"
   608           moreover have "g b \<cdot> d = v"
   614 	  proof (rule IH[OF lessC Ceq inj_onC Cv])
   609 	  proof (rule IH[OF lessC Ceq inj_onC Cv])
   615 	    show "(C, g b \<cdot> d) \<in> foldSet f g z" using C notinB Dfoldd
   610 	    show "foldSet f g z C (g b \<cdot> d)" using C notinB Dfoldd
   616 	      by fastsimp
   611 	      by fastsimp
   617 	  qed
   612 	  qed
   618 	  ultimately show ?thesis using x x' by (auto simp: AC)
   613 	  ultimately show ?thesis using x x' by (auto simp: AC)
   619 	qed
   614 	qed
   620       qed
   615       qed
   621     qed
   616     qed
   622   qed
   617   qed
   623 
   618 
   624 
   619 
   625 lemma (in ACf) foldSet_determ:
   620 lemma (in ACf) foldSet_determ:
   626   "(A,x) : foldSet f g z ==> (A,y) : foldSet f g z ==> y = x"
   621   "foldSet f g z A x ==> foldSet f g z A y ==> y = x"
   627 apply (frule foldSet_imp_finite [THEN finite_imp_nat_seg_image_inj_on]) 
   622 apply (frule foldSet_imp_finite [THEN finite_imp_nat_seg_image_inj_on]) 
   628 apply (blast intro: foldSet_determ_aux [rule_format])
   623 apply (blast intro: foldSet_determ_aux [rule_format])
   629 done
   624 done
   630 
   625 
   631 lemma (in ACf) fold_equality: "(A, y) : foldSet f g z ==> fold f g z A = y"
   626 lemma (in ACf) fold_equality: "foldSet f g z A y ==> fold f g z A = y"
   632   by (unfold fold_def) (blast intro: foldSet_determ)
   627   by (unfold fold_def) (blast intro: foldSet_determ)
   633 
   628 
   634 text{* The base case for @{text fold}: *}
   629 text{* The base case for @{text fold}: *}
   635 
   630 
   636 lemma fold_empty [simp]: "fold f g z {} = z"
   631 lemma fold_empty [simp]: "fold f g z {} = z"
   637   by (unfold fold_def) blast
   632   by (unfold fold_def) blast
   638 
   633 
   639 lemma (in ACf) fold_insert_aux: "x \<notin> A ==>
   634 lemma (in ACf) fold_insert_aux: "x \<notin> A ==>
   640     ((insert x A, v) : foldSet f g z) =
   635     (foldSet f g z (insert x A) v) =
   641     (EX y. (A, y) : foldSet f g z & v = f (g x) y)"
   636     (EX y. foldSet f g z A y & v = f (g x) y)"
   642   apply auto
   637   apply auto
   643   apply (rule_tac A1 = A and f1 = f in finite_imp_foldSet [THEN exE])
   638   apply (rule_tac A1 = A and f1 = f in finite_imp_foldSet [THEN exE])
   644    apply (fastsimp dest: foldSet_imp_finite)
   639    apply (fastsimp dest: foldSet_imp_finite)
   645   apply (blast intro: foldSet_determ)
   640   apply (blast intro: foldSet_determ)
   646   done
   641   done
   698 
   693 
   699 subsubsection{*Lemmas about @{text fold}*}
   694 subsubsection{*Lemmas about @{text fold}*}
   700 
   695 
   701 lemma (in ACf) fold_commute:
   696 lemma (in ACf) fold_commute:
   702   "finite A ==> (!!z. f x (fold f g z A) = fold f g (f x z) A)"
   697   "finite A ==> (!!z. f x (fold f g z A) = fold f g (f x z) A)"
   703   apply (induct set: Finites)
   698   apply (induct set: finite)
   704    apply simp
   699    apply simp
   705   apply (simp add: left_commute [of x])
   700   apply (simp add: left_commute [of x])
   706   done
   701   done
   707 
   702 
   708 lemma (in ACf) fold_nest_Un_Int:
   703 lemma (in ACf) fold_nest_Un_Int:
   709   "finite A ==> finite B
   704   "finite A ==> finite B
   710     ==> fold f g (fold f g z B) A = fold f g (fold f g z (A Int B)) (A Un B)"
   705     ==> fold f g (fold f g z B) A = fold f g (fold f g z (A Int B)) (A Un B)"
   711   apply (induct set: Finites)
   706   apply (induct set: finite)
   712    apply simp
   707    apply simp
   713   apply (simp add: fold_commute Int_insert_left insert_absorb)
   708   apply (simp add: fold_commute Int_insert_left insert_absorb)
   714   done
   709   done
   715 
   710 
   716 lemma (in ACf) fold_nest_Un_disjoint:
   711 lemma (in ACf) fold_nest_Un_disjoint:
   728 
   723 
   729 lemma (in ACe) fold_Un_Int:
   724 lemma (in ACe) fold_Un_Int:
   730   "finite A ==> finite B ==>
   725   "finite A ==> finite B ==>
   731     fold f g e A \<cdot> fold f g e B =
   726     fold f g e A \<cdot> fold f g e B =
   732     fold f g e (A Un B) \<cdot> fold f g e (A Int B)"
   727     fold f g e (A Un B) \<cdot> fold f g e (A Int B)"
   733   apply (induct set: Finites, simp)
   728   apply (induct set: finite, simp)
   734   apply (simp add: AC insert_absorb Int_insert_left)
   729   apply (simp add: AC insert_absorb Int_insert_left)
   735   done
   730   done
   736 
   731 
   737 corollary (in ACe) fold_Un_disjoint:
   732 corollary (in ACe) fold_Un_disjoint:
   738   "finite A ==> finite B ==> A Int B = {} ==>
   733   "finite A ==> finite B ==> A Int B = {} ==>
   742 lemma (in ACe) fold_UN_disjoint:
   737 lemma (in ACe) fold_UN_disjoint:
   743   "\<lbrakk> finite I; ALL i:I. finite (A i);
   738   "\<lbrakk> finite I; ALL i:I. finite (A i);
   744      ALL i:I. ALL j:I. i \<noteq> j --> A i Int A j = {} \<rbrakk>
   739      ALL i:I. ALL j:I. i \<noteq> j --> A i Int A j = {} \<rbrakk>
   745    \<Longrightarrow> fold f g e (UNION I A) =
   740    \<Longrightarrow> fold f g e (UNION I A) =
   746        fold f (%i. fold f g e (A i)) e I"
   741        fold f (%i. fold f g e (A i)) e I"
   747   apply (induct set: Finites, simp, atomize)
   742   apply (induct set: finite, simp, atomize)
   748   apply (subgoal_tac "ALL i:F. x \<noteq> i")
   743   apply (subgoal_tac "ALL i:F. x \<noteq> i")
   749    prefer 2 apply blast
   744    prefer 2 apply blast
   750   apply (subgoal_tac "A x Int UNION F A = {}")
   745   apply (subgoal_tac "A x Int UNION F A = {}")
   751    prefer 2 apply blast
   746    prefer 2 apply blast
   752   apply (simp add: fold_Un_disjoint)
   747   apply (simp add: fold_Un_disjoint)
   760       includes ACf g
   755       includes ACf g
   761       shows
   756       shows
   762 	"finite A ==> 
   757 	"finite A ==> 
   763 	 (!!x y. h (g x y) = f x (h y)) ==>
   758 	 (!!x y. h (g x y) = f x (h y)) ==>
   764          h (fold g j w A) = fold f j (h w) A"
   759          h (fold g j w A) = fold f j (h w) A"
   765   by (induct set: Finites) simp_all
   760   by (induct set: finite) simp_all
   766 
   761 
   767 lemma (in ACf) fold_cong:
   762 lemma (in ACf) fold_cong:
   768   "finite A \<Longrightarrow> (!!x. x:A ==> g x = h x) ==> fold f g z A = fold f h z A"
   763   "finite A \<Longrightarrow> (!!x. x:A ==> g x = h x) ==> fold f g z A = fold f h z A"
   769   apply (subgoal_tac "ALL C. C <= A --> (ALL x:C. g x = h x) --> fold f g z C = fold f h z C")
   764   apply (subgoal_tac "ALL C. C <= A --> (ALL x:C. g x = h x) --> fold f g z C = fold f h z C")
   770    apply simp
   765    apply simp
   952   apply (erule finite_induct, auto)
   947   apply (erule finite_induct, auto)
   953   done
   948   done
   954 
   949 
   955 lemma setsum_eq_0_iff [simp]:
   950 lemma setsum_eq_0_iff [simp]:
   956     "finite F ==> (setsum f F = 0) = (ALL a:F. f a = (0::nat))"
   951     "finite F ==> (setsum f F = 0) = (ALL a:F. f a = (0::nat))"
   957   by (induct set: Finites) auto
   952   by (induct set: finite) auto
   958 
   953 
   959 lemma setsum_Un_nat: "finite A ==> finite B ==>
   954 lemma setsum_Un_nat: "finite A ==> finite B ==>
   960     (setsum f (A Un B) :: nat) = setsum f A + setsum f B - setsum f (A Int B)"
   955     (setsum f (A Un B) :: nat) = setsum f A + setsum f B - setsum f (A Int B)"
   961   -- {* For the natural numbers, we have subtraction. *}
   956   -- {* For the natural numbers, we have subtraction. *}
   962   by (subst setsum_Un_Int [symmetric], auto simp add: ring_eq_simps)
   957   by (subst setsum_Un_Int [symmetric], auto simp add: ring_eq_simps)
  1062 qed
  1057 qed
  1063 
  1058 
  1064 lemma setsum_negf:
  1059 lemma setsum_negf:
  1065   "setsum (%x. - (f x)::'a::ab_group_add) A = - setsum f A"
  1060   "setsum (%x. - (f x)::'a::ab_group_add) A = - setsum f A"
  1066 proof (cases "finite A")
  1061 proof (cases "finite A")
  1067   case True thus ?thesis by (induct set: Finites) auto
  1062   case True thus ?thesis by (induct set: finite) auto
  1068 next
  1063 next
  1069   case False thus ?thesis by (simp add: setsum_def)
  1064   case False thus ?thesis by (simp add: setsum_def)
  1070 qed
  1065 qed
  1071 
  1066 
  1072 lemma setsum_subtractf:
  1067 lemma setsum_subtractf:
  1396 
  1391 
  1397 subsubsection {* Properties in more restricted classes of structures *}
  1392 subsubsection {* Properties in more restricted classes of structures *}
  1398 
  1393 
  1399 lemma setprod_eq_1_iff [simp]:
  1394 lemma setprod_eq_1_iff [simp]:
  1400     "finite F ==> (setprod f F = 1) = (ALL a:F. f a = (1::nat))"
  1395     "finite F ==> (setprod f F = 1) = (ALL a:F. f a = (1::nat))"
  1401   by (induct set: Finites) auto
  1396   by (induct set: finite) auto
  1402 
  1397 
  1403 lemma setprod_zero:
  1398 lemma setprod_zero:
  1404      "finite A ==> EX x: A. f x = (0::'a::comm_semiring_1_cancel) ==> setprod f A = 0"
  1399      "finite A ==> EX x: A. f x = (0::'a::comm_semiring_1_cancel) ==> setprod f A = 0"
  1405   apply (induct set: Finites, force, clarsimp)
  1400   apply (induct set: finite, force, clarsimp)
  1406   apply (erule disjE, auto)
  1401   apply (erule disjE, auto)
  1407   done
  1402   done
  1408 
  1403 
  1409 lemma setprod_nonneg [rule_format]:
  1404 lemma setprod_nonneg [rule_format]:
  1410      "(ALL x: A. (0::'a::ordered_idom) \<le> f x) --> 0 \<le> setprod f A"
  1405      "(ALL x: A. (0::'a::ordered_idom) \<le> f x) --> 0 \<le> setprod f A"
  1411   apply (case_tac "finite A")
  1406   apply (case_tac "finite A")
  1412   apply (induct set: Finites, force, clarsimp)
  1407   apply (induct set: finite, force, clarsimp)
  1413   apply (subgoal_tac "0 * 0 \<le> f x * setprod f F", force)
  1408   apply (subgoal_tac "0 * 0 \<le> f x * setprod f F", force)
  1414   apply (rule mult_mono, assumption+)
  1409   apply (rule mult_mono, assumption+)
  1415   apply (auto simp add: setprod_def)
  1410   apply (auto simp add: setprod_def)
  1416   done
  1411   done
  1417 
  1412 
  1418 lemma setprod_pos [rule_format]: "(ALL x: A. (0::'a::ordered_idom) < f x)
  1413 lemma setprod_pos [rule_format]: "(ALL x: A. (0::'a::ordered_idom) < f x)
  1419      --> 0 < setprod f A"
  1414      --> 0 < setprod f A"
  1420   apply (case_tac "finite A")
  1415   apply (case_tac "finite A")
  1421   apply (induct set: Finites, force, clarsimp)
  1416   apply (induct set: finite, force, clarsimp)
  1422   apply (subgoal_tac "0 * 0 < f x * setprod f F", force)
  1417   apply (subgoal_tac "0 * 0 < f x * setprod f F", force)
  1423   apply (rule mult_strict_mono, assumption+)
  1418   apply (rule mult_strict_mono, assumption+)
  1424   apply (auto simp add: setprod_def)
  1419   apply (auto simp add: setprod_def)
  1425   done
  1420   done
  1426 
  1421 
  1544 
  1539 
  1545 lemma card_mono: "\<lbrakk> finite B; A \<subseteq> B \<rbrakk> \<Longrightarrow> card A \<le> card B"
  1540 lemma card_mono: "\<lbrakk> finite B; A \<subseteq> B \<rbrakk> \<Longrightarrow> card A \<le> card B"
  1546 by (simp add: card_def setsum_mono2)
  1541 by (simp add: card_def setsum_mono2)
  1547 
  1542 
  1548 lemma card_seteq: "finite B ==> (!!A. A <= B ==> card B <= card A ==> A = B)"
  1543 lemma card_seteq: "finite B ==> (!!A. A <= B ==> card B <= card A ==> A = B)"
  1549   apply (induct set: Finites, simp, clarify)
  1544   apply (induct set: finite, simp, clarify)
  1550   apply (subgoal_tac "finite A & A - {x} <= F")
  1545   apply (subgoal_tac "finite A & A - {x} <= F")
  1551    prefer 2 apply (blast intro: finite_subset, atomize)
  1546    prefer 2 apply (blast intro: finite_subset, atomize)
  1552   apply (drule_tac x = "A - {x}" in spec)
  1547   apply (drule_tac x = "A - {x}" in spec)
  1553   apply (simp add: card_Diff_singleton_if split add: split_if_asm)
  1548   apply (simp add: card_Diff_singleton_if split add: split_if_asm)
  1554   apply (case_tac "card A", auto)
  1549   apply (case_tac "card A", auto)
  1696   apply (subst ACf.fold_insert) 
  1691   apply (subst ACf.fold_insert) 
  1697   apply (auto simp add: ACf_def) 
  1692   apply (auto simp add: ACf_def) 
  1698   done
  1693   done
  1699 
  1694 
  1700 lemma card_image_le: "finite A ==> card (f ` A) <= card A"
  1695 lemma card_image_le: "finite A ==> card (f ` A) <= card A"
  1701   apply (induct set: Finites)
  1696   apply (induct set: finite)
  1702    apply simp
  1697    apply simp
  1703   apply (simp add: le_SucI finite_imageI card_insert_if)
  1698   apply (simp add: le_SucI finite_imageI card_insert_if)
  1704   done
  1699   done
  1705 
  1700 
  1706 lemma card_image: "inj_on f A ==> card (f ` A) = card A"
  1701 lemma card_image: "inj_on f A ==> card (f ` A) = card A"
  1761 
  1756 
  1762 
  1757 
  1763 subsubsection {* Cardinality of the Powerset *}
  1758 subsubsection {* Cardinality of the Powerset *}
  1764 
  1759 
  1765 lemma card_Pow: "finite A ==> card (Pow A) = Suc (Suc 0) ^ card A"  (* FIXME numeral 2 (!?) *)
  1760 lemma card_Pow: "finite A ==> card (Pow A) = Suc (Suc 0) ^ card A"  (* FIXME numeral 2 (!?) *)
  1766   apply (induct set: Finites)
  1761   apply (induct set: finite)
  1767    apply (simp_all add: Pow_insert)
  1762    apply (simp_all add: Pow_insert)
  1768   apply (subst card_Un_disjoint, blast)
  1763   apply (subst card_Un_disjoint, blast)
  1769     apply (blast intro: finite_imageI, blast)
  1764     apply (blast intro: finite_imageI, blast)
  1770   apply (subgoal_tac "inj_on (insert x) (Pow F)")
  1765   apply (subgoal_tac "inj_on (insert x) (Pow F)")
  1771    apply (simp add: card_image Pow_insert)
  1766    apply (simp add: card_image Pow_insert)
  1781     ALL c : C. k dvd card c ==>
  1776     ALL c : C. k dvd card c ==>
  1782     (ALL c1: C. ALL c2: C. c1 \<noteq> c2 --> c1 Int c2 = {}) ==>
  1777     (ALL c1: C. ALL c2: C. c1 \<noteq> c2 --> c1 Int c2 = {}) ==>
  1783   k dvd card (Union C)"
  1778   k dvd card (Union C)"
  1784 apply(frule finite_UnionD)
  1779 apply(frule finite_UnionD)
  1785 apply(rotate_tac -1)
  1780 apply(rotate_tac -1)
  1786   apply (induct set: Finites, simp_all, clarify)
  1781   apply (induct set: finite, simp_all, clarify)
  1787   apply (subst card_Un_disjoint)
  1782   apply (subst card_Un_disjoint)
  1788   apply (auto simp add: dvd_add disjoint_eq_subset_Compl)
  1783   apply (auto simp add: dvd_add disjoint_eq_subset_Compl)
  1789   done
  1784   done
  1790 
  1785 
  1791 
  1786 
  1792 subsection{* A fold functional for non-empty sets *}
  1787 subsection{* A fold functional for non-empty sets *}
  1793 
  1788 
  1794 text{* Does not require start value. *}
  1789 text{* Does not require start value. *}
  1795 
  1790 
  1796 consts
  1791 inductive2
  1797   fold1Set :: "('a => 'a => 'a) => ('a set \<times> 'a) set"
  1792   fold1Set :: "('a => 'a => 'a) => 'a set => 'a => bool"
  1798 
  1793   for f :: "'a => 'a => 'a"
  1799 inductive "fold1Set f"
  1794 where
  1800 intros
       
  1801   fold1Set_insertI [intro]:
  1795   fold1Set_insertI [intro]:
  1802    "\<lbrakk> (A,x) \<in> foldSet f id a; a \<notin> A \<rbrakk> \<Longrightarrow> (insert a A, x) \<in> fold1Set f"
  1796    "\<lbrakk> foldSet f id a A x; a \<notin> A \<rbrakk> \<Longrightarrow> fold1Set f (insert a A) x"
  1803 
  1797 
  1804 constdefs
  1798 constdefs
  1805   fold1 :: "('a => 'a => 'a) => 'a set => 'a"
  1799   fold1 :: "('a => 'a => 'a) => 'a set => 'a"
  1806   "fold1 f A == THE x. (A, x) : fold1Set f"
  1800   "fold1 f A == THE x. fold1Set f A x"
  1807 
  1801 
  1808 lemma fold1Set_nonempty:
  1802 lemma fold1Set_nonempty:
  1809  "(A, x) : fold1Set f \<Longrightarrow> A \<noteq> {}"
  1803  "fold1Set f A x \<Longrightarrow> A \<noteq> {}"
  1810 by(erule fold1Set.cases, simp_all) 
  1804 by(erule fold1Set.cases, simp_all) 
  1811 
  1805 
  1812 
  1806 
  1813 inductive_cases empty_fold1SetE [elim!]: "({}, x) : fold1Set f"
  1807 inductive_cases2 empty_fold1SetE [elim!]: "fold1Set f {} x"
  1814 
  1808 
  1815 inductive_cases insert_fold1SetE [elim!]: "(insert a X, x) : fold1Set f"
  1809 inductive_cases2 insert_fold1SetE [elim!]: "fold1Set f (insert a X) x"
  1816 
  1810 
  1817 
  1811 
  1818 lemma fold1Set_sing [iff]: "(({a},b) : fold1Set f) = (a = b)"
  1812 lemma fold1Set_sing [iff]: "(fold1Set f {a} b) = (a = b)"
  1819   by (blast intro: foldSet.intros elim: foldSet.cases)
  1813   by (blast intro: foldSet.intros elim: foldSet.cases)
  1820 
  1814 
  1821 lemma fold1_singleton[simp]: "fold1 f {a} = a"
  1815 lemma fold1_singleton[simp]: "fold1 f {a} = a"
  1822   by (unfold fold1_def) blast
  1816   by (unfold fold1_def) blast
  1823 
  1817 
  1824 lemma finite_nonempty_imp_fold1Set:
  1818 lemma finite_nonempty_imp_fold1Set:
  1825   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> EX x. (A, x) : fold1Set f"
  1819   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> EX x. fold1Set f A x"
  1826 apply (induct A rule: finite_induct)
  1820 apply (induct A rule: finite_induct)
  1827 apply (auto dest: finite_imp_foldSet [of _ f id])  
  1821 apply (auto dest: finite_imp_foldSet [of _ f id])  
  1828 done
  1822 done
  1829 
  1823 
  1830 text{*First, some lemmas about @{term foldSet}.*}
  1824 text{*First, some lemmas about @{term foldSet}.*}
  1831 
  1825 
  1832 lemma (in ACf) foldSet_insert_swap:
  1826 lemma (in ACf) foldSet_insert_swap:
  1833 assumes fold: "(A,y) \<in> foldSet f id b"
  1827 assumes fold: "foldSet f id b A y"
  1834 shows "b \<notin> A \<Longrightarrow> (insert b A, z \<cdot> y) \<in> foldSet f id z"
  1828 shows "b \<notin> A \<Longrightarrow> foldSet f id z (insert b A) (z \<cdot> y)"
  1835 using fold
  1829 using fold
  1836 proof (induct rule: foldSet.induct)
  1830 proof (induct rule: foldSet.induct)
  1837   case emptyI thus ?case by (force simp add: fold_insert_aux commute)
  1831   case emptyI thus ?case by (force simp add: fold_insert_aux commute)
  1838 next
  1832 next
  1839   case (insertI A x y)
  1833   case (insertI x A y)
  1840     have "(insert x (insert b A), x \<cdot> (z \<cdot> y)) \<in> foldSet f (\<lambda>u. u) z"
  1834     have "foldSet f (\<lambda>u. u) z (insert x (insert b A)) (x \<cdot> (z \<cdot> y))"
  1841       using insertI by force  --{*how does @{term id} get unfolded?*}
  1835       using insertI by force  --{*how does @{term id} get unfolded?*}
  1842     thus ?case by (simp add: insert_commute AC)
  1836     thus ?case by (simp add: insert_commute AC)
  1843 qed
  1837 qed
  1844 
  1838 
  1845 lemma (in ACf) foldSet_permute_diff:
  1839 lemma (in ACf) foldSet_permute_diff:
  1846 assumes fold: "(A,x) \<in> foldSet f id b"
  1840 assumes fold: "foldSet f id b A x"
  1847 shows "!!a. \<lbrakk>a \<in> A; b \<notin> A\<rbrakk> \<Longrightarrow> (insert b (A-{a}), x) \<in> foldSet f id a"
  1841 shows "!!a. \<lbrakk>a \<in> A; b \<notin> A\<rbrakk> \<Longrightarrow> foldSet f id a (insert b (A-{a})) x"
  1848 using fold
  1842 using fold
  1849 proof (induct rule: foldSet.induct)
  1843 proof (induct rule: foldSet.induct)
  1850   case emptyI thus ?case by simp
  1844   case emptyI thus ?case by simp
  1851 next
  1845 next
  1852   case (insertI A x y)
  1846   case (insertI x A y)
  1853   have "a = x \<or> a \<in> A" using insertI by simp
  1847   have "a = x \<or> a \<in> A" using insertI by simp
  1854   thus ?case
  1848   thus ?case
  1855   proof
  1849   proof
  1856     assume "a = x"
  1850     assume "a = x"
  1857     with insertI show ?thesis
  1851     with insertI show ?thesis
  1858       by (simp add: id_def [symmetric], blast intro: foldSet_insert_swap) 
  1852       by (simp add: id_def [symmetric], blast intro: foldSet_insert_swap) 
  1859   next
  1853   next
  1860     assume ainA: "a \<in> A"
  1854     assume ainA: "a \<in> A"
  1861     hence "(insert x (insert b (A - {a})), x \<cdot> y) \<in> foldSet f id a"
  1855     hence "foldSet f id a (insert x (insert b (A - {a}))) (x \<cdot> y)"
  1862       using insertI by (force simp: id_def)
  1856       using insertI by (force simp: id_def)
  1863     moreover
  1857     moreover
  1864     have "insert x (insert b (A - {a})) = insert b (insert x A - {a})"
  1858     have "insert x (insert b (A - {a})) = insert b (insert x A - {a})"
  1865       using ainA insertI by blast
  1859       using ainA insertI by blast
  1866     ultimately show ?thesis by (simp add: id_def)
  1860     ultimately show ?thesis by (simp add: id_def)
  1873 apply (rule the_equality)
  1867 apply (rule the_equality)
  1874 apply (best intro: foldSet_determ theI dest: finite_imp_foldSet [of _ f id]) 
  1868 apply (best intro: foldSet_determ theI dest: finite_imp_foldSet [of _ f id]) 
  1875 apply (rule sym, clarify)
  1869 apply (rule sym, clarify)
  1876 apply (case_tac "Aa=A")
  1870 apply (case_tac "Aa=A")
  1877  apply (best intro: the_equality foldSet_determ)  
  1871  apply (best intro: the_equality foldSet_determ)  
  1878 apply (subgoal_tac "(A,x) \<in> foldSet f id a") 
  1872 apply (subgoal_tac "foldSet f id a A x")
  1879  apply (best intro: the_equality foldSet_determ)  
  1873  apply (best intro: the_equality foldSet_determ)  
  1880 apply (subgoal_tac "insert aa (Aa - {a}) = A") 
  1874 apply (subgoal_tac "insert aa (Aa - {a}) = A") 
  1881  prefer 2 apply (blast elim: equalityE) 
  1875  prefer 2 apply (blast elim: equalityE) 
  1882 apply (auto dest: foldSet_permute_diff [where a=a]) 
  1876 apply (auto dest: foldSet_permute_diff [where a=a]) 
  1883 done
  1877 done
  1941 subsubsection{* Determinacy for @{term fold1Set} *}
  1935 subsubsection{* Determinacy for @{term fold1Set} *}
  1942 
  1936 
  1943 text{*Not actually used!!*}
  1937 text{*Not actually used!!*}
  1944 
  1938 
  1945 lemma (in ACf) foldSet_permute:
  1939 lemma (in ACf) foldSet_permute:
  1946   "[|(insert a A, x) \<in> foldSet f id b; a \<notin> A; b \<notin> A|]
  1940   "[|foldSet f id b (insert a A) x; a \<notin> A; b \<notin> A|]
  1947    ==> (insert b A, x) \<in> foldSet f id a"
  1941    ==> foldSet f id a (insert b A) x"
  1948 apply (case_tac "a=b") 
  1942 apply (case_tac "a=b") 
  1949 apply (auto dest: foldSet_permute_diff) 
  1943 apply (auto dest: foldSet_permute_diff) 
  1950 done
  1944 done
  1951 
  1945 
  1952 lemma (in ACf) fold1Set_determ:
  1946 lemma (in ACf) fold1Set_determ:
  1953   "(A, x) \<in> fold1Set f ==> (A, y) \<in> fold1Set f ==> y = x"
  1947   "fold1Set f A x ==> fold1Set f A y ==> y = x"
  1954 proof (clarify elim!: fold1Set.cases)
  1948 proof (clarify elim!: fold1Set.cases)
  1955   fix A x B y a b
  1949   fix A x B y a b
  1956   assume Ax: "(A, x) \<in> foldSet f id a"
  1950   assume Ax: "foldSet f id a A x"
  1957   assume By: "(B, y) \<in> foldSet f id b"
  1951   assume By: "foldSet f id b B y"
  1958   assume anotA:  "a \<notin> A"
  1952   assume anotA:  "a \<notin> A"
  1959   assume bnotB:  "b \<notin> B"
  1953   assume bnotB:  "b \<notin> B"
  1960   assume eq: "insert a A = insert b B"
  1954   assume eq: "insert a A = insert b B"
  1961   show "y=x"
  1955   show "y=x"
  1962   proof cases
  1956   proof cases
  1968     let ?D = "B - {a}"
  1962     let ?D = "B - {a}"
  1969     have B: "B = insert a ?D" and A: "A = insert b ?D"
  1963     have B: "B = insert a ?D" and A: "A = insert b ?D"
  1970      and aB: "a \<in> B" and bA: "b \<in> A"
  1964      and aB: "a \<in> B" and bA: "b \<in> A"
  1971       using eq anotA bnotB diff by (blast elim!:equalityE)+
  1965       using eq anotA bnotB diff by (blast elim!:equalityE)+
  1972     with aB bnotB By
  1966     with aB bnotB By
  1973     have "(insert b ?D, y) \<in> foldSet f id a" 
  1967     have "foldSet f id a (insert b ?D) y" 
  1974       by (auto intro: foldSet_permute simp add: insert_absorb)
  1968       by (auto intro: foldSet_permute simp add: insert_absorb)
  1975     moreover
  1969     moreover
  1976     have "(insert b ?D, x) \<in> foldSet f id a"
  1970     have "foldSet f id a (insert b ?D) x"
  1977       by (simp add: A [symmetric] Ax) 
  1971       by (simp add: A [symmetric] Ax) 
  1978     ultimately show ?thesis by (blast intro: foldSet_determ) 
  1972     ultimately show ?thesis by (blast intro: foldSet_determ) 
  1979   qed
  1973   qed
  1980 qed
  1974 qed
  1981 
  1975 
  1982 lemma (in ACf) fold1Set_equality: "(A, y) : fold1Set f ==> fold1 f A = y"
  1976 lemma (in ACf) fold1Set_equality: "fold1Set f A y ==> fold1 f A = y"
  1983   by (unfold fold1_def) (blast intro: fold1Set_determ)
  1977   by (unfold fold1_def) (blast intro: fold1Set_determ)
  1984 
  1978 
  1985 declare
  1979 declare
  1986   empty_foldSetE [rule del]   foldSet.intros [rule del]
  1980   empty_foldSetE [rule del]   foldSet.intros [rule del]
  1987   empty_fold1SetE [rule del]  insert_fold1SetE [rule del]
  1981   empty_fold1SetE [rule del]  insert_fold1SetE [rule del]