src/HOL/HOLCF/Porder.thy
author huffman
Sat Nov 27 16:08:10 2010 -0800 (2010-11-27)
changeset 40774 0437dbc127b3
parent 40771 src/HOLCF/Porder.thy@1c6f7d4b110e
child 41182 717404c7d59a
permissions -rw-r--r--
moved directory src/HOLCF to src/HOL/HOLCF;
added HOLCF theories to src/HOL/IsaMakefile;
huffman@15600
     1
(*  Title:      HOLCF/Porder.thy
huffman@25773
     2
    Author:     Franz Regensburger and Brian Huffman
nipkow@243
     3
*)
nipkow@243
     4
huffman@15587
     5
header {* Partial orders *}
huffman@15576
     6
huffman@15577
     7
theory Porder
huffman@27317
     8
imports Main
huffman@15577
     9
begin
huffman@15576
    10
huffman@15587
    11
subsection {* Type class for partial orders *}
huffman@15587
    12
huffman@31076
    13
class below =
huffman@31076
    14
  fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
haftmann@31071
    15
begin
huffman@15576
    16
huffman@23284
    17
notation
huffman@40436
    18
  below (infix "<<" 50)
huffman@15576
    19
huffman@23284
    20
notation (xsymbols)
huffman@40436
    21
  below (infix "\<sqsubseteq>" 50)
huffman@15576
    22
huffman@31076
    23
lemma below_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
haftmann@31071
    24
  by (rule subst)
haftmann@31071
    25
huffman@31076
    26
lemma eq_below_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
haftmann@31071
    27
  by (rule ssubst)
haftmann@31071
    28
haftmann@31071
    29
end
haftmann@31071
    30
huffman@31076
    31
class po = below +
huffman@31076
    32
  assumes below_refl [iff]: "x \<sqsubseteq> x"
huffman@31076
    33
  assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
huffman@31076
    34
  assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
haftmann@31071
    35
begin
huffman@15576
    36
huffman@40432
    37
lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
huffman@40432
    38
  by simp
huffman@40432
    39
huffman@31076
    40
lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
huffman@31076
    41
  by (rule below_trans [OF below_trans])
huffman@17810
    42
haftmann@31071
    43
lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
huffman@31076
    44
  by (fast intro!: below_antisym)
huffman@15576
    45
huffman@31076
    46
lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
huffman@31076
    47
  by (rule below_trans)
huffman@18647
    48
huffman@31076
    49
lemma not_below2not_eq: "\<not> x \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
haftmann@31071
    50
  by auto
haftmann@31071
    51
haftmann@31071
    52
end
huffman@18647
    53
huffman@18647
    54
lemmas HOLCF_trans_rules [trans] =
huffman@31076
    55
  below_trans
huffman@31076
    56
  below_antisym
huffman@31076
    57
  below_eq_trans
huffman@31076
    58
  eq_below_trans
huffman@18647
    59
haftmann@31071
    60
context po
haftmann@31071
    61
begin
haftmann@31071
    62
huffman@25777
    63
subsection {* Upper bounds *}
huffman@18071
    64
huffman@40436
    65
definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<|" 55) where
huffman@39968
    66
  "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"
huffman@18071
    67
huffman@25777
    68
lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
haftmann@31071
    69
  by (simp add: is_ub_def)
huffman@25777
    70
huffman@25777
    71
lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
haftmann@31071
    72
  by (simp add: is_ub_def)
huffman@25777
    73
huffman@25777
    74
lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
haftmann@31071
    75
  unfolding is_ub_def by fast
huffman@25777
    76
huffman@25777
    77
lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
haftmann@31071
    78
  unfolding is_ub_def by fast
huffman@25777
    79
huffman@25777
    80
lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
haftmann@31071
    81
  unfolding is_ub_def by fast
huffman@25777
    82
huffman@25777
    83
lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
haftmann@31071
    84
  unfolding is_ub_def by fast
huffman@25777
    85
huffman@25828
    86
lemma is_ub_empty [simp]: "{} <| u"
haftmann@31071
    87
  unfolding is_ub_def by fast
huffman@25828
    88
huffman@25828
    89
lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
haftmann@31071
    90
  unfolding is_ub_def by fast
huffman@25828
    91
huffman@25828
    92
lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
huffman@31076
    93
  unfolding is_ub_def by (fast intro: below_trans)
huffman@25828
    94
huffman@25777
    95
subsection {* Least upper bounds *}
huffman@25777
    96
huffman@40436
    97
definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<<|" 55) where
haftmann@31071
    98
  "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
huffman@18071
    99
haftmann@31071
   100
definition lub :: "'a set \<Rightarrow> 'a" where
wenzelm@25131
   101
  "lub S = (THE x. S <<| x)"
nipkow@243
   102
haftmann@31071
   103
end
haftmann@31071
   104
huffman@25777
   105
syntax
huffman@25777
   106
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)
huffman@25777
   107
huffman@25777
   108
syntax (xsymbols)
huffman@25777
   109
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)
huffman@25777
   110
huffman@25777
   111
translations
huffman@25777
   112
  "LUB x:A. t" == "CONST lub ((%x. t) ` A)"
huffman@25777
   113
haftmann@31071
   114
context po
haftmann@31071
   115
begin
haftmann@31071
   116
wenzelm@21524
   117
abbreviation
wenzelm@21524
   118
  Lub  (binder "LUB " 10) where
wenzelm@21524
   119
  "LUB n. t n == lub (range t)"
oheimb@2394
   120
wenzelm@21524
   121
notation (xsymbols)
wenzelm@21524
   122
  Lub  (binder "\<Squnion> " 10)
nipkow@243
   123
huffman@25813
   124
text {* access to some definition as inference rule *}
huffman@25813
   125
huffman@25813
   126
lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
haftmann@31071
   127
  unfolding is_lub_def by fast
huffman@25813
   128
huffman@40771
   129
lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
haftmann@31071
   130
  unfolding is_lub_def by fast
huffman@25813
   131
huffman@25813
   132
lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
haftmann@31071
   133
  unfolding is_lub_def by fast
huffman@25813
   134
huffman@39969
   135
lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
huffman@39969
   136
  unfolding is_lub_def is_ub_def by (metis below_trans)
huffman@39969
   137
huffman@15576
   138
text {* lubs are unique *}
huffman@15562
   139
huffman@40771
   140
lemma is_lub_unique: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
huffman@40771
   141
  unfolding is_lub_def is_ub_def by (blast intro: below_antisym)
huffman@15562
   142
huffman@15576
   143
text {* technical lemmas about @{term lub} and @{term is_lub} *}
huffman@15562
   144
huffman@40771
   145
lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
huffman@40771
   146
  unfolding lub_def by (rule theI [OF _ is_lub_unique])
huffman@15562
   147
huffman@40771
   148
lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
huffman@40771
   149
  by (rule is_lub_unique [OF is_lub_lub])
huffman@15562
   150
huffman@25780
   151
lemma is_lub_singleton: "{x} <<| x"
haftmann@31071
   152
  by (simp add: is_lub_def)
huffman@25780
   153
huffman@17810
   154
lemma lub_singleton [simp]: "lub {x} = x"
huffman@40771
   155
  by (rule is_lub_singleton [THEN lub_eqI])
huffman@25780
   156
huffman@25780
   157
lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
haftmann@31071
   158
  by (simp add: is_lub_def)
huffman@25780
   159
huffman@25780
   160
lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
huffman@40771
   161
  by (rule is_lub_bin [THEN lub_eqI])
huffman@15562
   162
huffman@25813
   163
lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
haftmann@31071
   164
  by (erule is_lubI, erule (1) is_ubD)
huffman@15562
   165
huffman@25813
   166
lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
huffman@40771
   167
  by (rule is_lub_maximal [THEN lub_eqI])
nipkow@243
   168
huffman@25695
   169
subsection {* Countable chains *}
huffman@25695
   170
haftmann@31071
   171
definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
huffman@25695
   172
  -- {* Here we use countable chains and I prefer to code them as functions! *}
huffman@25922
   173
  "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
huffman@25922
   174
huffman@25922
   175
lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
haftmann@31071
   176
  unfolding chain_def by fast
huffman@25922
   177
huffman@25922
   178
lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
haftmann@31071
   179
  unfolding chain_def by fast
huffman@25695
   180
huffman@25695
   181
text {* chains are monotone functions *}
huffman@25695
   182
huffman@27317
   183
lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
huffman@31076
   184
  by (erule less_Suc_induct, erule chainE, erule below_trans)
huffman@25695
   185
huffman@27317
   186
lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
haftmann@31071
   187
  by (cases "i = j", simp, simp add: chain_mono_less)
huffman@15562
   188
huffman@17810
   189
lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
haftmann@31071
   190
  by (rule chainI, simp, erule chainE)
huffman@15562
   191
huffman@15576
   192
text {* technical lemmas about (least) upper bounds of chains *}
huffman@15562
   193
huffman@40771
   194
lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
haftmann@31071
   195
  by (rule is_lubD1 [THEN ub_rangeD])
huffman@15562
   196
huffman@16318
   197
lemma is_ub_range_shift:
huffman@16318
   198
  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
huffman@16318
   199
apply (rule iffI)
huffman@16318
   200
apply (rule ub_rangeI)
huffman@31076
   201
apply (rule_tac y="S (i + j)" in below_trans)
huffman@25922
   202
apply (erule chain_mono)
huffman@16318
   203
apply (rule le_add1)
huffman@16318
   204
apply (erule ub_rangeD)
huffman@16318
   205
apply (rule ub_rangeI)
huffman@16318
   206
apply (erule ub_rangeD)
huffman@16318
   207
done
huffman@16318
   208
huffman@16318
   209
lemma is_lub_range_shift:
huffman@16318
   210
  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
haftmann@31071
   211
  by (simp add: is_lub_def is_ub_range_shift)
huffman@16318
   212
huffman@25695
   213
text {* the lub of a constant chain is the constant *}
huffman@25695
   214
huffman@25695
   215
lemma chain_const [simp]: "chain (\<lambda>i. c)"
haftmann@31071
   216
  by (simp add: chainI)
huffman@25695
   217
huffman@40771
   218
lemma is_lub_const: "range (\<lambda>x. c) <<| c"
huffman@25695
   219
by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
huffman@25695
   220
huffman@40771
   221
lemma lub_const [simp]: "(\<Squnion>i. c) = c"
huffman@40771
   222
  by (rule is_lub_const [THEN lub_eqI])
huffman@25695
   223
huffman@25695
   224
subsection {* Finite chains *}
huffman@25695
   225
haftmann@31071
   226
definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
huffman@25695
   227
  -- {* finite chains, needed for monotony of continuous functions *}
haftmann@31071
   228
  "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
huffman@25695
   229
haftmann@31071
   230
definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
huffman@25695
   231
  "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
huffman@25695
   232
huffman@15576
   233
text {* results about finite chains *}
huffman@15562
   234
huffman@25878
   235
lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
haftmann@31071
   236
  unfolding max_in_chain_def by fast
huffman@25878
   237
huffman@25878
   238
lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
haftmann@31071
   239
  unfolding max_in_chain_def by fast
huffman@25878
   240
huffman@27317
   241
lemma finite_chainI:
huffman@27317
   242
  "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
haftmann@31071
   243
  unfolding finite_chain_def by fast
huffman@27317
   244
huffman@27317
   245
lemma finite_chainE:
huffman@27317
   246
  "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
haftmann@31071
   247
  unfolding finite_chain_def by fast
huffman@27317
   248
huffman@17810
   249
lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
huffman@15562
   250
apply (rule is_lubI)
huffman@17810
   251
apply (rule ub_rangeI, rename_tac j)
huffman@17810
   252
apply (rule_tac x=i and y=j in linorder_le_cases)
huffman@25878
   253
apply (drule (1) max_in_chainD, simp)
huffman@25922
   254
apply (erule (1) chain_mono)
huffman@15562
   255
apply (erule ub_rangeD)
huffman@15562
   256
done
huffman@15562
   257
wenzelm@25131
   258
lemma lub_finch2:
huffman@27317
   259
  "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
huffman@27317
   260
apply (erule finite_chainE)
huffman@27317
   261
apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
huffman@17810
   262
apply (erule (1) lub_finch1)
huffman@15562
   263
done
huffman@15562
   264
huffman@19621
   265
lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
huffman@27317
   266
 apply (erule finite_chainE)
huffman@27317
   267
 apply (rule_tac B="Y ` {..i}" in finite_subset)
huffman@19621
   268
  apply (rule subsetI)
huffman@19621
   269
  apply (erule rangeE, rename_tac j)
huffman@19621
   270
  apply (rule_tac x=i and y=j in linorder_le_cases)
huffman@19621
   271
   apply (subgoal_tac "Y j = Y i", simp)
huffman@19621
   272
   apply (simp add: max_in_chain_def)
huffman@19621
   273
  apply simp
huffman@27317
   274
 apply simp
huffman@19621
   275
done
huffman@19621
   276
huffman@27317
   277
lemma finite_range_has_max:
huffman@27317
   278
  fixes f :: "nat \<Rightarrow> 'a" and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
huffman@27317
   279
  assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
huffman@27317
   280
  assumes finite_range: "finite (range f)"
huffman@27317
   281
  shows "\<exists>k. \<forall>i. r (f i) (f k)"
huffman@27317
   282
proof (intro exI allI)
huffman@27317
   283
  fix i :: nat
huffman@27317
   284
  let ?j = "LEAST k. f k = f i"
huffman@27317
   285
  let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
huffman@27317
   286
  have "?j \<le> ?k"
huffman@27317
   287
  proof (rule Max_ge)
huffman@27317
   288
    show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
huffman@27317
   289
      using finite_range by (rule finite_imageI)
huffman@27317
   290
    show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
huffman@27317
   291
      by (intro imageI rangeI)
huffman@27317
   292
  qed
huffman@27317
   293
  hence "r (f ?j) (f ?k)"
huffman@27317
   294
    by (rule mono)
huffman@27317
   295
  also have "f ?j = f i"
huffman@27317
   296
    by (rule LeastI, rule refl)
huffman@27317
   297
  finally show "r (f i) (f ?k)" .
huffman@27317
   298
qed
huffman@27317
   299
huffman@19621
   300
lemma finite_range_imp_finch:
huffman@19621
   301
  "\<lbrakk>chain Y; finite (range Y)\<rbrakk> \<Longrightarrow> finite_chain Y"
huffman@27317
   302
 apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
huffman@27317
   303
  apply (erule exE)
huffman@27317
   304
  apply (rule finite_chainI, assumption)
huffman@27317
   305
  apply (rule max_in_chainI)
huffman@31076
   306
  apply (rule below_antisym)
huffman@27317
   307
   apply (erule (1) chain_mono)
huffman@27317
   308
  apply (erule spec)
huffman@27317
   309
 apply (rule finite_range_has_max)
huffman@27317
   310
  apply (erule (1) chain_mono)
huffman@27317
   311
 apply assumption
huffman@19621
   312
done
huffman@19621
   313
huffman@17810
   314
lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
haftmann@31071
   315
  by (rule chainI, simp)
huffman@17810
   316
huffman@17810
   317
lemma bin_chainmax:
huffman@17810
   318
  "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
haftmann@31071
   319
  unfolding max_in_chain_def by simp
huffman@15562
   320
huffman@40771
   321
lemma is_lub_bin_chain:
huffman@17810
   322
  "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
huffman@17810
   323
apply (frule bin_chain)
huffman@17810
   324
apply (drule bin_chainmax)
huffman@17810
   325
apply (drule (1) lub_finch1)
huffman@17810
   326
apply simp
huffman@15562
   327
done
huffman@15562
   328
huffman@15576
   329
text {* the maximal element in a chain is its lub *}
huffman@15562
   330
huffman@17810
   331
lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
huffman@40771
   332
  by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)
huffman@15562
   333
huffman@18071
   334
end
haftmann@31071
   335
huffman@31076
   336
end