src/HOL/Library/Ramsey.thy
 author nipkow Fri Jun 23 13:42:19 2006 +0200 (2006-06-23) changeset 19946 e3ddb0812840 parent 19944 60e0cbeae3d8 child 19948 1be283f3f1ba permissions -rwxr-xr-x
beautification
```     1 (*  Title:      HOL/Library/Ramsey.thy
```
```     2     ID:         \$Id\$
```
```     3     Author:     Tom Ridge. Converted to structured Isar by L C Paulson
```
```     4 *)
```
```     5
```
```     6 header "Ramsey's Theorem"
```
```     7
```
```     8 theory Ramsey imports Main begin
```
```     9
```
```    10
```
```    11 subsection{*``Axiom'' of Dependent Choice*}
```
```    12
```
```    13 consts choice :: "('a => bool) => (('a * 'a) set) => nat => 'a"
```
```    14   --{*An integer-indexed chain of choices*}
```
```    15 primrec
```
```    16   choice_0:   "choice P r 0 = (SOME x. P x)"
```
```    17
```
```    18   choice_Suc: "choice P r (Suc n) = (SOME y. P y & (choice P r n, y) \<in> r)"
```
```    19
```
```    20
```
```    21 lemma choice_n:
```
```    22   assumes P0: "P x0"
```
```    23       and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
```
```    24   shows "P (choice P r n)"
```
```    25  proof (induct n)
```
```    26    case 0 show ?case by (force intro: someI P0)
```
```    27  next
```
```    28    case Suc thus ?case by (auto intro: someI2_ex [OF Pstep])
```
```    29  qed
```
```    30
```
```    31 lemma dependent_choice:
```
```    32   assumes trans: "trans r"
```
```    33       and P0: "P x0"
```
```    34       and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
```
```    35   shows "\<exists>f::nat=>'a. (\<forall>n. P (f n)) & (\<forall>n m. n<m --> (f n, f m) \<in> r)"
```
```    36 proof (intro exI conjI)
```
```    37   show "\<forall>n. P (choice P r n)" by (blast intro: choice_n [OF P0 Pstep])
```
```    38 next
```
```    39   have PSuc: "\<forall>n. (choice P r n, choice P r (Suc n)) \<in> r"
```
```    40     using Pstep [OF choice_n [OF P0 Pstep]]
```
```    41     by (auto intro: someI2_ex)
```
```    42   show "\<forall>n m. n<m --> (choice P r n, choice P r m) \<in> r"
```
```    43   proof (intro strip)
```
```    44     fix n and m::nat
```
```    45     assume less: "n<m"
```
```    46     show "(choice P r n, choice P r m) \<in> r" using PSuc
```
```    47       by (auto intro: less_Suc_induct [OF less] transD [OF trans])
```
```    48   qed
```
```    49 qed
```
```    50
```
```    51
```
```    52 subsection {*Partitions of a Set*}
```
```    53
```
```    54 constdefs part :: "nat => nat => 'a set => ('a set => nat) => bool"
```
```    55   --{*the function @{term f} partitions the @{term r}-subsets of the typically
```
```    56        infinite set @{term Y} into @{term s} distinct categories.*}
```
```    57   "part r s Y f == \<forall>X. X \<subseteq> Y & finite X & card X = r --> f X < s"
```
```    58
```
```    59 text{*For induction, we decrease the value of @{term r} in partitions.*}
```
```    60 lemma part_Suc_imp_part:
```
```    61      "[| infinite Y; part (Suc r) s Y f; y \<in> Y |]
```
```    62       ==> part r s (Y - {y}) (%u. f (insert y u))"
```
```    63   apply(simp add: part_def, clarify)
```
```    64   apply(drule_tac x="insert y X" in spec)
```
```    65   apply(force simp:card_Diff_singleton_if)
```
```    66   done
```
```    67
```
```    68 lemma part_subset: "part r s YY f ==> Y \<subseteq> YY ==> part r s Y f"
```
```    69   by (simp add: part_def, blast)
```
```    70
```
```    71
```
```    72 subsection {*Ramsey's Theorem: Infinitary Version*}
```
```    73
```
```    74 lemma ramsey_induction:
```
```    75   fixes s::nat and r::nat
```
```    76   shows
```
```    77   "!!(YY::'a set) (f::'a set => nat).
```
```    78       [|infinite YY; part r s YY f|]
```
```    79       ==> \<exists>Y' t'. Y' \<subseteq> YY & infinite Y' & t' < s &
```
```    80                   (\<forall>X. X \<subseteq> Y' & finite X & card X = r --> f X = t')"
```
```    81 proof (induct r)
```
```    82   case 0
```
```    83   thus ?case by (auto simp add: part_def card_eq_0_iff cong: conj_cong)
```
```    84 next
```
```    85   case (Suc r)
```
```    86   show ?case
```
```    87   proof -
```
```    88     from Suc.prems infinite_imp_nonempty obtain yy where yy: "yy \<in> YY" by blast
```
```    89     let ?ramr = "{((y,Y,t),(y',Y',t')). y' \<in> Y & Y' \<subseteq> Y}"
```
```    90     let ?propr = "%(y,Y,t).
```
```    91 		 y \<in> YY & y \<notin> Y & Y \<subseteq> YY & infinite Y & t < s
```
```    92 		 & (\<forall>X. X\<subseteq>Y & finite X & card X = r --> (f o insert y) X = t)"
```
```    93     have infYY': "infinite (YY-{yy})" using Suc.prems by auto
```
```    94     have partf': "part r s (YY - {yy}) (f \<circ> insert yy)"
```
```    95       by (simp add: o_def part_Suc_imp_part yy Suc.prems)
```
```    96     have transr: "trans ?ramr" by (force simp add: trans_def)
```
```    97     from Suc.hyps [OF infYY' partf']
```
```    98     obtain Y0 and t0
```
```    99     where "Y0 \<subseteq> YY - {yy}"  "infinite Y0"  "t0 < s"
```
```   100           "\<forall>X. X\<subseteq>Y0 \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yy) X = t0"
```
```   101         by blast
```
```   102     with yy have propr0: "?propr(yy,Y0,t0)" by blast
```
```   103     have proprstep: "\<And>x. ?propr x \<Longrightarrow> \<exists>y. ?propr y \<and> (x, y) \<in> ?ramr"
```
```   104     proof -
```
```   105       fix x
```
```   106       assume px: "?propr x" thus "?thesis x"
```
```   107       proof (cases x)
```
```   108         case (fields yx Yx tx)
```
```   109         then obtain yx' where yx': "yx' \<in> Yx" using px
```
```   110                by (blast dest: infinite_imp_nonempty)
```
```   111         have infYx': "infinite (Yx-{yx'})" using fields px by auto
```
```   112         with fields px yx' Suc.prems
```
```   113         have partfx': "part r s (Yx - {yx'}) (f \<circ> insert yx')"
```
```   114           by (simp add: o_def part_Suc_imp_part part_subset [where ?YY=YY])
```
```   115 	from Suc.hyps [OF infYx' partfx']
```
```   116 	obtain Y' and t'
```
```   117 	where Y': "Y' \<subseteq> Yx - {yx'}"  "infinite Y'"  "t' < s"
```
```   118 	       "\<forall>X. X\<subseteq>Y' \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yx') X = t'"
```
```   119 	    by blast
```
```   120 	show ?thesis
```
```   121 	proof
```
```   122 	  show "?propr (yx',Y',t') & (x, (yx',Y',t')) \<in> ?ramr"
```
```   123   	    using fields Y' yx' px by blast
```
```   124 	qed
```
```   125       qed
```
```   126     qed
```
```   127     from dependent_choice [OF transr propr0 proprstep]
```
```   128     obtain g where pg: "!!n::nat.  ?propr (g n)"
```
```   129       and rg: "!!n m. n<m ==> (g n, g m) \<in> ?ramr" by force
```
```   130     let ?gy = "(\<lambda>n. let (y,Y,t) = g n in y)"
```
```   131     let ?gt = "(\<lambda>n. let (y,Y,t) = g n in t)"
```
```   132     have rangeg: "\<exists>k. range ?gt \<subseteq> {..<k}"
```
```   133     proof (intro exI subsetI)
```
```   134       fix x
```
```   135       assume "x \<in> range ?gt"
```
```   136       then obtain n where "x = ?gt n" ..
```
```   137       with pg [of n] show "x \<in> {..<s}" by (cases "g n") auto
```
```   138     qed
```
```   139     have "\<exists>s' \<in> range ?gt. infinite (?gt -` {s'})"
```
```   140      by (rule inf_img_fin_dom [OF _ nat_infinite])
```
```   141         (simp add: finite_nat_iff_bounded rangeg)
```
```   142     then obtain s' and n'
```
```   143             where s':      "s' = ?gt n'"
```
```   144               and infeqs': "infinite {n. ?gt n = s'}"
```
```   145        by (auto simp add: vimage_def)
```
```   146     with pg [of n'] have less': "s'<s" by (cases "g n'") auto
```
```   147     have inj_gy: "inj ?gy"
```
```   148     proof (rule linorder_injI)
```
```   149       fix m and m'::nat assume less: "m < m'" show "?gy m \<noteq> ?gy m'"
```
```   150         using rg [OF less] pg [of m] by (cases "g m", cases "g m'", auto)
```
```   151     qed
```
```   152     show ?thesis
```
```   153     proof (intro exI conjI)
```
```   154       show "?gy ` {n. ?gt n = s'} \<subseteq> YY" using pg
```
```   155         by (auto simp add: Let_def split_beta)
```
```   156     next
```
```   157       show "infinite (?gy ` {n. ?gt n = s'})" using infeqs'
```
```   158         by (blast intro: inj_gy [THEN subset_inj_on] dest: finite_imageD)
```
```   159     next
```
```   160       show "s' < s" by (rule less')
```
```   161     next
```
```   162       show "\<forall>X. X \<subseteq> ?gy ` {n. ?gt n = s'} & finite X & card X = Suc r
```
```   163           --> f X = s'"
```
```   164       proof -
```
```   165         {fix X
```
```   166          assume "X \<subseteq> ?gy ` {n. ?gt n = s'}"
```
```   167             and cardX: "finite X" "card X = Suc r"
```
```   168          then obtain AA where AA: "AA \<subseteq> {n. ?gt n = s'}" and Xeq: "X = ?gy`AA"
```
```   169              by (auto simp add: subset_image_iff)
```
```   170          with cardX have "AA\<noteq>{}" by auto
```
```   171          hence AAleast: "(LEAST x. x \<in> AA) \<in> AA" by (auto intro: LeastI_ex)
```
```   172          have "f X = s'"
```
```   173          proof (cases "g (LEAST x. x \<in> AA)")
```
```   174            case (fields ya Ya ta)
```
```   175            with AAleast Xeq
```
```   176            have ya: "ya \<in> X" by (force intro!: rev_image_eqI)
```
```   177            hence "f X = f (insert ya (X - {ya}))" by (simp add: insert_absorb)
```
```   178            also have "... = ta"
```
```   179            proof -
```
```   180              have "X - {ya} \<subseteq> Ya"
```
```   181              proof
```
```   182                fix x
```
```   183                assume x: "x \<in> X - {ya}"
```
```   184                then obtain a' where xeq: "x = ?gy a'" and a': "a' \<in> AA"
```
```   185                  by (auto simp add: Xeq)
```
```   186                hence "a' \<noteq> (LEAST x. x \<in> AA)" using x fields by auto
```
```   187                hence lessa': "(LEAST x. x \<in> AA) < a'"
```
```   188                  using Least_le [of "%x. x \<in> AA", OF a'] by arith
```
```   189                show "x \<in> Ya" using xeq fields rg [OF lessa'] by auto
```
```   190              qed
```
```   191              moreover
```
```   192              have "card (X - {ya}) = r"
```
```   193                by (simp add: card_Diff_singleton_if cardX ya)
```
```   194              ultimately show ?thesis
```
```   195                using pg [of "LEAST x. x \<in> AA"] fields cardX
```
```   196 	       by (clarsimp simp del:insert_Diff_single)
```
```   197            qed
```
```   198            also have "... = s'" using AA AAleast fields by auto
```
```   199            finally show ?thesis .
```
```   200          qed}
```
```   201         thus ?thesis by blast
```
```   202       qed
```
```   203     qed
```
```   204   qed
```
```   205 qed
```
```   206
```
```   207
```
```   208 text{*Repackaging of Tom Ridge's final result*}
```
```   209 theorem Ramsey:
```
```   210   fixes s::nat and r::nat and Z::"'a set" and f::"'a set => nat"
```
```   211   shows
```
```   212    "[|infinite Z;
```
```   213       \<forall>X. X \<subseteq> Z & finite X & card X = r --> f X < s|]
```
```   214   ==> \<exists>Y t. Y \<subseteq> Z & infinite Y & t < s
```
```   215             & (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X = t)"
```
```   216 by (blast intro: ramsey_induction [unfolded part_def])
```
```   217
```
```   218 end
```
```   219
```