src/HOLCF/Porder.thy
author haftmann
Fri Jun 19 21:08:07 2009 +0200 (2009-06-19)
changeset 31726 ffd2dc631d88
parent 31076 99fe356cbbc2
child 39968 d841744718fe
permissions -rw-r--r--
merged
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@31076
    18
  below (infixl "<<" 55)
huffman@15576
    19
huffman@23284
    20
notation (xsymbols)
huffman@31076
    21
  below (infixl "\<sqsubseteq>" 55)
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@15576
    37
text {* minimal fixes least element *}
huffman@15576
    38
haftmann@31071
    39
lemma minimal2UU[OF allI] : "\<forall>x. uu \<sqsubseteq> x \<Longrightarrow> uu = (THE u. \<forall>y. u \<sqsubseteq> y)"
huffman@31076
    40
  by (blast intro: theI2 below_antisym)
huffman@15576
    41
huffman@15576
    42
text {* the reverse law of anti-symmetry of @{term "op <<"} *}
huffman@31076
    43
(* Is this rule ever useful? *)
huffman@31076
    44
lemma below_antisym_inverse: "x = y \<Longrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
haftmann@31071
    45
  by simp
huffman@15576
    46
huffman@31076
    47
lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
huffman@31076
    48
  by (rule below_trans [OF below_trans])
huffman@17810
    49
haftmann@31071
    50
lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
huffman@31076
    51
  by (fast intro!: below_antisym)
huffman@15576
    52
huffman@31076
    53
lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
huffman@31076
    54
  by (rule below_trans)
huffman@18647
    55
huffman@31076
    56
lemma not_below2not_eq: "\<not> x \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
haftmann@31071
    57
  by auto
haftmann@31071
    58
haftmann@31071
    59
end
huffman@18647
    60
huffman@18647
    61
lemmas HOLCF_trans_rules [trans] =
huffman@31076
    62
  below_trans
huffman@31076
    63
  below_antisym
huffman@31076
    64
  below_eq_trans
huffman@31076
    65
  eq_below_trans
huffman@18647
    66
haftmann@31071
    67
context po
haftmann@31071
    68
begin
haftmann@31071
    69
huffman@25777
    70
subsection {* Upper bounds *}
huffman@18071
    71
haftmann@31071
    72
definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<|" 55) where
haftmann@31071
    73
  "S <| x \<longleftrightarrow> (\<forall>y. y \<in> S \<longrightarrow> y \<sqsubseteq> x)"
huffman@18071
    74
huffman@25777
    75
lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
haftmann@31071
    76
  by (simp add: is_ub_def)
huffman@25777
    77
huffman@25777
    78
lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
haftmann@31071
    79
  by (simp add: is_ub_def)
huffman@25777
    80
huffman@25777
    81
lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
haftmann@31071
    82
  unfolding is_ub_def by fast
huffman@25777
    83
huffman@25777
    84
lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
haftmann@31071
    85
  unfolding is_ub_def by fast
huffman@25777
    86
huffman@25777
    87
lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
haftmann@31071
    88
  unfolding is_ub_def by fast
huffman@25777
    89
huffman@25777
    90
lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
haftmann@31071
    91
  unfolding is_ub_def by fast
huffman@25777
    92
huffman@25828
    93
lemma is_ub_empty [simp]: "{} <| u"
haftmann@31071
    94
  unfolding is_ub_def by fast
huffman@25828
    95
huffman@25828
    96
lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
haftmann@31071
    97
  unfolding is_ub_def by fast
huffman@25828
    98
huffman@25828
    99
lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
huffman@31076
   100
  unfolding is_ub_def by (fast intro: below_trans)
huffman@25828
   101
huffman@25777
   102
subsection {* Least upper bounds *}
huffman@25777
   103
haftmann@31071
   104
definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<<|" 55) where
haftmann@31071
   105
  "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
huffman@18071
   106
haftmann@31071
   107
definition lub :: "'a set \<Rightarrow> 'a" where
wenzelm@25131
   108
  "lub S = (THE x. S <<| x)"
nipkow@243
   109
haftmann@31071
   110
end
haftmann@31071
   111
huffman@25777
   112
syntax
huffman@25777
   113
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)
huffman@25777
   114
huffman@25777
   115
syntax (xsymbols)
huffman@25777
   116
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)
huffman@25777
   117
huffman@25777
   118
translations
huffman@25777
   119
  "LUB x:A. t" == "CONST lub ((%x. t) ` A)"
huffman@25777
   120
haftmann@31071
   121
context po
haftmann@31071
   122
begin
haftmann@31071
   123
wenzelm@21524
   124
abbreviation
wenzelm@21524
   125
  Lub  (binder "LUB " 10) where
wenzelm@21524
   126
  "LUB n. t n == lub (range t)"
oheimb@2394
   127
wenzelm@21524
   128
notation (xsymbols)
wenzelm@21524
   129
  Lub  (binder "\<Squnion> " 10)
nipkow@243
   130
huffman@25813
   131
text {* access to some definition as inference rule *}
huffman@25813
   132
huffman@25813
   133
lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
haftmann@31071
   134
  unfolding is_lub_def by fast
huffman@25813
   135
huffman@25813
   136
lemma is_lub_lub: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
haftmann@31071
   137
  unfolding is_lub_def by fast
huffman@25813
   138
huffman@25813
   139
lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
haftmann@31071
   140
  unfolding is_lub_def by fast
huffman@25813
   141
huffman@15576
   142
text {* lubs are unique *}
huffman@15562
   143
huffman@17810
   144
lemma unique_lub: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
huffman@15562
   145
apply (unfold is_lub_def is_ub_def)
huffman@31076
   146
apply (blast intro: below_antisym)
huffman@15562
   147
done
huffman@15562
   148
huffman@15576
   149
text {* technical lemmas about @{term lub} and @{term is_lub} *}
huffman@15562
   150
huffman@17810
   151
lemma lubI: "M <<| x \<Longrightarrow> M <<| lub M"
huffman@15930
   152
apply (unfold lub_def)
huffman@17810
   153
apply (rule theI)
huffman@15930
   154
apply assumption
huffman@17810
   155
apply (erule (1) unique_lub)
huffman@15562
   156
done
huffman@15562
   157
huffman@17810
   158
lemma thelubI: "M <<| l \<Longrightarrow> lub M = l"
haftmann@31071
   159
  by (rule unique_lub [OF lubI])
huffman@15562
   160
huffman@25780
   161
lemma is_lub_singleton: "{x} <<| x"
haftmann@31071
   162
  by (simp add: is_lub_def)
huffman@25780
   163
huffman@17810
   164
lemma lub_singleton [simp]: "lub {x} = x"
haftmann@31071
   165
  by (rule thelubI [OF is_lub_singleton])
huffman@25780
   166
huffman@25780
   167
lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
haftmann@31071
   168
  by (simp add: is_lub_def)
huffman@25780
   169
huffman@25780
   170
lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
haftmann@31071
   171
  by (rule is_lub_bin [THEN thelubI])
huffman@15562
   172
huffman@25813
   173
lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
haftmann@31071
   174
  by (erule is_lubI, erule (1) is_ubD)
huffman@15562
   175
huffman@25813
   176
lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
haftmann@31071
   177
  by (rule is_lub_maximal [THEN thelubI])
nipkow@243
   178
huffman@25695
   179
subsection {* Countable chains *}
huffman@25695
   180
haftmann@31071
   181
definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
huffman@25695
   182
  -- {* Here we use countable chains and I prefer to code them as functions! *}
huffman@25922
   183
  "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
huffman@25922
   184
huffman@25922
   185
lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
haftmann@31071
   186
  unfolding chain_def by fast
huffman@25922
   187
huffman@25922
   188
lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
haftmann@31071
   189
  unfolding chain_def by fast
huffman@25695
   190
huffman@25695
   191
text {* chains are monotone functions *}
huffman@25695
   192
huffman@27317
   193
lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
huffman@31076
   194
  by (erule less_Suc_induct, erule chainE, erule below_trans)
huffman@25695
   195
huffman@27317
   196
lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
haftmann@31071
   197
  by (cases "i = j", simp, simp add: chain_mono_less)
huffman@15562
   198
huffman@17810
   199
lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
haftmann@31071
   200
  by (rule chainI, simp, erule chainE)
huffman@15562
   201
huffman@15576
   202
text {* technical lemmas about (least) upper bounds of chains *}
huffman@15562
   203
huffman@17810
   204
lemma is_ub_lub: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
haftmann@31071
   205
  by (rule is_lubD1 [THEN ub_rangeD])
huffman@15562
   206
huffman@16318
   207
lemma is_ub_range_shift:
huffman@16318
   208
  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
huffman@16318
   209
apply (rule iffI)
huffman@16318
   210
apply (rule ub_rangeI)
huffman@31076
   211
apply (rule_tac y="S (i + j)" in below_trans)
huffman@25922
   212
apply (erule chain_mono)
huffman@16318
   213
apply (rule le_add1)
huffman@16318
   214
apply (erule ub_rangeD)
huffman@16318
   215
apply (rule ub_rangeI)
huffman@16318
   216
apply (erule ub_rangeD)
huffman@16318
   217
done
huffman@16318
   218
huffman@16318
   219
lemma is_lub_range_shift:
huffman@16318
   220
  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
haftmann@31071
   221
  by (simp add: is_lub_def is_ub_range_shift)
huffman@16318
   222
huffman@25695
   223
text {* the lub of a constant chain is the constant *}
huffman@25695
   224
huffman@25695
   225
lemma chain_const [simp]: "chain (\<lambda>i. c)"
haftmann@31071
   226
  by (simp add: chainI)
huffman@25695
   227
huffman@25695
   228
lemma lub_const: "range (\<lambda>x. c) <<| c"
huffman@25695
   229
by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
huffman@25695
   230
huffman@25695
   231
lemma thelub_const [simp]: "(\<Squnion>i. c) = c"
haftmann@31071
   232
  by (rule lub_const [THEN thelubI])
huffman@25695
   233
huffman@25695
   234
subsection {* Finite chains *}
huffman@25695
   235
haftmann@31071
   236
definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
huffman@25695
   237
  -- {* finite chains, needed for monotony of continuous functions *}
haftmann@31071
   238
  "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
huffman@25695
   239
haftmann@31071
   240
definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
huffman@25695
   241
  "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
huffman@25695
   242
huffman@15576
   243
text {* results about finite chains *}
huffman@15562
   244
huffman@25878
   245
lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
haftmann@31071
   246
  unfolding max_in_chain_def by fast
huffman@25878
   247
huffman@25878
   248
lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
haftmann@31071
   249
  unfolding max_in_chain_def by fast
huffman@25878
   250
huffman@27317
   251
lemma finite_chainI:
huffman@27317
   252
  "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
haftmann@31071
   253
  unfolding finite_chain_def by fast
huffman@27317
   254
huffman@27317
   255
lemma finite_chainE:
huffman@27317
   256
  "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
haftmann@31071
   257
  unfolding finite_chain_def by fast
huffman@27317
   258
huffman@17810
   259
lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
huffman@15562
   260
apply (rule is_lubI)
huffman@17810
   261
apply (rule ub_rangeI, rename_tac j)
huffman@17810
   262
apply (rule_tac x=i and y=j in linorder_le_cases)
huffman@25878
   263
apply (drule (1) max_in_chainD, simp)
huffman@25922
   264
apply (erule (1) chain_mono)
huffman@15562
   265
apply (erule ub_rangeD)
huffman@15562
   266
done
huffman@15562
   267
wenzelm@25131
   268
lemma lub_finch2:
huffman@27317
   269
  "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
huffman@27317
   270
apply (erule finite_chainE)
huffman@27317
   271
apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
huffman@17810
   272
apply (erule (1) lub_finch1)
huffman@15562
   273
done
huffman@15562
   274
huffman@19621
   275
lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
huffman@27317
   276
 apply (erule finite_chainE)
huffman@27317
   277
 apply (rule_tac B="Y ` {..i}" in finite_subset)
huffman@19621
   278
  apply (rule subsetI)
huffman@19621
   279
  apply (erule rangeE, rename_tac j)
huffman@19621
   280
  apply (rule_tac x=i and y=j in linorder_le_cases)
huffman@19621
   281
   apply (subgoal_tac "Y j = Y i", simp)
huffman@19621
   282
   apply (simp add: max_in_chain_def)
huffman@19621
   283
  apply simp
huffman@27317
   284
 apply simp
huffman@19621
   285
done
huffman@19621
   286
huffman@27317
   287
lemma finite_range_has_max:
huffman@27317
   288
  fixes f :: "nat \<Rightarrow> 'a" and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
huffman@27317
   289
  assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
huffman@27317
   290
  assumes finite_range: "finite (range f)"
huffman@27317
   291
  shows "\<exists>k. \<forall>i. r (f i) (f k)"
huffman@27317
   292
proof (intro exI allI)
huffman@27317
   293
  fix i :: nat
huffman@27317
   294
  let ?j = "LEAST k. f k = f i"
huffman@27317
   295
  let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
huffman@27317
   296
  have "?j \<le> ?k"
huffman@27317
   297
  proof (rule Max_ge)
huffman@27317
   298
    show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
huffman@27317
   299
      using finite_range by (rule finite_imageI)
huffman@27317
   300
    show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
huffman@27317
   301
      by (intro imageI rangeI)
huffman@27317
   302
  qed
huffman@27317
   303
  hence "r (f ?j) (f ?k)"
huffman@27317
   304
    by (rule mono)
huffman@27317
   305
  also have "f ?j = f i"
huffman@27317
   306
    by (rule LeastI, rule refl)
huffman@27317
   307
  finally show "r (f i) (f ?k)" .
huffman@27317
   308
qed
huffman@27317
   309
huffman@19621
   310
lemma finite_range_imp_finch:
huffman@19621
   311
  "\<lbrakk>chain Y; finite (range Y)\<rbrakk> \<Longrightarrow> finite_chain Y"
huffman@27317
   312
 apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
huffman@27317
   313
  apply (erule exE)
huffman@27317
   314
  apply (rule finite_chainI, assumption)
huffman@27317
   315
  apply (rule max_in_chainI)
huffman@31076
   316
  apply (rule below_antisym)
huffman@27317
   317
   apply (erule (1) chain_mono)
huffman@27317
   318
  apply (erule spec)
huffman@27317
   319
 apply (rule finite_range_has_max)
huffman@27317
   320
  apply (erule (1) chain_mono)
huffman@27317
   321
 apply assumption
huffman@19621
   322
done
huffman@19621
   323
huffman@17810
   324
lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
haftmann@31071
   325
  by (rule chainI, simp)
huffman@17810
   326
huffman@17810
   327
lemma bin_chainmax:
huffman@17810
   328
  "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
haftmann@31071
   329
  unfolding max_in_chain_def by simp
huffman@15562
   330
huffman@17810
   331
lemma lub_bin_chain:
huffman@17810
   332
  "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
huffman@17810
   333
apply (frule bin_chain)
huffman@17810
   334
apply (drule bin_chainmax)
huffman@17810
   335
apply (drule (1) lub_finch1)
huffman@17810
   336
apply simp
huffman@15562
   337
done
huffman@15562
   338
huffman@15576
   339
text {* the maximal element in a chain is its lub *}
huffman@15562
   340
huffman@17810
   341
lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
haftmann@31071
   342
  by (blast dest: ub_rangeD intro: thelubI is_lubI ub_rangeI)
huffman@15562
   343
huffman@25773
   344
subsection {* Directed sets *}
huffman@25773
   345
haftmann@31071
   346
definition directed :: "'a set \<Rightarrow> bool" where
haftmann@31071
   347
  "directed S \<longleftrightarrow> (\<exists>x. x \<in> S) \<and> (\<forall>x\<in>S. \<forall>y\<in>S. \<exists>z\<in>S. x \<sqsubseteq> z \<and> y \<sqsubseteq> z)"
huffman@25773
   348
huffman@25773
   349
lemma directedI:
huffman@25773
   350
  assumes 1: "\<exists>z. z \<in> S"
huffman@25773
   351
  assumes 2: "\<And>x y. \<lbrakk>x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> \<exists>z\<in>S. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
huffman@25773
   352
  shows "directed S"
haftmann@31071
   353
  unfolding directed_def using prems by fast
huffman@25773
   354
huffman@25773
   355
lemma directedD1: "directed S \<Longrightarrow> \<exists>z. z \<in> S"
haftmann@31071
   356
  unfolding directed_def by fast
huffman@25773
   357
huffman@25773
   358
lemma directedD2: "\<lbrakk>directed S; x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> \<exists>z\<in>S. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
haftmann@31071
   359
  unfolding directed_def by fast
huffman@25773
   360
huffman@25780
   361
lemma directedE1:
huffman@25780
   362
  assumes S: "directed S"
huffman@25780
   363
  obtains z where "z \<in> S"
haftmann@31071
   364
  by (insert directedD1 [OF S], fast)
huffman@25780
   365
huffman@25780
   366
lemma directedE2:
huffman@25780
   367
  assumes S: "directed S"
huffman@25780
   368
  assumes x: "x \<in> S" and y: "y \<in> S"
huffman@25780
   369
  obtains z where "z \<in> S" "x \<sqsubseteq> z" "y \<sqsubseteq> z"
haftmann@31071
   370
  by (insert directedD2 [OF S x y], fast)
huffman@25780
   371
huffman@25773
   372
lemma directed_finiteI:
huffman@25828
   373
  assumes U: "\<And>U. \<lbrakk>finite U; U \<subseteq> S\<rbrakk> \<Longrightarrow> \<exists>z\<in>S. U <| z"
huffman@25773
   374
  shows "directed S"
huffman@25773
   375
proof (rule directedI)
huffman@25773
   376
  have "finite {}" and "{} \<subseteq> S" by simp_all
huffman@25828
   377
  hence "\<exists>z\<in>S. {} <| z" by (rule U)
huffman@25773
   378
  thus "\<exists>z. z \<in> S" by simp
huffman@25773
   379
next
huffman@25773
   380
  fix x y
huffman@25773
   381
  assume "x \<in> S" and "y \<in> S"
huffman@25773
   382
  hence "finite {x, y}" and "{x, y} \<subseteq> S" by simp_all
huffman@25828
   383
  hence "\<exists>z\<in>S. {x, y} <| z" by (rule U)
huffman@25773
   384
  thus "\<exists>z\<in>S. x \<sqsubseteq> z \<and> y \<sqsubseteq> z" by simp
huffman@25773
   385
qed
huffman@25773
   386
huffman@25773
   387
lemma directed_finiteD:
huffman@25773
   388
  assumes S: "directed S"
huffman@25828
   389
  shows "\<lbrakk>finite U; U \<subseteq> S\<rbrakk> \<Longrightarrow> \<exists>z\<in>S. U <| z"
huffman@25828
   390
proof (induct U set: finite)
huffman@25828
   391
  case empty
huffman@25828
   392
  from S have "\<exists>z. z \<in> S" by (rule directedD1)
huffman@25828
   393
  thus "\<exists>z\<in>S. {} <| z" by simp
huffman@25828
   394
next
huffman@25828
   395
  case (insert x F)
huffman@25828
   396
  from `insert x F \<subseteq> S`
huffman@25828
   397
  have xS: "x \<in> S" and FS: "F \<subseteq> S" by simp_all
huffman@25828
   398
  from FS have "\<exists>y\<in>S. F <| y" by fact
huffman@25828
   399
  then obtain y where yS: "y \<in> S" and Fy: "F <| y" ..
huffman@25828
   400
  obtain z where zS: "z \<in> S" and xz: "x \<sqsubseteq> z" and yz: "y \<sqsubseteq> z"
huffman@25828
   401
    using S xS yS by (rule directedE2)
huffman@25828
   402
  from Fy yz have "F <| z" by (rule is_ub_upward)
huffman@25828
   403
  with xz have "insert x F <| z" by simp
huffman@25828
   404
  with zS show "\<exists>z\<in>S. insert x F <| z" ..
huffman@25773
   405
qed
huffman@25773
   406
huffman@25813
   407
lemma not_directed_empty [simp]: "\<not> directed {}"
haftmann@31071
   408
  by (rule notI, drule directedD1, simp)
huffman@25773
   409
huffman@25773
   410
lemma directed_singleton: "directed {x}"
haftmann@31071
   411
  by (rule directedI, auto)
huffman@25773
   412
huffman@25773
   413
lemma directed_bin: "x \<sqsubseteq> y \<Longrightarrow> directed {x, y}"
haftmann@31071
   414
  by (rule directedI, auto)
huffman@25773
   415
huffman@25773
   416
lemma directed_chain: "chain S \<Longrightarrow> directed (range S)"
huffman@25773
   417
apply (rule directedI)
huffman@25773
   418
apply (rule_tac x="S 0" in exI, simp)
huffman@25773
   419
apply (clarify, rename_tac m n)
huffman@25773
   420
apply (rule_tac x="S (max m n)" in bexI)
huffman@25922
   421
apply (simp add: chain_mono)
huffman@25773
   422
apply simp
huffman@25773
   423
done
huffman@25773
   424
haftmann@31071
   425
text {* lemmata for improved admissibility introdution rule *}
haftmann@31071
   426
haftmann@31071
   427
lemma infinite_chain_adm_lemma:
haftmann@31071
   428
  "\<lbrakk>chain Y; \<forall>i. P (Y i);  
haftmann@31071
   429
    \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
haftmann@31071
   430
      \<Longrightarrow> P (\<Squnion>i. Y i)"
haftmann@31071
   431
apply (case_tac "finite_chain Y")
haftmann@31071
   432
prefer 2 apply fast
haftmann@31071
   433
apply (unfold finite_chain_def)
haftmann@31071
   434
apply safe
haftmann@31071
   435
apply (erule lub_finch1 [THEN thelubI, THEN ssubst])
haftmann@31071
   436
apply assumption
haftmann@31071
   437
apply (erule spec)
haftmann@31071
   438
done
haftmann@31071
   439
haftmann@31071
   440
lemma increasing_chain_adm_lemma:
haftmann@31071
   441
  "\<lbrakk>chain Y;  \<forall>i. P (Y i); \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i);
haftmann@31071
   442
    \<forall>i. \<exists>j>i. Y i \<noteq> Y j \<and> Y i \<sqsubseteq> Y j\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
haftmann@31071
   443
      \<Longrightarrow> P (\<Squnion>i. Y i)"
haftmann@31071
   444
apply (erule infinite_chain_adm_lemma)
haftmann@31071
   445
apply assumption
haftmann@31071
   446
apply (erule thin_rl)
haftmann@31071
   447
apply (unfold finite_chain_def)
haftmann@31071
   448
apply (unfold max_in_chain_def)
haftmann@31071
   449
apply (fast dest: le_imp_less_or_eq elim: chain_mono_less)
haftmann@31071
   450
done
haftmann@31071
   451
huffman@18071
   452
end
haftmann@31071
   453
huffman@31076
   454
end