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