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