src/HOL/Library/Ramsey.thy
changeset 19944 60e0cbeae3d8
child 19946 e3ddb0812840
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Library/Ramsey.thy	Fri Jun 23 09:55:01 2006 +0200
     1.3 @@ -0,0 +1,221 @@
     1.4 +(*  Title:      HOL/Library/Ramsey.thy
     1.5 +    ID:         $Id$
     1.6 +    Author:     Tom Ridge. Converted to structured Isar by L C Paulson
     1.7 +*)
     1.8 +
     1.9 +header "Ramsey's Theorem"
    1.10 +
    1.11 +theory Ramsey imports Main begin
    1.12 +
    1.13 +
    1.14 +subsection{*``Axiom'' of Dependent Choice*}
    1.15 +
    1.16 +consts choice :: "('a => bool) => (('a * 'a) set) => nat => 'a"
    1.17 +  --{*An integer-indexed chain of choices*}
    1.18 +primrec
    1.19 +  choice_0:   "choice P r 0 = (SOME x. P x)"
    1.20 +
    1.21 +  choice_Suc: "choice P r (Suc n) = (SOME y. P y & (choice P r n, y) \<in> r)"
    1.22 +
    1.23 +
    1.24 +lemma choice_n: 
    1.25 +  assumes P0: "P x0"
    1.26 +      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
    1.27 +  shows "P (choice P r n)"
    1.28 + proof (induct n)
    1.29 +   case 0 show ?case by (force intro: someI P0) 
    1.30 + next
    1.31 +   case (Suc n) thus ?case by (auto intro: someI2_ex [OF Pstep]) 
    1.32 + qed
    1.33 +
    1.34 +lemma dependent_choice: 
    1.35 +  assumes trans: "trans r"
    1.36 +      and P0: "P x0"
    1.37 +      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
    1.38 +  shows "\<exists>f::nat=>'a. (\<forall>n. P (f n)) & (\<forall>n m. n<m --> (f n, f m) \<in> r)"
    1.39 +proof (intro exI conjI)
    1.40 +  show "\<forall>n. P (choice P r n)" by (blast intro: choice_n [OF P0 Pstep]) 
    1.41 +next
    1.42 +  have PSuc: "\<forall>n. (choice P r n, choice P r (Suc n)) \<in> r" 
    1.43 +    using Pstep [OF choice_n [OF P0 Pstep]]
    1.44 +    by (auto intro: someI2_ex)
    1.45 +  show "\<forall>n m. n<m --> (choice P r n, choice P r m) \<in> r"
    1.46 +  proof (intro strip)
    1.47 +    fix n and m::nat
    1.48 +    assume less: "n<m"
    1.49 +    show "(choice P r n, choice P r m) \<in> r" using PSuc
    1.50 +      by (auto intro: less_Suc_induct [OF less] transD [OF trans])
    1.51 +  qed
    1.52 +qed 
    1.53 +
    1.54 +
    1.55 +subsection {*Partitions of a Set*}
    1.56 +
    1.57 +constdefs part :: "nat => nat => 'a set => ('a set => nat) => bool"
    1.58 +  --{*the function @{term f} partitions the @{term r}-subsets of the typically
    1.59 +       infinite set @{term Y} into @{term s} distinct categories.*}
    1.60 +  "part r s Y f == \<forall>X. X \<subseteq> Y & finite X & card X = r --> f X < s"
    1.61 +
    1.62 +text{*For induction, we decrease the value of @{term r} in partitions.*}
    1.63 +lemma part_Suc_imp_part:
    1.64 +     "[| infinite Y; part (Suc r) s Y f; y \<in> Y |] 
    1.65 +      ==> part r s (Y - {y}) (%u. f (insert y u))"
    1.66 +  apply(simp add: part_def, clarify)
    1.67 +  apply(drule_tac x="insert y X" in spec)
    1.68 +  apply(force simp:card_Diff_singleton_if)
    1.69 +  done
    1.70 +
    1.71 +lemma part_subset: "part r s YY f ==> Y \<subseteq> YY ==> part r s Y f" 
    1.72 +  by (simp add: part_def, blast)
    1.73 +  
    1.74 +
    1.75 +subsection {*Ramsey's Theorem: Infinitary Version*}
    1.76 +
    1.77 +lemma ramsey_induction: 
    1.78 +  fixes s::nat and r::nat
    1.79 +  shows
    1.80 +  "!!(YY::'a set) (f::'a set => nat). 
    1.81 +      [|infinite YY; part r s YY f|]
    1.82 +      ==> \<exists>Y' t'. Y' \<subseteq> YY & infinite Y' & t' < s & 
    1.83 +                  (\<forall>X. X \<subseteq> Y' & finite X & card X = r --> f X = t')"
    1.84 +proof (induct r)
    1.85 +  case 0
    1.86 +  thus ?case by (auto simp add: part_def card_eq_0_iff cong: conj_cong) 
    1.87 +next
    1.88 +  case (Suc r) 
    1.89 +  show ?case
    1.90 +  proof -
    1.91 +    from Suc.prems infinite_imp_nonempty obtain yy where yy: "yy \<in> YY" by blast
    1.92 +    let ?ramr = "{((y,Y,t),(y',Y',t')). y' \<in> Y & Y' \<subseteq> Y}"
    1.93 +    let ?propr = "%(y,Y,t).     
    1.94 +		 y \<in> YY & y \<notin> Y & Y \<subseteq> YY & infinite Y & t < s
    1.95 +		 & (\<forall>X. X\<subseteq>Y & finite X & card X = r --> (f o insert y) X = t)"
    1.96 +    have infYY': "infinite (YY-{yy})" using Suc.prems by auto
    1.97 +    have partf': "part r s (YY - {yy}) (f \<circ> insert yy)"
    1.98 +      by (simp add: o_def part_Suc_imp_part yy Suc.prems)
    1.99 +    have transr: "trans ?ramr" by (force simp add: trans_def) 
   1.100 +    from Suc.hyps [OF infYY' partf']
   1.101 +    obtain Y0 and t0
   1.102 +    where "Y0 \<subseteq> YY - {yy}"  "infinite Y0"  "t0 < s"
   1.103 +          "\<forall>X. X\<subseteq>Y0 \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yy) X = t0"
   1.104 +        by blast 
   1.105 +    with yy have propr0: "?propr(yy,Y0,t0)" by blast
   1.106 +    have proprstep: "\<And>x. ?propr x \<Longrightarrow> \<exists>y. ?propr y \<and> (x, y) \<in> ?ramr" 
   1.107 +    proof -
   1.108 +      fix x
   1.109 +      assume px: "?propr x" thus "?thesis x"
   1.110 +      proof (cases x)
   1.111 +        case (fields yx Yx tx)
   1.112 +        then obtain yx' where yx': "yx' \<in> Yx" using px
   1.113 +               by (blast dest: infinite_imp_nonempty)
   1.114 +        have infYx': "infinite (Yx-{yx'})" using fields px by auto
   1.115 +        with fields px yx' Suc.prems
   1.116 +        have partfx': "part r s (Yx - {yx'}) (f \<circ> insert yx')"
   1.117 +          by (simp add: o_def part_Suc_imp_part part_subset [where ?YY=YY]) 
   1.118 +	from Suc.hyps [OF infYx' partfx']
   1.119 +	obtain Y' and t'
   1.120 +	where Y': "Y' \<subseteq> Yx - {yx'}"  "infinite Y'"  "t' < s"
   1.121 +	       "\<forall>X. X\<subseteq>Y' \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yx') X = t'"
   1.122 +	    by blast 
   1.123 +	show ?thesis
   1.124 +	proof
   1.125 +	  show "?propr (yx',Y',t') & (x, (yx',Y',t')) \<in> ?ramr"
   1.126 +  	    using fields Y' yx' px by blast
   1.127 +	qed
   1.128 +      qed
   1.129 +    qed
   1.130 +    from dependent_choice [OF transr propr0 proprstep]
   1.131 +    obtain g where "(\<forall>n::nat. ?propr(g n)) & (\<forall>n m. n<m -->(g n, g m) \<in> ?ramr)"
   1.132 +      .. --{*for some reason, can't derive the following directly from dc*}
   1.133 +    hence pg: "!!n.  ?propr (g n)"
   1.134 +      and rg: "!!n m. n<m ==> (g n, g m) \<in> ?ramr" by auto
   1.135 +    let ?gy = "(\<lambda>n. let (y,Y,t) = g n in y)"
   1.136 +    let ?gt = "(\<lambda>n. let (y,Y,t) = g n in t)"
   1.137 +    have rangeg: "\<exists>k. range ?gt \<subseteq> {..<k}"
   1.138 +    proof (intro exI subsetI)
   1.139 +      fix x
   1.140 +      assume "x \<in> range ?gt"
   1.141 +      then obtain n where "x = ?gt n" ..
   1.142 +      with pg [of n] show "x \<in> {..<s}" by (cases "g n") auto
   1.143 +    qed
   1.144 +    have "\<exists>s' \<in> range ?gt. infinite (?gt -` {s'})" 
   1.145 +     by (rule inf_img_fin_dom [OF _ nat_infinite]) 
   1.146 +        (simp add: finite_nat_iff_bounded rangeg)
   1.147 +    then obtain s' and n'
   1.148 +            where s':      "s' = ?gt n'"
   1.149 +              and infeqs': "infinite {n. ?gt n = s'}"
   1.150 +       by (auto simp add: vimage_def)
   1.151 +    with pg [of n'] have less': "s'<s" by (cases "g n'") auto
   1.152 +    have inj_gy: "inj ?gy"
   1.153 +    proof (rule linorder_injI)
   1.154 +      fix m and m'::nat assume less: "m < m'" show "?gy m \<noteq> ?gy m'"
   1.155 +        using rg [OF less] pg [of m] by (cases "g m", cases "g m'", auto) 
   1.156 +    qed
   1.157 +    show ?thesis
   1.158 +    proof (intro exI conjI)
   1.159 +      show "?gy ` {n. ?gt n = s'} \<subseteq> YY" using pg
   1.160 +        by (auto simp add: Let_def split_beta) 
   1.161 +    next
   1.162 +      show "infinite (?gy ` {n. ?gt n = s'})" using infeqs'
   1.163 +        by (blast intro: inj_gy [THEN subset_inj_on] dest: finite_imageD) 
   1.164 +    next
   1.165 +      show "s' < s" by (rule less')
   1.166 +    next
   1.167 +      show "\<forall>X. X \<subseteq> ?gy ` {n. ?gt n = s'} & finite X & card X = Suc r 
   1.168 +          --> f X = s'"
   1.169 +      proof -
   1.170 +        {fix X 
   1.171 +         assume "X \<subseteq> ?gy ` {n. ?gt n = s'}"
   1.172 +            and cardX: "finite X" "card X = Suc r"
   1.173 +         then obtain AA where AA: "AA \<subseteq> {n. ?gt n = s'}" and Xeq: "X = ?gy`AA" 
   1.174 +             by (auto simp add: subset_image_iff) 
   1.175 +         with cardX have "AA\<noteq>{}" by auto
   1.176 +         hence AAleast: "(LEAST x. x \<in> AA) \<in> AA" by (auto intro: LeastI_ex) 
   1.177 +         have "f X = s'"
   1.178 +         proof (cases "g (LEAST x. x \<in> AA)") 
   1.179 +           case (fields ya Ya ta)
   1.180 +           with AAleast Xeq 
   1.181 +           have ya: "ya \<in> X" by (force intro!: rev_image_eqI) 
   1.182 +           hence "f X = f (insert ya (X - {ya}))" by (simp add: insert_absorb)
   1.183 +           also have "... = ta" 
   1.184 +           proof -
   1.185 +             have "X - {ya} \<subseteq> Ya"
   1.186 +             proof 
   1.187 +               fix x
   1.188 +               assume x: "x \<in> X - {ya}"
   1.189 +               then obtain a' where xeq: "x = ?gy a'" and a': "a' \<in> AA" 
   1.190 +                 by (auto simp add: Xeq) 
   1.191 +               hence "a' \<noteq> (LEAST x. x \<in> AA)" using x fields by auto
   1.192 +               hence lessa': "(LEAST x. x \<in> AA) < a'"
   1.193 +                 using Least_le [of "%x. x \<in> AA", OF a'] by arith
   1.194 +               show "x \<in> Ya" using xeq fields rg [OF lessa'] by auto
   1.195 +             qed
   1.196 +             moreover
   1.197 +             have "card (X - {ya}) = r"
   1.198 +               by (simp add: card_Diff_singleton_if cardX ya)
   1.199 +             ultimately show ?thesis 
   1.200 +               using pg [of "LEAST x. x \<in> AA"] fields cardX
   1.201 +               by (clarify, drule_tac x="X-{ya}" in spec, simp)
   1.202 +           qed
   1.203 +           also have "... = s'" using AA AAleast fields by auto
   1.204 +           finally show ?thesis .
   1.205 +         qed}
   1.206 +        thus ?thesis by blast
   1.207 +      qed 
   1.208 +    qed 
   1.209 +  qed
   1.210 +qed
   1.211 +
   1.212 +
   1.213 +text{*Repackaging of Tom Ridge's final result*}
   1.214 +theorem Ramsey:
   1.215 +  fixes s::nat and r::nat and Z::"'a set" and f::"'a set => nat"
   1.216 +  shows
   1.217 +   "[|infinite Z;
   1.218 +      \<forall>X. X \<subseteq> Z & finite X & card X = r --> f X < s|]
   1.219 +  ==> \<exists>Y t. Y \<subseteq> Z & infinite Y & t < s 
   1.220 +            & (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X = t)"
   1.221 +by (blast intro: ramsey_induction [unfolded part_def, rule_format]) 
   1.222 +
   1.223 +end
   1.224 +