src/HOL/Library/Ramsey.thy
author wenzelm
Sat Jun 24 22:25:31 2006 +0200 (2006-06-24)
changeset 19948 1be283f3f1ba
parent 19946 e3ddb0812840
child 19949 0505dce27b0b
permissions -rwxr-xr-x
minor tuning of definitions/proofs;
     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 definition
    55   part :: "nat => nat => 'a set => ('a set => nat) => bool"
    56   --{*the function @{term f} partitions the @{term r}-subsets of the typically
    57        infinite set @{term Y} into @{term s} distinct categories.*}
    58   "part r s Y f = (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X < s)"
    59 
    60 text{*For induction, we decrease the value of @{term r} in partitions.*}
    61 lemma part_Suc_imp_part:
    62      "[| infinite Y; part (Suc r) s Y f; y \<in> Y |] 
    63       ==> part r s (Y - {y}) (%u. f (insert y u))"
    64   apply(simp add: part_def, clarify)
    65   apply(drule_tac x="insert y X" in spec)
    66   apply(force simp:card_Diff_singleton_if)
    67   done
    68 
    69 lemma part_subset: "part r s YY f ==> Y \<subseteq> YY ==> part r s Y f" 
    70   unfolding part_def by blast
    71   
    72 
    73 subsection {*Ramsey's Theorem: Infinitary Version*}
    74 
    75 lemma ramsey_induction: 
    76   fixes s::nat and r::nat
    77   shows
    78   "!!(YY::'a set) (f::'a set => nat). 
    79       [|infinite YY; part r s YY f|]
    80       ==> \<exists>Y' t'. Y' \<subseteq> YY & infinite Y' & t' < s & 
    81                   (\<forall>X. X \<subseteq> Y' & finite X & card X = r --> f X = t')"
    82 proof (induct r)
    83   case 0
    84   thus ?case by (auto simp add: part_def card_eq_0_iff cong: conj_cong) 
    85 next
    86   case (Suc r) 
    87   show ?case
    88   proof -
    89     from Suc.prems infinite_imp_nonempty obtain yy where yy: "yy \<in> YY" by blast
    90     let ?ramr = "{((y,Y,t),(y',Y',t')). y' \<in> Y & Y' \<subseteq> Y}"
    91     let ?propr = "%(y,Y,t).     
    92 		 y \<in> YY & y \<notin> Y & Y \<subseteq> YY & infinite Y & t < s
    93 		 & (\<forall>X. X\<subseteq>Y & finite X & card X = r --> (f o insert y) X = t)"
    94     have infYY': "infinite (YY-{yy})" using Suc.prems by auto
    95     have partf': "part r s (YY - {yy}) (f \<circ> insert yy)"
    96       by (simp add: o_def part_Suc_imp_part yy Suc.prems)
    97     have transr: "trans ?ramr" by (force simp add: trans_def) 
    98     from Suc.hyps [OF infYY' partf']
    99     obtain Y0 and t0
   100     where "Y0 \<subseteq> YY - {yy}"  "infinite Y0"  "t0 < s"
   101           "\<forall>X. X\<subseteq>Y0 \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yy) X = t0"
   102         by blast 
   103     with yy have propr0: "?propr(yy,Y0,t0)" by blast
   104     have proprstep: "\<And>x. ?propr x \<Longrightarrow> \<exists>y. ?propr y \<and> (x, y) \<in> ?ramr" 
   105     proof -
   106       fix x
   107       assume px: "?propr x" thus "?thesis x"
   108       proof (cases x)
   109         case (fields yx Yx tx)
   110         then obtain yx' where yx': "yx' \<in> Yx" using px
   111                by (blast dest: infinite_imp_nonempty)
   112         have infYx': "infinite (Yx-{yx'})" using fields px by auto
   113         with fields px yx' Suc.prems
   114         have partfx': "part r s (Yx - {yx'}) (f \<circ> insert yx')"
   115           by (simp add: o_def part_Suc_imp_part part_subset [where ?YY=YY]) 
   116 	from Suc.hyps [OF infYx' partfx']
   117 	obtain Y' and t'
   118 	where Y': "Y' \<subseteq> Yx - {yx'}"  "infinite Y'"  "t' < s"
   119 	       "\<forall>X. X\<subseteq>Y' \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yx') X = t'"
   120 	    by blast 
   121 	show ?thesis
   122 	proof
   123 	  show "?propr (yx',Y',t') & (x, (yx',Y',t')) \<in> ?ramr"
   124   	    using fields Y' yx' px by blast
   125 	qed
   126       qed
   127     qed
   128     from dependent_choice [OF transr propr0 proprstep]
   129     obtain g where pg: "!!n::nat.  ?propr (g n)"
   130       and rg: "!!n m. n<m ==> (g n, g m) \<in> ?ramr" by force
   131     let ?gy = "(\<lambda>n. let (y,Y,t) = g n in y)"
   132     let ?gt = "(\<lambda>n. let (y,Y,t) = g n in t)"
   133     have rangeg: "\<exists>k. range ?gt \<subseteq> {..<k}"
   134     proof (intro exI subsetI)
   135       fix x
   136       assume "x \<in> range ?gt"
   137       then obtain n where "x = ?gt n" ..
   138       with pg [of n] show "x \<in> {..<s}" by (cases "g n") auto
   139     qed
   140     have "\<exists>s' \<in> range ?gt. infinite (?gt -` {s'})" 
   141      by (rule inf_img_fin_dom [OF _ nat_infinite]) 
   142         (simp add: finite_nat_iff_bounded rangeg)
   143     then obtain s' and n'
   144             where s':      "s' = ?gt n'"
   145               and infeqs': "infinite {n. ?gt n = s'}"
   146        by (auto simp add: vimage_def)
   147     with pg [of n'] have less': "s'<s" by (cases "g n'") auto
   148     have inj_gy: "inj ?gy"
   149     proof (rule linorder_injI)
   150       fix m and m'::nat assume less: "m < m'" show "?gy m \<noteq> ?gy m'"
   151         using rg [OF less] pg [of m] by (cases "g m", cases "g m'") auto
   152     qed
   153     show ?thesis
   154     proof (intro exI conjI)
   155       show "?gy ` {n. ?gt n = s'} \<subseteq> YY" using pg
   156         by (auto simp add: Let_def split_beta) 
   157       show "infinite (?gy ` {n. ?gt n = s'})" using infeqs'
   158         by (blast intro: inj_gy [THEN subset_inj_on] dest: finite_imageD) 
   159       show "s' < s" by (rule less')
   160       show "\<forall>X. X \<subseteq> ?gy ` {n. ?gt n = s'} & finite X & card X = Suc r 
   161           --> f X = s'"
   162       proof -
   163         {fix X 
   164          assume "X \<subseteq> ?gy ` {n. ?gt n = s'}"
   165             and cardX: "finite X" "card X = Suc r"
   166          then obtain AA where AA: "AA \<subseteq> {n. ?gt n = s'}" and Xeq: "X = ?gy`AA" 
   167              by (auto simp add: subset_image_iff) 
   168          with cardX have "AA\<noteq>{}" by auto
   169          hence AAleast: "(LEAST x. x \<in> AA) \<in> AA" by (auto intro: LeastI_ex) 
   170          have "f X = s'"
   171          proof (cases "g (LEAST x. x \<in> AA)") 
   172            case (fields ya Ya ta)
   173            with AAleast Xeq 
   174            have ya: "ya \<in> X" by (force intro!: rev_image_eqI) 
   175            hence "f X = f (insert ya (X - {ya}))" by (simp add: insert_absorb)
   176            also have "... = ta" 
   177            proof -
   178              have "X - {ya} \<subseteq> Ya"
   179              proof 
   180                fix x
   181                assume x: "x \<in> X - {ya}"
   182                then obtain a' where xeq: "x = ?gy a'" and a': "a' \<in> AA" 
   183                  by (auto simp add: Xeq) 
   184                hence "a' \<noteq> (LEAST x. x \<in> AA)" using x fields by auto
   185                hence lessa': "(LEAST x. x \<in> AA) < a'"
   186                  using Least_le [of "%x. x \<in> AA", OF a'] by arith
   187                show "x \<in> Ya" using xeq fields rg [OF lessa'] by auto
   188              qed
   189              moreover
   190              have "card (X - {ya}) = r"
   191                by (simp add: card_Diff_singleton_if cardX ya)
   192              ultimately show ?thesis 
   193                using pg [of "LEAST x. x \<in> AA"] fields cardX
   194 	       by (clarsimp simp del:insert_Diff_single)
   195            qed
   196            also have "... = s'" using AA AAleast fields by auto
   197            finally show ?thesis .
   198          qed}
   199         thus ?thesis by blast
   200       qed 
   201     qed 
   202   qed
   203 qed
   204 
   205 
   206 text{*Repackaging of Tom Ridge's final result*}
   207 theorem Ramsey:
   208   fixes s::nat and r::nat and Z::"'a set" and f::"'a set => nat"
   209   shows
   210    "[|infinite Z;
   211       \<forall>X. X \<subseteq> Z & finite X & card X = r --> f X < s|]
   212   ==> \<exists>Y t. Y \<subseteq> Z & infinite Y & t < s 
   213             & (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X = t)"
   214 by (blast intro: ramsey_induction [unfolded part_def]) 
   215 
   216 end