19944

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 integerindexed 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

19946

28 
case Suc thus ?case by (auto intro: someI2_ex [OF Pstep])

19944

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]

19946

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

19944

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

19946

196 
by (clarsimp simp del:insert_Diff_single)

19944

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)"

19946

216 
by (blast intro: ramsey_induction [unfolded part_def])

19944

217 


218 
end


219 
