src/HOL/Library/Ramsey.thy
author wenzelm
Thu Feb 11 23:00:22 2010 +0100 (2010-02-11)
changeset 35115 446c5063e4fd
parent 34941 156925dd67af
child 35175 61255c81da01
permissions -rw-r--r--
modernized translations;
formal markup of @{syntax_const} and @{const_syntax};
minor tuning;
paulson@19944
     1
(*  Title:      HOL/Library/Ramsey.thy
wenzelm@32960
     2
    Author:     Tom Ridge.  Converted to structured Isar by L C Paulson
paulson@19944
     3
*)
paulson@19944
     4
paulson@19944
     5
header "Ramsey's Theorem"
paulson@19944
     6
haftmann@25594
     7
theory Ramsey
haftmann@30738
     8
imports Main Infinite_Set
haftmann@25594
     9
begin
paulson@19944
    10
wenzelm@22665
    11
subsection {* Preliminaries *}
paulson@19944
    12
wenzelm@22665
    13
subsubsection {* ``Axiom'' of Dependent Choice *}
paulson@19944
    14
haftmann@34941
    15
primrec choice :: "('a => bool) => ('a * 'a) set => nat => 'a" where
paulson@19944
    16
  --{*An integer-indexed chain of choices*}
haftmann@34941
    17
    choice_0:   "choice P r 0 = (SOME x. P x)"
haftmann@34941
    18
  | choice_Suc: "choice P r (Suc n) = (SOME y. P y & (choice P r n, y) \<in> r)"
paulson@19944
    19
paulson@19944
    20
lemma choice_n: 
paulson@19944
    21
  assumes P0: "P x0"
paulson@19944
    22
      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
paulson@19944
    23
  shows "P (choice P r n)"
wenzelm@19948
    24
proof (induct n)
wenzelm@19948
    25
  case 0 show ?case by (force intro: someI P0) 
wenzelm@19948
    26
next
wenzelm@19948
    27
  case Suc thus ?case by (auto intro: someI2_ex [OF Pstep]) 
wenzelm@19948
    28
qed
paulson@19944
    29
paulson@19944
    30
lemma dependent_choice: 
paulson@19944
    31
  assumes trans: "trans r"
paulson@19944
    32
      and P0: "P x0"
paulson@19944
    33
      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
paulson@19954
    34
  obtains f :: "nat => 'a" where
paulson@19954
    35
    "!!n. P (f n)" and "!!n m. n < m ==> (f n, f m) \<in> r"
paulson@19954
    36
proof
paulson@19954
    37
  fix n
paulson@19954
    38
  show "P (choice P r n)" by (blast intro: choice_n [OF P0 Pstep])
paulson@19944
    39
next
paulson@19944
    40
  have PSuc: "\<forall>n. (choice P r n, choice P r (Suc n)) \<in> r" 
paulson@19944
    41
    using Pstep [OF choice_n [OF P0 Pstep]]
paulson@19944
    42
    by (auto intro: someI2_ex)
paulson@19954
    43
  fix n m :: nat
paulson@19954
    44
  assume less: "n < m"
paulson@19954
    45
  show "(choice P r n, choice P r m) \<in> r" using PSuc
paulson@19954
    46
    by (auto intro: less_Suc_induct [OF less] transD [OF trans])
paulson@19954
    47
qed
paulson@19944
    48
paulson@19944
    49
wenzelm@22665
    50
subsubsection {* Partitions of a Set *}
paulson@19944
    51
wenzelm@19948
    52
definition
wenzelm@19948
    53
  part :: "nat => nat => 'a set => ('a set => nat) => bool"
paulson@19944
    54
  --{*the function @{term f} partitions the @{term r}-subsets of the typically
paulson@19944
    55
       infinite set @{term Y} into @{term s} distinct categories.*}
krauss@21634
    56
where
wenzelm@19948
    57
  "part r s Y f = (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X < s)"
paulson@19944
    58
paulson@19944
    59
text{*For induction, we decrease the value of @{term r} in partitions.*}
paulson@19944
    60
lemma part_Suc_imp_part:
paulson@19944
    61
     "[| infinite Y; part (Suc r) s Y f; y \<in> Y |] 
paulson@19944
    62
      ==> part r s (Y - {y}) (%u. f (insert y u))"
paulson@19944
    63
  apply(simp add: part_def, clarify)
paulson@19944
    64
  apply(drule_tac x="insert y X" in spec)
nipkow@24853
    65
  apply(force)
paulson@19944
    66
  done
paulson@19944
    67
paulson@19944
    68
lemma part_subset: "part r s YY f ==> Y \<subseteq> YY ==> part r s Y f" 
wenzelm@19948
    69
  unfolding part_def by blast
paulson@19944
    70
  
paulson@19944
    71
wenzelm@22665
    72
subsection {* Ramsey's Theorem: Infinitary Version *}
paulson@19944
    73
paulson@19954
    74
lemma Ramsey_induction: 
paulson@19954
    75
  fixes s and r::nat
paulson@19944
    76
  shows
paulson@19944
    77
  "!!(YY::'a set) (f::'a set => nat). 
paulson@19944
    78
      [|infinite YY; part r s YY f|]
paulson@19944
    79
      ==> \<exists>Y' t'. Y' \<subseteq> YY & infinite Y' & t' < s & 
paulson@19944
    80
                  (\<forall>X. X \<subseteq> Y' & finite X & card X = r --> f X = t')"
paulson@19944
    81
proof (induct r)
paulson@19944
    82
  case 0
nipkow@24853
    83
  thus ?case by (auto simp add: part_def card_eq_0_iff cong: conj_cong)
paulson@19944
    84
next
paulson@19944
    85
  case (Suc r) 
paulson@19944
    86
  show ?case
paulson@19944
    87
  proof -
paulson@19944
    88
    from Suc.prems infinite_imp_nonempty obtain yy where yy: "yy \<in> YY" by blast
paulson@19944
    89
    let ?ramr = "{((y,Y,t),(y',Y',t')). y' \<in> Y & Y' \<subseteq> Y}"
paulson@19944
    90
    let ?propr = "%(y,Y,t).     
wenzelm@32960
    91
                 y \<in> YY & y \<notin> Y & Y \<subseteq> YY & infinite Y & t < s
wenzelm@32960
    92
                 & (\<forall>X. X\<subseteq>Y & finite X & card X = r --> (f o insert y) X = t)"
paulson@19944
    93
    have infYY': "infinite (YY-{yy})" using Suc.prems by auto
paulson@19944
    94
    have partf': "part r s (YY - {yy}) (f \<circ> insert yy)"
paulson@19944
    95
      by (simp add: o_def part_Suc_imp_part yy Suc.prems)
paulson@19944
    96
    have transr: "trans ?ramr" by (force simp add: trans_def) 
paulson@19944
    97
    from Suc.hyps [OF infYY' partf']
paulson@19944
    98
    obtain Y0 and t0
paulson@19944
    99
    where "Y0 \<subseteq> YY - {yy}"  "infinite Y0"  "t0 < s"
paulson@19944
   100
          "\<forall>X. X\<subseteq>Y0 \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yy) X = t0"
paulson@19944
   101
        by blast 
paulson@19944
   102
    with yy have propr0: "?propr(yy,Y0,t0)" by blast
paulson@19944
   103
    have proprstep: "\<And>x. ?propr x \<Longrightarrow> \<exists>y. ?propr y \<and> (x, y) \<in> ?ramr" 
paulson@19944
   104
    proof -
paulson@19944
   105
      fix x
paulson@19944
   106
      assume px: "?propr x" thus "?thesis x"
paulson@19944
   107
      proof (cases x)
paulson@19944
   108
        case (fields yx Yx tx)
paulson@19944
   109
        then obtain yx' where yx': "yx' \<in> Yx" using px
paulson@19944
   110
               by (blast dest: infinite_imp_nonempty)
paulson@19944
   111
        have infYx': "infinite (Yx-{yx'})" using fields px by auto
paulson@19944
   112
        with fields px yx' Suc.prems
paulson@19944
   113
        have partfx': "part r s (Yx - {yx'}) (f \<circ> insert yx')"
paulson@19944
   114
          by (simp add: o_def part_Suc_imp_part part_subset [where ?YY=YY]) 
wenzelm@32960
   115
        from Suc.hyps [OF infYx' partfx']
wenzelm@32960
   116
        obtain Y' and t'
wenzelm@32960
   117
        where Y': "Y' \<subseteq> Yx - {yx'}"  "infinite Y'"  "t' < s"
wenzelm@32960
   118
               "\<forall>X. X\<subseteq>Y' \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yx') X = t'"
wenzelm@32960
   119
            by blast 
wenzelm@32960
   120
        show ?thesis
wenzelm@32960
   121
        proof
wenzelm@32960
   122
          show "?propr (yx',Y',t') & (x, (yx',Y',t')) \<in> ?ramr"
wenzelm@32960
   123
            using fields Y' yx' px by blast
wenzelm@32960
   124
        qed
paulson@19944
   125
      qed
paulson@19944
   126
    qed
paulson@19944
   127
    from dependent_choice [OF transr propr0 proprstep]
nipkow@19946
   128
    obtain g where pg: "!!n::nat.  ?propr (g n)"
paulson@19954
   129
      and rg: "!!n m. n<m ==> (g n, g m) \<in> ?ramr" by blast
haftmann@28741
   130
    let ?gy = "fst o g"
haftmann@28741
   131
    let ?gt = "snd o snd o g"
paulson@19944
   132
    have rangeg: "\<exists>k. range ?gt \<subseteq> {..<k}"
paulson@19944
   133
    proof (intro exI subsetI)
paulson@19944
   134
      fix x
paulson@19944
   135
      assume "x \<in> range ?gt"
paulson@19944
   136
      then obtain n where "x = ?gt n" ..
paulson@19944
   137
      with pg [of n] show "x \<in> {..<s}" by (cases "g n") auto
paulson@19944
   138
    qed
wenzelm@20810
   139
    have "finite (range ?gt)"
wenzelm@20810
   140
      by (simp add: finite_nat_iff_bounded rangeg)
paulson@19944
   141
    then obtain s' and n'
wenzelm@20810
   142
      where s': "s' = ?gt n'"
wenzelm@20810
   143
        and infeqs': "infinite {n. ?gt n = s'}"
wenzelm@20810
   144
      by (rule inf_img_fin_domE) (auto simp add: vimage_def intro: nat_infinite)
paulson@19944
   145
    with pg [of n'] have less': "s'<s" by (cases "g n'") auto
paulson@19944
   146
    have inj_gy: "inj ?gy"
paulson@19944
   147
    proof (rule linorder_injI)
wenzelm@19949
   148
      fix m m' :: nat assume less: "m < m'" show "?gy m \<noteq> ?gy m'"
wenzelm@19948
   149
        using rg [OF less] pg [of m] by (cases "g m", cases "g m'") auto
paulson@19944
   150
    qed
paulson@19944
   151
    show ?thesis
paulson@19944
   152
    proof (intro exI conjI)
paulson@19944
   153
      show "?gy ` {n. ?gt n = s'} \<subseteq> YY" using pg
paulson@19944
   154
        by (auto simp add: Let_def split_beta) 
paulson@19944
   155
      show "infinite (?gy ` {n. ?gt n = s'})" using infeqs'
paulson@19944
   156
        by (blast intro: inj_gy [THEN subset_inj_on] dest: finite_imageD) 
paulson@19944
   157
      show "s' < s" by (rule less')
paulson@19944
   158
      show "\<forall>X. X \<subseteq> ?gy ` {n. ?gt n = s'} & finite X & card X = Suc r 
paulson@19944
   159
          --> f X = s'"
paulson@19944
   160
      proof -
paulson@19944
   161
        {fix X 
paulson@19944
   162
         assume "X \<subseteq> ?gy ` {n. ?gt n = s'}"
paulson@19944
   163
            and cardX: "finite X" "card X = Suc r"
paulson@19944
   164
         then obtain AA where AA: "AA \<subseteq> {n. ?gt n = s'}" and Xeq: "X = ?gy`AA" 
paulson@19944
   165
             by (auto simp add: subset_image_iff) 
paulson@19944
   166
         with cardX have "AA\<noteq>{}" by auto
paulson@19944
   167
         hence AAleast: "(LEAST x. x \<in> AA) \<in> AA" by (auto intro: LeastI_ex) 
paulson@19944
   168
         have "f X = s'"
paulson@19944
   169
         proof (cases "g (LEAST x. x \<in> AA)") 
paulson@19944
   170
           case (fields ya Ya ta)
paulson@19944
   171
           with AAleast Xeq 
paulson@19944
   172
           have ya: "ya \<in> X" by (force intro!: rev_image_eqI) 
paulson@19944
   173
           hence "f X = f (insert ya (X - {ya}))" by (simp add: insert_absorb)
paulson@19944
   174
           also have "... = ta" 
paulson@19944
   175
           proof -
paulson@19944
   176
             have "X - {ya} \<subseteq> Ya"
paulson@19944
   177
             proof 
paulson@19954
   178
               fix x assume x: "x \<in> X - {ya}"
paulson@19944
   179
               then obtain a' where xeq: "x = ?gy a'" and a': "a' \<in> AA" 
paulson@19944
   180
                 by (auto simp add: Xeq) 
paulson@19944
   181
               hence "a' \<noteq> (LEAST x. x \<in> AA)" using x fields by auto
paulson@19944
   182
               hence lessa': "(LEAST x. x \<in> AA) < a'"
paulson@19944
   183
                 using Least_le [of "%x. x \<in> AA", OF a'] by arith
paulson@19944
   184
               show "x \<in> Ya" using xeq fields rg [OF lessa'] by auto
paulson@19944
   185
             qed
paulson@19944
   186
             moreover
paulson@19944
   187
             have "card (X - {ya}) = r"
nipkow@24853
   188
               by (simp add: cardX ya)
paulson@19944
   189
             ultimately show ?thesis 
paulson@19944
   190
               using pg [of "LEAST x. x \<in> AA"] fields cardX
wenzelm@32960
   191
               by (clarsimp simp del:insert_Diff_single)
paulson@19944
   192
           qed
paulson@19944
   193
           also have "... = s'" using AA AAleast fields by auto
paulson@19944
   194
           finally show ?thesis .
paulson@19944
   195
         qed}
paulson@19944
   196
        thus ?thesis by blast
paulson@19944
   197
      qed 
paulson@19944
   198
    qed 
paulson@19944
   199
  qed
paulson@19944
   200
qed
paulson@19944
   201
paulson@19944
   202
paulson@19944
   203
theorem Ramsey:
wenzelm@19949
   204
  fixes s r :: nat and Z::"'a set" and f::"'a set => nat"
paulson@19944
   205
  shows
paulson@19944
   206
   "[|infinite Z;
paulson@19944
   207
      \<forall>X. X \<subseteq> Z & finite X & card X = r --> f X < s|]
paulson@19944
   208
  ==> \<exists>Y t. Y \<subseteq> Z & infinite Y & t < s 
paulson@19944
   209
            & (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X = t)"
paulson@19954
   210
by (blast intro: Ramsey_induction [unfolded part_def])
paulson@19954
   211
paulson@19954
   212
paulson@19954
   213
corollary Ramsey2:
paulson@19954
   214
  fixes s::nat and Z::"'a set" and f::"'a set => nat"
paulson@19954
   215
  assumes infZ: "infinite Z"
paulson@19954
   216
      and part: "\<forall>x\<in>Z. \<forall>y\<in>Z. x\<noteq>y --> f{x,y} < s"
paulson@19954
   217
  shows
paulson@19954
   218
   "\<exists>Y t. Y \<subseteq> Z & infinite Y & t < s & (\<forall>x\<in>Y. \<forall>y\<in>Y. x\<noteq>y --> f{x,y} = t)"
paulson@19954
   219
proof -
paulson@19954
   220
  have part2: "\<forall>X. X \<subseteq> Z & finite X & card X = 2 --> f X < s"
nipkow@24853
   221
    using part by (fastsimp simp add: nat_number card_Suc_eq)
paulson@19954
   222
  obtain Y t 
paulson@19954
   223
    where "Y \<subseteq> Z" "infinite Y" "t < s"
paulson@19954
   224
          "(\<forall>X. X \<subseteq> Y & finite X & card X = 2 --> f X = t)"
paulson@19954
   225
    by (insert Ramsey [OF infZ part2]) auto
paulson@19954
   226
  moreover from this have  "\<forall>x\<in>Y. \<forall>y\<in>Y. x \<noteq> y \<longrightarrow> f {x, y} = t" by auto
paulson@19954
   227
  ultimately show ?thesis by iprover
paulson@19954
   228
qed
paulson@19954
   229
paulson@19954
   230
wenzelm@22665
   231
subsection {* Disjunctive Well-Foundedness *}
paulson@19954
   232
wenzelm@22367
   233
text {*
wenzelm@22367
   234
  An application of Ramsey's theorem to program termination. See
wenzelm@22367
   235
  \cite{Podelski-Rybalchenko}.
paulson@19954
   236
*}
paulson@19954
   237
wenzelm@20810
   238
definition
paulson@19954
   239
  disj_wf         :: "('a * 'a)set => bool"
krauss@21634
   240
where
wenzelm@20810
   241
  "disj_wf r = (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) & r = (\<Union>i<n. T i))"
paulson@19954
   242
krauss@21634
   243
definition
paulson@19954
   244
  transition_idx :: "[nat => 'a, nat => ('a*'a)set, nat set] => nat"
krauss@21634
   245
where
wenzelm@20810
   246
  "transition_idx s T A =
wenzelm@20810
   247
    (LEAST k. \<exists>i j. A = {i,j} & i<j & (s j, s i) \<in> T k)"
paulson@19954
   248
paulson@19954
   249
paulson@19954
   250
lemma transition_idx_less:
paulson@19954
   251
    "[|i<j; (s j, s i) \<in> T k; k<n|] ==> transition_idx s T {i,j} < n"
paulson@19954
   252
apply (subgoal_tac "transition_idx s T {i, j} \<le> k", simp) 
paulson@19954
   253
apply (simp add: transition_idx_def, blast intro: Least_le) 
paulson@19954
   254
done
paulson@19954
   255
paulson@19954
   256
lemma transition_idx_in:
paulson@19954
   257
    "[|i<j; (s j, s i) \<in> T k|] ==> (s j, s i) \<in> T (transition_idx s T {i,j})"
paulson@19954
   258
apply (simp add: transition_idx_def doubleton_eq_iff conj_disj_distribR 
paulson@19954
   259
            cong: conj_cong) 
paulson@19954
   260
apply (erule LeastI) 
paulson@19954
   261
done
paulson@19954
   262
paulson@19954
   263
text{*To be equal to the union of some well-founded relations is equivalent
paulson@19954
   264
to being the subset of such a union.*}
paulson@19954
   265
lemma disj_wf:
paulson@19954
   266
     "disj_wf(r) = (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) & r \<subseteq> (\<Union>i<n. T i))"
paulson@19954
   267
apply (auto simp add: disj_wf_def) 
paulson@19954
   268
apply (rule_tac x="%i. T i Int r" in exI) 
paulson@19954
   269
apply (rule_tac x=n in exI) 
paulson@19954
   270
apply (force simp add: wf_Int1) 
paulson@19954
   271
done
paulson@19954
   272
paulson@19954
   273
theorem trans_disj_wf_implies_wf:
paulson@19954
   274
  assumes transr: "trans r"
paulson@19954
   275
      and dwf:    "disj_wf(r)"
paulson@19954
   276
  shows "wf r"
paulson@19954
   277
proof (simp only: wf_iff_no_infinite_down_chain, rule notI)
paulson@19954
   278
  assume "\<exists>s. \<forall>i. (s (Suc i), s i) \<in> r"
paulson@19954
   279
  then obtain s where sSuc: "\<forall>i. (s (Suc i), s i) \<in> r" ..
paulson@19954
   280
  have s: "!!i j. i < j ==> (s j, s i) \<in> r"
paulson@19954
   281
  proof -
paulson@19954
   282
    fix i and j::nat
paulson@19954
   283
    assume less: "i<j"
paulson@19954
   284
    thus "(s j, s i) \<in> r"
paulson@19954
   285
    proof (rule less_Suc_induct)
paulson@19954
   286
      show "\<And>i. (s (Suc i), s i) \<in> r" by (simp add: sSuc) 
paulson@19954
   287
      show "\<And>i j k. \<lbrakk>(s j, s i) \<in> r; (s k, s j) \<in> r\<rbrakk> \<Longrightarrow> (s k, s i) \<in> r"
paulson@19954
   288
        using transr by (unfold trans_def, blast) 
paulson@19954
   289
    qed
paulson@19954
   290
  qed    
paulson@19954
   291
  from dwf
paulson@19954
   292
  obtain T and n::nat where wfT: "\<forall>k<n. wf(T k)" and r: "r = (\<Union>k<n. T k)"
paulson@19954
   293
    by (auto simp add: disj_wf_def)
paulson@19954
   294
  have s_in_T: "\<And>i j. i<j ==> \<exists>k. (s j, s i) \<in> T k & k<n"
paulson@19954
   295
  proof -
paulson@19954
   296
    fix i and j::nat
paulson@19954
   297
    assume less: "i<j"
paulson@19954
   298
    hence "(s j, s i) \<in> r" by (rule s [of i j]) 
paulson@19954
   299
    thus "\<exists>k. (s j, s i) \<in> T k & k<n" by (auto simp add: r)
paulson@19954
   300
  qed    
paulson@19954
   301
  have trless: "!!i j. i\<noteq>j ==> transition_idx s T {i,j} < n"
paulson@19954
   302
    apply (auto simp add: linorder_neq_iff)
paulson@19954
   303
    apply (blast dest: s_in_T transition_idx_less) 
paulson@19954
   304
    apply (subst insert_commute)   
paulson@19954
   305
    apply (blast dest: s_in_T transition_idx_less) 
paulson@19954
   306
    done
paulson@19954
   307
  have
paulson@19954
   308
   "\<exists>K k. K \<subseteq> UNIV & infinite K & k < n & 
paulson@19954
   309
          (\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k)"
paulson@19954
   310
    by (rule Ramsey2) (auto intro: trless nat_infinite) 
paulson@19954
   311
  then obtain K and k 
paulson@19954
   312
    where infK: "infinite K" and less: "k < n" and
paulson@19954
   313
          allk: "\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k"
paulson@19954
   314
    by auto
paulson@19954
   315
  have "\<forall>m. (s (enumerate K (Suc m)), s(enumerate K m)) \<in> T k"
paulson@19954
   316
  proof
paulson@19954
   317
    fix m::nat
paulson@19954
   318
    let ?j = "enumerate K (Suc m)"
paulson@19954
   319
    let ?i = "enumerate K m"
paulson@19954
   320
    have jK: "?j \<in> K" by (simp add: enumerate_in_set infK) 
paulson@19954
   321
    have iK: "?i \<in> K" by (simp add: enumerate_in_set infK) 
paulson@19954
   322
    have ij: "?i < ?j" by (simp add: enumerate_step infK) 
paulson@19954
   323
    have ijk: "transition_idx s T {?i,?j} = k" using iK jK ij 
paulson@19954
   324
      by (simp add: allk)
paulson@19954
   325
    obtain k' where "(s ?j, s ?i) \<in> T k'" "k'<n" 
paulson@19954
   326
      using s_in_T [OF ij] by blast
paulson@19954
   327
    thus "(s ?j, s ?i) \<in> T k" 
paulson@19954
   328
      by (simp add: ijk [symmetric] transition_idx_in ij) 
paulson@19954
   329
  qed
paulson@19954
   330
  hence "~ wf(T k)" by (force simp add: wf_iff_no_infinite_down_chain) 
paulson@19954
   331
  thus False using wfT less by blast
paulson@19954
   332
qed
paulson@19954
   333
paulson@19944
   334
end