src/HOLCF/Up.thy
author wenzelm
Sun Oct 21 14:21:48 2007 +0200 (2007-10-21)
changeset 25131 2c8caac48ade
parent 19105 3aabd46340e0
child 25785 dbe118fe3180
permissions -rw-r--r--
modernized specifications ('definition', 'abbreviation', 'notation');
     1 (*  Title:      HOLCF/Up.thy
     2     ID:         $Id$
     3     Author:     Franz Regensburger and Brian Huffman
     4 
     5 Lifting.
     6 *)
     7 
     8 header {* The type of lifted values *}
     9 
    10 theory Up
    11 imports Cfun
    12 begin
    13 
    14 defaultsort cpo
    15 
    16 subsection {* Definition of new type for lifting *}
    17 
    18 datatype 'a u = Ibottom | Iup 'a
    19 
    20 syntax (xsymbols)
    21   "u" :: "type \<Rightarrow> type" ("(_\<^sub>\<bottom>)" [1000] 999)
    22 
    23 consts
    24   Ifup :: "('a \<rightarrow> 'b::pcpo) \<Rightarrow> 'a u \<Rightarrow> 'b"
    25 
    26 primrec
    27   "Ifup f Ibottom = \<bottom>"
    28   "Ifup f (Iup x) = f\<cdot>x"
    29 
    30 subsection {* Ordering on lifted cpo *}
    31 
    32 instance u :: (sq_ord) sq_ord ..
    33 
    34 defs (overloaded)
    35   less_up_def:
    36     "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. case x of Ibottom \<Rightarrow> True | Iup a \<Rightarrow>
    37       (case y of Ibottom \<Rightarrow> False | Iup b \<Rightarrow> a \<sqsubseteq> b))"
    38 
    39 lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z"
    40 by (simp add: less_up_def)
    41 
    42 lemma not_Iup_less [iff]: "\<not> Iup x \<sqsubseteq> Ibottom"
    43 by (simp add: less_up_def)
    44 
    45 lemma Iup_less [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
    46 by (simp add: less_up_def)
    47 
    48 subsection {* Lifted cpo is a partial order *}
    49 
    50 lemma refl_less_up: "(x::'a u) \<sqsubseteq> x"
    51 by (simp add: less_up_def split: u.split)
    52 
    53 lemma antisym_less_up: "\<lbrakk>(x::'a u) \<sqsubseteq> y; y \<sqsubseteq> x\<rbrakk> \<Longrightarrow> x = y"
    54 apply (simp add: less_up_def split: u.split_asm)
    55 apply (erule (1) antisym_less)
    56 done
    57 
    58 lemma trans_less_up: "\<lbrakk>(x::'a u) \<sqsubseteq> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
    59 apply (simp add: less_up_def split: u.split_asm)
    60 apply (erule (1) trans_less)
    61 done
    62 
    63 instance u :: (cpo) po
    64 by intro_classes
    65   (assumption | rule refl_less_up antisym_less_up trans_less_up)+
    66 
    67 subsection {* Lifted cpo is a cpo *}
    68 
    69 lemma is_lub_Iup:
    70   "range S <<| x \<Longrightarrow> range (\<lambda>i. Iup (S i)) <<| Iup x"
    71 apply (rule is_lubI)
    72 apply (rule ub_rangeI)
    73 apply (subst Iup_less)
    74 apply (erule is_ub_lub)
    75 apply (case_tac u)
    76 apply (drule ub_rangeD)
    77 apply simp
    78 apply simp
    79 apply (erule is_lub_lub)
    80 apply (rule ub_rangeI)
    81 apply (drule_tac i=i in ub_rangeD)
    82 apply simp
    83 done
    84 
    85 text {* Now some lemmas about chains of @{typ "'a u"} elements *}
    86 
    87 lemma up_lemma1: "z \<noteq> Ibottom \<Longrightarrow> Iup (THE a. Iup a = z) = z"
    88 by (case_tac z, simp_all)
    89 
    90 lemma up_lemma2:
    91   "\<lbrakk>chain Y; Y j \<noteq> Ibottom\<rbrakk> \<Longrightarrow> Y (i + j) \<noteq> Ibottom"
    92 apply (erule contrapos_nn)
    93 apply (drule_tac x="j" and y="i + j" in chain_mono3)
    94 apply (rule le_add2)
    95 apply (case_tac "Y j")
    96 apply assumption
    97 apply simp
    98 done
    99 
   100 lemma up_lemma3:
   101   "\<lbrakk>chain Y; Y j \<noteq> Ibottom\<rbrakk> \<Longrightarrow> Iup (THE a. Iup a = Y (i + j)) = Y (i + j)"
   102 by (rule up_lemma1 [OF up_lemma2])
   103 
   104 lemma up_lemma4:
   105   "\<lbrakk>chain Y; Y j \<noteq> Ibottom\<rbrakk> \<Longrightarrow> chain (\<lambda>i. THE a. Iup a = Y (i + j))"
   106 apply (rule chainI)
   107 apply (rule Iup_less [THEN iffD1])
   108 apply (subst up_lemma3, assumption+)+
   109 apply (simp add: chainE)
   110 done
   111 
   112 lemma up_lemma5:
   113   "\<lbrakk>chain Y; Y j \<noteq> Ibottom\<rbrakk> \<Longrightarrow>
   114     (\<lambda>i. Y (i + j)) = (\<lambda>i. Iup (THE a. Iup a = Y (i + j)))"
   115 by (rule ext, rule up_lemma3 [symmetric])
   116 
   117 lemma up_lemma6:
   118   "\<lbrakk>chain Y; Y j \<noteq> Ibottom\<rbrakk>
   119       \<Longrightarrow> range Y <<| Iup (\<Squnion>i. THE a. Iup a = Y(i + j))"
   120 apply (rule_tac j1 = j in is_lub_range_shift [THEN iffD1])
   121 apply assumption
   122 apply (subst up_lemma5, assumption+)
   123 apply (rule is_lub_Iup)
   124 apply (rule thelubE [OF _ refl])
   125 apply (erule (1) up_lemma4)
   126 done
   127 
   128 lemma up_chain_lemma:
   129   "chain Y \<Longrightarrow>
   130    (\<exists>A. chain A \<and> lub (range Y) = Iup (lub (range A)) \<and>
   131    (\<exists>j. \<forall>i. Y (i + j) = Iup (A i))) \<or> (Y = (\<lambda>i. Ibottom))"
   132 apply (rule disjCI)
   133 apply (simp add: expand_fun_eq)
   134 apply (erule exE, rename_tac j)
   135 apply (rule_tac x="\<lambda>i. THE a. Iup a = Y (i + j)" in exI)
   136 apply (simp add: up_lemma4)
   137 apply (simp add: up_lemma6 [THEN thelubI])
   138 apply (rule_tac x=j in exI)
   139 apply (simp add: up_lemma3)
   140 done
   141 
   142 lemma cpo_up: "chain (Y::nat \<Rightarrow> 'a u) \<Longrightarrow> \<exists>x. range Y <<| x"
   143 apply (frule up_chain_lemma, safe)
   144 apply (rule_tac x="Iup (lub (range A))" in exI)
   145 apply (erule_tac j="j" in is_lub_range_shift [THEN iffD1, standard])
   146 apply (simp add: is_lub_Iup thelubE)
   147 apply (rule exI, rule lub_const)
   148 done
   149 
   150 instance u :: (cpo) cpo
   151 by intro_classes (rule cpo_up)
   152 
   153 subsection {* Lifted cpo is pointed *}
   154 
   155 lemma least_up: "\<exists>x::'a u. \<forall>y. x \<sqsubseteq> y"
   156 apply (rule_tac x = "Ibottom" in exI)
   157 apply (rule minimal_up [THEN allI])
   158 done
   159 
   160 instance u :: (cpo) pcpo
   161 by intro_classes (rule least_up)
   162 
   163 text {* for compatibility with old HOLCF-Version *}
   164 lemma inst_up_pcpo: "\<bottom> = Ibottom"
   165 by (rule minimal_up [THEN UU_I, symmetric])
   166 
   167 subsection {* Continuity of @{term Iup} and @{term Ifup} *}
   168 
   169 text {* continuity for @{term Iup} *}
   170 
   171 lemma cont_Iup: "cont Iup"
   172 apply (rule contI)
   173 apply (rule is_lub_Iup)
   174 apply (erule thelubE [OF _ refl])
   175 done
   176 
   177 text {* continuity for @{term Ifup} *}
   178 
   179 lemma cont_Ifup1: "cont (\<lambda>f. Ifup f x)"
   180 by (induct x, simp_all)
   181 
   182 lemma monofun_Ifup2: "monofun (\<lambda>x. Ifup f x)"
   183 apply (rule monofunI)
   184 apply (case_tac x, simp)
   185 apply (case_tac y, simp)
   186 apply (simp add: monofun_cfun_arg)
   187 done
   188 
   189 lemma cont_Ifup2: "cont (\<lambda>x. Ifup f x)"
   190 apply (rule contI)
   191 apply (frule up_chain_lemma, safe)
   192 apply (rule_tac j="j" in is_lub_range_shift [THEN iffD1, standard])
   193 apply (erule monofun_Ifup2 [THEN ch2ch_monofun])
   194 apply (simp add: cont_cfun_arg)
   195 apply (simp add: lub_const)
   196 done
   197 
   198 subsection {* Continuous versions of constants *}
   199 
   200 definition
   201   up  :: "'a \<rightarrow> 'a u" where
   202   "up = (\<Lambda> x. Iup x)"
   203 
   204 definition
   205   fup :: "('a \<rightarrow> 'b::pcpo) \<rightarrow> 'a u \<rightarrow> 'b" where
   206   "fup = (\<Lambda> f p. Ifup f p)"
   207 
   208 translations
   209   "case l of CONST up\<cdot>x \<Rightarrow> t" == "CONST fup\<cdot>(\<Lambda> x. t)\<cdot>l"
   210   "\<Lambda>(CONST up\<cdot>x). t" == "CONST fup\<cdot>(\<Lambda> x. t)"
   211 
   212 text {* continuous versions of lemmas for @{typ "('a)u"} *}
   213 
   214 lemma Exh_Up: "z = \<bottom> \<or> (\<exists>x. z = up\<cdot>x)"
   215 apply (induct z)
   216 apply (simp add: inst_up_pcpo)
   217 apply (simp add: up_def cont_Iup)
   218 done
   219 
   220 lemma up_eq [simp]: "(up\<cdot>x = up\<cdot>y) = (x = y)"
   221 by (simp add: up_def cont_Iup)
   222 
   223 lemma up_inject: "up\<cdot>x = up\<cdot>y \<Longrightarrow> x = y"
   224 by simp
   225 
   226 lemma up_defined [simp]: "up\<cdot>x \<noteq> \<bottom>"
   227 by (simp add: up_def cont_Iup inst_up_pcpo)
   228 
   229 lemma not_up_less_UU [simp]: "\<not> up\<cdot>x \<sqsubseteq> \<bottom>"
   230 by (simp add: eq_UU_iff [symmetric])
   231 
   232 lemma up_less [simp]: "(up\<cdot>x \<sqsubseteq> up\<cdot>y) = (x \<sqsubseteq> y)"
   233 by (simp add: up_def cont_Iup)
   234 
   235 lemma upE: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x. p = up\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
   236 apply (case_tac p)
   237 apply (simp add: inst_up_pcpo)
   238 apply (simp add: up_def cont_Iup)
   239 done
   240 
   241 lemma up_chain_cases:
   242   "chain Y \<Longrightarrow>
   243   (\<exists>A. chain A \<and> (\<Squnion>i. Y i) = up\<cdot>(\<Squnion>i. A i) \<and>
   244   (\<exists>j. \<forall>i. Y (i + j) = up\<cdot>(A i))) \<or> Y = (\<lambda>i. \<bottom>)"
   245 by (simp add: inst_up_pcpo up_def cont_Iup up_chain_lemma)
   246 
   247 lemma compact_up [simp]: "compact x \<Longrightarrow> compact (up\<cdot>x)"
   248 apply (unfold compact_def)
   249 apply (rule admI)
   250 apply (drule up_chain_cases)
   251 apply (elim disjE exE conjE)
   252 apply simp
   253 apply (erule (1) admD)
   254 apply (rule allI, drule_tac x="i + j" in spec)
   255 apply simp
   256 apply simp
   257 done
   258 
   259 text {* properties of fup *}
   260 
   261 lemma fup1 [simp]: "fup\<cdot>f\<cdot>\<bottom> = \<bottom>"
   262 by (simp add: fup_def cont_Ifup1 cont_Ifup2 inst_up_pcpo)
   263 
   264 lemma fup2 [simp]: "fup\<cdot>f\<cdot>(up\<cdot>x) = f\<cdot>x"
   265 by (simp add: up_def fup_def cont_Iup cont_Ifup1 cont_Ifup2)
   266 
   267 lemma fup3 [simp]: "fup\<cdot>up\<cdot>x = x"
   268 by (rule_tac p=x in upE, simp_all)
   269 
   270 end