src/HOL/Library/Ramsey.thy
author paulson <lp15@cam.ac.uk>
Mon Feb 22 14:37:56 2016 +0000 (2016-02-22)
changeset 62379 340738057c8c
parent 61585 a9599d3d7610
child 63060 293ede07b775
permissions -rw-r--r--
An assortment of useful lemmas about sums, norm, etc. Also: norm_conv_dist [symmetric] is now a simprule!
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
wenzelm@58881
     5
section "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@60500
    11
subsection\<open>Finite Ramsey theorem(s)\<close>
nipkow@40695
    12
wenzelm@60500
    13
text\<open>To distinguish the finite and infinite ones, lower and upper case
nipkow@40695
    14
names are used.
nipkow@40695
    15
nipkow@40695
    16
This is the most basic version in terms of cliques and independent
wenzelm@60500
    17
sets, i.e. the version for graphs and 2 colours.\<close>
nipkow@40695
    18
nipkow@40695
    19
definition "clique V E = (\<forall>v\<in>V. \<forall>w\<in>V. v\<noteq>w \<longrightarrow> {v,w} : E)"
nipkow@40695
    20
definition "indep V E = (\<forall>v\<in>V. \<forall>w\<in>V. v\<noteq>w \<longrightarrow> \<not> {v,w} : E)"
nipkow@40695
    21
nipkow@40695
    22
lemma ramsey2:
nipkow@40695
    23
  "\<exists>r\<ge>1. \<forall> (V::'a set) (E::'a set set). finite V \<and> card V \<ge> r \<longrightarrow>
nipkow@40695
    24
  (\<exists> R \<subseteq> V. card R = m \<and> clique R E \<or> card R = n \<and> indep R E)"
nipkow@40695
    25
  (is "\<exists>r\<ge>1. ?R m n r")
nipkow@40695
    26
proof(induct k == "m+n" arbitrary: m n)
nipkow@40695
    27
  case 0
nipkow@40695
    28
  show ?case (is "EX r. ?R r")
nipkow@40695
    29
  proof
nipkow@40695
    30
    show "?R 1" using 0
nipkow@40695
    31
      by (clarsimp simp: indep_def)(metis card.empty emptyE empty_subsetI)
nipkow@40695
    32
  qed
nipkow@40695
    33
next
nipkow@40695
    34
  case (Suc k)
nipkow@40695
    35
  { assume "m=0"
nipkow@40695
    36
    have ?case (is "EX r. ?R r")
nipkow@40695
    37
    proof
wenzelm@60500
    38
      show "?R 1" using \<open>m=0\<close>
nipkow@40695
    39
        by (simp add:clique_def)(metis card.empty emptyE empty_subsetI)
nipkow@40695
    40
    qed
nipkow@40695
    41
  } moreover
nipkow@40695
    42
  { assume "n=0"
nipkow@40695
    43
    have ?case (is "EX r. ?R r")
nipkow@40695
    44
    proof
wenzelm@60500
    45
      show "?R 1" using \<open>n=0\<close>
nipkow@40695
    46
        by (simp add:indep_def)(metis card.empty emptyE empty_subsetI)
nipkow@40695
    47
    qed
nipkow@40695
    48
  } moreover
nipkow@40695
    49
  { assume "m\<noteq>0" "n\<noteq>0"
wenzelm@60500
    50
    then have "k = (m - 1) + n" "k = m + (n - 1)" using \<open>Suc k = m+n\<close> by auto
wenzelm@46575
    51
    from Suc(1)[OF this(1)] Suc(1)[OF this(2)]
nipkow@40695
    52
    obtain r1 r2 where "r1\<ge>1" "r2\<ge>1" "?R (m - 1) n r1" "?R m (n - 1) r2"
nipkow@40695
    53
      by auto
wenzelm@46575
    54
    then have "r1+r2 \<ge> 1" by arith
nipkow@40695
    55
    moreover
nipkow@40695
    56
    have "?R m n (r1+r2)" (is "ALL V E. _ \<longrightarrow> ?EX V E m n")
nipkow@40695
    57
    proof clarify
nipkow@40695
    58
      fix V :: "'a set" and E :: "'a set set"
nipkow@40695
    59
      assume "finite V" "r1+r2 \<le> card V"
wenzelm@60500
    60
      with \<open>r1\<ge>1\<close> have "V \<noteq> {}" by auto
nipkow@40695
    61
      then obtain v where "v : V" by blast
nipkow@40695
    62
      let ?M = "{w : V. w\<noteq>v & {v,w} : E}"
nipkow@40695
    63
      let ?N = "{w : V. w\<noteq>v & {v,w} ~: E}"
wenzelm@60500
    64
      have "V = insert v (?M \<union> ?N)" using \<open>v : V\<close> by auto
wenzelm@46575
    65
      then have "card V = card(insert v (?M \<union> ?N))" by metis
wenzelm@60500
    66
      also have "\<dots> = card ?M + card ?N + 1" using \<open>finite V\<close>
nipkow@44890
    67
        by(fastforce intro: card_Un_disjoint)
nipkow@40695
    68
      finally have "card V = card ?M + card ?N + 1" .
wenzelm@60500
    69
      then have "r1+r2 \<le> card ?M + card ?N + 1" using \<open>r1+r2 \<le> card V\<close> by simp
wenzelm@46575
    70
      then have "r1 \<le> card ?M \<or> r2 \<le> card ?N" by arith
nipkow@40695
    71
      moreover
nipkow@40695
    72
      { assume "r1 \<le> card ?M"
wenzelm@60500
    73
        moreover have "finite ?M" using \<open>finite V\<close> by auto
wenzelm@60500
    74
        ultimately have "?EX ?M E (m - 1) n" using \<open>?R (m - 1) n r1\<close> by blast
nipkow@40695
    75
        then obtain R where "R \<subseteq> ?M" "v ~: R" and
nipkow@40695
    76
          CI: "card R = m - 1 \<and> clique R E \<or>
nipkow@40695
    77
               card R = n \<and> indep R E" (is "?C \<or> ?I")
nipkow@40695
    78
          by blast
wenzelm@60500
    79
        have "R <= V" using \<open>R <= ?M\<close> by auto
wenzelm@60500
    80
        have "finite R" using \<open>finite V\<close> \<open>R \<subseteq> V\<close> by (metis finite_subset)
nipkow@40695
    81
        { assume "?I"
wenzelm@60500
    82
          with \<open>R <= V\<close> have "?EX V E m n" by blast
nipkow@40695
    83
        } moreover
nipkow@40695
    84
        { assume "?C"
wenzelm@60500
    85
          then have "clique (insert v R) E" using \<open>R <= ?M\<close>
nipkow@40695
    86
           by(auto simp:clique_def insert_commute)
nipkow@40695
    87
          moreover have "card(insert v R) = m"
wenzelm@60500
    88
            using \<open>?C\<close> \<open>finite R\<close> \<open>v ~: R\<close> \<open>m\<noteq>0\<close> by simp
wenzelm@60510
    89
          ultimately have "?EX V E m n" using \<open>R <= V\<close> \<open>v : V\<close> by (metis insert_subset)
nipkow@40695
    90
        } ultimately have "?EX V E m n" using CI by blast
nipkow@40695
    91
      } moreover
nipkow@40695
    92
      { assume "r2 \<le> card ?N"
wenzelm@60500
    93
        moreover have "finite ?N" using \<open>finite V\<close> by auto
wenzelm@60500
    94
        ultimately have "?EX ?N E m (n - 1)" using \<open>?R m (n - 1) r2\<close> by blast
nipkow@40695
    95
        then obtain R where "R \<subseteq> ?N" "v ~: R" and
nipkow@40695
    96
          CI: "card R = m \<and> clique R E \<or>
nipkow@40695
    97
               card R = n - 1 \<and> indep R E" (is "?C \<or> ?I")
nipkow@40695
    98
          by blast
wenzelm@60500
    99
        have "R <= V" using \<open>R <= ?N\<close> by auto
wenzelm@60500
   100
        have "finite R" using \<open>finite V\<close> \<open>R \<subseteq> V\<close> by (metis finite_subset)
nipkow@40695
   101
        { assume "?C"
wenzelm@60500
   102
          with \<open>R <= V\<close> have "?EX V E m n" by blast
nipkow@40695
   103
        } moreover
nipkow@40695
   104
        { assume "?I"
wenzelm@60500
   105
          then have "indep (insert v R) E" using \<open>R <= ?N\<close>
nipkow@40695
   106
            by(auto simp:indep_def insert_commute)
nipkow@40695
   107
          moreover have "card(insert v R) = n"
wenzelm@60500
   108
            using \<open>?I\<close> \<open>finite R\<close> \<open>v ~: R\<close> \<open>n\<noteq>0\<close> by simp
wenzelm@60510
   109
          ultimately have "?EX V E m n" using \<open>R <= V\<close> \<open>v : V\<close> by (metis insert_subset)
nipkow@40695
   110
        } ultimately have "?EX V E m n" using CI by blast
nipkow@40695
   111
      } ultimately show "?EX V E m n" by blast
nipkow@40695
   112
    qed
nipkow@40695
   113
    ultimately have ?case by blast
nipkow@40695
   114
  } ultimately show ?case by blast
nipkow@40695
   115
qed
nipkow@40695
   116
nipkow@40695
   117
wenzelm@60500
   118
subsection \<open>Preliminaries\<close>
paulson@19944
   119
wenzelm@60500
   120
subsubsection \<open>``Axiom'' of Dependent Choice\<close>
paulson@19944
   121
haftmann@34941
   122
primrec choice :: "('a => bool) => ('a * 'a) set => nat => 'a" where
wenzelm@61585
   123
  \<comment>\<open>An integer-indexed chain of choices\<close>
haftmann@34941
   124
    choice_0:   "choice P r 0 = (SOME x. P x)"
haftmann@34941
   125
  | choice_Suc: "choice P r (Suc n) = (SOME y. P y & (choice P r n, y) \<in> r)"
paulson@19944
   126
wenzelm@46575
   127
lemma choice_n:
paulson@19944
   128
  assumes P0: "P x0"
paulson@19944
   129
      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
paulson@19944
   130
  shows "P (choice P r n)"
wenzelm@19948
   131
proof (induct n)
wenzelm@46575
   132
  case 0 show ?case by (force intro: someI P0)
wenzelm@19948
   133
next
wenzelm@46575
   134
  case Suc then show ?case by (auto intro: someI2_ex [OF Pstep])
wenzelm@19948
   135
qed
paulson@19944
   136
wenzelm@46575
   137
lemma dependent_choice:
paulson@19944
   138
  assumes trans: "trans r"
paulson@19944
   139
      and P0: "P x0"
paulson@19944
   140
      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
paulson@19954
   141
  obtains f :: "nat => 'a" where
paulson@19954
   142
    "!!n. P (f n)" and "!!n m. n < m ==> (f n, f m) \<in> r"
paulson@19954
   143
proof
paulson@19954
   144
  fix n
paulson@19954
   145
  show "P (choice P r n)" by (blast intro: choice_n [OF P0 Pstep])
paulson@19944
   146
next
wenzelm@46575
   147
  have PSuc: "\<forall>n. (choice P r n, choice P r (Suc n)) \<in> r"
paulson@19944
   148
    using Pstep [OF choice_n [OF P0 Pstep]]
paulson@19944
   149
    by (auto intro: someI2_ex)
paulson@19954
   150
  fix n m :: nat
paulson@19954
   151
  assume less: "n < m"
paulson@19954
   152
  show "(choice P r n, choice P r m) \<in> r" using PSuc
paulson@19954
   153
    by (auto intro: less_Suc_induct [OF less] transD [OF trans])
paulson@19954
   154
qed
paulson@19944
   155
paulson@19944
   156
wenzelm@60500
   157
subsubsection \<open>Partitions of a Set\<close>
paulson@19944
   158
wenzelm@46575
   159
definition part :: "nat => nat => 'a set => ('a set => nat) => bool"
wenzelm@61585
   160
  \<comment>\<open>the function @{term f} partitions the @{term r}-subsets of the typically
wenzelm@60500
   161
       infinite set @{term Y} into @{term s} distinct categories.\<close>
krauss@21634
   162
where
wenzelm@19948
   163
  "part r s Y f = (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X < s)"
paulson@19944
   164
wenzelm@60500
   165
text\<open>For induction, we decrease the value of @{term r} in partitions.\<close>
paulson@19944
   166
lemma part_Suc_imp_part:
wenzelm@46575
   167
     "[| infinite Y; part (Suc r) s Y f; y \<in> Y |]
paulson@19944
   168
      ==> part r s (Y - {y}) (%u. f (insert y u))"
paulson@19944
   169
  apply(simp add: part_def, clarify)
paulson@19944
   170
  apply(drule_tac x="insert y X" in spec)
nipkow@24853
   171
  apply(force)
paulson@19944
   172
  done
paulson@19944
   173
wenzelm@46575
   174
lemma part_subset: "part r s YY f ==> Y \<subseteq> YY ==> part r s Y f"
wenzelm@19948
   175
  unfolding part_def by blast
wenzelm@46575
   176
paulson@19944
   177
wenzelm@60500
   178
subsection \<open>Ramsey's Theorem: Infinitary Version\<close>
paulson@19944
   179
wenzelm@46575
   180
lemma Ramsey_induction:
paulson@19954
   181
  fixes s and r::nat
paulson@19944
   182
  shows
wenzelm@46575
   183
  "!!(YY::'a set) (f::'a set => nat).
paulson@19944
   184
      [|infinite YY; part r s YY f|]
wenzelm@46575
   185
      ==> \<exists>Y' t'. Y' \<subseteq> YY & infinite Y' & t' < s &
paulson@19944
   186
                  (\<forall>X. X \<subseteq> Y' & finite X & card X = r --> f X = t')"
paulson@19944
   187
proof (induct r)
paulson@19944
   188
  case 0
wenzelm@46575
   189
  then show ?case by (auto simp add: part_def card_eq_0_iff cong: conj_cong)
paulson@19944
   190
next
wenzelm@46575
   191
  case (Suc r)
paulson@19944
   192
  show ?case
paulson@19944
   193
  proof -
paulson@19944
   194
    from Suc.prems infinite_imp_nonempty obtain yy where yy: "yy \<in> YY" by blast
paulson@19944
   195
    let ?ramr = "{((y,Y,t),(y',Y',t')). y' \<in> Y & Y' \<subseteq> Y}"
wenzelm@46575
   196
    let ?propr = "%(y,Y,t).
wenzelm@32960
   197
                 y \<in> YY & y \<notin> Y & Y \<subseteq> YY & infinite Y & t < s
wenzelm@32960
   198
                 & (\<forall>X. X\<subseteq>Y & finite X & card X = r --> (f o insert y) X = t)"
paulson@19944
   199
    have infYY': "infinite (YY-{yy})" using Suc.prems by auto
paulson@19944
   200
    have partf': "part r s (YY - {yy}) (f \<circ> insert yy)"
paulson@19944
   201
      by (simp add: o_def part_Suc_imp_part yy Suc.prems)
wenzelm@46575
   202
    have transr: "trans ?ramr" by (force simp add: trans_def)
paulson@19944
   203
    from Suc.hyps [OF infYY' partf']
paulson@19944
   204
    obtain Y0 and t0
paulson@19944
   205
    where "Y0 \<subseteq> YY - {yy}"  "infinite Y0"  "t0 < s"
paulson@19944
   206
          "\<forall>X. X\<subseteq>Y0 \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yy) X = t0"
wenzelm@46575
   207
        by blast
paulson@19944
   208
    with yy have propr0: "?propr(yy,Y0,t0)" by blast
wenzelm@46575
   209
    have proprstep: "\<And>x. ?propr x \<Longrightarrow> \<exists>y. ?propr y \<and> (x, y) \<in> ?ramr"
paulson@19944
   210
    proof -
paulson@19944
   211
      fix x
wenzelm@46575
   212
      assume px: "?propr x" then show "?thesis x"
paulson@19944
   213
      proof (cases x)
paulson@19944
   214
        case (fields yx Yx tx)
paulson@19944
   215
        then obtain yx' where yx': "yx' \<in> Yx" using px
paulson@19944
   216
               by (blast dest: infinite_imp_nonempty)
paulson@19944
   217
        have infYx': "infinite (Yx-{yx'})" using fields px by auto
paulson@19944
   218
        with fields px yx' Suc.prems
paulson@19944
   219
        have partfx': "part r s (Yx - {yx'}) (f \<circ> insert yx')"
huffman@35175
   220
          by (simp add: o_def part_Suc_imp_part part_subset [where YY=YY and Y=Yx])
wenzelm@32960
   221
        from Suc.hyps [OF infYx' partfx']
wenzelm@32960
   222
        obtain Y' and t'
wenzelm@32960
   223
        where Y': "Y' \<subseteq> Yx - {yx'}"  "infinite Y'"  "t' < s"
wenzelm@32960
   224
               "\<forall>X. X\<subseteq>Y' \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yx') X = t'"
wenzelm@46575
   225
            by blast
wenzelm@32960
   226
        show ?thesis
wenzelm@32960
   227
        proof
wenzelm@32960
   228
          show "?propr (yx',Y',t') & (x, (yx',Y',t')) \<in> ?ramr"
wenzelm@32960
   229
            using fields Y' yx' px by blast
wenzelm@32960
   230
        qed
paulson@19944
   231
      qed
paulson@19944
   232
    qed
paulson@19944
   233
    from dependent_choice [OF transr propr0 proprstep]
nipkow@19946
   234
    obtain g where pg: "!!n::nat.  ?propr (g n)"
paulson@19954
   235
      and rg: "!!n m. n<m ==> (g n, g m) \<in> ?ramr" by blast
haftmann@28741
   236
    let ?gy = "fst o g"
haftmann@28741
   237
    let ?gt = "snd o snd o g"
paulson@19944
   238
    have rangeg: "\<exists>k. range ?gt \<subseteq> {..<k}"
paulson@19944
   239
    proof (intro exI subsetI)
paulson@19944
   240
      fix x
paulson@19944
   241
      assume "x \<in> range ?gt"
paulson@19944
   242
      then obtain n where "x = ?gt n" ..
paulson@19944
   243
      with pg [of n] show "x \<in> {..<s}" by (cases "g n") auto
paulson@19944
   244
    qed
wenzelm@20810
   245
    have "finite (range ?gt)"
wenzelm@20810
   246
      by (simp add: finite_nat_iff_bounded rangeg)
paulson@19944
   247
    then obtain s' and n'
wenzelm@20810
   248
      where s': "s' = ?gt n'"
wenzelm@20810
   249
        and infeqs': "infinite {n. ?gt n = s'}"
traytel@54580
   250
      by (rule inf_img_fin_domE) (auto simp add: vimage_def intro: infinite_UNIV_nat)
paulson@19944
   251
    with pg [of n'] have less': "s'<s" by (cases "g n'") auto
paulson@19944
   252
    have inj_gy: "inj ?gy"
paulson@19944
   253
    proof (rule linorder_injI)
wenzelm@19949
   254
      fix m m' :: nat assume less: "m < m'" show "?gy m \<noteq> ?gy m'"
wenzelm@19948
   255
        using rg [OF less] pg [of m] by (cases "g m", cases "g m'") auto
paulson@19944
   256
    qed
paulson@19944
   257
    show ?thesis
paulson@19944
   258
    proof (intro exI conjI)
paulson@19944
   259
      show "?gy ` {n. ?gt n = s'} \<subseteq> YY" using pg
wenzelm@46575
   260
        by (auto simp add: Let_def split_beta)
paulson@19944
   261
      show "infinite (?gy ` {n. ?gt n = s'})" using infeqs'
wenzelm@46575
   262
        by (blast intro: inj_gy [THEN subset_inj_on] dest: finite_imageD)
paulson@19944
   263
      show "s' < s" by (rule less')
wenzelm@46575
   264
      show "\<forall>X. X \<subseteq> ?gy ` {n. ?gt n = s'} & finite X & card X = Suc r
paulson@19944
   265
          --> f X = s'"
paulson@19944
   266
      proof -
wenzelm@46575
   267
        {fix X
paulson@19944
   268
         assume "X \<subseteq> ?gy ` {n. ?gt n = s'}"
paulson@19944
   269
            and cardX: "finite X" "card X = Suc r"
wenzelm@46575
   270
         then obtain AA where AA: "AA \<subseteq> {n. ?gt n = s'}" and Xeq: "X = ?gy`AA"
wenzelm@46575
   271
             by (auto simp add: subset_image_iff)
paulson@19944
   272
         with cardX have "AA\<noteq>{}" by auto
wenzelm@46575
   273
         then have AAleast: "(LEAST x. x \<in> AA) \<in> AA" by (auto intro: LeastI_ex)
paulson@19944
   274
         have "f X = s'"
wenzelm@46575
   275
         proof (cases "g (LEAST x. x \<in> AA)")
paulson@19944
   276
           case (fields ya Ya ta)
wenzelm@46575
   277
           with AAleast Xeq
wenzelm@46575
   278
           have ya: "ya \<in> X" by (force intro!: rev_image_eqI)
wenzelm@46575
   279
           then have "f X = f (insert ya (X - {ya}))" by (simp add: insert_absorb)
wenzelm@46575
   280
           also have "... = ta"
paulson@19944
   281
           proof -
paulson@19944
   282
             have "X - {ya} \<subseteq> Ya"
wenzelm@46575
   283
             proof
paulson@19954
   284
               fix x assume x: "x \<in> X - {ya}"
wenzelm@46575
   285
               then obtain a' where xeq: "x = ?gy a'" and a': "a' \<in> AA"
wenzelm@46575
   286
                 by (auto simp add: Xeq)
wenzelm@46575
   287
               then have "a' \<noteq> (LEAST x. x \<in> AA)" using x fields by auto
wenzelm@46575
   288
               then have lessa': "(LEAST x. x \<in> AA) < a'"
paulson@19944
   289
                 using Least_le [of "%x. x \<in> AA", OF a'] by arith
paulson@19944
   290
               show "x \<in> Ya" using xeq fields rg [OF lessa'] by auto
paulson@19944
   291
             qed
paulson@19944
   292
             moreover
paulson@19944
   293
             have "card (X - {ya}) = r"
nipkow@24853
   294
               by (simp add: cardX ya)
wenzelm@46575
   295
             ultimately show ?thesis
paulson@19944
   296
               using pg [of "LEAST x. x \<in> AA"] fields cardX
wenzelm@32960
   297
               by (clarsimp simp del:insert_Diff_single)
paulson@19944
   298
           qed
paulson@19944
   299
           also have "... = s'" using AA AAleast fields by auto
paulson@19944
   300
           finally show ?thesis .
paulson@19944
   301
         qed}
wenzelm@46575
   302
        then show ?thesis by blast
wenzelm@46575
   303
      qed
wenzelm@46575
   304
    qed
paulson@19944
   305
  qed
paulson@19944
   306
qed
paulson@19944
   307
paulson@19944
   308
paulson@19944
   309
theorem Ramsey:
wenzelm@19949
   310
  fixes s r :: nat and Z::"'a set" and f::"'a set => nat"
paulson@19944
   311
  shows
paulson@19944
   312
   "[|infinite Z;
paulson@19944
   313
      \<forall>X. X \<subseteq> Z & finite X & card X = r --> f X < s|]
wenzelm@46575
   314
  ==> \<exists>Y t. Y \<subseteq> Z & infinite Y & t < s
paulson@19944
   315
            & (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X = t)"
paulson@19954
   316
by (blast intro: Ramsey_induction [unfolded part_def])
paulson@19954
   317
paulson@19954
   318
paulson@19954
   319
corollary Ramsey2:
paulson@19954
   320
  fixes s::nat and Z::"'a set" and f::"'a set => nat"
paulson@19954
   321
  assumes infZ: "infinite Z"
paulson@19954
   322
      and part: "\<forall>x\<in>Z. \<forall>y\<in>Z. x\<noteq>y --> f{x,y} < s"
paulson@19954
   323
  shows
paulson@19954
   324
   "\<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
   325
proof -
paulson@19954
   326
  have part2: "\<forall>X. X \<subseteq> Z & finite X & card X = 2 --> f X < s"
nipkow@44890
   327
    using part by (fastforce simp add: eval_nat_numeral card_Suc_eq)
wenzelm@46575
   328
  obtain Y t
wenzelm@53374
   329
    where *: "Y \<subseteq> Z" "infinite Y" "t < s"
paulson@19954
   330
          "(\<forall>X. X \<subseteq> Y & finite X & card X = 2 --> f X = t)"
paulson@19954
   331
    by (insert Ramsey [OF infZ part2]) auto
wenzelm@53374
   332
  then have "\<forall>x\<in>Y. \<forall>y\<in>Y. x \<noteq> y \<longrightarrow> f {x, y} = t" by auto
wenzelm@53374
   333
  with * show ?thesis by iprover
paulson@19954
   334
qed
paulson@19954
   335
paulson@19954
   336
wenzelm@60500
   337
subsection \<open>Disjunctive Well-Foundedness\<close>
paulson@19954
   338
wenzelm@60500
   339
text \<open>
wenzelm@22367
   340
  An application of Ramsey's theorem to program termination. See
wenzelm@58622
   341
  @{cite "Podelski-Rybalchenko"}.
wenzelm@60500
   342
\<close>
paulson@19954
   343
wenzelm@46575
   344
definition disj_wf :: "('a * 'a)set => bool"
wenzelm@46575
   345
  where "disj_wf r = (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) & r = (\<Union>i<n. T i))"
paulson@19954
   346
wenzelm@46575
   347
definition transition_idx :: "[nat => 'a, nat => ('a*'a)set, nat set] => nat"
wenzelm@46575
   348
  where
wenzelm@46575
   349
    "transition_idx s T A =
wenzelm@46575
   350
      (LEAST k. \<exists>i j. A = {i,j} & i<j & (s j, s i) \<in> T k)"
paulson@19954
   351
paulson@19954
   352
paulson@19954
   353
lemma transition_idx_less:
paulson@19954
   354
    "[|i<j; (s j, s i) \<in> T k; k<n|] ==> transition_idx s T {i,j} < n"
wenzelm@46575
   355
apply (subgoal_tac "transition_idx s T {i, j} \<le> k", simp)
wenzelm@46575
   356
apply (simp add: transition_idx_def, blast intro: Least_le)
paulson@19954
   357
done
paulson@19954
   358
paulson@19954
   359
lemma transition_idx_in:
paulson@19954
   360
    "[|i<j; (s j, s i) \<in> T k|] ==> (s j, s i) \<in> T (transition_idx s T {i,j})"
wenzelm@46575
   361
apply (simp add: transition_idx_def doubleton_eq_iff conj_disj_distribR
wenzelm@46575
   362
            cong: conj_cong)
wenzelm@46575
   363
apply (erule LeastI)
paulson@19954
   364
done
paulson@19954
   365
wenzelm@60500
   366
text\<open>To be equal to the union of some well-founded relations is equivalent
wenzelm@60500
   367
to being the subset of such a union.\<close>
paulson@19954
   368
lemma disj_wf:
paulson@19954
   369
     "disj_wf(r) = (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) & r \<subseteq> (\<Union>i<n. T i))"
wenzelm@46575
   370
apply (auto simp add: disj_wf_def)
wenzelm@46575
   371
apply (rule_tac x="%i. T i Int r" in exI)
wenzelm@46575
   372
apply (rule_tac x=n in exI)
wenzelm@46575
   373
apply (force simp add: wf_Int1)
paulson@19954
   374
done
paulson@19954
   375
paulson@19954
   376
theorem trans_disj_wf_implies_wf:
paulson@19954
   377
  assumes transr: "trans r"
paulson@19954
   378
      and dwf:    "disj_wf(r)"
paulson@19954
   379
  shows "wf r"
paulson@19954
   380
proof (simp only: wf_iff_no_infinite_down_chain, rule notI)
paulson@19954
   381
  assume "\<exists>s. \<forall>i. (s (Suc i), s i) \<in> r"
paulson@19954
   382
  then obtain s where sSuc: "\<forall>i. (s (Suc i), s i) \<in> r" ..
paulson@19954
   383
  have s: "!!i j. i < j ==> (s j, s i) \<in> r"
paulson@19954
   384
  proof -
paulson@19954
   385
    fix i and j::nat
paulson@19954
   386
    assume less: "i<j"
wenzelm@46575
   387
    then show "(s j, s i) \<in> r"
paulson@19954
   388
    proof (rule less_Suc_induct)
wenzelm@46575
   389
      show "\<And>i. (s (Suc i), s i) \<in> r" by (simp add: sSuc)
paulson@19954
   390
      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"
wenzelm@46575
   391
        using transr by (unfold trans_def, blast)
paulson@19954
   392
    qed
wenzelm@46575
   393
  qed
paulson@19954
   394
  from dwf
paulson@19954
   395
  obtain T and n::nat where wfT: "\<forall>k<n. wf(T k)" and r: "r = (\<Union>k<n. T k)"
paulson@19954
   396
    by (auto simp add: disj_wf_def)
paulson@19954
   397
  have s_in_T: "\<And>i j. i<j ==> \<exists>k. (s j, s i) \<in> T k & k<n"
paulson@19954
   398
  proof -
paulson@19954
   399
    fix i and j::nat
paulson@19954
   400
    assume less: "i<j"
wenzelm@46575
   401
    then have "(s j, s i) \<in> r" by (rule s [of i j])
wenzelm@46575
   402
    then show "\<exists>k. (s j, s i) \<in> T k & k<n" by (auto simp add: r)
wenzelm@46575
   403
  qed
paulson@19954
   404
  have trless: "!!i j. i\<noteq>j ==> transition_idx s T {i,j} < n"
paulson@19954
   405
    apply (auto simp add: linorder_neq_iff)
wenzelm@46575
   406
    apply (blast dest: s_in_T transition_idx_less)
wenzelm@46575
   407
    apply (subst insert_commute)
wenzelm@46575
   408
    apply (blast dest: s_in_T transition_idx_less)
paulson@19954
   409
    done
paulson@19954
   410
  have
wenzelm@46575
   411
   "\<exists>K k. K \<subseteq> UNIV & infinite K & k < n &
paulson@19954
   412
          (\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k)"
traytel@54580
   413
    by (rule Ramsey2) (auto intro: trless infinite_UNIV_nat)
wenzelm@46575
   414
  then obtain K and k
paulson@19954
   415
    where infK: "infinite K" and less: "k < n" and
paulson@19954
   416
          allk: "\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k"
paulson@19954
   417
    by auto
paulson@19954
   418
  have "\<forall>m. (s (enumerate K (Suc m)), s(enumerate K m)) \<in> T k"
paulson@19954
   419
  proof
paulson@19954
   420
    fix m::nat
paulson@19954
   421
    let ?j = "enumerate K (Suc m)"
paulson@19954
   422
    let ?i = "enumerate K m"
wenzelm@46575
   423
    have jK: "?j \<in> K" by (simp add: enumerate_in_set infK)
wenzelm@46575
   424
    have iK: "?i \<in> K" by (simp add: enumerate_in_set infK)
wenzelm@46575
   425
    have ij: "?i < ?j" by (simp add: enumerate_step infK)
wenzelm@46575
   426
    have ijk: "transition_idx s T {?i,?j} = k" using iK jK ij
paulson@19954
   427
      by (simp add: allk)
wenzelm@46575
   428
    obtain k' where "(s ?j, s ?i) \<in> T k'" "k'<n"
paulson@19954
   429
      using s_in_T [OF ij] by blast
wenzelm@46575
   430
    then show "(s ?j, s ?i) \<in> T k"
wenzelm@46575
   431
      by (simp add: ijk [symmetric] transition_idx_in ij)
paulson@19954
   432
  qed
wenzelm@46575
   433
  then have "~ wf(T k)" by (force simp add: wf_iff_no_infinite_down_chain)
wenzelm@46575
   434
  then show False using wfT less by blast
paulson@19954
   435
qed
paulson@19954
   436
paulson@19944
   437
end