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