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