1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/src/HOLCF/Cfun.ML Fri Mar 04 23:12:36 2005 +0100
1.3 @@ -0,0 +1,92 @@
1.4 +
1.5 +(* legacy ML bindings *)
1.6 +
1.7 +val less_cfun_def = thm "less_cfun_def";
1.8 +val Rep_Cfun = thm "Rep_Cfun";
1.9 +val Rep_Cfun_inverse = thm "Rep_Cfun_inverse";
1.10 +val Abs_Cfun_inverse = thm "Abs_Cfun_inverse";
1.11 +val refl_less_cfun = thm "refl_less_cfun";
1.12 +val antisym_less_cfun = thm "antisym_less_cfun";
1.13 +val trans_less_cfun = thm "trans_less_cfun";
1.14 +val cfun_cong = thm "cfun_cong";
1.15 +val cfun_fun_cong = thm "cfun_fun_cong";
1.16 +val cfun_arg_cong = thm "cfun_arg_cong";
1.17 +val Abs_Cfun_inverse2 = thm "Abs_Cfun_inverse2";
1.18 +val Cfunapp2 = thm "Cfunapp2";
1.19 +val beta_cfun = thm "beta_cfun";
1.20 +val inst_cfun_po = thm "inst_cfun_po";
1.21 +val less_cfun = thm "less_cfun";
1.22 +val minimal_cfun = thm "minimal_cfun";
1.23 +val UU_cfun_def = thm "UU_cfun_def";
1.24 +val least_cfun = thm "least_cfun";
1.25 +val cont_Rep_CFun2 = thm "cont_Rep_CFun2";
1.26 +val monofun_Rep_CFun2 = thm "monofun_Rep_CFun2";
1.27 +val contlub_Rep_CFun2 = thm "contlub_Rep_CFun2";
1.28 +val cont_cfun_arg = thm "cont_cfun_arg";
1.29 +val contlub_cfun_arg = thm "contlub_cfun_arg";
1.30 +val monofun_Rep_CFun1 = thm "monofun_Rep_CFun1";
1.31 +val monofun_cfun_fun = thm "monofun_cfun_fun";
1.32 +val monofun_cfun_arg = thm "monofun_cfun_arg";
1.33 +val chain_monofun = thm "chain_monofun";
1.34 +val monofun_cfun = thm "monofun_cfun";
1.35 +val strictI = thm "strictI";
1.36 +val ch2ch_Rep_CFunR = thm "ch2ch_Rep_CFunR";
1.37 +val ch2ch_Rep_CFunL = thm "ch2ch_Rep_CFunL";
1.38 +val lub_cfun_mono = thm "lub_cfun_mono";
1.39 +val ex_lubcfun = thm "ex_lubcfun";
1.40 +val cont_lubcfun = thm "cont_lubcfun";
1.41 +val lub_cfun = thm "lub_cfun";
1.42 +val thelub_cfun = thm "thelub_cfun";
1.43 +val cpo_cfun = thm "cpo_cfun";
1.44 +val ext_cfun = thm "ext_cfun";
1.45 +val semi_monofun_Abs_CFun = thm "semi_monofun_Abs_CFun";
1.46 +val less_cfun2 = thm "less_cfun2";
1.47 +val Istrictify_def = thm "Istrictify_def";
1.48 +val strictify_def = thm "strictify_def";
1.49 +val ID_def = thm "ID_def";
1.50 +val oo_def = thm "oo_def";
1.51 +val inst_cfun_pcpo = thm "inst_cfun_pcpo";
1.52 +val contlub_Rep_CFun1 = thm "contlub_Rep_CFun1";
1.53 +val cont_Rep_CFun1 = thm "cont_Rep_CFun1";
1.54 +val contlub_cfun_fun = thm "contlub_cfun_fun";
1.55 +val cont_cfun_fun = thm "cont_cfun_fun";
1.56 +val contlub_cfun = thm "contlub_cfun";
1.57 +val cont_cfun = thm "cont_cfun";
1.58 +val cont2cont_Rep_CFun = thm "cont2cont_Rep_CFun";
1.59 +val cont2mono_LAM = thm "cont2mono_LAM";
1.60 +val cont2cont_LAM = thm "cont2cont_LAM";
1.61 +val cont_lemmas1 = [cont_const, cont_id, cont_Rep_CFun2,
1.62 + cont2cont_Rep_CFun, cont2cont_LAM];
1.63 +val strict_Rep_CFun1 = thm "strict_Rep_CFun1";
1.64 +val Istrictify1 = thm "Istrictify1";
1.65 +val Istrictify2 = thm "Istrictify2";
1.66 +val monofun_Istrictify1 = thm "monofun_Istrictify1";
1.67 +val monofun_Istrictify2 = thm "monofun_Istrictify2";
1.68 +val contlub_Istrictify1 = thm "contlub_Istrictify1";
1.69 +val contlub_Istrictify2 = thm "contlub_Istrictify2";
1.70 +val cont_Istrictify1 = thm "cont_Istrictify1";
1.71 +val cont_Istrictify2 = thm "cont_Istrictify2";
1.72 +val strictify1 = thm "strictify1";
1.73 +val strictify2 = thm "strictify2";
1.74 +val chfin_Rep_CFunR = thm "chfin_Rep_CFunR";
1.75 +val iso_strict = thm "iso_strict";
1.76 +val isorep_defined = thm "isorep_defined";
1.77 +val isoabs_defined = thm "isoabs_defined";
1.78 +val chfin2chfin = thm "chfin2chfin";
1.79 +val flat2flat = thm "flat2flat";
1.80 +val flat_codom = thm "flat_codom";
1.81 +val ID1 = thm "ID1";
1.82 +val cfcomp1 = thm "cfcomp1";
1.83 +val cfcomp2 = thm "cfcomp2";
1.84 +val ID2 = thm "ID2";
1.85 +val ID3 = thm "ID3";
1.86 +val assoc_oo = thm "assoc_oo";
1.87 +
1.88 +structure Cfun =
1.89 +struct
1.90 + val thy = the_context ();
1.91 + val Istrictify_def = Istrictify_def;
1.92 + val strictify_def = strictify_def;
1.93 + val ID_def = ID_def;
1.94 + val oo_def = oo_def;
1.95 +end;
2.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
2.2 +++ b/src/HOLCF/Cfun.thy Fri Mar 04 23:12:36 2005 +0100
2.3 @@ -0,0 +1,912 @@
2.4 +(* Title: HOLCF/Cfun1.thy
2.5 + ID: $Id$
2.6 + Author: Franz Regensburger
2.7 + License: GPL (GNU GENERAL PUBLIC LICENSE)
2.8 +
2.9 +Definition of the type -> of continuous functions.
2.10 +
2.11 +*)
2.12 +
2.13 +header {* The type of continuous functions *}
2.14 +
2.15 +theory Cfun = Cont:
2.16 +
2.17 +defaultsort cpo
2.18 +
2.19 +typedef (CFun) ('a, 'b) "->" (infixr 0) = "{f::'a => 'b. cont f}"
2.20 +by (rule exI, rule CfunI)
2.21 +
2.22 +(* to make << defineable *)
2.23 +instance "->" :: (cpo,cpo)sq_ord ..
2.24 +
2.25 +syntax
2.26 + Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("_$_" [999,1000] 999)
2.27 + (* application *)
2.28 + Abs_CFun :: "('a => 'b) => ('a -> 'b)" (binder "LAM " 10)
2.29 + (* abstraction *)
2.30 + less_cfun :: "[('a -> 'b),('a -> 'b)]=>bool"
2.31 +
2.32 +syntax (xsymbols)
2.33 + "->" :: "[type, type] => type" ("(_ \<rightarrow>/ _)" [1,0]0)
2.34 + "LAM " :: "[idts, 'a => 'b] => ('a -> 'b)"
2.35 + ("(3\<Lambda>_./ _)" [0, 10] 10)
2.36 + Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("(_\<cdot>_)" [999,1000] 999)
2.37 +
2.38 +syntax (HTML output)
2.39 + Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("(_\<cdot>_)" [999,1000] 999)
2.40 +
2.41 +defs (overloaded)
2.42 + less_cfun_def: "(op <<) == (% fo1 fo2. Rep_CFun fo1 << Rep_CFun fo2 )"
2.43 +
2.44 +(* ------------------------------------------------------------------------ *)
2.45 +(* derive old type definition rules for Abs_CFun & Rep_CFun
2.46 + *)
2.47 +(* Rep_CFun and Abs_CFun should be replaced by Rep_Cfun anf Abs_Cfun in future
2.48 + *)
2.49 +(* ------------------------------------------------------------------------ *)
2.50 +
2.51 +lemma Rep_Cfun: "Rep_CFun fo : CFun"
2.52 +apply (rule Rep_CFun)
2.53 +done
2.54 +
2.55 +lemma Rep_Cfun_inverse: "Abs_CFun (Rep_CFun fo) = fo"
2.56 +apply (rule Rep_CFun_inverse)
2.57 +done
2.58 +
2.59 +lemma Abs_Cfun_inverse: "f:CFun==>Rep_CFun(Abs_CFun f)=f"
2.60 +apply (erule Abs_CFun_inverse)
2.61 +done
2.62 +
2.63 +(* ------------------------------------------------------------------------ *)
2.64 +(* less_cfun is a partial order on type 'a -> 'b *)
2.65 +(* ------------------------------------------------------------------------ *)
2.66 +
2.67 +lemma refl_less_cfun: "(f::'a->'b) << f"
2.68 +
2.69 +apply (unfold less_cfun_def)
2.70 +apply (rule refl_less)
2.71 +done
2.72 +
2.73 +lemma antisym_less_cfun:
2.74 + "[|(f1::'a->'b) << f2; f2 << f1|] ==> f1 = f2"
2.75 +apply (unfold less_cfun_def)
2.76 +apply (rule injD)
2.77 +apply (rule_tac [2] antisym_less)
2.78 +prefer 3 apply (assumption)
2.79 +prefer 2 apply (assumption)
2.80 +apply (rule inj_on_inverseI)
2.81 +apply (rule Rep_Cfun_inverse)
2.82 +done
2.83 +
2.84 +lemma trans_less_cfun:
2.85 + "[|(f1::'a->'b) << f2; f2 << f3|] ==> f1 << f3"
2.86 +apply (unfold less_cfun_def)
2.87 +apply (erule trans_less)
2.88 +apply assumption
2.89 +done
2.90 +
2.91 +(* ------------------------------------------------------------------------ *)
2.92 +(* lemmas about application of continuous functions *)
2.93 +(* ------------------------------------------------------------------------ *)
2.94 +
2.95 +lemma cfun_cong: "[| f=g; x=y |] ==> f$x = g$y"
2.96 +apply (simp (no_asm_simp))
2.97 +done
2.98 +
2.99 +lemma cfun_fun_cong: "f=g ==> f$x = g$x"
2.100 +apply (simp (no_asm_simp))
2.101 +done
2.102 +
2.103 +lemma cfun_arg_cong: "x=y ==> f$x = f$y"
2.104 +apply (simp (no_asm_simp))
2.105 +done
2.106 +
2.107 +
2.108 +(* ------------------------------------------------------------------------ *)
2.109 +(* additional lemma about the isomorphism between -> and Cfun *)
2.110 +(* ------------------------------------------------------------------------ *)
2.111 +
2.112 +lemma Abs_Cfun_inverse2: "cont f ==> Rep_CFun (Abs_CFun f) = f"
2.113 +apply (rule Abs_Cfun_inverse)
2.114 +apply (unfold CFun_def)
2.115 +apply (erule mem_Collect_eq [THEN ssubst])
2.116 +done
2.117 +
2.118 +(* ------------------------------------------------------------------------ *)
2.119 +(* simplification of application *)
2.120 +(* ------------------------------------------------------------------------ *)
2.121 +
2.122 +lemma Cfunapp2: "cont f ==> (Abs_CFun f)$x = f x"
2.123 +apply (erule Abs_Cfun_inverse2 [THEN fun_cong])
2.124 +done
2.125 +
2.126 +(* ------------------------------------------------------------------------ *)
2.127 +(* beta - equality for continuous functions *)
2.128 +(* ------------------------------------------------------------------------ *)
2.129 +
2.130 +lemma beta_cfun: "cont(c1) ==> (LAM x .c1 x)$u = c1 u"
2.131 +apply (rule Cfunapp2)
2.132 +apply assumption
2.133 +done
2.134 +
2.135 +
2.136 +(* Class Instance ->::(cpo,cpo)po *)
2.137 +
2.138 +instance "->"::(cpo,cpo)po
2.139 +apply (intro_classes)
2.140 +apply (rule refl_less_cfun)
2.141 +apply (rule antisym_less_cfun, assumption+)
2.142 +apply (rule trans_less_cfun, assumption+)
2.143 +done
2.144 +
2.145 +(* Class Instance ->::(cpo,cpo)po *)
2.146 +
2.147 +(* for compatibility with old HOLCF-Version *)
2.148 +lemma inst_cfun_po: "(op <<)=(%f1 f2. Rep_CFun f1 << Rep_CFun f2)"
2.149 +apply (fold less_cfun_def)
2.150 +apply (rule refl)
2.151 +done
2.152 +
2.153 +(* ------------------------------------------------------------------------ *)
2.154 +(* access to less_cfun in class po *)
2.155 +(* ------------------------------------------------------------------------ *)
2.156 +
2.157 +lemma less_cfun: "( f1 << f2 ) = (Rep_CFun(f1) << Rep_CFun(f2))"
2.158 +apply (simp (no_asm) add: inst_cfun_po)
2.159 +done
2.160 +
2.161 +(* ------------------------------------------------------------------------ *)
2.162 +(* Type 'a ->'b is pointed *)
2.163 +(* ------------------------------------------------------------------------ *)
2.164 +
2.165 +lemma minimal_cfun: "Abs_CFun(% x. UU) << f"
2.166 +apply (subst less_cfun)
2.167 +apply (subst Abs_Cfun_inverse2)
2.168 +apply (rule cont_const)
2.169 +apply (rule minimal_fun)
2.170 +done
2.171 +
2.172 +lemmas UU_cfun_def = minimal_cfun [THEN minimal2UU, symmetric, standard]
2.173 +
2.174 +lemma least_cfun: "? x::'a->'b::pcpo.!y. x<<y"
2.175 +apply (rule_tac x = "Abs_CFun (% x. UU) " in exI)
2.176 +apply (rule minimal_cfun [THEN allI])
2.177 +done
2.178 +
2.179 +(* ------------------------------------------------------------------------ *)
2.180 +(* Rep_CFun yields continuous functions in 'a => 'b *)
2.181 +(* this is continuity of Rep_CFun in its 'second' argument *)
2.182 +(* cont_Rep_CFun2 ==> monofun_Rep_CFun2 & contlub_Rep_CFun2 *)
2.183 +(* ------------------------------------------------------------------------ *)
2.184 +
2.185 +lemma cont_Rep_CFun2: "cont(Rep_CFun(fo))"
2.186 +apply (rule_tac P = "cont" in CollectD)
2.187 +apply (fold CFun_def)
2.188 +apply (rule Rep_Cfun)
2.189 +done
2.190 +
2.191 +lemmas monofun_Rep_CFun2 = cont_Rep_CFun2 [THEN cont2mono, standard]
2.192 +(* monofun(Rep_CFun(?fo1)) *)
2.193 +
2.194 +
2.195 +lemmas contlub_Rep_CFun2 = cont_Rep_CFun2 [THEN cont2contlub, standard]
2.196 +(* contlub(Rep_CFun(?fo1)) *)
2.197 +
2.198 +(* ------------------------------------------------------------------------ *)
2.199 +(* expanded thms cont_Rep_CFun2, contlub_Rep_CFun2 *)
2.200 +(* looks nice with mixfix syntac *)
2.201 +(* ------------------------------------------------------------------------ *)
2.202 +
2.203 +lemmas cont_cfun_arg = cont_Rep_CFun2 [THEN contE, THEN spec, THEN mp]
2.204 +(* chain(?x1) ==> range (%i. ?fo3$(?x1 i)) <<| ?fo3$(lub (range ?x1)) *)
2.205 +
2.206 +lemmas contlub_cfun_arg = contlub_Rep_CFun2 [THEN contlubE, THEN spec, THEN mp]
2.207 +(* chain(?x1) ==> ?fo4$(lub (range ?x1)) = lub (range (%i. ?fo4$(?x1 i))) *)
2.208 +
2.209 +
2.210 +(* ------------------------------------------------------------------------ *)
2.211 +(* Rep_CFun is monotone in its 'first' argument *)
2.212 +(* ------------------------------------------------------------------------ *)
2.213 +
2.214 +lemma monofun_Rep_CFun1: "monofun(Rep_CFun)"
2.215 +apply (unfold monofun)
2.216 +apply (intro strip)
2.217 +apply (erule less_cfun [THEN subst])
2.218 +done
2.219 +
2.220 +
2.221 +(* ------------------------------------------------------------------------ *)
2.222 +(* monotonicity of application Rep_CFun in mixfix syntax [_]_ *)
2.223 +(* ------------------------------------------------------------------------ *)
2.224 +
2.225 +lemma monofun_cfun_fun: "f1 << f2 ==> f1$x << f2$x"
2.226 +apply (rule_tac x = "x" in spec)
2.227 +apply (rule less_fun [THEN subst])
2.228 +apply (erule monofun_Rep_CFun1 [THEN monofunE, THEN spec, THEN spec, THEN mp])
2.229 +done
2.230 +
2.231 +
2.232 +lemmas monofun_cfun_arg = monofun_Rep_CFun2 [THEN monofunE, THEN spec, THEN spec, THEN mp, standard]
2.233 +(* ?x2 << ?x1 ==> ?fo5$?x2 << ?fo5$?x1 *)
2.234 +
2.235 +lemma chain_monofun: "chain Y ==> chain (%i. f\<cdot>(Y i))"
2.236 +apply (rule chainI)
2.237 +apply (rule monofun_cfun_arg)
2.238 +apply (erule chainE)
2.239 +done
2.240 +
2.241 +
2.242 +(* ------------------------------------------------------------------------ *)
2.243 +(* monotonicity of Rep_CFun in both arguments in mixfix syntax [_]_ *)
2.244 +(* ------------------------------------------------------------------------ *)
2.245 +
2.246 +lemma monofun_cfun: "[|f1<<f2;x1<<x2|] ==> f1$x1 << f2$x2"
2.247 +apply (rule trans_less)
2.248 +apply (erule monofun_cfun_arg)
2.249 +apply (erule monofun_cfun_fun)
2.250 +done
2.251 +
2.252 +
2.253 +lemma strictI: "f$x = UU ==> f$UU = UU"
2.254 +apply (rule eq_UU_iff [THEN iffD2])
2.255 +apply (erule subst)
2.256 +apply (rule minimal [THEN monofun_cfun_arg])
2.257 +done
2.258 +
2.259 +
2.260 +(* ------------------------------------------------------------------------ *)
2.261 +(* ch2ch - rules for the type 'a -> 'b *)
2.262 +(* use MF2 lemmas from Cont.ML *)
2.263 +(* ------------------------------------------------------------------------ *)
2.264 +
2.265 +lemma ch2ch_Rep_CFunR: "chain(Y) ==> chain(%i. f$(Y i))"
2.266 +apply (erule monofun_Rep_CFun2 [THEN ch2ch_MF2R])
2.267 +done
2.268 +
2.269 +
2.270 +lemmas ch2ch_Rep_CFunL = monofun_Rep_CFun1 [THEN ch2ch_MF2L, standard]
2.271 +(* chain(?F) ==> chain (%i. ?F i$?x) *)
2.272 +
2.273 +
2.274 +(* ------------------------------------------------------------------------ *)
2.275 +(* the lub of a chain of continous functions is monotone *)
2.276 +(* use MF2 lemmas from Cont.ML *)
2.277 +(* ------------------------------------------------------------------------ *)
2.278 +
2.279 +lemma lub_cfun_mono: "chain(F) ==> monofun(% x. lub(range(% j.(F j)$x)))"
2.280 +apply (rule lub_MF2_mono)
2.281 +apply (rule monofun_Rep_CFun1)
2.282 +apply (rule monofun_Rep_CFun2 [THEN allI])
2.283 +apply assumption
2.284 +done
2.285 +
2.286 +(* ------------------------------------------------------------------------ *)
2.287 +(* a lemma about the exchange of lubs for type 'a -> 'b *)
2.288 +(* use MF2 lemmas from Cont.ML *)
2.289 +(* ------------------------------------------------------------------------ *)
2.290 +
2.291 +lemma ex_lubcfun: "[| chain(F); chain(Y) |] ==>
2.292 + lub(range(%j. lub(range(%i. F(j)$(Y i))))) =
2.293 + lub(range(%i. lub(range(%j. F(j)$(Y i)))))"
2.294 +apply (rule ex_lubMF2)
2.295 +apply (rule monofun_Rep_CFun1)
2.296 +apply (rule monofun_Rep_CFun2 [THEN allI])
2.297 +apply assumption
2.298 +apply assumption
2.299 +done
2.300 +
2.301 +(* ------------------------------------------------------------------------ *)
2.302 +(* the lub of a chain of cont. functions is continuous *)
2.303 +(* ------------------------------------------------------------------------ *)
2.304 +
2.305 +lemma cont_lubcfun: "chain(F) ==> cont(% x. lub(range(% j. F(j)$x)))"
2.306 +apply (rule monocontlub2cont)
2.307 +apply (erule lub_cfun_mono)
2.308 +apply (rule contlubI)
2.309 +apply (intro strip)
2.310 +apply (subst contlub_cfun_arg [THEN ext])
2.311 +apply assumption
2.312 +apply (erule ex_lubcfun)
2.313 +apply assumption
2.314 +done
2.315 +
2.316 +(* ------------------------------------------------------------------------ *)
2.317 +(* type 'a -> 'b is chain complete *)
2.318 +(* ------------------------------------------------------------------------ *)
2.319 +
2.320 +lemma lub_cfun: "chain(CCF) ==> range(CCF) <<| (LAM x. lub(range(% i. CCF(i)$x)))"
2.321 +apply (rule is_lubI)
2.322 +apply (rule ub_rangeI)
2.323 +apply (subst less_cfun)
2.324 +apply (subst Abs_Cfun_inverse2)
2.325 +apply (erule cont_lubcfun)
2.326 +apply (rule lub_fun [THEN is_lubD1, THEN ub_rangeD])
2.327 +apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
2.328 +apply (subst less_cfun)
2.329 +apply (subst Abs_Cfun_inverse2)
2.330 +apply (erule cont_lubcfun)
2.331 +apply (rule lub_fun [THEN is_lub_lub])
2.332 +apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
2.333 +apply (erule monofun_Rep_CFun1 [THEN ub2ub_monofun])
2.334 +done
2.335 +
2.336 +lemmas thelub_cfun = lub_cfun [THEN thelubI, standard]
2.337 +(*
2.338 +chain(?CCF1) ==> lub (range ?CCF1) = (LAM x. lub (range (%i. ?CCF1 i$x)))
2.339 +*)
2.340 +
2.341 +lemma cpo_cfun: "chain(CCF::nat=>('a->'b)) ==> ? x. range(CCF) <<| x"
2.342 +apply (rule exI)
2.343 +apply (erule lub_cfun)
2.344 +done
2.345 +
2.346 +
2.347 +(* ------------------------------------------------------------------------ *)
2.348 +(* Extensionality in 'a -> 'b *)
2.349 +(* ------------------------------------------------------------------------ *)
2.350 +
2.351 +lemma ext_cfun: "(!!x. f$x = g$x) ==> f = g"
2.352 +apply (rule_tac t = "f" in Rep_Cfun_inverse [THEN subst])
2.353 +apply (rule_tac t = "g" in Rep_Cfun_inverse [THEN subst])
2.354 +apply (rule_tac f = "Abs_CFun" in arg_cong)
2.355 +apply (rule ext)
2.356 +apply simp
2.357 +done
2.358 +
2.359 +(* ------------------------------------------------------------------------ *)
2.360 +(* Monotonicity of Abs_CFun *)
2.361 +(* ------------------------------------------------------------------------ *)
2.362 +
2.363 +lemma semi_monofun_Abs_CFun: "[| cont(f); cont(g); f<<g|] ==> Abs_CFun(f)<<Abs_CFun(g)"
2.364 +apply (rule less_cfun [THEN iffD2])
2.365 +apply (subst Abs_Cfun_inverse2)
2.366 +apply assumption
2.367 +apply (subst Abs_Cfun_inverse2)
2.368 +apply assumption
2.369 +apply assumption
2.370 +done
2.371 +
2.372 +(* ------------------------------------------------------------------------ *)
2.373 +(* Extenionality wrt. << in 'a -> 'b *)
2.374 +(* ------------------------------------------------------------------------ *)
2.375 +
2.376 +lemma less_cfun2: "(!!x. f$x << g$x) ==> f << g"
2.377 +apply (rule_tac t = "f" in Rep_Cfun_inverse [THEN subst])
2.378 +apply (rule_tac t = "g" in Rep_Cfun_inverse [THEN subst])
2.379 +apply (rule semi_monofun_Abs_CFun)
2.380 +apply (rule cont_Rep_CFun2)
2.381 +apply (rule cont_Rep_CFun2)
2.382 +apply (rule less_fun [THEN iffD2])
2.383 +apply (rule allI)
2.384 +apply simp
2.385 +done
2.386 +
2.387 +(* Class instance of -> for class pcpo *)
2.388 +
2.389 +instance "->" :: (cpo,cpo)cpo
2.390 +by (intro_classes, rule cpo_cfun)
2.391 +
2.392 +instance "->" :: (cpo,pcpo)pcpo
2.393 +by (intro_classes, rule least_cfun)
2.394 +
2.395 +defaultsort pcpo
2.396 +
2.397 +consts
2.398 + Istrictify :: "('a->'b)=>'a=>'b"
2.399 + strictify :: "('a->'b)->'a->'b"
2.400 +defs
2.401 +
2.402 +Istrictify_def: "Istrictify f x == if x=UU then UU else f$x"
2.403 +strictify_def: "strictify == (LAM f x. Istrictify f x)"
2.404 +
2.405 +consts
2.406 + ID :: "('a::cpo) -> 'a"
2.407 + cfcomp :: "('b->'c)->(('a::cpo)->('b::cpo))->'a->('c::cpo)"
2.408 +
2.409 +syntax "@oo" :: "('b->'c)=>('a->'b)=>'a->'c" ("_ oo _" [101,100] 100)
2.410 +
2.411 +translations "f1 oo f2" == "cfcomp$f1$f2"
2.412 +
2.413 +defs
2.414 +
2.415 + ID_def: "ID ==(LAM x. x)"
2.416 + oo_def: "cfcomp == (LAM f g x. f$(g$x))"
2.417 +
2.418 +(* for compatibility with old HOLCF-Version *)
2.419 +lemma inst_cfun_pcpo: "UU = Abs_CFun(%x. UU)"
2.420 +apply (simp add: UU_def UU_cfun_def)
2.421 +done
2.422 +
2.423 +(* ------------------------------------------------------------------------ *)
2.424 +(* the contlub property for Rep_CFun its 'first' argument *)
2.425 +(* ------------------------------------------------------------------------ *)
2.426 +
2.427 +lemma contlub_Rep_CFun1: "contlub(Rep_CFun)"
2.428 +apply (rule contlubI)
2.429 +apply (intro strip)
2.430 +apply (rule expand_fun_eq [THEN iffD2])
2.431 +apply (intro strip)
2.432 +apply (subst thelub_cfun)
2.433 +apply assumption
2.434 +apply (subst Cfunapp2)
2.435 +apply (erule cont_lubcfun)
2.436 +apply (subst thelub_fun)
2.437 +apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
2.438 +apply (rule refl)
2.439 +done
2.440 +
2.441 +
2.442 +(* ------------------------------------------------------------------------ *)
2.443 +(* the cont property for Rep_CFun in its first argument *)
2.444 +(* ------------------------------------------------------------------------ *)
2.445 +
2.446 +lemma cont_Rep_CFun1: "cont(Rep_CFun)"
2.447 +apply (rule monocontlub2cont)
2.448 +apply (rule monofun_Rep_CFun1)
2.449 +apply (rule contlub_Rep_CFun1)
2.450 +done
2.451 +
2.452 +
2.453 +(* ------------------------------------------------------------------------ *)
2.454 +(* contlub, cont properties of Rep_CFun in its first argument in mixfix _[_] *)
2.455 +(* ------------------------------------------------------------------------ *)
2.456 +
2.457 +lemma contlub_cfun_fun:
2.458 +"chain(FY) ==>
2.459 + lub(range FY)$x = lub(range (%i. FY(i)$x))"
2.460 +apply (rule trans)
2.461 +apply (erule contlub_Rep_CFun1 [THEN contlubE, THEN spec, THEN mp, THEN fun_cong])
2.462 +apply (subst thelub_fun)
2.463 +apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
2.464 +apply (rule refl)
2.465 +done
2.466 +
2.467 +
2.468 +lemma cont_cfun_fun:
2.469 +"chain(FY) ==>
2.470 + range(%i. FY(i)$x) <<| lub(range FY)$x"
2.471 +apply (rule thelubE)
2.472 +apply (erule ch2ch_Rep_CFunL)
2.473 +apply (erule contlub_cfun_fun [symmetric])
2.474 +done
2.475 +
2.476 +
2.477 +(* ------------------------------------------------------------------------ *)
2.478 +(* contlub, cont properties of Rep_CFun in both argument in mixfix _[_] *)
2.479 +(* ------------------------------------------------------------------------ *)
2.480 +
2.481 +lemma contlub_cfun:
2.482 +"[|chain(FY);chain(TY)|] ==>
2.483 + (lub(range FY))$(lub(range TY)) = lub(range(%i. FY(i)$(TY i)))"
2.484 +apply (rule contlub_CF2)
2.485 +apply (rule cont_Rep_CFun1)
2.486 +apply (rule allI)
2.487 +apply (rule cont_Rep_CFun2)
2.488 +apply assumption
2.489 +apply assumption
2.490 +done
2.491 +
2.492 +lemma cont_cfun:
2.493 +"[|chain(FY);chain(TY)|] ==>
2.494 + range(%i.(FY i)$(TY i)) <<| (lub (range FY))$(lub(range TY))"
2.495 +apply (rule thelubE)
2.496 +apply (rule monofun_Rep_CFun1 [THEN ch2ch_MF2LR])
2.497 +apply (rule allI)
2.498 +apply (rule monofun_Rep_CFun2)
2.499 +apply assumption
2.500 +apply assumption
2.501 +apply (erule contlub_cfun [symmetric])
2.502 +apply assumption
2.503 +done
2.504 +
2.505 +
2.506 +(* ------------------------------------------------------------------------ *)
2.507 +(* cont2cont lemma for Rep_CFun *)
2.508 +(* ------------------------------------------------------------------------ *)
2.509 +
2.510 +lemma cont2cont_Rep_CFun: "[|cont(%x. ft x);cont(%x. tt x)|] ==> cont(%x. (ft x)$(tt x))"
2.511 +apply (best intro: cont2cont_app2 cont_const cont_Rep_CFun1 cont_Rep_CFun2)
2.512 +done
2.513 +
2.514 +
2.515 +
2.516 +(* ------------------------------------------------------------------------ *)
2.517 +(* cont2mono Lemma for %x. LAM y. c1(x)(y) *)
2.518 +(* ------------------------------------------------------------------------ *)
2.519 +
2.520 +lemma cont2mono_LAM:
2.521 +assumes p1: "!!x. cont(c1 x)"
2.522 +assumes p2: "!!y. monofun(%x. c1 x y)"
2.523 +shows "monofun(%x. LAM y. c1 x y)"
2.524 +apply (rule monofunI)
2.525 +apply (intro strip)
2.526 +apply (subst less_cfun)
2.527 +apply (subst less_fun)
2.528 +apply (rule allI)
2.529 +apply (subst beta_cfun)
2.530 +apply (rule p1)
2.531 +apply (subst beta_cfun)
2.532 +apply (rule p1)
2.533 +apply (erule p2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
2.534 +done
2.535 +
2.536 +(* ------------------------------------------------------------------------ *)
2.537 +(* cont2cont Lemma for %x. LAM y. c1 x y) *)
2.538 +(* ------------------------------------------------------------------------ *)
2.539 +
2.540 +lemma cont2cont_LAM:
2.541 +assumes p1: "!!x. cont(c1 x)"
2.542 +assumes p2: "!!y. cont(%x. c1 x y)"
2.543 +shows "cont(%x. LAM y. c1 x y)"
2.544 +apply (rule monocontlub2cont)
2.545 +apply (rule p1 [THEN cont2mono_LAM])
2.546 +apply (rule p2 [THEN cont2mono])
2.547 +apply (rule contlubI)
2.548 +apply (intro strip)
2.549 +apply (subst thelub_cfun)
2.550 +apply (rule p1 [THEN cont2mono_LAM, THEN ch2ch_monofun])
2.551 +apply (rule p2 [THEN cont2mono])
2.552 +apply assumption
2.553 +apply (rule_tac f = "Abs_CFun" in arg_cong)
2.554 +apply (rule ext)
2.555 +apply (subst p1 [THEN beta_cfun, THEN ext])
2.556 +apply (erule p2 [THEN cont2contlub, THEN contlubE, THEN spec, THEN mp])
2.557 +done
2.558 +
2.559 +(* ------------------------------------------------------------------------ *)
2.560 +(* cont2cont tactic *)
2.561 +(* ------------------------------------------------------------------------ *)
2.562 +
2.563 +lemmas cont_lemmas1 = cont_const cont_id cont_Rep_CFun2
2.564 + cont2cont_Rep_CFun cont2cont_LAM
2.565 +
2.566 +declare cont_lemmas1 [simp]
2.567 +
2.568 +(* HINT: cont_tac is now installed in simplifier in Lift.ML ! *)
2.569 +
2.570 +(*val cont_tac = (fn i => (resolve_tac cont_lemmas i));*)
2.571 +(*val cont_tacR = (fn i => (REPEAT (cont_tac i)));*)
2.572 +
2.573 +(* ------------------------------------------------------------------------ *)
2.574 +(* function application _[_] is strict in its first arguments *)
2.575 +(* ------------------------------------------------------------------------ *)
2.576 +
2.577 +lemma strict_Rep_CFun1: "(UU::'a::cpo->'b)$x = (UU::'b)"
2.578 +apply (subst inst_cfun_pcpo)
2.579 +apply (subst beta_cfun)
2.580 +apply (simp (no_asm))
2.581 +apply (rule refl)
2.582 +done
2.583 +
2.584 +
2.585 +(* ------------------------------------------------------------------------ *)
2.586 +(* results about strictify *)
2.587 +(* ------------------------------------------------------------------------ *)
2.588 +
2.589 +lemma Istrictify1:
2.590 + "Istrictify(f)(UU)= (UU)"
2.591 +apply (unfold Istrictify_def)
2.592 +apply (simp (no_asm))
2.593 +done
2.594 +
2.595 +lemma Istrictify2:
2.596 + "~x=UU ==> Istrictify(f)(x)=f$x"
2.597 +apply (unfold Istrictify_def)
2.598 +apply (simp (no_asm_simp))
2.599 +done
2.600 +
2.601 +lemma monofun_Istrictify1: "monofun(Istrictify)"
2.602 +apply (rule monofunI)
2.603 +apply (intro strip)
2.604 +apply (rule less_fun [THEN iffD2])
2.605 +apply (intro strip)
2.606 +apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
2.607 +apply (subst Istrictify2)
2.608 +apply assumption
2.609 +apply (subst Istrictify2)
2.610 +apply assumption
2.611 +apply (rule monofun_cfun_fun)
2.612 +apply assumption
2.613 +apply (erule ssubst)
2.614 +apply (subst Istrictify1)
2.615 +apply (subst Istrictify1)
2.616 +apply (rule refl_less)
2.617 +done
2.618 +
2.619 +lemma monofun_Istrictify2: "monofun(Istrictify(f))"
2.620 +apply (rule monofunI)
2.621 +apply (intro strip)
2.622 +apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
2.623 +apply (simplesubst Istrictify2)
2.624 +apply (erule notUU_I)
2.625 +apply assumption
2.626 +apply (subst Istrictify2)
2.627 +apply assumption
2.628 +apply (rule monofun_cfun_arg)
2.629 +apply assumption
2.630 +apply (erule ssubst)
2.631 +apply (subst Istrictify1)
2.632 +apply (rule minimal)
2.633 +done
2.634 +
2.635 +
2.636 +lemma contlub_Istrictify1: "contlub(Istrictify)"
2.637 +apply (rule contlubI)
2.638 +apply (intro strip)
2.639 +apply (rule expand_fun_eq [THEN iffD2])
2.640 +apply (intro strip)
2.641 +apply (subst thelub_fun)
2.642 +apply (erule monofun_Istrictify1 [THEN ch2ch_monofun])
2.643 +apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
2.644 +apply (subst Istrictify2)
2.645 +apply assumption
2.646 +apply (subst Istrictify2 [THEN ext])
2.647 +apply assumption
2.648 +apply (subst thelub_cfun)
2.649 +apply assumption
2.650 +apply (subst beta_cfun)
2.651 +apply (rule cont_lubcfun)
2.652 +apply assumption
2.653 +apply (rule refl)
2.654 +apply (erule ssubst)
2.655 +apply (subst Istrictify1)
2.656 +apply (subst Istrictify1 [THEN ext])
2.657 +apply (rule chain_UU_I_inverse [symmetric])
2.658 +apply (rule refl [THEN allI])
2.659 +done
2.660 +
2.661 +lemma contlub_Istrictify2: "contlub(Istrictify(f::'a -> 'b))"
2.662 +apply (rule contlubI)
2.663 +apply (intro strip)
2.664 +apply (case_tac "lub (range (Y))= (UU::'a) ")
2.665 +apply (simp (no_asm_simp) add: Istrictify1 chain_UU_I_inverse chain_UU_I Istrictify1)
2.666 +apply (subst Istrictify2)
2.667 +apply assumption
2.668 +apply (rule_tac s = "lub (range (%i. f$ (Y i))) " in trans)
2.669 +apply (rule contlub_cfun_arg)
2.670 +apply assumption
2.671 +apply (rule lub_equal2)
2.672 +prefer 3 apply (best intro: ch2ch_monofun monofun_Istrictify2)
2.673 +prefer 2 apply (best intro: ch2ch_monofun monofun_Rep_CFun2)
2.674 +apply (rule chain_mono2 [THEN exE])
2.675 +prefer 2 apply (assumption)
2.676 +apply (erule chain_UU_I_inverse2)
2.677 +apply (blast intro: Istrictify2 [symmetric])
2.678 +done
2.679 +
2.680 +
2.681 +lemmas cont_Istrictify1 = contlub_Istrictify1 [THEN monofun_Istrictify1 [THEN monocontlub2cont], standard]
2.682 +
2.683 +lemmas cont_Istrictify2 = contlub_Istrictify2 [THEN monofun_Istrictify2 [THEN monocontlub2cont], standard]
2.684 +
2.685 +
2.686 +lemma strictify1: "strictify$f$UU=UU"
2.687 +apply (unfold strictify_def)
2.688 +apply (subst beta_cfun)
2.689 +apply (simp (no_asm) add: cont_Istrictify2 cont_Istrictify1 cont2cont_CF1L)
2.690 +apply (subst beta_cfun)
2.691 +apply (rule cont_Istrictify2)
2.692 +apply (rule Istrictify1)
2.693 +done
2.694 +
2.695 +lemma strictify2: "~x=UU ==> strictify$f$x=f$x"
2.696 +apply (unfold strictify_def)
2.697 +apply (subst beta_cfun)
2.698 +apply (simp (no_asm) add: cont_Istrictify2 cont_Istrictify1 cont2cont_CF1L)
2.699 +apply (subst beta_cfun)
2.700 +apply (rule cont_Istrictify2)
2.701 +apply (erule Istrictify2)
2.702 +done
2.703 +
2.704 +
2.705 +(* ------------------------------------------------------------------------ *)
2.706 +(* Instantiate the simplifier *)
2.707 +(* ------------------------------------------------------------------------ *)
2.708 +
2.709 +declare minimal [simp] refl_less [simp] beta_cfun [simp] strict_Rep_CFun1 [simp] strictify1 [simp] strictify2 [simp]
2.710 +
2.711 +
2.712 +(* ------------------------------------------------------------------------ *)
2.713 +(* use cont_tac as autotac. *)
2.714 +(* ------------------------------------------------------------------------ *)
2.715 +
2.716 +(* HINT: cont_tac is now installed in simplifier in Lift.ML ! *)
2.717 +(*simpset_ref() := simpset() addsolver (K (DEPTH_SOLVE_1 o cont_tac));*)
2.718 +
2.719 +(* ------------------------------------------------------------------------ *)
2.720 +(* some lemmata for functions with flat/chfin domain/range types *)
2.721 +(* ------------------------------------------------------------------------ *)
2.722 +
2.723 +lemma chfin_Rep_CFunR: "chain (Y::nat => 'a::cpo->'b::chfin)
2.724 + ==> !s. ? n. lub(range(Y))$s = Y n$s"
2.725 +apply (rule allI)
2.726 +apply (subst contlub_cfun_fun)
2.727 +apply assumption
2.728 +apply (fast intro!: thelubI chfin lub_finch2 chfin2finch ch2ch_Rep_CFunL)
2.729 +done
2.730 +
2.731 +(* ------------------------------------------------------------------------ *)
2.732 +(* continuous isomorphisms are strict *)
2.733 +(* a prove for embedding projection pairs is similar *)
2.734 +(* ------------------------------------------------------------------------ *)
2.735 +
2.736 +lemma iso_strict:
2.737 +"!!f g.[|!y. f$(g$y)=(y::'b) ; !x. g$(f$x)=(x::'a) |]
2.738 + ==> f$UU=UU & g$UU=UU"
2.739 +apply (rule conjI)
2.740 +apply (rule UU_I)
2.741 +apply (rule_tac s = "f$ (g$ (UU::'b))" and t = "UU::'b" in subst)
2.742 +apply (erule spec)
2.743 +apply (rule minimal [THEN monofun_cfun_arg])
2.744 +apply (rule UU_I)
2.745 +apply (rule_tac s = "g$ (f$ (UU::'a))" and t = "UU::'a" in subst)
2.746 +apply (erule spec)
2.747 +apply (rule minimal [THEN monofun_cfun_arg])
2.748 +done
2.749 +
2.750 +
2.751 +lemma isorep_defined: "[|!x. rep$(ab$x)=x;!y. ab$(rep$y)=y; z~=UU|] ==> rep$z ~= UU"
2.752 +apply (erule contrapos_nn)
2.753 +apply (drule_tac f = "ab" in cfun_arg_cong)
2.754 +apply (erule box_equals)
2.755 +apply fast
2.756 +apply (erule iso_strict [THEN conjunct1])
2.757 +apply assumption
2.758 +done
2.759 +
2.760 +lemma isoabs_defined: "[|!x. rep$(ab$x) = x;!y. ab$(rep$y)=y ; z~=UU|] ==> ab$z ~= UU"
2.761 +apply (erule contrapos_nn)
2.762 +apply (drule_tac f = "rep" in cfun_arg_cong)
2.763 +apply (erule box_equals)
2.764 +apply fast
2.765 +apply (erule iso_strict [THEN conjunct2])
2.766 +apply assumption
2.767 +done
2.768 +
2.769 +(* ------------------------------------------------------------------------ *)
2.770 +(* propagation of flatness and chainfiniteness by continuous isomorphisms *)
2.771 +(* ------------------------------------------------------------------------ *)
2.772 +
2.773 +lemma chfin2chfin: "!!f g.[|! Y::nat=>'a. chain Y --> (? n. max_in_chain n Y);
2.774 + !y. f$(g$y)=(y::'b) ; !x. g$(f$x)=(x::'a::chfin) |]
2.775 + ==> ! Y::nat=>'b. chain Y --> (? n. max_in_chain n Y)"
2.776 +apply (unfold max_in_chain_def)
2.777 +apply (intro strip)
2.778 +apply (rule exE)
2.779 +apply (rule_tac P = "chain (%i. g$ (Y i))" in mp)
2.780 +apply (erule spec)
2.781 +apply (erule ch2ch_Rep_CFunR)
2.782 +apply (rule exI)
2.783 +apply (intro strip)
2.784 +apply (rule_tac s = "f$ (g$ (Y x))" and t = "Y (x) " in subst)
2.785 +apply (erule spec)
2.786 +apply (rule_tac s = "f$ (g$ (Y j))" and t = "Y (j) " in subst)
2.787 +apply (erule spec)
2.788 +apply (rule cfun_arg_cong)
2.789 +apply (rule mp)
2.790 +apply (erule spec)
2.791 +apply assumption
2.792 +done
2.793 +
2.794 +
2.795 +lemma flat2flat: "!!f g.[|!x y::'a. x<<y --> x=UU | x=y;
2.796 + !y. f$(g$y)=(y::'b); !x. g$(f$x)=(x::'a)|] ==> !x y::'b. x<<y --> x=UU | x=y"
2.797 +apply (intro strip)
2.798 +apply (rule disjE)
2.799 +apply (rule_tac P = "g$x<<g$y" in mp)
2.800 +apply (erule_tac [2] monofun_cfun_arg)
2.801 +apply (drule spec)
2.802 +apply (erule spec)
2.803 +apply (rule disjI1)
2.804 +apply (rule trans)
2.805 +apply (rule_tac s = "f$ (g$x) " and t = "x" in subst)
2.806 +apply (erule spec)
2.807 +apply (erule cfun_arg_cong)
2.808 +apply (rule iso_strict [THEN conjunct1])
2.809 +apply assumption
2.810 +apply assumption
2.811 +apply (rule disjI2)
2.812 +apply (rule_tac s = "f$ (g$x) " and t = "x" in subst)
2.813 +apply (erule spec)
2.814 +apply (rule_tac s = "f$ (g$y) " and t = "y" in subst)
2.815 +apply (erule spec)
2.816 +apply (erule cfun_arg_cong)
2.817 +done
2.818 +
2.819 +(* ------------------------------------------------------------------------- *)
2.820 +(* a result about functions with flat codomain *)
2.821 +(* ------------------------------------------------------------------------- *)
2.822 +
2.823 +lemma flat_codom: "f$(x::'a)=(c::'b::flat) ==> f$(UU::'a)=(UU::'b) | (!z. f$(z::'a)=c)"
2.824 +apply (case_tac "f$ (x::'a) = (UU::'b) ")
2.825 +apply (rule disjI1)
2.826 +apply (rule UU_I)
2.827 +apply (rule_tac s = "f$ (x) " and t = "UU::'b" in subst)
2.828 +apply assumption
2.829 +apply (rule minimal [THEN monofun_cfun_arg])
2.830 +apply (case_tac "f$ (UU::'a) = (UU::'b) ")
2.831 +apply (erule disjI1)
2.832 +apply (rule disjI2)
2.833 +apply (rule allI)
2.834 +apply (erule subst)
2.835 +apply (rule_tac a = "f$ (UU::'a) " in refl [THEN box_equals])
2.836 +apply (rule_tac fo5 = "f" in minimal [THEN monofun_cfun_arg, THEN ax_flat [THEN spec, THEN spec, THEN mp], THEN disjE])
2.837 +apply simp
2.838 +apply assumption
2.839 +apply (rule_tac fo5 = "f" in minimal [THEN monofun_cfun_arg, THEN ax_flat [THEN spec, THEN spec, THEN mp], THEN disjE])
2.840 +apply simp
2.841 +apply assumption
2.842 +done
2.843 +
2.844 +
2.845 +(* ------------------------------------------------------------------------ *)
2.846 +(* Access to definitions *)
2.847 +(* ------------------------------------------------------------------------ *)
2.848 +
2.849 +
2.850 +lemma ID1: "ID$x=x"
2.851 +apply (unfold ID_def)
2.852 +apply (subst beta_cfun)
2.853 +apply (rule cont_id)
2.854 +apply (rule refl)
2.855 +done
2.856 +
2.857 +lemma cfcomp1: "(f oo g)=(LAM x. f$(g$x))"
2.858 +apply (unfold oo_def)
2.859 +apply (subst beta_cfun)
2.860 +apply (simp (no_asm))
2.861 +apply (subst beta_cfun)
2.862 +apply (simp (no_asm))
2.863 +apply (rule refl)
2.864 +done
2.865 +
2.866 +lemma cfcomp2: "(f oo g)$x=f$(g$x)"
2.867 +apply (subst cfcomp1)
2.868 +apply (subst beta_cfun)
2.869 +apply (simp (no_asm))
2.870 +apply (rule refl)
2.871 +done
2.872 +
2.873 +
2.874 +(* ------------------------------------------------------------------------ *)
2.875 +(* Show that interpretation of (pcpo,_->_) is a category *)
2.876 +(* The class of objects is interpretation of syntactical class pcpo *)
2.877 +(* The class of arrows between objects 'a and 'b is interpret. of 'a -> 'b *)
2.878 +(* The identity arrow is interpretation of ID *)
2.879 +(* The composition of f and g is interpretation of oo *)
2.880 +(* ------------------------------------------------------------------------ *)
2.881 +
2.882 +
2.883 +lemma ID2: "f oo ID = f "
2.884 +apply (rule ext_cfun)
2.885 +apply (subst cfcomp2)
2.886 +apply (subst ID1)
2.887 +apply (rule refl)
2.888 +done
2.889 +
2.890 +lemma ID3: "ID oo f = f "
2.891 +apply (rule ext_cfun)
2.892 +apply (subst cfcomp2)
2.893 +apply (subst ID1)
2.894 +apply (rule refl)
2.895 +done
2.896 +
2.897 +
2.898 +lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
2.899 +apply (rule ext_cfun)
2.900 +apply (rule_tac s = "f$ (g$ (h$x))" in trans)
2.901 +apply (subst cfcomp2)
2.902 +apply (subst cfcomp2)
2.903 +apply (rule refl)
2.904 +apply (subst cfcomp2)
2.905 +apply (subst cfcomp2)
2.906 +apply (rule refl)
2.907 +done
2.908 +
2.909 +(* ------------------------------------------------------------------------ *)
2.910 +(* Merge the different rewrite rules for the simplifier *)
2.911 +(* ------------------------------------------------------------------------ *)
2.912 +
2.913 +declare ID1[simp] ID2[simp] ID3[simp] cfcomp2[simp]
2.914 +
2.915 +end
3.1 --- a/src/HOLCF/Cfun1.ML Fri Mar 04 18:53:46 2005 +0100
3.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
3.3 @@ -1,16 +0,0 @@
3.4 -
3.5 -(* legacy ML bindings *)
3.6 -
3.7 -val less_cfun_def = thm "less_cfun_def";
3.8 -val Rep_Cfun = thm "Rep_Cfun";
3.9 -val Rep_Cfun_inverse = thm "Rep_Cfun_inverse";
3.10 -val Abs_Cfun_inverse = thm "Abs_Cfun_inverse";
3.11 -val refl_less_cfun = thm "refl_less_cfun";
3.12 -val antisym_less_cfun = thm "antisym_less_cfun";
3.13 -val trans_less_cfun = thm "trans_less_cfun";
3.14 -val cfun_cong = thm "cfun_cong";
3.15 -val cfun_fun_cong = thm "cfun_fun_cong";
3.16 -val cfun_arg_cong = thm "cfun_arg_cong";
3.17 -val Abs_Cfun_inverse2 = thm "Abs_Cfun_inverse2";
3.18 -val Cfunapp2 = thm "Cfunapp2";
3.19 -val beta_cfun = thm "beta_cfun";
4.1 --- a/src/HOLCF/Cfun1.thy Fri Mar 04 18:53:46 2005 +0100
4.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
4.3 @@ -1,138 +0,0 @@
4.4 -(* Title: HOLCF/Cfun1.thy
4.5 - ID: $Id$
4.6 - Author: Franz Regensburger
4.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
4.8 -
4.9 -Definition of the type -> of continuous functions.
4.10 -
4.11 -*)
4.12 -
4.13 -theory Cfun1 = Cont:
4.14 -
4.15 -defaultsort cpo
4.16 -
4.17 -typedef (CFun) ('a, 'b) "->" (infixr 0) = "{f::'a => 'b. cont f}"
4.18 -by (rule exI, rule CfunI)
4.19 -
4.20 -(* to make << defineable *)
4.21 -instance "->" :: (cpo,cpo)sq_ord ..
4.22 -
4.23 -syntax
4.24 - Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("_$_" [999,1000] 999)
4.25 - (* application *)
4.26 - Abs_CFun :: "('a => 'b) => ('a -> 'b)" (binder "LAM " 10)
4.27 - (* abstraction *)
4.28 - less_cfun :: "[('a -> 'b),('a -> 'b)]=>bool"
4.29 -
4.30 -syntax (xsymbols)
4.31 - "->" :: "[type, type] => type" ("(_ \<rightarrow>/ _)" [1,0]0)
4.32 - "LAM " :: "[idts, 'a => 'b] => ('a -> 'b)"
4.33 - ("(3\<Lambda>_./ _)" [0, 10] 10)
4.34 - Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("(_\<cdot>_)" [999,1000] 999)
4.35 -
4.36 -syntax (HTML output)
4.37 - Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("(_\<cdot>_)" [999,1000] 999)
4.38 -
4.39 -defs (overloaded)
4.40 - less_cfun_def: "(op <<) == (% fo1 fo2. Rep_CFun fo1 << Rep_CFun fo2 )"
4.41 -
4.42 -(* Title: HOLCF/Cfun1.ML
4.43 - ID: $Id$
4.44 - Author: Franz Regensburger
4.45 - License: GPL (GNU GENERAL PUBLIC LICENSE)
4.46 -
4.47 -The type -> of continuous functions.
4.48 -*)
4.49 -
4.50 -(* ------------------------------------------------------------------------ *)
4.51 -(* derive old type definition rules for Abs_CFun & Rep_CFun
4.52 - *)
4.53 -(* Rep_CFun and Abs_CFun should be replaced by Rep_Cfun anf Abs_Cfun in future
4.54 - *)
4.55 -(* ------------------------------------------------------------------------ *)
4.56 -
4.57 -lemma Rep_Cfun: "Rep_CFun fo : CFun"
4.58 -apply (rule Rep_CFun)
4.59 -done
4.60 -
4.61 -lemma Rep_Cfun_inverse: "Abs_CFun (Rep_CFun fo) = fo"
4.62 -apply (rule Rep_CFun_inverse)
4.63 -done
4.64 -
4.65 -lemma Abs_Cfun_inverse: "f:CFun==>Rep_CFun(Abs_CFun f)=f"
4.66 -apply (erule Abs_CFun_inverse)
4.67 -done
4.68 -
4.69 -(* ------------------------------------------------------------------------ *)
4.70 -(* less_cfun is a partial order on type 'a -> 'b *)
4.71 -(* ------------------------------------------------------------------------ *)
4.72 -
4.73 -lemma refl_less_cfun: "(f::'a->'b) << f"
4.74 -
4.75 -apply (unfold less_cfun_def)
4.76 -apply (rule refl_less)
4.77 -done
4.78 -
4.79 -lemma antisym_less_cfun:
4.80 - "[|(f1::'a->'b) << f2; f2 << f1|] ==> f1 = f2"
4.81 -apply (unfold less_cfun_def)
4.82 -apply (rule injD)
4.83 -apply (rule_tac [2] antisym_less)
4.84 -prefer 3 apply (assumption)
4.85 -prefer 2 apply (assumption)
4.86 -apply (rule inj_on_inverseI)
4.87 -apply (rule Rep_Cfun_inverse)
4.88 -done
4.89 -
4.90 -lemma trans_less_cfun:
4.91 - "[|(f1::'a->'b) << f2; f2 << f3|] ==> f1 << f3"
4.92 -apply (unfold less_cfun_def)
4.93 -apply (erule trans_less)
4.94 -apply assumption
4.95 -done
4.96 -
4.97 -(* ------------------------------------------------------------------------ *)
4.98 -(* lemmas about application of continuous functions *)
4.99 -(* ------------------------------------------------------------------------ *)
4.100 -
4.101 -lemma cfun_cong: "[| f=g; x=y |] ==> f$x = g$y"
4.102 -apply (simp (no_asm_simp))
4.103 -done
4.104 -
4.105 -lemma cfun_fun_cong: "f=g ==> f$x = g$x"
4.106 -apply (simp (no_asm_simp))
4.107 -done
4.108 -
4.109 -lemma cfun_arg_cong: "x=y ==> f$x = f$y"
4.110 -apply (simp (no_asm_simp))
4.111 -done
4.112 -
4.113 -
4.114 -(* ------------------------------------------------------------------------ *)
4.115 -(* additional lemma about the isomorphism between -> and Cfun *)
4.116 -(* ------------------------------------------------------------------------ *)
4.117 -
4.118 -lemma Abs_Cfun_inverse2: "cont f ==> Rep_CFun (Abs_CFun f) = f"
4.119 -apply (rule Abs_Cfun_inverse)
4.120 -apply (unfold CFun_def)
4.121 -apply (erule mem_Collect_eq [THEN ssubst])
4.122 -done
4.123 -
4.124 -(* ------------------------------------------------------------------------ *)
4.125 -(* simplification of application *)
4.126 -(* ------------------------------------------------------------------------ *)
4.127 -
4.128 -lemma Cfunapp2: "cont f ==> (Abs_CFun f)$x = f x"
4.129 -apply (erule Abs_Cfun_inverse2 [THEN fun_cong])
4.130 -done
4.131 -
4.132 -(* ------------------------------------------------------------------------ *)
4.133 -(* beta - equality for continuous functions *)
4.134 -(* ------------------------------------------------------------------------ *)
4.135 -
4.136 -lemma beta_cfun: "cont(c1) ==> (LAM x .c1 x)$u = c1 u"
4.137 -apply (rule Cfunapp2)
4.138 -apply assumption
4.139 -done
4.140 -
4.141 -end
5.1 --- a/src/HOLCF/Cfun2.ML Fri Mar 04 18:53:46 2005 +0100
5.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
5.3 @@ -1,30 +0,0 @@
5.4 -
5.5 -(* legacy ML bindings *)
5.6 -
5.7 -val inst_cfun_po = thm "inst_cfun_po";
5.8 -val less_cfun = thm "less_cfun";
5.9 -val minimal_cfun = thm "minimal_cfun";
5.10 -val UU_cfun_def = thm "UU_cfun_def";
5.11 -val least_cfun = thm "least_cfun";
5.12 -val cont_Rep_CFun2 = thm "cont_Rep_CFun2";
5.13 -val monofun_Rep_CFun2 = thm "monofun_Rep_CFun2";
5.14 -val contlub_Rep_CFun2 = thm "contlub_Rep_CFun2";
5.15 -val cont_cfun_arg = thm "cont_cfun_arg";
5.16 -val contlub_cfun_arg = thm "contlub_cfun_arg";
5.17 -val monofun_Rep_CFun1 = thm "monofun_Rep_CFun1";
5.18 -val monofun_cfun_fun = thm "monofun_cfun_fun";
5.19 -val monofun_cfun_arg = thm "monofun_cfun_arg";
5.20 -val chain_monofun = thm "chain_monofun";
5.21 -val monofun_cfun = thm "monofun_cfun";
5.22 -val strictI = thm "strictI";
5.23 -val ch2ch_Rep_CFunR = thm "ch2ch_Rep_CFunR";
5.24 -val ch2ch_Rep_CFunL = thm "ch2ch_Rep_CFunL";
5.25 -val lub_cfun_mono = thm "lub_cfun_mono";
5.26 -val ex_lubcfun = thm "ex_lubcfun";
5.27 -val cont_lubcfun = thm "cont_lubcfun";
5.28 -val lub_cfun = thm "lub_cfun";
5.29 -val thelub_cfun = thm "thelub_cfun";
5.30 -val cpo_cfun = thm "cpo_cfun";
5.31 -val ext_cfun = thm "ext_cfun";
5.32 -val semi_monofun_Abs_CFun = thm "semi_monofun_Abs_CFun";
5.33 -val less_cfun2 = thm "less_cfun2";
6.1 --- a/src/HOLCF/Cfun2.thy Fri Mar 04 18:53:46 2005 +0100
6.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
6.3 @@ -1,267 +0,0 @@
6.4 -(* Title: HOLCF/Cfun2.thy
6.5 - ID: $Id$
6.6 - Author: Franz Regensburger
6.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
6.8 -
6.9 -Class Instance ->::(cpo,cpo)po
6.10 -
6.11 -*)
6.12 -
6.13 -theory Cfun2 = Cfun1:
6.14 -
6.15 -instance "->"::(cpo,cpo)po
6.16 -apply (intro_classes)
6.17 -apply (rule refl_less_cfun)
6.18 -apply (rule antisym_less_cfun, assumption+)
6.19 -apply (rule trans_less_cfun, assumption+)
6.20 -done
6.21 -
6.22 -(* Title: HOLCF/Cfun2
6.23 - ID: $Id$
6.24 - Author: Franz Regensburger
6.25 - License: GPL (GNU GENERAL PUBLIC LICENSE)
6.26 -
6.27 -Class Instance ->::(cpo,cpo)po
6.28 -*)
6.29 -
6.30 -(* for compatibility with old HOLCF-Version *)
6.31 -lemma inst_cfun_po: "(op <<)=(%f1 f2. Rep_CFun f1 << Rep_CFun f2)"
6.32 -apply (fold less_cfun_def)
6.33 -apply (rule refl)
6.34 -done
6.35 -
6.36 -(* ------------------------------------------------------------------------ *)
6.37 -(* access to less_cfun in class po *)
6.38 -(* ------------------------------------------------------------------------ *)
6.39 -
6.40 -lemma less_cfun: "( f1 << f2 ) = (Rep_CFun(f1) << Rep_CFun(f2))"
6.41 -apply (simp (no_asm) add: inst_cfun_po)
6.42 -done
6.43 -
6.44 -(* ------------------------------------------------------------------------ *)
6.45 -(* Type 'a ->'b is pointed *)
6.46 -(* ------------------------------------------------------------------------ *)
6.47 -
6.48 -lemma minimal_cfun: "Abs_CFun(% x. UU) << f"
6.49 -apply (subst less_cfun)
6.50 -apply (subst Abs_Cfun_inverse2)
6.51 -apply (rule cont_const)
6.52 -apply (rule minimal_fun)
6.53 -done
6.54 -
6.55 -lemmas UU_cfun_def = minimal_cfun [THEN minimal2UU, symmetric, standard]
6.56 -
6.57 -lemma least_cfun: "? x::'a->'b::pcpo.!y. x<<y"
6.58 -apply (rule_tac x = "Abs_CFun (% x. UU) " in exI)
6.59 -apply (rule minimal_cfun [THEN allI])
6.60 -done
6.61 -
6.62 -(* ------------------------------------------------------------------------ *)
6.63 -(* Rep_CFun yields continuous functions in 'a => 'b *)
6.64 -(* this is continuity of Rep_CFun in its 'second' argument *)
6.65 -(* cont_Rep_CFun2 ==> monofun_Rep_CFun2 & contlub_Rep_CFun2 *)
6.66 -(* ------------------------------------------------------------------------ *)
6.67 -
6.68 -lemma cont_Rep_CFun2: "cont(Rep_CFun(fo))"
6.69 -apply (rule_tac P = "cont" in CollectD)
6.70 -apply (fold CFun_def)
6.71 -apply (rule Rep_Cfun)
6.72 -done
6.73 -
6.74 -lemmas monofun_Rep_CFun2 = cont_Rep_CFun2 [THEN cont2mono, standard]
6.75 -(* monofun(Rep_CFun(?fo1)) *)
6.76 -
6.77 -
6.78 -lemmas contlub_Rep_CFun2 = cont_Rep_CFun2 [THEN cont2contlub, standard]
6.79 -(* contlub(Rep_CFun(?fo1)) *)
6.80 -
6.81 -(* ------------------------------------------------------------------------ *)
6.82 -(* expanded thms cont_Rep_CFun2, contlub_Rep_CFun2 *)
6.83 -(* looks nice with mixfix syntac *)
6.84 -(* ------------------------------------------------------------------------ *)
6.85 -
6.86 -lemmas cont_cfun_arg = cont_Rep_CFun2 [THEN contE, THEN spec, THEN mp]
6.87 -(* chain(?x1) ==> range (%i. ?fo3$(?x1 i)) <<| ?fo3$(lub (range ?x1)) *)
6.88 -
6.89 -lemmas contlub_cfun_arg = contlub_Rep_CFun2 [THEN contlubE, THEN spec, THEN mp]
6.90 -(* chain(?x1) ==> ?fo4$(lub (range ?x1)) = lub (range (%i. ?fo4$(?x1 i))) *)
6.91 -
6.92 -
6.93 -(* ------------------------------------------------------------------------ *)
6.94 -(* Rep_CFun is monotone in its 'first' argument *)
6.95 -(* ------------------------------------------------------------------------ *)
6.96 -
6.97 -lemma monofun_Rep_CFun1: "monofun(Rep_CFun)"
6.98 -apply (unfold monofun)
6.99 -apply (intro strip)
6.100 -apply (erule less_cfun [THEN subst])
6.101 -done
6.102 -
6.103 -
6.104 -(* ------------------------------------------------------------------------ *)
6.105 -(* monotonicity of application Rep_CFun in mixfix syntax [_]_ *)
6.106 -(* ------------------------------------------------------------------------ *)
6.107 -
6.108 -lemma monofun_cfun_fun: "f1 << f2 ==> f1$x << f2$x"
6.109 -apply (rule_tac x = "x" in spec)
6.110 -apply (rule less_fun [THEN subst])
6.111 -apply (erule monofun_Rep_CFun1 [THEN monofunE, THEN spec, THEN spec, THEN mp])
6.112 -done
6.113 -
6.114 -
6.115 -lemmas monofun_cfun_arg = monofun_Rep_CFun2 [THEN monofunE, THEN spec, THEN spec, THEN mp, standard]
6.116 -(* ?x2 << ?x1 ==> ?fo5$?x2 << ?fo5$?x1 *)
6.117 -
6.118 -lemma chain_monofun: "chain Y ==> chain (%i. f\<cdot>(Y i))"
6.119 -apply (rule chainI)
6.120 -apply (rule monofun_cfun_arg)
6.121 -apply (erule chainE)
6.122 -done
6.123 -
6.124 -
6.125 -(* ------------------------------------------------------------------------ *)
6.126 -(* monotonicity of Rep_CFun in both arguments in mixfix syntax [_]_ *)
6.127 -(* ------------------------------------------------------------------------ *)
6.128 -
6.129 -lemma monofun_cfun: "[|f1<<f2;x1<<x2|] ==> f1$x1 << f2$x2"
6.130 -apply (rule trans_less)
6.131 -apply (erule monofun_cfun_arg)
6.132 -apply (erule monofun_cfun_fun)
6.133 -done
6.134 -
6.135 -
6.136 -lemma strictI: "f$x = UU ==> f$UU = UU"
6.137 -apply (rule eq_UU_iff [THEN iffD2])
6.138 -apply (erule subst)
6.139 -apply (rule minimal [THEN monofun_cfun_arg])
6.140 -done
6.141 -
6.142 -
6.143 -(* ------------------------------------------------------------------------ *)
6.144 -(* ch2ch - rules for the type 'a -> 'b *)
6.145 -(* use MF2 lemmas from Cont.ML *)
6.146 -(* ------------------------------------------------------------------------ *)
6.147 -
6.148 -lemma ch2ch_Rep_CFunR: "chain(Y) ==> chain(%i. f$(Y i))"
6.149 -apply (erule monofun_Rep_CFun2 [THEN ch2ch_MF2R])
6.150 -done
6.151 -
6.152 -
6.153 -lemmas ch2ch_Rep_CFunL = monofun_Rep_CFun1 [THEN ch2ch_MF2L, standard]
6.154 -(* chain(?F) ==> chain (%i. ?F i$?x) *)
6.155 -
6.156 -
6.157 -(* ------------------------------------------------------------------------ *)
6.158 -(* the lub of a chain of continous functions is monotone *)
6.159 -(* use MF2 lemmas from Cont.ML *)
6.160 -(* ------------------------------------------------------------------------ *)
6.161 -
6.162 -lemma lub_cfun_mono: "chain(F) ==> monofun(% x. lub(range(% j.(F j)$x)))"
6.163 -apply (rule lub_MF2_mono)
6.164 -apply (rule monofun_Rep_CFun1)
6.165 -apply (rule monofun_Rep_CFun2 [THEN allI])
6.166 -apply assumption
6.167 -done
6.168 -
6.169 -(* ------------------------------------------------------------------------ *)
6.170 -(* a lemma about the exchange of lubs for type 'a -> 'b *)
6.171 -(* use MF2 lemmas from Cont.ML *)
6.172 -(* ------------------------------------------------------------------------ *)
6.173 -
6.174 -lemma ex_lubcfun: "[| chain(F); chain(Y) |] ==>
6.175 - lub(range(%j. lub(range(%i. F(j)$(Y i))))) =
6.176 - lub(range(%i. lub(range(%j. F(j)$(Y i)))))"
6.177 -apply (rule ex_lubMF2)
6.178 -apply (rule monofun_Rep_CFun1)
6.179 -apply (rule monofun_Rep_CFun2 [THEN allI])
6.180 -apply assumption
6.181 -apply assumption
6.182 -done
6.183 -
6.184 -(* ------------------------------------------------------------------------ *)
6.185 -(* the lub of a chain of cont. functions is continuous *)
6.186 -(* ------------------------------------------------------------------------ *)
6.187 -
6.188 -lemma cont_lubcfun: "chain(F) ==> cont(% x. lub(range(% j. F(j)$x)))"
6.189 -apply (rule monocontlub2cont)
6.190 -apply (erule lub_cfun_mono)
6.191 -apply (rule contlubI)
6.192 -apply (intro strip)
6.193 -apply (subst contlub_cfun_arg [THEN ext])
6.194 -apply assumption
6.195 -apply (erule ex_lubcfun)
6.196 -apply assumption
6.197 -done
6.198 -
6.199 -(* ------------------------------------------------------------------------ *)
6.200 -(* type 'a -> 'b is chain complete *)
6.201 -(* ------------------------------------------------------------------------ *)
6.202 -
6.203 -lemma lub_cfun: "chain(CCF) ==> range(CCF) <<| (LAM x. lub(range(% i. CCF(i)$x)))"
6.204 -apply (rule is_lubI)
6.205 -apply (rule ub_rangeI)
6.206 -apply (subst less_cfun)
6.207 -apply (subst Abs_Cfun_inverse2)
6.208 -apply (erule cont_lubcfun)
6.209 -apply (rule lub_fun [THEN is_lubD1, THEN ub_rangeD])
6.210 -apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
6.211 -apply (subst less_cfun)
6.212 -apply (subst Abs_Cfun_inverse2)
6.213 -apply (erule cont_lubcfun)
6.214 -apply (rule lub_fun [THEN is_lub_lub])
6.215 -apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
6.216 -apply (erule monofun_Rep_CFun1 [THEN ub2ub_monofun])
6.217 -done
6.218 -
6.219 -lemmas thelub_cfun = lub_cfun [THEN thelubI, standard]
6.220 -(*
6.221 -chain(?CCF1) ==> lub (range ?CCF1) = (LAM x. lub (range (%i. ?CCF1 i$x)))
6.222 -*)
6.223 -
6.224 -lemma cpo_cfun: "chain(CCF::nat=>('a->'b)) ==> ? x. range(CCF) <<| x"
6.225 -apply (rule exI)
6.226 -apply (erule lub_cfun)
6.227 -done
6.228 -
6.229 -
6.230 -(* ------------------------------------------------------------------------ *)
6.231 -(* Extensionality in 'a -> 'b *)
6.232 -(* ------------------------------------------------------------------------ *)
6.233 -
6.234 -lemma ext_cfun: "(!!x. f$x = g$x) ==> f = g"
6.235 -apply (rule_tac t = "f" in Rep_Cfun_inverse [THEN subst])
6.236 -apply (rule_tac t = "g" in Rep_Cfun_inverse [THEN subst])
6.237 -apply (rule_tac f = "Abs_CFun" in arg_cong)
6.238 -apply (rule ext)
6.239 -apply simp
6.240 -done
6.241 -
6.242 -(* ------------------------------------------------------------------------ *)
6.243 -(* Monotonicity of Abs_CFun *)
6.244 -(* ------------------------------------------------------------------------ *)
6.245 -
6.246 -lemma semi_monofun_Abs_CFun: "[| cont(f); cont(g); f<<g|] ==> Abs_CFun(f)<<Abs_CFun(g)"
6.247 -apply (rule less_cfun [THEN iffD2])
6.248 -apply (subst Abs_Cfun_inverse2)
6.249 -apply assumption
6.250 -apply (subst Abs_Cfun_inverse2)
6.251 -apply assumption
6.252 -apply assumption
6.253 -done
6.254 -
6.255 -(* ------------------------------------------------------------------------ *)
6.256 -(* Extenionality wrt. << in 'a -> 'b *)
6.257 -(* ------------------------------------------------------------------------ *)
6.258 -
6.259 -lemma less_cfun2: "(!!x. f$x << g$x) ==> f << g"
6.260 -apply (rule_tac t = "f" in Rep_Cfun_inverse [THEN subst])
6.261 -apply (rule_tac t = "g" in Rep_Cfun_inverse [THEN subst])
6.262 -apply (rule semi_monofun_Abs_CFun)
6.263 -apply (rule cont_Rep_CFun2)
6.264 -apply (rule cont_Rep_CFun2)
6.265 -apply (rule less_fun [THEN iffD2])
6.266 -apply (rule allI)
6.267 -apply simp
6.268 -done
6.269 -
6.270 -end
7.1 --- a/src/HOLCF/Cfun3.ML Fri Mar 04 18:53:46 2005 +0100
7.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
7.3 @@ -1,52 +0,0 @@
7.4 -
7.5 -(* legacy ML bindings *)
7.6 -
7.7 -val Istrictify_def = thm "Istrictify_def";
7.8 -val strictify_def = thm "strictify_def";
7.9 -val ID_def = thm "ID_def";
7.10 -val oo_def = thm "oo_def";
7.11 -val inst_cfun_pcpo = thm "inst_cfun_pcpo";
7.12 -val contlub_Rep_CFun1 = thm "contlub_Rep_CFun1";
7.13 -val cont_Rep_CFun1 = thm "cont_Rep_CFun1";
7.14 -val contlub_cfun_fun = thm "contlub_cfun_fun";
7.15 -val cont_cfun_fun = thm "cont_cfun_fun";
7.16 -val contlub_cfun = thm "contlub_cfun";
7.17 -val cont_cfun = thm "cont_cfun";
7.18 -val cont2cont_Rep_CFun = thm "cont2cont_Rep_CFun";
7.19 -val cont2mono_LAM = thm "cont2mono_LAM";
7.20 -val cont2cont_LAM = thm "cont2cont_LAM";
7.21 -val cont_lemmas1 = [cont_const, cont_id, cont_Rep_CFun2,
7.22 - cont2cont_Rep_CFun, cont2cont_LAM];
7.23 -val strict_Rep_CFun1 = thm "strict_Rep_CFun1";
7.24 -val Istrictify1 = thm "Istrictify1";
7.25 -val Istrictify2 = thm "Istrictify2";
7.26 -val monofun_Istrictify1 = thm "monofun_Istrictify1";
7.27 -val monofun_Istrictify2 = thm "monofun_Istrictify2";
7.28 -val contlub_Istrictify1 = thm "contlub_Istrictify1";
7.29 -val contlub_Istrictify2 = thm "contlub_Istrictify2";
7.30 -val cont_Istrictify1 = thm "cont_Istrictify1";
7.31 -val cont_Istrictify2 = thm "cont_Istrictify2";
7.32 -val strictify1 = thm "strictify1";
7.33 -val strictify2 = thm "strictify2";
7.34 -val chfin_Rep_CFunR = thm "chfin_Rep_CFunR";
7.35 -val iso_strict = thm "iso_strict";
7.36 -val isorep_defined = thm "isorep_defined";
7.37 -val isoabs_defined = thm "isoabs_defined";
7.38 -val chfin2chfin = thm "chfin2chfin";
7.39 -val flat2flat = thm "flat2flat";
7.40 -val flat_codom = thm "flat_codom";
7.41 -val ID1 = thm "ID1";
7.42 -val cfcomp1 = thm "cfcomp1";
7.43 -val cfcomp2 = thm "cfcomp2";
7.44 -val ID2 = thm "ID2";
7.45 -val ID3 = thm "ID3";
7.46 -val assoc_oo = thm "assoc_oo";
7.47 -
7.48 -structure Cfun3 =
7.49 -struct
7.50 - val thy = the_context ();
7.51 - val Istrictify_def = Istrictify_def;
7.52 - val strictify_def = strictify_def;
7.53 - val ID_def = ID_def;
7.54 - val oo_def = oo_def;
7.55 -end;
8.1 --- a/src/HOLCF/Cfun3.thy Fri Mar 04 18:53:46 2005 +0100
8.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
8.3 @@ -1,546 +0,0 @@
8.4 -(* Title: HOLCF/Cfun3.thy
8.5 - ID: $Id$
8.6 - Author: Franz Regensburger
8.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
8.8 -
8.9 -Class instance of -> for class pcpo
8.10 -
8.11 -*)
8.12 -
8.13 -theory Cfun3 = Cfun2:
8.14 -
8.15 -instance "->" :: (cpo,cpo)cpo
8.16 -by (intro_classes, rule cpo_cfun)
8.17 -
8.18 -instance "->" :: (cpo,pcpo)pcpo
8.19 -by (intro_classes, rule least_cfun)
8.20 -
8.21 -defaultsort pcpo
8.22 -
8.23 -consts
8.24 - Istrictify :: "('a->'b)=>'a=>'b"
8.25 - strictify :: "('a->'b)->'a->'b"
8.26 -defs
8.27 -
8.28 -Istrictify_def: "Istrictify f x == if x=UU then UU else f$x"
8.29 -strictify_def: "strictify == (LAM f x. Istrictify f x)"
8.30 -
8.31 -consts
8.32 - ID :: "('a::cpo) -> 'a"
8.33 - cfcomp :: "('b->'c)->(('a::cpo)->('b::cpo))->'a->('c::cpo)"
8.34 -
8.35 -syntax "@oo" :: "('b->'c)=>('a->'b)=>'a->'c" ("_ oo _" [101,100] 100)
8.36 -
8.37 -translations "f1 oo f2" == "cfcomp$f1$f2"
8.38 -
8.39 -defs
8.40 -
8.41 - ID_def: "ID ==(LAM x. x)"
8.42 - oo_def: "cfcomp == (LAM f g x. f$(g$x))"
8.43 -
8.44 -(* Title: HOLCF/Cfun3
8.45 - ID: $Id$
8.46 - Author: Franz Regensburger
8.47 - License: GPL (GNU GENERAL PUBLIC LICENSE)
8.48 -
8.49 -Class instance of -> for class pcpo
8.50 -*)
8.51 -
8.52 -(* for compatibility with old HOLCF-Version *)
8.53 -lemma inst_cfun_pcpo: "UU = Abs_CFun(%x. UU)"
8.54 -apply (simp add: UU_def UU_cfun_def)
8.55 -done
8.56 -
8.57 -(* ------------------------------------------------------------------------ *)
8.58 -(* the contlub property for Rep_CFun its 'first' argument *)
8.59 -(* ------------------------------------------------------------------------ *)
8.60 -
8.61 -lemma contlub_Rep_CFun1: "contlub(Rep_CFun)"
8.62 -apply (rule contlubI)
8.63 -apply (intro strip)
8.64 -apply (rule expand_fun_eq [THEN iffD2])
8.65 -apply (intro strip)
8.66 -apply (subst thelub_cfun)
8.67 -apply assumption
8.68 -apply (subst Cfunapp2)
8.69 -apply (erule cont_lubcfun)
8.70 -apply (subst thelub_fun)
8.71 -apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
8.72 -apply (rule refl)
8.73 -done
8.74 -
8.75 -
8.76 -(* ------------------------------------------------------------------------ *)
8.77 -(* the cont property for Rep_CFun in its first argument *)
8.78 -(* ------------------------------------------------------------------------ *)
8.79 -
8.80 -lemma cont_Rep_CFun1: "cont(Rep_CFun)"
8.81 -apply (rule monocontlub2cont)
8.82 -apply (rule monofun_Rep_CFun1)
8.83 -apply (rule contlub_Rep_CFun1)
8.84 -done
8.85 -
8.86 -
8.87 -(* ------------------------------------------------------------------------ *)
8.88 -(* contlub, cont properties of Rep_CFun in its first argument in mixfix _[_] *)
8.89 -(* ------------------------------------------------------------------------ *)
8.90 -
8.91 -lemma contlub_cfun_fun:
8.92 -"chain(FY) ==>
8.93 - lub(range FY)$x = lub(range (%i. FY(i)$x))"
8.94 -apply (rule trans)
8.95 -apply (erule contlub_Rep_CFun1 [THEN contlubE, THEN spec, THEN mp, THEN fun_cong])
8.96 -apply (subst thelub_fun)
8.97 -apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
8.98 -apply (rule refl)
8.99 -done
8.100 -
8.101 -
8.102 -lemma cont_cfun_fun:
8.103 -"chain(FY) ==>
8.104 - range(%i. FY(i)$x) <<| lub(range FY)$x"
8.105 -apply (rule thelubE)
8.106 -apply (erule ch2ch_Rep_CFunL)
8.107 -apply (erule contlub_cfun_fun [symmetric])
8.108 -done
8.109 -
8.110 -
8.111 -(* ------------------------------------------------------------------------ *)
8.112 -(* contlub, cont properties of Rep_CFun in both argument in mixfix _[_] *)
8.113 -(* ------------------------------------------------------------------------ *)
8.114 -
8.115 -lemma contlub_cfun:
8.116 -"[|chain(FY);chain(TY)|] ==>
8.117 - (lub(range FY))$(lub(range TY)) = lub(range(%i. FY(i)$(TY i)))"
8.118 -apply (rule contlub_CF2)
8.119 -apply (rule cont_Rep_CFun1)
8.120 -apply (rule allI)
8.121 -apply (rule cont_Rep_CFun2)
8.122 -apply assumption
8.123 -apply assumption
8.124 -done
8.125 -
8.126 -lemma cont_cfun:
8.127 -"[|chain(FY);chain(TY)|] ==>
8.128 - range(%i.(FY i)$(TY i)) <<| (lub (range FY))$(lub(range TY))"
8.129 -apply (rule thelubE)
8.130 -apply (rule monofun_Rep_CFun1 [THEN ch2ch_MF2LR])
8.131 -apply (rule allI)
8.132 -apply (rule monofun_Rep_CFun2)
8.133 -apply assumption
8.134 -apply assumption
8.135 -apply (erule contlub_cfun [symmetric])
8.136 -apply assumption
8.137 -done
8.138 -
8.139 -
8.140 -(* ------------------------------------------------------------------------ *)
8.141 -(* cont2cont lemma for Rep_CFun *)
8.142 -(* ------------------------------------------------------------------------ *)
8.143 -
8.144 -lemma cont2cont_Rep_CFun: "[|cont(%x. ft x);cont(%x. tt x)|] ==> cont(%x. (ft x)$(tt x))"
8.145 -apply (best intro: cont2cont_app2 cont_const cont_Rep_CFun1 cont_Rep_CFun2)
8.146 -done
8.147 -
8.148 -
8.149 -
8.150 -(* ------------------------------------------------------------------------ *)
8.151 -(* cont2mono Lemma for %x. LAM y. c1(x)(y) *)
8.152 -(* ------------------------------------------------------------------------ *)
8.153 -
8.154 -lemma cont2mono_LAM:
8.155 -assumes p1: "!!x. cont(c1 x)"
8.156 -assumes p2: "!!y. monofun(%x. c1 x y)"
8.157 -shows "monofun(%x. LAM y. c1 x y)"
8.158 -apply (rule monofunI)
8.159 -apply (intro strip)
8.160 -apply (subst less_cfun)
8.161 -apply (subst less_fun)
8.162 -apply (rule allI)
8.163 -apply (subst beta_cfun)
8.164 -apply (rule p1)
8.165 -apply (subst beta_cfun)
8.166 -apply (rule p1)
8.167 -apply (erule p2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
8.168 -done
8.169 -
8.170 -(* ------------------------------------------------------------------------ *)
8.171 -(* cont2cont Lemma for %x. LAM y. c1 x y) *)
8.172 -(* ------------------------------------------------------------------------ *)
8.173 -
8.174 -lemma cont2cont_LAM:
8.175 -assumes p1: "!!x. cont(c1 x)"
8.176 -assumes p2: "!!y. cont(%x. c1 x y)"
8.177 -shows "cont(%x. LAM y. c1 x y)"
8.178 -apply (rule monocontlub2cont)
8.179 -apply (rule p1 [THEN cont2mono_LAM])
8.180 -apply (rule p2 [THEN cont2mono])
8.181 -apply (rule contlubI)
8.182 -apply (intro strip)
8.183 -apply (subst thelub_cfun)
8.184 -apply (rule p1 [THEN cont2mono_LAM, THEN ch2ch_monofun])
8.185 -apply (rule p2 [THEN cont2mono])
8.186 -apply assumption
8.187 -apply (rule_tac f = "Abs_CFun" in arg_cong)
8.188 -apply (rule ext)
8.189 -apply (subst p1 [THEN beta_cfun, THEN ext])
8.190 -apply (erule p2 [THEN cont2contlub, THEN contlubE, THEN spec, THEN mp])
8.191 -done
8.192 -
8.193 -(* ------------------------------------------------------------------------ *)
8.194 -(* cont2cont tactic *)
8.195 -(* ------------------------------------------------------------------------ *)
8.196 -
8.197 -lemmas cont_lemmas1 = cont_const cont_id cont_Rep_CFun2
8.198 - cont2cont_Rep_CFun cont2cont_LAM
8.199 -
8.200 -declare cont_lemmas1 [simp]
8.201 -
8.202 -(* HINT: cont_tac is now installed in simplifier in Lift.ML ! *)
8.203 -
8.204 -(*val cont_tac = (fn i => (resolve_tac cont_lemmas i));*)
8.205 -(*val cont_tacR = (fn i => (REPEAT (cont_tac i)));*)
8.206 -
8.207 -(* ------------------------------------------------------------------------ *)
8.208 -(* function application _[_] is strict in its first arguments *)
8.209 -(* ------------------------------------------------------------------------ *)
8.210 -
8.211 -lemma strict_Rep_CFun1: "(UU::'a::cpo->'b)$x = (UU::'b)"
8.212 -apply (subst inst_cfun_pcpo)
8.213 -apply (subst beta_cfun)
8.214 -apply (simp (no_asm))
8.215 -apply (rule refl)
8.216 -done
8.217 -
8.218 -
8.219 -(* ------------------------------------------------------------------------ *)
8.220 -(* results about strictify *)
8.221 -(* ------------------------------------------------------------------------ *)
8.222 -
8.223 -lemma Istrictify1:
8.224 - "Istrictify(f)(UU)= (UU)"
8.225 -apply (unfold Istrictify_def)
8.226 -apply (simp (no_asm))
8.227 -done
8.228 -
8.229 -lemma Istrictify2:
8.230 - "~x=UU ==> Istrictify(f)(x)=f$x"
8.231 -apply (unfold Istrictify_def)
8.232 -apply (simp (no_asm_simp))
8.233 -done
8.234 -
8.235 -lemma monofun_Istrictify1: "monofun(Istrictify)"
8.236 -apply (rule monofunI)
8.237 -apply (intro strip)
8.238 -apply (rule less_fun [THEN iffD2])
8.239 -apply (intro strip)
8.240 -apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
8.241 -apply (subst Istrictify2)
8.242 -apply assumption
8.243 -apply (subst Istrictify2)
8.244 -apply assumption
8.245 -apply (rule monofun_cfun_fun)
8.246 -apply assumption
8.247 -apply (erule ssubst)
8.248 -apply (subst Istrictify1)
8.249 -apply (subst Istrictify1)
8.250 -apply (rule refl_less)
8.251 -done
8.252 -
8.253 -lemma monofun_Istrictify2: "monofun(Istrictify(f))"
8.254 -apply (rule monofunI)
8.255 -apply (intro strip)
8.256 -apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
8.257 -apply (simplesubst Istrictify2)
8.258 -apply (erule notUU_I)
8.259 -apply assumption
8.260 -apply (subst Istrictify2)
8.261 -apply assumption
8.262 -apply (rule monofun_cfun_arg)
8.263 -apply assumption
8.264 -apply (erule ssubst)
8.265 -apply (subst Istrictify1)
8.266 -apply (rule minimal)
8.267 -done
8.268 -
8.269 -
8.270 -lemma contlub_Istrictify1: "contlub(Istrictify)"
8.271 -apply (rule contlubI)
8.272 -apply (intro strip)
8.273 -apply (rule expand_fun_eq [THEN iffD2])
8.274 -apply (intro strip)
8.275 -apply (subst thelub_fun)
8.276 -apply (erule monofun_Istrictify1 [THEN ch2ch_monofun])
8.277 -apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
8.278 -apply (subst Istrictify2)
8.279 -apply assumption
8.280 -apply (subst Istrictify2 [THEN ext])
8.281 -apply assumption
8.282 -apply (subst thelub_cfun)
8.283 -apply assumption
8.284 -apply (subst beta_cfun)
8.285 -apply (rule cont_lubcfun)
8.286 -apply assumption
8.287 -apply (rule refl)
8.288 -apply (erule ssubst)
8.289 -apply (subst Istrictify1)
8.290 -apply (subst Istrictify1 [THEN ext])
8.291 -apply (rule chain_UU_I_inverse [symmetric])
8.292 -apply (rule refl [THEN allI])
8.293 -done
8.294 -
8.295 -lemma contlub_Istrictify2: "contlub(Istrictify(f::'a -> 'b))"
8.296 -apply (rule contlubI)
8.297 -apply (intro strip)
8.298 -apply (case_tac "lub (range (Y))= (UU::'a) ")
8.299 -apply (simp (no_asm_simp) add: Istrictify1 chain_UU_I_inverse chain_UU_I Istrictify1)
8.300 -apply (subst Istrictify2)
8.301 -apply assumption
8.302 -apply (rule_tac s = "lub (range (%i. f$ (Y i))) " in trans)
8.303 -apply (rule contlub_cfun_arg)
8.304 -apply assumption
8.305 -apply (rule lub_equal2)
8.306 -prefer 3 apply (best intro: ch2ch_monofun monofun_Istrictify2)
8.307 -prefer 2 apply (best intro: ch2ch_monofun monofun_Rep_CFun2)
8.308 -apply (rule chain_mono2 [THEN exE])
8.309 -prefer 2 apply (assumption)
8.310 -apply (erule chain_UU_I_inverse2)
8.311 -apply (blast intro: Istrictify2 [symmetric])
8.312 -done
8.313 -
8.314 -
8.315 -lemmas cont_Istrictify1 = contlub_Istrictify1 [THEN monofun_Istrictify1 [THEN monocontlub2cont], standard]
8.316 -
8.317 -lemmas cont_Istrictify2 = contlub_Istrictify2 [THEN monofun_Istrictify2 [THEN monocontlub2cont], standard]
8.318 -
8.319 -
8.320 -lemma strictify1: "strictify$f$UU=UU"
8.321 -apply (unfold strictify_def)
8.322 -apply (subst beta_cfun)
8.323 -apply (simp (no_asm) add: cont_Istrictify2 cont_Istrictify1 cont2cont_CF1L)
8.324 -apply (subst beta_cfun)
8.325 -apply (rule cont_Istrictify2)
8.326 -apply (rule Istrictify1)
8.327 -done
8.328 -
8.329 -lemma strictify2: "~x=UU ==> strictify$f$x=f$x"
8.330 -apply (unfold strictify_def)
8.331 -apply (subst beta_cfun)
8.332 -apply (simp (no_asm) add: cont_Istrictify2 cont_Istrictify1 cont2cont_CF1L)
8.333 -apply (subst beta_cfun)
8.334 -apply (rule cont_Istrictify2)
8.335 -apply (erule Istrictify2)
8.336 -done
8.337 -
8.338 -
8.339 -(* ------------------------------------------------------------------------ *)
8.340 -(* Instantiate the simplifier *)
8.341 -(* ------------------------------------------------------------------------ *)
8.342 -
8.343 -declare minimal [simp] refl_less [simp] beta_cfun [simp] strict_Rep_CFun1 [simp] strictify1 [simp] strictify2 [simp]
8.344 -
8.345 -
8.346 -(* ------------------------------------------------------------------------ *)
8.347 -(* use cont_tac as autotac. *)
8.348 -(* ------------------------------------------------------------------------ *)
8.349 -
8.350 -(* HINT: cont_tac is now installed in simplifier in Lift.ML ! *)
8.351 -(*simpset_ref() := simpset() addsolver (K (DEPTH_SOLVE_1 o cont_tac));*)
8.352 -
8.353 -(* ------------------------------------------------------------------------ *)
8.354 -(* some lemmata for functions with flat/chfin domain/range types *)
8.355 -(* ------------------------------------------------------------------------ *)
8.356 -
8.357 -lemma chfin_Rep_CFunR: "chain (Y::nat => 'a::cpo->'b::chfin)
8.358 - ==> !s. ? n. lub(range(Y))$s = Y n$s"
8.359 -apply (rule allI)
8.360 -apply (subst contlub_cfun_fun)
8.361 -apply assumption
8.362 -apply (fast intro!: thelubI chfin lub_finch2 chfin2finch ch2ch_Rep_CFunL)
8.363 -done
8.364 -
8.365 -(* ------------------------------------------------------------------------ *)
8.366 -(* continuous isomorphisms are strict *)
8.367 -(* a prove for embedding projection pairs is similar *)
8.368 -(* ------------------------------------------------------------------------ *)
8.369 -
8.370 -lemma iso_strict:
8.371 -"!!f g.[|!y. f$(g$y)=(y::'b) ; !x. g$(f$x)=(x::'a) |]
8.372 - ==> f$UU=UU & g$UU=UU"
8.373 -apply (rule conjI)
8.374 -apply (rule UU_I)
8.375 -apply (rule_tac s = "f$ (g$ (UU::'b))" and t = "UU::'b" in subst)
8.376 -apply (erule spec)
8.377 -apply (rule minimal [THEN monofun_cfun_arg])
8.378 -apply (rule UU_I)
8.379 -apply (rule_tac s = "g$ (f$ (UU::'a))" and t = "UU::'a" in subst)
8.380 -apply (erule spec)
8.381 -apply (rule minimal [THEN monofun_cfun_arg])
8.382 -done
8.383 -
8.384 -
8.385 -lemma isorep_defined: "[|!x. rep$(ab$x)=x;!y. ab$(rep$y)=y; z~=UU|] ==> rep$z ~= UU"
8.386 -apply (erule contrapos_nn)
8.387 -apply (drule_tac f = "ab" in cfun_arg_cong)
8.388 -apply (erule box_equals)
8.389 -apply fast
8.390 -apply (erule iso_strict [THEN conjunct1])
8.391 -apply assumption
8.392 -done
8.393 -
8.394 -lemma isoabs_defined: "[|!x. rep$(ab$x) = x;!y. ab$(rep$y)=y ; z~=UU|] ==> ab$z ~= UU"
8.395 -apply (erule contrapos_nn)
8.396 -apply (drule_tac f = "rep" in cfun_arg_cong)
8.397 -apply (erule box_equals)
8.398 -apply fast
8.399 -apply (erule iso_strict [THEN conjunct2])
8.400 -apply assumption
8.401 -done
8.402 -
8.403 -(* ------------------------------------------------------------------------ *)
8.404 -(* propagation of flatness and chainfiniteness by continuous isomorphisms *)
8.405 -(* ------------------------------------------------------------------------ *)
8.406 -
8.407 -lemma chfin2chfin: "!!f g.[|! Y::nat=>'a. chain Y --> (? n. max_in_chain n Y);
8.408 - !y. f$(g$y)=(y::'b) ; !x. g$(f$x)=(x::'a::chfin) |]
8.409 - ==> ! Y::nat=>'b. chain Y --> (? n. max_in_chain n Y)"
8.410 -apply (unfold max_in_chain_def)
8.411 -apply (intro strip)
8.412 -apply (rule exE)
8.413 -apply (rule_tac P = "chain (%i. g$ (Y i))" in mp)
8.414 -apply (erule spec)
8.415 -apply (erule ch2ch_Rep_CFunR)
8.416 -apply (rule exI)
8.417 -apply (intro strip)
8.418 -apply (rule_tac s = "f$ (g$ (Y x))" and t = "Y (x) " in subst)
8.419 -apply (erule spec)
8.420 -apply (rule_tac s = "f$ (g$ (Y j))" and t = "Y (j) " in subst)
8.421 -apply (erule spec)
8.422 -apply (rule cfun_arg_cong)
8.423 -apply (rule mp)
8.424 -apply (erule spec)
8.425 -apply assumption
8.426 -done
8.427 -
8.428 -
8.429 -lemma flat2flat: "!!f g.[|!x y::'a. x<<y --> x=UU | x=y;
8.430 - !y. f$(g$y)=(y::'b); !x. g$(f$x)=(x::'a)|] ==> !x y::'b. x<<y --> x=UU | x=y"
8.431 -apply (intro strip)
8.432 -apply (rule disjE)
8.433 -apply (rule_tac P = "g$x<<g$y" in mp)
8.434 -apply (erule_tac [2] monofun_cfun_arg)
8.435 -apply (drule spec)
8.436 -apply (erule spec)
8.437 -apply (rule disjI1)
8.438 -apply (rule trans)
8.439 -apply (rule_tac s = "f$ (g$x) " and t = "x" in subst)
8.440 -apply (erule spec)
8.441 -apply (erule cfun_arg_cong)
8.442 -apply (rule iso_strict [THEN conjunct1])
8.443 -apply assumption
8.444 -apply assumption
8.445 -apply (rule disjI2)
8.446 -apply (rule_tac s = "f$ (g$x) " and t = "x" in subst)
8.447 -apply (erule spec)
8.448 -apply (rule_tac s = "f$ (g$y) " and t = "y" in subst)
8.449 -apply (erule spec)
8.450 -apply (erule cfun_arg_cong)
8.451 -done
8.452 -
8.453 -(* ------------------------------------------------------------------------- *)
8.454 -(* a result about functions with flat codomain *)
8.455 -(* ------------------------------------------------------------------------- *)
8.456 -
8.457 -lemma flat_codom: "f$(x::'a)=(c::'b::flat) ==> f$(UU::'a)=(UU::'b) | (!z. f$(z::'a)=c)"
8.458 -apply (case_tac "f$ (x::'a) = (UU::'b) ")
8.459 -apply (rule disjI1)
8.460 -apply (rule UU_I)
8.461 -apply (rule_tac s = "f$ (x) " and t = "UU::'b" in subst)
8.462 -apply assumption
8.463 -apply (rule minimal [THEN monofun_cfun_arg])
8.464 -apply (case_tac "f$ (UU::'a) = (UU::'b) ")
8.465 -apply (erule disjI1)
8.466 -apply (rule disjI2)
8.467 -apply (rule allI)
8.468 -apply (erule subst)
8.469 -apply (rule_tac a = "f$ (UU::'a) " in refl [THEN box_equals])
8.470 -apply (rule_tac fo5 = "f" in minimal [THEN monofun_cfun_arg, THEN ax_flat [THEN spec, THEN spec, THEN mp], THEN disjE])
8.471 -apply simp
8.472 -apply assumption
8.473 -apply (rule_tac fo5 = "f" in minimal [THEN monofun_cfun_arg, THEN ax_flat [THEN spec, THEN spec, THEN mp], THEN disjE])
8.474 -apply simp
8.475 -apply assumption
8.476 -done
8.477 -
8.478 -
8.479 -(* ------------------------------------------------------------------------ *)
8.480 -(* Access to definitions *)
8.481 -(* ------------------------------------------------------------------------ *)
8.482 -
8.483 -
8.484 -lemma ID1: "ID$x=x"
8.485 -apply (unfold ID_def)
8.486 -apply (subst beta_cfun)
8.487 -apply (rule cont_id)
8.488 -apply (rule refl)
8.489 -done
8.490 -
8.491 -lemma cfcomp1: "(f oo g)=(LAM x. f$(g$x))"
8.492 -apply (unfold oo_def)
8.493 -apply (subst beta_cfun)
8.494 -apply (simp (no_asm))
8.495 -apply (subst beta_cfun)
8.496 -apply (simp (no_asm))
8.497 -apply (rule refl)
8.498 -done
8.499 -
8.500 -lemma cfcomp2: "(f oo g)$x=f$(g$x)"
8.501 -apply (subst cfcomp1)
8.502 -apply (subst beta_cfun)
8.503 -apply (simp (no_asm))
8.504 -apply (rule refl)
8.505 -done
8.506 -
8.507 -
8.508 -(* ------------------------------------------------------------------------ *)
8.509 -(* Show that interpretation of (pcpo,_->_) is a category *)
8.510 -(* The class of objects is interpretation of syntactical class pcpo *)
8.511 -(* The class of arrows between objects 'a and 'b is interpret. of 'a -> 'b *)
8.512 -(* The identity arrow is interpretation of ID *)
8.513 -(* The composition of f and g is interpretation of oo *)
8.514 -(* ------------------------------------------------------------------------ *)
8.515 -
8.516 -
8.517 -lemma ID2: "f oo ID = f "
8.518 -apply (rule ext_cfun)
8.519 -apply (subst cfcomp2)
8.520 -apply (subst ID1)
8.521 -apply (rule refl)
8.522 -done
8.523 -
8.524 -lemma ID3: "ID oo f = f "
8.525 -apply (rule ext_cfun)
8.526 -apply (subst cfcomp2)
8.527 -apply (subst ID1)
8.528 -apply (rule refl)
8.529 -done
8.530 -
8.531 -
8.532 -lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
8.533 -apply (rule ext_cfun)
8.534 -apply (rule_tac s = "f$ (g$ (h$x))" in trans)
8.535 -apply (subst cfcomp2)
8.536 -apply (subst cfcomp2)
8.537 -apply (rule refl)
8.538 -apply (subst cfcomp2)
8.539 -apply (subst cfcomp2)
8.540 -apply (rule refl)
8.541 -done
8.542 -
8.543 -(* ------------------------------------------------------------------------ *)
8.544 -(* Merge the different rewrite rules for the simplifier *)
8.545 -(* ------------------------------------------------------------------------ *)
8.546 -
8.547 -declare ID1[simp] ID2[simp] ID3[simp] cfcomp2[simp]
8.548 -
8.549 -end
9.1 --- a/src/HOLCF/Cont.thy Fri Mar 04 18:53:46 2005 +0100
9.2 +++ b/src/HOLCF/Cont.thy Fri Mar 04 23:12:36 2005 +0100
9.3 @@ -6,7 +6,7 @@
9.4 Results about continuity and monotonicity
9.5 *)
9.6
9.7 -theory Cont = Fun3:
9.8 +theory Cont = FunCpo:
9.9
9.10 (*
9.11
10.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2 +++ b/src/HOLCF/Cprod.ML Fri Mar 04 23:12:36 2005 +0100
10.3 @@ -0,0 +1,53 @@
10.4 +
10.5 +(* legacy ML bindings *)
10.6 +
10.7 +val less_cprod_def = thm "less_cprod_def";
10.8 +val refl_less_cprod = thm "refl_less_cprod";
10.9 +val antisym_less_cprod = thm "antisym_less_cprod";
10.10 +val trans_less_cprod = thm "trans_less_cprod";
10.11 +val inst_cprod_po = thm "inst_cprod_po";
10.12 +val less_cprod4c = thm "less_cprod4c";
10.13 +val minimal_cprod = thm "minimal_cprod";
10.14 +val UU_cprod_def = thm "UU_cprod_def";
10.15 +val least_cprod = thm "least_cprod";
10.16 +val monofun_pair1 = thm "monofun_pair1";
10.17 +val monofun_pair2 = thm "monofun_pair2";
10.18 +val monofun_pair = thm "monofun_pair";
10.19 +val monofun_fst = thm "monofun_fst";
10.20 +val monofun_snd = thm "monofun_snd";
10.21 +val lub_cprod = thm "lub_cprod";
10.22 +val thelub_cprod = thm "thelub_cprod";
10.23 +val cpo_cprod = thm "cpo_cprod";
10.24 +val cpair_def = thm "cpair_def";
10.25 +val cfst_def = thm "cfst_def";
10.26 +val csnd_def = thm "csnd_def";
10.27 +val csplit_def = thm "csplit_def";
10.28 +val CLet_def = thm "CLet_def";
10.29 +val inst_cprod_pcpo = thm "inst_cprod_pcpo";
10.30 +val Cprod3_lemma1 = thm "Cprod3_lemma1";
10.31 +val contlub_pair1 = thm "contlub_pair1";
10.32 +val Cprod3_lemma2 = thm "Cprod3_lemma2";
10.33 +val contlub_pair2 = thm "contlub_pair2";
10.34 +val cont_pair1 = thm "cont_pair1";
10.35 +val cont_pair2 = thm "cont_pair2";
10.36 +val contlub_fst = thm "contlub_fst";
10.37 +val contlub_snd = thm "contlub_snd";
10.38 +val cont_fst = thm "cont_fst";
10.39 +val cont_snd = thm "cont_snd";
10.40 +val beta_cfun_cprod = thm "beta_cfun_cprod";
10.41 +val inject_cpair = thm "inject_cpair";
10.42 +val inst_cprod_pcpo2 = thm "inst_cprod_pcpo2";
10.43 +val defined_cpair_rev = thm "defined_cpair_rev";
10.44 +val Exh_Cprod2 = thm "Exh_Cprod2";
10.45 +val cprodE = thm "cprodE";
10.46 +val cfst2 = thm "cfst2";
10.47 +val csnd2 = thm "csnd2";
10.48 +val cfst_strict = thm "cfst_strict";
10.49 +val csnd_strict = thm "csnd_strict";
10.50 +val surjective_pairing_Cprod2 = thm "surjective_pairing_Cprod2";
10.51 +val less_cprod5c = thm "less_cprod5c";
10.52 +val lub_cprod2 = thm "lub_cprod2";
10.53 +val thelub_cprod2 = thm "thelub_cprod2";
10.54 +val csplit2 = thm "csplit2";
10.55 +val csplit3 = thm "csplit3";
10.56 +val Cprod_rews = [cfst2, csnd2, csplit2]
11.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2 +++ b/src/HOLCF/Cprod.thy Fri Mar 04 23:12:36 2005 +0100
11.3 @@ -0,0 +1,493 @@
11.4 +(* Title: HOLCF/Cprod1.thy
11.5 + ID: $Id$
11.6 + Author: Franz Regensburger
11.7 + License: GPL (GNU GENERAL PUBLIC LICENSE)
11.8 +
11.9 +Partial ordering for cartesian product of HOL theory prod.thy
11.10 +*)
11.11 +
11.12 +header {* The cpo of cartesian products *}
11.13 +
11.14 +theory Cprod = Cfun:
11.15 +
11.16 +defaultsort cpo
11.17 +
11.18 +instance "*"::(sq_ord,sq_ord)sq_ord ..
11.19 +
11.20 +defs (overloaded)
11.21 +
11.22 + less_cprod_def: "p1 << p2 == (fst p1<<fst p2 & snd p1 << snd p2)"
11.23 +
11.24 +(* ------------------------------------------------------------------------ *)
11.25 +(* less_cprod is a partial order on 'a * 'b *)
11.26 +(* ------------------------------------------------------------------------ *)
11.27 +
11.28 +lemma refl_less_cprod: "(p::'a*'b) << p"
11.29 +apply (unfold less_cprod_def)
11.30 +apply simp
11.31 +done
11.32 +
11.33 +lemma antisym_less_cprod: "[|(p1::'a * 'b) << p2;p2 << p1|] ==> p1=p2"
11.34 +apply (unfold less_cprod_def)
11.35 +apply (rule injective_fst_snd)
11.36 +apply (fast intro: antisym_less)
11.37 +apply (fast intro: antisym_less)
11.38 +done
11.39 +
11.40 +lemma trans_less_cprod:
11.41 + "[|(p1::'a*'b) << p2;p2 << p3|] ==> p1 << p3"
11.42 +apply (unfold less_cprod_def)
11.43 +apply (rule conjI)
11.44 +apply (fast intro: trans_less)
11.45 +apply (fast intro: trans_less)
11.46 +done
11.47 +
11.48 +(* Class Instance *::(pcpo,pcpo)po *)
11.49 +
11.50 +defaultsort pcpo
11.51 +
11.52 +instance "*"::(cpo,cpo)po
11.53 +apply (intro_classes)
11.54 +apply (rule refl_less_cprod)
11.55 +apply (rule antisym_less_cprod, assumption+)
11.56 +apply (rule trans_less_cprod, assumption+)
11.57 +done
11.58 +
11.59 +(* for compatibility with old HOLCF-Version *)
11.60 +lemma inst_cprod_po: "(op <<)=(%x y. fst x<<fst y & snd x<<snd y)"
11.61 +apply (fold less_cprod_def)
11.62 +apply (rule refl)
11.63 +done
11.64 +
11.65 +lemma less_cprod4c: "(x1,y1) << (x2,y2) ==> x1 << x2 & y1 << y2"
11.66 +apply (simp add: inst_cprod_po)
11.67 +done
11.68 +
11.69 +(* ------------------------------------------------------------------------ *)
11.70 +(* type cprod is pointed *)
11.71 +(* ------------------------------------------------------------------------ *)
11.72 +
11.73 +lemma minimal_cprod: "(UU,UU)<<p"
11.74 +apply (simp (no_asm) add: inst_cprod_po)
11.75 +done
11.76 +
11.77 +lemmas UU_cprod_def = minimal_cprod [THEN minimal2UU, symmetric, standard]
11.78 +
11.79 +lemma least_cprod: "EX x::'a*'b. ALL y. x<<y"
11.80 +apply (rule_tac x = " (UU,UU) " in exI)
11.81 +apply (rule minimal_cprod [THEN allI])
11.82 +done
11.83 +
11.84 +(* ------------------------------------------------------------------------ *)
11.85 +(* Pair <_,_> is monotone in both arguments *)
11.86 +(* ------------------------------------------------------------------------ *)
11.87 +
11.88 +lemma monofun_pair1: "monofun Pair"
11.89 +
11.90 +apply (unfold monofun)
11.91 +apply (intro strip)
11.92 +apply (rule less_fun [THEN iffD2])
11.93 +apply (intro strip)
11.94 +apply (simp (no_asm_simp) add: inst_cprod_po)
11.95 +done
11.96 +
11.97 +lemma monofun_pair2: "monofun(Pair x)"
11.98 +apply (unfold monofun)
11.99 +apply (simp (no_asm_simp) add: inst_cprod_po)
11.100 +done
11.101 +
11.102 +lemma monofun_pair: "[|x1<<x2; y1<<y2|] ==> (x1::'a::cpo,y1::'b::cpo)<<(x2,y2)"
11.103 +apply (rule trans_less)
11.104 +apply (erule monofun_pair1 [THEN monofunE, THEN spec, THEN spec, THEN mp, THEN less_fun [THEN iffD1, THEN spec]])
11.105 +apply (erule monofun_pair2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
11.106 +done
11.107 +
11.108 +(* ------------------------------------------------------------------------ *)
11.109 +(* fst and snd are monotone *)
11.110 +(* ------------------------------------------------------------------------ *)
11.111 +
11.112 +lemma monofun_fst: "monofun fst"
11.113 +apply (unfold monofun)
11.114 +apply (intro strip)
11.115 +apply (rule_tac p = "x" in PairE)
11.116 +apply (rule_tac p = "y" in PairE)
11.117 +apply simp
11.118 +apply (erule less_cprod4c [THEN conjunct1])
11.119 +done
11.120 +
11.121 +lemma monofun_snd: "monofun snd"
11.122 +apply (unfold monofun)
11.123 +apply (intro strip)
11.124 +apply (rule_tac p = "x" in PairE)
11.125 +apply (rule_tac p = "y" in PairE)
11.126 +apply simp
11.127 +apply (erule less_cprod4c [THEN conjunct2])
11.128 +done
11.129 +
11.130 +(* ------------------------------------------------------------------------ *)
11.131 +(* the type 'a * 'b is a cpo *)
11.132 +(* ------------------------------------------------------------------------ *)
11.133 +
11.134 +lemma lub_cprod:
11.135 +"chain S ==> range S<<|(lub(range(%i. fst(S i))),lub(range(%i. snd(S i))))"
11.136 +apply (rule is_lubI)
11.137 +apply (rule ub_rangeI)
11.138 +apply (rule_tac t = "S i" in surjective_pairing [THEN ssubst])
11.139 +apply (rule monofun_pair)
11.140 +apply (rule is_ub_thelub)
11.141 +apply (erule monofun_fst [THEN ch2ch_monofun])
11.142 +apply (rule is_ub_thelub)
11.143 +apply (erule monofun_snd [THEN ch2ch_monofun])
11.144 +apply (rule_tac t = "u" in surjective_pairing [THEN ssubst])
11.145 +apply (rule monofun_pair)
11.146 +apply (rule is_lub_thelub)
11.147 +apply (erule monofun_fst [THEN ch2ch_monofun])
11.148 +apply (erule monofun_fst [THEN ub2ub_monofun])
11.149 +apply (rule is_lub_thelub)
11.150 +apply (erule monofun_snd [THEN ch2ch_monofun])
11.151 +apply (erule monofun_snd [THEN ub2ub_monofun])
11.152 +done
11.153 +
11.154 +lemmas thelub_cprod = lub_cprod [THEN thelubI, standard]
11.155 +(*
11.156 +"chain ?S1 ==>
11.157 + lub (range ?S1) =
11.158 + (lub (range (%i. fst (?S1 i))), lub (range (%i. snd (?S1 i))))" : thm
11.159 +
11.160 +*)
11.161 +
11.162 +lemma cpo_cprod: "chain(S::nat=>'a::cpo*'b::cpo)==>EX x. range S<<| x"
11.163 +apply (rule exI)
11.164 +apply (erule lub_cprod)
11.165 +done
11.166 +
11.167 +(* Class instance of * for class pcpo and cpo. *)
11.168 +
11.169 +instance "*" :: (cpo,cpo)cpo
11.170 +by (intro_classes, rule cpo_cprod)
11.171 +
11.172 +instance "*" :: (pcpo,pcpo)pcpo
11.173 +by (intro_classes, rule least_cprod)
11.174 +
11.175 +consts
11.176 + cpair :: "'a::cpo -> 'b::cpo -> ('a*'b)" (* continuous pairing *)
11.177 + cfst :: "('a::cpo*'b::cpo)->'a"
11.178 + csnd :: "('a::cpo*'b::cpo)->'b"
11.179 + csplit :: "('a::cpo->'b::cpo->'c::cpo)->('a*'b)->'c"
11.180 +
11.181 +syntax
11.182 + "@ctuple" :: "['a, args] => 'a * 'b" ("(1<_,/ _>)")
11.183 +
11.184 +translations
11.185 + "<x, y, z>" == "<x, <y, z>>"
11.186 + "<x, y>" == "cpair$x$y"
11.187 +
11.188 +defs
11.189 +cpair_def: "cpair == (LAM x y.(x,y))"
11.190 +cfst_def: "cfst == (LAM p. fst(p))"
11.191 +csnd_def: "csnd == (LAM p. snd(p))"
11.192 +csplit_def: "csplit == (LAM f p. f$(cfst$p)$(csnd$p))"
11.193 +
11.194 +
11.195 +
11.196 +(* introduce syntax for
11.197 +
11.198 + Let <x,y> = e1; z = E2 in E3
11.199 +
11.200 + and
11.201 +
11.202 + LAM <x,y,z>.e
11.203 +*)
11.204 +
11.205 +constdefs
11.206 + CLet :: "'a -> ('a -> 'b) -> 'b"
11.207 + "CLet == LAM s f. f$s"
11.208 +
11.209 +
11.210 +(* syntax for Let *)
11.211 +
11.212 +nonterminals
11.213 + Cletbinds Cletbind
11.214 +
11.215 +syntax
11.216 + "_Cbind" :: "[pttrn, 'a] => Cletbind" ("(2_ =/ _)" 10)
11.217 + "" :: "Cletbind => Cletbinds" ("_")
11.218 + "_Cbinds" :: "[Cletbind, Cletbinds] => Cletbinds" ("_;/ _")
11.219 + "_CLet" :: "[Cletbinds, 'a] => 'a" ("(Let (_)/ in (_))" 10)
11.220 +
11.221 +translations
11.222 + "_CLet (_Cbinds b bs) e" == "_CLet b (_CLet bs e)"
11.223 + "Let x = a in e" == "CLet$a$(LAM x. e)"
11.224 +
11.225 +
11.226 +(* syntax for LAM <x,y,z>.e *)
11.227 +
11.228 +syntax
11.229 + "_LAM" :: "[patterns, 'a => 'b] => ('a -> 'b)" ("(3LAM <_>./ _)" [0, 10] 10)
11.230 +
11.231 +translations
11.232 + "LAM <x,y,zs>.b" == "csplit$(LAM x. LAM <y,zs>.b)"
11.233 + "LAM <x,y>. LAM zs. b" <= "csplit$(LAM x y zs. b)"
11.234 + "LAM <x,y>.b" == "csplit$(LAM x y. b)"
11.235 +
11.236 +syntax (xsymbols)
11.237 + "_LAM" :: "[patterns, 'a => 'b] => ('a -> 'b)" ("(3\\<Lambda>()<_>./ _)" [0, 10] 10)
11.238 +
11.239 +(* for compatibility with old HOLCF-Version *)
11.240 +lemma inst_cprod_pcpo: "UU = (UU,UU)"
11.241 +apply (simp add: UU_cprod_def[folded UU_def])
11.242 +done
11.243 +
11.244 +(* ------------------------------------------------------------------------ *)
11.245 +(* continuity of (_,_) , fst, snd *)
11.246 +(* ------------------------------------------------------------------------ *)
11.247 +
11.248 +lemma Cprod3_lemma1:
11.249 +"chain(Y::(nat=>'a::cpo)) ==>
11.250 + (lub(range(Y)),(x::'b::cpo)) =
11.251 + (lub(range(%i. fst(Y i,x))),lub(range(%i. snd(Y i,x))))"
11.252 +apply (rule_tac f1 = "Pair" in arg_cong [THEN cong])
11.253 +apply (rule lub_equal)
11.254 +apply assumption
11.255 +apply (rule monofun_fst [THEN ch2ch_monofun])
11.256 +apply (rule ch2ch_fun)
11.257 +apply (rule monofun_pair1 [THEN ch2ch_monofun])
11.258 +apply assumption
11.259 +apply (rule allI)
11.260 +apply (simp (no_asm))
11.261 +apply (rule sym)
11.262 +apply (simp (no_asm))
11.263 +apply (rule lub_const [THEN thelubI])
11.264 +done
11.265 +
11.266 +lemma contlub_pair1: "contlub(Pair)"
11.267 +apply (rule contlubI)
11.268 +apply (intro strip)
11.269 +apply (rule expand_fun_eq [THEN iffD2])
11.270 +apply (intro strip)
11.271 +apply (subst lub_fun [THEN thelubI])
11.272 +apply (erule monofun_pair1 [THEN ch2ch_monofun])
11.273 +apply (rule trans)
11.274 +apply (rule_tac [2] thelub_cprod [symmetric])
11.275 +apply (rule_tac [2] ch2ch_fun)
11.276 +apply (erule_tac [2] monofun_pair1 [THEN ch2ch_monofun])
11.277 +apply (erule Cprod3_lemma1)
11.278 +done
11.279 +
11.280 +lemma Cprod3_lemma2:
11.281 +"chain(Y::(nat=>'a::cpo)) ==>
11.282 + ((x::'b::cpo),lub(range Y)) =
11.283 + (lub(range(%i. fst(x,Y i))),lub(range(%i. snd(x, Y i))))"
11.284 +apply (rule_tac f1 = "Pair" in arg_cong [THEN cong])
11.285 +apply (rule sym)
11.286 +apply (simp (no_asm))
11.287 +apply (rule lub_const [THEN thelubI])
11.288 +apply (rule lub_equal)
11.289 +apply assumption
11.290 +apply (rule monofun_snd [THEN ch2ch_monofun])
11.291 +apply (rule monofun_pair2 [THEN ch2ch_monofun])
11.292 +apply assumption
11.293 +apply (rule allI)
11.294 +apply (simp (no_asm))
11.295 +done
11.296 +
11.297 +lemma contlub_pair2: "contlub(Pair(x))"
11.298 +apply (rule contlubI)
11.299 +apply (intro strip)
11.300 +apply (rule trans)
11.301 +apply (rule_tac [2] thelub_cprod [symmetric])
11.302 +apply (erule_tac [2] monofun_pair2 [THEN ch2ch_monofun])
11.303 +apply (erule Cprod3_lemma2)
11.304 +done
11.305 +
11.306 +lemma cont_pair1: "cont(Pair)"
11.307 +apply (rule monocontlub2cont)
11.308 +apply (rule monofun_pair1)
11.309 +apply (rule contlub_pair1)
11.310 +done
11.311 +
11.312 +lemma cont_pair2: "cont(Pair(x))"
11.313 +apply (rule monocontlub2cont)
11.314 +apply (rule monofun_pair2)
11.315 +apply (rule contlub_pair2)
11.316 +done
11.317 +
11.318 +lemma contlub_fst: "contlub(fst)"
11.319 +apply (rule contlubI)
11.320 +apply (intro strip)
11.321 +apply (subst lub_cprod [THEN thelubI])
11.322 +apply assumption
11.323 +apply (simp (no_asm))
11.324 +done
11.325 +
11.326 +lemma contlub_snd: "contlub(snd)"
11.327 +apply (rule contlubI)
11.328 +apply (intro strip)
11.329 +apply (subst lub_cprod [THEN thelubI])
11.330 +apply assumption
11.331 +apply (simp (no_asm))
11.332 +done
11.333 +
11.334 +lemma cont_fst: "cont(fst)"
11.335 +apply (rule monocontlub2cont)
11.336 +apply (rule monofun_fst)
11.337 +apply (rule contlub_fst)
11.338 +done
11.339 +
11.340 +lemma cont_snd: "cont(snd)"
11.341 +apply (rule monocontlub2cont)
11.342 +apply (rule monofun_snd)
11.343 +apply (rule contlub_snd)
11.344 +done
11.345 +
11.346 +(*
11.347 + --------------------------------------------------------------------------
11.348 + more lemmas for Cprod3.thy
11.349 +
11.350 + --------------------------------------------------------------------------
11.351 +*)
11.352 +
11.353 +(* ------------------------------------------------------------------------ *)
11.354 +(* convert all lemmas to the continuous versions *)
11.355 +(* ------------------------------------------------------------------------ *)
11.356 +
11.357 +lemma beta_cfun_cprod:
11.358 + "(LAM x y.(x,y))$a$b = (a,b)"
11.359 +apply (subst beta_cfun)
11.360 +apply (simp (no_asm) add: cont_pair1 cont_pair2 cont2cont_CF1L)
11.361 +apply (subst beta_cfun)
11.362 +apply (rule cont_pair2)
11.363 +apply (rule refl)
11.364 +done
11.365 +
11.366 +lemma inject_cpair:
11.367 + "<a,b> = <aa,ba> ==> a=aa & b=ba"
11.368 +apply (unfold cpair_def)
11.369 +apply (drule beta_cfun_cprod [THEN subst])
11.370 +apply (drule beta_cfun_cprod [THEN subst])
11.371 +apply (erule Pair_inject)
11.372 +apply fast
11.373 +done
11.374 +
11.375 +lemma inst_cprod_pcpo2: "UU = <UU,UU>"
11.376 +apply (unfold cpair_def)
11.377 +apply (rule sym)
11.378 +apply (rule trans)
11.379 +apply (rule beta_cfun_cprod)
11.380 +apply (rule sym)
11.381 +apply (rule inst_cprod_pcpo)
11.382 +done
11.383 +
11.384 +lemma defined_cpair_rev:
11.385 + "<a,b> = UU ==> a = UU & b = UU"
11.386 +apply (drule inst_cprod_pcpo2 [THEN subst])
11.387 +apply (erule inject_cpair)
11.388 +done
11.389 +
11.390 +lemma Exh_Cprod2:
11.391 + "? a b. z=<a,b>"
11.392 +apply (unfold cpair_def)
11.393 +apply (rule PairE)
11.394 +apply (rule exI)
11.395 +apply (rule exI)
11.396 +apply (erule beta_cfun_cprod [THEN ssubst])
11.397 +done
11.398 +
11.399 +lemma cprodE:
11.400 +assumes prems: "!!x y. [| p = <x,y> |] ==> Q"
11.401 +shows "Q"
11.402 +apply (rule PairE)
11.403 +apply (rule prems)
11.404 +apply (unfold cpair_def)
11.405 +apply (erule beta_cfun_cprod [THEN ssubst])
11.406 +done
11.407 +
11.408 +lemma cfst2:
11.409 + "cfst$<x,y> = x"
11.410 +apply (unfold cfst_def cpair_def)
11.411 +apply (subst beta_cfun_cprod)
11.412 +apply (subst beta_cfun)
11.413 +apply (rule cont_fst)
11.414 +apply (simp (no_asm))
11.415 +done
11.416 +
11.417 +lemma csnd2:
11.418 + "csnd$<x,y> = y"
11.419 +apply (unfold csnd_def cpair_def)
11.420 +apply (subst beta_cfun_cprod)
11.421 +apply (subst beta_cfun)
11.422 +apply (rule cont_snd)
11.423 +apply (simp (no_asm))
11.424 +done
11.425 +
11.426 +lemma cfst_strict: "cfst$UU = UU"
11.427 +apply (simp add: inst_cprod_pcpo2 cfst2)
11.428 +done
11.429 +
11.430 +lemma csnd_strict: "csnd$UU = UU"
11.431 +apply (simp add: inst_cprod_pcpo2 csnd2)
11.432 +done
11.433 +
11.434 +lemma surjective_pairing_Cprod2: "<cfst$p , csnd$p> = p"
11.435 +apply (unfold cfst_def csnd_def cpair_def)
11.436 +apply (subst beta_cfun_cprod)
11.437 +apply (simplesubst beta_cfun)
11.438 +apply (rule cont_snd)
11.439 +apply (subst beta_cfun)
11.440 +apply (rule cont_fst)
11.441 +apply (rule surjective_pairing [symmetric])
11.442 +done
11.443 +
11.444 +lemma less_cprod5c:
11.445 + "<xa,ya> << <x,y> ==> xa<<x & ya << y"
11.446 +apply (unfold cfst_def csnd_def cpair_def)
11.447 +apply (rule less_cprod4c)
11.448 +apply (drule beta_cfun_cprod [THEN subst])
11.449 +apply (drule beta_cfun_cprod [THEN subst])
11.450 +apply assumption
11.451 +done
11.452 +
11.453 +lemma lub_cprod2:
11.454 +"[|chain(S)|] ==> range(S) <<|
11.455 + <(lub(range(%i. cfst$(S i)))) , lub(range(%i. csnd$(S i)))>"
11.456 +apply (unfold cfst_def csnd_def cpair_def)
11.457 +apply (subst beta_cfun_cprod)
11.458 +apply (simplesubst beta_cfun [THEN ext])
11.459 +apply (rule cont_snd)
11.460 +apply (subst beta_cfun [THEN ext])
11.461 +apply (rule cont_fst)
11.462 +apply (rule lub_cprod)
11.463 +apply assumption
11.464 +done
11.465 +
11.466 +lemmas thelub_cprod2 = lub_cprod2 [THEN thelubI, standard]
11.467 +(*
11.468 +chain ?S1 ==>
11.469 + lub (range ?S1) =
11.470 + <lub (range (%i. cfst$(?S1 i))), lub (range (%i. csnd$(?S1 i)))>"
11.471 +*)
11.472 +lemma csplit2:
11.473 + "csplit$f$<x,y> = f$x$y"
11.474 +apply (unfold csplit_def)
11.475 +apply (subst beta_cfun)
11.476 +apply (simp (no_asm))
11.477 +apply (simp (no_asm) add: cfst2 csnd2)
11.478 +done
11.479 +
11.480 +lemma csplit3:
11.481 + "csplit$cpair$z=z"
11.482 +apply (unfold csplit_def)
11.483 +apply (subst beta_cfun)
11.484 +apply (simp (no_asm))
11.485 +apply (simp (no_asm) add: surjective_pairing_Cprod2)
11.486 +done
11.487 +
11.488 +(* ------------------------------------------------------------------------ *)
11.489 +(* install simplifier for Cprod *)
11.490 +(* ------------------------------------------------------------------------ *)
11.491 +
11.492 +declare cfst2 [simp] csnd2 [simp] csplit2 [simp]
11.493 +
11.494 +lemmas Cprod_rews = cfst2 csnd2 csplit2
11.495 +
11.496 +end
12.1 --- a/src/HOLCF/Cprod1.ML Fri Mar 04 18:53:46 2005 +0100
12.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
12.3 @@ -1,28 +0,0 @@
12.4 -(* Title: HOLCF/Cprod1.ML
12.5 - ID: $Id$
12.6 - Author: Franz Regensburger
12.7 -
12.8 -Partial ordering for cartesian product of HOL theory Product_Type.thy
12.9 -*)
12.10 -
12.11 -
12.12 -(* ------------------------------------------------------------------------ *)
12.13 -(* less_cprod is a partial order on 'a * 'b *)
12.14 -(* ------------------------------------------------------------------------ *)
12.15 -
12.16 -Goalw [less_cprod_def] "(p::'a*'b) << p";
12.17 -by (Simp_tac 1);
12.18 -qed "refl_less_cprod";
12.19 -
12.20 -Goalw [less_cprod_def] "[|(p1::'a * 'b) << p2;p2 << p1|] ==> p1=p2";
12.21 -by (rtac injective_fst_snd 1);
12.22 -by (fast_tac (HOL_cs addIs [antisym_less]) 1);
12.23 -by (fast_tac (HOL_cs addIs [antisym_less]) 1);
12.24 -qed "antisym_less_cprod";
12.25 -
12.26 -Goalw [less_cprod_def]
12.27 - "[|(p1::'a*'b) << p2;p2 << p3|] ==> p1 << p3";
12.28 -by (rtac conjI 1);
12.29 -by (fast_tac (HOL_cs addIs [trans_less]) 1);
12.30 -by (fast_tac (HOL_cs addIs [trans_less]) 1);
12.31 -qed "trans_less_cprod";
13.1 --- a/src/HOLCF/Cprod1.thy Fri Mar 04 18:53:46 2005 +0100
13.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
13.3 @@ -1,18 +0,0 @@
13.4 -(* Title: HOLCF/Cprod1.thy
13.5 - ID: $Id$
13.6 - Author: Franz Regensburger
13.7 -
13.8 -Partial ordering for cartesian product of HOL theory prod.thy
13.9 -*)
13.10 -
13.11 -Cprod1 = Cfun3 +
13.12 -
13.13 -default cpo
13.14 -
13.15 -instance "*"::(sq_ord,sq_ord)sq_ord
13.16 -
13.17 -defs
13.18 -
13.19 - less_cprod_def "p1 << p2 == (fst p1<<fst p2 & snd p1 << snd p2)"
13.20 -
13.21 -end
14.1 --- a/src/HOLCF/Cprod2.ML Fri Mar 04 18:53:46 2005 +0100
14.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
14.3 @@ -1,118 +0,0 @@
14.4 -(* Title: HOLCF/Cprod2
14.5 - ID: $Id$
14.6 - Author: Franz Regensburger
14.7 -
14.8 -Class Instance *::(pcpo,pcpo)po
14.9 -*)
14.10 -
14.11 -(* for compatibility with old HOLCF-Version *)
14.12 -Goal "(op <<)=(%x y. fst x<<fst y & snd x<<snd y)";
14.13 -by (fold_goals_tac [less_cprod_def]);
14.14 -by (rtac refl 1);
14.15 -qed "inst_cprod_po";
14.16 -
14.17 -Goal "(x1,y1) << (x2,y2) ==> x1 << x2 & y1 << y2";
14.18 -by (asm_full_simp_tac (simpset() addsimps [inst_cprod_po]) 1);
14.19 -qed "less_cprod4c";
14.20 -
14.21 -(* ------------------------------------------------------------------------ *)
14.22 -(* type cprod is pointed *)
14.23 -(* ------------------------------------------------------------------------ *)
14.24 -
14.25 -Goal "(UU,UU)<<p";
14.26 -by (simp_tac(simpset() addsimps[inst_cprod_po])1);
14.27 -qed "minimal_cprod";
14.28 -
14.29 -bind_thm ("UU_cprod_def",minimal_cprod RS minimal2UU RS sym);
14.30 -
14.31 -Goal "EX x::'a*'b. ALL y. x<<y";
14.32 -by (res_inst_tac [("x","(UU,UU)")] exI 1);
14.33 -by (rtac (minimal_cprod RS allI) 1);
14.34 -qed "least_cprod";
14.35 -
14.36 -(* ------------------------------------------------------------------------ *)
14.37 -(* Pair <_,_> is monotone in both arguments *)
14.38 -(* ------------------------------------------------------------------------ *)
14.39 -
14.40 -Goalw [monofun] "monofun Pair";
14.41 -by (strip_tac 1);
14.42 -by (rtac (less_fun RS iffD2) 1);
14.43 -by (strip_tac 1);
14.44 -by (asm_simp_tac (simpset() addsimps [inst_cprod_po]) 1);
14.45 -qed "monofun_pair1";
14.46 -
14.47 -Goalw [monofun] "monofun(Pair x)";
14.48 -by (asm_simp_tac (simpset() addsimps [inst_cprod_po]) 1);
14.49 -qed "monofun_pair2";
14.50 -
14.51 -Goal "[|x1<<x2; y1<<y2|] ==> (x1::'a::cpo,y1::'b::cpo)<<(x2,y2)";
14.52 -by (rtac trans_less 1);
14.53 -by (rtac (monofun_pair1 RS monofunE RS spec RS spec RS mp RS (less_fun RS iffD1 RS spec)) 1);
14.54 -by (rtac (monofun_pair2 RS monofunE RS spec RS spec RS mp) 2);
14.55 -by (atac 1);
14.56 -by (atac 1);
14.57 -qed "monofun_pair";
14.58 -
14.59 -(* ------------------------------------------------------------------------ *)
14.60 -(* fst and snd are monotone *)
14.61 -(* ------------------------------------------------------------------------ *)
14.62 -
14.63 -Goalw [monofun] "monofun fst";
14.64 -by (strip_tac 1);
14.65 -by (res_inst_tac [("p","x")] PairE 1);
14.66 -by (hyp_subst_tac 1);
14.67 -by (res_inst_tac [("p","y")] PairE 1);
14.68 -by (hyp_subst_tac 1);
14.69 -by (Asm_simp_tac 1);
14.70 -by (etac (less_cprod4c RS conjunct1) 1);
14.71 -qed "monofun_fst";
14.72 -
14.73 -Goalw [monofun] "monofun snd";
14.74 -by (strip_tac 1);
14.75 -by (res_inst_tac [("p","x")] PairE 1);
14.76 -by (hyp_subst_tac 1);
14.77 -by (res_inst_tac [("p","y")] PairE 1);
14.78 -by (hyp_subst_tac 1);
14.79 -by (Asm_simp_tac 1);
14.80 -by (etac (less_cprod4c RS conjunct2) 1);
14.81 -qed "monofun_snd";
14.82 -
14.83 -(* ------------------------------------------------------------------------ *)
14.84 -(* the type 'a * 'b is a cpo *)
14.85 -(* ------------------------------------------------------------------------ *)
14.86 -
14.87 -Goal
14.88 -"chain S ==> range S<<|(lub(range(%i. fst(S i))),lub(range(%i. snd(S i))))";
14.89 -by (rtac (is_lubI) 1);
14.90 -by (rtac (ub_rangeI) 1);
14.91 -by (res_inst_tac [("t","S i")] (surjective_pairing RS ssubst) 1);
14.92 -by (rtac monofun_pair 1);
14.93 -by (rtac is_ub_thelub 1);
14.94 -by (etac (monofun_fst RS ch2ch_monofun) 1);
14.95 -by (rtac is_ub_thelub 1);
14.96 -by (etac (monofun_snd RS ch2ch_monofun) 1);
14.97 -by (strip_tac 1);
14.98 -by (res_inst_tac [("t","u")] (surjective_pairing RS ssubst) 1);
14.99 -by (rtac monofun_pair 1);
14.100 -by (rtac is_lub_thelub 1);
14.101 -by (etac (monofun_fst RS ch2ch_monofun) 1);
14.102 -by (etac (monofun_fst RS ub2ub_monofun) 1);
14.103 -by (rtac is_lub_thelub 1);
14.104 -by (etac (monofun_snd RS ch2ch_monofun) 1);
14.105 -by (etac (monofun_snd RS ub2ub_monofun) 1);
14.106 -qed "lub_cprod";
14.107 -
14.108 -bind_thm ("thelub_cprod", lub_cprod RS thelubI);
14.109 -(*
14.110 -"chain ?S1 ==>
14.111 - lub (range ?S1) =
14.112 - (lub (range (%i. fst (?S1 i))), lub (range (%i. snd (?S1 i))))" : thm
14.113 -
14.114 -*)
14.115 -
14.116 -Goal "chain(S::nat=>'a::cpo*'b::cpo)==>EX x. range S<<| x";
14.117 -by (rtac exI 1);
14.118 -by (etac lub_cprod 1);
14.119 -qed "cpo_cprod";
14.120 -
14.121 -
15.1 --- a/src/HOLCF/Cprod2.thy Fri Mar 04 18:53:46 2005 +0100
15.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
15.3 @@ -1,18 +0,0 @@
15.4 -(* Title: HOLCF/Cprod2.thy
15.5 - ID: $Id$
15.6 - Author: Franz Regensburger
15.7 -
15.8 -Class Instance *::(pcpo,pcpo)po
15.9 -
15.10 -*)
15.11 -
15.12 -Cprod2 = Cprod1 +
15.13 -
15.14 -default pcpo
15.15 -
15.16 -instance "*"::(cpo,cpo)po
15.17 - (refl_less_cprod,antisym_less_cprod,trans_less_cprod)
15.18 -end
15.19 -
15.20 -
15.21 -
16.1 --- a/src/HOLCF/Cprod3.ML Fri Mar 04 18:53:46 2005 +0100
16.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
16.3 @@ -1,250 +0,0 @@
16.4 -(* Title: HOLCF/Cprod3
16.5 - ID: $Id$
16.6 - Author: Franz Regensburger
16.7 -
16.8 -Class instance of * for class pcpo and cpo.
16.9 -*)
16.10 -
16.11 -(* for compatibility with old HOLCF-Version *)
16.12 -Goal "UU = (UU,UU)";
16.13 -by (simp_tac (HOL_ss addsimps [UU_def,UU_cprod_def]) 1);
16.14 -qed "inst_cprod_pcpo";
16.15 -
16.16 -(* ------------------------------------------------------------------------ *)
16.17 -(* continuity of (_,_) , fst, snd *)
16.18 -(* ------------------------------------------------------------------------ *)
16.19 -
16.20 -Goal
16.21 -"chain(Y::(nat=>'a::cpo)) ==>\
16.22 -\ (lub(range(Y)),(x::'b::cpo)) =\
16.23 -\ (lub(range(%i. fst(Y i,x))),lub(range(%i. snd(Y i,x))))";
16.24 -by (res_inst_tac [("f1","Pair")] (arg_cong RS cong) 1);
16.25 -by (rtac lub_equal 1);
16.26 -by (atac 1);
16.27 -by (rtac (monofun_fst RS ch2ch_monofun) 1);
16.28 -by (rtac ch2ch_fun 1);
16.29 -by (rtac (monofun_pair1 RS ch2ch_monofun) 1);
16.30 -by (atac 1);
16.31 -by (rtac allI 1);
16.32 -by (Simp_tac 1);
16.33 -by (rtac sym 1);
16.34 -by (Simp_tac 1);
16.35 -by (rtac (lub_const RS thelubI) 1);
16.36 -qed "Cprod3_lemma1";
16.37 -
16.38 -Goal "contlub(Pair)";
16.39 -by (rtac contlubI 1);
16.40 -by (strip_tac 1);
16.41 -by (rtac (expand_fun_eq RS iffD2) 1);
16.42 -by (strip_tac 1);
16.43 -by (stac (lub_fun RS thelubI) 1);
16.44 -by (etac (monofun_pair1 RS ch2ch_monofun) 1);
16.45 -by (rtac trans 1);
16.46 -by (rtac (thelub_cprod RS sym) 2);
16.47 -by (rtac ch2ch_fun 2);
16.48 -by (etac (monofun_pair1 RS ch2ch_monofun) 2);
16.49 -by (etac Cprod3_lemma1 1);
16.50 -qed "contlub_pair1";
16.51 -
16.52 -Goal
16.53 -"chain(Y::(nat=>'a::cpo)) ==>\
16.54 -\ ((x::'b::cpo),lub(range Y)) =\
16.55 -\ (lub(range(%i. fst(x,Y i))),lub(range(%i. snd(x, Y i))))";
16.56 -by (res_inst_tac [("f1","Pair")] (arg_cong RS cong) 1);
16.57 -by (rtac sym 1);
16.58 -by (Simp_tac 1);
16.59 -by (rtac (lub_const RS thelubI) 1);
16.60 -by (rtac lub_equal 1);
16.61 -by (atac 1);
16.62 -by (rtac (monofun_snd RS ch2ch_monofun) 1);
16.63 -by (rtac (monofun_pair2 RS ch2ch_monofun) 1);
16.64 -by (atac 1);
16.65 -by (rtac allI 1);
16.66 -by (Simp_tac 1);
16.67 -qed "Cprod3_lemma2";
16.68 -
16.69 -Goal "contlub(Pair(x))";
16.70 -by (rtac contlubI 1);
16.71 -by (strip_tac 1);
16.72 -by (rtac trans 1);
16.73 -by (rtac (thelub_cprod RS sym) 2);
16.74 -by (etac (monofun_pair2 RS ch2ch_monofun) 2);
16.75 -by (etac Cprod3_lemma2 1);
16.76 -qed "contlub_pair2";
16.77 -
16.78 -Goal "cont(Pair)";
16.79 -by (rtac monocontlub2cont 1);
16.80 -by (rtac monofun_pair1 1);
16.81 -by (rtac contlub_pair1 1);
16.82 -qed "cont_pair1";
16.83 -
16.84 -Goal "cont(Pair(x))";
16.85 -by (rtac monocontlub2cont 1);
16.86 -by (rtac monofun_pair2 1);
16.87 -by (rtac contlub_pair2 1);
16.88 -qed "cont_pair2";
16.89 -
16.90 -Goal "contlub(fst)";
16.91 -by (rtac contlubI 1);
16.92 -by (strip_tac 1);
16.93 -by (stac (lub_cprod RS thelubI) 1);
16.94 -by (atac 1);
16.95 -by (Simp_tac 1);
16.96 -qed "contlub_fst";
16.97 -
16.98 -Goal "contlub(snd)";
16.99 -by (rtac contlubI 1);
16.100 -by (strip_tac 1);
16.101 -by (stac (lub_cprod RS thelubI) 1);
16.102 -by (atac 1);
16.103 -by (Simp_tac 1);
16.104 -qed "contlub_snd";
16.105 -
16.106 -Goal "cont(fst)";
16.107 -by (rtac monocontlub2cont 1);
16.108 -by (rtac monofun_fst 1);
16.109 -by (rtac contlub_fst 1);
16.110 -qed "cont_fst";
16.111 -
16.112 -Goal "cont(snd)";
16.113 -by (rtac monocontlub2cont 1);
16.114 -by (rtac monofun_snd 1);
16.115 -by (rtac contlub_snd 1);
16.116 -qed "cont_snd";
16.117 -
16.118 -(*
16.119 - --------------------------------------------------------------------------
16.120 - more lemmas for Cprod3.thy
16.121 -
16.122 - --------------------------------------------------------------------------
16.123 -*)
16.124 -
16.125 -(* ------------------------------------------------------------------------ *)
16.126 -(* convert all lemmas to the continuous versions *)
16.127 -(* ------------------------------------------------------------------------ *)
16.128 -
16.129 -Goalw [cpair_def]
16.130 - "(LAM x y.(x,y))$a$b = (a,b)";
16.131 -by (stac beta_cfun 1);
16.132 -by (simp_tac (simpset() addsimps [cont_pair1,cont_pair2,cont2cont_CF1L]) 1);
16.133 -by (stac beta_cfun 1);
16.134 -by (rtac cont_pair2 1);
16.135 -by (rtac refl 1);
16.136 -qed "beta_cfun_cprod";
16.137 -
16.138 -Goalw [cpair_def]
16.139 - " <a,b> = <aa,ba> ==> a=aa & b=ba";
16.140 -by (dtac (beta_cfun_cprod RS subst) 1);
16.141 -by (dtac (beta_cfun_cprod RS subst) 1);
16.142 -by (etac Pair_inject 1);
16.143 -by (fast_tac HOL_cs 1);
16.144 -qed "inject_cpair";
16.145 -
16.146 -Goalw [cpair_def] "UU = <UU,UU>";
16.147 -by (rtac sym 1);
16.148 -by (rtac trans 1);
16.149 -by (rtac beta_cfun_cprod 1);
16.150 -by (rtac sym 1);
16.151 -by (rtac inst_cprod_pcpo 1);
16.152 -qed "inst_cprod_pcpo2";
16.153 -
16.154 -Goal
16.155 - "<a,b> = UU ==> a = UU & b = UU";
16.156 -by (dtac (inst_cprod_pcpo2 RS subst) 1);
16.157 -by (etac inject_cpair 1);
16.158 -qed "defined_cpair_rev";
16.159 -
16.160 -Goalw [cpair_def]
16.161 - "? a b. z=<a,b>";
16.162 -by (rtac PairE 1);
16.163 -by (rtac exI 1);
16.164 -by (rtac exI 1);
16.165 -by (etac (beta_cfun_cprod RS ssubst) 1);
16.166 -qed "Exh_Cprod2";
16.167 -
16.168 -val prems = Goalw [cpair_def] "[|!!x y. [|p=<x,y> |] ==> Q|] ==> Q";
16.169 -by (rtac PairE 1);
16.170 -by (resolve_tac prems 1);
16.171 -by (etac (beta_cfun_cprod RS ssubst) 1);
16.172 -qed "cprodE";
16.173 -
16.174 -Goalw [cfst_def,cpair_def]
16.175 - "cfst$<x,y> = x";
16.176 -by (stac beta_cfun_cprod 1);
16.177 -by (stac beta_cfun 1);
16.178 -by (rtac cont_fst 1);
16.179 -by (Simp_tac 1);
16.180 -qed "cfst2";
16.181 -
16.182 -Goalw [csnd_def,cpair_def]
16.183 - "csnd$<x,y> = y";
16.184 -by (stac beta_cfun_cprod 1);
16.185 -by (stac beta_cfun 1);
16.186 -by (rtac cont_snd 1);
16.187 -by (Simp_tac 1);
16.188 -qed "csnd2";
16.189 -
16.190 -Goal "cfst$UU = UU";
16.191 -by (simp_tac (HOL_ss addsimps [inst_cprod_pcpo2,cfst2]) 1);
16.192 -qed "cfst_strict";
16.193 -
16.194 -Goal "csnd$UU = UU";
16.195 -by (simp_tac (HOL_ss addsimps [inst_cprod_pcpo2,csnd2]) 1);
16.196 -qed "csnd_strict";
16.197 -
16.198 -Goalw [cfst_def,csnd_def,cpair_def] "<cfst$p , csnd$p> = p";
16.199 -by (stac beta_cfun_cprod 1);
16.200 -by (stac beta_cfun 1);
16.201 -by (rtac cont_snd 1);
16.202 -by (stac beta_cfun 1);
16.203 -by (rtac cont_fst 1);
16.204 -by (rtac (surjective_pairing RS sym) 1);
16.205 -qed "surjective_pairing_Cprod2";
16.206 -
16.207 -Goalw [cfst_def,csnd_def,cpair_def]
16.208 - "<xa,ya> << <x,y> ==> xa<<x & ya << y";
16.209 -by (rtac less_cprod4c 1);
16.210 -by (dtac (beta_cfun_cprod RS subst) 1);
16.211 -by (dtac (beta_cfun_cprod RS subst) 1);
16.212 -by (atac 1);
16.213 -qed "less_cprod5c";
16.214 -
16.215 -Goalw [cfst_def,csnd_def,cpair_def]
16.216 -"[|chain(S)|] ==> range(S) <<| \
16.217 -\ <(lub(range(%i. cfst$(S i)))) , lub(range(%i. csnd$(S i)))>";
16.218 -by (stac beta_cfun_cprod 1);
16.219 -by (stac (beta_cfun RS ext) 1);
16.220 -by (rtac cont_snd 1);
16.221 -by (stac (beta_cfun RS ext) 1);
16.222 -by (rtac cont_fst 1);
16.223 -by (rtac lub_cprod 1);
16.224 -by (atac 1);
16.225 -qed "lub_cprod2";
16.226 -
16.227 -bind_thm ("thelub_cprod2", lub_cprod2 RS thelubI);
16.228 -(*
16.229 -chain ?S1 ==>
16.230 - lub (range ?S1) =
16.231 - <lub (range (%i. cfst$(?S1 i))), lub (range (%i. csnd$(?S1 i)))>"
16.232 -*)
16.233 -Goalw [csplit_def]
16.234 - "csplit$f$<x,y> = f$x$y";
16.235 -by (stac beta_cfun 1);
16.236 -by (Simp_tac 1);
16.237 -by (simp_tac (simpset() addsimps [cfst2,csnd2]) 1);
16.238 -qed "csplit2";
16.239 -
16.240 -Goalw [csplit_def]
16.241 - "csplit$cpair$z=z";
16.242 -by (stac beta_cfun 1);
16.243 -by (Simp_tac 1);
16.244 -by (simp_tac (simpset() addsimps [surjective_pairing_Cprod2]) 1);
16.245 -qed "csplit3";
16.246 -
16.247 -(* ------------------------------------------------------------------------ *)
16.248 -(* install simplifier for Cprod *)
16.249 -(* ------------------------------------------------------------------------ *)
16.250 -
16.251 -Addsimps [cfst2,csnd2,csplit2];
16.252 -
16.253 -val Cprod_rews = [cfst2,csnd2,csplit2];
17.1 --- a/src/HOLCF/Cprod3.thy Fri Mar 04 18:53:46 2005 +0100
17.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
17.3 @@ -1,77 +0,0 @@
17.4 -(* Title: HOLCF/Cprod3.thy
17.5 - ID: $Id$
17.6 - Author: Franz Regensburger
17.7 -
17.8 -Class instance of * for class pcpo and cpo.
17.9 -*)
17.10 -
17.11 -Cprod3 = Cprod2 +
17.12 -
17.13 -instance "*" :: (cpo,cpo)cpo (cpo_cprod)
17.14 -instance "*" :: (pcpo,pcpo)pcpo (least_cprod)
17.15 -
17.16 -consts
17.17 - cpair :: "'a -> 'b -> ('a*'b)" (* continuous pairing *)
17.18 - cfst :: "('a*'b)->'a"
17.19 - csnd :: "('a*'b)->'b"
17.20 - csplit :: "('a->'b->'c)->('a*'b)->'c"
17.21 -
17.22 -syntax
17.23 - "@ctuple" :: "['a, args] => 'a * 'b" ("(1<_,/ _>)")
17.24 -
17.25 -translations
17.26 - "<x, y, z>" == "<x, <y, z>>"
17.27 - "<x, y>" == "cpair$x$y"
17.28 -
17.29 -defs
17.30 -cpair_def "cpair == (LAM x y.(x,y))"
17.31 -cfst_def "cfst == (LAM p. fst(p))"
17.32 -csnd_def "csnd == (LAM p. snd(p))"
17.33 -csplit_def "csplit == (LAM f p. f$(cfst$p)$(csnd$p))"
17.34 -
17.35 -
17.36 -
17.37 -(* introduce syntax for
17.38 -
17.39 - Let <x,y> = e1; z = E2 in E3
17.40 -
17.41 - and
17.42 -
17.43 - LAM <x,y,z>.e
17.44 -*)
17.45 -
17.46 -constdefs
17.47 - CLet :: "'a -> ('a -> 'b) -> 'b"
17.48 - "CLet == LAM s f. f$s"
17.49 -
17.50 -
17.51 -(* syntax for Let *)
17.52 -
17.53 -nonterminals
17.54 - Cletbinds Cletbind
17.55 -
17.56 -syntax
17.57 - "_Cbind" :: "[pttrn, 'a] => Cletbind" ("(2_ =/ _)" 10)
17.58 - "" :: "Cletbind => Cletbinds" ("_")
17.59 - "_Cbinds" :: "[Cletbind, Cletbinds] => Cletbinds" ("_;/ _")
17.60 - "_CLet" :: "[Cletbinds, 'a] => 'a" ("(Let (_)/ in (_))" 10)
17.61 -
17.62 -translations
17.63 - "_CLet (_Cbinds b bs) e" == "_CLet b (_CLet bs e)"
17.64 - "Let x = a in e" == "CLet$a$(LAM x. e)"
17.65 -
17.66 -
17.67 -(* syntax for LAM <x,y,z>.e *)
17.68 -
17.69 -syntax
17.70 - "_LAM" :: "[patterns, 'a => 'b] => ('a -> 'b)" ("(3LAM <_>./ _)" [0, 10] 10)
17.71 -
17.72 -translations
17.73 - "LAM <x,y,zs>.b" == "csplit$(LAM x. LAM <y,zs>.b)"
17.74 - "LAM <x,y>. LAM zs. b" <= "csplit$(LAM x y zs. b)"
17.75 - "LAM <x,y>.b" == "csplit$(LAM x y. b)"
17.76 -
17.77 -syntax (xsymbols)
17.78 - "_LAM" :: "[patterns, 'a => 'b] => ('a -> 'b)" ("(3\\<Lambda>()<_>./ _)" [0, 10] 10)
17.79 -
17.80 -end
18.1 --- a/src/HOLCF/Fix.ML Fri Mar 04 18:53:46 2005 +0100
18.2 +++ b/src/HOLCF/Fix.ML Fri Mar 04 23:12:36 2005 +0100
18.3 @@ -1,297 +1,93 @@
18.4 -(* Title: HOLCF/Fix.ML
18.5 - ID: $Id$
18.6 - Author: Franz Regensburger
18.7
18.8 -fixed point operator and admissibility
18.9 -*)
18.10 +(* legacy ML bindings *)
18.11
18.12 -(* ------------------------------------------------------------------------ *)
18.13 -(* derive inductive properties of iterate from primitive recursion *)
18.14 -(* ------------------------------------------------------------------------ *)
18.15 +val iterate_0 = thm "iterate_0";
18.16 +val iterate_Suc = thm "iterate_Suc";
18.17 +val Ifix_def = thm "Ifix_def";
18.18 +val fix_def = thm "fix_def";
18.19 +val adm_def = thm "adm_def";
18.20 +val admw_def = thm "admw_def";
18.21 +val iterate_Suc2 = thm "iterate_Suc2";
18.22 +val chain_iterate2 = thm "chain_iterate2";
18.23 +val chain_iterate = thm "chain_iterate";
18.24 +val Ifix_eq = thm "Ifix_eq";
18.25 +val Ifix_least = thm "Ifix_least";
18.26 +val monofun_iterate = thm "monofun_iterate";
18.27 +val contlub_iterate = thm "contlub_iterate";
18.28 +val cont_iterate = thm "cont_iterate";
18.29 +val monofun_iterate2 = thm "monofun_iterate2";
18.30 +val contlub_iterate2 = thm "contlub_iterate2";
18.31 +val cont_iterate2 = thm "cont_iterate2";
18.32 +val monofun_Ifix = thm "monofun_Ifix";
18.33 +val chain_iterate_lub = thm "chain_iterate_lub";
18.34 +val contlub_Ifix_lemma1 = thm "contlub_Ifix_lemma1";
18.35 +val ex_lub_iterate = thm "ex_lub_iterate";
18.36 +val contlub_Ifix = thm "contlub_Ifix";
18.37 +val cont_Ifix = thm "cont_Ifix";
18.38 +val fix_eq = thm "fix_eq";
18.39 +val fix_least = thm "fix_least";
18.40 +val fix_eqI = thm "fix_eqI";
18.41 +val fix_eq2 = thm "fix_eq2";
18.42 +val fix_eq3 = thm "fix_eq3";
18.43 +val fix_eq4 = thm "fix_eq4";
18.44 +val fix_eq5 = thm "fix_eq5";
18.45 +val Ifix_def2 = thm "Ifix_def2";
18.46 +val fix_def2 = thm "fix_def2";
18.47 +val admI = thm "admI";
18.48 +val triv_admI = thm "triv_admI";
18.49 +val admD = thm "admD";
18.50 +val admw_def2 = thm "admw_def2";
18.51 +val def_fix_ind = thm "def_fix_ind";
18.52 +val adm_impl_admw = thm "adm_impl_admw";
18.53 +val fix_ind = thm "fix_ind";
18.54 +val def_fix_ind = thm "def_fix_ind";
18.55 +val wfix_ind = thm "wfix_ind";
18.56 +val def_wfix_ind = thm "def_wfix_ind";
18.57 +val adm_max_in_chain = thm "adm_max_in_chain";
18.58 +val adm_chfin = thm "adm_chfin";
18.59 +val adm_chfindom = thm "adm_chfindom";
18.60 +val admI2 = thm "admI2";
18.61 +val adm_less = thm "adm_less";
18.62 +val adm_conj = thm "adm_conj";
18.63 +val adm_not_free = thm "adm_not_free";
18.64 +val adm_not_less = thm "adm_not_less";
18.65 +val adm_all = thm "adm_all";
18.66 +val adm_all2 = thm "adm_all2";
18.67 +val adm_subst = thm "adm_subst";
18.68 +val adm_UU_not_less = thm "adm_UU_not_less";
18.69 +val adm_not_UU = thm "adm_not_UU";
18.70 +val adm_eq = thm "adm_eq";
18.71 +val adm_disj_lemma1 = thm "adm_disj_lemma1";
18.72 +val adm_disj_lemma2 = thm "adm_disj_lemma2";
18.73 +val adm_disj_lemma3 = thm "adm_disj_lemma3";
18.74 +val adm_disj_lemma4 = thm "adm_disj_lemma4";
18.75 +val adm_disj_lemma5 = thm "adm_disj_lemma5";
18.76 +val adm_disj_lemma6 = thm "adm_disj_lemma6";
18.77 +val adm_disj_lemma7 = thm "adm_disj_lemma7";
18.78 +val adm_disj_lemma8 = thm "adm_disj_lemma8";
18.79 +val adm_disj_lemma9 = thm "adm_disj_lemma9";
18.80 +val adm_disj_lemma10 = thm "adm_disj_lemma10";
18.81 +val adm_disj_lemma12 = thm "adm_disj_lemma12";
18.82 +val adm_lemma11 = thm "adm_lemma11";
18.83 +val adm_disj = thm "adm_disj";
18.84 +val adm_imp = thm "adm_imp";
18.85 +val adm_iff = thm "adm_iff";
18.86 +val adm_not_conj = thm "adm_not_conj";
18.87 +val adm_lemmas = [adm_not_free, adm_imp, adm_disj, adm_eq, adm_not_UU,
18.88 + adm_UU_not_less, adm_all2, adm_not_less, adm_not_conj, adm_iff]
18.89
18.90 -Goal "iterate (Suc n) F x = iterate n F (F$x)";
18.91 -by (induct_tac "n" 1);
18.92 -by Auto_tac;
18.93 -qed "iterate_Suc2";
18.94 +structure Fix =
18.95 +struct
18.96 + val thy = the_context ();
18.97 + val Ifix_def = Ifix_def;
18.98 + val fix_def = fix_def;
18.99 + val adm_def = adm_def;
18.100 + val admw_def = admw_def;
18.101 +end;
18.102
18.103 -(* ------------------------------------------------------------------------ *)
18.104 -(* the sequence of function itertaions is a chain *)
18.105 -(* This property is essential since monotonicity of iterate makes no sense *)
18.106 -(* ------------------------------------------------------------------------ *)
18.107 +fun fix_tac3 thm i = ((rtac trans i) THEN (rtac (thm RS fix_eq3) i));
18.108
18.109 -Goalw [chain_def] "x << F$x ==> chain (%i. iterate i F x)";
18.110 -by (strip_tac 1);
18.111 -by (induct_tac "i" 1);
18.112 -by Auto_tac;
18.113 -by (etac monofun_cfun_arg 1);
18.114 -qed "chain_iterate2";
18.115 -
18.116 -
18.117 -Goal "chain (%i. iterate i F UU)";
18.118 -by (rtac chain_iterate2 1);
18.119 -by (rtac minimal 1);
18.120 -qed "chain_iterate";
18.121 -
18.122 -
18.123 -(* ------------------------------------------------------------------------ *)
18.124 -(* Kleene's fixed point theorems for continuous functions in pointed *)
18.125 -(* omega cpo's *)
18.126 -(* ------------------------------------------------------------------------ *)
18.127 -
18.128 -
18.129 -Goalw [Ifix_def] "Ifix F =F$(Ifix F)";
18.130 -by (stac contlub_cfun_arg 1);
18.131 -by (rtac chain_iterate 1);
18.132 -by (rtac antisym_less 1);
18.133 -by (rtac lub_mono 1);
18.134 -by (rtac chain_iterate 1);
18.135 -by (rtac ch2ch_Rep_CFunR 1);
18.136 -by (rtac chain_iterate 1);
18.137 -by (rtac allI 1);
18.138 -by (rtac (iterate_Suc RS subst) 1);
18.139 -by (rtac (chain_iterate RS chainE) 1);
18.140 -by (rtac is_lub_thelub 1);
18.141 -by (rtac ch2ch_Rep_CFunR 1);
18.142 -by (rtac chain_iterate 1);
18.143 -by (rtac ub_rangeI 1);
18.144 -by (rtac (iterate_Suc RS subst) 1);
18.145 -by (rtac is_ub_thelub 1);
18.146 -by (rtac chain_iterate 1);
18.147 -qed "Ifix_eq";
18.148 -
18.149 -
18.150 -Goalw [Ifix_def] "F$x=x ==> Ifix(F) << x";
18.151 -by (rtac is_lub_thelub 1);
18.152 -by (rtac chain_iterate 1);
18.153 -by (rtac ub_rangeI 1);
18.154 -by (strip_tac 1);
18.155 -by (induct_tac "i" 1);
18.156 -by (Asm_simp_tac 1);
18.157 -by (Asm_simp_tac 1);
18.158 -by (res_inst_tac [("t","x")] subst 1);
18.159 -by (atac 1);
18.160 -by (etac monofun_cfun_arg 1);
18.161 -qed "Ifix_least";
18.162 -
18.163 -
18.164 -(* ------------------------------------------------------------------------ *)
18.165 -(* monotonicity and continuity of iterate *)
18.166 -(* ------------------------------------------------------------------------ *)
18.167 -
18.168 -Goalw [monofun] "monofun(iterate(i))";
18.169 -by (strip_tac 1);
18.170 -by (induct_tac "i" 1);
18.171 -by (Asm_simp_tac 1);
18.172 -by (asm_full_simp_tac (simpset() addsimps [less_fun, monofun_cfun]) 1);
18.173 -qed "monofun_iterate";
18.174 -
18.175 -(* ------------------------------------------------------------------------ *)
18.176 -(* the following lemma uses contlub_cfun which itself is based on a *)
18.177 -(* diagonalisation lemma for continuous functions with two arguments. *)
18.178 -(* In this special case it is the application function Rep_CFun *)
18.179 -(* ------------------------------------------------------------------------ *)
18.180 -
18.181 -Goalw [contlub] "contlub(iterate(i))";
18.182 -by (strip_tac 1);
18.183 -by (induct_tac "i" 1);
18.184 -by (Asm_simp_tac 1);
18.185 -by (rtac (lub_const RS thelubI RS sym) 1);
18.186 -by (asm_simp_tac (simpset() delsimps [range_composition]) 1);
18.187 -by (rtac ext 1);
18.188 -by (stac thelub_fun 1);
18.189 -by (rtac chainI 1);
18.190 -by (rtac (less_fun RS iffD2) 1);
18.191 -by (rtac allI 1);
18.192 -by (rtac (chainE) 1);
18.193 -by (rtac (monofun_Rep_CFun1 RS ch2ch_MF2LR) 1);
18.194 -by (rtac allI 1);
18.195 -by (rtac monofun_Rep_CFun2 1);
18.196 -by (atac 1);
18.197 -by (rtac ch2ch_fun 1);
18.198 -by (rtac (monofun_iterate RS ch2ch_monofun) 1);
18.199 -by (atac 1);
18.200 -by (stac thelub_fun 1);
18.201 -by (rtac (monofun_iterate RS ch2ch_monofun) 1);
18.202 -by (atac 1);
18.203 -by (rtac contlub_cfun 1);
18.204 -by (atac 1);
18.205 -by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun) 1);
18.206 -qed "contlub_iterate";
18.207 -
18.208 -
18.209 -Goal "cont(iterate(i))";
18.210 -by (rtac monocontlub2cont 1);
18.211 -by (rtac monofun_iterate 1);
18.212 -by (rtac contlub_iterate 1);
18.213 -qed "cont_iterate";
18.214 -
18.215 -(* ------------------------------------------------------------------------ *)
18.216 -(* a lemma about continuity of iterate in its third argument *)
18.217 -(* ------------------------------------------------------------------------ *)
18.218 -
18.219 -Goal "monofun(iterate n F)";
18.220 -by (rtac monofunI 1);
18.221 -by (strip_tac 1);
18.222 -by (induct_tac "n" 1);
18.223 -by (Asm_simp_tac 1);
18.224 -by (Asm_simp_tac 1);
18.225 -by (etac monofun_cfun_arg 1);
18.226 -qed "monofun_iterate2";
18.227 -
18.228 -Goal "contlub(iterate n F)";
18.229 -by (rtac contlubI 1);
18.230 -by (strip_tac 1);
18.231 -by (induct_tac "n" 1);
18.232 -by (Simp_tac 1);
18.233 -by (Simp_tac 1);
18.234 -by (res_inst_tac [("t","iterate n F (lub(range(%u. Y u)))"),
18.235 - ("s","lub(range(%i. iterate n F (Y i)))")] ssubst 1);
18.236 -by (atac 1);
18.237 -by (rtac contlub_cfun_arg 1);
18.238 -by (etac (monofun_iterate2 RS ch2ch_monofun) 1);
18.239 -qed "contlub_iterate2";
18.240 -
18.241 -Goal "cont (iterate n F)";
18.242 -by (rtac monocontlub2cont 1);
18.243 -by (rtac monofun_iterate2 1);
18.244 -by (rtac contlub_iterate2 1);
18.245 -qed "cont_iterate2";
18.246 -
18.247 -(* ------------------------------------------------------------------------ *)
18.248 -(* monotonicity and continuity of Ifix *)
18.249 -(* ------------------------------------------------------------------------ *)
18.250 -
18.251 -Goalw [monofun,Ifix_def] "monofun(Ifix)";
18.252 -by (strip_tac 1);
18.253 -by (rtac lub_mono 1);
18.254 -by (rtac chain_iterate 1);
18.255 -by (rtac chain_iterate 1);
18.256 -by (rtac allI 1);
18.257 -by (rtac (less_fun RS iffD1 RS spec) 1 THEN
18.258 - etac (monofun_iterate RS monofunE RS spec RS spec RS mp) 1);
18.259 -qed "monofun_Ifix";
18.260 -
18.261 -(* ------------------------------------------------------------------------ *)
18.262 -(* since iterate is not monotone in its first argument, special lemmas must *)
18.263 -(* be derived for lubs in this argument *)
18.264 -(* ------------------------------------------------------------------------ *)
18.265 -
18.266 -Goal
18.267 -"chain(Y) ==> chain(%i. lub(range(%ia. iterate ia (Y i) UU)))";
18.268 -by (rtac chainI 1);
18.269 -by (strip_tac 1);
18.270 -by (rtac lub_mono 1);
18.271 -by (rtac chain_iterate 1);
18.272 -by (rtac chain_iterate 1);
18.273 -by (strip_tac 1);
18.274 -by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun RS chainE) 1);
18.275 -qed "chain_iterate_lub";
18.276 -
18.277 -(* ------------------------------------------------------------------------ *)
18.278 -(* this exchange lemma is analog to the one for monotone functions *)
18.279 -(* observe that monotonicity is not really needed. The propagation of *)
18.280 -(* chains is the essential argument which is usually derived from monot. *)
18.281 -(* ------------------------------------------------------------------------ *)
18.282 -
18.283 -Goal "chain(Y) ==>iterate n (lub(range Y)) y = lub(range(%i. iterate n (Y i) y))";
18.284 -by (rtac (thelub_fun RS subst) 1);
18.285 -by (etac (monofun_iterate RS ch2ch_monofun) 1);
18.286 -by (asm_simp_tac (simpset() addsimps [contlub_iterate RS contlubE]) 1);
18.287 -qed "contlub_Ifix_lemma1";
18.288 -
18.289 -
18.290 -Goal "chain(Y) ==>\
18.291 -\ lub(range(%i. lub(range(%ia. iterate i (Y ia) UU)))) =\
18.292 -\ lub(range(%i. lub(range(%ia. iterate ia (Y i) UU))))";
18.293 -by (rtac antisym_less 1);
18.294 -by (rtac is_lub_thelub 1);
18.295 -by (rtac (contlub_Ifix_lemma1 RS ext RS subst) 1);
18.296 -by (atac 1);
18.297 -by (rtac chain_iterate 1);
18.298 -by (rtac ub_rangeI 1);
18.299 -by (strip_tac 1);
18.300 -by (rtac lub_mono 1);
18.301 -by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun) 1);
18.302 -by (etac chain_iterate_lub 1);
18.303 -by (strip_tac 1);
18.304 -by (rtac is_ub_thelub 1);
18.305 -by (rtac chain_iterate 1);
18.306 -by (rtac is_lub_thelub 1);
18.307 -by (etac chain_iterate_lub 1);
18.308 -by (rtac ub_rangeI 1);
18.309 -by (strip_tac 1);
18.310 -by (rtac lub_mono 1);
18.311 -by (rtac chain_iterate 1);
18.312 -by (rtac (contlub_Ifix_lemma1 RS ext RS subst) 1);
18.313 -by (atac 1);
18.314 -by (rtac chain_iterate 1);
18.315 -by (strip_tac 1);
18.316 -by (rtac is_ub_thelub 1);
18.317 -by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun) 1);
18.318 -qed "ex_lub_iterate";
18.319 -
18.320 -
18.321 -Goalw [contlub,Ifix_def] "contlub(Ifix)";
18.322 -by (strip_tac 1);
18.323 -by (stac (contlub_Ifix_lemma1 RS ext) 1);
18.324 -by (atac 1);
18.325 -by (etac ex_lub_iterate 1);
18.326 -qed "contlub_Ifix";
18.327 -
18.328 -
18.329 -Goal "cont(Ifix)";
18.330 -by (rtac monocontlub2cont 1);
18.331 -by (rtac monofun_Ifix 1);
18.332 -by (rtac contlub_Ifix 1);
18.333 -qed "cont_Ifix";
18.334 -
18.335 -(* ------------------------------------------------------------------------ *)
18.336 -(* propagate properties of Ifix to its continuous counterpart *)
18.337 -(* ------------------------------------------------------------------------ *)
18.338 -
18.339 -Goalw [fix_def] "fix$F = F$(fix$F)";
18.340 -by (asm_simp_tac (simpset() addsimps [cont_Ifix]) 1);
18.341 -by (rtac Ifix_eq 1);
18.342 -qed "fix_eq";
18.343 -
18.344 -Goalw [fix_def] "F$x = x ==> fix$F << x";
18.345 -by (asm_simp_tac (simpset() addsimps [cont_Ifix]) 1);
18.346 -by (etac Ifix_least 1);
18.347 -qed "fix_least";
18.348 -
18.349 -
18.350 -Goal
18.351 -"[| F$x = x; !z. F$z = z --> x << z |] ==> x = fix$F";
18.352 -by (rtac antisym_less 1);
18.353 -by (etac allE 1);
18.354 -by (etac mp 1);
18.355 -by (rtac (fix_eq RS sym) 1);
18.356 -by (etac fix_least 1);
18.357 -qed "fix_eqI";
18.358 -
18.359 -
18.360 -Goal "f == fix$F ==> f = F$f";
18.361 -by (asm_simp_tac (simpset() addsimps [fix_eq RS sym]) 1);
18.362 -qed "fix_eq2";
18.363 -
18.364 -Goal "f == fix$F ==> f$x = F$f$x";
18.365 -by (etac (fix_eq2 RS cfun_fun_cong) 1);
18.366 -qed "fix_eq3";
18.367 -
18.368 -fun fix_tac3 thm i = ((rtac trans i) THEN (rtac (thm RS fix_eq3) i));
18.369 -
18.370 -Goal "f = fix$F ==> f = F$f";
18.371 -by (hyp_subst_tac 1);
18.372 -by (rtac fix_eq 1);
18.373 -qed "fix_eq4";
18.374 -
18.375 -Goal "f = fix$F ==> f$x = F$f$x";
18.376 -by (rtac trans 1);
18.377 -by (etac (fix_eq4 RS cfun_fun_cong) 1);
18.378 -by (rtac refl 1);
18.379 -qed "fix_eq5";
18.380 -
18.381 -fun fix_tac5 thm i = ((rtac trans i) THEN (rtac (thm RS fix_eq5) i));
18.382 +fun fix_tac5 thm i = ((rtac trans i) THEN (rtac (thm RS fix_eq5) i));
18.383
18.384 (* proves the unfolding theorem for function equations f = fix$... *)
18.385 fun fix_prover thy fixeq s = prove_goal thy s (fn prems => [
18.386 @@ -313,416 +109,8 @@
18.387
18.388 (* proves an application case for a function from its unfolding thm *)
18.389 fun case_prover thy unfold s = prove_goal thy s (fn prems => [
18.390 - (cut_facts_tac prems 1),
18.391 - (rtac trans 1),
18.392 - (stac unfold 1),
18.393 - Auto_tac
18.394 - ]);
18.395 -
18.396 -(* ------------------------------------------------------------------------ *)
18.397 -(* better access to definitions *)
18.398 -(* ------------------------------------------------------------------------ *)
18.399 -
18.400 -
18.401 -Goal "Ifix=(%x. lub(range(%i. iterate i x UU)))";
18.402 -by (rtac ext 1);
18.403 -by (rewtac Ifix_def);
18.404 -by (rtac refl 1);
18.405 -qed "Ifix_def2";
18.406 -
18.407 -(* ------------------------------------------------------------------------ *)
18.408 -(* direct connection between fix and iteration without Ifix *)
18.409 -(* ------------------------------------------------------------------------ *)
18.410 -
18.411 -Goalw [fix_def] "fix$F = lub(range(%i. iterate i F UU))";
18.412 -by (fold_goals_tac [Ifix_def]);
18.413 -by (asm_simp_tac (simpset() addsimps [cont_Ifix]) 1);
18.414 -qed "fix_def2";
18.415 -
18.416 -
18.417 -(* ------------------------------------------------------------------------ *)
18.418 -(* Lemmas about admissibility and fixed point induction *)
18.419 -(* ------------------------------------------------------------------------ *)
18.420 -
18.421 -(* ------------------------------------------------------------------------ *)
18.422 -(* access to definitions *)
18.423 -(* ------------------------------------------------------------------------ *)
18.424 -
18.425 -val prems = Goalw [adm_def]
18.426 - "(!!Y. [| chain Y; !i. P (Y i) |] ==> P (lub (range Y))) ==> adm P";
18.427 -by (blast_tac (claset() addIs prems) 1);
18.428 -qed "admI";
18.429 -
18.430 -Goal "!x. P x ==> adm P";
18.431 -by (rtac admI 1);
18.432 -by (etac spec 1);
18.433 -qed "triv_admI";
18.434 -
18.435 -Goalw [adm_def] "[| adm(P); chain(Y); !i. P(Y(i)) |] ==> P(lub(range(Y)))";
18.436 -by (Blast_tac 1);
18.437 -qed "admD";
18.438 -
18.439 -Goalw [admw_def] "admw(P) = (!F.(!n. P(iterate n F UU)) -->\
18.440 -\ P (lub(range(%i. iterate i F UU))))";
18.441 -by (rtac refl 1);
18.442 -qed "admw_def2";
18.443 -
18.444 -(* ------------------------------------------------------------------------ *)
18.445 -(* an admissible formula is also weak admissible *)
18.446 -(* ------------------------------------------------------------------------ *)
18.447 -
18.448 -Goalw [admw_def] "adm(P)==>admw(P)";
18.449 -by (strip_tac 1);
18.450 -by (etac admD 1);
18.451 -by (rtac chain_iterate 1);
18.452 -by (atac 1);
18.453 -qed "adm_impl_admw";
18.454 -
18.455 -(* ------------------------------------------------------------------------ *)
18.456 -(* fixed point induction *)
18.457 -(* ------------------------------------------------------------------------ *)
18.458 -
18.459 -val major::prems = Goal
18.460 - "[| adm(P); P(UU); !!x. P(x) ==> P(F$x)|] ==> P(fix$F)";
18.461 -by (stac fix_def2 1);
18.462 -by (rtac (major RS admD) 1);
18.463 -by (rtac chain_iterate 1);
18.464 -by (rtac allI 1);
18.465 -by (induct_tac "i" 1);
18.466 -by (asm_simp_tac (simpset() addsimps (iterate_0::prems)) 1);
18.467 -by (asm_simp_tac (simpset() addsimps (iterate_Suc::prems)) 1);
18.468 -qed "fix_ind";
18.469 -
18.470 -val prems = Goal "[| f == fix$F; adm(P); \
18.471 -\ P(UU); !!x. P(x) ==> P(F$x)|] ==> P f";
18.472 -by (cut_facts_tac prems 1);
18.473 -by (asm_simp_tac HOL_ss 1);
18.474 -by (etac fix_ind 1);
18.475 -by (atac 1);
18.476 -by (eresolve_tac prems 1);
18.477 -qed "def_fix_ind";
18.478 -
18.479 -(* ------------------------------------------------------------------------ *)
18.480 -(* computational induction for weak admissible formulae *)
18.481 -(* ------------------------------------------------------------------------ *)
18.482 -
18.483 -Goal "[| admw(P); !n. P(iterate n F UU)|] ==> P(fix$F)";
18.484 -by (stac fix_def2 1);
18.485 -by (rtac (admw_def2 RS iffD1 RS spec RS mp) 1);
18.486 -by (atac 1);
18.487 -by (rtac allI 1);
18.488 -by (etac spec 1);
18.489 -qed "wfix_ind";
18.490 -
18.491 -Goal "[| f == fix$F; admw(P); \
18.492 -\ !n. P(iterate n F UU) |] ==> P f";
18.493 -by (asm_simp_tac HOL_ss 1);
18.494 -by (etac wfix_ind 1);
18.495 -by (atac 1);
18.496 -qed "def_wfix_ind";
18.497 -
18.498 -(* ------------------------------------------------------------------------ *)
18.499 -(* for chain-finite (easy) types every formula is admissible *)
18.500 -(* ------------------------------------------------------------------------ *)
18.501 -
18.502 -Goalw [adm_def]
18.503 -"!Y. chain(Y::nat=>'a) --> (? n. max_in_chain n Y) ==> adm(P::'a=>bool)";
18.504 -by (strip_tac 1);
18.505 -by (rtac exE 1);
18.506 -by (rtac mp 1);
18.507 -by (etac spec 1);
18.508 -by (atac 1);
18.509 -by (stac (lub_finch1 RS thelubI) 1);
18.510 -by (atac 1);
18.511 -by (atac 1);
18.512 -by (etac spec 1);
18.513 -qed "adm_max_in_chain";
18.514 -
18.515 -bind_thm ("adm_chfin" ,chfin RS adm_max_in_chain);
18.516 -
18.517 -(* ------------------------------------------------------------------------ *)
18.518 -(* some lemmata for functions with flat/chfin domain/range types *)
18.519 -(* ------------------------------------------------------------------------ *)
18.520 -
18.521 -val _ = goalw thy [adm_def] "adm (%(u::'a::cpo->'b::chfin). P(u$s))";
18.522 -by (strip_tac 1);
18.523 -by (dtac chfin_Rep_CFunR 1);
18.524 -by (eres_inst_tac [("x","s")] allE 1);
18.525 -by (fast_tac (HOL_cs addss (simpset() addsimps [chfin])) 1);
18.526 -qed "adm_chfindom";
18.527 -
18.528 -(* adm_flat not needed any more, since it is a special case of adm_chfindom *)
18.529 -
18.530 -(* ------------------------------------------------------------------------ *)
18.531 -(* improved admisibility introduction *)
18.532 -(* ------------------------------------------------------------------------ *)
18.533 -
18.534 -val prems = Goalw [adm_def]
18.535 - "(!!Y. [| chain Y; !i. P (Y i); !i. ? j. i < j & Y i ~= Y j & Y i << Y j |]\
18.536 -\ ==> P(lub (range Y))) ==> adm P";
18.537 -by (strip_tac 1);
18.538 -by (etac increasing_chain_adm_lemma 1);
18.539 -by (atac 1);
18.540 -by (eresolve_tac prems 1);
18.541 -by (atac 1);
18.542 -by (atac 1);
18.543 -qed "admI2";
18.544 -
18.545 -
18.546 -(* ------------------------------------------------------------------------ *)
18.547 -(* admissibility of special formulae and propagation *)
18.548 -(* ------------------------------------------------------------------------ *)
18.549 -
18.550 -Goalw [adm_def] "[|cont u;cont v|]==> adm(%x. u x << v x)";
18.551 -by (strip_tac 1);
18.552 -by (forw_inst_tac [("f","u")] (cont2mono RS ch2ch_monofun) 1);
18.553 -by (assume_tac 1);
18.554 -by (forw_inst_tac [("f","v")] (cont2mono RS ch2ch_monofun) 1);
18.555 -by (assume_tac 1);
18.556 -by (etac (cont2contlub RS contlubE RS spec RS mp RS ssubst) 1);
18.557 -by (atac 1);
18.558 -by (etac (cont2contlub RS contlubE RS spec RS mp RS ssubst) 1);
18.559 -by (atac 1);
18.560 -by (blast_tac (claset() addIs [lub_mono]) 1);
18.561 -qed "adm_less";
18.562 -Addsimps [adm_less];
18.563 -
18.564 -Goal "[| adm P; adm Q |] ==> adm(%x. P x & Q x)";
18.565 -by (fast_tac (HOL_cs addEs [admD] addIs [admI]) 1);
18.566 -qed "adm_conj";
18.567 -Addsimps [adm_conj];
18.568 -
18.569 -Goalw [adm_def] "adm(%x. t)";
18.570 -by (fast_tac HOL_cs 1);
18.571 -qed "adm_not_free";
18.572 -Addsimps [adm_not_free];
18.573 -
18.574 -Goalw [adm_def] "cont t ==> adm(%x.~ (t x) << u)";
18.575 -by (strip_tac 1);
18.576 -by (rtac contrapos_nn 1);
18.577 -by (etac spec 1);
18.578 -by (rtac trans_less 1);
18.579 -by (atac 2);
18.580 -by (etac (cont2mono RS monofun_fun_arg) 1);
18.581 -by (rtac is_ub_thelub 1);
18.582 -by (atac 1);
18.583 -qed "adm_not_less";
18.584 -
18.585 -Goal "!y. adm(P y) ==> adm(%x.!y. P y x)";
18.586 -by (fast_tac (HOL_cs addIs [admI] addEs [admD]) 1);
18.587 -qed "adm_all";
18.588 -
18.589 -bind_thm ("adm_all2", allI RS adm_all);
18.590 -
18.591 -Goal "[|cont t; adm P|] ==> adm(%x. P (t x))";
18.592 -by (rtac admI 1);
18.593 -by (stac (cont2contlub RS contlubE RS spec RS mp) 1);
18.594 -by (atac 1);
18.595 -by (atac 1);
18.596 -by (etac admD 1);
18.597 -by (etac (cont2mono RS ch2ch_monofun) 1);
18.598 -by (atac 1);
18.599 -by (atac 1);
18.600 -qed "adm_subst";
18.601 -
18.602 -Goal "adm(%x.~ UU << t(x))";
18.603 -by (Simp_tac 1);
18.604 -qed "adm_UU_not_less";
18.605 -
18.606 -
18.607 -Goalw [adm_def] "cont(t)==> adm(%x.~ (t x) = UU)";
18.608 -by (strip_tac 1);
18.609 -by (rtac contrapos_nn 1);
18.610 -by (etac spec 1);
18.611 -by (rtac (chain_UU_I RS spec) 1);
18.612 -by (etac (cont2mono RS ch2ch_monofun) 1);
18.613 -by (atac 1);
18.614 -by (etac (cont2contlub RS contlubE RS spec RS mp RS subst) 1);
18.615 -by (atac 1);
18.616 -by (atac 1);
18.617 -qed "adm_not_UU";
18.618 -
18.619 -Goal "[|cont u ; cont v|]==> adm(%x. u x = v x)";
18.620 -by (asm_simp_tac (simpset() addsimps [po_eq_conv]) 1);
18.621 -qed "adm_eq";
18.622 -
18.623 -
18.624 -
18.625 -(* ------------------------------------------------------------------------ *)
18.626 -(* admissibility for disjunction is hard to prove. It takes 10 Lemmas *)
18.627 -(* ------------------------------------------------------------------------ *)
18.628 -
18.629 -
18.630 -Goal "!n. P(Y n)|Q(Y n) ==> (? i.!j. R i j --> Q(Y(j))) | (!i.? j. R i j & P(Y(j)))";
18.631 -by (Fast_tac 1);
18.632 -qed "adm_disj_lemma1";
18.633 -
18.634 -Goal "[| adm(Q); ? X. chain(X) & (!n. Q(X(n))) &\
18.635 - \ lub(range(Y))=lub(range(X))|] ==> Q(lub(range(Y)))";
18.636 -by (force_tac (claset() addEs [admD], simpset()) 1);
18.637 -qed "adm_disj_lemma2";
18.638 -
18.639 -Goalw [chain_def]"chain Y ==> chain (%m. if m < Suc i then Y (Suc i) else Y m)";
18.640 -by (Asm_simp_tac 1);
18.641 -by (safe_tac HOL_cs);
18.642 -by (subgoal_tac "ia = i" 1);
18.643 -by (ALLGOALS Asm_simp_tac);
18.644 -qed "adm_disj_lemma3";
18.645 -
18.646 -Goal "!j. i < j --> Q(Y(j)) ==> !n. Q( if n < Suc i then Y(Suc i) else Y n)";
18.647 -by (Asm_simp_tac 1);
18.648 -qed "adm_disj_lemma4";
18.649 -
18.650 -Goal
18.651 - "!!Y::nat=>'a::cpo. [| chain(Y); ! j. i < j --> Q(Y(j)) |] ==>\
18.652 - \ lub(range(Y)) = lub(range(%m. if m< Suc(i) then Y(Suc(i)) else Y m))";
18.653 -by (safe_tac (HOL_cs addSIs [lub_equal2,adm_disj_lemma3]));
18.654 -by (atac 2);
18.655 -by (res_inst_tac [("x","i")] exI 1);
18.656 -by (Asm_simp_tac 1);
18.657 -qed "adm_disj_lemma5";
18.658 -
18.659 -Goal
18.660 - "[| chain(Y::nat=>'a::cpo); ? i. ! j. i < j --> Q(Y(j)) |] ==>\
18.661 - \ ? X. chain(X) & (! n. Q(X(n))) & lub(range(Y)) = lub(range(X))";
18.662 -by (etac exE 1);
18.663 -by (res_inst_tac [("x","%m. if m<Suc(i) then Y(Suc(i)) else Y m")] exI 1);
18.664 -by (rtac conjI 1);
18.665 -by (rtac adm_disj_lemma3 1);
18.666 -by (atac 1);
18.667 -by (rtac conjI 1);
18.668 -by (rtac adm_disj_lemma4 1);
18.669 -by (atac 1);
18.670 -by (rtac adm_disj_lemma5 1);
18.671 -by (atac 1);
18.672 -by (atac 1);
18.673 -qed "adm_disj_lemma6";
18.674 -
18.675 -Goal
18.676 - "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>\
18.677 - \ chain(%m. Y(Least(%j. m<j & P(Y(j)))))";
18.678 -by (rtac chainI 1);
18.679 -by (rtac chain_mono3 1);
18.680 -by (atac 1);
18.681 -by (rtac Least_le 1);
18.682 -by (rtac conjI 1);
18.683 -by (rtac Suc_lessD 1);
18.684 -by (etac allE 1);
18.685 -by (etac exE 1);
18.686 -by (rtac (LeastI RS conjunct1) 1);
18.687 -by (atac 1);
18.688 -by (etac allE 1);
18.689 -by (etac exE 1);
18.690 -by (rtac (LeastI RS conjunct2) 1);
18.691 -by (atac 1);
18.692 -qed "adm_disj_lemma7";
18.693 -
18.694 -Goal
18.695 - "[| ! i. ? j. i < j & P(Y(j)) |] ==> ! m. P(Y(LEAST j::nat. m<j & P(Y(j))))";
18.696 -by (strip_tac 1);
18.697 -by (etac allE 1);
18.698 -by (etac exE 1);
18.699 -by (etac (LeastI RS conjunct2) 1);
18.700 -qed "adm_disj_lemma8";
18.701 -
18.702 -Goal
18.703 - "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>\
18.704 - \ lub(range(Y)) = lub(range(%m. Y(Least(%j. m<j & P(Y(j))))))";
18.705 -by (rtac antisym_less 1);
18.706 -by (rtac lub_mono 1);
18.707 -by (atac 1);
18.708 -by (rtac adm_disj_lemma7 1);
18.709 -by (atac 1);
18.710 -by (atac 1);
18.711 -by (strip_tac 1);
18.712 -by (rtac (chain_mono) 1);
18.713 -by (atac 1);
18.714 -by (etac allE 1);
18.715 -by (etac exE 1);
18.716 -by (rtac (LeastI RS conjunct1) 1);
18.717 -by (atac 1);
18.718 -by (rtac lub_mono3 1);
18.719 -by (rtac adm_disj_lemma7 1);
18.720 -by (atac 1);
18.721 -by (atac 1);
18.722 -by (atac 1);
18.723 -by (strip_tac 1);
18.724 -by (rtac exI 1);
18.725 -by (rtac (chain_mono) 1);
18.726 -by (atac 1);
18.727 -by (rtac lessI 1);
18.728 -qed "adm_disj_lemma9";
18.729 -
18.730 -Goal "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>\
18.731 - \ ? X. chain(X) & (! n. P(X(n))) & lub(range(Y)) = lub(range(X))";
18.732 -by (res_inst_tac [("x","%m. Y(Least(%j. m<j & P(Y(j))))")] exI 1);
18.733 -by (rtac conjI 1);
18.734 -by (rtac adm_disj_lemma7 1);
18.735 -by (atac 1);
18.736 -by (atac 1);
18.737 -by (rtac conjI 1);
18.738 -by (rtac adm_disj_lemma8 1);
18.739 -by (atac 1);
18.740 -by (rtac adm_disj_lemma9 1);
18.741 -by (atac 1);
18.742 -by (atac 1);
18.743 -qed "adm_disj_lemma10";
18.744 -
18.745 -Goal "[| adm(P); chain(Y);? i. ! j. i < j --> P(Y(j))|]==>P(lub(range(Y)))";
18.746 -by (etac adm_disj_lemma2 1);
18.747 -by (etac adm_disj_lemma6 1);
18.748 -by (atac 1);
18.749 -qed "adm_disj_lemma12";
18.750 -
18.751 -
18.752 -Goal
18.753 -"[| adm(P); chain(Y); ! i. ? j. i < j & P(Y(j)) |]==>P(lub(range(Y)))";
18.754 -by (etac adm_disj_lemma2 1);
18.755 -by (etac adm_disj_lemma10 1);
18.756 -by (atac 1);
18.757 -qed "adm_lemma11";
18.758 -
18.759 -Goal "[| adm P; adm Q |] ==> adm(%x. P x | Q x)";
18.760 -by (rtac admI 1);
18.761 -by (rtac (adm_disj_lemma1 RS disjE) 1);
18.762 -by (atac 1);
18.763 -by (rtac disjI2 1);
18.764 -by (etac adm_disj_lemma12 1);
18.765 -by (atac 1);
18.766 -by (atac 1);
18.767 -by (rtac disjI1 1);
18.768 -by (etac adm_lemma11 1);
18.769 -by (atac 1);
18.770 -by (atac 1);
18.771 -qed "adm_disj";
18.772 -
18.773 -Goal "[| adm(%x.~(P x)); adm Q |] ==> adm(%x. P x --> Q x)";
18.774 -by (subgoal_tac "(%x. P x --> Q x) = (%x. ~P x | Q x)" 1);
18.775 -by (etac ssubst 1);
18.776 -by (etac adm_disj 1);
18.777 -by (atac 1);
18.778 -by (Simp_tac 1);
18.779 -qed "adm_imp";
18.780 -
18.781 -Goal "[| adm (%x. P x --> Q x); adm (%x. Q x --> P x) |] \
18.782 -\ ==> adm (%x. P x = Q x)";
18.783 -by (subgoal_tac "(%x. P x = Q x) = (%x. (P x --> Q x) & (Q x --> P x))" 1);
18.784 -by (Asm_simp_tac 1);
18.785 -by (rtac ext 1);
18.786 -by (fast_tac HOL_cs 1);
18.787 -qed"adm_iff";
18.788 -
18.789 -
18.790 -Goal "[| adm (%x. ~ P x); adm (%x. ~ Q x) |] ==> adm (%x. ~ (P x & Q x))";
18.791 -by (subgoal_tac "(%x. ~ (P x & Q x)) = (%x. ~ P x | ~ Q x)" 1);
18.792 -by (rtac ext 2);
18.793 -by (fast_tac HOL_cs 2);
18.794 -by (etac ssubst 1);
18.795 -by (etac adm_disj 1);
18.796 -by (atac 1);
18.797 -qed "adm_not_conj";
18.798 -
18.799 -bind_thms ("adm_lemmas", [adm_not_free,adm_imp,adm_disj,adm_eq,adm_not_UU,
18.800 - adm_UU_not_less,adm_all2,adm_not_less,adm_not_conj,adm_iff]);
18.801 -
18.802 -Addsimps adm_lemmas;
18.803 + (cut_facts_tac prems 1),
18.804 + (rtac trans 1),
18.805 + (stac unfold 1),
18.806 + Auto_tac
18.807 + ]);
19.1 --- a/src/HOLCF/Fix.thy Fri Mar 04 18:53:46 2005 +0100
19.2 +++ b/src/HOLCF/Fix.thy Fri Mar 04 23:12:36 2005 +0100
19.3 @@ -1,34 +1,790 @@
19.4 (* Title: HOLCF/Fix.thy
19.5 ID: $Id$
19.6 Author: Franz Regensburger
19.7 + License: GPL (GNU GENERAL PUBLIC LICENSE)
19.8
19.9 definitions for fixed point operator and admissibility
19.10 *)
19.11
19.12 -Fix = Cfun3 +
19.13 +theory Fix = Cfun:
19.14
19.15 consts
19.16
19.17 iterate :: "nat=>('a->'a)=>'a=>'a"
19.18 Ifix :: "('a->'a)=>'a"
19.19 -fix :: "('a->'a)->'a"
19.20 +"fix" :: "('a->'a)->'a"
19.21 adm :: "('a::cpo=>bool)=>bool"
19.22 admw :: "('a=>bool)=>bool"
19.23
19.24 primrec
19.25 - iterate_0 "iterate 0 F x = x"
19.26 - iterate_Suc "iterate (Suc n) F x = F$(iterate n F x)"
19.27 + iterate_0: "iterate 0 F x = x"
19.28 + iterate_Suc: "iterate (Suc n) F x = F$(iterate n F x)"
19.29
19.30 defs
19.31
19.32 -Ifix_def "Ifix F == lub(range(%i. iterate i F UU))"
19.33 -fix_def "fix == (LAM f. Ifix f)"
19.34 +Ifix_def: "Ifix F == lub(range(%i. iterate i F UU))"
19.35 +fix_def: "fix == (LAM f. Ifix f)"
19.36
19.37 -adm_def "adm P == !Y. chain(Y) -->
19.38 +adm_def: "adm P == !Y. chain(Y) -->
19.39 (!i. P(Y i)) --> P(lub(range Y))"
19.40
19.41 -admw_def "admw P == !F. (!n. P (iterate n F UU)) -->
19.42 +admw_def: "admw P == !F. (!n. P (iterate n F UU)) -->
19.43 P (lub(range (%i. iterate i F UU)))"
19.44
19.45 +(* Title: HOLCF/Fix.ML
19.46 + ID: $Id$
19.47 + Author: Franz Regensburger
19.48 + License: GPL (GNU GENERAL PUBLIC LICENSE)
19.49 +
19.50 +fixed point operator and admissibility
19.51 +*)
19.52 +
19.53 +(* ------------------------------------------------------------------------ *)
19.54 +(* derive inductive properties of iterate from primitive recursion *)
19.55 +(* ------------------------------------------------------------------------ *)
19.56 +
19.57 +lemma iterate_Suc2: "iterate (Suc n) F x = iterate n F (F$x)"
19.58 +apply (induct_tac "n")
19.59 +apply auto
19.60 +done
19.61 +
19.62 +(* ------------------------------------------------------------------------ *)
19.63 +(* the sequence of function itertaions is a chain *)
19.64 +(* This property is essential since monotonicity of iterate makes no sense *)
19.65 +(* ------------------------------------------------------------------------ *)
19.66 +
19.67 +lemma chain_iterate2: "x << F$x ==> chain (%i. iterate i F x)"
19.68 +
19.69 +apply (unfold chain_def)
19.70 +apply (intro strip)
19.71 +apply (induct_tac "i")
19.72 +apply auto
19.73 +apply (erule monofun_cfun_arg)
19.74 +done
19.75 +
19.76 +
19.77 +lemma chain_iterate: "chain (%i. iterate i F UU)"
19.78 +apply (rule chain_iterate2)
19.79 +apply (rule minimal)
19.80 +done
19.81 +
19.82 +
19.83 +(* ------------------------------------------------------------------------ *)
19.84 +(* Kleene's fixed point theorems for continuous functions in pointed *)
19.85 +(* omega cpo's *)
19.86 +(* ------------------------------------------------------------------------ *)
19.87 +
19.88 +
19.89 +lemma Ifix_eq: "Ifix F =F$(Ifix F)"
19.90 +
19.91 +
19.92 +apply (unfold Ifix_def)
19.93 +apply (subst contlub_cfun_arg)
19.94 +apply (rule chain_iterate)
19.95 +apply (rule antisym_less)
19.96 +apply (rule lub_mono)
19.97 +apply (rule chain_iterate)
19.98 +apply (rule ch2ch_Rep_CFunR)
19.99 +apply (rule chain_iterate)
19.100 +apply (rule allI)
19.101 +apply (rule iterate_Suc [THEN subst])
19.102 +apply (rule chain_iterate [THEN chainE])
19.103 +apply (rule is_lub_thelub)
19.104 +apply (rule ch2ch_Rep_CFunR)
19.105 +apply (rule chain_iterate)
19.106 +apply (rule ub_rangeI)
19.107 +apply (rule iterate_Suc [THEN subst])
19.108 +apply (rule is_ub_thelub)
19.109 +apply (rule chain_iterate)
19.110 +done
19.111 +
19.112 +
19.113 +lemma Ifix_least: "F$x=x ==> Ifix(F) << x"
19.114 +
19.115 +apply (unfold Ifix_def)
19.116 +apply (rule is_lub_thelub)
19.117 +apply (rule chain_iterate)
19.118 +apply (rule ub_rangeI)
19.119 +apply (induct_tac "i")
19.120 +apply (simp (no_asm_simp))
19.121 +apply (simp (no_asm_simp))
19.122 +apply (rule_tac t = "x" in subst)
19.123 +apply assumption
19.124 +apply (erule monofun_cfun_arg)
19.125 +done
19.126 +
19.127 +
19.128 +(* ------------------------------------------------------------------------ *)
19.129 +(* monotonicity and continuity of iterate *)
19.130 +(* ------------------------------------------------------------------------ *)
19.131 +
19.132 +lemma monofun_iterate: "monofun(iterate(i))"
19.133 +apply (unfold monofun)
19.134 +apply (intro strip)
19.135 +apply (induct_tac "i")
19.136 +apply (simp (no_asm_simp))
19.137 +apply (simp add: less_fun monofun_cfun)
19.138 +done
19.139 +
19.140 +(* ------------------------------------------------------------------------ *)
19.141 +(* the following lemma uses contlub_cfun which itself is based on a *)
19.142 +(* diagonalisation lemma for continuous functions with two arguments. *)
19.143 +(* In this special case it is the application function Rep_CFun *)
19.144 +(* ------------------------------------------------------------------------ *)
19.145 +
19.146 +lemma contlub_iterate: "contlub(iterate(i))"
19.147 +
19.148 +apply (unfold contlub)
19.149 +apply (intro strip)
19.150 +apply (induct_tac "i")
19.151 +apply (simp (no_asm_simp))
19.152 +apply (rule lub_const [THEN thelubI, symmetric])
19.153 +apply (simp (no_asm_simp) del: range_composition)
19.154 +apply (rule ext)
19.155 +apply (simplesubst thelub_fun)
19.156 +apply (rule chainI)
19.157 +apply (rule less_fun [THEN iffD2])
19.158 +apply (rule allI)
19.159 +apply (rule chainE)
19.160 +apply (rule monofun_Rep_CFun1 [THEN ch2ch_MF2LR])
19.161 +apply (rule allI)
19.162 +apply (rule monofun_Rep_CFun2)
19.163 +apply assumption
19.164 +apply (rule ch2ch_fun)
19.165 +apply (rule monofun_iterate [THEN ch2ch_monofun])
19.166 +apply assumption
19.167 +apply (subst thelub_fun)
19.168 +apply (rule monofun_iterate [THEN ch2ch_monofun])
19.169 +apply assumption
19.170 +apply (rule contlub_cfun)
19.171 +apply assumption
19.172 +apply (erule monofun_iterate [THEN ch2ch_monofun, THEN ch2ch_fun])
19.173 +done
19.174 +
19.175 +
19.176 +lemma cont_iterate: "cont(iterate(i))"
19.177 +apply (rule monocontlub2cont)
19.178 +apply (rule monofun_iterate)
19.179 +apply (rule contlub_iterate)
19.180 +done
19.181 +
19.182 +(* ------------------------------------------------------------------------ *)
19.183 +(* a lemma about continuity of iterate in its third argument *)
19.184 +(* ------------------------------------------------------------------------ *)
19.185 +
19.186 +lemma monofun_iterate2: "monofun(iterate n F)"
19.187 +apply (rule monofunI)
19.188 +apply (intro strip)
19.189 +apply (induct_tac "n")
19.190 +apply (simp (no_asm_simp))
19.191 +apply (simp (no_asm_simp))
19.192 +apply (erule monofun_cfun_arg)
19.193 +done
19.194 +
19.195 +lemma contlub_iterate2: "contlub(iterate n F)"
19.196 +apply (rule contlubI)
19.197 +apply (intro strip)
19.198 +apply (induct_tac "n")
19.199 +apply (simp (no_asm))
19.200 +apply (simp (no_asm))
19.201 +apply (rule_tac t = "iterate n F (lub (range (%u. Y u))) " and s = "lub (range (%i. iterate n F (Y i))) " in ssubst)
19.202 +apply assumption
19.203 +apply (rule contlub_cfun_arg)
19.204 +apply (erule monofun_iterate2 [THEN ch2ch_monofun])
19.205 +done
19.206 +
19.207 +lemma cont_iterate2: "cont (iterate n F)"
19.208 +apply (rule monocontlub2cont)
19.209 +apply (rule monofun_iterate2)
19.210 +apply (rule contlub_iterate2)
19.211 +done
19.212 +
19.213 +(* ------------------------------------------------------------------------ *)
19.214 +(* monotonicity and continuity of Ifix *)
19.215 +(* ------------------------------------------------------------------------ *)
19.216 +
19.217 +lemma monofun_Ifix: "monofun(Ifix)"
19.218 +
19.219 +apply (unfold monofun Ifix_def)
19.220 +apply (intro strip)
19.221 +apply (rule lub_mono)
19.222 +apply (rule chain_iterate)
19.223 +apply (rule chain_iterate)
19.224 +apply (rule allI)
19.225 +apply (rule less_fun [THEN iffD1, THEN spec], erule monofun_iterate [THEN monofunE, THEN spec, THEN spec, THEN mp])
19.226 +done
19.227 +
19.228 +(* ------------------------------------------------------------------------ *)
19.229 +(* since iterate is not monotone in its first argument, special lemmas must *)
19.230 +(* be derived for lubs in this argument *)
19.231 +(* ------------------------------------------------------------------------ *)
19.232 +
19.233 +lemma chain_iterate_lub:
19.234 +"chain(Y) ==> chain(%i. lub(range(%ia. iterate ia (Y i) UU)))"
19.235 +apply (rule chainI)
19.236 +apply (rule lub_mono)
19.237 +apply (rule chain_iterate)
19.238 +apply (rule chain_iterate)
19.239 +apply (intro strip)
19.240 +apply (erule monofun_iterate [THEN ch2ch_monofun, THEN ch2ch_fun, THEN chainE])
19.241 +done
19.242 +
19.243 +(* ------------------------------------------------------------------------ *)
19.244 +(* this exchange lemma is analog to the one for monotone functions *)
19.245 +(* observe that monotonicity is not really needed. The propagation of *)
19.246 +(* chains is the essential argument which is usually derived from monot. *)
19.247 +(* ------------------------------------------------------------------------ *)
19.248 +
19.249 +lemma contlub_Ifix_lemma1: "chain(Y) ==>iterate n (lub(range Y)) y = lub(range(%i. iterate n (Y i) y))"
19.250 +apply (rule thelub_fun [THEN subst])
19.251 +apply (erule monofun_iterate [THEN ch2ch_monofun])
19.252 +apply (simp (no_asm_simp) add: contlub_iterate [THEN contlubE])
19.253 +done
19.254 +
19.255 +
19.256 +lemma ex_lub_iterate: "chain(Y) ==>
19.257 + lub(range(%i. lub(range(%ia. iterate i (Y ia) UU)))) =
19.258 + lub(range(%i. lub(range(%ia. iterate ia (Y i) UU))))"
19.259 +apply (rule antisym_less)
19.260 +apply (rule is_lub_thelub)
19.261 +apply (rule contlub_Ifix_lemma1 [THEN ext, THEN subst])
19.262 +apply assumption
19.263 +apply (rule chain_iterate)
19.264 +apply (rule ub_rangeI)
19.265 +apply (rule lub_mono)
19.266 +apply (erule monofun_iterate [THEN ch2ch_monofun, THEN ch2ch_fun])
19.267 +apply (erule chain_iterate_lub)
19.268 +apply (intro strip)
19.269 +apply (rule is_ub_thelub)
19.270 +apply (rule chain_iterate)
19.271 +apply (rule is_lub_thelub)
19.272 +apply (erule chain_iterate_lub)
19.273 +apply (rule ub_rangeI)
19.274 +apply (rule lub_mono)
19.275 +apply (rule chain_iterate)
19.276 +apply (rule contlub_Ifix_lemma1 [THEN ext, THEN subst])
19.277 +apply assumption
19.278 +apply (rule chain_iterate)
19.279 +apply (intro strip)
19.280 +apply (rule is_ub_thelub)
19.281 +apply (erule monofun_iterate [THEN ch2ch_monofun, THEN ch2ch_fun])
19.282 +done
19.283 +
19.284 +
19.285 +lemma contlub_Ifix: "contlub(Ifix)"
19.286 +
19.287 +apply (unfold contlub Ifix_def)
19.288 +apply (intro strip)
19.289 +apply (subst contlub_Ifix_lemma1 [THEN ext])
19.290 +apply assumption
19.291 +apply (erule ex_lub_iterate)
19.292 +done
19.293 +
19.294 +
19.295 +lemma cont_Ifix: "cont(Ifix)"
19.296 +apply (rule monocontlub2cont)
19.297 +apply (rule monofun_Ifix)
19.298 +apply (rule contlub_Ifix)
19.299 +done
19.300 +
19.301 +(* ------------------------------------------------------------------------ *)
19.302 +(* propagate properties of Ifix to its continuous counterpart *)
19.303 +(* ------------------------------------------------------------------------ *)
19.304 +
19.305 +lemma fix_eq: "fix$F = F$(fix$F)"
19.306 +
19.307 +apply (unfold fix_def)
19.308 +apply (simp (no_asm_simp) add: cont_Ifix)
19.309 +apply (rule Ifix_eq)
19.310 +done
19.311 +
19.312 +lemma fix_least: "F$x = x ==> fix$F << x"
19.313 +apply (unfold fix_def)
19.314 +apply (simp (no_asm_simp) add: cont_Ifix)
19.315 +apply (erule Ifix_least)
19.316 +done
19.317 +
19.318 +
19.319 +lemma fix_eqI:
19.320 +"[| F$x = x; !z. F$z = z --> x << z |] ==> x = fix$F"
19.321 +apply (rule antisym_less)
19.322 +apply (erule allE)
19.323 +apply (erule mp)
19.324 +apply (rule fix_eq [symmetric])
19.325 +apply (erule fix_least)
19.326 +done
19.327 +
19.328 +
19.329 +lemma fix_eq2: "f == fix$F ==> f = F$f"
19.330 +apply (simp (no_asm_simp) add: fix_eq [symmetric])
19.331 +done
19.332 +
19.333 +lemma fix_eq3: "f == fix$F ==> f$x = F$f$x"
19.334 +apply (erule fix_eq2 [THEN cfun_fun_cong])
19.335 +done
19.336 +
19.337 +(* fun fix_tac3 thm i = ((rtac trans i) THEN (rtac (thm RS fix_eq3) i)) *)
19.338 +
19.339 +lemma fix_eq4: "f = fix$F ==> f = F$f"
19.340 +apply (erule ssubst)
19.341 +apply (rule fix_eq)
19.342 +done
19.343 +
19.344 +lemma fix_eq5: "f = fix$F ==> f$x = F$f$x"
19.345 +apply (rule trans)
19.346 +apply (erule fix_eq4 [THEN cfun_fun_cong])
19.347 +apply (rule refl)
19.348 +done
19.349 +
19.350 +(* fun fix_tac5 thm i = ((rtac trans i) THEN (rtac (thm RS fix_eq5) i)) *)
19.351 +
19.352 +(* proves the unfolding theorem for function equations f = fix$... *)
19.353 +(*
19.354 +fun fix_prover thy fixeq s = prove_goal thy s (fn prems => [
19.355 + (rtac trans 1),
19.356 + (rtac (fixeq RS fix_eq4) 1),
19.357 + (rtac trans 1),
19.358 + (rtac beta_cfun 1),
19.359 + (Simp_tac 1)
19.360 + ])
19.361 +*)
19.362 +(* proves the unfolding theorem for function definitions f == fix$... *)
19.363 +(*
19.364 +fun fix_prover2 thy fixdef s = prove_goal thy s (fn prems => [
19.365 + (rtac trans 1),
19.366 + (rtac (fix_eq2) 1),
19.367 + (rtac fixdef 1),
19.368 + (rtac beta_cfun 1),
19.369 + (Simp_tac 1)
19.370 + ])
19.371 +*)
19.372 +(* proves an application case for a function from its unfolding thm *)
19.373 +(*
19.374 +fun case_prover thy unfold s = prove_goal thy s (fn prems => [
19.375 + (cut_facts_tac prems 1),
19.376 + (rtac trans 1),
19.377 + (stac unfold 1),
19.378 + Auto_tac
19.379 + ])
19.380 +*)
19.381 +(* ------------------------------------------------------------------------ *)
19.382 +(* better access to definitions *)
19.383 +(* ------------------------------------------------------------------------ *)
19.384 +
19.385 +
19.386 +lemma Ifix_def2: "Ifix=(%x. lub(range(%i. iterate i x UU)))"
19.387 +apply (rule ext)
19.388 +apply (unfold Ifix_def)
19.389 +apply (rule refl)
19.390 +done
19.391 +
19.392 +(* ------------------------------------------------------------------------ *)
19.393 +(* direct connection between fix and iteration without Ifix *)
19.394 +(* ------------------------------------------------------------------------ *)
19.395 +
19.396 +lemma fix_def2: "fix$F = lub(range(%i. iterate i F UU))"
19.397 +apply (unfold fix_def)
19.398 +apply (fold Ifix_def)
19.399 +apply (simp (no_asm_simp) add: cont_Ifix)
19.400 +done
19.401 +
19.402 +
19.403 +(* ------------------------------------------------------------------------ *)
19.404 +(* Lemmas about admissibility and fixed point induction *)
19.405 +(* ------------------------------------------------------------------------ *)
19.406 +
19.407 +(* ------------------------------------------------------------------------ *)
19.408 +(* access to definitions *)
19.409 +(* ------------------------------------------------------------------------ *)
19.410 +
19.411 +lemma admI:
19.412 + "(!!Y. [| chain Y; !i. P (Y i) |] ==> P (lub (range Y))) ==> adm P"
19.413 +apply (unfold adm_def)
19.414 +apply blast
19.415 +done
19.416 +
19.417 +lemma triv_admI: "!x. P x ==> adm P"
19.418 +apply (rule admI)
19.419 +apply (erule spec)
19.420 +done
19.421 +
19.422 +lemma admD: "[| adm(P); chain(Y); !i. P(Y(i)) |] ==> P(lub(range(Y)))"
19.423 +apply (unfold adm_def)
19.424 +apply blast
19.425 +done
19.426 +
19.427 +lemma admw_def2: "admw(P) = (!F.(!n. P(iterate n F UU)) -->
19.428 + P (lub(range(%i. iterate i F UU))))"
19.429 +apply (unfold admw_def)
19.430 +apply (rule refl)
19.431 +done
19.432 +
19.433 +(* ------------------------------------------------------------------------ *)
19.434 +(* an admissible formula is also weak admissible *)
19.435 +(* ------------------------------------------------------------------------ *)
19.436 +
19.437 +lemma adm_impl_admw: "adm(P)==>admw(P)"
19.438 +apply (unfold admw_def)
19.439 +apply (intro strip)
19.440 +apply (erule admD)
19.441 +apply (rule chain_iterate)
19.442 +apply assumption
19.443 +done
19.444 +
19.445 +(* ------------------------------------------------------------------------ *)
19.446 +(* fixed point induction *)
19.447 +(* ------------------------------------------------------------------------ *)
19.448 +
19.449 +lemma fix_ind:
19.450 + "[| adm(P); P(UU); !!x. P(x) ==> P(F$x)|] ==> P(fix$F)"
19.451 +apply (subst fix_def2)
19.452 +apply (erule admD)
19.453 +apply (rule chain_iterate)
19.454 +apply (rule allI)
19.455 +apply (induct_tac "i")
19.456 +apply simp
19.457 +apply simp
19.458 +done
19.459 +
19.460 +lemma def_fix_ind: "[| f == fix$F; adm(P);
19.461 + P(UU); !!x. P(x) ==> P(F$x)|] ==> P f"
19.462 +apply simp
19.463 +apply (erule fix_ind)
19.464 +apply assumption
19.465 +apply fast
19.466 +done
19.467 +
19.468 +(* ------------------------------------------------------------------------ *)
19.469 +(* computational induction for weak admissible formulae *)
19.470 +(* ------------------------------------------------------------------------ *)
19.471 +
19.472 +lemma wfix_ind: "[| admw(P); !n. P(iterate n F UU)|] ==> P(fix$F)"
19.473 +apply (subst fix_def2)
19.474 +apply (rule admw_def2 [THEN iffD1, THEN spec, THEN mp])
19.475 +apply assumption
19.476 +apply (rule allI)
19.477 +apply (erule spec)
19.478 +done
19.479 +
19.480 +lemma def_wfix_ind: "[| f == fix$F; admw(P);
19.481 + !n. P(iterate n F UU) |] ==> P f"
19.482 +apply simp
19.483 +apply (erule wfix_ind)
19.484 +apply assumption
19.485 +done
19.486 +
19.487 +(* ------------------------------------------------------------------------ *)
19.488 +(* for chain-finite (easy) types every formula is admissible *)
19.489 +(* ------------------------------------------------------------------------ *)
19.490 +
19.491 +lemma adm_max_in_chain:
19.492 +"!Y. chain(Y::nat=>'a) --> (? n. max_in_chain n Y) ==> adm(P::'a=>bool)"
19.493 +apply (unfold adm_def)
19.494 +apply (intro strip)
19.495 +apply (rule exE)
19.496 +apply (rule mp)
19.497 +apply (erule spec)
19.498 +apply assumption
19.499 +apply (subst lub_finch1 [THEN thelubI])
19.500 +apply assumption
19.501 +apply assumption
19.502 +apply (erule spec)
19.503 +done
19.504 +
19.505 +lemmas adm_chfin = chfin [THEN adm_max_in_chain, standard]
19.506 +
19.507 +(* ------------------------------------------------------------------------ *)
19.508 +(* some lemmata for functions with flat/chfin domain/range types *)
19.509 +(* ------------------------------------------------------------------------ *)
19.510 +
19.511 +lemma adm_chfindom: "adm (%(u::'a::cpo->'b::chfin). P(u$s))"
19.512 +apply (unfold adm_def)
19.513 +apply (intro strip)
19.514 +apply (drule chfin_Rep_CFunR)
19.515 +apply (erule_tac x = "s" in allE)
19.516 +apply clarsimp
19.517 +done
19.518 +
19.519 +(* adm_flat not needed any more, since it is a special case of adm_chfindom *)
19.520 +
19.521 +(* ------------------------------------------------------------------------ *)
19.522 +(* improved admisibility introduction *)
19.523 +(* ------------------------------------------------------------------------ *)
19.524 +
19.525 +lemma admI2:
19.526 + "(!!Y. [| chain Y; !i. P (Y i); !i. ? j. i < j & Y i ~= Y j & Y i << Y j |]
19.527 + ==> P(lub (range Y))) ==> adm P"
19.528 +apply (unfold adm_def)
19.529 +apply (intro strip)
19.530 +apply (erule increasing_chain_adm_lemma)
19.531 +apply assumption
19.532 +apply fast
19.533 +done
19.534 +
19.535 +
19.536 +(* ------------------------------------------------------------------------ *)
19.537 +(* admissibility of special formulae and propagation *)
19.538 +(* ------------------------------------------------------------------------ *)
19.539 +
19.540 +lemma adm_less: "[|cont u;cont v|]==> adm(%x. u x << v x)"
19.541 +apply (unfold adm_def)
19.542 +apply (intro strip)
19.543 +apply (frule_tac f = "u" in cont2mono [THEN ch2ch_monofun])
19.544 +apply assumption
19.545 +apply (frule_tac f = "v" in cont2mono [THEN ch2ch_monofun])
19.546 +apply assumption
19.547 +apply (erule cont2contlub [THEN contlubE, THEN spec, THEN mp, THEN ssubst])
19.548 +apply assumption
19.549 +apply (erule cont2contlub [THEN contlubE, THEN spec, THEN mp, THEN ssubst])
19.550 +apply assumption
19.551 +apply (blast intro: lub_mono)
19.552 +done
19.553 +declare adm_less [simp]
19.554 +
19.555 +lemma adm_conj: "[| adm P; adm Q |] ==> adm(%x. P x & Q x)"
19.556 +apply (fast elim: admD intro: admI)
19.557 +done
19.558 +declare adm_conj [simp]
19.559 +
19.560 +lemma adm_not_free: "adm(%x. t)"
19.561 +apply (unfold adm_def)
19.562 +apply fast
19.563 +done
19.564 +declare adm_not_free [simp]
19.565 +
19.566 +lemma adm_not_less: "cont t ==> adm(%x.~ (t x) << u)"
19.567 +apply (unfold adm_def)
19.568 +apply (intro strip)
19.569 +apply (rule contrapos_nn)
19.570 +apply (erule spec)
19.571 +apply (rule trans_less)
19.572 +prefer 2 apply (assumption)
19.573 +apply (erule cont2mono [THEN monofun_fun_arg])
19.574 +apply (rule is_ub_thelub)
19.575 +apply assumption
19.576 +done
19.577 +
19.578 +lemma adm_all: "!y. adm(P y) ==> adm(%x.!y. P y x)"
19.579 +apply (fast intro: admI elim: admD)
19.580 +done
19.581 +
19.582 +lemmas adm_all2 = allI [THEN adm_all, standard]
19.583 +
19.584 +lemma adm_subst: "[|cont t; adm P|] ==> adm(%x. P (t x))"
19.585 +apply (rule admI)
19.586 +apply (simplesubst cont2contlub [THEN contlubE, THEN spec, THEN mp])
19.587 +apply assumption
19.588 +apply assumption
19.589 +apply (erule admD)
19.590 +apply (erule cont2mono [THEN ch2ch_monofun])
19.591 +apply assumption
19.592 +apply assumption
19.593 +done
19.594 +
19.595 +lemma adm_UU_not_less: "adm(%x.~ UU << t(x))"
19.596 +apply (simp (no_asm))
19.597 +done
19.598 +
19.599 +
19.600 +lemma adm_not_UU: "cont(t)==> adm(%x.~ (t x) = UU)"
19.601 +
19.602 +apply (unfold adm_def)
19.603 +apply (intro strip)
19.604 +apply (rule contrapos_nn)
19.605 +apply (erule spec)
19.606 +apply (rule chain_UU_I [THEN spec])
19.607 +apply (erule cont2mono [THEN ch2ch_monofun])
19.608 +apply assumption
19.609 +apply (erule cont2contlub [THEN contlubE, THEN spec, THEN mp, THEN subst])
19.610 +apply assumption
19.611 +apply assumption
19.612 +done
19.613 +
19.614 +lemma adm_eq: "[|cont u ; cont v|]==> adm(%x. u x = v x)"
19.615 +apply (simp (no_asm_simp) add: po_eq_conv)
19.616 +done
19.617 +
19.618 +
19.619 +
19.620 +(* ------------------------------------------------------------------------ *)
19.621 +(* admissibility for disjunction is hard to prove. It takes 10 Lemmas *)
19.622 +(* ------------------------------------------------------------------------ *)
19.623 +
19.624 +
19.625 +lemma adm_disj_lemma1: "!n. P(Y n)|Q(Y n) ==> (? i.!j. R i j --> Q(Y(j))) | (!i.? j. R i j & P(Y(j)))"
19.626 +apply fast
19.627 +done
19.628 +
19.629 +lemma adm_disj_lemma2: "[| adm(Q); ? X. chain(X) & (!n. Q(X(n))) &
19.630 + lub(range(Y))=lub(range(X))|] ==> Q(lub(range(Y)))"
19.631 +apply (force elim: admD)
19.632 +done
19.633 +
19.634 +lemma adm_disj_lemma3: "chain Y ==> chain (%m. if m < Suc i then Y (Suc i) else Y m)"
19.635 +apply (unfold chain_def)
19.636 +apply (simp (no_asm_simp))
19.637 +apply safe
19.638 +apply (subgoal_tac "ia = i")
19.639 +apply (simp_all (no_asm_simp))
19.640 +done
19.641 +
19.642 +lemma adm_disj_lemma4: "!j. i < j --> Q(Y(j)) ==> !n. Q( if n < Suc i then Y(Suc i) else Y n)"
19.643 +apply (simp (no_asm_simp))
19.644 +done
19.645 +
19.646 +lemma adm_disj_lemma5:
19.647 + "!!Y::nat=>'a::cpo. [| chain(Y); ! j. i < j --> Q(Y(j)) |] ==>
19.648 + lub(range(Y)) = lub(range(%m. if m< Suc(i) then Y(Suc(i)) else Y m))"
19.649 +apply (safe intro!: lub_equal2 adm_disj_lemma3)
19.650 +prefer 2 apply (assumption)
19.651 +apply (rule_tac x = "i" in exI)
19.652 +apply (simp (no_asm_simp))
19.653 +done
19.654 +
19.655 +lemma adm_disj_lemma6:
19.656 + "[| chain(Y::nat=>'a::cpo); ? i. ! j. i < j --> Q(Y(j)) |] ==>
19.657 + ? X. chain(X) & (! n. Q(X(n))) & lub(range(Y)) = lub(range(X))"
19.658 +apply (erule exE)
19.659 +apply (rule_tac x = "%m. if m<Suc (i) then Y (Suc (i)) else Y m" in exI)
19.660 +apply (rule conjI)
19.661 +apply (rule adm_disj_lemma3)
19.662 +apply assumption
19.663 +apply (rule conjI)
19.664 +apply (rule adm_disj_lemma4)
19.665 +apply assumption
19.666 +apply (rule adm_disj_lemma5)
19.667 +apply assumption
19.668 +apply assumption
19.669 +done
19.670 +
19.671 +lemma adm_disj_lemma7:
19.672 + "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>
19.673 + chain(%m. Y(Least(%j. m<j & P(Y(j)))))"
19.674 +apply (rule chainI)
19.675 +apply (rule chain_mono3)
19.676 +apply assumption
19.677 +apply (rule Least_le)
19.678 +apply (rule conjI)
19.679 +apply (rule Suc_lessD)
19.680 +apply (erule allE)
19.681 +apply (erule exE)
19.682 +apply (rule LeastI [THEN conjunct1])
19.683 +apply assumption
19.684 +apply (erule allE)
19.685 +apply (erule exE)
19.686 +apply (rule LeastI [THEN conjunct2])
19.687 +apply assumption
19.688 +done
19.689 +
19.690 +lemma adm_disj_lemma8:
19.691 + "[| ! i. ? j. i < j & P(Y(j)) |] ==> ! m. P(Y(LEAST j::nat. m<j & P(Y(j))))"
19.692 +apply (intro strip)
19.693 +apply (erule allE)
19.694 +apply (erule exE)
19.695 +apply (erule LeastI [THEN conjunct2])
19.696 +done
19.697 +
19.698 +lemma adm_disj_lemma9:
19.699 + "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>
19.700 + lub(range(Y)) = lub(range(%m. Y(Least(%j. m<j & P(Y(j))))))"
19.701 +apply (rule antisym_less)
19.702 +apply (rule lub_mono)
19.703 +apply assumption
19.704 +apply (rule adm_disj_lemma7)
19.705 +apply assumption
19.706 +apply assumption
19.707 +apply (intro strip)
19.708 +apply (rule chain_mono)
19.709 +apply assumption
19.710 +apply (erule allE)
19.711 +apply (erule exE)
19.712 +apply (rule LeastI [THEN conjunct1])
19.713 +apply assumption
19.714 +apply (rule lub_mono3)
19.715 +apply (rule adm_disj_lemma7)
19.716 +apply assumption
19.717 +apply assumption
19.718 +apply assumption
19.719 +apply (intro strip)
19.720 +apply (rule exI)
19.721 +apply (rule chain_mono)
19.722 +apply assumption
19.723 +apply (rule lessI)
19.724 +done
19.725 +
19.726 +lemma adm_disj_lemma10: "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>
19.727 + ? X. chain(X) & (! n. P(X(n))) & lub(range(Y)) = lub(range(X))"
19.728 +apply (rule_tac x = "%m. Y (Least (%j. m<j & P (Y (j))))" in exI)
19.729 +apply (rule conjI)
19.730 +apply (rule adm_disj_lemma7)
19.731 +apply assumption
19.732 +apply assumption
19.733 +apply (rule conjI)
19.734 +apply (rule adm_disj_lemma8)
19.735 +apply assumption
19.736 +apply (rule adm_disj_lemma9)
19.737 +apply assumption
19.738 +apply assumption
19.739 +done
19.740 +
19.741 +lemma adm_disj_lemma12: "[| adm(P); chain(Y);? i. ! j. i < j --> P(Y(j))|]==>P(lub(range(Y)))"
19.742 +apply (erule adm_disj_lemma2)
19.743 +apply (erule adm_disj_lemma6)
19.744 +apply assumption
19.745 +done
19.746 +
19.747 +
19.748 +lemma adm_lemma11:
19.749 +"[| adm(P); chain(Y); ! i. ? j. i < j & P(Y(j)) |]==>P(lub(range(Y)))"
19.750 +apply (erule adm_disj_lemma2)
19.751 +apply (erule adm_disj_lemma10)
19.752 +apply assumption
19.753 +done
19.754 +
19.755 +lemma adm_disj: "[| adm P; adm Q |] ==> adm(%x. P x | Q x)"
19.756 +apply (rule admI)
19.757 +apply (rule adm_disj_lemma1 [THEN disjE])
19.758 +apply assumption
19.759 +apply (rule disjI2)
19.760 +apply (erule adm_disj_lemma12)
19.761 +apply assumption
19.762 +apply assumption
19.763 +apply (rule disjI1)
19.764 +apply (erule adm_lemma11)
19.765 +apply assumption
19.766 +apply assumption
19.767 +done
19.768 +
19.769 +lemma adm_imp: "[| adm(%x.~(P x)); adm Q |] ==> adm(%x. P x --> Q x)"
19.770 +apply (subgoal_tac " (%x. P x --> Q x) = (%x. ~P x | Q x) ")
19.771 +apply (erule ssubst)
19.772 +apply (erule adm_disj)
19.773 +apply assumption
19.774 +apply (simp (no_asm))
19.775 +done
19.776 +
19.777 +lemma adm_iff: "[| adm (%x. P x --> Q x); adm (%x. Q x --> P x) |]
19.778 + ==> adm (%x. P x = Q x)"
19.779 +apply (subgoal_tac " (%x. P x = Q x) = (%x. (P x --> Q x) & (Q x --> P x))")
19.780 +apply (simp (no_asm_simp))
19.781 +apply (rule ext)
19.782 +apply fast
19.783 +done
19.784 +
19.785 +
19.786 +lemma adm_not_conj: "[| adm (%x. ~ P x); adm (%x. ~ Q x) |] ==> adm (%x. ~ (P x & Q x))"
19.787 +apply (subgoal_tac " (%x. ~ (P x & Q x)) = (%x. ~ P x | ~ Q x) ")
19.788 +apply (rule_tac [2] ext)
19.789 +prefer 2 apply fast
19.790 +apply (erule ssubst)
19.791 +apply (erule adm_disj)
19.792 +apply assumption
19.793 +done
19.794 +
19.795 +lemmas adm_lemmas = adm_not_free adm_imp adm_disj adm_eq adm_not_UU
19.796 + adm_UU_not_less adm_all2 adm_not_less adm_not_conj adm_iff
19.797 +
19.798 +declare adm_lemmas [simp]
19.799 +
19.800 end
19.801
20.1 --- a/src/HOLCF/Fun1.ML Fri Mar 04 18:53:46 2005 +0100
20.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
20.3 @@ -1,7 +0,0 @@
20.4 -
20.5 -(* legacy ML bindings *)
20.6 -
20.7 -val less_fun_def = thm "less_fun_def";
20.8 -val refl_less_fun = thm "refl_less_fun";
20.9 -val antisym_less_fun = thm "antisym_less_fun";
20.10 -val trans_less_fun = thm "trans_less_fun";
21.1 --- a/src/HOLCF/Fun1.thy Fri Mar 04 18:53:46 2005 +0100
21.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
21.3 @@ -1,65 +0,0 @@
21.4 -(* Title: HOLCF/Fun1.thy
21.5 - ID: $Id$
21.6 - Author: Franz Regensburger
21.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
21.8 -
21.9 -Definition of the partial ordering for the type of all functions => (fun)
21.10 -
21.11 -REMARK: The ordering on 'a => 'b is only defined if 'b is in class po !!
21.12 -*)
21.13 -
21.14 -theory Fun1 = Pcpo:
21.15 -
21.16 -instance flat<chfin
21.17 -apply (intro_classes)
21.18 -apply (rule flat_imp_chfin)
21.19 -done
21.20 -
21.21 -(* to make << defineable: *)
21.22 -
21.23 -instance fun :: (type, sq_ord) sq_ord ..
21.24 -
21.25 -defs (overloaded)
21.26 - less_fun_def: "(op <<) == (%f1 f2.!x. f1 x << f2 x)"
21.27 -
21.28 -(* Title: HOLCF/Fun1.ML
21.29 - ID: $Id$
21.30 - Author: Franz Regensburger
21.31 - License: GPL (GNU GENERAL PUBLIC LICENSE)
21.32 -
21.33 -Definition of the partial ordering for the type of all functions => (fun)
21.34 -*)
21.35 -
21.36 -(* ------------------------------------------------------------------------ *)
21.37 -(* less_fun is a partial order on 'a => 'b *)
21.38 -(* ------------------------------------------------------------------------ *)
21.39 -
21.40 -lemma refl_less_fun: "(f::'a::type =>'b::po) << f"
21.41 -apply (unfold less_fun_def)
21.42 -apply (fast intro!: refl_less)
21.43 -done
21.44 -
21.45 -lemma antisym_less_fun:
21.46 - "[|(f1::'a::type =>'b::po) << f2; f2 << f1|] ==> f1 = f2"
21.47 -apply (unfold less_fun_def)
21.48 -(* apply (cut_tac prems) *)
21.49 -apply (subst expand_fun_eq)
21.50 -apply (fast intro!: antisym_less)
21.51 -done
21.52 -
21.53 -lemma trans_less_fun:
21.54 - "[|(f1::'a::type =>'b::po) << f2; f2 << f3 |] ==> f1 << f3"
21.55 -apply (unfold less_fun_def)
21.56 -(* apply (cut_tac prems) *)
21.57 -apply clarify
21.58 -apply (rule trans_less)
21.59 -apply (erule allE)
21.60 -apply assumption
21.61 -apply (erule allE, assumption)
21.62 -done
21.63 -
21.64 -end
21.65 -
21.66 -
21.67 -
21.68 -
22.1 --- a/src/HOLCF/Fun2.ML Fri Mar 04 18:53:46 2005 +0100
22.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
22.3 @@ -1,13 +0,0 @@
22.4 -
22.5 -(* legacy ML bindings *)
22.6 -
22.7 -val inst_fun_po = thm "inst_fun_po";
22.8 -val minimal_fun = thm "minimal_fun";
22.9 -val UU_fun_def = thm "UU_fun_def";
22.10 -val least_fun = thm "least_fun";
22.11 -val less_fun = thm "less_fun";
22.12 -val ch2ch_fun = thm "ch2ch_fun";
22.13 -val ub2ub_fun = thm "ub2ub_fun";
22.14 -val lub_fun = thm "lub_fun";
22.15 -val thelub_fun = thm "thelub_fun";
22.16 -val cpo_fun = thm "cpo_fun";
23.1 --- a/src/HOLCF/Fun2.thy Fri Mar 04 18:53:46 2005 +0100
23.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
23.3 @@ -1,111 +0,0 @@
23.4 -(* Title: HOLCF/Fun2.thy
23.5 - ID: $Id$
23.6 - Author: Franz Regensburger
23.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
23.8 -*)
23.9 -
23.10 -theory Fun2 = Fun1:
23.11 -
23.12 -(* default class is still type!*)
23.13 -
23.14 -instance fun :: (type, po) po
23.15 -apply (intro_classes)
23.16 -apply (rule refl_less_fun)
23.17 -apply (rule antisym_less_fun, assumption+)
23.18 -apply (rule trans_less_fun, assumption+)
23.19 -done
23.20 -
23.21 -(* Title: HOLCF/Fun2.ML
23.22 - ID: $Id$
23.23 - Author: Franz Regensburger
23.24 - License: GPL (GNU GENERAL PUBLIC LICENSE)
23.25 -*)
23.26 -
23.27 -(* for compatibility with old HOLCF-Version *)
23.28 -lemma inst_fun_po: "(op <<)=(%f g.!x. f x << g x)"
23.29 -apply (fold less_fun_def)
23.30 -apply (rule refl)
23.31 -done
23.32 -
23.33 -(* ------------------------------------------------------------------------ *)
23.34 -(* Type 'a::type => 'b::pcpo is pointed *)
23.35 -(* ------------------------------------------------------------------------ *)
23.36 -
23.37 -lemma minimal_fun: "(%z. UU) << x"
23.38 -apply (simp (no_asm) add: inst_fun_po minimal)
23.39 -done
23.40 -
23.41 -lemmas UU_fun_def = minimal_fun [THEN minimal2UU, symmetric, standard]
23.42 -
23.43 -lemma least_fun: "? x::'a=>'b::pcpo.!y. x<<y"
23.44 -apply (rule_tac x = " (%z. UU) " in exI)
23.45 -apply (rule minimal_fun [THEN allI])
23.46 -done
23.47 -
23.48 -(* ------------------------------------------------------------------------ *)
23.49 -(* make the symbol << accessible for type fun *)
23.50 -(* ------------------------------------------------------------------------ *)
23.51 -
23.52 -lemma less_fun: "(f1 << f2) = (! x. f1(x) << f2(x))"
23.53 -apply (subst inst_fun_po)
23.54 -apply (rule refl)
23.55 -done
23.56 -
23.57 -(* ------------------------------------------------------------------------ *)
23.58 -(* chains of functions yield chains in the po range *)
23.59 -(* ------------------------------------------------------------------------ *)
23.60 -
23.61 -lemma ch2ch_fun: "chain (S::nat=>('a=>'b::po)) ==> chain (%i. S i x)"
23.62 -
23.63 -apply (unfold chain_def)
23.64 -apply (simp add: less_fun)
23.65 -done
23.66 -
23.67 -(* ------------------------------------------------------------------------ *)
23.68 -(* upper bounds of function chains yield upper bound in the po range *)
23.69 -(* ------------------------------------------------------------------------ *)
23.70 -
23.71 -lemma ub2ub_fun: "range(S::nat=>('a::type => 'b::po)) <| u ==> range(%i. S i x) <| u(x)"
23.72 -apply (rule ub_rangeI)
23.73 -apply (drule ub_rangeD)
23.74 -apply (simp add: less_fun)
23.75 -apply auto
23.76 -done
23.77 -
23.78 -(* ------------------------------------------------------------------------ *)
23.79 -(* Type 'a::type => 'b::pcpo is chain complete *)
23.80 -(* ------------------------------------------------------------------------ *)
23.81 -
23.82 -lemma lub_fun: "chain(S::nat=>('a::type => 'b::cpo)) ==>
23.83 - range(S) <<| (% x. lub(range(% i. S(i)(x))))"
23.84 -apply (rule is_lubI)
23.85 -apply (rule ub_rangeI)
23.86 -apply (subst less_fun)
23.87 -apply (rule allI)
23.88 -apply (rule is_ub_thelub)
23.89 -apply (erule ch2ch_fun)
23.90 -(* apply (intro strip) *)
23.91 -apply (subst less_fun)
23.92 -apply (rule allI)
23.93 -apply (rule is_lub_thelub)
23.94 -apply (erule ch2ch_fun)
23.95 -apply (erule ub2ub_fun)
23.96 -done
23.97 -
23.98 -lemmas thelub_fun = lub_fun [THEN thelubI, standard]
23.99 -(* chain ?S1 ==> lub (range ?S1) = (%x. lub (range (%i. ?S1 i x))) *)
23.100 -
23.101 -lemma cpo_fun: "chain(S::nat=>('a::type => 'b::cpo)) ==> ? x. range(S) <<| x"
23.102 -apply (rule exI)
23.103 -apply (erule lub_fun)
23.104 -done
23.105 -
23.106 -end
23.107 -
23.108 -
23.109 -
23.110 -
23.111 -
23.112 -
23.113 -
23.114 -
24.1 --- a/src/HOLCF/Fun3.ML Fri Mar 04 18:53:46 2005 +0100
24.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
24.3 @@ -1,4 +0,0 @@
24.4 -
24.5 -(* legacy ML bindings *)
24.6 -
24.7 -val inst_fun_pcpo = thm "inst_fun_pcpo";
25.1 --- a/src/HOLCF/Fun3.thy Fri Mar 04 18:53:46 2005 +0100
25.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
25.3 @@ -1,35 +0,0 @@
25.4 -(* Title: HOLCF/Fun3.thy
25.5 - ID: $Id$
25.6 - Author: Franz Regensburger
25.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
25.8 -
25.9 -Class instance of => (fun) for class pcpo
25.10 -*)
25.11 -
25.12 -theory Fun3 = Fun2:
25.13 -
25.14 -(* default class is still type *)
25.15 -
25.16 -instance fun :: (type, cpo) cpo
25.17 -apply (intro_classes)
25.18 -apply (erule cpo_fun)
25.19 -done
25.20 -
25.21 -instance fun :: (type, pcpo)pcpo
25.22 -apply (intro_classes)
25.23 -apply (rule least_fun)
25.24 -done
25.25 -
25.26 -(* Title: HOLCF/Fun3.ML
25.27 - ID: $Id$
25.28 - Author: Franz Regensburger
25.29 - License: GPL (GNU GENERAL PUBLIC LICENSE)
25.30 -*)
25.31 -
25.32 -(* for compatibility with old HOLCF-Version *)
25.33 -lemma inst_fun_pcpo: "UU = (%x. UU)"
25.34 -apply (simp add: UU_def UU_fun_def)
25.35 -done
25.36 -
25.37 -end
25.38 -
26.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
26.2 +++ b/src/HOLCF/FunCpo.ML Fri Mar 04 23:12:36 2005 +0100
26.3 @@ -0,0 +1,18 @@
26.4 +
26.5 +(* legacy ML bindings *)
26.6 +
26.7 +val less_fun_def = thm "less_fun_def";
26.8 +val refl_less_fun = thm "refl_less_fun";
26.9 +val antisym_less_fun = thm "antisym_less_fun";
26.10 +val trans_less_fun = thm "trans_less_fun";
26.11 +val inst_fun_po = thm "inst_fun_po";
26.12 +val minimal_fun = thm "minimal_fun";
26.13 +val UU_fun_def = thm "UU_fun_def";
26.14 +val least_fun = thm "least_fun";
26.15 +val less_fun = thm "less_fun";
26.16 +val ch2ch_fun = thm "ch2ch_fun";
26.17 +val ub2ub_fun = thm "ub2ub_fun";
26.18 +val lub_fun = thm "lub_fun";
26.19 +val thelub_fun = thm "thelub_fun";
26.20 +val cpo_fun = thm "cpo_fun";
26.21 +val inst_fun_pcpo = thm "inst_fun_pcpo";
27.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
27.2 +++ b/src/HOLCF/FunCpo.thy Fri Mar 04 23:12:36 2005 +0100
27.3 @@ -0,0 +1,157 @@
27.4 +(* Title: HOLCF/Fun1.thy
27.5 + ID: $Id$
27.6 + Author: Franz Regensburger
27.7 + License: GPL (GNU GENERAL PUBLIC LICENSE)
27.8 +
27.9 +Definition of the partial ordering for the type of all functions => (fun)
27.10 +
27.11 +REMARK: The ordering on 'a => 'b is only defined if 'b is in class po !!
27.12 +
27.13 +Class instance of => (fun) for class pcpo
27.14 +*)
27.15 +
27.16 +header {* Class instances for the type of all functions *}
27.17 +
27.18 +theory FunCpo = Pcpo:
27.19 +
27.20 +(* to make << defineable: *)
27.21 +
27.22 +instance fun :: (type, sq_ord) sq_ord ..
27.23 +
27.24 +defs (overloaded)
27.25 + less_fun_def: "(op <<) == (%f1 f2.!x. f1 x << f2 x)"
27.26 +
27.27 +(* ------------------------------------------------------------------------ *)
27.28 +(* less_fun is a partial order on 'a => 'b *)
27.29 +(* ------------------------------------------------------------------------ *)
27.30 +
27.31 +lemma refl_less_fun: "(f::'a::type =>'b::po) << f"
27.32 +apply (unfold less_fun_def)
27.33 +apply (fast intro!: refl_less)
27.34 +done
27.35 +
27.36 +lemma antisym_less_fun:
27.37 + "[|(f1::'a::type =>'b::po) << f2; f2 << f1|] ==> f1 = f2"
27.38 +apply (unfold less_fun_def)
27.39 +(* apply (cut_tac prems) *)
27.40 +apply (subst expand_fun_eq)
27.41 +apply (fast intro!: antisym_less)
27.42 +done
27.43 +
27.44 +lemma trans_less_fun:
27.45 + "[|(f1::'a::type =>'b::po) << f2; f2 << f3 |] ==> f1 << f3"
27.46 +apply (unfold less_fun_def)
27.47 +(* apply (cut_tac prems) *)
27.48 +apply clarify
27.49 +apply (rule trans_less)
27.50 +apply (erule allE)
27.51 +apply assumption
27.52 +apply (erule allE, assumption)
27.53 +done
27.54 +
27.55 +(* default class is still type!*)
27.56 +
27.57 +instance fun :: (type, po) po
27.58 +apply (intro_classes)
27.59 +apply (rule refl_less_fun)
27.60 +apply (rule antisym_less_fun, assumption+)
27.61 +apply (rule trans_less_fun, assumption+)
27.62 +done
27.63 +
27.64 +(* for compatibility with old HOLCF-Version *)
27.65 +lemma inst_fun_po: "(op <<)=(%f g.!x. f x << g x)"
27.66 +apply (fold less_fun_def)
27.67 +apply (rule refl)
27.68 +done
27.69 +
27.70 +(* ------------------------------------------------------------------------ *)
27.71 +(* Type 'a::type => 'b::pcpo is pointed *)
27.72 +(* ------------------------------------------------------------------------ *)
27.73 +
27.74 +lemma minimal_fun: "(%z. UU) << x"
27.75 +apply (simp (no_asm) add: inst_fun_po minimal)
27.76 +done
27.77 +
27.78 +lemmas UU_fun_def = minimal_fun [THEN minimal2UU, symmetric, standard]
27.79 +
27.80 +lemma least_fun: "? x::'a=>'b::pcpo.!y. x<<y"
27.81 +apply (rule_tac x = " (%z. UU) " in exI)
27.82 +apply (rule minimal_fun [THEN allI])
27.83 +done
27.84 +
27.85 +(* ------------------------------------------------------------------------ *)
27.86 +(* make the symbol << accessible for type fun *)
27.87 +(* ------------------------------------------------------------------------ *)
27.88 +
27.89 +lemma less_fun: "(f1 << f2) = (! x. f1(x) << f2(x))"
27.90 +apply (subst inst_fun_po)
27.91 +apply (rule refl)
27.92 +done
27.93 +
27.94 +(* ------------------------------------------------------------------------ *)
27.95 +(* chains of functions yield chains in the po range *)
27.96 +(* ------------------------------------------------------------------------ *)
27.97 +
27.98 +lemma ch2ch_fun: "chain (S::nat=>('a=>'b::po)) ==> chain (%i. S i x)"
27.99 +apply (unfold chain_def)
27.100 +apply (simp add: less_fun)
27.101 +done
27.102 +
27.103 +(* ------------------------------------------------------------------------ *)
27.104 +(* upper bounds of function chains yield upper bound in the po range *)
27.105 +(* ------------------------------------------------------------------------ *)
27.106 +
27.107 +lemma ub2ub_fun: "range(S::nat=>('a::type => 'b::po)) <| u ==> range(%i. S i x) <| u(x)"
27.108 +apply (rule ub_rangeI)
27.109 +apply (drule ub_rangeD)
27.110 +apply (simp add: less_fun)
27.111 +apply auto
27.112 +done
27.113 +
27.114 +(* ------------------------------------------------------------------------ *)
27.115 +(* Type 'a::type => 'b::pcpo is chain complete *)
27.116 +(* ------------------------------------------------------------------------ *)
27.117 +
27.118 +lemma lub_fun: "chain(S::nat=>('a::type => 'b::cpo)) ==>
27.119 + range(S) <<| (% x. lub(range(% i. S(i)(x))))"
27.120 +apply (rule is_lubI)
27.121 +apply (rule ub_rangeI)
27.122 +apply (subst less_fun)
27.123 +apply (rule allI)
27.124 +apply (rule is_ub_thelub)
27.125 +apply (erule ch2ch_fun)
27.126 +(* apply (intro strip) *)
27.127 +apply (subst less_fun)
27.128 +apply (rule allI)
27.129 +apply (rule is_lub_thelub)
27.130 +apply (erule ch2ch_fun)
27.131 +apply (erule ub2ub_fun)
27.132 +done
27.133 +
27.134 +lemmas thelub_fun = lub_fun [THEN thelubI, standard]
27.135 +(* chain ?S1 ==> lub (range ?S1) = (%x. lub (range (%i. ?S1 i x))) *)
27.136 +
27.137 +lemma cpo_fun: "chain(S::nat=>('a::type => 'b::cpo)) ==> ? x. range(S) <<| x"
27.138 +apply (rule exI)
27.139 +apply (erule lub_fun)
27.140 +done
27.141 +
27.142 +(* default class is still type *)
27.143 +
27.144 +instance fun :: (type, cpo) cpo
27.145 +apply (intro_classes)
27.146 +apply (erule cpo_fun)
27.147 +done
27.148 +
27.149 +instance fun :: (type, pcpo)pcpo
27.150 +apply (intro_classes)
27.151 +apply (rule least_fun)
27.152 +done
27.153 +
27.154 +(* for compatibility with old HOLCF-Version *)
27.155 +lemma inst_fun_pcpo: "UU = (%x. UU)"
27.156 +apply (simp add: UU_def UU_fun_def)
27.157 +done
27.158 +
27.159 +end
27.160 +
28.1 --- a/src/HOLCF/HOLCF.thy Fri Mar 04 18:53:46 2005 +0100
28.2 +++ b/src/HOLCF/HOLCF.thy Fri Mar 04 23:12:36 2005 +0100
28.3 @@ -5,4 +5,4 @@
28.4 Top theory for HOLCF system.
28.5 *)
28.6
28.7 -HOLCF = Sprod3 + Ssum3 + Up3 + Lift + Discrete + One + Tr
28.8 +HOLCF = Sprod + Ssum + Up + Lift + Discrete + One + Tr
29.1 --- a/src/HOLCF/IsaMakefile Fri Mar 04 18:53:46 2005 +0100
29.2 +++ b/src/HOLCF/IsaMakefile Fri Mar 04 23:12:36 2005 +0100
29.3 @@ -27,15 +27,15 @@
29.4 HOL:
29.5 @cd $(SRC)/HOL; $(ISATOOL) make HOL
29.6
29.7 -$(OUT)/HOLCF: $(OUT)/HOL Cfun1.ML Cfun1.thy Cfun2.ML Cfun2.thy \
29.8 - Cfun3.ML Cfun3.thy Cont.ML Cont.thy Cprod1.ML Cprod1.thy Cprod2.ML \
29.9 - Cprod2.thy Cprod3.ML Cprod3.thy Discrete.thy Fix.ML Fix.thy Fun1.ML \
29.10 - Fun1.thy Fun2.ML Fun2.thy Fun3.ML Fun3.thy HOLCF.ML HOLCF.thy Lift.ML \
29.11 - Lift.thy One.ML One.thy Pcpo.ML Pcpo.thy Porder.ML Porder.thy Porder0.ML \
29.12 - Porder0.thy ROOT.ML Sprod0.ML Sprod0.thy Sprod1.ML Sprod1.thy \
29.13 - Sprod2.ML Sprod2.thy Sprod3.ML Sprod3.thy Ssum0.ML Ssum0.thy Ssum1.ML \
29.14 - Ssum1.thy Ssum2.ML Ssum2.thy Ssum3.ML Ssum3.thy Tr.ML Tr.thy Up1.ML \
29.15 - Up1.thy Up2.ML Up2.thy Up3.ML Up3.thy adm.ML cont_consts.ML \
29.16 +$(OUT)/HOLCF: $(OUT)/HOL Cfun.ML Cfun.thy \
29.17 + Cont.ML Cont.thy Cprod.ML Cprod.thy \
29.18 + Discrete.thy Fix.ML Fix.thy FunCpo.ML \
29.19 + FunCpo.thy HOLCF.ML HOLCF.thy Lift.ML \
29.20 + Lift.thy One.ML One.thy Pcpo.ML Pcpo.thy Porder.ML Porder.thy \
29.21 + ROOT.ML Sprod.ML Sprod.thy \
29.22 + Ssum.ML Ssum.thy \
29.23 + Tr.ML Tr.thy Up.ML \
29.24 + Up.thy adm.ML cont_consts.ML \
29.25 domain/axioms.ML domain/extender.ML domain/interface.ML \
29.26 domain/library.ML domain/syntax.ML domain/theorems.ML holcf_logic.ML \
29.27 ex/Stream.thy
30.1 --- a/src/HOLCF/Lift.thy Fri Mar 04 18:53:46 2005 +0100
30.2 +++ b/src/HOLCF/Lift.thy Fri Mar 04 23:12:36 2005 +0100
30.3 @@ -5,7 +5,7 @@
30.4
30.5 header {* Lifting types of class type to flat pcpo's *}
30.6
30.7 -theory Lift = Cprod3:
30.8 +theory Lift = Cprod:
30.9
30.10 defaultsort type
30.11
31.1 --- a/src/HOLCF/One.ML Fri Mar 04 18:53:46 2005 +0100
31.2 +++ b/src/HOLCF/One.ML Fri Mar 04 23:12:36 2005 +0100
31.3 @@ -1,42 +1,7 @@
31.4 -(* Title: HOLCF/One.ML
31.5 - ID: $Id$
31.6 - Author: Oscar Slotosch
31.7
31.8 -The unit domain.
31.9 -*)
31.10 +(* legacy ML bindings *)
31.11
31.12 -(* ------------------------------------------------------------------------ *)
31.13 -(* Exhaustion and Elimination for type one *)
31.14 -(* ------------------------------------------------------------------------ *)
31.15 -
31.16 -Goalw [ONE_def] "t=UU | t = ONE";
31.17 -by (induct_tac "t" 1);
31.18 -by (Simp_tac 1);
31.19 -by (Simp_tac 1);
31.20 -qed "Exh_one";
31.21 -
31.22 -val prems = Goal "[| p=UU ==> Q; p = ONE ==>Q|] ==>Q";
31.23 -by (rtac (Exh_one RS disjE) 1);
31.24 -by (eresolve_tac prems 1);
31.25 -by (eresolve_tac prems 1);
31.26 -qed "oneE";
31.27 -
31.28 -(* ------------------------------------------------------------------------ *)
31.29 -(* tactic for one-thms *)
31.30 -(* ------------------------------------------------------------------------ *)
31.31 -
31.32 -fun prover t = prove_goalw thy [ONE_def] t
31.33 - (fn prems =>
31.34 - [
31.35 - (asm_simp_tac (simpset() addsimps [inst_lift_po]) 1)
31.36 - ]);
31.37 -
31.38 -(* ------------------------------------------------------------------------ *)
31.39 -(* distinctness for type one : stored in a list *)
31.40 -(* ------------------------------------------------------------------------ *)
31.41 -
31.42 -val dist_less_one = map prover ["~ONE << UU"];
31.43 -
31.44 -val dist_eq_one = map prover ["ONE~=UU","UU~=ONE"];
31.45 -
31.46 -Addsimps (dist_less_one@dist_eq_one);
31.47 +val Exh_one = thm "Exh_one";
31.48 +val oneE = thm "oneE";
31.49 +val dist_less_one = thm "dist_less_one";
31.50 +val dist_eq_one = thms "dist_eq_one";
32.1 --- a/src/HOLCF/One.thy Fri Mar 04 18:53:46 2005 +0100
32.2 +++ b/src/HOLCF/One.thy Fri Mar 04 23:12:36 2005 +0100
32.3 @@ -1,11 +1,12 @@
32.4 (* Title: HOLCF/One.thy
32.5 ID: $Id$
32.6 Author: Oscar Slotosch
32.7 + License: GPL (GNU GENERAL PUBLIC LICENSE)
32.8 *)
32.9
32.10 -One = Lift +
32.11 +theory One = Lift:
32.12
32.13 -types one = unit lift
32.14 +types one = "unit lift"
32.15
32.16 constdefs
32.17 ONE :: "one"
32.18 @@ -14,4 +15,39 @@
32.19 translations
32.20 "one" <= (type) "unit lift"
32.21
32.22 +(* Title: HOLCF/One.ML
32.23 + ID: $Id$
32.24 + Author: Oscar Slotosch
32.25 + License: GPL (GNU GENERAL PUBLIC LICENSE)
32.26 +
32.27 +The unit domain.
32.28 +*)
32.29 +
32.30 +(* ------------------------------------------------------------------------ *)
32.31 +(* Exhaustion and Elimination for type one *)
32.32 +(* ------------------------------------------------------------------------ *)
32.33 +
32.34 +lemma Exh_one: "t=UU | t = ONE"
32.35 +apply (unfold ONE_def)
32.36 +apply (induct t)
32.37 +apply simp
32.38 +apply simp
32.39 +done
32.40 +
32.41 +lemma oneE: "[| p=UU ==> Q; p = ONE ==>Q|] ==>Q"
32.42 +apply (rule Exh_one [THEN disjE])
32.43 +apply fast
32.44 +apply fast
32.45 +done
32.46 +
32.47 +lemma dist_less_one [simp]: "~ONE << UU"
32.48 +apply (unfold ONE_def)
32.49 +apply (simp add: inst_lift_po)
32.50 +done
32.51 +
32.52 +lemma dist_eq_one [simp]: "ONE~=UU" "UU~=ONE"
32.53 +apply (unfold ONE_def)
32.54 +apply (simp_all add: inst_lift_po)
32.55 +done
32.56 +
32.57 end
33.1 --- a/src/HOLCF/Pcpo.thy Fri Mar 04 18:53:46 2005 +0100
33.2 +++ b/src/HOLCF/Pcpo.thy Fri Mar 04 23:12:36 2005 +0100
33.3 @@ -5,6 +5,9 @@
33.4
33.5 introduction of the classes cpo and pcpo
33.6 *)
33.7 +
33.8 +header {* Classes cpo and pcpo *}
33.9 +
33.10 theory Pcpo = Porder:
33.11
33.12 (* The class cpo of chain complete partial orders *)
33.13 @@ -318,4 +321,10 @@
33.14 apply (unfold max_in_chain_def)
33.15 apply (fast dest: le_imp_less_or_eq elim: chain_mono)
33.16 done
33.17 +
33.18 +instance flat<chfin
33.19 +apply (intro_classes)
33.20 +apply (rule flat_imp_chfin)
33.21 +done
33.22 +
33.23 end
34.1 --- a/src/HOLCF/Porder.ML Fri Mar 04 18:53:46 2005 +0100
34.2 +++ b/src/HOLCF/Porder.ML Fri Mar 04 23:12:36 2005 +0100
34.3 @@ -1,6 +1,13 @@
34.4
34.5 (* legacy ML bindings *)
34.6
34.7 +val refl_less = thm "refl_less";
34.8 +val antisym_less = thm "antisym_less";
34.9 +val trans_less = thm "trans_less";
34.10 +val minimal2UU = thm "minimal2UU";
34.11 +val antisym_less_inverse = thm "antisym_less_inverse";
34.12 +val box_less = thm "box_less";
34.13 +val po_eq_conv = thm "po_eq_conv";
34.14 val is_ub_def = thm "is_ub_def";
34.15 val is_lub_def = thm "is_lub_def";
34.16 val tord_def = thm "tord_def";
35.1 --- a/src/HOLCF/Porder.thy Fri Mar 04 18:53:46 2005 +0100
35.2 +++ b/src/HOLCF/Porder.thy Fri Mar 04 23:12:36 2005 +0100
35.3 @@ -3,10 +3,53 @@
35.4 Author: Franz Regensburger
35.5 License: GPL (GNU GENERAL PUBLIC LICENSE)
35.6
35.7 +Definition of class porder (partial order).
35.8 Conservative extension of theory Porder0 by constant definitions
35.9 *)
35.10
35.11 -theory Porder = Porder0:
35.12 +header {* Type class of partial orders *}
35.13 +
35.14 +theory Porder = Main:
35.15 +
35.16 + (* introduce a (syntactic) class for the constant << *)
35.17 +axclass sq_ord < type
35.18 +
35.19 + (* characteristic constant << for po *)
35.20 +consts
35.21 + "<<" :: "['a,'a::sq_ord] => bool" (infixl 55)
35.22 +
35.23 +syntax (xsymbols)
35.24 + "op <<" :: "['a,'a::sq_ord] => bool" (infixl "\<sqsubseteq>" 55)
35.25 +
35.26 +axclass po < sq_ord
35.27 + (* class axioms: *)
35.28 +refl_less [iff]: "x << x"
35.29 +antisym_less: "[|x << y; y << x |] ==> x = y"
35.30 +trans_less: "[|x << y; y << z |] ==> x << z"
35.31 +
35.32 +text {* minimal fixes least element *}
35.33 +
35.34 +lemma minimal2UU[OF allI] : "!x::'a::po. uu<<x ==> uu=(@u.!y. u<<y)"
35.35 +apply (blast intro: someI2 antisym_less)
35.36 +done
35.37 +
35.38 +text {* the reverse law of anti-symmetry of @{term "op <<"} *}
35.39 +
35.40 +lemma antisym_less_inverse: "(x::'a::po)=y ==> x << y & y << x"
35.41 +apply blast
35.42 +done
35.43 +
35.44 +lemma box_less: "[| (a::'a::po) << b; c << a; b << d|] ==> c << d"
35.45 +apply (erule trans_less)
35.46 +apply (erule trans_less)
35.47 +apply assumption
35.48 +done
35.49 +
35.50 +lemma po_eq_conv: "((x::'a::po)=y) = (x << y & y << x)"
35.51 +apply (fast elim!: antisym_less_inverse intro!: antisym_less)
35.52 +done
35.53 +
35.54 +subsection {* Constant definitions *}
35.55
35.56 consts
35.57 "<|" :: "['a set,'a::po] => bool" (infixl 55)
35.58 @@ -21,11 +64,9 @@
35.59 "@LUB" :: "('b => 'a) => 'a" (binder "LUB " 10)
35.60
35.61 translations
35.62 -
35.63 "LUB x. t" == "lub(range(%x. t))"
35.64
35.65 syntax (xsymbols)
35.66 -
35.67 "LUB " :: "[idts, 'a] => 'a" ("(3\<Squnion>_./ _)"[0,10] 10)
35.68
35.69 defs
35.70 @@ -46,18 +87,7 @@
35.71
35.72 lub_def: "lub S == (@x. S <<| x)"
35.73
35.74 -(* Title: HOLCF/Porder
35.75 - ID: $Id$
35.76 - Author: Franz Regensburger
35.77 - License: GPL (GNU GENERAL PUBLIC LICENSE)
35.78 -
35.79 -Conservative extension of theory Porder0 by constant definitions
35.80 -*)
35.81 -
35.82 -(* ------------------------------------------------------------------------ *)
35.83 -(* lubs are unique *)
35.84 -(* ------------------------------------------------------------------------ *)
35.85 -
35.86 +text {* lubs are unique *}
35.87
35.88 lemma unique_lub:
35.89 "[| S <<| x ; S <<| y |] ==> x=y"
35.90 @@ -65,9 +95,7 @@
35.91 apply (blast intro: antisym_less)
35.92 done
35.93
35.94 -(* ------------------------------------------------------------------------ *)
35.95 -(* chains are monotone functions *)
35.96 -(* ------------------------------------------------------------------------ *)
35.97 +text {* chains are monotone functions *}
35.98
35.99 lemma chain_mono [rule_format]: "chain F ==> x<y --> F x<<F y"
35.100 apply (unfold chain_def)
35.101 @@ -82,10 +110,7 @@
35.102 apply (blast intro: chain_mono)
35.103 done
35.104
35.105 -
35.106 -(* ------------------------------------------------------------------------ *)
35.107 -(* The range of a chain is a totally ordered << *)
35.108 -(* ------------------------------------------------------------------------ *)
35.109 +text {* The range of a chain is a totally ordered *}
35.110
35.111 lemma chain_tord: "chain(F) ==> tord(range(F))"
35.112 apply (unfold tord_def)
35.113 @@ -94,10 +119,8 @@
35.114 apply (fast intro: chain_mono)+
35.115 done
35.116
35.117 +text {* technical lemmas about @{term lub} and @{term is_lub} *}
35.118
35.119 -(* ------------------------------------------------------------------------ *)
35.120 -(* technical lemmas about lub and is_lub *)
35.121 -(* ------------------------------------------------------------------------ *)
35.122 lemmas lub = lub_def [THEN meta_eq_to_obj_eq, standard]
35.123
35.124 lemma lubI[OF exI]: "EX x. M <<| x ==> M <<| lub(M)"
35.125 @@ -111,15 +134,11 @@
35.126 apply assumption
35.127 done
35.128
35.129 -
35.130 -lemma lub_singleton: "lub{x} = x"
35.131 +lemma lub_singleton [simp]: "lub{x} = x"
35.132 apply (simp (no_asm) add: thelubI is_lub_def is_ub_def)
35.133 done
35.134 -declare lub_singleton [simp]
35.135
35.136 -(* ------------------------------------------------------------------------ *)
35.137 -(* access to some definition as inference rule *)
35.138 -(* ------------------------------------------------------------------------ *)
35.139 +text {* access to some definition as inference rule *}
35.140
35.141 lemma is_lubD1: "S <<| x ==> S <| x"
35.142 apply (unfold is_lub_def)
35.143 @@ -153,9 +172,7 @@
35.144 apply (erule chainE)
35.145 done
35.146
35.147 -(* ------------------------------------------------------------------------ *)
35.148 -(* technical lemmas about (least) upper bounds of chains *)
35.149 -(* ------------------------------------------------------------------------ *)
35.150 +text {* technical lemmas about (least) upper bounds of chains *}
35.151
35.152 lemma ub_rangeD: "range S <| x ==> S(i) << x"
35.153 apply (unfold is_ub_def)
35.154 @@ -170,10 +187,7 @@
35.155 lemmas is_ub_lub = is_lubD1 [THEN ub_rangeD, standard]
35.156 (* range(?S1) <<| ?x1 ==> ?S1(?x) << ?x1 *)
35.157
35.158 -
35.159 -(* ------------------------------------------------------------------------ *)
35.160 -(* results about finite chains *)
35.161 -(* ------------------------------------------------------------------------ *)
35.162 +text {* results about finite chains *}
35.163
35.164 lemma lub_finch1:
35.165 "[| chain C; max_in_chain i C|] ==> range C <<| C i"
35.166 @@ -200,7 +214,6 @@
35.167 apply blast
35.168 done
35.169
35.170 -
35.171 lemma bin_chain: "x<<y ==> chain (%i. if i=0 then x else y)"
35.172 apply (rule chainI)
35.173 apply (induct_tac "i")
35.174 @@ -222,17 +235,13 @@
35.175 apply (simp (no_asm))
35.176 done
35.177
35.178 -(* ------------------------------------------------------------------------ *)
35.179 -(* the maximal element in a chain is its lub *)
35.180 -(* ------------------------------------------------------------------------ *)
35.181 +text {* the maximal element in a chain is its lub *}
35.182
35.183 lemma lub_chain_maxelem: "[| Y i = c; ALL i. Y i<<c |] ==> lub(range Y) = c"
35.184 apply (blast dest: ub_rangeD intro: thelubI is_lubI ub_rangeI)
35.185 done
35.186
35.187 -(* ------------------------------------------------------------------------ *)
35.188 -(* the lub of a constant chain is the constant *)
35.189 -(* ------------------------------------------------------------------------ *)
35.190 +text {* the lub of a constant chain is the constant *}
35.191
35.192 lemma lub_const: "range(%x. c) <<| c"
35.193 apply (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
36.1 --- a/src/HOLCF/Porder0.ML Fri Mar 04 18:53:46 2005 +0100
36.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
36.3 @@ -1,10 +0,0 @@
36.4 -
36.5 -(* legacy ML bindings *)
36.6 -
36.7 -val refl_less = thm "refl_less";
36.8 -val antisym_less = thm "antisym_less";
36.9 -val trans_less = thm "trans_less";
36.10 -val minimal2UU = thm "minimal2UU";
36.11 -val antisym_less_inverse = thm "antisym_less_inverse";
36.12 -val box_less = thm "box_less";
36.13 -val po_eq_conv = thm "po_eq_conv";
37.1 --- a/src/HOLCF/Porder0.thy Fri Mar 04 18:53:46 2005 +0100
37.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
37.3 @@ -1,56 +0,0 @@
37.4 -(* Title: HOLCF/Porder0.thy
37.5 - ID: $Id$
37.6 - Author: Franz Regensburger
37.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
37.8 -
37.9 -Definition of class porder (partial order).
37.10 -*)
37.11 -
37.12 -theory Porder0 = Main:
37.13 -
37.14 - (* introduce a (syntactic) class for the constant << *)
37.15 -axclass sq_ord < type
37.16 -
37.17 - (* characteristic constant << for po *)
37.18 -consts
37.19 - "<<" :: "['a,'a::sq_ord] => bool" (infixl 55)
37.20 -
37.21 -syntax (xsymbols)
37.22 - "op <<" :: "['a,'a::sq_ord] => bool" (infixl "\<sqsubseteq>" 55)
37.23 -
37.24 -axclass po < sq_ord
37.25 - (* class axioms: *)
37.26 -refl_less: "x << x"
37.27 -antisym_less: "[|x << y; y << x |] ==> x = y"
37.28 -trans_less: "[|x << y; y << z |] ==> x << z"
37.29 -
37.30 -declare refl_less [iff]
37.31 -
37.32 -(* ------------------------------------------------------------------------ *)
37.33 -(* minimal fixes least element *)
37.34 -(* ------------------------------------------------------------------------ *)
37.35 -lemma minimal2UU[OF allI] : "!x::'a::po. uu<<x ==> uu=(@u.!y. u<<y)"
37.36 -apply (blast intro: someI2 antisym_less)
37.37 -done
37.38 -
37.39 -(* ------------------------------------------------------------------------ *)
37.40 -(* the reverse law of anti--symmetrie of << *)
37.41 -(* ------------------------------------------------------------------------ *)
37.42 -
37.43 -lemma antisym_less_inverse: "(x::'a::po)=y ==> x << y & y << x"
37.44 -apply blast
37.45 -done
37.46 -
37.47 -
37.48 -lemma box_less: "[| (a::'a::po) << b; c << a; b << d|] ==> c << d"
37.49 -apply (erule trans_less)
37.50 -apply (erule trans_less)
37.51 -apply assumption
37.52 -done
37.53 -
37.54 -lemma po_eq_conv: "((x::'a::po)=y) = (x << y & y << x)"
37.55 -apply (fast elim!: antisym_less_inverse intro!: antisym_less)
37.56 -done
37.57 -end
37.58 -
37.59 -
38.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
38.2 +++ b/src/HOLCF/Sprod.ML Fri Mar 04 23:12:36 2005 +0100
38.3 @@ -0,0 +1,101 @@
38.4 +
38.5 +(* legacy ML bindings *)
38.6 +
38.7 +val Ispair_def = thm "Ispair_def";
38.8 +val Isfst_def = thm "Isfst_def";
38.9 +val Issnd_def = thm "Issnd_def";
38.10 +val SprodI = thm "SprodI";
38.11 +val inj_on_Abs_Sprod = thm "inj_on_Abs_Sprod";
38.12 +val strict_Spair_Rep = thm "strict_Spair_Rep";
38.13 +val defined_Spair_Rep_rev = thm "defined_Spair_Rep_rev";
38.14 +val inject_Spair_Rep = thm "inject_Spair_Rep";
38.15 +val inject_Ispair = thm "inject_Ispair";
38.16 +val strict_Ispair = thm "strict_Ispair";
38.17 +val strict_Ispair1 = thm "strict_Ispair1";
38.18 +val strict_Ispair2 = thm "strict_Ispair2";
38.19 +val strict_Ispair_rev = thm "strict_Ispair_rev";
38.20 +val defined_Ispair_rev = thm "defined_Ispair_rev";
38.21 +val defined_Ispair = thm "defined_Ispair";
38.22 +val Exh_Sprod = thm "Exh_Sprod";
38.23 +val IsprodE = thm "IsprodE";
38.24 +val strict_Isfst = thm "strict_Isfst";
38.25 +val strict_Isfst1 = thm "strict_Isfst1";
38.26 +val strict_Isfst2 = thm "strict_Isfst2";
38.27 +val strict_Issnd = thm "strict_Issnd";
38.28 +val strict_Issnd1 = thm "strict_Issnd1";
38.29 +val strict_Issnd2 = thm "strict_Issnd2";
38.30 +val Isfst = thm "Isfst";
38.31 +val Issnd = thm "Issnd";
38.32 +val Isfst2 = thm "Isfst2";
38.33 +val Issnd2 = thm "Issnd2";
38.34 +val Sprod0_ss = [strict_Isfst1, strict_Isfst2, strict_Issnd1, strict_Issnd2,
38.35 + Isfst2, Issnd2]
38.36 +val defined_IsfstIssnd = thm "defined_IsfstIssnd";
38.37 +val surjective_pairing_Sprod = thm "surjective_pairing_Sprod";
38.38 +val Sel_injective_Sprod = thm "Sel_injective_Sprod";
38.39 +val less_sprod_def = thm "less_sprod_def";
38.40 +val refl_less_sprod = thm "refl_less_sprod";
38.41 +val antisym_less_sprod = thm "antisym_less_sprod";
38.42 +val trans_less_sprod = thm "trans_less_sprod";
38.43 +val inst_sprod_po = thm "inst_sprod_po";
38.44 +val minimal_sprod = thm "minimal_sprod";
38.45 +val UU_sprod_def = thm "UU_sprod_def";
38.46 +val least_sprod = thm "least_sprod";
38.47 +val monofun_Ispair1 = thm "monofun_Ispair1";
38.48 +val monofun_Ispair2 = thm "monofun_Ispair2";
38.49 +val monofun_Ispair = thm "monofun_Ispair";
38.50 +val monofun_Isfst = thm "monofun_Isfst";
38.51 +val monofun_Issnd = thm "monofun_Issnd";
38.52 +val lub_sprod = thm "lub_sprod";
38.53 +val thelub_sprod = thm "thelub_sprod";
38.54 +val cpo_sprod = thm "cpo_sprod";
38.55 +val spair_def = thm "spair_def";
38.56 +val sfst_def = thm "sfst_def";
38.57 +val ssnd_def = thm "ssnd_def";
38.58 +val ssplit_def = thm "ssplit_def";
38.59 +val inst_sprod_pcpo = thm "inst_sprod_pcpo";
38.60 +val sprod3_lemma1 = thm "sprod3_lemma1";
38.61 +val sprod3_lemma2 = thm "sprod3_lemma2";
38.62 +val sprod3_lemma3 = thm "sprod3_lemma3";
38.63 +val contlub_Ispair1 = thm "contlub_Ispair1";
38.64 +val sprod3_lemma4 = thm "sprod3_lemma4";
38.65 +val sprod3_lemma5 = thm "sprod3_lemma5";
38.66 +val sprod3_lemma6 = thm "sprod3_lemma6";
38.67 +val contlub_Ispair2 = thm "contlub_Ispair2";
38.68 +val cont_Ispair1 = thm "cont_Ispair1";
38.69 +val cont_Ispair2 = thm "cont_Ispair2";
38.70 +val contlub_Isfst = thm "contlub_Isfst";
38.71 +val contlub_Issnd = thm "contlub_Issnd";
38.72 +val cont_Isfst = thm "cont_Isfst";
38.73 +val cont_Issnd = thm "cont_Issnd";
38.74 +val spair_eq = thm "spair_eq";
38.75 +val beta_cfun_sprod = thm "beta_cfun_sprod";
38.76 +val inject_spair = thm "inject_spair";
38.77 +val inst_sprod_pcpo2 = thm "inst_sprod_pcpo2";
38.78 +val strict_spair = thm "strict_spair";
38.79 +val strict_spair1 = thm "strict_spair1";
38.80 +val strict_spair2 = thm "strict_spair2";
38.81 +val strict_spair_rev = thm "strict_spair_rev";
38.82 +val defined_spair_rev = thm "defined_spair_rev";
38.83 +val defined_spair = thm "defined_spair";
38.84 +val Exh_Sprod2 = thm "Exh_Sprod2";
38.85 +val sprodE = thm "sprodE";
38.86 +val strict_sfst = thm "strict_sfst";
38.87 +val strict_sfst1 = thm "strict_sfst1";
38.88 +val strict_sfst2 = thm "strict_sfst2";
38.89 +val strict_ssnd = thm "strict_ssnd";
38.90 +val strict_ssnd1 = thm "strict_ssnd1";
38.91 +val strict_ssnd2 = thm "strict_ssnd2";
38.92 +val sfst2 = thm "sfst2";
38.93 +val ssnd2 = thm "ssnd2";
38.94 +val defined_sfstssnd = thm "defined_sfstssnd";
38.95 +val surjective_pairing_Sprod2 = thm "surjective_pairing_Sprod2";
38.96 +val lub_sprod2 = thm "lub_sprod2";
38.97 +val thelub_sprod2 = thm "thelub_sprod2";
38.98 +val ssplit1 = thm "ssplit1";
38.99 +val ssplit2 = thm "ssplit2";
38.100 +val ssplit3 = thm "ssplit3";
38.101 +val Sprod_rews = [strict_sfst1, strict_sfst2,
38.102 + strict_ssnd1, strict_ssnd2, sfst2, ssnd2, defined_spair,
38.103 + ssplit1, ssplit2]
38.104 +
39.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
39.2 +++ b/src/HOLCF/Sprod.thy Fri Mar 04 23:12:36 2005 +0100
39.3 @@ -0,0 +1,1029 @@
39.4 +(* Title: HOLCF/Sprod0.thy
39.5 + ID: $Id$
39.6 + Author: Franz Regensburger
39.7 + License: GPL (GNU GENERAL PUBLIC LICENSE)
39.8 +
39.9 +Strict product with typedef.
39.10 +*)
39.11 +
39.12 +header {* The type of strict products *}
39.13 +
39.14 +theory Sprod = Cfun:
39.15 +
39.16 +constdefs
39.17 + Spair_Rep :: "['a,'b] => ['a,'b] => bool"
39.18 + "Spair_Rep == (%a b. %x y.(~a=UU & ~b=UU --> x=a & y=b ))"
39.19 +
39.20 +typedef (Sprod) ('a, 'b) "**" (infixr 20) = "{f. ? a b. f = Spair_Rep (a::'a) (b::'b)}"
39.21 +by auto
39.22 +
39.23 +syntax (xsymbols)
39.24 + "**" :: "[type, type] => type" ("(_ \<otimes>/ _)" [21,20] 20)
39.25 +syntax (HTML output)
39.26 + "**" :: "[type, type] => type" ("(_ \<otimes>/ _)" [21,20] 20)
39.27 +
39.28 +subsection {* @{term Ispair}, @{term Isfst}, and @{term Issnd} *}
39.29 +
39.30 +consts
39.31 + Ispair :: "['a,'b] => ('a ** 'b)"
39.32 + Isfst :: "('a ** 'b) => 'a"
39.33 + Issnd :: "('a ** 'b) => 'b"
39.34 +
39.35 +defs
39.36 + (*defining the abstract constants*)
39.37 +
39.38 + Ispair_def: "Ispair a b == Abs_Sprod(Spair_Rep a b)"
39.39 +
39.40 + Isfst_def: "Isfst(p) == @z. (p=Ispair UU UU --> z=UU)
39.41 + &(! a b. ~a=UU & ~b=UU & p=Ispair a b --> z=a)"
39.42 +
39.43 + Issnd_def: "Issnd(p) == @z. (p=Ispair UU UU --> z=UU)
39.44 + &(! a b. ~a=UU & ~b=UU & p=Ispair a b --> z=b)"
39.45 +
39.46 +(* ------------------------------------------------------------------------ *)
39.47 +(* A non-emptyness result for Sprod *)
39.48 +(* ------------------------------------------------------------------------ *)
39.49 +
39.50 +lemma SprodI: "(Spair_Rep a b):Sprod"
39.51 +apply (unfold Sprod_def)
39.52 +apply (rule CollectI, rule exI, rule exI, rule refl)
39.53 +done
39.54 +
39.55 +lemma inj_on_Abs_Sprod: "inj_on Abs_Sprod Sprod"
39.56 +apply (rule inj_on_inverseI)
39.57 +apply (erule Abs_Sprod_inverse)
39.58 +done
39.59 +
39.60 +(* ------------------------------------------------------------------------ *)
39.61 +(* Strictness and definedness of Spair_Rep *)
39.62 +(* ------------------------------------------------------------------------ *)
39.63 +
39.64 +lemma strict_Spair_Rep:
39.65 + "(a=UU | b=UU) ==> (Spair_Rep a b) = (Spair_Rep UU UU)"
39.66 +apply (unfold Spair_Rep_def)
39.67 +apply (rule ext)
39.68 +apply (rule ext)
39.69 +apply (rule iffI)
39.70 +apply fast
39.71 +apply fast
39.72 +done
39.73 +
39.74 +lemma defined_Spair_Rep_rev:
39.75 + "(Spair_Rep a b) = (Spair_Rep UU UU) ==> (a=UU | b=UU)"
39.76 +apply (unfold Spair_Rep_def)
39.77 +apply (case_tac "a=UU|b=UU")
39.78 +apply assumption
39.79 +apply (fast dest: fun_cong)
39.80 +done
39.81 +
39.82 +(* ------------------------------------------------------------------------ *)
39.83 +(* injectivity of Spair_Rep and Ispair *)
39.84 +(* ------------------------------------------------------------------------ *)
39.85 +
39.86 +lemma inject_Spair_Rep:
39.87 +"[|~aa=UU ; ~ba=UU ; Spair_Rep a b = Spair_Rep aa ba |] ==> a=aa & b=ba"
39.88 +
39.89 +apply (unfold Spair_Rep_def)
39.90 +apply (drule fun_cong)
39.91 +apply (drule fun_cong)
39.92 +apply (erule iffD1 [THEN mp])
39.93 +apply auto
39.94 +done
39.95 +
39.96 +lemma inject_Ispair:
39.97 + "[|~aa=UU ; ~ba=UU ; Ispair a b = Ispair aa ba |] ==> a=aa & b=ba"
39.98 +apply (unfold Ispair_def)
39.99 +apply (erule inject_Spair_Rep)
39.100 +apply assumption
39.101 +apply (erule inj_on_Abs_Sprod [THEN inj_onD])
39.102 +apply (rule SprodI)
39.103 +apply (rule SprodI)
39.104 +done
39.105 +
39.106 +(* ------------------------------------------------------------------------ *)
39.107 +(* strictness and definedness of Ispair *)
39.108 +(* ------------------------------------------------------------------------ *)
39.109 +
39.110 +lemma strict_Ispair:
39.111 + "(a=UU | b=UU) ==> Ispair a b = Ispair UU UU"
39.112 +apply (unfold Ispair_def)
39.113 +apply (erule strict_Spair_Rep [THEN arg_cong])
39.114 +done
39.115 +
39.116 +lemma strict_Ispair1:
39.117 + "Ispair UU b = Ispair UU UU"
39.118 +apply (unfold Ispair_def)
39.119 +apply (rule strict_Spair_Rep [THEN arg_cong])
39.120 +apply (rule disjI1)
39.121 +apply (rule refl)
39.122 +done
39.123 +
39.124 +lemma strict_Ispair2:
39.125 + "Ispair a UU = Ispair UU UU"
39.126 +apply (unfold Ispair_def)
39.127 +apply (rule strict_Spair_Rep [THEN arg_cong])
39.128 +apply (rule disjI2)
39.129 +apply (rule refl)
39.130 +done
39.131 +
39.132 +lemma strict_Ispair_rev: "~Ispair x y = Ispair UU UU ==> ~x=UU & ~y=UU"
39.133 +apply (rule de_Morgan_disj [THEN subst])
39.134 +apply (erule contrapos_nn)
39.135 +apply (erule strict_Ispair)
39.136 +done
39.137 +
39.138 +lemma defined_Ispair_rev:
39.139 + "Ispair a b = Ispair UU UU ==> (a = UU | b = UU)"
39.140 +apply (unfold Ispair_def)
39.141 +apply (rule defined_Spair_Rep_rev)
39.142 +apply (rule inj_on_Abs_Sprod [THEN inj_onD])
39.143 +apply assumption
39.144 +apply (rule SprodI)
39.145 +apply (rule SprodI)
39.146 +done
39.147 +
39.148 +lemma defined_Ispair: "[|a~=UU; b~=UU|] ==> (Ispair a b) ~= (Ispair UU UU)"
39.149 +apply (rule contrapos_nn)
39.150 +apply (erule_tac [2] defined_Ispair_rev)
39.151 +apply (rule de_Morgan_disj [THEN iffD2])
39.152 +apply (erule conjI)
39.153 +apply assumption
39.154 +done
39.155 +
39.156 +
39.157 +(* ------------------------------------------------------------------------ *)
39.158 +(* Exhaustion of the strict product ** *)
39.159 +(* ------------------------------------------------------------------------ *)
39.160 +
39.161 +lemma Exh_Sprod:
39.162 + "z=Ispair UU UU | (? a b. z=Ispair a b & a~=UU & b~=UU)"
39.163 +apply (unfold Ispair_def)
39.164 +apply (rule Rep_Sprod[unfolded Sprod_def, THEN CollectE])
39.165 +apply (erule exE)
39.166 +apply (erule exE)
39.167 +apply (rule excluded_middle [THEN disjE])
39.168 +apply (rule disjI2)
39.169 +apply (rule exI)
39.170 +apply (rule exI)
39.171 +apply (rule conjI)
39.172 +apply (rule Rep_Sprod_inverse [symmetric, THEN trans])
39.173 +apply (erule arg_cong)
39.174 +apply (rule de_Morgan_disj [THEN subst])
39.175 +apply assumption
39.176 +apply (rule disjI1)
39.177 +apply (rule Rep_Sprod_inverse [symmetric, THEN trans])
39.178 +apply (rule_tac f = "Abs_Sprod" in arg_cong)
39.179 +apply (erule trans)
39.180 +apply (erule strict_Spair_Rep)
39.181 +done
39.182 +
39.183 +(* ------------------------------------------------------------------------ *)
39.184 +(* general elimination rule for strict product *)
39.185 +(* ------------------------------------------------------------------------ *)
39.186 +
39.187 +lemma IsprodE:
39.188 +assumes prem1: "p=Ispair UU UU ==> Q"
39.189 +assumes prem2: "!!x y. [|p=Ispair x y; x~=UU ; y~=UU|] ==> Q"
39.190 +shows "Q"
39.191 +apply (rule Exh_Sprod [THEN disjE])
39.192 +apply (erule prem1)
39.193 +apply (erule exE)
39.194 +apply (erule exE)
39.195 +apply (erule conjE)
39.196 +apply (erule conjE)
39.197 +apply (erule prem2)
39.198 +apply assumption
39.199 +apply assumption
39.200 +done
39.201 +
39.202 +(* ------------------------------------------------------------------------ *)
39.203 +(* some results about the selectors Isfst, Issnd *)
39.204 +(* ------------------------------------------------------------------------ *)
39.205 +
39.206 +lemma strict_Isfst: "p=Ispair UU UU ==> Isfst p = UU"
39.207 +apply (unfold Isfst_def)
39.208 +apply (rule some_equality)
39.209 +apply (rule conjI)
39.210 +apply fast
39.211 +apply (intro strip)
39.212 +apply (rule_tac P = "Ispair UU UU = Ispair a b" in notE)
39.213 +apply (rule not_sym)
39.214 +apply (rule defined_Ispair)
39.215 +apply (fast+)
39.216 +done
39.217 +
39.218 +lemma strict_Isfst1 [simp]: "Isfst(Ispair UU y) = UU"
39.219 +apply (subst strict_Ispair1)
39.220 +apply (rule strict_Isfst)
39.221 +apply (rule refl)
39.222 +done
39.223 +
39.224 +lemma strict_Isfst2 [simp]: "Isfst(Ispair x UU) = UU"
39.225 +apply (subst strict_Ispair2)
39.226 +apply (rule strict_Isfst)
39.227 +apply (rule refl)
39.228 +done
39.229 +
39.230 +lemma strict_Issnd: "p=Ispair UU UU ==>Issnd p=UU"
39.231 +apply (unfold Issnd_def)
39.232 +apply (rule some_equality)
39.233 +apply (rule conjI)
39.234 +apply fast
39.235 +apply (intro strip)
39.236 +apply (rule_tac P = "Ispair UU UU = Ispair a b" in notE)
39.237 +apply (rule not_sym)
39.238 +apply (rule defined_Ispair)
39.239 +apply (fast+)
39.240 +done
39.241 +
39.242 +lemma strict_Issnd1 [simp]: "Issnd(Ispair UU y) = UU"
39.243 +apply (subst strict_Ispair1)
39.244 +apply (rule strict_Issnd)
39.245 +apply (rule refl)
39.246 +done
39.247 +
39.248 +lemma strict_Issnd2 [simp]: "Issnd(Ispair x UU) = UU"
39.249 +apply (subst strict_Ispair2)
39.250 +apply (rule strict_Issnd)
39.251 +apply (rule refl)
39.252 +done
39.253 +
39.254 +lemma Isfst: "[|x~=UU ;y~=UU |] ==> Isfst(Ispair x y) = x"
39.255 +apply (unfold Isfst_def)
39.256 +apply (rule some_equality)
39.257 +apply (rule conjI)
39.258 +apply (intro strip)
39.259 +apply (rule_tac P = "Ispair x y = Ispair UU UU" in notE)
39.260 +apply (erule defined_Ispair)
39.261 +apply assumption
39.262 +apply assumption
39.263 +apply (intro strip)
39.264 +apply (rule inject_Ispair [THEN conjunct1])
39.265 +prefer 3 apply fast
39.266 +apply (fast+)
39.267 +done
39.268 +
39.269 +lemma Issnd: "[|x~=UU ;y~=UU |] ==> Issnd(Ispair x y) = y"
39.270 +apply (unfold Issnd_def)
39.271 +apply (rule some_equality)
39.272 +apply (rule conjI)
39.273 +apply (intro strip)
39.274 +apply (rule_tac P = "Ispair x y = Ispair UU UU" in notE)
39.275 +apply (erule defined_Ispair)
39.276 +apply assumption
39.277 +apply assumption
39.278 +apply (intro strip)
39.279 +apply (rule inject_Ispair [THEN conjunct2])
39.280 +prefer 3 apply fast
39.281 +apply (fast+)
39.282 +done
39.283 +
39.284 +lemma Isfst2: "y~=UU ==>Isfst(Ispair x y)=x"
39.285 +apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
39.286 +apply (erule Isfst)
39.287 +apply assumption
39.288 +apply (erule ssubst)
39.289 +apply (rule strict_Isfst1)
39.290 +done
39.291 +
39.292 +lemma Issnd2: "~x=UU ==>Issnd(Ispair x y)=y"
39.293 +apply (rule_tac Q = "y=UU" in excluded_middle [THEN disjE])
39.294 +apply (erule Issnd)
39.295 +apply assumption
39.296 +apply (erule ssubst)
39.297 +apply (rule strict_Issnd2)
39.298 +done
39.299 +
39.300 +
39.301 +(* ------------------------------------------------------------------------ *)
39.302 +(* instantiate the simplifier *)
39.303 +(* ------------------------------------------------------------------------ *)
39.304 +
39.305 +lemmas Sprod0_ss = strict_Isfst1 strict_Isfst2 strict_Issnd1 strict_Issnd2
39.306 + Isfst2 Issnd2
39.307 +
39.308 +declare Isfst2 [simp] Issnd2 [simp]
39.309 +
39.310 +lemma defined_IsfstIssnd: "p~=Ispair UU UU ==> Isfst p ~= UU & Issnd p ~= UU"
39.311 +apply (rule_tac p = "p" in IsprodE)
39.312 +apply simp
39.313 +apply (erule ssubst)
39.314 +apply (rule conjI)
39.315 +apply (simp add: Sprod0_ss)
39.316 +apply (simp add: Sprod0_ss)
39.317 +done
39.318 +
39.319 +
39.320 +(* ------------------------------------------------------------------------ *)
39.321 +(* Surjective pairing: equivalent to Exh_Sprod *)
39.322 +(* ------------------------------------------------------------------------ *)
39.323 +
39.324 +lemma surjective_pairing_Sprod: "z = Ispair(Isfst z)(Issnd z)"
39.325 +apply (rule_tac z1 = "z" in Exh_Sprod [THEN disjE])
39.326 +apply (simp add: Sprod0_ss)
39.327 +apply (erule exE)
39.328 +apply (erule exE)
39.329 +apply (simp add: Sprod0_ss)
39.330 +done
39.331 +
39.332 +lemma Sel_injective_Sprod: "[|Isfst x = Isfst y; Issnd x = Issnd y|] ==> x = y"
39.333 +apply (subgoal_tac "Ispair (Isfst x) (Issnd x) =Ispair (Isfst y) (Issnd y) ")
39.334 +apply (simp (no_asm_use) add: surjective_pairing_Sprod[symmetric])
39.335 +apply simp
39.336 +done
39.337 +
39.338 +subsection {* The strict product is a partial order *}
39.339 +
39.340 +instance "**"::(sq_ord,sq_ord)sq_ord ..
39.341 +
39.342 +defs (overloaded)
39.343 + less_sprod_def: "p1 << p2 == Isfst p1 << Isfst p2 & Issnd p1 << Issnd p2"
39.344 +
39.345 +(* ------------------------------------------------------------------------ *)
39.346 +(* less_sprod is a partial order on Sprod *)
39.347 +(* ------------------------------------------------------------------------ *)
39.348 +
39.349 +lemma refl_less_sprod: "(p::'a ** 'b) << p"
39.350 +apply (unfold less_sprod_def)
39.351 +apply (fast intro: refl_less)
39.352 +done
39.353 +
39.354 +lemma antisym_less_sprod:
39.355 + "[|(p1::'a ** 'b) << p2;p2 << p1|] ==> p1=p2"
39.356 +apply (unfold less_sprod_def)
39.357 +apply (rule Sel_injective_Sprod)
39.358 +apply (fast intro: antisym_less)
39.359 +apply (fast intro: antisym_less)
39.360 +done
39.361 +
39.362 +lemma trans_less_sprod:
39.363 + "[|(p1::'a**'b) << p2;p2 << p3|] ==> p1 << p3"
39.364 +apply (unfold less_sprod_def)
39.365 +apply (blast intro: trans_less)
39.366 +done
39.367 +
39.368 +instance "**"::(pcpo,pcpo)po
39.369 +by intro_classes
39.370 + (assumption | rule refl_less_sprod antisym_less_sprod trans_less_sprod)+
39.371 +
39.372 +(* for compatibility with old HOLCF-Version *)
39.373 +lemma inst_sprod_po: "(op <<)=(%x y. Isfst x<<Isfst y&Issnd x<<Issnd y)"
39.374 +apply (fold less_sprod_def)
39.375 +apply (rule refl)
39.376 +done
39.377 +
39.378 +subsection {* The strict product is pointed *}
39.379 +(* ------------------------------------------------------------------------ *)
39.380 +(* type sprod is pointed *)
39.381 +(* ------------------------------------------------------------------------ *)
39.382 +(*
39.383 +lemma minimal_sprod: "Ispair UU UU << p"
39.384 +apply (simp add: inst_sprod_po minimal)
39.385 +done
39.386 +
39.387 +lemmas UU_sprod_def = minimal_sprod [THEN minimal2UU, symmetric, standard]
39.388 +
39.389 +lemma least_sprod: "? x::'a**'b.!y. x<<y"
39.390 +apply (rule_tac x = "Ispair UU UU" in exI)
39.391 +apply (rule minimal_sprod [THEN allI])
39.392 +done
39.393 +*)
39.394 +(* ------------------------------------------------------------------------ *)
39.395 +(* Ispair is monotone in both arguments *)
39.396 +(* ------------------------------------------------------------------------ *)
39.397 +
39.398 +lemma monofun_Ispair1: "monofun(Ispair)"
39.399 +apply (unfold monofun)
39.400 +apply (intro strip)
39.401 +apply (rule less_fun [THEN iffD2])
39.402 +apply (intro strip)
39.403 +apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
39.404 +apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
39.405 +apply (frule notUU_I)
39.406 +apply assumption
39.407 +apply (simp_all add: Sprod0_ss inst_sprod_po refl_less minimal)
39.408 +done
39.409 +
39.410 +lemma monofun_Ispair2: "monofun(Ispair(x))"
39.411 +apply (unfold monofun)
39.412 +apply (intro strip)
39.413 +apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
39.414 +apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
39.415 +apply (frule notUU_I)
39.416 +apply assumption
39.417 +apply (simp_all add: Sprod0_ss inst_sprod_po refl_less minimal)
39.418 +done
39.419 +
39.420 +lemma monofun_Ispair: "[|x1<<x2; y1<<y2|] ==> Ispair x1 y1 << Ispair x2 y2"
39.421 +apply (rule trans_less)
39.422 +apply (rule monofun_Ispair1 [THEN monofunE, THEN spec, THEN spec, THEN mp, THEN less_fun [THEN iffD1, THEN spec]])
39.423 +prefer 2 apply (rule monofun_Ispair2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
39.424 +apply assumption
39.425 +apply assumption
39.426 +done
39.427 +
39.428 +(* ------------------------------------------------------------------------ *)
39.429 +(* Isfst and Issnd are monotone *)
39.430 +(* ------------------------------------------------------------------------ *)
39.431 +
39.432 +lemma monofun_Isfst: "monofun(Isfst)"
39.433 +apply (unfold monofun)
39.434 +apply (simp add: inst_sprod_po)
39.435 +done
39.436 +
39.437 +lemma monofun_Issnd: "monofun(Issnd)"
39.438 +apply (unfold monofun)
39.439 +apply (simp add: inst_sprod_po)
39.440 +done
39.441 +
39.442 +subsection {* The strict product is a cpo *}
39.443 +(* ------------------------------------------------------------------------ *)
39.444 +(* the type 'a ** 'b is a cpo *)
39.445 +(* ------------------------------------------------------------------------ *)
39.446 +
39.447 +lemma lub_sprod:
39.448 +"[|chain(S)|] ==> range(S) <<|
39.449 + Ispair (lub(range(%i. Isfst(S i)))) (lub(range(%i. Issnd(S i))))"
39.450 +apply (rule is_lubI)
39.451 +apply (rule ub_rangeI)
39.452 +apply (rule_tac t = "S (i) " in surjective_pairing_Sprod [THEN ssubst])
39.453 +apply (rule monofun_Ispair)
39.454 +apply (rule is_ub_thelub)
39.455 +apply (erule monofun_Isfst [THEN ch2ch_monofun])
39.456 +apply (rule is_ub_thelub)
39.457 +apply (erule monofun_Issnd [THEN ch2ch_monofun])
39.458 +apply (rule_tac t = "u" in surjective_pairing_Sprod [THEN ssubst])
39.459 +apply (rule monofun_Ispair)
39.460 +apply (rule is_lub_thelub)
39.461 +apply (erule monofun_Isfst [THEN ch2ch_monofun])
39.462 +apply (erule monofun_Isfst [THEN ub2ub_monofun])
39.463 +apply (rule is_lub_thelub)
39.464 +apply (erule monofun_Issnd [THEN ch2ch_monofun])
39.465 +apply (erule monofun_Issnd [THEN ub2ub_monofun])
39.466 +done
39.467 +
39.468 +lemmas thelub_sprod = lub_sprod [THEN thelubI, standard]
39.469 +
39.470 +lemma cpo_sprod: "chain(S::nat=>'a**'b)==>? x. range(S)<<| x"
39.471 +apply (rule exI)
39.472 +apply (erule lub_sprod)
39.473 +done
39.474 +
39.475 +instance "**" :: (pcpo, pcpo) cpo
39.476 +by intro_classes (rule cpo_sprod)
39.477 +
39.478 +
39.479 +subsection {* The strict product is a pcpo *}
39.480 +
39.481 +lemma minimal_sprod: "Ispair UU UU << p"
39.482 +apply (simp add: inst_sprod_po minimal)
39.483 +done
39.484 +
39.485 +lemmas UU_sprod_def = minimal_sprod [THEN minimal2UU, symmetric, standard]
39.486 +
39.487 +lemma least_sprod: "? x::'a**'b.!y. x<<y"
39.488 +apply (rule_tac x = "Ispair UU UU" in exI)
39.489 +apply (rule minimal_sprod [THEN allI])
39.490 +done
39.491 +
39.492 +instance "**" :: (pcpo, pcpo) pcpo
39.493 +by intro_classes (rule least_sprod)
39.494 +
39.495 +
39.496 +subsection {* Other constants *}
39.497 +
39.498 +consts
39.499 + spair :: "'a -> 'b -> ('a**'b)" (* continuous strict pairing *)
39.500 + sfst :: "('a**'b)->'a"
39.501 + ssnd :: "('a**'b)->'b"
39.502 + ssplit :: "('a->'b->'c)->('a**'b)->'c"
39.503 +
39.504 +syntax
39.505 + "@stuple" :: "['a, args] => 'a ** 'b" ("(1'(:_,/ _:'))")
39.506 +
39.507 +translations
39.508 + "(:x, y, z:)" == "(:x, (:y, z:):)"
39.509 + "(:x, y:)" == "spair$x$y"
39.510 +
39.511 +defs
39.512 +spair_def: "spair == (LAM x y. Ispair x y)"
39.513 +sfst_def: "sfst == (LAM p. Isfst p)"
39.514 +ssnd_def: "ssnd == (LAM p. Issnd p)"
39.515 +ssplit_def: "ssplit == (LAM f. strictify$(LAM p. f$(sfst$p)$(ssnd$p)))"
39.516 +
39.517 +(* for compatibility with old HOLCF-Version *)
39.518 +lemma inst_sprod_pcpo: "UU = Ispair UU UU"
39.519 +apply (simp add: UU_def UU_sprod_def)
39.520 +done
39.521 +
39.522 +declare inst_sprod_pcpo [symmetric, simp]
39.523 +
39.524 +(* ------------------------------------------------------------------------ *)
39.525 +(* continuity of Ispair, Isfst, Issnd *)
39.526 +(* ------------------------------------------------------------------------ *)
39.527 +
39.528 +lemma sprod3_lemma1:
39.529 +"[| chain(Y); x~= UU; lub(range(Y))~= UU |] ==>
39.530 + Ispair (lub(range Y)) x =
39.531 + Ispair (lub(range(%i. Isfst(Ispair(Y i) x))))
39.532 + (lub(range(%i. Issnd(Ispair(Y i) x))))"
39.533 +apply (rule_tac f1 = "Ispair" in arg_cong [THEN cong])
39.534 +apply (rule lub_equal)
39.535 +apply assumption
39.536 +apply (rule monofun_Isfst [THEN ch2ch_monofun])
39.537 +apply (rule ch2ch_fun)
39.538 +apply (rule monofun_Ispair1 [THEN ch2ch_monofun])
39.539 +apply assumption
39.540 +apply (rule allI)
39.541 +apply (simp (no_asm_simp))
39.542 +apply (rule sym)
39.543 +apply (drule chain_UU_I_inverse2)
39.544 +apply (erule exE)
39.545 +apply (rule lub_chain_maxelem)
39.546 +apply (erule Issnd2)
39.547 +apply (rule allI)
39.548 +apply (rename_tac "j")
39.549 +apply (case_tac "Y (j) =UU")
39.550 +apply auto
39.551 +done
39.552 +
39.553 +lemma sprod3_lemma2:
39.554 +"[| chain(Y); x ~= UU; lub(range(Y)) = UU |] ==>
39.555 + Ispair (lub(range Y)) x =
39.556 + Ispair (lub(range(%i. Isfst(Ispair(Y i) x))))
39.557 + (lub(range(%i. Issnd(Ispair(Y i) x))))"
39.558 +apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
39.559 +apply assumption
39.560 +apply (rule trans)
39.561 +apply (rule strict_Ispair1)
39.562 +apply (rule strict_Ispair [symmetric])
39.563 +apply (rule disjI1)
39.564 +apply (rule chain_UU_I_inverse)
39.565 +apply auto
39.566 +apply (erule chain_UU_I [THEN spec])
39.567 +apply assumption
39.568 +done
39.569 +
39.570 +
39.571 +lemma sprod3_lemma3:
39.572 +"[| chain(Y); x = UU |] ==>
39.573 + Ispair (lub(range Y)) x =
39.574 + Ispair (lub(range(%i. Isfst(Ispair (Y i) x))))
39.575 + (lub(range(%i. Issnd(Ispair (Y i) x))))"
39.576 +apply (erule ssubst)
39.577 +apply (rule trans)
39.578 +apply (rule strict_Ispair2)
39.579 +apply (rule strict_Ispair [symmetric])
39.580 +apply (rule disjI1)
39.581 +apply (rule chain_UU_I_inverse)
39.582 +apply (rule allI)
39.583 +apply (simp add: Sprod0_ss)
39.584 +done
39.585 +
39.586 +lemma contlub_Ispair1: "contlub(Ispair)"
39.587 +apply (rule contlubI)
39.588 +apply (intro strip)
39.589 +apply (rule expand_fun_eq [THEN iffD2])
39.590 +apply (intro strip)
39.591 +apply (subst lub_fun [THEN thelubI])
39.592 +apply (erule monofun_Ispair1 [THEN ch2ch_monofun])
39.593 +apply (rule trans)
39.594 +apply (rule_tac [2] thelub_sprod [symmetric])
39.595 +apply (rule_tac [2] ch2ch_fun)
39.596 +apply (erule_tac [2] monofun_Ispair1 [THEN ch2ch_monofun])
39.597 +apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
39.598 +apply (rule_tac Q = "lub (range (Y))=UU" in excluded_middle [THEN disjE])
39.599 +apply (erule sprod3_lemma1)
39.600 +apply assumption
39.601 +apply assumption
39.602 +apply (erule sprod3_lemma2)
39.603 +apply assumption
39.604 +apply assumption
39.605 +apply (erule sprod3_lemma3)
39.606 +apply assumption
39.607 +done
39.608 +
39.609 +lemma sprod3_lemma4:
39.610 +"[| chain(Y); x ~= UU; lub(range(Y)) ~= UU |] ==>
39.611 + Ispair x (lub(range Y)) =
39.612 + Ispair (lub(range(%i. Isfst (Ispair x (Y i)))))
39.613 + (lub(range(%i. Issnd (Ispair x (Y i)))))"
39.614 +apply (rule_tac f1 = "Ispair" in arg_cong [THEN cong])
39.615 +apply (rule sym)
39.616 +apply (drule chain_UU_I_inverse2)
39.617 +apply (erule exE)
39.618 +apply (rule lub_chain_maxelem)
39.619 +apply (erule Isfst2)
39.620 +apply (rule allI)
39.621 +apply (rename_tac "j")
39.622 +apply (case_tac "Y (j) =UU")
39.623 +apply auto
39.624 +done
39.625 +
39.626 +lemma sprod3_lemma5:
39.627 +"[| chain(Y); x ~= UU; lub(range(Y)) = UU |] ==>
39.628 + Ispair x (lub(range Y)) =
39.629 + Ispair (lub(range(%i. Isfst(Ispair x (Y i)))))
39.630 + (lub(range(%i. Issnd(Ispair x (Y i)))))"
39.631 +apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
39.632 +apply assumption
39.633 +apply (rule trans)
39.634 +apply (rule strict_Ispair2)
39.635 +apply (rule strict_Ispair [symmetric])
39.636 +apply (rule disjI2)
39.637 +apply (rule chain_UU_I_inverse)
39.638 +apply (rule allI)
39.639 +apply (simp add: Sprod0_ss)
39.640 +apply (erule chain_UU_I [THEN spec])
39.641 +apply assumption
39.642 +done
39.643 +
39.644 +lemma sprod3_lemma6:
39.645 +"[| chain(Y); x = UU |] ==>
39.646 + Ispair x (lub(range Y)) =
39.647 + Ispair (lub(range(%i. Isfst (Ispair x (Y i)))))
39.648 + (lub(range(%i. Issnd (Ispair x (Y i)))))"
39.649 +apply (rule_tac s = "UU" and t = "x" in ssubst)
39.650 +apply assumption
39.651 +apply (rule trans)
39.652 +apply (rule strict_Ispair1)
39.653 +apply (rule strict_Ispair [symmetric])
39.654 +apply (rule disjI1)
39.655 +apply (rule chain_UU_I_inverse)
39.656 +apply (rule allI)
39.657 +apply (simp add: Sprod0_ss)
39.658 +done
39.659 +
39.660 +lemma contlub_Ispair2: "contlub(Ispair(x))"
39.661 +apply (rule contlubI)
39.662 +apply (intro strip)
39.663 +apply (rule trans)
39.664 +apply (rule_tac [2] thelub_sprod [symmetric])
39.665 +apply (erule_tac [2] monofun_Ispair2 [THEN ch2ch_monofun])
39.666 +apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
39.667 +apply (rule_tac Q = "lub (range (Y))=UU" in excluded_middle [THEN disjE])
39.668 +apply (erule sprod3_lemma4)
39.669 +apply assumption
39.670 +apply assumption
39.671 +apply (erule sprod3_lemma5)
39.672 +apply assumption
39.673 +apply assumption
39.674 +apply (erule sprod3_lemma6)
39.675 +apply assumption
39.676 +done
39.677 +
39.678 +lemma cont_Ispair1: "cont(Ispair)"
39.679 +apply (rule monocontlub2cont)
39.680 +apply (rule monofun_Ispair1)
39.681 +apply (rule contlub_Ispair1)
39.682 +done
39.683 +
39.684 +lemma cont_Ispair2: "cont(Ispair(x))"
39.685 +apply (rule monocontlub2cont)
39.686 +apply (rule monofun_Ispair2)
39.687 +apply (rule contlub_Ispair2)
39.688 +done
39.689 +
39.690 +lemma contlub_Isfst: "contlub(Isfst)"
39.691 +apply (rule contlubI)
39.692 +apply (intro strip)
39.693 +apply (subst lub_sprod [THEN thelubI])
39.694 +apply assumption
39.695 +apply (rule_tac Q = "lub (range (%i. Issnd (Y (i))))=UU" in excluded_middle [THEN disjE])
39.696 +apply (simp add: Sprod0_ss)
39.697 +apply (rule_tac s = "UU" and t = "lub (range (%i. Issnd (Y (i))))" in ssubst)
39.698 +apply assumption
39.699 +apply (rule trans)
39.700 +apply (simp add: Sprod0_ss)
39.701 +apply (rule sym)
39.702 +apply (rule chain_UU_I_inverse)
39.703 +apply (rule allI)
39.704 +apply (rule strict_Isfst)
39.705 +apply (rule contrapos_np)
39.706 +apply (erule_tac [2] defined_IsfstIssnd [THEN conjunct2])
39.707 +apply (fast dest!: monofun_Issnd [THEN ch2ch_monofun, THEN chain_UU_I, THEN spec])
39.708 +done
39.709 +
39.710 +lemma contlub_Issnd: "contlub(Issnd)"
39.711 +apply (rule contlubI)
39.712 +apply (intro strip)
39.713 +apply (subst lub_sprod [THEN thelubI])
39.714 +apply assumption
39.715 +apply (rule_tac Q = "lub (range (%i. Isfst (Y (i))))=UU" in excluded_middle [THEN disjE])
39.716 +apply (simp add: Sprod0_ss)
39.717 +apply (rule_tac s = "UU" and t = "lub (range (%i. Isfst (Y (i))))" in ssubst)
39.718 +apply assumption
39.719 +apply (simp add: Sprod0_ss)
39.720 +apply (rule sym)
39.721 +apply (rule chain_UU_I_inverse)
39.722 +apply (rule allI)
39.723 +apply (rule strict_Issnd)
39.724 +apply (rule contrapos_np)
39.725 +apply (erule_tac [2] defined_IsfstIssnd [THEN conjunct1])
39.726 +apply (fast dest!: monofun_Isfst [THEN ch2ch_monofun, THEN chain_UU_I, THEN spec])
39.727 +done
39.728 +
39.729 +lemma cont_Isfst: "cont(Isfst)"
39.730 +apply (rule monocontlub2cont)
39.731 +apply (rule monofun_Isfst)
39.732 +apply (rule contlub_Isfst)
39.733 +done
39.734 +
39.735 +lemma cont_Issnd: "cont(Issnd)"
39.736 +apply (rule monocontlub2cont)
39.737 +apply (rule monofun_Issnd)
39.738 +apply (rule contlub_Issnd)
39.739 +done
39.740 +
39.741 +lemma spair_eq: "[|x1=x2;y1=y2|] ==> (:x1,y1:) = (:x2,y2:)"
39.742 +apply fast
39.743 +done
39.744 +
39.745 +(* ------------------------------------------------------------------------ *)
39.746 +(* convert all lemmas to the continuous versions *)
39.747 +(* ------------------------------------------------------------------------ *)
39.748 +
39.749 +lemma beta_cfun_sprod [simp]:
39.750 + "(LAM x y. Ispair x y)$a$b = Ispair a b"
39.751 +apply (subst beta_cfun)
39.752 +apply (simp (no_asm) add: cont_Ispair2 cont_Ispair1 cont2cont_CF1L)
39.753 +apply (subst beta_cfun)
39.754 +apply (rule cont_Ispair2)
39.755 +apply (rule refl)
39.756 +done
39.757 +
39.758 +lemma inject_spair:
39.759 + "[| aa~=UU ; ba~=UU ; (:a,b:)=(:aa,ba:) |] ==> a=aa & b=ba"
39.760 +apply (unfold spair_def)
39.761 +apply (erule inject_Ispair)
39.762 +apply assumption
39.763 +apply (erule box_equals)
39.764 +apply (rule beta_cfun_sprod)
39.765 +apply (rule beta_cfun_sprod)
39.766 +done
39.767 +
39.768 +lemma inst_sprod_pcpo2: "UU = (:UU,UU:)"
39.769 +apply (unfold spair_def)
39.770 +apply (rule sym)
39.771 +apply (rule trans)
39.772 +apply (rule beta_cfun_sprod)
39.773 +apply (rule sym)
39.774 +apply (rule inst_sprod_pcpo)
39.775 +done
39.776 +
39.777 +lemma strict_spair:
39.778 + "(a=UU | b=UU) ==> (:a,b:)=UU"
39.779 +apply (unfold spair_def)
39.780 +apply (rule trans)
39.781 +apply (rule beta_cfun_sprod)
39.782 +apply (rule trans)
39.783 +apply (rule_tac [2] inst_sprod_pcpo [symmetric])
39.784 +apply (erule strict_Ispair)
39.785 +done
39.786 +
39.787 +lemma strict_spair1: "(:UU,b:) = UU"
39.788 +apply (unfold spair_def)
39.789 +apply (subst beta_cfun_sprod)
39.790 +apply (rule trans)
39.791 +apply (rule_tac [2] inst_sprod_pcpo [symmetric])
39.792 +apply (rule strict_Ispair1)
39.793 +done
39.794 +
39.795 +lemma strict_spair2: "(:a,UU:) = UU"
39.796 +apply (unfold spair_def)
39.797 +apply (subst beta_cfun_sprod)
39.798 +apply (rule trans)
39.799 +apply (rule_tac [2] inst_sprod_pcpo [symmetric])
39.800 +apply (rule strict_Ispair2)
39.801 +done
39.802 +
39.803 +declare strict_spair1 [simp] strict_spair2 [simp]
39.804 +
39.805 +lemma strict_spair_rev: "(:x,y:)~=UU ==> ~x=UU & ~y=UU"
39.806 +apply (unfold spair_def)
39.807 +apply (rule strict_Ispair_rev)
39.808 +apply auto
39.809 +done
39.810 +
39.811 +lemma defined_spair_rev: "(:a,b:) = UU ==> (a = UU | b = UU)"
39.812 +apply (unfold spair_def)
39.813 +apply (rule defined_Ispair_rev)
39.814 +apply auto
39.815 +done
39.816 +
39.817 +lemma defined_spair:
39.818 + "[|a~=UU; b~=UU|] ==> (:a,b:) ~= UU"
39.819 +apply (unfold spair_def)
39.820 +apply (subst beta_cfun_sprod)
39.821 +apply (subst inst_sprod_pcpo)
39.822 +apply (erule defined_Ispair)
39.823 +apply assumption
39.824 +done
39.825 +
39.826 +lemma Exh_Sprod2:
39.827 + "z=UU | (? a b. z=(:a,b:) & a~=UU & b~=UU)"
39.828 +apply (unfold spair_def)
39.829 +apply (rule Exh_Sprod [THEN disjE])
39.830 +apply (rule disjI1)
39.831 +apply (subst inst_sprod_pcpo)
39.832 +apply assumption
39.833 +apply (rule disjI2)
39.834 +apply (erule exE)
39.835 +apply (erule exE)
39.836 +apply (rule exI)
39.837 +apply (rule exI)
39.838 +apply (rule conjI)
39.839 +apply (subst beta_cfun_sprod)
39.840 +apply fast
39.841 +apply fast
39.842 +done
39.843 +
39.844 +
39.845 +lemma sprodE:
39.846 +assumes prem1: "p=UU ==> Q"
39.847 +assumes prem2: "!!x y. [| p=(:x,y:); x~=UU; y~=UU|] ==> Q"
39.848 +shows "Q"
39.849 +apply (rule IsprodE)
39.850 +apply (rule prem1)
39.851 +apply (subst inst_sprod_pcpo)
39.852 +apply assumption
39.853 +apply (rule prem2)
39.854 +prefer 2 apply (assumption)
39.855 +prefer 2 apply (assumption)
39.856 +apply (unfold spair_def)
39.857 +apply (subst beta_cfun_sprod)
39.858 +apply assumption
39.859 +done
39.860 +
39.861 +
39.862 +lemma strict_sfst:
39.863 + "p=UU==>sfst$p=UU"
39.864 +apply (unfold sfst_def)
39.865 +apply (subst beta_cfun)
39.866 +apply (rule cont_Isfst)
39.867 +apply (rule strict_Isfst)
39.868 +apply (rule inst_sprod_pcpo [THEN subst])
39.869 +apply assumption
39.870 +done
39.871 +
39.872 +lemma strict_sfst1:
39.873 + "sfst$(:UU,y:) = UU"
39.874 +apply (unfold sfst_def spair_def)
39.875 +apply (subst beta_cfun_sprod)
39.876 +apply (subst beta_cfun)
39.877 +apply (rule cont_Isfst)
39.878 +apply (rule strict_Isfst1)
39.879 +done
39.880 +
39.881 +lemma strict_sfst2:
39.882 + "sfst$(:x,UU:) = UU"
39.883 +apply (unfold sfst_def spair_def)
39.884 +apply (subst beta_cfun_sprod)
39.885 +apply (subst beta_cfun)
39.886 +apply (rule cont_Isfst)
39.887 +apply (rule strict_Isfst2)
39.888 +done
39.889 +
39.890 +lemma strict_ssnd:
39.891 + "p=UU==>ssnd$p=UU"
39.892 +apply (unfold ssnd_def)
39.893 +apply (subst beta_cfun)
39.894 +apply (rule cont_Issnd)
39.895 +apply (rule strict_Issnd)
39.896 +apply (rule inst_sprod_pcpo [THEN subst])
39.897 +apply assumption
39.898 +done
39.899 +
39.900 +lemma strict_ssnd1:
39.901 + "ssnd$(:UU,y:) = UU"
39.902 +apply (unfold ssnd_def spair_def)
39.903 +apply (subst beta_cfun_sprod)
39.904 +apply (subst beta_cfun)
39.905 +apply (rule cont_Issnd)
39.906 +apply (rule strict_Issnd1)
39.907 +done
39.908 +
39.909 +lemma strict_ssnd2:
39.910 + "ssnd$(:x,UU:) = UU"
39.911 +apply (unfold ssnd_def spair_def)
39.912 +apply (subst beta_cfun_sprod)
39.913 +apply (subst beta_cfun)
39.914 +apply (rule cont_Issnd)
39.915 +apply (rule strict_Issnd2)
39.916 +done
39.917 +
39.918 +lemma sfst2:
39.919 + "y~=UU ==>sfst$(:x,y:)=x"
39.920 +apply (unfold sfst_def spair_def)
39.921 +apply (subst beta_cfun_sprod)
39.922 +apply (subst beta_cfun)
39.923 +apply (rule cont_Isfst)
39.924 +apply (erule Isfst2)
39.925 +done
39.926 +
39.927 +lemma ssnd2:
39.928 + "x~=UU ==>ssnd$(:x,y:)=y"
39.929 +apply (unfold ssnd_def spair_def)
39.930 +apply (subst beta_cfun_sprod)
39.931 +apply (subst beta_cfun)
39.932 +apply (rule cont_Issnd)
39.933 +apply (erule Issnd2)
39.934 +done
39.935 +
39.936 +
39.937 +lemma defined_sfstssnd:
39.938 + "p~=UU ==> sfst$p ~=UU & ssnd$p ~=UU"
39.939 +apply (unfold sfst_def ssnd_def spair_def)
39.940 +apply (simplesubst beta_cfun)
39.941 +apply (rule cont_Issnd)
39.942 +apply (subst beta_cfun)
39.943 +apply (rule cont_Isfst)
39.944 +apply (rule defined_IsfstIssnd)
39.945 +apply (rule inst_sprod_pcpo [THEN subst])
39.946 +apply assumption
39.947 +done
39.948 +
39.949 +lemma surjective_pairing_Sprod2: "(:sfst$p , ssnd$p:) = p"
39.950 +apply (unfold sfst_def ssnd_def spair_def)
39.951 +apply (subst beta_cfun_sprod)
39.952 +apply (simplesubst beta_cfun)
39.953 +apply (rule cont_Issnd)
39.954 +apply (subst beta_cfun)
39.955 +apply (rule cont_Isfst)
39.956 +apply (rule surjective_pairing_Sprod [symmetric])
39.957 +done
39.958 +
39.959 +lemma lub_sprod2:
39.960 +"chain(S) ==> range(S) <<|
39.961 + (: lub(range(%i. sfst$(S i))), lub(range(%i. ssnd$(S i))) :)"
39.962 +apply (unfold sfst_def ssnd_def spair_def)
39.963 +apply (subst beta_cfun_sprod)
39.964 +apply (simplesubst beta_cfun [THEN ext])
39.965 +apply (rule cont_Issnd)
39.966 +apply (subst beta_cfun [THEN ext])
39.967 +apply (rule cont_Isfst)
39.968 +apply (erule lub_sprod)
39.969 +done
39.970 +
39.971 +
39.972 +lemmas thelub_sprod2 = lub_sprod2 [THEN thelubI, standard]
39.973 +(*
39.974 + "chain ?S1 ==>
39.975 + lub (range ?S1) =
39.976 + (:lub (range (%i. sfst$(?S1 i))), lub (range (%i. ssnd$(?S1 i))):)" : thm
39.977 +*)
39.978 +
39.979 +lemma ssplit1:
39.980 + "ssplit$f$UU=UU"
39.981 +apply (unfold ssplit_def)
39.982 +apply (subst beta_cfun)
39.983 +apply (simp (no_asm))
39.984 +apply (subst strictify1)
39.985 +apply (rule refl)
39.986 +done
39.987 +
39.988 +lemma ssplit2:
39.989 + "[|x~=UU;y~=UU|] ==> ssplit$f$(:x,y:)= f$x$y"
39.990 +apply (unfold ssplit_def)
39.991 +apply (subst beta_cfun)
39.992 +apply (simp (no_asm))
39.993 +apply (subst strictify2)
39.994 +apply (rule defined_spair)
39.995 +apply assumption
39.996 +apply assumption
39.997 +apply (subst beta_cfun)
39.998 +apply (simp (no_asm))
39.999 +apply (subst sfst2)
39.1000 +apply assumption
39.1001 +apply (subst ssnd2)
39.1002 +apply assumption
39.1003 +apply (rule refl)
39.1004 +done
39.1005 +
39.1006 +
39.1007 +lemma ssplit3:
39.1008 + "ssplit$spair$z=z"
39.1009 +apply (unfold ssplit_def)
39.1010 +apply (subst beta_cfun)
39.1011 +apply (simp (no_asm))
39.1012 +apply (case_tac "z=UU")
39.1013 +apply (erule ssubst)
39.1014 +apply (rule strictify1)
39.1015 +apply (rule trans)
39.1016 +apply (rule strictify2)
39.1017 +apply assumption
39.1018 +apply (subst beta_cfun)
39.1019 +apply (simp (no_asm))
39.1020 +apply (rule surjective_pairing_Sprod2)
39.1021 +done
39.1022 +
39.1023 +(* ------------------------------------------------------------------------ *)
39.1024 +(* install simplifier for Sprod *)
39.1025 +(* ------------------------------------------------------------------------ *)
39.1026 +
39.1027 +lemmas Sprod_rews = strict_sfst1 strict_sfst2
39.1028 + strict_ssnd1 strict_ssnd2 sfst2 ssnd2 defined_spair
39.1029 + ssplit1 ssplit2
39.1030 +declare Sprod_rews [simp]
39.1031 +
39.1032 +end
40.1 --- a/src/HOLCF/Sprod0.ML Fri Mar 04 18:53:46 2005 +0100
40.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
40.3 @@ -1,35 +0,0 @@
40.4 -
40.5 -(* legacy ML bindings *)
40.6 -
40.7 -val Ispair_def = thm "Ispair_def";
40.8 -val Isfst_def = thm "Isfst_def";
40.9 -val Issnd_def = thm "Issnd_def";
40.10 -val SprodI = thm "SprodI";
40.11 -val inj_on_Abs_Sprod = thm "inj_on_Abs_Sprod";
40.12 -val strict_Spair_Rep = thm "strict_Spair_Rep";
40.13 -val defined_Spair_Rep_rev = thm "defined_Spair_Rep_rev";
40.14 -val inject_Spair_Rep = thm "inject_Spair_Rep";
40.15 -val inject_Ispair = thm "inject_Ispair";
40.16 -val strict_Ispair = thm "strict_Ispair";
40.17 -val strict_Ispair1 = thm "strict_Ispair1";
40.18 -val strict_Ispair2 = thm "strict_Ispair2";
40.19 -val strict_Ispair_rev = thm "strict_Ispair_rev";
40.20 -val defined_Ispair_rev = thm "defined_Ispair_rev";
40.21 -val defined_Ispair = thm "defined_Ispair";
40.22 -val Exh_Sprod = thm "Exh_Sprod";
40.23 -val IsprodE = thm "IsprodE";
40.24 -val strict_Isfst = thm "strict_Isfst";
40.25 -val strict_Isfst1 = thm "strict_Isfst1";
40.26 -val strict_Isfst2 = thm "strict_Isfst2";
40.27 -val strict_Issnd = thm "strict_Issnd";
40.28 -val strict_Issnd1 = thm "strict_Issnd1";
40.29 -val strict_Issnd2 = thm "strict_Issnd2";
40.30 -val Isfst = thm "Isfst";
40.31 -val Issnd = thm "Issnd";
40.32 -val Isfst2 = thm "Isfst2";
40.33 -val Issnd2 = thm "Issnd2";
40.34 -val Sprod0_ss = [strict_Isfst1, strict_Isfst2, strict_Issnd1, strict_Issnd2,
40.35 - Isfst2, Issnd2]
40.36 -val defined_IsfstIssnd = thm "defined_IsfstIssnd";
40.37 -val surjective_pairing_Sprod = thm "surjective_pairing_Sprod";
40.38 -val Sel_injective_Sprod = thm "Sel_injective_Sprod";
41.1 --- a/src/HOLCF/Sprod0.thy Fri Mar 04 18:53:46 2005 +0100
41.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
41.3 @@ -1,353 +0,0 @@
41.4 -(* Title: HOLCF/Sprod0.thy
41.5 - ID: $Id$
41.6 - Author: Franz Regensburger
41.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
41.8 -
41.9 -Strict product with typedef.
41.10 -*)
41.11 -
41.12 -theory Sprod0 = Cfun3:
41.13 -
41.14 -constdefs
41.15 - Spair_Rep :: "['a,'b] => ['a,'b] => bool"
41.16 - "Spair_Rep == (%a b. %x y.(~a=UU & ~b=UU --> x=a & y=b ))"
41.17 -
41.18 -typedef (Sprod) ('a, 'b) "**" (infixr 20) = "{f. ? a b. f = Spair_Rep (a::'a) (b::'b)}"
41.19 -by auto
41.20 -
41.21 -syntax (xsymbols)
41.22 - "**" :: "[type, type] => type" ("(_ \<otimes>/ _)" [21,20] 20)
41.23 -syntax (HTML output)
41.24 - "**" :: "[type, type] => type" ("(_ \<otimes>/ _)" [21,20] 20)
41.25 -
41.26 -consts
41.27 - Ispair :: "['a,'b] => ('a ** 'b)"
41.28 - Isfst :: "('a ** 'b) => 'a"
41.29 - Issnd :: "('a ** 'b) => 'b"
41.30 -
41.31 -defs
41.32 - (*defining the abstract constants*)
41.33 -
41.34 - Ispair_def: "Ispair a b == Abs_Sprod(Spair_Rep a b)"
41.35 -
41.36 - Isfst_def: "Isfst(p) == @z. (p=Ispair UU UU --> z=UU)
41.37 - &(! a b. ~a=UU & ~b=UU & p=Ispair a b --> z=a)"
41.38 -
41.39 - Issnd_def: "Issnd(p) == @z. (p=Ispair UU UU --> z=UU)
41.40 - &(! a b. ~a=UU & ~b=UU & p=Ispair a b --> z=b)"
41.41 -
41.42 -(* Title: HOLCF/Sprod0
41.43 - ID: $Id$
41.44 - Author: Franz Regensburger
41.45 - License: GPL (GNU GENERAL PUBLIC LICENSE)
41.46 -
41.47 -Strict product with typedef.
41.48 -*)
41.49 -
41.50 -(* ------------------------------------------------------------------------ *)
41.51 -(* A non-emptyness result for Sprod *)
41.52 -(* ------------------------------------------------------------------------ *)
41.53 -
41.54 -lemma SprodI: "(Spair_Rep a b):Sprod"
41.55 -apply (unfold Sprod_def)
41.56 -apply (rule CollectI, rule exI, rule exI, rule refl)
41.57 -done
41.58 -
41.59 -lemma inj_on_Abs_Sprod: "inj_on Abs_Sprod Sprod"
41.60 -apply (rule inj_on_inverseI)
41.61 -apply (erule Abs_Sprod_inverse)
41.62 -done
41.63 -
41.64 -(* ------------------------------------------------------------------------ *)
41.65 -(* Strictness and definedness of Spair_Rep *)
41.66 -(* ------------------------------------------------------------------------ *)
41.67 -
41.68 -lemma strict_Spair_Rep:
41.69 - "(a=UU | b=UU) ==> (Spair_Rep a b) = (Spair_Rep UU UU)"
41.70 -apply (unfold Spair_Rep_def)
41.71 -apply (rule ext)
41.72 -apply (rule ext)
41.73 -apply (rule iffI)
41.74 -apply fast
41.75 -apply fast
41.76 -done
41.77 -
41.78 -lemma defined_Spair_Rep_rev:
41.79 - "(Spair_Rep a b) = (Spair_Rep UU UU) ==> (a=UU | b=UU)"
41.80 -apply (unfold Spair_Rep_def)
41.81 -apply (case_tac "a=UU|b=UU")
41.82 -apply assumption
41.83 -apply (fast dest: fun_cong)
41.84 -done
41.85 -
41.86 -(* ------------------------------------------------------------------------ *)
41.87 -(* injectivity of Spair_Rep and Ispair *)
41.88 -(* ------------------------------------------------------------------------ *)
41.89 -
41.90 -lemma inject_Spair_Rep:
41.91 -"[|~aa=UU ; ~ba=UU ; Spair_Rep a b = Spair_Rep aa ba |] ==> a=aa & b=ba"
41.92 -
41.93 -apply (unfold Spair_Rep_def)
41.94 -apply (drule fun_cong)
41.95 -apply (drule fun_cong)
41.96 -apply (erule iffD1 [THEN mp])
41.97 -apply auto
41.98 -done
41.99 -
41.100 -
41.101 -lemma inject_Ispair:
41.102 - "[|~aa=UU ; ~ba=UU ; Ispair a b = Ispair aa ba |] ==> a=aa & b=ba"
41.103 -apply (unfold Ispair_def)
41.104 -apply (erule inject_Spair_Rep)
41.105 -apply assumption
41.106 -apply (erule inj_on_Abs_Sprod [THEN inj_onD])
41.107 -apply (rule SprodI)
41.108 -apply (rule SprodI)
41.109 -done
41.110 -
41.111 -
41.112 -(* ------------------------------------------------------------------------ *)
41.113 -(* strictness and definedness of Ispair *)
41.114 -(* ------------------------------------------------------------------------ *)
41.115 -
41.116 -lemma strict_Ispair:
41.117 - "(a=UU | b=UU) ==> Ispair a b = Ispair UU UU"
41.118 -apply (unfold Ispair_def)
41.119 -apply (erule strict_Spair_Rep [THEN arg_cong])
41.120 -done
41.121 -
41.122 -lemma strict_Ispair1:
41.123 - "Ispair UU b = Ispair UU UU"
41.124 -apply (unfold Ispair_def)
41.125 -apply (rule strict_Spair_Rep [THEN arg_cong])
41.126 -apply (rule disjI1)
41.127 -apply (rule refl)
41.128 -done
41.129 -
41.130 -lemma strict_Ispair2:
41.131 - "Ispair a UU = Ispair UU UU"
41.132 -apply (unfold Ispair_def)
41.133 -apply (rule strict_Spair_Rep [THEN arg_cong])
41.134 -apply (rule disjI2)
41.135 -apply (rule refl)
41.136 -done
41.137 -
41.138 -lemma strict_Ispair_rev: "~Ispair x y = Ispair UU UU ==> ~x=UU & ~y=UU"
41.139 -apply (rule de_Morgan_disj [THEN subst])
41.140 -apply (erule contrapos_nn)
41.141 -apply (erule strict_Ispair)
41.142 -done
41.143 -
41.144 -lemma defined_Ispair_rev:
41.145 - "Ispair a b = Ispair UU UU ==> (a = UU | b = UU)"
41.146 -apply (unfold Ispair_def)
41.147 -apply (rule defined_Spair_Rep_rev)
41.148 -apply (rule inj_on_Abs_Sprod [THEN inj_onD])
41.149 -apply assumption
41.150 -apply (rule SprodI)
41.151 -apply (rule SprodI)
41.152 -done
41.153 -
41.154 -lemma defined_Ispair: "[|a~=UU; b~=UU|] ==> (Ispair a b) ~= (Ispair UU UU)"
41.155 -apply (rule contrapos_nn)
41.156 -apply (erule_tac [2] defined_Ispair_rev)
41.157 -apply (rule de_Morgan_disj [THEN iffD2])
41.158 -apply (erule conjI)
41.159 -apply assumption
41.160 -done
41.161 -
41.162 -
41.163 -(* ------------------------------------------------------------------------ *)
41.164 -(* Exhaustion of the strict product ** *)
41.165 -(* ------------------------------------------------------------------------ *)
41.166 -
41.167 -lemma Exh_Sprod:
41.168 - "z=Ispair UU UU | (? a b. z=Ispair a b & a~=UU & b~=UU)"
41.169 -apply (unfold Ispair_def)
41.170 -apply (rule Rep_Sprod[unfolded Sprod_def, THEN CollectE])
41.171 -apply (erule exE)
41.172 -apply (erule exE)
41.173 -apply (rule excluded_middle [THEN disjE])
41.174 -apply (rule disjI2)
41.175 -apply (rule exI)
41.176 -apply (rule exI)
41.177 -apply (rule conjI)
41.178 -apply (rule Rep_Sprod_inverse [symmetric, THEN trans])
41.179 -apply (erule arg_cong)
41.180 -apply (rule de_Morgan_disj [THEN subst])
41.181 -apply assumption
41.182 -apply (rule disjI1)
41.183 -apply (rule Rep_Sprod_inverse [symmetric, THEN trans])
41.184 -apply (rule_tac f = "Abs_Sprod" in arg_cong)
41.185 -apply (erule trans)
41.186 -apply (erule strict_Spair_Rep)
41.187 -done
41.188 -
41.189 -(* ------------------------------------------------------------------------ *)
41.190 -(* general elimination rule for strict product *)
41.191 -(* ------------------------------------------------------------------------ *)
41.192 -
41.193 -lemma IsprodE:
41.194 -assumes prem1: "p=Ispair UU UU ==> Q"
41.195 -assumes prem2: "!!x y. [|p=Ispair x y; x~=UU ; y~=UU|] ==> Q"
41.196 -shows "Q"
41.197 -apply (rule Exh_Sprod [THEN disjE])
41.198 -apply (erule prem1)
41.199 -apply (erule exE)
41.200 -apply (erule exE)
41.201 -apply (erule conjE)
41.202 -apply (erule conjE)
41.203 -apply (erule prem2)
41.204 -apply assumption
41.205 -apply assumption
41.206 -done
41.207 -
41.208 -
41.209 -(* ------------------------------------------------------------------------ *)
41.210 -(* some results about the selectors Isfst, Issnd *)
41.211 -(* ------------------------------------------------------------------------ *)
41.212 -
41.213 -lemma strict_Isfst: "p=Ispair UU UU ==> Isfst p = UU"
41.214 -apply (unfold Isfst_def)
41.215 -apply (rule some_equality)
41.216 -apply (rule conjI)
41.217 -apply fast
41.218 -apply (intro strip)
41.219 -apply (rule_tac P = "Ispair UU UU = Ispair a b" in notE)
41.220 -apply (rule not_sym)
41.221 -apply (rule defined_Ispair)
41.222 -apply (fast+)
41.223 -done
41.224 -
41.225 -
41.226 -lemma strict_Isfst1: "Isfst(Ispair UU y) = UU"
41.227 -apply (subst strict_Ispair1)
41.228 -apply (rule strict_Isfst)
41.229 -apply (rule refl)
41.230 -done
41.231 -
41.232 -declare strict_Isfst1 [simp]
41.233 -
41.234 -lemma strict_Isfst2: "Isfst(Ispair x UU) = UU"
41.235 -apply (subst strict_Ispair2)
41.236 -apply (rule strict_Isfst)
41.237 -apply (rule refl)
41.238 -done
41.239 -
41.240 -declare strict_Isfst2 [simp]
41.241 -
41.242 -
41.243 -lemma strict_Issnd: "p=Ispair UU UU ==>Issnd p=UU"
41.244 -
41.245 -apply (unfold Issnd_def)
41.246 -apply (rule some_equality)
41.247 -apply (rule conjI)
41.248 -apply fast
41.249 -apply (intro strip)
41.250 -apply (rule_tac P = "Ispair UU UU = Ispair a b" in notE)
41.251 -apply (rule not_sym)
41.252 -apply (rule defined_Ispair)
41.253 -apply (fast+)
41.254 -done
41.255 -
41.256 -lemma strict_Issnd1: "Issnd(Ispair UU y) = UU"
41.257 -apply (subst strict_Ispair1)
41.258 -apply (rule strict_Issnd)
41.259 -apply (rule refl)
41.260 -done
41.261 -
41.262 -declare strict_Issnd1 [simp]
41.263 -
41.264 -lemma strict_Issnd2: "Issnd(Ispair x UU) = UU"
41.265 -apply (subst strict_Ispair2)
41.266 -apply (rule strict_Issnd)
41.267 -apply (rule refl)
41.268 -done
41.269 -
41.270 -declare strict_Issnd2 [simp]
41.271 -
41.272 -lemma Isfst: "[|x~=UU ;y~=UU |] ==> Isfst(Ispair x y) = x"
41.273 -apply (unfold Isfst_def)
41.274 -apply (rule some_equality)
41.275 -apply (rule conjI)
41.276 -apply (intro strip)
41.277 -apply (rule_tac P = "Ispair x y = Ispair UU UU" in notE)
41.278 -apply (erule defined_Ispair)
41.279 -apply assumption
41.280 -apply assumption
41.281 -apply (intro strip)
41.282 -apply (rule inject_Ispair [THEN conjunct1])
41.283 -prefer 3 apply fast
41.284 -apply (fast+)
41.285 -done
41.286 -
41.287 -lemma Issnd: "[|x~=UU ;y~=UU |] ==> Issnd(Ispair x y) = y"
41.288 -apply (unfold Issnd_def)
41.289 -apply (rule some_equality)
41.290 -apply (rule conjI)
41.291 -apply (intro strip)
41.292 -apply (rule_tac P = "Ispair x y = Ispair UU UU" in notE)
41.293 -apply (erule defined_Ispair)
41.294 -apply assumption
41.295 -apply assumption
41.296 -apply (intro strip)
41.297 -apply (rule inject_Ispair [THEN conjunct2])
41.298 -prefer 3 apply fast
41.299 -apply (fast+)
41.300 -done
41.301 -
41.302 -lemma Isfst2: "y~=UU ==>Isfst(Ispair x y)=x"
41.303 -apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
41.304 -apply (erule Isfst)
41.305 -apply assumption
41.306 -apply (erule ssubst)
41.307 -apply (rule strict_Isfst1)
41.308 -done
41.309 -
41.310 -lemma Issnd2: "~x=UU ==>Issnd(Ispair x y)=y"
41.311 -apply (rule_tac Q = "y=UU" in excluded_middle [THEN disjE])
41.312 -apply (erule Issnd)
41.313 -apply assumption
41.314 -apply (erule ssubst)
41.315 -apply (rule strict_Issnd2)
41.316 -done
41.317 -
41.318 -
41.319 -(* ------------------------------------------------------------------------ *)
41.320 -(* instantiate the simplifier *)
41.321 -(* ------------------------------------------------------------------------ *)
41.322 -
41.323 -lemmas Sprod0_ss = strict_Isfst1 strict_Isfst2 strict_Issnd1 strict_Issnd2
41.324 - Isfst2 Issnd2
41.325 -
41.326 -declare Isfst2 [simp] Issnd2 [simp]
41.327 -
41.328 -lemma defined_IsfstIssnd: "p~=Ispair UU UU ==> Isfst p ~= UU & Issnd p ~= UU"
41.329 -apply (rule_tac p = "p" in IsprodE)
41.330 -apply simp
41.331 -apply (erule ssubst)
41.332 -apply (rule conjI)
41.333 -apply (simp add: Sprod0_ss)
41.334 -apply (simp add: Sprod0_ss)
41.335 -done
41.336 -
41.337 -
41.338 -(* ------------------------------------------------------------------------ *)
41.339 -(* Surjective pairing: equivalent to Exh_Sprod *)
41.340 -(* ------------------------------------------------------------------------ *)
41.341 -
41.342 -lemma surjective_pairing_Sprod: "z = Ispair(Isfst z)(Issnd z)"
41.343 -apply (rule_tac z1 = "z" in Exh_Sprod [THEN disjE])
41.344 -apply (simp add: Sprod0_ss)
41.345 -apply (erule exE)
41.346 -apply (erule exE)
41.347 -apply (simp add: Sprod0_ss)
41.348 -done
41.349 -
41.350 -lemma Sel_injective_Sprod: "[|Isfst x = Isfst y; Issnd x = Issnd y|] ==> x = y"
41.351 -apply (subgoal_tac "Ispair (Isfst x) (Issnd x) =Ispair (Isfst y) (Issnd y) ")
41.352 -apply (simp (no_asm_use) add: surjective_pairing_Sprod[symmetric])
41.353 -apply simp
41.354 -done
41.355 -
41.356 -end
42.1 --- a/src/HOLCF/Sprod1.ML Fri Mar 04 18:53:46 2005 +0100
42.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
42.3 @@ -1,7 +0,0 @@
42.4 -
42.5 -(* legacy ML bindings *)
42.6 -
42.7 -val less_sprod_def = thm "less_sprod_def";
42.8 -val refl_less_sprod = thm "refl_less_sprod";
42.9 -val antisym_less_sprod = thm "antisym_less_sprod";
42.10 -val trans_less_sprod = thm "trans_less_sprod";
43.1 --- a/src/HOLCF/Sprod1.thy Fri Mar 04 18:53:46 2005 +0100
43.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
43.3 @@ -1,46 +0,0 @@
43.4 -(* Title: HOLCF/sprod1.thy
43.5 - ID: $Id$
43.6 - Author: Franz Regensburger
43.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
43.8 -
43.9 -Partial ordering for the strict product.
43.10 -*)
43.11 -
43.12 -theory Sprod1 = Sprod0:
43.13 -
43.14 -instance "**"::(sq_ord,sq_ord)sq_ord ..
43.15 -
43.16 -defs (overloaded)
43.17 - less_sprod_def: "p1 << p2 == Isfst p1 << Isfst p2 & Issnd p1 << Issnd p2"
43.18 -
43.19 -(* Title: HOLCF/Sprod1.ML
43.20 - ID: $Id$
43.21 - Author: Franz Regensburger
43.22 - License: GPL (GNU GENERAL PUBLIC LICENSE)
43.23 -*)
43.24 -
43.25 -(* ------------------------------------------------------------------------ *)
43.26 -(* less_sprod is a partial order on Sprod *)
43.27 -(* ------------------------------------------------------------------------ *)
43.28 -
43.29 -lemma refl_less_sprod: "(p::'a ** 'b) << p"
43.30 -
43.31 -apply (unfold less_sprod_def)
43.32 -apply (fast intro: refl_less)
43.33 -done
43.34 -
43.35 -lemma antisym_less_sprod:
43.36 - "[|(p1::'a ** 'b) << p2;p2 << p1|] ==> p1=p2"
43.37 -apply (unfold less_sprod_def)
43.38 -apply (rule Sel_injective_Sprod)
43.39 -apply (fast intro: antisym_less)
43.40 -apply (fast intro: antisym_less)
43.41 -done
43.42 -
43.43 -lemma trans_less_sprod:
43.44 - "[|(p1::'a**'b) << p2;p2 << p3|] ==> p1 << p3"
43.45 -apply (unfold less_sprod_def)
43.46 -apply (blast intro: trans_less)
43.47 -done
43.48 -
43.49 -end
44.1 --- a/src/HOLCF/Sprod2.ML Fri Mar 04 18:53:46 2005 +0100
44.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
44.3 @@ -1,15 +0,0 @@
44.4 -
44.5 -(* legacy ML bindings *)
44.6 -
44.7 -val inst_sprod_po = thm "inst_sprod_po";
44.8 -val minimal_sprod = thm "minimal_sprod";
44.9 -val UU_sprod_def = thm "UU_sprod_def";
44.10 -val least_sprod = thm "least_sprod";
44.11 -val monofun_Ispair1 = thm "monofun_Ispair1";
44.12 -val monofun_Ispair2 = thm "monofun_Ispair2";
44.13 -val monofun_Ispair = thm "monofun_Ispair";
44.14 -val monofun_Isfst = thm "monofun_Isfst";
44.15 -val monofun_Issnd = thm "monofun_Issnd";
44.16 -val lub_sprod = thm "lub_sprod";
44.17 -val thelub_sprod = thm "thelub_sprod";
44.18 -val cpo_sprod = thm "cpo_sprod";
45.1 --- a/src/HOLCF/Sprod2.thy Fri Mar 04 18:53:46 2005 +0100
45.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
45.3 @@ -1,132 +0,0 @@
45.4 -(* Title: HOLCF/Sprod2.thy
45.5 - ID: $Id$
45.6 - Author: Franz Regensburger
45.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
45.8 -
45.9 -Class Instance **::(pcpo,pcpo)po
45.10 -*)
45.11 -
45.12 -theory Sprod2 = Sprod1:
45.13 -
45.14 -instance "**"::(pcpo,pcpo)po
45.15 -apply (intro_classes)
45.16 -apply (rule refl_less_sprod)
45.17 -apply (rule antisym_less_sprod, assumption+)
45.18 -apply (rule trans_less_sprod, assumption+)
45.19 -done
45.20 -
45.21 -(* Title: HOLCF/Sprod2.ML
45.22 - ID: $Id$
45.23 - Author: Franz Regensburger
45.24 - License: GPL (GNU GENERAL PUBLIC LICENSE)
45.25 -
45.26 -Class Instance **::(pcpo,pcpo)po
45.27 -*)
45.28 -
45.29 -(* for compatibility with old HOLCF-Version *)
45.30 -lemma inst_sprod_po: "(op <<)=(%x y. Isfst x<<Isfst y&Issnd x<<Issnd y)"
45.31 -apply (fold less_sprod_def)
45.32 -apply (rule refl)
45.33 -done
45.34 -
45.35 -(* ------------------------------------------------------------------------ *)
45.36 -(* type sprod is pointed *)
45.37 -(* ------------------------------------------------------------------------ *)
45.38 -
45.39 -lemma minimal_sprod: "Ispair UU UU << p"
45.40 -apply (simp add: inst_sprod_po minimal)
45.41 -done
45.42 -
45.43 -lemmas UU_sprod_def = minimal_sprod [THEN minimal2UU, symmetric, standard]
45.44 -
45.45 -lemma least_sprod: "? x::'a**'b.!y. x<<y"
45.46 -apply (rule_tac x = "Ispair UU UU" in exI)
45.47 -apply (rule minimal_sprod [THEN allI])
45.48 -done
45.49 -
45.50 -(* ------------------------------------------------------------------------ *)
45.51 -(* Ispair is monotone in both arguments *)
45.52 -(* ------------------------------------------------------------------------ *)
45.53 -
45.54 -lemma monofun_Ispair1: "monofun(Ispair)"
45.55 -
45.56 -apply (unfold monofun)
45.57 -apply (intro strip)
45.58 -apply (rule less_fun [THEN iffD2])
45.59 -apply (intro strip)
45.60 -apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
45.61 -apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
45.62 -apply (frule notUU_I)
45.63 -apply assumption
45.64 -apply (simp_all add: Sprod0_ss inst_sprod_po refl_less minimal)
45.65 -done
45.66 -
45.67 -lemma monofun_Ispair2: "monofun(Ispair(x))"
45.68 -apply (unfold monofun)
45.69 -apply (intro strip)
45.70 -apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
45.71 -apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
45.72 -apply (frule notUU_I)
45.73 -apply assumption
45.74 -apply (simp_all add: Sprod0_ss inst_sprod_po refl_less minimal)
45.75 -done
45.76 -
45.77 -lemma monofun_Ispair: "[|x1<<x2; y1<<y2|] ==> Ispair x1 y1 << Ispair x2 y2"
45.78 -apply (rule trans_less)
45.79 -apply (rule monofun_Ispair1 [THEN monofunE, THEN spec, THEN spec, THEN mp, THEN less_fun [THEN iffD1, THEN spec]])
45.80 -prefer 2 apply (rule monofun_Ispair2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
45.81 -apply assumption
45.82 -apply assumption
45.83 -done
45.84 -
45.85 -(* ------------------------------------------------------------------------ *)
45.86 -(* Isfst and Issnd are monotone *)
45.87 -(* ------------------------------------------------------------------------ *)
45.88 -
45.89 -lemma monofun_Isfst: "monofun(Isfst)"
45.90 -
45.91 -apply (unfold monofun)
45.92 -apply (simp add: inst_sprod_po)
45.93 -done
45.94 -
45.95 -lemma monofun_Issnd: "monofun(Issnd)"
45.96 -apply (unfold monofun)
45.97 -apply (simp add: inst_sprod_po)
45.98 -done
45.99 -
45.100 -(* ------------------------------------------------------------------------ *)
45.101 -(* the type 'a ** 'b is a cpo *)
45.102 -(* ------------------------------------------------------------------------ *)
45.103 -
45.104 -lemma lub_sprod:
45.105 -"[|chain(S)|] ==> range(S) <<|
45.106 - Ispair (lub(range(%i. Isfst(S i)))) (lub(range(%i. Issnd(S i))))"
45.107 -apply (rule is_lubI)
45.108 -apply (rule ub_rangeI)
45.109 -apply (rule_tac t = "S (i) " in surjective_pairing_Sprod [THEN ssubst])
45.110 -apply (rule monofun_Ispair)
45.111 -apply (rule is_ub_thelub)
45.112 -apply (erule monofun_Isfst [THEN ch2ch_monofun])
45.113 -apply (rule is_ub_thelub)
45.114 -apply (erule monofun_Issnd [THEN ch2ch_monofun])
45.115 -apply (rule_tac t = "u" in surjective_pairing_Sprod [THEN ssubst])
45.116 -apply (rule monofun_Ispair)
45.117 -apply (rule is_lub_thelub)
45.118 -apply (erule monofun_Isfst [THEN ch2ch_monofun])
45.119 -apply (erule monofun_Isfst [THEN ub2ub_monofun])
45.120 -apply (rule is_lub_thelub)
45.121 -apply (erule monofun_Issnd [THEN ch2ch_monofun])
45.122 -apply (erule monofun_Issnd [THEN ub2ub_monofun])
45.123 -done
45.124 -
45.125 -lemmas thelub_sprod = lub_sprod [THEN thelubI, standard]
45.126 -
45.127 -
45.128 -lemma cpo_sprod: "chain(S::nat=>'a**'b)==>? x. range(S)<<| x"
45.129 -apply (rule exI)
45.130 -apply (erule lub_sprod)
45.131 -done
45.132 -
45.133 -end
45.134 -
45.135 -
46.1 --- a/src/HOLCF/Sprod3.ML Fri Mar 04 18:53:46 2005 +0100
46.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
46.3 @@ -1,53 +0,0 @@
46.4 -
46.5 -(* legacy ML bindings *)
46.6 -
46.7 -val spair_def = thm "spair_def";
46.8 -val sfst_def = thm "sfst_def";
46.9 -val ssnd_def = thm "ssnd_def";
46.10 -val ssplit_def = thm "ssplit_def";
46.11 -val inst_sprod_pcpo = thm "inst_sprod_pcpo";
46.12 -val sprod3_lemma1 = thm "sprod3_lemma1";
46.13 -val sprod3_lemma2 = thm "sprod3_lemma2";
46.14 -val sprod3_lemma3 = thm "sprod3_lemma3";
46.15 -val contlub_Ispair1 = thm "contlub_Ispair1";
46.16 -val sprod3_lemma4 = thm "sprod3_lemma4";
46.17 -val sprod3_lemma5 = thm "sprod3_lemma5";
46.18 -val sprod3_lemma6 = thm "sprod3_lemma6";
46.19 -val contlub_Ispair2 = thm "contlub_Ispair2";
46.20 -val cont_Ispair1 = thm "cont_Ispair1";
46.21 -val cont_Ispair2 = thm "cont_Ispair2";
46.22 -val contlub_Isfst = thm "contlub_Isfst";
46.23 -val contlub_Issnd = thm "contlub_Issnd";
46.24 -val cont_Isfst = thm "cont_Isfst";
46.25 -val cont_Issnd = thm "cont_Issnd";
46.26 -val spair_eq = thm "spair_eq";
46.27 -val beta_cfun_sprod = thm "beta_cfun_sprod";
46.28 -val inject_spair = thm "inject_spair";
46.29 -val inst_sprod_pcpo2 = thm "inst_sprod_pcpo2";
46.30 -val strict_spair = thm "strict_spair";
46.31 -val strict_spair1 = thm "strict_spair1";
46.32 -val strict_spair2 = thm "strict_spair2";
46.33 -val strict_spair_rev = thm "strict_spair_rev";
46.34 -val defined_spair_rev = thm "defined_spair_rev";
46.35 -val defined_spair = thm "defined_spair";
46.36 -val Exh_Sprod2 = thm "Exh_Sprod2";
46.37 -val sprodE = thm "sprodE";
46.38 -val strict_sfst = thm "strict_sfst";
46.39 -val strict_sfst1 = thm "strict_sfst1";
46.40 -val strict_sfst2 = thm "strict_sfst2";
46.41 -val strict_ssnd = thm "strict_ssnd";
46.42 -val strict_ssnd1 = thm "strict_ssnd1";
46.43 -val strict_ssnd2 = thm "strict_ssnd2";
46.44 -val sfst2 = thm "sfst2";
46.45 -val ssnd2 = thm "ssnd2";
46.46 -val defined_sfstssnd = thm "defined_sfstssnd";
46.47 -val surjective_pairing_Sprod2 = thm "surjective_pairing_Sprod2";
46.48 -val lub_sprod2 = thm "lub_sprod2";
46.49 -val thelub_sprod2 = thm "thelub_sprod2";
46.50 -val ssplit1 = thm "ssplit1";
46.51 -val ssplit2 = thm "ssplit2";
46.52 -val ssplit3 = thm "ssplit3";
46.53 -val Sprod_rews = [strict_sfst1, strict_sfst2,
46.54 - strict_ssnd1, strict_ssnd2, sfst2, ssnd2, defined_spair,
46.55 - ssplit1, ssplit2]
46.56 -
47.1 --- a/src/HOLCF/Sprod3.thy Fri Mar 04 18:53:46 2005 +0100
47.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
47.3 @@ -1,565 +0,0 @@
47.4 -(* Title: HOLCF/sprod3.thy
47.5 - ID: $Id$
47.6 - Author: Franz Regensburger
47.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
47.8 -
47.9 -Class instance of ** for class pcpo
47.10 -*)
47.11 -
47.12 -theory Sprod3 = Sprod2:
47.13 -
47.14 -instance "**" :: (pcpo,pcpo)pcpo
47.15 -apply (intro_classes)
47.16 -apply (erule cpo_sprod)
47.17 -apply (rule least_sprod)
47.18 -done
47.19 -
47.20 -consts
47.21 - spair :: "'a -> 'b -> ('a**'b)" (* continuous strict pairing *)
47.22 - sfst :: "('a**'b)->'a"
47.23 - ssnd :: "('a**'b)->'b"
47.24 - ssplit :: "('a->'b->'c)->('a**'b)->'c"
47.25 -
47.26 -syntax
47.27 - "@stuple" :: "['a, args] => 'a ** 'b" ("(1'(:_,/ _:'))")
47.28 -
47.29 -translations
47.30 - "(:x, y, z:)" == "(:x, (:y, z:):)"
47.31 - "(:x, y:)" == "spair$x$y"
47.32 -
47.33 -defs
47.34 -spair_def: "spair == (LAM x y. Ispair x y)"
47.35 -sfst_def: "sfst == (LAM p. Isfst p)"
47.36 -ssnd_def: "ssnd == (LAM p. Issnd p)"
47.37 -ssplit_def: "ssplit == (LAM f. strictify$(LAM p. f$(sfst$p)$(ssnd$p)))"
47.38 -
47.39 -(* Title: HOLCF/Sprod3
47.40 - ID: $Id$
47.41 - Author: Franz Regensburger
47.42 - License: GPL (GNU GENERAL PUBLIC LICENSE)
47.43 -
47.44 -Class instance of ** for class pcpo
47.45 -*)
47.46 -
47.47 -(* for compatibility with old HOLCF-Version *)
47.48 -lemma inst_sprod_pcpo: "UU = Ispair UU UU"
47.49 -apply (simp add: UU_def UU_sprod_def)
47.50 -done
47.51 -
47.52 -declare inst_sprod_pcpo [symmetric, simp]
47.53 -
47.54 -(* ------------------------------------------------------------------------ *)
47.55 -(* continuity of Ispair, Isfst, Issnd *)
47.56 -(* ------------------------------------------------------------------------ *)
47.57 -
47.58 -lemma sprod3_lemma1:
47.59 -"[| chain(Y); x~= UU; lub(range(Y))~= UU |] ==>
47.60 - Ispair (lub(range Y)) x =
47.61 - Ispair (lub(range(%i. Isfst(Ispair(Y i) x))))
47.62 - (lub(range(%i. Issnd(Ispair(Y i) x))))"
47.63 -apply (rule_tac f1 = "Ispair" in arg_cong [THEN cong])
47.64 -apply (rule lub_equal)
47.65 -apply assumption
47.66 -apply (rule monofun_Isfst [THEN ch2ch_monofun])
47.67 -apply (rule ch2ch_fun)
47.68 -apply (rule monofun_Ispair1 [THEN ch2ch_monofun])
47.69 -apply assumption
47.70 -apply (rule allI)
47.71 -apply (simp (no_asm_simp))
47.72 -apply (rule sym)
47.73 -apply (drule chain_UU_I_inverse2)
47.74 -apply (erule exE)
47.75 -apply (rule lub_chain_maxelem)
47.76 -apply (erule Issnd2)
47.77 -apply (rule allI)
47.78 -apply (rename_tac "j")
47.79 -apply (case_tac "Y (j) =UU")
47.80 -apply auto
47.81 -done
47.82 -
47.83 -lemma sprod3_lemma2:
47.84 -"[| chain(Y); x ~= UU; lub(range(Y)) = UU |] ==>
47.85 - Ispair (lub(range Y)) x =
47.86 - Ispair (lub(range(%i. Isfst(Ispair(Y i) x))))
47.87 - (lub(range(%i. Issnd(Ispair(Y i) x))))"
47.88 -apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
47.89 -apply assumption
47.90 -apply (rule trans)
47.91 -apply (rule strict_Ispair1)
47.92 -apply (rule strict_Ispair [symmetric])
47.93 -apply (rule disjI1)
47.94 -apply (rule chain_UU_I_inverse)
47.95 -apply auto
47.96 -apply (erule chain_UU_I [THEN spec])
47.97 -apply assumption
47.98 -done
47.99 -
47.100 -
47.101 -lemma sprod3_lemma3:
47.102 -"[| chain(Y); x = UU |] ==>
47.103 - Ispair (lub(range Y)) x =
47.104 - Ispair (lub(range(%i. Isfst(Ispair (Y i) x))))
47.105 - (lub(range(%i. Issnd(Ispair (Y i) x))))"
47.106 -apply (erule ssubst)
47.107 -apply (rule trans)
47.108 -apply (rule strict_Ispair2)
47.109 -apply (rule strict_Ispair [symmetric])
47.110 -apply (rule disjI1)
47.111 -apply (rule chain_UU_I_inverse)
47.112 -apply (rule allI)
47.113 -apply (simp add: Sprod0_ss)
47.114 -done
47.115 -
47.116 -lemma contlub_Ispair1: "contlub(Ispair)"
47.117 -apply (rule contlubI)
47.118 -apply (intro strip)
47.119 -apply (rule expand_fun_eq [THEN iffD2])
47.120 -apply (intro strip)
47.121 -apply (subst lub_fun [THEN thelubI])
47.122 -apply (erule monofun_Ispair1 [THEN ch2ch_monofun])
47.123 -apply (rule trans)
47.124 -apply (rule_tac [2] thelub_sprod [symmetric])
47.125 -apply (rule_tac [2] ch2ch_fun)
47.126 -apply (erule_tac [2] monofun_Ispair1 [THEN ch2ch_monofun])
47.127 -apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
47.128 -apply (rule_tac Q = "lub (range (Y))=UU" in excluded_middle [THEN disjE])
47.129 -apply (erule sprod3_lemma1)
47.130 -apply assumption
47.131 -apply assumption
47.132 -apply (erule sprod3_lemma2)
47.133 -apply assumption
47.134 -apply assumption
47.135 -apply (erule sprod3_lemma3)
47.136 -apply assumption
47.137 -done
47.138 -
47.139 -lemma sprod3_lemma4:
47.140 -"[| chain(Y); x ~= UU; lub(range(Y)) ~= UU |] ==>
47.141 - Ispair x (lub(range Y)) =
47.142 - Ispair (lub(range(%i. Isfst (Ispair x (Y i)))))
47.143 - (lub(range(%i. Issnd (Ispair x (Y i)))))"
47.144 -apply (rule_tac f1 = "Ispair" in arg_cong [THEN cong])
47.145 -apply (rule sym)
47.146 -apply (drule chain_UU_I_inverse2)
47.147 -apply (erule exE)
47.148 -apply (rule lub_chain_maxelem)
47.149 -apply (erule Isfst2)
47.150 -apply (rule allI)
47.151 -apply (rename_tac "j")
47.152 -apply (case_tac "Y (j) =UU")
47.153 -apply auto
47.154 -done
47.155 -
47.156 -lemma sprod3_lemma5:
47.157 -"[| chain(Y); x ~= UU; lub(range(Y)) = UU |] ==>
47.158 - Ispair x (lub(range Y)) =
47.159 - Ispair (lub(range(%i. Isfst(Ispair x (Y i)))))
47.160 - (lub(range(%i. Issnd(Ispair x (Y i)))))"
47.161 -apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
47.162 -apply assumption
47.163 -apply (rule trans)
47.164 -apply (rule strict_Ispair2)
47.165 -apply (rule strict_Ispair [symmetric])
47.166 -apply (rule disjI2)
47.167 -apply (rule chain_UU_I_inverse)
47.168 -apply (rule allI)
47.169 -apply (simp add: Sprod0_ss)
47.170 -apply (erule chain_UU_I [THEN spec])
47.171 -apply assumption
47.172 -done
47.173 -
47.174 -lemma sprod3_lemma6:
47.175 -"[| chain(Y); x = UU |] ==>
47.176 - Ispair x (lub(range Y)) =
47.177 - Ispair (lub(range(%i. Isfst (Ispair x (Y i)))))
47.178 - (lub(range(%i. Issnd (Ispair x (Y i)))))"
47.179 -apply (rule_tac s = "UU" and t = "x" in ssubst)
47.180 -apply assumption
47.181 -apply (rule trans)
47.182 -apply (rule strict_Ispair1)
47.183 -apply (rule strict_Ispair [symmetric])
47.184 -apply (rule disjI1)
47.185 -apply (rule chain_UU_I_inverse)
47.186 -apply (rule allI)
47.187 -apply (simp add: Sprod0_ss)
47.188 -done
47.189 -
47.190 -lemma contlub_Ispair2: "contlub(Ispair(x))"
47.191 -apply (rule contlubI)
47.192 -apply (intro strip)
47.193 -apply (rule trans)
47.194 -apply (rule_tac [2] thelub_sprod [symmetric])
47.195 -apply (erule_tac [2] monofun_Ispair2 [THEN ch2ch_monofun])
47.196 -apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
47.197 -apply (rule_tac Q = "lub (range (Y))=UU" in excluded_middle [THEN disjE])
47.198 -apply (erule sprod3_lemma4)
47.199 -apply assumption
47.200 -apply assumption
47.201 -apply (erule sprod3_lemma5)
47.202 -apply assumption
47.203 -apply assumption
47.204 -apply (erule sprod3_lemma6)
47.205 -apply assumption
47.206 -done
47.207 -
47.208 -lemma cont_Ispair1: "cont(Ispair)"
47.209 -apply (rule monocontlub2cont)
47.210 -apply (rule monofun_Ispair1)
47.211 -apply (rule contlub_Ispair1)
47.212 -done
47.213 -
47.214 -
47.215 -lemma cont_Ispair2: "cont(Ispair(x))"
47.216 -apply (rule monocontlub2cont)
47.217 -apply (rule monofun_Ispair2)
47.218 -apply (rule contlub_Ispair2)
47.219 -done
47.220 -
47.221 -lemma contlub_Isfst: "contlub(Isfst)"
47.222 -apply (rule contlubI)
47.223 -apply (intro strip)
47.224 -apply (subst lub_sprod [THEN thelubI])
47.225 -apply assumption
47.226 -apply (rule_tac Q = "lub (range (%i. Issnd (Y (i))))=UU" in excluded_middle [THEN disjE])
47.227 -apply (simp add: Sprod0_ss)
47.228 -apply (rule_tac s = "UU" and t = "lub (range (%i. Issnd (Y (i))))" in ssubst)
47.229 -apply assumption
47.230 -apply (rule trans)
47.231 -apply (simp add: Sprod0_ss)
47.232 -apply (rule sym)
47.233 -apply (rule chain_UU_I_inverse)
47.234 -apply (rule allI)
47.235 -apply (rule strict_Isfst)
47.236 -apply (rule contrapos_np)
47.237 -apply (erule_tac [2] defined_IsfstIssnd [THEN conjunct2])
47.238 -apply (fast dest!: monofun_Issnd [THEN ch2ch_monofun, THEN chain_UU_I, THEN spec])
47.239 -done
47.240 -
47.241 -lemma contlub_Issnd: "contlub(Issnd)"
47.242 -apply (rule contlubI)
47.243 -apply (intro strip)
47.244 -apply (subst lub_sprod [THEN thelubI])
47.245 -apply assumption
47.246 -apply (rule_tac Q = "lub (range (%i. Isfst (Y (i))))=UU" in excluded_middle [THEN disjE])
47.247 -apply (simp add: Sprod0_ss)
47.248 -apply (rule_tac s = "UU" and t = "lub (range (%i. Isfst (Y (i))))" in ssubst)
47.249 -apply assumption
47.250 -apply (simp add: Sprod0_ss)
47.251 -apply (rule sym)
47.252 -apply (rule chain_UU_I_inverse)
47.253 -apply (rule allI)
47.254 -apply (rule strict_Issnd)
47.255 -apply (rule contrapos_np)
47.256 -apply (erule_tac [2] defined_IsfstIssnd [THEN conjunct1])
47.257 -apply (fast dest!: monofun_Isfst [THEN ch2ch_monofun, THEN chain_UU_I, THEN spec])
47.258 -done
47.259 -
47.260 -lemma cont_Isfst: "cont(Isfst)"
47.261 -apply (rule monocontlub2cont)
47.262 -apply (rule monofun_Isfst)
47.263 -apply (rule contlub_Isfst)
47.264 -done
47.265 -
47.266 -lemma cont_Issnd: "cont(Issnd)"
47.267 -apply (rule monocontlub2cont)
47.268 -apply (rule monofun_Issnd)
47.269 -apply (rule contlub_Issnd)
47.270 -done
47.271 -
47.272 -lemma spair_eq: "[|x1=x2;y1=y2|] ==> (:x1,y1:) = (:x2,y2:)"
47.273 -apply fast
47.274 -done
47.275 -
47.276 -(* ------------------------------------------------------------------------ *)
47.277 -(* convert all lemmas to the continuous versions *)
47.278 -(* ------------------------------------------------------------------------ *)
47.279 -
47.280 -lemma beta_cfun_sprod:
47.281 - "(LAM x y. Ispair x y)$a$b = Ispair a b"
47.282 -apply (subst beta_cfun)
47.283 -apply (simp (no_asm) add: cont_Ispair2 cont_Ispair1 cont2cont_CF1L)
47.284 -apply (subst beta_cfun)
47.285 -apply (rule cont_Ispair2)
47.286 -apply (rule refl)
47.287 -done
47.288 -
47.289 -declare beta_cfun_sprod [simp]
47.290 -
47.291 -lemma inject_spair:
47.292 - "[| aa~=UU ; ba~=UU ; (:a,b:)=(:aa,ba:) |] ==> a=aa & b=ba"
47.293 -apply (unfold spair_def)
47.294 -apply (erule inject_Ispair)
47.295 -apply assumption
47.296 -apply (erule box_equals)
47.297 -apply (rule beta_cfun_sprod)
47.298 -apply (rule beta_cfun_sprod)
47.299 -done
47.300 -
47.301 -lemma inst_sprod_pcpo2: "UU = (:UU,UU:)"
47.302 -apply (unfold spair_def)
47.303 -apply (rule sym)
47.304 -apply (rule trans)
47.305 -apply (rule beta_cfun_sprod)
47.306 -apply (rule sym)
47.307 -apply (rule inst_sprod_pcpo)
47.308 -done
47.309 -
47.310 -lemma strict_spair:
47.311 - "(a=UU | b=UU) ==> (:a,b:)=UU"
47.312 -apply (unfold spair_def)
47.313 -apply (rule trans)
47.314 -apply (rule beta_cfun_sprod)
47.315 -apply (rule trans)
47.316 -apply (rule_tac [2] inst_sprod_pcpo [symmetric])
47.317 -apply (erule strict_Ispair)
47.318 -done
47.319 -
47.320 -lemma strict_spair1: "(:UU,b:) = UU"
47.321 -apply (unfold spair_def)
47.322 -apply (subst beta_cfun_sprod)
47.323 -apply (rule trans)
47.324 -apply (rule_tac [2] inst_sprod_pcpo [symmetric])
47.325 -apply (rule strict_Ispair1)
47.326 -done
47.327 -
47.328 -lemma strict_spair2: "(:a,UU:) = UU"
47.329 -apply (unfold spair_def)
47.330 -apply (subst beta_cfun_sprod)
47.331 -apply (rule trans)
47.332 -apply (rule_tac [2] inst_sprod_pcpo [symmetric])
47.333 -apply (rule strict_Ispair2)
47.334 -done
47.335 -
47.336 -declare strict_spair1 [simp] strict_spair2 [simp]
47.337 -
47.338 -lemma strict_spair_rev: "(:x,y:)~=UU ==> ~x=UU & ~y=UU"
47.339 -apply (unfold spair_def)
47.340 -apply (rule strict_Ispair_rev)
47.341 -apply auto
47.342 -done
47.343 -
47.344 -lemma defined_spair_rev: "(:a,b:) = UU ==> (a = UU | b = UU)"
47.345 -apply (unfold spair_def)
47.346 -apply (rule defined_Ispair_rev)
47.347 -apply auto
47.348 -done
47.349 -
47.350 -lemma defined_spair:
47.351 - "[|a~=UU; b~=UU|] ==> (:a,b:) ~= UU"
47.352 -apply (unfold spair_def)
47.353 -apply (subst beta_cfun_sprod)
47.354 -apply (subst inst_sprod_pcpo)
47.355 -apply (erule defined_Ispair)
47.356 -apply assumption
47.357 -done
47.358 -
47.359 -lemma Exh_Sprod2:
47.360 - "z=UU | (? a b. z=(:a,b:) & a~=UU & b~=UU)"
47.361 -apply (unfold spair_def)
47.362 -apply (rule Exh_Sprod [THEN disjE])
47.363 -apply (rule disjI1)
47.364 -apply (subst inst_sprod_pcpo)
47.365 -apply assumption
47.366 -apply (rule disjI2)
47.367 -apply (erule exE)
47.368 -apply (erule exE)
47.369 -apply (rule exI)
47.370 -apply (rule exI)
47.371 -apply (rule conjI)
47.372 -apply (subst beta_cfun_sprod)
47.373 -apply fast
47.374 -apply fast
47.375 -done
47.376 -
47.377 -
47.378 -lemma sprodE:
47.379 -assumes prem1: "p=UU ==> Q"
47.380 -assumes prem2: "!!x y. [| p=(:x,y:); x~=UU; y~=UU|] ==> Q"
47.381 -shows "Q"
47.382 -apply (rule IsprodE)
47.383 -apply (rule prem1)
47.384 -apply (subst inst_sprod_pcpo)
47.385 -apply assumption
47.386 -apply (rule prem2)
47.387 -prefer 2 apply (assumption)
47.388 -prefer 2 apply (assumption)
47.389 -apply (unfold spair_def)
47.390 -apply (subst beta_cfun_sprod)
47.391 -apply assumption
47.392 -done
47.393 -
47.394 -
47.395 -lemma strict_sfst:
47.396 - "p=UU==>sfst$p=UU"
47.397 -apply (unfold sfst_def)
47.398 -apply (subst beta_cfun)
47.399 -apply (rule cont_Isfst)
47.400 -apply (rule strict_Isfst)
47.401 -apply (rule inst_sprod_pcpo [THEN subst])
47.402 -apply assumption
47.403 -done
47.404 -
47.405 -lemma strict_sfst1:
47.406 - "sfst$(:UU,y:) = UU"
47.407 -apply (unfold sfst_def spair_def)
47.408 -apply (subst beta_cfun_sprod)
47.409 -apply (subst beta_cfun)
47.410 -apply (rule cont_Isfst)
47.411 -apply (rule strict_Isfst1)
47.412 -done
47.413 -
47.414 -lemma strict_sfst2:
47.415 - "sfst$(:x,UU:) = UU"
47.416 -apply (unfold sfst_def spair_def)
47.417 -apply (subst beta_cfun_sprod)
47.418 -apply (subst beta_cfun)
47.419 -apply (rule cont_Isfst)
47.420 -apply (rule strict_Isfst2)
47.421 -done
47.422 -
47.423 -lemma strict_ssnd:
47.424 - "p=UU==>ssnd$p=UU"
47.425 -apply (unfold ssnd_def)
47.426 -apply (subst beta_cfun)
47.427 -apply (rule cont_Issnd)
47.428 -apply (rule strict_Issnd)
47.429 -apply (rule inst_sprod_pcpo [THEN subst])
47.430 -apply assumption
47.431 -done
47.432 -
47.433 -lemma strict_ssnd1:
47.434 - "ssnd$(:UU,y:) = UU"
47.435 -apply (unfold ssnd_def spair_def)
47.436 -apply (subst beta_cfun_sprod)
47.437 -apply (subst beta_cfun)
47.438 -apply (rule cont_Issnd)
47.439 -apply (rule strict_Issnd1)
47.440 -done
47.441 -
47.442 -lemma strict_ssnd2:
47.443 - "ssnd$(:x,UU:) = UU"
47.444 -apply (unfold ssnd_def spair_def)
47.445 -apply (subst beta_cfun_sprod)
47.446 -apply (subst beta_cfun)
47.447 -apply (rule cont_Issnd)
47.448 -apply (rule strict_Issnd2)
47.449 -done
47.450 -
47.451 -lemma sfst2:
47.452 - "y~=UU ==>sfst$(:x,y:)=x"
47.453 -apply (unfold sfst_def spair_def)
47.454 -apply (subst beta_cfun_sprod)
47.455 -apply (subst beta_cfun)
47.456 -apply (rule cont_Isfst)
47.457 -apply (erule Isfst2)
47.458 -done
47.459 -
47.460 -lemma ssnd2:
47.461 - "x~=UU ==>ssnd$(:x,y:)=y"
47.462 -apply (unfold ssnd_def spair_def)
47.463 -apply (subst beta_cfun_sprod)
47.464 -apply (subst beta_cfun)
47.465 -apply (rule cont_Issnd)
47.466 -apply (erule Issnd2)
47.467 -done
47.468 -
47.469 -
47.470 -lemma defined_sfstssnd:
47.471 - "p~=UU ==> sfst$p ~=UU & ssnd$p ~=UU"
47.472 -apply (unfold sfst_def ssnd_def spair_def)
47.473 -apply (simplesubst beta_cfun)
47.474 -apply (rule cont_Issnd)
47.475 -apply (subst beta_cfun)
47.476 -apply (rule cont_Isfst)
47.477 -apply (rule defined_IsfstIssnd)
47.478 -apply (rule inst_sprod_pcpo [THEN subst])
47.479 -apply assumption
47.480 -done
47.481 -
47.482 -lemma surjective_pairing_Sprod2: "(:sfst$p , ssnd$p:) = p"
47.483 -
47.484 -apply (unfold sfst_def ssnd_def spair_def)
47.485 -apply (subst beta_cfun_sprod)
47.486 -apply (simplesubst beta_cfun)
47.487 -apply (rule cont_Issnd)
47.488 -apply (subst beta_cfun)
47.489 -apply (rule cont_Isfst)
47.490 -apply (rule surjective_pairing_Sprod [symmetric])
47.491 -done
47.492 -
47.493 -lemma lub_sprod2:
47.494 -"chain(S) ==> range(S) <<|
47.495 - (: lub(range(%i. sfst$(S i))), lub(range(%i. ssnd$(S i))) :)"
47.496 -apply (unfold sfst_def ssnd_def spair_def)
47.497 -apply (subst beta_cfun_sprod)
47.498 -apply (simplesubst beta_cfun [THEN ext])
47.499 -apply (rule cont_Issnd)
47.500 -apply (subst beta_cfun [THEN ext])
47.501 -apply (rule cont_Isfst)
47.502 -apply (erule lub_sprod)
47.503 -done
47.504 -
47.505 -
47.506 -lemmas thelub_sprod2 = lub_sprod2 [THEN thelubI, standard]
47.507 -(*
47.508 - "chain ?S1 ==>
47.509 - lub (range ?S1) =
47.510 - (:lub (range (%i. sfst$(?S1 i))), lub (range (%i. ssnd$(?S1 i))):)" : thm
47.511 -*)
47.512 -
47.513 -lemma ssplit1:
47.514 - "ssplit$f$UU=UU"
47.515 -
47.516 -apply (unfold ssplit_def)
47.517 -apply (subst beta_cfun)
47.518 -apply (simp (no_asm))
47.519 -apply (subst strictify1)
47.520 -apply (rule refl)
47.521 -done
47.522 -
47.523 -lemma ssplit2:
47.524 - "[|x~=UU;y~=UU|] ==> ssplit$f$(:x,y:)= f$x$y"
47.525 -apply (unfold ssplit_def)
47.526 -apply (subst beta_cfun)
47.527 -apply (simp (no_asm))
47.528 -apply (subst strictify2)
47.529 -apply (rule defined_spair)
47.530 -apply assumption
47.531 -apply assumption
47.532 -apply (subst beta_cfun)
47.533 -apply (simp (no_asm))
47.534 -apply (subst sfst2)
47.535 -apply assumption
47.536 -apply (subst ssnd2)
47.537 -apply assumption
47.538 -apply (rule refl)
47.539 -done
47.540 -
47.541 -
47.542 -lemma ssplit3:
47.543 - "ssplit$spair$z=z"
47.544 -
47.545 -apply (unfold ssplit_def)
47.546 -apply (subst beta_cfun)
47.547 -apply (simp (no_asm))
47.548 -apply (case_tac "z=UU")
47.549 -apply (erule ssubst)
47.550 -apply (rule strictify1)
47.551 -apply (rule trans)
47.552 -apply (rule strictify2)
47.553 -apply assumption
47.554 -apply (subst beta_cfun)
47.555 -apply (simp (no_asm))
47.556 -apply (rule surjective_pairing_Sprod2)
47.557 -done
47.558 -
47.559 -(* ------------------------------------------------------------------------ *)
47.560 -(* install simplifier for Sprod *)
47.561 -(* ------------------------------------------------------------------------ *)
47.562 -
47.563 -lemmas Sprod_rews = strict_sfst1 strict_sfst2
47.564 - strict_ssnd1 strict_ssnd2 sfst2 ssnd2 defined_spair
47.565 - ssplit1 ssplit2
47.566 -declare Sprod_rews [simp]
47.567 -
47.568 -end
48.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
48.2 +++ b/src/HOLCF/Ssum.ML Fri Mar 04 23:12:36 2005 +0100
48.3 @@ -0,0 +1,112 @@
48.4 +
48.5 +(* legacy ML bindings *)
48.6 +
48.7 +val Isinl_def = thm "Isinl_def";
48.8 +val Isinr_def = thm "Isinr_def";
48.9 +val Iwhen_def = thm "Iwhen_def";
48.10 +val SsumIl = thm "SsumIl";
48.11 +val SsumIr = thm "SsumIr";
48.12 +val inj_on_Abs_Ssum = thm "inj_on_Abs_Ssum";
48.13 +val strict_SinlSinr_Rep = thm "strict_SinlSinr_Rep";
48.14 +val strict_IsinlIsinr = thm "strict_IsinlIsinr";
48.15 +val noteq_SinlSinr_Rep = thm "noteq_SinlSinr_Rep";
48.16 +val noteq_IsinlIsinr = thm "noteq_IsinlIsinr";
48.17 +val inject_Sinl_Rep1 = thm "inject_Sinl_Rep1";
48.18 +val inject_Sinr_Rep1 = thm "inject_Sinr_Rep1";
48.19 +val inject_Sinl_Rep2 = thm "inject_Sinl_Rep2";
48.20 +val inject_Sinr_Rep2 = thm "inject_Sinr_Rep2";
48.21 +val inject_Sinl_Rep = thm "inject_Sinl_Rep";
48.22 +val inject_Sinr_Rep = thm "inject_Sinr_Rep";
48.23 +val inject_Isinl = thm "inject_Isinl";
48.24 +val inject_Isinr = thm "inject_Isinr";
48.25 +val inject_Isinl_rev = thm "inject_Isinl_rev";
48.26 +val inject_Isinr_rev = thm "inject_Isinr_rev";
48.27 +val Exh_Ssum = thm "Exh_Ssum";
48.28 +val IssumE = thm "IssumE";
48.29 +val IssumE2 = thm "IssumE2";
48.30 +val Iwhen1 = thm "Iwhen1";
48.31 +val Iwhen2 = thm "Iwhen2";
48.32 +val Iwhen3 = thm "Iwhen3";
48.33 +val less_ssum_def = thm "less_ssum_def";
48.34 +val less_ssum1a = thm "less_ssum1a";
48.35 +val less_ssum1b = thm "less_ssum1b";
48.36 +val less_ssum1c = thm "less_ssum1c";
48.37 +val less_ssum1d = thm "less_ssum1d";
48.38 +val less_ssum2a = thm "less_ssum2a";
48.39 +val less_ssum2b = thm "less_ssum2b";
48.40 +val less_ssum2c = thm "less_ssum2c";
48.41 +val less_ssum2d = thm "less_ssum2d";
48.42 +val refl_less_ssum = thm "refl_less_ssum";
48.43 +val antisym_less_ssum = thm "antisym_less_ssum";
48.44 +val trans_less_ssum = thm "trans_less_ssum";
48.45 +val inst_ssum_po = thm "inst_ssum_po";
48.46 +val less_ssum3a = thm "less_ssum3a";
48.47 +val less_ssum3b = thm "less_ssum3b";
48.48 +val less_ssum3c = thm "less_ssum3c";
48.49 +val less_ssum3d = thm "less_ssum3d";
48.50 +val minimal_ssum = thm "minimal_ssum";
48.51 +val UU_ssum_def = thm "UU_ssum_def";
48.52 +val least_ssum = thm "least_ssum";
48.53 +val monofun_Isinl = thm "monofun_Isinl";
48.54 +val monofun_Isinr = thm "monofun_Isinr";
48.55 +val monofun_Iwhen1 = thm "monofun_Iwhen1";
48.56 +val monofun_Iwhen2 = thm "monofun_Iwhen2";
48.57 +val monofun_Iwhen3 = thm "monofun_Iwhen3";
48.58 +val ssum_lemma1 = thm "ssum_lemma1";
48.59 +val ssum_lemma2 = thm "ssum_lemma2";
48.60 +val ssum_lemma3 = thm "ssum_lemma3";
48.61 +val ssum_lemma4 = thm "ssum_lemma4";
48.62 +val ssum_lemma5 = thm "ssum_lemma5";
48.63 +val ssum_lemma6 = thm "ssum_lemma6";
48.64 +val ssum_lemma7 = thm "ssum_lemma7";
48.65 +val ssum_lemma8 = thm "ssum_lemma8";
48.66 +val lub_ssum1a = thm "lub_ssum1a";
48.67 +val lub_ssum1b = thm "lub_ssum1b";
48.68 +val thelub_ssum1a = thm "thelub_ssum1a";
48.69 +val thelub_ssum1b = thm "thelub_ssum1b";
48.70 +val cpo_ssum = thm "cpo_ssum";
48.71 +val sinl_def = thm "sinl_def";
48.72 +val sinr_def = thm "sinr_def";
48.73 +val sscase_def = thm "sscase_def";
48.74 +val inst_ssum_pcpo = thm "inst_ssum_pcpo";
48.75 +val contlub_Isinl = thm "contlub_Isinl";
48.76 +val contlub_Isinr = thm "contlub_Isinr";
48.77 +val cont_Isinl = thm "cont_Isinl";
48.78 +val cont_Isinr = thm "cont_Isinr";
48.79 +val contlub_Iwhen1 = thm "contlub_Iwhen1";
48.80 +val contlub_Iwhen2 = thm "contlub_Iwhen2";
48.81 +val ssum_lemma9 = thm "ssum_lemma9";
48.82 +val ssum_lemma10 = thm "ssum_lemma10";
48.83 +val ssum_lemma11 = thm "ssum_lemma11";
48.84 +val ssum_lemma12 = thm "ssum_lemma12";
48.85 +val ssum_lemma13 = thm "ssum_lemma13";
48.86 +val contlub_Iwhen3 = thm "contlub_Iwhen3";
48.87 +val cont_Iwhen1 = thm "cont_Iwhen1";
48.88 +val cont_Iwhen2 = thm "cont_Iwhen2";
48.89 +val cont_Iwhen3 = thm "cont_Iwhen3";
48.90 +val strict_sinl = thm "strict_sinl";
48.91 +val strict_sinr = thm "strict_sinr";
48.92 +val noteq_sinlsinr = thm "noteq_sinlsinr";
48.93 +val inject_sinl = thm "inject_sinl";
48.94 +val inject_sinr = thm "inject_sinr";
48.95 +val defined_sinl = thm "defined_sinl";
48.96 +val defined_sinr = thm "defined_sinr";
48.97 +val Exh_Ssum1 = thm "Exh_Ssum1";
48.98 +val ssumE = thm "ssumE";
48.99 +val ssumE2 = thm "ssumE2";
48.100 +val sscase1 = thm "sscase1";
48.101 +val sscase2 = thm "sscase2";
48.102 +val sscase3 = thm "sscase3";
48.103 +val less_ssum4a = thm "less_ssum4a";
48.104 +val less_ssum4b = thm "less_ssum4b";
48.105 +val less_ssum4c = thm "less_ssum4c";
48.106 +val less_ssum4d = thm "less_ssum4d";
48.107 +val ssum_chainE = thm "ssum_chainE";
48.108 +val thelub_ssum2a = thm "thelub_ssum2a";
48.109 +val thelub_ssum2b = thm "thelub_ssum2b";
48.110 +val thelub_ssum2a_rev = thm "thelub_ssum2a_rev";
48.111 +val thelub_ssum2b_rev = thm "thelub_ssum2b_rev";
48.112 +val thelub_ssum3 = thm "thelub_ssum3";
48.113 +val sscase4 = thm "sscase4";
48.114 +val Ssum_rews = [strict_sinl, strict_sinr, defined_sinl, defined_sinr,
48.115 + sscase1, sscase2, sscase3]
49.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
49.2 +++ b/src/HOLCF/Ssum.thy Fri Mar 04 23:12:36 2005 +0100
49.3 @@ -0,0 +1,1565 @@
49.4 +(* Title: HOLCF/Ssum0.thy
49.5 + ID: $Id$
49.6 + Author: Franz Regensburger
49.7 + License: GPL (GNU GENERAL PUBLIC LICENSE)
49.8 +
49.9 +Strict sum with typedef
49.10 +*)
49.11 +
49.12 +header {* The type of strict sums *}
49.13 +
49.14 +theory Ssum = Cfun:
49.15 +
49.16 +constdefs
49.17 + Sinl_Rep :: "['a,'a,'b,bool]=>bool"
49.18 + "Sinl_Rep == (%a.%x y p. (a~=UU --> x=a & p))"
49.19 + Sinr_Rep :: "['b,'a,'b,bool]=>bool"
49.20 + "Sinr_Rep == (%b.%x y p.(b~=UU --> y=b & ~p))"
49.21 +
49.22 +typedef (Ssum) ('a, 'b) "++" (infixr 10) =
49.23 + "{f.(? a. f=Sinl_Rep(a::'a))|(? b. f=Sinr_Rep(b::'b))}"
49.24 +by auto
49.25 +
49.26 +syntax (xsymbols)
49.27 + "++" :: "[type, type] => type" ("(_ \<oplus>/ _)" [21, 20] 20)
49.28 +syntax (HTML output)
49.29 + "++" :: "[type, type] => type" ("(_ \<oplus>/ _)" [21, 20] 20)
49.30 +
49.31 +consts
49.32 + Isinl :: "'a => ('a ++ 'b)"
49.33 + Isinr :: "'b => ('a ++ 'b)"
49.34 + Iwhen :: "('a->'c)=>('b->'c)=>('a ++ 'b)=> 'c"
49.35 +
49.36 +defs (*defining the abstract constants*)
49.37 + Isinl_def: "Isinl(a) == Abs_Ssum(Sinl_Rep(a))"
49.38 + Isinr_def: "Isinr(b) == Abs_Ssum(Sinr_Rep(b))"
49.39 +
49.40 + Iwhen_def: "Iwhen(f)(g)(s) == @z.
49.41 + (s=Isinl(UU) --> z=UU)
49.42 + &(!a. a~=UU & s=Isinl(a) --> z=f$a)
49.43 + &(!b. b~=UU & s=Isinr(b) --> z=g$b)"
49.44 +
49.45 +(* ------------------------------------------------------------------------ *)
49.46 +(* A non-emptyness result for Sssum *)
49.47 +(* ------------------------------------------------------------------------ *)
49.48 +
49.49 +lemma SsumIl: "Sinl_Rep(a):Ssum"
49.50 +apply (unfold Ssum_def)
49.51 +apply blast
49.52 +done
49.53 +
49.54 +lemma SsumIr: "Sinr_Rep(a):Ssum"
49.55 +apply (unfold Ssum_def)
49.56 +apply blast
49.57 +done
49.58 +
49.59 +lemma inj_on_Abs_Ssum: "inj_on Abs_Ssum Ssum"
49.60 +apply (rule inj_on_inverseI)
49.61 +apply (erule Abs_Ssum_inverse)
49.62 +done
49.63 +
49.64 +(* ------------------------------------------------------------------------ *)
49.65 +(* Strictness of Sinr_Rep, Sinl_Rep and Isinl, Isinr *)
49.66 +(* ------------------------------------------------------------------------ *)
49.67 +
49.68 +lemma strict_SinlSinr_Rep:
49.69 + "Sinl_Rep(UU) = Sinr_Rep(UU)"
49.70 +apply (unfold Sinr_Rep_def Sinl_Rep_def)
49.71 +apply (rule ext)
49.72 +apply (rule ext)
49.73 +apply (rule ext)
49.74 +apply fast
49.75 +done
49.76 +
49.77 +lemma strict_IsinlIsinr:
49.78 + "Isinl(UU) = Isinr(UU)"
49.79 +apply (unfold Isinl_def Isinr_def)
49.80 +apply (rule strict_SinlSinr_Rep [THEN arg_cong])
49.81 +done
49.82 +
49.83 +
49.84 +(* ------------------------------------------------------------------------ *)
49.85 +(* distinctness of Sinl_Rep, Sinr_Rep and Isinl, Isinr *)
49.86 +(* ------------------------------------------------------------------------ *)
49.87 +
49.88 +lemma noteq_SinlSinr_Rep:
49.89 + "(Sinl_Rep(a) = Sinr_Rep(b)) ==> a=UU & b=UU"
49.90 +apply (unfold Sinl_Rep_def Sinr_Rep_def)
49.91 +apply (blast dest!: fun_cong)
49.92 +done
49.93 +
49.94 +
49.95 +lemma noteq_IsinlIsinr:
49.96 + "Isinl(a)=Isinr(b) ==> a=UU & b=UU"
49.97 +apply (unfold Isinl_def Isinr_def)
49.98 +apply (rule noteq_SinlSinr_Rep)
49.99 +apply (erule inj_on_Abs_Ssum [THEN inj_onD])
49.100 +apply (rule SsumIl)
49.101 +apply (rule SsumIr)
49.102 +done
49.103 +
49.104 +
49.105 +
49.106 +(* ------------------------------------------------------------------------ *)
49.107 +(* injectivity of Sinl_Rep, Sinr_Rep and Isinl, Isinr *)
49.108 +(* ------------------------------------------------------------------------ *)
49.109 +
49.110 +lemma inject_Sinl_Rep1: "(Sinl_Rep(a) = Sinl_Rep(UU)) ==> a=UU"
49.111 +apply (unfold Sinl_Rep_def)
49.112 +apply (blast dest!: fun_cong)
49.113 +done
49.114 +
49.115 +lemma inject_Sinr_Rep1: "(Sinr_Rep(b) = Sinr_Rep(UU)) ==> b=UU"
49.116 +apply (unfold Sinr_Rep_def)
49.117 +apply (blast dest!: fun_cong)
49.118 +done
49.119 +
49.120 +lemma inject_Sinl_Rep2:
49.121 +"[| a1~=UU ; a2~=UU ; Sinl_Rep(a1)=Sinl_Rep(a2) |] ==> a1=a2"
49.122 +apply (unfold Sinl_Rep_def)
49.123 +apply (blast dest!: fun_cong)
49.124 +done
49.125 +
49.126 +lemma inject_Sinr_Rep2:
49.127 +"[|b1~=UU ; b2~=UU ; Sinr_Rep(b1)=Sinr_Rep(b2) |] ==> b1=b2"
49.128 +apply (unfold Sinr_Rep_def)
49.129 +apply (blast dest!: fun_cong)
49.130 +done
49.131 +
49.132 +lemma inject_Sinl_Rep: "Sinl_Rep(a1)=Sinl_Rep(a2) ==> a1=a2"
49.133 +apply (case_tac "a1=UU")
49.134 +apply simp
49.135 +apply (rule inject_Sinl_Rep1 [symmetric])
49.136 +apply (erule sym)
49.137 +apply (case_tac "a2=UU")
49.138 +apply simp
49.139 +apply (drule inject_Sinl_Rep1)
49.140 +apply simp
49.141 +apply (erule inject_Sinl_Rep2)
49.142 +apply assumption
49.143 +apply assumption
49.144 +done
49.145 +
49.146 +lemma inject_Sinr_Rep: "Sinr_Rep(b1)=Sinr_Rep(b2) ==> b1=b2"
49.147 +apply (case_tac "b1=UU")
49.148 +apply simp
49.149 +apply (rule inject_Sinr_Rep1 [symmetric])
49.150 +apply (erule sym)
49.151 +apply (case_tac "b2=UU")
49.152 +apply simp
49.153 +apply (drule inject_Sinr_Rep1)
49.154 +apply simp
49.155 +apply (erule inject_Sinr_Rep2)
49.156 +apply assumption
49.157 +apply assumption
49.158 +done
49.159 +
49.160 +lemma inject_Isinl: "Isinl(a1)=Isinl(a2)==> a1=a2"
49.161 +apply (unfold Isinl_def)
49.162 +apply (rule inject_Sinl_Rep)
49.163 +apply (erule inj_on_Abs_Ssum [THEN inj_onD])
49.164 +apply (rule SsumIl)
49.165 +apply (rule SsumIl)
49.166 +done
49.167 +
49.168 +lemma inject_Isinr: "Isinr(b1)=Isinr(b2) ==> b1=b2"
49.169 +apply (unfold Isinr_def)
49.170 +apply (rule inject_Sinr_Rep)
49.171 +apply (erule inj_on_Abs_Ssum [THEN inj_onD])
49.172 +apply (rule SsumIr)
49.173 +apply (rule SsumIr)
49.174 +done
49.175 +
49.176 +declare inject_Isinl [dest!] inject_Isinr [dest!]
49.177 +
49.178 +lemma inject_Isinl_rev: "a1~=a2 ==> Isinl(a1) ~= Isinl(a2)"
49.179 +apply blast
49.180 +done
49.181 +
49.182 +lemma inject_Isinr_rev: "b1~=b2 ==> Isinr(b1) ~= Isinr(b2)"
49.183 +apply blast
49.184 +done
49.185 +
49.186 +(* ------------------------------------------------------------------------ *)
49.187 +(* Exhaustion of the strict sum ++ *)
49.188 +(* choice of the bottom representation is arbitrary *)
49.189 +(* ------------------------------------------------------------------------ *)
49.190 +
49.191 +lemma Exh_Ssum:
49.192 + "z=Isinl(UU) | (? a. z=Isinl(a) & a~=UU) | (? b. z=Isinr(b) & b~=UU)"
49.193 +apply (unfold Isinl_def Isinr_def)
49.194 +apply (rule Rep_Ssum[unfolded Ssum_def, THEN CollectE])
49.195 +apply (erule disjE)
49.196 +apply (erule exE)
49.197 +apply (case_tac "z= Abs_Ssum (Sinl_Rep (UU))")
49.198 +apply (erule disjI1)
49.199 +apply (rule disjI2)
49.200 +apply (rule disjI1)
49.201 +apply (rule exI)
49.202 +apply (rule conjI)
49.203 +apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
49.204 +apply (erule arg_cong)
49.205 +apply (rule_tac Q = "Sinl_Rep (a) =Sinl_Rep (UU) " in contrapos_nn)
49.206 +apply (erule_tac [2] arg_cong)
49.207 +apply (erule contrapos_nn)
49.208 +apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
49.209 +apply (rule trans)
49.210 +apply (erule arg_cong)
49.211 +apply (erule arg_cong)
49.212 +apply (erule exE)
49.213 +apply (case_tac "z= Abs_Ssum (Sinl_Rep (UU))")
49.214 +apply (erule disjI1)
49.215 +apply (rule disjI2)
49.216 +apply (rule disjI2)
49.217 +apply (rule exI)
49.218 +apply (rule conjI)
49.219 +apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
49.220 +apply (erule arg_cong)
49.221 +apply (rule_tac Q = "Sinr_Rep (b) =Sinl_Rep (UU) " in contrapos_nn)
49.222 +prefer 2 apply simp
49.223 +apply (rule strict_SinlSinr_Rep [symmetric])
49.224 +apply (erule contrapos_nn)
49.225 +apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
49.226 +apply (rule trans)
49.227 +apply (erule arg_cong)
49.228 +apply (erule arg_cong)
49.229 +done
49.230 +
49.231 +(* ------------------------------------------------------------------------ *)
49.232 +(* elimination rules for the strict sum ++ *)
49.233 +(* ------------------------------------------------------------------------ *)
49.234 +
49.235 +lemma IssumE:
49.236 + "[|p=Isinl(UU) ==> Q ;
49.237 + !!x.[|p=Isinl(x); x~=UU |] ==> Q;
49.238 + !!y.[|p=Isinr(y); y~=UU |] ==> Q|] ==> Q"
49.239 +apply (rule Exh_Ssum [THEN disjE])
49.240 +apply auto
49.241 +done
49.242 +
49.243 +lemma IssumE2:
49.244 +"[| !!x. [| p = Isinl(x) |] ==> Q; !!y. [| p = Isinr(y) |] ==> Q |] ==>Q"
49.245 +apply (rule IssumE)
49.246 +apply auto
49.247 +done
49.248 +
49.249 +
49.250 +
49.251 +
49.252 +(* ------------------------------------------------------------------------ *)
49.253 +(* rewrites for Iwhen *)
49.254 +(* ------------------------------------------------------------------------ *)
49.255 +
49.256 +lemma Iwhen1:
49.257 + "Iwhen f g (Isinl UU) = UU"
49.258 +apply (unfold Iwhen_def)
49.259 +apply (rule some_equality)
49.260 +apply (rule conjI)
49.261 +apply fast
49.262 +apply (rule conjI)
49.263 +apply (intro strip)
49.264 +apply (rule_tac P = "a=UU" in notE)
49.265 +apply fast
49.266 +apply (rule inject_Isinl)
49.267 +apply (rule sym)
49.268 +apply fast
49.269 +apply (intro strip)
49.270 +apply (rule_tac P = "b=UU" in notE)
49.271 +apply fast
49.272 +apply (rule inject_Isinr)
49.273 +apply (rule sym)
49.274 +apply (rule strict_IsinlIsinr [THEN subst])
49.275 +apply fast
49.276 +apply fast
49.277 +done
49.278 +
49.279 +
49.280 +lemma Iwhen2:
49.281 + "x~=UU ==> Iwhen f g (Isinl x) = f$x"
49.282 +apply (unfold Iwhen_def)
49.283 +apply (rule some_equality)
49.284 +prefer 2 apply fast
49.285 +apply (rule conjI)
49.286 +apply (intro strip)
49.287 +apply (rule_tac P = "x=UU" in notE)
49.288 +apply assumption
49.289 +apply (rule inject_Isinl)
49.290 +apply assumption
49.291 +apply (rule conjI)
49.292 +apply (intro strip)
49.293 +apply (rule cfun_arg_cong)
49.294 +apply (rule inject_Isinl)
49.295 +apply fast
49.296 +apply (intro strip)
49.297 +apply (rule_tac P = "Isinl (x) = Isinr (b) " in notE)
49.298 +prefer 2 apply fast
49.299 +apply (rule contrapos_nn)
49.300 +apply (erule_tac [2] noteq_IsinlIsinr)
49.301 +apply fast
49.302 +done
49.303 +
49.304 +lemma Iwhen3:
49.305 + "y~=UU ==> Iwhen f g (Isinr y) = g$y"
49.306 +apply (unfold Iwhen_def)
49.307 +apply (rule some_equality)
49.308 +prefer 2 apply fast
49.309 +apply (rule conjI)
49.310 +apply (intro strip)
49.311 +apply (rule_tac P = "y=UU" in notE)
49.312 +apply assumption
49.313 +apply (rule inject_Isinr)
49.314 +apply (rule strict_IsinlIsinr [THEN subst])
49.315 +apply assumption
49.316 +apply (rule conjI)
49.317 +apply (intro strip)
49.318 +apply (rule_tac P = "Isinr (y) = Isinl (a) " in notE)
49.319 +prefer 2 apply fast
49.320 +apply (rule contrapos_nn)
49.321 +apply (erule_tac [2] sym [THEN noteq_IsinlIsinr])
49.322 +apply fast
49.323 +apply (intro strip)
49.324 +apply (rule cfun_arg_cong)
49.325 +apply (rule inject_Isinr)
49.326 +apply fast
49.327 +done
49.328 +
49.329 +(* ------------------------------------------------------------------------ *)
49.330 +(* instantiate the simplifier *)
49.331 +(* ------------------------------------------------------------------------ *)
49.332 +
49.333 +lemmas Ssum0_ss = strict_IsinlIsinr[symmetric] Iwhen1 Iwhen2 Iwhen3
49.334 +
49.335 +declare Ssum0_ss [simp]
49.336 +
49.337 +(* Partial ordering for the strict sum ++ *)
49.338 +
49.339 +instance "++"::(pcpo,pcpo)sq_ord ..
49.340 +
49.341 +defs (overloaded)
49.342 + less_ssum_def: "(op <<) == (%s1 s2.@z.
49.343 + (! u x. s1=Isinl u & s2=Isinl x --> z = u << x)
49.344 + &(! v y. s1=Isinr v & s2=Isinr y --> z = v << y)
49.345 + &(! u y. s1=Isinl u & s2=Isinr y --> z = (u = UU))
49.346 + &(! v x. s1=Isinr v & s2=Isinl x --> z = (v = UU)))"
49.347 +
49.348 +lemma less_ssum1a:
49.349 +"[|s1=Isinl(x::'a); s2=Isinl(y::'a)|] ==> s1 << s2 = (x << y)"
49.350 +apply (unfold less_ssum_def)
49.351 +apply (rule some_equality)
49.352 +apply (drule_tac [2] conjunct1)
49.353 +apply (drule_tac [2] spec)
49.354 +apply (drule_tac [2] spec)
49.355 +apply (erule_tac [2] mp)
49.356 +prefer 2 apply fast
49.357 +apply (rule conjI)
49.358 +apply (intro strip)
49.359 +apply (erule conjE)
49.360 +apply simp
49.361 +apply (drule inject_Isinl)
49.362 +apply (drule inject_Isinl)
49.363 +apply simp
49.364 +apply (rule conjI)
49.365 +apply (intro strip)
49.366 +apply (erule conjE)
49.367 +apply simp
49.368 +apply (drule noteq_IsinlIsinr[OF sym])
49.369 +apply simp
49.370 +apply (rule conjI)
49.371 +apply (intro strip)
49.372 +apply (erule conjE)
49.373 +apply simp
49.374 +apply (drule inject_Isinl)
49.375 +apply (drule noteq_IsinlIsinr[OF sym])
49.376 +apply simp
49.377 +apply (rule eq_UU_iff[symmetric])
49.378 +apply (intro strip)
49.379 +apply (erule conjE)
49.380 +apply simp
49.381 +apply (drule noteq_IsinlIsinr[OF sym])
49.382 +apply simp
49.383 +done
49.384 +
49.385 +
49.386 +lemma less_ssum1b:
49.387 +"[|s1=Isinr(x::'b); s2=Isinr(y::'b)|] ==> s1 << s2 = (x << y)"
49.388 +apply (unfold less_ssum_def)
49.389 +apply (rule some_equality)
49.390 +apply (drule_tac [2] conjunct2)
49.391 +apply (drule_tac [2] conjunct1)
49.392 +apply (drule_tac [2] spec)
49.393 +apply (drule_tac [2] spec)
49.394 +apply (erule_tac [2] mp)
49.395 +prefer 2 apply fast
49.396 +apply (rule conjI)
49.397 +apply (intro strip)
49.398 +apply (erule conjE)
49.399 +apply simp
49.400 +apply (drule noteq_IsinlIsinr)
49.401 +apply (drule noteq_IsinlIsinr)
49.402 +apply simp
49.403 +apply (rule conjI)
49.404 +apply (intro strip)
49.405 +apply (erule conjE)
49.406 +apply simp
49.407 +apply (drule inject_Isinr)
49.408 +apply (drule inject_Isinr)
49.409 +apply simp
49.410 +apply (rule conjI)
49.411 +apply (intro strip)
49.412 +apply (erule conjE)
49.413 +apply simp
49.414 +apply (drule noteq_IsinlIsinr)
49.415 +apply (drule inject_Isinr)
49.416 +apply simp
49.417 +apply (intro strip)
49.418 +apply (erule conjE)
49.419 +apply simp
49.420 +apply (drule inject_Isinr)
49.421 +apply (drule noteq_IsinlIsinr)
49.422 +apply simp
49.423 +apply (rule eq_UU_iff[symmetric])
49.424 +done
49.425 +
49.426 +
49.427 +lemma less_ssum1c:
49.428 +"[|s1=Isinl(x::'a); s2=Isinr(y::'b)|] ==> s1 << s2 = ((x::'a) = UU)"
49.429 +apply (unfold less_ssum_def)
49.430 +apply (rule some_equality)
49.431 +apply (rule conjI)
49.432 +apply (intro strip)
49.433 +apply (erule conjE)
49.434 +apply simp
49.435 +apply (drule inject_Isinl)
49.436 +apply (drule noteq_IsinlIsinr)
49.437 +apply simp
49.438 +apply (rule eq_UU_iff)
49.439 +apply (rule conjI)
49.440 +apply (intro strip)
49.441 +apply (erule conjE)
49.442 +apply simp
49.443 +apply (drule noteq_IsinlIsinr[OF sym])
49.444 +apply (drule inject_Isinr)
49.445 +apply simp
49.446 +apply (rule conjI)
49.447 +apply (intro strip)
49.448 +apply (erule conjE)
49.449 +apply simp
49.450 +apply (drule inject_Isinl)
49.451 +apply (drule inject_Isinr)
49.452 +apply simp
49.453 +apply (intro strip)
49.454 +apply (erule conjE)
49.455 +apply simp
49.456 +apply (drule noteq_IsinlIsinr[OF sym])
49.457 +apply (drule noteq_IsinlIsinr)
49.458 +apply simp
49.459 +apply (drule conjunct2)
49.460 +apply (drule conjunct2)
49.461 +apply (drule conjunct1)
49.462 +apply (drule spec)
49.463 +apply (drule spec)
49.464 +apply (erule mp)
49.465 +apply fast
49.466 +done
49.467 +
49.468 +
49.469 +lemma less_ssum1d:
49.470 +"[|s1=Isinr(x); s2=Isinl(y)|] ==> s1 << s2 = (x = UU)"
49.471 +apply (unfold less_ssum_def)
49.472 +apply (rule some_equality)
49.473 +apply (drule_tac [2] conjunct2)
49.474 +apply (drule_tac [2] conjunct2)
49.475 +apply (drule_tac [2] conjunct2)
49.476 +apply (drule_tac [2] spec)
49.477 +apply (drule_tac [2] spec)
49.478 +apply (erule_tac [2] mp)
49.479 +prefer 2 apply fast
49.480 +apply (rule conjI)
49.481 +apply (intro strip)
49.482 +apply (erule conjE)
49.483 +apply simp
49.484 +apply (drule noteq_IsinlIsinr)
49.485 +apply (drule inject_Isinl)
49.486 +apply simp
49.487 +apply (rule conjI)
49.488 +apply (intro strip)
49.489 +apply (erule conjE)
49.490 +apply simp
49.491 +apply (drule noteq_IsinlIsinr[OF sym])
49.492 +apply (drule inject_Isinr)
49.493 +apply simp
49.494 +apply (rule eq_UU_iff)
49.495 +apply (rule conjI)
49.496 +apply (intro strip)
49.497 +apply (erule conjE)
49.498 +apply simp
49.499 +apply (drule noteq_IsinlIsinr)
49.500 +apply (drule noteq_IsinlIsinr[OF sym])
49.501 +apply simp
49.502 +apply (intro strip)
49.503 +apply (erule conjE)
49.504 +apply simp
49.505 +apply (drule inject_Isinr)
49.506 +apply simp
49.507 +done
49.508 +
49.509 +
49.510 +(* ------------------------------------------------------------------------ *)
49.511 +(* optimize lemmas about less_ssum *)
49.512 +(* ------------------------------------------------------------------------ *)
49.513 +
49.514 +lemma less_ssum2a: "(Isinl x) << (Isinl y) = (x << y)"
49.515 +apply (rule less_ssum1a)
49.516 +apply (rule refl)
49.517 +apply (rule refl)
49.518 +done
49.519 +
49.520 +lemma less_ssum2b: "(Isinr x) << (Isinr y) = (x << y)"
49.521 +apply (rule less_ssum1b)
49.522 +apply (rule refl)
49.523 +apply (rule refl)
49.524 +done
49.525 +
49.526 +lemma less_ssum2c: "(Isinl x) << (Isinr y) = (x = UU)"
49.527 +apply (rule less_ssum1c)
49.528 +apply (rule refl)
49.529 +apply (rule refl)
49.530 +done
49.531 +
49.532 +lemma less_ssum2d: "(Isinr x) << (Isinl y) = (x = UU)"
49.533 +apply (rule less_ssum1d)
49.534 +apply (rule refl)
49.535 +apply (rule refl)
49.536 +done
49.537 +
49.538 +
49.539 +(* ------------------------------------------------------------------------ *)
49.540 +(* less_ssum is a partial order on ++ *)
49.541 +(* ------------------------------------------------------------------------ *)
49.542 +
49.543 +lemma refl_less_ssum: "(p::'a++'b) << p"
49.544 +apply (rule_tac p = "p" in IssumE2)
49.545 +apply (erule ssubst)
49.546 +apply (rule less_ssum2a [THEN iffD2])
49.547 +apply (rule refl_less)
49.548 +apply (erule ssubst)
49.549 +apply (rule less_ssum2b [THEN iffD2])
49.550 +apply (rule refl_less)
49.551 +done
49.552 +
49.553 +lemma antisym_less_ssum: "[|(p1::'a++'b) << p2; p2 << p1|] ==> p1=p2"
49.554 +apply (rule_tac p = "p1" in IssumE2)
49.555 +apply simp
49.556 +apply (rule_tac p = "p2" in IssumE2)
49.557 +apply simp
49.558 +apply (rule_tac f = "Isinl" in arg_cong)
49.559 +apply (rule antisym_less)
49.560 +apply (erule less_ssum2a [THEN iffD1])
49.561 +apply (erule less_ssum2a [THEN iffD1])
49.562 +apply simp
49.563 +apply (erule less_ssum2d [THEN iffD1, THEN ssubst])
49.564 +apply (erule less_ssum2c [THEN iffD1, THEN ssubst])
49.565 +apply (rule strict_IsinlIsinr)
49.566 +apply simp
49.567 +apply (rule_tac p = "p2" in IssumE2)
49.568 +apply simp
49.569 +apply (erule less_ssum2c [THEN iffD1, THEN ssubst])
49.570 +apply (erule less_ssum2d [THEN iffD1, THEN ssubst])
49.571 +apply (rule strict_IsinlIsinr [symmetric])
49.572 +apply simp
49.573 +apply (rule_tac f = "Isinr" in arg_cong)
49.574 +apply (rule antisym_less)
49.575 +apply (erule less_ssum2b [THEN iffD1])
49.576 +apply (erule less_ssum2b [THEN iffD1])
49.577 +done
49.578 +
49.579 +lemma trans_less_ssum: "[|(p1::'a++'b) << p2; p2 << p3|] ==> p1 << p3"
49.580 +apply (rule_tac p = "p1" in IssumE2)
49.581 +apply simp
49.582 +apply (rule_tac p = "p3" in IssumE2)
49.583 +apply simp
49.584 +apply (rule less_ssum2a [THEN iffD2])
49.585 +apply (rule_tac p = "p2" in IssumE2)
49.586 +apply simp
49.587 +apply (rule trans_less)
49.588 +apply (erule less_ssum2a [THEN iffD1])
49.589 +apply (erule less_ssum2a [THEN iffD1])
49.590 +apply simp
49.591 +apply (erule less_ssum2c [THEN iffD1, THEN ssubst])
49.592 +apply (rule minimal)
49.593 +apply simp
49.594 +apply (rule less_ssum2c [THEN iffD2])
49.595 +apply (rule_tac p = "p2" in IssumE2)
49.596 +apply simp
49.597 +apply (rule UU_I)
49.598 +apply (rule trans_less)
49.599 +apply (erule less_ssum2a [THEN iffD1])
49.600 +apply (rule antisym_less_inverse [THEN conjunct1])
49.601 +apply (erule less_ssum2c [THEN iffD1])
49.602 +apply simp
49.603 +apply (erule less_ssum2c [THEN iffD1])
49.604 +apply simp
49.605 +apply (rule_tac p = "p3" in IssumE2)
49.606 +apply simp
49.607 +apply (rule less_ssum2d [THEN iffD2])
49.608 +apply (rule_tac p = "p2" in IssumE2)
49.609 +apply simp
49.610 +apply (erule less_ssum2d [THEN iffD1])
49.611 +apply simp
49.612 +apply (rule UU_I)
49.613 +apply (rule trans_less)
49.614 +apply (erule less_ssum2b [THEN iffD1])
49.615 +apply (rule antisym_less_inverse [THEN conjunct1])
49.616 +apply (erule less_ssum2d [THEN iffD1])
49.617 +apply simp
49.618 +apply (rule less_ssum2b [THEN iffD2])
49.619 +apply (rule_tac p = "p2" in IssumE2)
49.620 +apply simp
49.621 +apply (erule less_ssum2d [THEN iffD1, THEN ssubst])
49.622 +apply (rule minimal)
49.623 +apply simp
49.624 +apply (rule trans_less)
49.625 +apply (erule less_ssum2b [THEN iffD1])
49.626 +apply (erule less_ssum2b [THEN iffD1])
49.627 +done
49.628 +
49.629 +(* Class Instance ++::(pcpo,pcpo)po *)
49.630 +
49.631 +instance "++"::(pcpo,pcpo)po
49.632 +apply (intro_classes)
49.633 +apply (rule refl_less_ssum)
49.634 +apply (rule antisym_less_ssum, assumption+)
49.635 +apply (rule trans_less_ssum, assumption+)
49.636 +done
49.637 +
49.638 +(* for compatibility with old HOLCF-Version *)
49.639 +lemma inst_ssum_po: "(op <<)=(%s1 s2.@z.
49.640 + (! u x. s1=Isinl u & s2=Isinl x --> z = u << x)
49.641 + &(! v y. s1=Isinr v & s2=Isinr y --> z = v << y)
49.642 + &(! u y. s1=Isinl u & s2=Isinr y --> z = (u = UU))
49.643 + &(! v x. s1=Isinr v & s2=Isinl x --> z = (v = UU)))"
49.644 +apply (fold less_ssum_def)
49.645 +apply (rule refl)
49.646 +done
49.647 +
49.648 +(* ------------------------------------------------------------------------ *)
49.649 +(* access to less_ssum in class po *)
49.650 +(* ------------------------------------------------------------------------ *)
49.651 +
49.652 +lemma less_ssum3a: "Isinl x << Isinl y = x << y"
49.653 +apply (simp (no_asm) add: less_ssum2a)
49.654 +done
49.655 +
49.656 +lemma less_ssum3b: "Isinr x << Isinr y = x << y"
49.657 +apply (simp (no_asm) add: less_ssum2b)
49.658 +done
49.659 +
49.660 +lemma less_ssum3c: "Isinl x << Isinr y = (x = UU)"
49.661 +apply (simp (no_asm) add: less_ssum2c)
49.662 +done
49.663 +
49.664 +lemma less_ssum3d: "Isinr x << Isinl y = (x = UU)"
49.665 +apply (simp (no_asm) add: less_ssum2d)
49.666 +done
49.667 +
49.668 +(* ------------------------------------------------------------------------ *)
49.669 +(* type ssum ++ is pointed *)
49.670 +(* ------------------------------------------------------------------------ *)
49.671 +
49.672 +lemma minimal_ssum: "Isinl UU << s"
49.673 +apply (rule_tac p = "s" in IssumE2)
49.674 +apply simp
49.675 +apply (rule less_ssum3a [THEN iffD2])
49.676 +apply (rule minimal)
49.677 +apply simp
49.678 +apply (subst strict_IsinlIsinr)
49.679 +apply (rule less_ssum3b [THEN iffD2])
49.680 +apply (rule minimal)
49.681 +done
49.682 +
49.683 +lemmas UU_ssum_def = minimal_ssum [THEN minimal2UU, symmetric, standard]
49.684 +
49.685 +lemma least_ssum: "? x::'a++'b.!y. x<<y"
49.686 +apply (rule_tac x = "Isinl UU" in exI)
49.687 +apply (rule minimal_ssum [THEN allI])
49.688 +done
49.689 +
49.690 +(* ------------------------------------------------------------------------ *)
49.691 +(* Isinl, Isinr are monotone *)
49.692 +(* ------------------------------------------------------------------------ *)
49.693 +
49.694 +lemma monofun_Isinl: "monofun(Isinl)"
49.695 +apply (unfold monofun)
49.696 +apply (intro strip)
49.697 +apply (erule less_ssum3a [THEN iffD2])
49.698 +done
49.699 +
49.700 +lemma monofun_Isinr: "monofun(Isinr)"
49.701 +apply (unfold monofun)
49.702 +apply (intro strip)
49.703 +apply (erule less_ssum3b [THEN iffD2])
49.704 +done
49.705 +
49.706 +
49.707 +(* ------------------------------------------------------------------------ *)
49.708 +(* Iwhen is monotone in all arguments *)
49.709 +(* ------------------------------------------------------------------------ *)
49.710 +
49.711 +
49.712 +lemma monofun_Iwhen1: "monofun(Iwhen)"
49.713 +apply (unfold monofun)
49.714 +apply (intro strip)
49.715 +apply (rule less_fun [THEN iffD2])
49.716 +apply (intro strip)
49.717 +apply (rule less_fun [THEN iffD2])
49.718 +apply (intro strip)
49.719 +apply (rule_tac p = "xb" in IssumE)
49.720 +apply simp
49.721 +apply simp
49.722 +apply (erule monofun_cfun_fun)
49.723 +apply simp
49.724 +done
49.725 +
49.726 +lemma monofun_Iwhen2: "monofun(Iwhen(f))"
49.727 +apply (unfold monofun)
49.728 +apply (intro strip)
49.729 +apply (rule less_fun [THEN iffD2])
49.730 +apply (intro strip)
49.731 +apply (rule_tac p = "xa" in IssumE)
49.732 +apply simp
49.733 +apply simp
49.734 +apply simp
49.735 +apply (erule monofun_cfun_fun)
49.736 +done
49.737 +
49.738 +lemma monofun_Iwhen3: "monofun(Iwhen(f)(g))"
49.739 +apply (unfold monofun)
49.740 +apply (intro strip)
49.741 +apply (rule_tac p = "x" in IssumE)
49.742 +apply simp
49.743 +apply (rule_tac p = "y" in IssumE)
49.744 +apply simp
49.745 +apply (rule_tac P = "xa=UU" in notE)
49.746 +apply assumption
49.747 +apply (rule UU_I)
49.748 +apply (rule less_ssum3a [THEN iffD1])
49.749 +apply assumption
49.750 +apply simp
49.751 +apply (rule monofun_cfun_arg)
49.752 +apply (erule less_ssum3a [THEN iffD1])
49.753 +apply (simp del: Iwhen2)
49.754 +apply (rule_tac s = "UU" and t = "xa" in subst)
49.755 +apply (erule less_ssum3c [THEN iffD1, symmetric])
49.756 +apply simp
49.757 +apply (rule_tac p = "y" in IssumE)
49.758 +apply simp
49.759 +apply (simp only: less_ssum3d)
49.760 +apply (simp only: less_ssum3d)
49.761 +apply simp
49.762 +apply (rule monofun_cfun_arg)
49.763 +apply (erule less_ssum3b [THEN iffD1])
49.764 +done
49.765 +
49.766 +
49.767 +(* ------------------------------------------------------------------------ *)
49.768 +(* some kind of exhaustion rules for chains in 'a ++ 'b *)
49.769 +(* ------------------------------------------------------------------------ *)
49.770 +
49.771 +lemma ssum_lemma1: "[|~(!i.? x. Y(i::nat)=Isinl(x))|] ==> (? i.! x. Y(i)~=Isinl(x))"
49.772 +apply fast
49.773 +done
49.774 +
49.775 +lemma ssum_lemma2: "[|(? i.!x.(Y::nat => 'a++'b)(i::nat)~=Isinl(x::'a))|]
49.776 + ==> (? i y. (Y::nat => 'a++'b)(i::nat)=Isinr(y::'b) & y~=UU)"
49.777 +apply (erule exE)
49.778 +apply (rule_tac p = "Y (i) " in IssumE)
49.779 +apply (drule spec)
49.780 +apply (erule notE, assumption)
49.781 +apply (drule spec)
49.782 +apply (erule notE, assumption)
49.783 +apply fast
49.784 +done
49.785 +
49.786 +
49.787 +lemma ssum_lemma3: "[|chain(Y);(? i x. Y(i)=Isinr(x::'b) & (x::'b)~=UU)|]
49.788 + ==> (!i.? y. Y(i)=Isinr(y))"
49.789 +apply (erule exE)
49.790 +apply (erule exE)
49.791 +apply (rule allI)
49.792 +apply (rule_tac p = "Y (ia) " in IssumE)
49.793 +apply (rule exI)
49.794 +apply (rule trans)
49.795 +apply (rule_tac [2] strict_IsinlIsinr)
49.796 +apply assumption
49.797 +apply (erule_tac [2] exI)
49.798 +apply (erule conjE)
49.799 +apply (rule_tac m = "i" and n = "ia" in nat_less_cases)
49.800 +prefer 2 apply simp
49.801 +apply (rule exI, rule refl)
49.802 +apply (erule_tac P = "x=UU" in notE)
49.803 +apply (rule less_ssum3d [THEN iffD1])
49.804 +apply (erule_tac s = "Y (i) " and t = "Isinr (x) ::'a++'b" in subst)
49.805 +apply (erule_tac s = "Y (ia) " and t = "Isinl (xa) ::'a++'b" in subst)
49.806 +apply (erule chain_mono)
49.807 +apply assumption
49.808 +apply (erule_tac P = "xa=UU" in notE)
49.809 +apply (rule less_ssum3c [THEN iffD1])
49.810 +apply (erule_tac s = "Y (i) " and t = "Isinr (x) ::'a++'b" in subst)
49.811 +apply (erule_tac s = "Y (ia) " and t = "Isinl (xa) ::'a++'b" in subst)
49.812 +apply (erule chain_mono)
49.813 +apply assumption
49.814 +done
49.815 +
49.816 +lemma ssum_lemma4: "chain(Y) ==> (!i.? x. Y(i)=Isinl(x))|(!i.? y. Y(i)=Isinr(y))"
49.817 +apply (rule case_split_thm)
49.818 +apply (erule disjI1)
49.819 +apply (rule disjI2)
49.820 +apply (erule ssum_lemma3)
49.821 +apply (rule ssum_lemma2)
49.822 +apply (erule ssum_lemma1)
49.823 +done
49.824 +
49.825 +
49.826 +(* ------------------------------------------------------------------------ *)
49.827 +(* restricted surjectivity of Isinl *)
49.828 +(* ------------------------------------------------------------------------ *)
49.829 +
49.830 +lemma ssum_lemma5: "z=Isinl(x)==> Isinl((Iwhen (LAM x. x) (LAM y. UU))(z)) = z"
49.831 +apply simp
49.832 +apply (case_tac "x=UU")
49.833 +apply simp
49.834 +apply simp
49.835 +done
49.836 +
49.837 +(* ------------------------------------------------------------------------ *)
49.838 +(* restricted surjectivity of Isinr *)
49.839 +(* ------------------------------------------------------------------------ *)
49.840 +
49.841 +lemma ssum_lemma6: "z=Isinr(x)==> Isinr((Iwhen (LAM y. UU) (LAM x. x))(z)) = z"
49.842 +apply simp
49.843 +apply (case_tac "x=UU")
49.844 +apply simp
49.845 +apply simp
49.846 +done
49.847 +
49.848 +(* ------------------------------------------------------------------------ *)
49.849 +(* technical lemmas *)
49.850 +(* ------------------------------------------------------------------------ *)
49.851 +
49.852 +lemma ssum_lemma7: "[|Isinl(x) << z; x~=UU|] ==> ? y. z=Isinl(y) & y~=UU"
49.853 +apply (rule_tac p = "z" in IssumE)
49.854 +apply simp
49.855 +apply (erule notE)
49.856 +apply (rule antisym_less)
49.857 +apply (erule less_ssum3a [THEN iffD1])
49.858 +apply (rule minimal)
49.859 +apply fast
49.860 +apply simp
49.861 +apply (rule notE)
49.862 +apply (erule_tac [2] less_ssum3c [THEN iffD1])
49.863 +apply assumption
49.864 +done
49.865 +
49.866 +lemma ssum_lemma8: "[|Isinr(x) << z; x~=UU|] ==> ? y. z=Isinr(y) & y~=UU"
49.867 +apply (rule_tac p = "z" in IssumE)
49.868 +apply simp
49.869 +apply (erule notE)
49.870 +apply (erule less_ssum3d [THEN iffD1])
49.871 +apply simp
49.872 +apply (rule notE)
49.873 +apply (erule_tac [2] less_ssum3d [THEN iffD1])
49.874 +apply assumption
49.875 +apply fast
49.876 +done
49.877 +
49.878 +(* ------------------------------------------------------------------------ *)
49.879 +(* the type 'a ++ 'b is a cpo in three steps *)
49.880 +(* ------------------------------------------------------------------------ *)
49.881 +
49.882 +lemma lub_ssum1a: "[|chain(Y);(!i.? x. Y(i)=Isinl(x))|] ==>
49.883 + range(Y) <<| Isinl(lub(range(%i.(Iwhen (LAM x. x) (LAM y. UU))(Y i))))"
49.884 +apply (rule is_lubI)
49.885 +apply (rule ub_rangeI)
49.886 +apply (erule allE)
49.887 +apply (erule exE)
49.888 +apply (rule_tac t = "Y (i) " in ssum_lemma5 [THEN subst])
49.889 +apply assumption
49.890 +apply (rule monofun_Isinl [THEN monofunE, THEN spec, THEN spec, THEN mp])
49.891 +apply (rule is_ub_thelub)
49.892 +apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
49.893 +apply (rule_tac p = "u" in IssumE2)
49.894 +apply (rule_tac t = "u" in ssum_lemma5 [THEN subst])
49.895 +apply assumption
49.896 +apply (rule monofun_Isinl [THEN monofunE, THEN spec, THEN spec, THEN mp])
49.897 +apply (rule is_lub_thelub)
49.898 +apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
49.899 +apply (erule monofun_Iwhen3 [THEN ub2ub_monofun])
49.900 +apply simp
49.901 +apply (rule less_ssum3c [THEN iffD2])
49.902 +apply (rule chain_UU_I_inverse)
49.903 +apply (rule allI)
49.904 +apply (rule_tac p = "Y (i) " in IssumE)
49.905 +apply simp
49.906 +apply simp
49.907 +apply (erule notE)
49.908 +apply (rule less_ssum3c [THEN iffD1])
49.909 +apply (rule_tac t = "Isinl (x) " in subst)
49.910 +apply assumption
49.911 +apply (erule ub_rangeD)
49.912 +apply simp
49.913 +done
49.914 +
49.915 +
49.916 +lemma lub_ssum1b: "[|chain(Y);(!i.? x. Y(i)=Isinr(x))|] ==>
49.917 + range(Y) <<| Isinr(lub(range(%i.(Iwhen (LAM y. UU) (LAM x. x))(Y i))))"
49.918 +apply (rule is_lubI)
49.919 +apply (rule ub_rangeI)
49.920 +apply (erule allE)
49.921 +apply (erule exE)
49.922 +apply (rule_tac t = "Y (i) " in ssum_lemma6 [THEN subst])
49.923 +apply assumption
49.924 +apply (rule monofun_Isinr [THEN monofunE, THEN spec, THEN spec, THEN mp])
49.925 +apply (rule is_ub_thelub)
49.926 +apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
49.927 +apply (rule_tac p = "u" in IssumE2)
49.928 +apply simp
49.929 +apply (rule less_ssum3d [THEN iffD2])
49.930 +apply (rule chain_UU_I_inverse)
49.931 +apply (rule allI)
49.932 +apply (rule_tac p = "Y (i) " in IssumE)
49.933 +apply simp
49.934 +apply simp
49.935 +apply (erule notE)
49.936 +apply (rule less_ssum3d [THEN iffD1])
49.937 +apply (rule_tac t = "Isinr (y) " in subst)
49.938 +apply assumption
49.939 +apply (erule ub_rangeD)
49.940 +apply (rule_tac t = "u" in ssum_lemma6 [THEN subst])
49.941 +apply assumption
49.942 +apply (rule monofun_Isinr [THEN monofunE, THEN spec, THEN spec, THEN mp])
49.943 +apply (rule is_lub_thelub)
49.944 +apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
49.945 +apply (erule monofun_Iwhen3 [THEN ub2ub_monofun])
49.946 +done
49.947 +
49.948 +
49.949 +lemmas thelub_ssum1a = lub_ssum1a [THEN thelubI, standard]
49.950 +(*
49.951 +[| chain ?Y1; ! i. ? x. ?Y1 i = Isinl x |] ==>
49.952 + lub (range ?Y1) = Isinl
49.953 + (lub (range (%i. Iwhen (LAM x. x) (LAM y. UU) (?Y1 i))))
49.954 +*)
49.955 +
49.956 +lemmas thelub_ssum1b = lub_ssum1b [THEN thelubI, standard]
49.957 +(*
49.958 +[| chain ?Y1; ! i. ? x. ?Y1 i = Isinr x |] ==>
49.959 + lub (range ?Y1) = Isinr
49.960 + (lub (range (%i. Iwhen (LAM y. UU) (LAM x. x) (?Y1 i))))
49.961 +*)
49.962 +
49.963 +lemma cpo_ssum: "chain(Y::nat=>'a ++'b) ==> ? x. range(Y) <<|x"
49.964 +apply (rule ssum_lemma4 [THEN disjE])
49.965 +apply assumption
49.966 +apply (rule exI)
49.967 +apply (erule lub_ssum1a)
49.968 +apply assumption
49.969 +apply (rule exI)
49.970 +apply (erule lub_ssum1b)
49.971 +apply assumption
49.972 +done
49.973 +
49.974 +(* Class instance of ++ for class pcpo *)
49.975 +
49.976 +instance "++" :: (pcpo,pcpo)pcpo
49.977 +apply (intro_classes)
49.978 +apply (erule cpo_ssum)
49.979 +apply (rule least_ssum)
49.980 +done
49.981 +
49.982 +consts
49.983 + sinl :: "'a -> ('a++'b)"
49.984 + sinr :: "'b -> ('a++'b)"
49.985 + sscase :: "('a->'c)->('b->'c)->('a ++ 'b)-> 'c"
49.986 +
49.987 +defs
49.988 +
49.989 +sinl_def: "sinl == (LAM x. Isinl(x))"
49.990 +sinr_def: "sinr == (LAM x. Isinr(x))"
49.991 +sscase_def: "sscase == (LAM f g s. Iwhen(f)(g)(s))"
49.992 +
49.993 +translations
49.994 +"case s of sinl$x => t1 | sinr$y => t2" == "sscase$(LAM x. t1)$(LAM y. t2)$s"
49.995 +
49.996 +(* for compatibility with old HOLCF-Version *)
49.997 +lemma inst_ssum_pcpo: "UU = Isinl UU"
49.998 +apply (simp add: UU_def UU_ssum_def)
49.999 +done
49.1000 +
49.1001 +declare inst_ssum_pcpo [symmetric, simp]
49.1002 +
49.1003 +(* ------------------------------------------------------------------------ *)
49.1004 +(* continuity for Isinl and Isinr *)
49.1005 +(* ------------------------------------------------------------------------ *)
49.1006 +
49.1007 +lemma contlub_Isinl: "contlub(Isinl)"
49.1008 +apply (rule contlubI)
49.1009 +apply (intro strip)
49.1010 +apply (rule trans)
49.1011 +apply (rule_tac [2] thelub_ssum1a [symmetric])
49.1012 +apply (rule_tac [3] allI)
49.1013 +apply (rule_tac [3] exI)
49.1014 +apply (rule_tac [3] refl)
49.1015 +apply (erule_tac [2] monofun_Isinl [THEN ch2ch_monofun])
49.1016 +apply (case_tac "lub (range (Y))=UU")
49.1017 +apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
49.1018 +apply assumption
49.1019 +apply (rule_tac f = "Isinl" in arg_cong)
49.1020 +apply (rule chain_UU_I_inverse [symmetric])
49.1021 +apply (rule allI)
49.1022 +apply (rule_tac s = "UU" and t = "Y (i) " in ssubst)
49.1023 +apply (erule chain_UU_I [THEN spec])
49.1024 +apply assumption
49.1025 +apply (rule Iwhen1)
49.1026 +apply (rule_tac f = "Isinl" in arg_cong)
49.1027 +apply (rule lub_equal)
49.1028 +apply assumption
49.1029 +apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
49.1030 +apply (erule monofun_Isinl [THEN ch2ch_monofun])
49.1031 +apply (rule allI)
49.1032 +apply (case_tac "Y (k) =UU")
49.1033 +apply (erule ssubst)
49.1034 +apply (rule Iwhen1[symmetric])
49.1035 +apply simp
49.1036 +done
49.1037 +
49.1038 +lemma contlub_Isinr: "contlub(Isinr)"
49.1039 +apply (rule contlubI)
49.1040 +apply (intro strip)
49.1041 +apply (rule trans)
49.1042 +apply (rule_tac [2] thelub_ssum1b [symmetric])
49.1043 +apply (rule_tac [3] allI)
49.1044 +apply (rule_tac [3] exI)
49.1045 +apply (rule_tac [3] refl)
49.1046 +apply (erule_tac [2] monofun_Isinr [THEN ch2ch_monofun])
49.1047 +apply (case_tac "lub (range (Y))=UU")
49.1048 +apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
49.1049 +apply assumption
49.1050 +apply (rule arg_cong, rule chain_UU_I_inverse [symmetric])
49.1051 +apply (rule allI)
49.1052 +apply (rule_tac s = "UU" and t = "Y (i) " in ssubst)
49.1053 +apply (erule chain_UU_I [THEN spec])
49.1054 +apply assumption
49.1055 +apply (rule strict_IsinlIsinr [THEN subst])
49.1056 +apply (rule Iwhen1)
49.1057 +apply (rule arg_cong, rule lub_equal)
49.1058 +apply assumption
49.1059 +apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
49.1060 +apply (erule monofun_Isinr [THEN ch2ch_monofun])
49.1061 +apply (rule allI)
49.1062 +apply (case_tac "Y (k) =UU")
49.1063 +apply (simp only: Ssum0_ss)
49.1064 +apply simp
49.1065 +done
49.1066 +
49.1067 +lemma cont_Isinl: "cont(Isinl)"
49.1068 +apply (rule monocontlub2cont)
49.1069 +apply (rule monofun_Isinl)
49.1070 +apply (rule contlub_Isinl)
49.1071 +done
49.1072 +
49.1073 +lemma cont_Isinr: "cont(Isinr)"
49.1074 +apply (rule monocontlub2cont)
49.1075 +apply (rule monofun_Isinr)
49.1076 +apply (rule contlub_Isinr)
49.1077 +done
49.1078 +
49.1079 +declare cont_Isinl [iff] cont_Isinr [iff]
49.1080 +
49.1081 +
49.1082 +(* ------------------------------------------------------------------------ *)
49.1083 +(* continuity for Iwhen in the firts two arguments *)
49.1084 +(* ------------------------------------------------------------------------ *)
49.1085 +
49.1086 +lemma contlub_Iwhen1: "contlub(Iwhen)"
49.1087 +apply (rule contlubI)
49.1088 +apply (intro strip)
49.1089 +apply (rule trans)
49.1090 +apply (rule_tac [2] thelub_fun [symmetric])
49.1091 +apply (erule_tac [2] monofun_Iwhen1 [THEN ch2ch_monofun])
49.1092 +apply (rule expand_fun_eq [THEN iffD2])
49.1093 +apply (intro strip)
49.1094 +apply (rule trans)
49.1095 +apply (rule_tac [2] thelub_fun [symmetric])
49.1096 +apply (rule_tac [2] ch2ch_fun)
49.1097 +apply (erule_tac [2] monofun_Iwhen1 [THEN ch2ch_monofun])
49.1098 +apply (rule expand_fun_eq [THEN iffD2])
49.1099 +apply (intro strip)
49.1100 +apply (rule_tac p = "xa" in IssumE)
49.1101 +apply (simp only: Ssum0_ss)
49.1102 +apply (rule lub_const [THEN thelubI, symmetric])
49.1103 +apply simp
49.1104 +apply (erule contlub_cfun_fun)
49.1105 +apply simp
49.1106 +apply (rule lub_const [THEN thelubI, symmetric])
49.1107 +done
49.1108 +
49.1109 +lemma contlub_Iwhen2: "contlub(Iwhen(f))"
49.1110 +apply (rule contlubI)
49.1111 +apply (intro strip)
49.1112 +apply (rule trans)
49.1113 +apply (rule_tac [2] thelub_fun [symmetric])
49.1114 +apply (erule_tac [2] monofun_Iwhen2 [THEN ch2ch_monofun])
49.1115 +apply (rule expand_fun_eq [THEN iffD2])
49.1116 +apply (intro strip)
49.1117 +apply (rule_tac p = "x" in IssumE)
49.1118 +apply (simp only: Ssum0_ss)
49.1119 +apply (rule lub_const [THEN thelubI, symmetric])
49.1120 +apply simp
49.1121 +apply (rule lub_const [THEN thelubI, symmetric])
49.1122 +apply simp
49.1123 +apply (erule contlub_cfun_fun)
49.1124 +done
49.1125 +
49.1126 +(* ------------------------------------------------------------------------ *)
49.1127 +(* continuity for Iwhen in its third argument *)
49.1128 +(* ------------------------------------------------------------------------ *)
49.1129 +
49.1130 +(* ------------------------------------------------------------------------ *)
49.1131 +(* first 5 ugly lemmas *)
49.1132 +(* ------------------------------------------------------------------------ *)
49.1133 +
49.1134 +lemma ssum_lemma9: "[| chain(Y); lub(range(Y)) = Isinl(x)|] ==> !i.? x. Y(i)=Isinl(x)"
49.1135 +apply (intro strip)
49.1136 +apply (rule_tac p = "Y (i) " in IssumE)
49.1137 +apply (erule exI)
49.1138 +apply (erule exI)
49.1139 +apply (rule_tac P = "y=UU" in notE)
49.1140 +apply assumption
49.1141 +apply (rule less_ssum3d [THEN iffD1])
49.1142 +apply (erule subst)
49.1143 +apply (erule subst)
49.1144 +apply (erule is_ub_thelub)
49.1145 +done
49.1146 +
49.1147 +
49.1148 +lemma ssum_lemma10: "[| chain(Y); lub(range(Y)) = Isinr(x)|] ==> !i.? x. Y(i)=Isinr(x)"
49.1149 +apply (intro strip)
49.1150 +apply (rule_tac p = "Y (i) " in IssumE)
49.1151 +apply (rule exI)
49.1152 +apply (erule trans)
49.1153 +apply (rule strict_IsinlIsinr)
49.1154 +apply (erule_tac [2] exI)
49.1155 +apply (rule_tac P = "xa=UU" in notE)
49.1156 +apply assumption
49.1157 +apply (rule less_ssum3c [THEN iffD1])
49.1158 +apply (erule subst)
49.1159 +apply (erule subst)
49.1160 +apply (erule is_ub_thelub)
49.1161 +done
49.1162 +
49.1163 +lemma ssum_lemma11: "[| chain(Y); lub(range(Y)) = Isinl(UU) |] ==>
49.1164 + Iwhen f g (lub(range Y)) = lub(range(%i. Iwhen f g (Y i)))"
49.1165 +apply (simp only: Ssum0_ss)
49.1166 +apply (rule chain_UU_I_inverse [symmetric])
49.1167 +apply (rule allI)
49.1168 +apply (rule_tac s = "Isinl (UU) " and t = "Y (i) " in subst)
49.1169 +apply (rule inst_ssum_pcpo [THEN subst])
49.1170 +apply (rule chain_UU_I [THEN spec, symmetric])
49.1171 +apply assumption
49.1172 +apply (erule inst_ssum_pcpo [THEN ssubst])
49.1173 +apply (simp only: Ssum0_ss)
49.1174 +done
49.1175 +
49.1176 +lemma ssum_lemma12: "[| chain(Y); lub(range(Y)) = Isinl(x); x ~= UU |] ==>
49.1177 + Iwhen f g (lub(range Y)) = lub(range(%i. Iwhen f g (Y i)))"
49.1178 +apply simp
49.1179 +apply (rule_tac t = "x" in subst)
49.1180 +apply (rule inject_Isinl)
49.1181 +apply (rule trans)
49.1182 +prefer 2 apply (assumption)
49.1183 +apply (rule thelub_ssum1a [symmetric])
49.1184 +apply assumption
49.1185 +apply (erule ssum_lemma9)
49.1186 +apply assumption
49.1187 +apply (rule trans)
49.1188 +apply (rule contlub_cfun_arg)
49.1189 +apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
49.1190 +apply assumption
49.1191 +apply (rule lub_equal2)
49.1192 +apply (rule chain_mono2 [THEN exE])
49.1193 +prefer 2 apply (assumption)
49.1194 +apply (rule chain_UU_I_inverse2)
49.1195 +apply (subst inst_ssum_pcpo)
49.1196 +apply (erule contrapos_np)
49.1197 +apply (rule inject_Isinl)
49.1198 +apply (rule trans)
49.1199 +apply (erule sym)
49.1200 +apply (erule notnotD)
49.1201 +apply (rule exI)
49.1202 +apply (intro strip)
49.1203 +apply (rule ssum_lemma9 [THEN spec, THEN exE])
49.1204 +apply assumption
49.1205 +apply assumption
49.1206 +apply (rule_tac t = "Y (i) " in ssubst)
49.1207 +apply assumption
49.1208 +apply (rule trans)
49.1209 +apply (rule cfun_arg_cong)
49.1210 +apply (rule Iwhen2)
49.1211 +apply force
49.1212 +apply (rule_tac t = "Y (i) " in ssubst)
49.1213 +apply assumption
49.1214 +apply auto
49.1215 +apply (subst Iwhen2)
49.1216 +apply force
49.1217 +apply (rule refl)
49.1218 +apply (rule monofun_Rep_CFun2 [THEN ch2ch_monofun])
49.1219 +apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
49.1220 +apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
49.1221 +done
49.1222 +
49.1223 +
49.1224 +lemma ssum_lemma13: "[| chain(Y); lub(range(Y)) = Isinr(x); x ~= UU |] ==>
49.1225 + Iwhen f g (lub(range Y)) = lub(range(%i. Iwhen f g (Y i)))"
49.1226 +apply simp
49.1227 +apply (rule_tac t = "x" in subst)
49.1228 +apply (rule inject_Isinr)
49.1229 +apply (rule trans)
49.1230 +prefer 2 apply (assumption)
49.1231 +apply (rule thelub_ssum1b [symmetric])
49.1232 +apply assumption
49.1233 +apply (erule ssum_lemma10)
49.1234 +apply assumption
49.1235 +apply (rule trans)
49.1236 +apply (rule contlub_cfun_arg)
49.1237 +apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
49.1238 +apply assumption
49.1239 +apply (rule lub_equal2)
49.1240 +apply (rule chain_mono2 [THEN exE])
49.1241 +prefer 2 apply (assumption)
49.1242 +apply (rule chain_UU_I_inverse2)
49.1243 +apply (subst inst_ssum_pcpo)
49.1244 +apply (erule contrapos_np)
49.1245 +apply (rule inject_Isinr)
49.1246 +apply (rule trans)
49.1247 +apply (erule sym)
49.1248 +apply (rule strict_IsinlIsinr [THEN subst])
49.1249 +apply (erule notnotD)
49.1250 +apply (rule exI)
49.1251 +apply (intro strip)
49.1252 +apply (rule ssum_lemma10 [THEN spec, THEN exE])
49.1253 +apply assumption
49.1254 +apply assumption
49.1255 +apply (rule_tac t = "Y (i) " in ssubst)
49.1256 +apply assumption
49.1257 +apply (rule trans)
49.1258 +apply (rule cfun_arg_cong)
49.1259 +apply (rule Iwhen3)
49.1260 +apply force
49.1261 +apply (rule_tac t = "Y (i) " in ssubst)
49.1262 +apply assumption
49.1263 +apply (subst Iwhen3)
49.1264 +apply force
49.1265 +apply (rule_tac t = "Y (i) " in ssubst)
49.1266 +apply assumption
49.1267 +apply simp
49.1268 +apply (rule monofun_Rep_CFun2 [THEN ch2ch_monofun])
49.1269 +apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
49.1270 +apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
49.1271 +done
49.1272 +
49.1273 +
49.1274 +lemma contlub_Iwhen3: "contlub(Iwhen(f)(g))"
49.1275 +apply (rule contlubI)
49.1276 +apply (intro strip)
49.1277 +apply (rule_tac p = "lub (range (Y))" in IssumE)
49.1278 +apply (erule ssum_lemma11)
49.1279 +apply assumption
49.1280 +apply (erule ssum_lemma12)
49.1281 +apply assumption
49.1282 +apply assumption
49.1283 +apply (erule ssum_lemma13)
49.1284 +apply assumption
49.1285 +apply assumption
49.1286 +done
49.1287 +
49.1288 +lemma cont_Iwhen1: "cont(Iwhen)"
49.1289 +apply (rule monocontlub2cont)
49.1290 +apply (rule monofun_Iwhen1)
49.1291 +apply (rule contlub_Iwhen1)
49.1292 +done
49.1293 +
49.1294 +lemma cont_Iwhen2: "cont(Iwhen(f))"
49.1295 +apply (rule monocontlub2cont)
49.1296 +apply (rule monofun_Iwhen2)
49.1297 +apply (rule contlub_Iwhen2)
49.1298 +done
49.1299 +
49.1300 +lemma cont_Iwhen3: "cont(Iwhen(f)(g))"
49.1301 +apply (rule monocontlub2cont)
49.1302 +apply (rule monofun_Iwhen3)
49.1303 +apply (rule contlub_Iwhen3)
49.1304 +done
49.1305 +
49.1306 +(* ------------------------------------------------------------------------ *)
49.1307 +(* continuous versions of lemmas for 'a ++ 'b *)
49.1308 +(* ------------------------------------------------------------------------ *)
49.1309 +
49.1310 +lemma strict_sinl [simp]: "sinl$UU =UU"
49.1311 +apply (unfold sinl_def)
49.1312 +apply (simp add: cont_Isinl)
49.1313 +done
49.1314 +
49.1315 +lemma strict_sinr [simp]: "sinr$UU=UU"
49.1316 +apply (unfold sinr_def)
49.1317 +apply (simp add: cont_Isinr)
49.1318 +done
49.1319 +
49.1320 +lemma noteq_sinlsinr:
49.1321 + "sinl$a=sinr$b ==> a=UU & b=UU"
49.1322 +apply (unfold sinl_def sinr_def)
49.1323 +apply (auto dest!: noteq_IsinlIsinr)
49.1324 +done
49.1325 +
49.1326 +lemma inject_sinl:
49.1327 + "sinl$a1=sinl$a2==> a1=a2"
49.1328 +apply (unfold sinl_def sinr_def)
49.1329 +apply auto
49.1330 +done
49.1331 +
49.1332 +lemma inject_sinr:
49.1333 + "sinr$a1=sinr$a2==> a1=a2"
49.1334 +apply (unfold sinl_def sinr_def)
49.1335 +apply auto
49.1336 +done
49.1337 +
49.1338 +declare inject_sinl [dest!] inject_sinr [dest!]
49.1339 +
49.1340 +lemma defined_sinl [simp]: "x~=UU ==> sinl$x ~= UU"
49.1341 +apply (erule contrapos_nn)
49.1342 +apply (rule inject_sinl)
49.1343 +apply auto
49.1344 +done
49.1345 +
49.1346 +lemma defined_sinr [simp]: "x~=UU ==> sinr$x ~= UU"
49.1347 +apply (erule contrapos_nn)
49.1348 +apply (rule inject_sinr)
49.1349 +apply auto
49.1350 +done
49.1351 +
49.1352 +lemma Exh_Ssum1:
49.1353 + "z=UU | (? a. z=sinl$a & a~=UU) | (? b. z=sinr$b & b~=UU)"
49.1354 +apply (unfold sinl_def sinr_def)
49.1355 +apply simp
49.1356 +apply (subst inst_ssum_pcpo)
49.1357 +apply (rule Exh_Ssum)
49.1358 +done
49.1359 +
49.1360 +
49.1361 +lemma ssumE:
49.1362 +assumes major: "p=UU ==> Q"
49.1363 +assumes prem2: "!!x.[|p=sinl$x; x~=UU |] ==> Q"
49.1364 +assumes prem3: "!!y.[|p=sinr$y; y~=UU |] ==> Q"
49.1365 +shows "Q"
49.1366 +apply (rule major [THEN IssumE])
49.1367 +apply (subst inst_ssum_pcpo)
49.1368 +apply assumption
49.1369 +apply (rule prem2)
49.1370 +prefer 2 apply (assumption)
49.1371 +apply (simp add: sinl_def)
49.1372 +apply (rule prem3)
49.1373 +prefer 2 apply (assumption)
49.1374 +apply (simp add: sinr_def)
49.1375 +done
49.1376 +
49.1377 +
49.1378 +lemma ssumE2:
49.1379 +assumes preml: "!!x.[|p=sinl$x|] ==> Q"
49.1380 +assumes premr: "!!y.[|p=sinr$y|] ==> Q"
49.1381 +shows "Q"
49.1382 +apply (rule IssumE2)
49.1383 +apply (rule preml)
49.1384 +apply (rule_tac [2] premr)
49.1385 +apply (unfold sinl_def sinr_def)
49.1386 +apply auto
49.1387 +done
49.1388 +
49.1389 +lemmas ssum_conts = cont_lemmas1 cont_Iwhen1 cont_Iwhen2
49.1390 + cont_Iwhen3 cont2cont_CF1L
49.1391 +
49.1392 +lemma sscase1 [simp]:
49.1393 + "sscase$f$g$UU = UU"
49.1394 +apply (unfold sscase_def sinl_def sinr_def)
49.1395 +apply (subst inst_ssum_pcpo)
49.1396 +apply (subst beta_cfun)
49.1397 +apply (intro ssum_conts)
49.1398 +apply (subst beta_cfun)
49.1399 +apply (intro ssum_conts)
49.1400 +apply (subst beta_cfun)
49.1401 +apply (intro ssum_conts)
49.1402 +apply (simp only: Ssum0_ss)
49.1403 +done
49.1404 +
49.1405 +lemma sscase2 [simp]:
49.1406 + "x~=UU==> sscase$f$g$(sinl$x) = f$x"
49.1407 +apply (unfold sscase_def sinl_def sinr_def)
49.1408 +apply (simplesubst beta_cfun)
49.1409 +apply (rule cont_Isinl)
49.1410 +apply (subst beta_cfun)
49.1411 +apply (intro ssum_conts)
49.1412 +apply (subst beta_cfun)
49.1413 +apply (intro ssum_conts)
49.1414 +apply (subst beta_cfun)
49.1415 +apply (intro ssum_conts)
49.1416 +apply simp
49.1417 +done
49.1418 +
49.1419 +lemma sscase3 [simp]:
49.1420 + "x~=UU==> sscase$f$g$(sinr$x) = g$x"
49.1421 +apply (unfold sscase_def sinl_def sinr_def)
49.1422 +apply (simplesubst beta_cfun)
49.1423 +apply (rule cont_Isinr)
49.1424 +apply (subst beta_cfun)
49.1425 +apply (intro ssum_conts)
49.1426 +apply (subst beta_cfun)
49.1427 +apply (intro ssum_conts)
49.1428 +apply (subst beta_cfun)
49.1429 +apply (intro ssum_conts)
49.1430 +apply simp
49.1431 +done
49.1432 +
49.1433 +lemma less_ssum4a:
49.1434 + "(sinl$x << sinl$y) = (x << y)"
49.1435 +apply (unfold sinl_def sinr_def)
49.1436 +apply (subst beta_cfun)
49.1437 +apply (rule cont_Isinl)
49.1438 +apply (subst beta_cfun)
49.1439 +apply (rule cont_Isinl)
49.1440 +apply (rule less_ssum3a)
49.1441 +done
49.1442 +
49.1443 +lemma less_ssum4b:
49.1444 + "(sinr$x << sinr$y) = (x << y)"
49.1445 +apply (unfold sinl_def sinr_def)
49.1446 +apply (subst beta_cfun)
49.1447 +apply (rule cont_Isinr)
49.1448 +apply (subst beta_cfun)
49.1449 +apply (rule cont_Isinr)
49.1450 +apply (rule less_ssum3b)
49.1451 +done
49.1452 +
49.1453 +lemma less_ssum4c:
49.1454 + "(sinl$x << sinr$y) = (x = UU)"
49.1455 +apply (unfold sinl_def sinr_def)
49.1456 +apply (simplesubst beta_cfun)
49.1457 +apply (rule cont_Isinr)
49.1458 +apply (subst beta_cfun)
49.1459 +apply (rule cont_Isinl)
49.1460 +apply (rule less_ssum3c)
49.1461 +done
49.1462 +
49.1463 +lemma less_ssum4d:
49.1464 + "(sinr$x << sinl$y) = (x = UU)"
49.1465 +apply (unfold sinl_def sinr_def)
49.1466 +apply (simplesubst beta_cfun)
49.1467 +apply (rule cont_Isinl)
49.1468 +apply (subst beta_cfun)
49.1469 +apply (rule cont_Isinr)
49.1470 +apply (rule less_ssum3d)
49.1471 +done
49.1472 +
49.1473 +lemma ssum_chainE:
49.1474 + "chain(Y) ==> (!i.? x.(Y i)=sinl$x)|(!i.? y.(Y i)=sinr$y)"
49.1475 +apply (unfold sinl_def sinr_def)
49.1476 +apply simp
49.1477 +apply (erule ssum_lemma4)
49.1478 +done
49.1479 +
49.1480 +lemma thelub_ssum2a:
49.1481 +"[| chain(Y); !i.? x. Y(i) = sinl$x |] ==>
49.1482 + lub(range(Y)) = sinl$(lub(range(%i. sscase$(LAM x. x)$(LAM y. UU)$(Y i))))"
49.1483 +apply (unfold sinl_def sinr_def sscase_def)
49.1484 +apply (subst beta_cfun)
49.1485 +apply (rule cont_Isinl)
49.1486 +apply (subst beta_cfun)
49.1487 +apply (intro ssum_conts)
49.1488 +apply (subst beta_cfun)
49.1489 +apply (intro ssum_conts)
49.1490 +apply (subst beta_cfun [THEN ext])
49.1491 +apply (intro ssum_conts)
49.1492 +apply (rule thelub_ssum1a)
49.1493 +apply assumption
49.1494 +apply (rule allI)
49.1495 +apply (erule allE)
49.1496 +apply (erule exE)
49.1497 +apply (rule exI)
49.1498 +apply (erule box_equals)
49.1499 +apply (rule refl)
49.1500 +apply simp
49.1501 +done
49.1502 +
49.1503 +lemma thelub_ssum2b:
49.1504 +"[| chain(Y); !i.? x. Y(i) = sinr$x |] ==>
49.1505 + lub(range(Y)) = sinr$(lub(range(%i. sscase$(LAM y. UU)$(LAM x. x)$(Y i))))"
49.1506 +apply (unfold sinl_def sinr_def sscase_def)
49.1507 +apply (subst beta_cfun)
49.1508 +apply (rule cont_Isinr)
49.1509 +apply (subst beta_cfun)
49.1510 +apply (intro ssum_conts)
49.1511 +apply (subst beta_cfun)
49.1512 +apply (intro ssum_conts)
49.1513 +apply (subst beta_cfun [THEN ext])
49.1514 +apply (intro ssum_conts)
49.1515 +apply (rule thelub_ssum1b)
49.1516 +apply assumption
49.1517 +apply (rule allI)
49.1518 +apply (erule allE)
49.1519 +apply (erule exE)
49.1520 +apply (rule exI)
49.1521 +apply (erule box_equals)
49.1522 +apply (rule refl)
49.1523 +apply simp
49.1524 +done
49.1525 +
49.1526 +lemma thelub_ssum2a_rev:
49.1527 + "[| chain(Y); lub(range(Y)) = sinl$x|] ==> !i.? x. Y(i)=sinl$x"
49.1528 +apply (unfold sinl_def sinr_def)
49.1529 +apply simp
49.1530 +apply (erule ssum_lemma9)
49.1531 +apply simp
49.1532 +done
49.1533 +
49.1534 +lemma thelub_ssum2b_rev:
49.1535 + "[| chain(Y); lub(range(Y)) = sinr$x|] ==> !i.? x. Y(i)=sinr$x"
49.1536 +apply (unfold sinl_def sinr_def)
49.1537 +apply simp
49.1538 +apply (erule ssum_lemma10)
49.1539 +apply simp
49.1540 +done
49.1541 +
49.1542 +lemma thelub_ssum3: "chain(Y) ==>
49.1543 + lub(range(Y)) = sinl$(lub(range(%i. sscase$(LAM x. x)$(LAM y. UU)$(Y i))))
49.1544 + | lub(range(Y)) = sinr$(lub(range(%i. sscase$(LAM y. UU)$(LAM x. x)$(Y i))))"
49.1545 +apply (rule ssum_chainE [THEN disjE])
49.1546 +apply assumption
49.1547 +apply (rule disjI1)
49.1548 +apply (erule thelub_ssum2a)
49.1549 +apply assumption
49.1550 +apply (rule disjI2)
49.1551 +apply (erule thelub_ssum2b)
49.1552 +apply assumption
49.1553 +done
49.1554 +
49.1555 +lemma sscase4: "sscase$sinl$sinr$z=z"
49.1556 +apply (rule_tac p = "z" in ssumE)
49.1557 +apply auto
49.1558 +done
49.1559 +
49.1560 +
49.1561 +(* ------------------------------------------------------------------------ *)
49.1562 +(* install simplifier for Ssum *)
49.1563 +(* ------------------------------------------------------------------------ *)
49.1564 +
49.1565 +lemmas Ssum_rews = strict_sinl strict_sinr defined_sinl defined_sinr
49.1566 + sscase1 sscase2 sscase3
49.1567 +
49.1568 +end
50.1 --- a/src/HOLCF/Ssum0.ML Fri Mar 04 18:53:46 2005 +0100
50.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
50.3 @@ -1,29 +0,0 @@
50.4 -
50.5 -(* legacy ML bindings *)
50.6 -
50.7 -val Isinl_def = thm "Isinl_def";
50.8 -val Isinr_def = thm "Isinr_def";
50.9 -val Iwhen_def = thm "Iwhen_def";
50.10 -val SsumIl = thm "SsumIl";
50.11 -val SsumIr = thm "SsumIr";
50.12 -val inj_on_Abs_Ssum = thm "inj_on_Abs_Ssum";
50.13 -val strict_SinlSinr_Rep = thm "strict_SinlSinr_Rep";
50.14 -val strict_IsinlIsinr = thm "strict_IsinlIsinr";
50.15 -val noteq_SinlSinr_Rep = thm "noteq_SinlSinr_Rep";
50.16 -val noteq_IsinlIsinr = thm "noteq_IsinlIsinr";
50.17 -val inject_Sinl_Rep1 = thm "inject_Sinl_Rep1";
50.18 -val inject_Sinr_Rep1 = thm "inject_Sinr_Rep1";
50.19 -val inject_Sinl_Rep2 = thm "inject_Sinl_Rep2";
50.20 -val inject_Sinr_Rep2 = thm "inject_Sinr_Rep2";
50.21 -val inject_Sinl_Rep = thm "inject_Sinl_Rep";
50.22 -val inject_Sinr_Rep = thm "inject_Sinr_Rep";
50.23 -val inject_Isinl = thm "inject_Isinl";
50.24 -val inject_Isinr = thm "inject_Isinr";
50.25 -val inject_Isinl_rev = thm "inject_Isinl_rev";
50.26 -val inject_Isinr_rev = thm "inject_Isinr_rev";
50.27 -val Exh_Ssum = thm "Exh_Ssum";
50.28 -val IssumE = thm "IssumE";
50.29 -val IssumE2 = thm "IssumE2";
50.30 -val Iwhen1 = thm "Iwhen1";
50.31 -val Iwhen2 = thm "Iwhen2";
50.32 -val Iwhen3 = thm "Iwhen3";
51.1 --- a/src/HOLCF/Ssum0.thy Fri Mar 04 18:53:46 2005 +0100
51.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
51.3 @@ -1,344 +0,0 @@
51.4 -(* Title: HOLCF/Ssum0.thy
51.5 - ID: $Id$
51.6 - Author: Franz Regensburger
51.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
51.8 -
51.9 -Strict sum with typedef
51.10 -*)
51.11 -
51.12 -theory Ssum0 = Cfun3:
51.13 -
51.14 -constdefs
51.15 - Sinl_Rep :: "['a,'a,'b,bool]=>bool"
51.16 - "Sinl_Rep == (%a.%x y p. (a~=UU --> x=a & p))"
51.17 - Sinr_Rep :: "['b,'a,'b,bool]=>bool"
51.18 - "Sinr_Rep == (%b.%x y p.(b~=UU --> y=b & ~p))"
51.19 -
51.20 -typedef (Ssum) ('a, 'b) "++" (infixr 10) =
51.21 - "{f.(? a. f=Sinl_Rep(a::'a))|(? b. f=Sinr_Rep(b::'b))}"
51.22 -by auto
51.23 -
51.24 -syntax (xsymbols)
51.25 - "++" :: "[type, type] => type" ("(_ \<oplus>/ _)" [21, 20] 20)
51.26 -syntax (HTML output)
51.27 - "++" :: "[type, type] => type" ("(_ \<oplus>/ _)" [21, 20] 20)
51.28 -
51.29 -consts
51.30 - Isinl :: "'a => ('a ++ 'b)"
51.31 - Isinr :: "'b => ('a ++ 'b)"
51.32 - Iwhen :: "('a->'c)=>('b->'c)=>('a ++ 'b)=> 'c"
51.33 -
51.34 -defs (*defining the abstract constants*)
51.35 - Isinl_def: "Isinl(a) == Abs_Ssum(Sinl_Rep(a))"
51.36 - Isinr_def: "Isinr(b) == Abs_Ssum(Sinr_Rep(b))"
51.37 -
51.38 - Iwhen_def: "Iwhen(f)(g)(s) == @z.
51.39 - (s=Isinl(UU) --> z=UU)
51.40 - &(!a. a~=UU & s=Isinl(a) --> z=f$a)
51.41 - &(!b. b~=UU & s=Isinr(b) --> z=g$b)"
51.42 -
51.43 -(* Title: HOLCF/Ssum0.ML
51.44 - ID: $Id$
51.45 - Author: Franz Regensburger
51.46 - License: GPL (GNU GENERAL PUBLIC LICENSE)
51.47 -
51.48 -Strict sum with typedef
51.49 -*)
51.50 -
51.51 -(* ------------------------------------------------------------------------ *)
51.52 -(* A non-emptyness result for Sssum *)
51.53 -(* ------------------------------------------------------------------------ *)
51.54 -
51.55 -lemma SsumIl: "Sinl_Rep(a):Ssum"
51.56 -apply (unfold Ssum_def)
51.57 -apply blast
51.58 -done
51.59 -
51.60 -lemma SsumIr: "Sinr_Rep(a):Ssum"
51.61 -apply (unfold Ssum_def)
51.62 -apply blast
51.63 -done
51.64 -
51.65 -lemma inj_on_Abs_Ssum: "inj_on Abs_Ssum Ssum"
51.66 -apply (rule inj_on_inverseI)
51.67 -apply (erule Abs_Ssum_inverse)
51.68 -done
51.69 -
51.70 -(* ------------------------------------------------------------------------ *)
51.71 -(* Strictness of Sinr_Rep, Sinl_Rep and Isinl, Isinr *)
51.72 -(* ------------------------------------------------------------------------ *)
51.73 -
51.74 -lemma strict_SinlSinr_Rep:
51.75 - "Sinl_Rep(UU) = Sinr_Rep(UU)"
51.76 -
51.77 -apply (unfold Sinr_Rep_def Sinl_Rep_def)
51.78 -apply (rule ext)
51.79 -apply (rule ext)
51.80 -apply (rule ext)
51.81 -apply fast
51.82 -done
51.83 -
51.84 -lemma strict_IsinlIsinr:
51.85 - "Isinl(UU) = Isinr(UU)"
51.86 -apply (unfold Isinl_def Isinr_def)
51.87 -apply (rule strict_SinlSinr_Rep [THEN arg_cong])
51.88 -done
51.89 -
51.90 -
51.91 -(* ------------------------------------------------------------------------ *)
51.92 -(* distinctness of Sinl_Rep, Sinr_Rep and Isinl, Isinr *)
51.93 -(* ------------------------------------------------------------------------ *)
51.94 -
51.95 -lemma noteq_SinlSinr_Rep:
51.96 - "(Sinl_Rep(a) = Sinr_Rep(b)) ==> a=UU & b=UU"
51.97 -
51.98 -apply (unfold Sinl_Rep_def Sinr_Rep_def)
51.99 -apply (blast dest!: fun_cong)
51.100 -done
51.101 -
51.102 -
51.103 -lemma noteq_IsinlIsinr:
51.104 - "Isinl(a)=Isinr(b) ==> a=UU & b=UU"
51.105 -
51.106 -apply (unfold Isinl_def Isinr_def)
51.107 -apply (rule noteq_SinlSinr_Rep)
51.108 -apply (erule inj_on_Abs_Ssum [THEN inj_onD])
51.109 -apply (rule SsumIl)
51.110 -apply (rule SsumIr)
51.111 -done
51.112 -
51.113 -
51.114 -
51.115 -(* ------------------------------------------------------------------------ *)
51.116 -(* injectivity of Sinl_Rep, Sinr_Rep and Isinl, Isinr *)
51.117 -(* ------------------------------------------------------------------------ *)
51.118 -
51.119 -lemma inject_Sinl_Rep1: "(Sinl_Rep(a) = Sinl_Rep(UU)) ==> a=UU"
51.120 -apply (unfold Sinl_Rep_def)
51.121 -apply (blast dest!: fun_cong)
51.122 -done
51.123 -
51.124 -lemma inject_Sinr_Rep1: "(Sinr_Rep(b) = Sinr_Rep(UU)) ==> b=UU"
51.125 -apply (unfold Sinr_Rep_def)
51.126 -apply (blast dest!: fun_cong)
51.127 -done
51.128 -
51.129 -lemma inject_Sinl_Rep2:
51.130 -"[| a1~=UU ; a2~=UU ; Sinl_Rep(a1)=Sinl_Rep(a2) |] ==> a1=a2"
51.131 -apply (unfold Sinl_Rep_def)
51.132 -apply (blast dest!: fun_cong)
51.133 -done
51.134 -
51.135 -lemma inject_Sinr_Rep2:
51.136 -"[|b1~=UU ; b2~=UU ; Sinr_Rep(b1)=Sinr_Rep(b2) |] ==> b1=b2"
51.137 -apply (unfold Sinr_Rep_def)
51.138 -apply (blast dest!: fun_cong)
51.139 -done
51.140 -
51.141 -lemma inject_Sinl_Rep: "Sinl_Rep(a1)=Sinl_Rep(a2) ==> a1=a2"
51.142 -apply (case_tac "a1=UU")
51.143 -apply simp
51.144 -apply (rule inject_Sinl_Rep1 [symmetric])
51.145 -apply (erule sym)
51.146 -apply (case_tac "a2=UU")
51.147 -apply simp
51.148 -apply (drule inject_Sinl_Rep1)
51.149 -apply simp
51.150 -apply (erule inject_Sinl_Rep2)
51.151 -apply assumption
51.152 -apply assumption
51.153 -done
51.154 -
51.155 -lemma inject_Sinr_Rep: "Sinr_Rep(b1)=Sinr_Rep(b2) ==> b1=b2"
51.156 -apply (case_tac "b1=UU")
51.157 -apply simp
51.158 -apply (rule inject_Sinr_Rep1 [symmetric])
51.159 -apply (erule sym)
51.160 -apply (case_tac "b2=UU")
51.161 -apply simp
51.162 -apply (drule inject_Sinr_Rep1)
51.163 -apply simp
51.164 -apply (erule inject_Sinr_Rep2)
51.165 -apply assumption
51.166 -apply assumption
51.167 -done
51.168 -
51.169 -lemma inject_Isinl: "Isinl(a1)=Isinl(a2)==> a1=a2"
51.170 -apply (unfold Isinl_def)
51.171 -apply (rule inject_Sinl_Rep)
51.172 -apply (erule inj_on_Abs_Ssum [THEN inj_onD])
51.173 -apply (rule SsumIl)
51.174 -apply (rule SsumIl)
51.175 -done
51.176 -
51.177 -lemma inject_Isinr: "Isinr(b1)=Isinr(b2) ==> b1=b2"
51.178 -apply (unfold Isinr_def)
51.179 -apply (rule inject_Sinr_Rep)
51.180 -apply (erule inj_on_Abs_Ssum [THEN inj_onD])
51.181 -apply (rule SsumIr)
51.182 -apply (rule SsumIr)
51.183 -done
51.184 -
51.185 -declare inject_Isinl [dest!] inject_Isinr [dest!]
51.186 -
51.187 -lemma inject_Isinl_rev: "a1~=a2 ==> Isinl(a1) ~= Isinl(a2)"
51.188 -apply blast
51.189 -done
51.190 -
51.191 -lemma inject_Isinr_rev: "b1~=b2 ==> Isinr(b1) ~= Isinr(b2)"
51.192 -apply blast
51.193 -done
51.194 -
51.195 -(* ------------------------------------------------------------------------ *)
51.196 -(* Exhaustion of the strict sum ++ *)
51.197 -(* choice of the bottom representation is arbitrary *)
51.198 -(* ------------------------------------------------------------------------ *)
51.199 -
51.200 -lemma Exh_Ssum:
51.201 - "z=Isinl(UU) | (? a. z=Isinl(a) & a~=UU) | (? b. z=Isinr(b) & b~=UU)"
51.202 -apply (unfold Isinl_def Isinr_def)
51.203 -apply (rule Rep_Ssum[unfolded Ssum_def, THEN CollectE])
51.204 -apply (erule disjE)
51.205 -apply (erule exE)
51.206 -apply (case_tac "z= Abs_Ssum (Sinl_Rep (UU))")
51.207 -apply (erule disjI1)
51.208 -apply (rule disjI2)
51.209 -apply (rule disjI1)
51.210 -apply (rule exI)
51.211 -apply (rule conjI)
51.212 -apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
51.213 -apply (erule arg_cong)
51.214 -apply (rule_tac Q = "Sinl_Rep (a) =Sinl_Rep (UU) " in contrapos_nn)
51.215 -apply (erule_tac [2] arg_cong)
51.216 -apply (erule contrapos_nn)
51.217 -apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
51.218 -apply (rule trans)
51.219 -apply (erule arg_cong)
51.220 -apply (erule arg_cong)
51.221 -apply (erule exE)
51.222 -apply (case_tac "z= Abs_Ssum (Sinl_Rep (UU))")
51.223 -apply (erule disjI1)
51.224 -apply (rule disjI2)
51.225 -apply (rule disjI2)
51.226 -apply (rule exI)
51.227 -apply (rule conjI)
51.228 -apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
51.229 -apply (erule arg_cong)
51.230 -apply (rule_tac Q = "Sinr_Rep (b) =Sinl_Rep (UU) " in contrapos_nn)
51.231 -prefer 2 apply simp
51.232 -apply (rule strict_SinlSinr_Rep [symmetric])
51.233 -apply (erule contrapos_nn)
51.234 -apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
51.235 -apply (rule trans)
51.236 -apply (erule arg_cong)
51.237 -apply (erule arg_cong)
51.238 -done
51.239 -
51.240 -(* ------------------------------------------------------------------------ *)
51.241 -(* elimination rules for the strict sum ++ *)
51.242 -(* ------------------------------------------------------------------------ *)
51.243 -
51.244 -lemma IssumE:
51.245 - "[|p=Isinl(UU) ==> Q ;
51.246 - !!x.[|p=Isinl(x); x~=UU |] ==> Q;
51.247 - !!y.[|p=Isinr(y); y~=UU |] ==> Q|] ==> Q"
51.248 -apply (rule Exh_Ssum [THEN disjE])
51.249 -apply auto
51.250 -done
51.251 -
51.252 -lemma IssumE2:
51.253 -"[| !!x. [| p = Isinl(x) |] ==> Q; !!y. [| p = Isinr(y) |] ==> Q |] ==>Q"
51.254 -apply (rule IssumE)
51.255 -apply auto
51.256 -done
51.257 -
51.258 -
51.259 -
51.260 -
51.261 -(* ------------------------------------------------------------------------ *)
51.262 -(* rewrites for Iwhen *)
51.263 -(* ------------------------------------------------------------------------ *)
51.264 -
51.265 -lemma Iwhen1:
51.266 - "Iwhen f g (Isinl UU) = UU"
51.267 -apply (unfold Iwhen_def)
51.268 -apply (rule some_equality)
51.269 -apply (rule conjI)
51.270 -apply fast
51.271 -apply (rule conjI)
51.272 -apply (intro strip)
51.273 -apply (rule_tac P = "a=UU" in notE)
51.274 -apply fast
51.275 -apply (rule inject_Isinl)
51.276 -apply (rule sym)
51.277 -apply fast
51.278 -apply (intro strip)
51.279 -apply (rule_tac P = "b=UU" in notE)
51.280 -apply fast
51.281 -apply (rule inject_Isinr)
51.282 -apply (rule sym)
51.283 -apply (rule strict_IsinlIsinr [THEN subst])
51.284 -apply fast
51.285 -apply fast
51.286 -done
51.287 -
51.288 -
51.289 -lemma Iwhen2:
51.290 - "x~=UU ==> Iwhen f g (Isinl x) = f$x"
51.291 -
51.292 -apply (unfold Iwhen_def)
51.293 -apply (rule some_equality)
51.294 -prefer 2 apply fast
51.295 -apply (rule conjI)
51.296 -apply (intro strip)
51.297 -apply (rule_tac P = "x=UU" in notE)
51.298 -apply assumption
51.299 -apply (rule inject_Isinl)
51.300 -apply assumption
51.301 -apply (rule conjI)
51.302 -apply (intro strip)
51.303 -apply (rule cfun_arg_cong)
51.304 -apply (rule inject_Isinl)
51.305 -apply fast
51.306 -apply (intro strip)
51.307 -apply (rule_tac P = "Isinl (x) = Isinr (b) " in notE)
51.308 -prefer 2 apply fast
51.309 -apply (rule contrapos_nn)
51.310 -apply (erule_tac [2] noteq_IsinlIsinr)
51.311 -apply fast
51.312 -done
51.313 -
51.314 -lemma Iwhen3:
51.315 - "y~=UU ==> Iwhen f g (Isinr y) = g$y"
51.316 -apply (unfold Iwhen_def)
51.317 -apply (rule some_equality)
51.318 -prefer 2 apply fast
51.319 -apply (rule conjI)
51.320 -apply (intro strip)
51.321 -apply (rule_tac P = "y=UU" in notE)
51.322 -apply assumption
51.323 -apply (rule inject_Isinr)
51.324 -apply (rule strict_IsinlIsinr [THEN subst])
51.325 -apply assumption
51.326 -apply (rule conjI)
51.327 -apply (intro strip)
51.328 -apply (rule_tac P = "Isinr (y) = Isinl (a) " in notE)
51.329 -prefer 2 apply fast
51.330 -apply (rule contrapos_nn)
51.331 -apply (erule_tac [2] sym [THEN noteq_IsinlIsinr])
51.332 -apply fast
51.333 -apply (intro strip)
51.334 -apply (rule cfun_arg_cong)
51.335 -apply (rule inject_Isinr)
51.336 -apply fast
51.337 -done
51.338 -
51.339 -(* ------------------------------------------------------------------------ *)
51.340 -(* instantiate the simplifier *)
51.341 -(* ------------------------------------------------------------------------ *)
51.342 -
51.343 -lemmas Ssum0_ss = strict_IsinlIsinr[symmetric] Iwhen1 Iwhen2 Iwhen3
51.344 -
51.345 -declare Ssum0_ss [simp]
51.346 -
51.347 -end
52.1 --- a/src/HOLCF/Ssum1.ML Fri Mar 04 18:53:46 2005 +0100
52.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
52.3 @@ -1,15 +0,0 @@
52.4 -
52.5 -(* legacy ML bindings *)
52.6 -
52.7 -val less_ssum_def = thm "less_ssum_def";
52.8 -val less_ssum1a = thm "less_ssum1a";
52.9 -val less_ssum1b = thm "less_ssum1b";
52.10 -val less_ssum1c = thm "less_ssum1c";
52.11 -val less_ssum1d = thm "less_ssum1d";
52.12 -val less_ssum2a = thm "less_ssum2a";
52.13 -val less_ssum2b = thm "less_ssum2b";
52.14 -val less_ssum2c = thm "less_ssum2c";
52.15 -val less_ssum2d = thm "less_ssum2d";
52.16 -val refl_less_ssum = thm "refl_less_ssum";
52.17 -val antisym_less_ssum = thm "antisym_less_ssum";
52.18 -val trans_less_ssum = thm "trans_less_ssum";
53.1 --- a/src/HOLCF/Ssum1.thy Fri Mar 04 18:53:46 2005 +0100
53.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
53.3 @@ -1,314 +0,0 @@
53.4 -(* Title: HOLCF/Ssum1.thy
53.5 - ID: $Id$
53.6 - Author: Franz Regensburger
53.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
53.8 -
53.9 -Partial ordering for the strict sum ++
53.10 -*)
53.11 -
53.12 -theory Ssum1 = Ssum0:
53.13 -
53.14 -instance "++"::(pcpo,pcpo)sq_ord ..
53.15 -
53.16 -defs (overloaded)
53.17 - less_ssum_def: "(op <<) == (%s1 s2.@z.
53.18 - (! u x. s1=Isinl u & s2=Isinl x --> z = u << x)
53.19 - &(! v y. s1=Isinr v & s2=Isinr y --> z = v << y)
53.20 - &(! u y. s1=Isinl u & s2=Isinr y --> z = (u = UU))
53.21 - &(! v x. s1=Isinr v & s2=Isinl x --> z = (v = UU)))"
53.22 -
53.23 -(* Title: HOLCF/Ssum1.ML
53.24 - ID: $Id$
53.25 - Author: Franz Regensburger
53.26 - License: GPL (GNU GENERAL PUBLIC LICENSE)
53.27 -
53.28 -Partial ordering for the strict sum ++
53.29 -*)
53.30 -
53.31 -lemma less_ssum1a:
53.32 -"[|s1=Isinl(x::'a); s2=Isinl(y::'a)|] ==> s1 << s2 = (x << y)"
53.33 -apply (unfold less_ssum_def)
53.34 -apply (rule some_equality)
53.35 -apply (drule_tac [2] conjunct1)
53.36 -apply (drule_tac [2] spec)
53.37 -apply (drule_tac [2] spec)
53.38 -apply (erule_tac [2] mp)
53.39 -prefer 2 apply fast
53.40 -apply (rule conjI)
53.41 -apply (intro strip)
53.42 -apply (erule conjE)
53.43 -apply simp
53.44 -apply (drule inject_Isinl)
53.45 -apply (drule inject_Isinl)
53.46 -apply simp
53.47 -apply (rule conjI)
53.48 -apply (intro strip)
53.49 -apply (erule conjE)
53.50 -apply simp
53.51 -apply (drule noteq_IsinlIsinr[OF sym])
53.52 -apply simp
53.53 -apply (rule conjI)
53.54 -apply (intro strip)
53.55 -apply (erule conjE)
53.56 -apply simp
53.57 -apply (drule inject_Isinl)
53.58 -apply (drule noteq_IsinlIsinr[OF sym])
53.59 -apply simp
53.60 -apply (rule eq_UU_iff[symmetric])
53.61 -apply (intro strip)
53.62 -apply (erule conjE)
53.63 -apply simp
53.64 -apply (drule noteq_IsinlIsinr[OF sym])
53.65 -apply simp
53.66 -done
53.67 -
53.68 -
53.69 -lemma less_ssum1b:
53.70 -"[|s1=Isinr(x::'b); s2=Isinr(y::'b)|] ==> s1 << s2 = (x << y)"
53.71 -
53.72 -apply (unfold less_ssum_def)
53.73 -apply (rule some_equality)
53.74 -apply (drule_tac [2] conjunct2)
53.75 -apply (drule_tac [2] conjunct1)
53.76 -apply (drule_tac [2] spec)
53.77 -apply (drule_tac [2] spec)
53.78 -apply (erule_tac [2] mp)
53.79 -prefer 2 apply fast
53.80 -apply (rule conjI)
53.81 -apply (intro strip)
53.82 -apply (erule conjE)
53.83 -apply simp
53.84 -apply (drule noteq_IsinlIsinr)
53.85 -apply (drule noteq_IsinlIsinr)
53.86 -apply simp
53.87 -apply (rule conjI)
53.88 -apply (intro strip)
53.89 -apply (erule conjE)
53.90 -apply simp
53.91 -apply (drule inject_Isinr)
53.92 -apply (drule inject_Isinr)
53.93 -apply simp
53.94 -apply (rule conjI)
53.95 -apply (intro strip)
53.96 -apply (erule conjE)
53.97 -apply simp
53.98 -apply (drule noteq_IsinlIsinr)
53.99 -apply (drule inject_Isinr)
53.100 -apply simp
53.101 -apply (intro strip)
53.102 -apply (erule conjE)
53.103 -apply simp
53.104 -apply (drule inject_Isinr)
53.105 -apply (drule noteq_IsinlIsinr)
53.106 -apply simp
53.107 -apply (rule eq_UU_iff[symmetric])
53.108 -done
53.109 -
53.110 -
53.111 -lemma less_ssum1c:
53.112 -"[|s1=Isinl(x::'a); s2=Isinr(y::'b)|] ==> s1 << s2 = ((x::'a) = UU)"
53.113 -
53.114 -apply (unfold less_ssum_def)
53.115 -apply (rule some_equality)
53.116 -apply (rule conjI)
53.117 -apply (intro strip)
53.118 -apply (erule conjE)
53.119 -apply simp
53.120 -apply (drule inject_Isinl)
53.121 -apply (drule noteq_IsinlIsinr)
53.122 -apply simp
53.123 -apply (rule eq_UU_iff)
53.124 -apply (rule conjI)
53.125 -apply (intro strip)
53.126 -apply (erule conjE)
53.127 -apply simp
53.128 -apply (drule noteq_IsinlIsinr[OF sym])
53.129 -apply (drule inject_Isinr)
53.130 -apply simp
53.131 -apply (rule conjI)
53.132 -apply (intro strip)
53.133 -apply (erule conjE)
53.134 -apply simp
53.135 -apply (drule inject_Isinl)
53.136 -apply (drule inject_Isinr)
53.137 -apply simp
53.138 -apply (intro strip)
53.139 -apply (erule conjE)
53.140 -apply simp
53.141 -apply (drule noteq_IsinlIsinr[OF sym])
53.142 -apply (drule noteq_IsinlIsinr)
53.143 -apply simp
53.144 -apply (drule conjunct2)
53.145 -apply (drule conjunct2)
53.146 -apply (drule conjunct1)
53.147 -apply (drule spec)
53.148 -apply (drule spec)
53.149 -apply (erule mp)
53.150 -apply fast
53.151 -done
53.152 -
53.153 -
53.154 -lemma less_ssum1d:
53.155 -"[|s1=Isinr(x); s2=Isinl(y)|] ==> s1 << s2 = (x = UU)"
53.156 -
53.157 -apply (unfold less_ssum_def)
53.158 -apply (rule some_equality)
53.159 -apply (drule_tac [2] conjunct2)
53.160 -apply (drule_tac [2] conjunct2)
53.161 -apply (drule_tac [2] conjunct2)
53.162 -apply (drule_tac [2] spec)
53.163 -apply (drule_tac [2] spec)
53.164 -apply (erule_tac [2] mp)
53.165 -prefer 2 apply fast
53.166 -apply (rule conjI)
53.167 -apply (intro strip)
53.168 -apply (erule conjE)
53.169 -apply simp
53.170 -apply (drule noteq_IsinlIsinr)
53.171 -apply (drule inject_Isinl)
53.172 -apply simp
53.173 -apply (rule conjI)
53.174 -apply (intro strip)
53.175 -apply (erule conjE)
53.176 -apply simp
53.177 -apply (drule noteq_IsinlIsinr[OF sym])
53.178 -apply (drule inject_Isinr)
53.179 -apply simp
53.180 -apply (rule eq_UU_iff)
53.181 -apply (rule conjI)
53.182 -apply (intro strip)
53.183 -apply (erule conjE)
53.184 -apply simp
53.185 -apply (drule noteq_IsinlIsinr)
53.186 -apply (drule noteq_IsinlIsinr[OF sym])
53.187 -apply simp
53.188 -apply (intro strip)
53.189 -apply (erule conjE)
53.190 -apply simp
53.191 -apply (drule inject_Isinr)
53.192 -apply simp
53.193 -done
53.194 -
53.195 -
53.196 -(* ------------------------------------------------------------------------ *)
53.197 -(* optimize lemmas about less_ssum *)
53.198 -(* ------------------------------------------------------------------------ *)
53.199 -
53.200 -lemma less_ssum2a: "(Isinl x) << (Isinl y) = (x << y)"
53.201 -apply (rule less_ssum1a)
53.202 -apply (rule refl)
53.203 -apply (rule refl)
53.204 -done
53.205 -
53.206 -lemma less_ssum2b: "(Isinr x) << (Isinr y) = (x << y)"
53.207 -apply (rule less_ssum1b)
53.208 -apply (rule refl)
53.209 -apply (rule refl)
53.210 -done
53.211 -
53.212 -lemma less_ssum2c: "(Isinl x) << (Isinr y) = (x = UU)"
53.213 -apply (rule less_ssum1c)
53.214 -apply (rule refl)
53.215 -apply (rule refl)
53.216 -done
53.217 -
53.218 -lemma less_ssum2d: "(Isinr x) << (Isinl y) = (x = UU)"
53.219 -apply (rule less_ssum1d)
53.220 -apply (rule refl)
53.221 -apply (rule refl)
53.222 -done
53.223 -
53.224 -
53.225 -(* ------------------------------------------------------------------------ *)
53.226 -(* less_ssum is a partial order on ++ *)
53.227 -(* ------------------------------------------------------------------------ *)
53.228 -
53.229 -lemma refl_less_ssum: "(p::'a++'b) << p"
53.230 -apply (rule_tac p = "p" in IssumE2)
53.231 -apply (erule ssubst)
53.232 -apply (rule less_ssum2a [THEN iffD2])
53.233 -apply (rule refl_less)
53.234 -apply (erule ssubst)
53.235 -apply (rule less_ssum2b [THEN iffD2])
53.236 -apply (rule refl_less)
53.237 -done
53.238 -
53.239 -lemma antisym_less_ssum: "[|(p1::'a++'b) << p2; p2 << p1|] ==> p1=p2"
53.240 -apply (rule_tac p = "p1" in IssumE2)
53.241 -apply simp
53.242 -apply (rule_tac p = "p2" in IssumE2)
53.243 -apply simp
53.244 -apply (rule_tac f = "Isinl" in arg_cong)
53.245 -apply (rule antisym_less)
53.246 -apply (erule less_ssum2a [THEN iffD1])
53.247 -apply (erule less_ssum2a [THEN iffD1])
53.248 -apply simp
53.249 -apply (erule less_ssum2d [THEN iffD1, THEN ssubst])
53.250 -apply (erule less_ssum2c [THEN iffD1, THEN ssubst])
53.251 -apply (rule strict_IsinlIsinr)
53.252 -apply simp
53.253 -apply (rule_tac p = "p2" in IssumE2)
53.254 -apply simp
53.255 -apply (erule less_ssum2c [THEN iffD1, THEN ssubst])
53.256 -apply (erule less_ssum2d [THEN iffD1, THEN ssubst])
53.257 -apply (rule strict_IsinlIsinr [symmetric])
53.258 -apply simp
53.259 -apply (rule_tac f = "Isinr" in arg_cong)
53.260 -apply (rule antisym_less)
53.261 -apply (erule less_ssum2b [THEN iffD1])
53.262 -apply (erule less_ssum2b [THEN iffD1])
53.263 -done
53.264 -
53.265 -lemma trans_less_ssum: "[|(p1::'a++'b) << p2; p2 << p3|] ==> p1 << p3"
53.266 -apply (rule_tac p = "p1" in IssumE2)
53.267 -apply simp
53.268 -apply (rule_tac p = "p3" in IssumE2)
53.269 -apply simp
53.270 -apply (rule less_ssum2a [THEN iffD2])
53.271 -apply (rule_tac p = "p2" in IssumE2)
53.272 -apply simp
53.273 -apply (rule trans_less)
53.274 -apply (erule less_ssum2a [THEN iffD1])
53.275 -apply (erule less_ssum2a [THEN iffD1])
53.276 -apply simp
53.277 -apply (erule less_ssum2c [THEN iffD1, THEN ssubst])
53.278 -apply (rule minimal)
53.279 -apply simp
53.280 -apply (rule less_ssum2c [THEN iffD2])
53.281 -apply (rule_tac p = "p2" in IssumE2)
53.282 -apply simp
53.283 -apply (rule UU_I)
53.284 -apply (rule trans_less)
53.285 -apply (erule less_ssum2a [THEN iffD1])
53.286 -apply (rule antisym_less_inverse [THEN conjunct1])
53.287 -apply (erule less_ssum2c [THEN iffD1])
53.288 -apply simp
53.289 -apply (erule less_ssum2c [THEN iffD1])
53.290 -apply simp
53.291 -apply (rule_tac p = "p3" in IssumE2)
53.292 -apply simp
53.293 -apply (rule less_ssum2d [THEN iffD2])
53.294 -apply (rule_tac p = "p2" in IssumE2)
53.295 -apply simp
53.296 -apply (erule less_ssum2d [THEN iffD1])
53.297 -apply simp
53.298 -apply (rule UU_I)
53.299 -apply (rule trans_less)
53.300 -apply (erule less_ssum2b [THEN iffD1])
53.301 -apply (rule antisym_less_inverse [THEN conjunct1])
53.302 -apply (erule less_ssum2d [THEN iffD1])
53.303 -apply simp
53.304 -apply (rule less_ssum2b [THEN iffD2])
53.305 -apply (rule_tac p = "p2" in IssumE2)
53.306 -apply simp
53.307 -apply (erule less_ssum2d [THEN iffD1, THEN ssubst])
53.308 -apply (rule minimal)
53.309 -apply simp
53.310 -apply (rule trans_less)
53.311 -apply (erule less_ssum2b [THEN iffD1])
53.312 -apply (erule less_ssum2b [THEN iffD1])
53.313 -done
53.314 -
53.315 -end
53.316 -
53.317 -
54.1 --- a/src/HOLCF/Ssum2.ML Fri Mar 04 18:53:46 2005 +0100
54.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
54.3 @@ -1,29 +0,0 @@
54.4 -
54.5 -(* legacy ML bindings *)
54.6 -
54.7 -val inst_ssum_po = thm "inst_ssum_po";
54.8 -val less_ssum3a = thm "less_ssum3a";
54.9 -val less_ssum3b = thm "less_ssum3b";
54.10 -val less_ssum3c = thm "less_ssum3c";
54.11 -val less_ssum3d = thm "less_ssum3d";
54.12 -val minimal_ssum = thm "minimal_ssum";
54.13 -val UU_ssum_def = thm "UU_ssum_def";
54.14 -val least_ssum = thm "least_ssum";
54.15 -val monofun_Isinl = thm "monofun_Isinl";
54.16 -val monofun_Isinr = thm "monofun_Isinr";
54.17 -val monofun_Iwhen1 = thm "monofun_Iwhen1";
54.18 -val monofun_Iwhen2 = thm "monofun_Iwhen2";
54.19 -val monofun_Iwhen3 = thm "monofun_Iwhen3";
54.20 -val ssum_lemma1 = thm "ssum_lemma1";
54.21 -val ssum_lemma2 = thm "ssum_lemma2";
54.22 -val ssum_lemma3 = thm "ssum_lemma3";
54.23 -val ssum_lemma4 = thm "ssum_lemma4";
54.24 -val ssum_lemma5 = thm "ssum_lemma5";
54.25 -val ssum_lemma6 = thm "ssum_lemma6";
54.26 -val ssum_lemma7 = thm "ssum_lemma7";
54.27 -val ssum_lemma8 = thm "ssum_lemma8";
54.28 -val lub_ssum1a = thm "lub_ssum1a";
54.29 -val lub_ssum1b = thm "lub_ssum1b";
54.30 -val thelub_ssum1a = thm "thelub_ssum1a";
54.31 -val thelub_ssum1b = thm "thelub_ssum1b";
54.32 -val cpo_ssum = thm "cpo_ssum";
55.1 --- a/src/HOLCF/Ssum2.thy Fri Mar 04 18:53:46 2005 +0100
55.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
55.3 @@ -1,368 +0,0 @@
55.4 -(* Title: HOLCF/ssum2.thy
55.5 - ID: $Id$
55.6 - Author: Franz Regensburger
55.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
55.8 -
55.9 -Class Instance ++::(pcpo,pcpo)po
55.10 -*)
55.11 -
55.12 -theory Ssum2 = Ssum1:
55.13 -
55.14 -instance "++"::(pcpo,pcpo)po
55.15 -apply (intro_classes)
55.16 -apply (rule refl_less_ssum)
55.17 -apply (rule antisym_less_ssum, assumption+)
55.18 -apply (rule trans_less_ssum, assumption+)
55.19 -done
55.20 -
55.21 -(* Title: HOLCF/Ssum2.ML
55.22 - ID: $Id$
55.23 - Author: Franz Regensburger
55.24 - License: GPL (GNU GENERAL PUBLIC LICENSE)
55.25 -
55.26 -Class Instance ++::(pcpo,pcpo)po
55.27 -*)
55.28 -
55.29 -(* for compatibility with old HOLCF-Version *)
55.30 -lemma inst_ssum_po: "(op <<)=(%s1 s2.@z.
55.31 - (! u x. s1=Isinl u & s2=Isinl x --> z = u << x)
55.32 - &(! v y. s1=Isinr v & s2=Isinr y --> z = v << y)
55.33 - &(! u y. s1=Isinl u & s2=Isinr y --> z = (u = UU))
55.34 - &(! v x. s1=Isinr v & s2=Isinl x --> z = (v = UU)))"
55.35 -apply (fold less_ssum_def)
55.36 -apply (rule refl)
55.37 -done
55.38 -
55.39 -(* ------------------------------------------------------------------------ *)
55.40 -(* access to less_ssum in class po *)
55.41 -(* ------------------------------------------------------------------------ *)
55.42 -
55.43 -lemma less_ssum3a: "Isinl x << Isinl y = x << y"
55.44 -apply (simp (no_asm) add: less_ssum2a)
55.45 -done
55.46 -
55.47 -lemma less_ssum3b: "Isinr x << Isinr y = x << y"
55.48 -apply (simp (no_asm) add: less_ssum2b)
55.49 -done
55.50 -
55.51 -lemma less_ssum3c: "Isinl x << Isinr y = (x = UU)"
55.52 -apply (simp (no_asm) add: less_ssum2c)
55.53 -done
55.54 -
55.55 -lemma less_ssum3d: "Isinr x << Isinl y = (x = UU)"
55.56 -apply (simp (no_asm) add: less_ssum2d)
55.57 -done
55.58 -
55.59 -(* ------------------------------------------------------------------------ *)
55.60 -(* type ssum ++ is pointed *)
55.61 -(* ------------------------------------------------------------------------ *)
55.62 -
55.63 -lemma minimal_ssum: "Isinl UU << s"
55.64 -apply (rule_tac p = "s" in IssumE2)
55.65 -apply simp
55.66 -apply (rule less_ssum3a [THEN iffD2])
55.67 -apply (rule minimal)
55.68 -apply simp
55.69 -apply (subst strict_IsinlIsinr)
55.70 -apply (rule less_ssum3b [THEN iffD2])
55.71 -apply (rule minimal)
55.72 -done
55.73 -
55.74 -lemmas UU_ssum_def = minimal_ssum [THEN minimal2UU, symmetric, standard]
55.75 -
55.76 -lemma least_ssum: "? x::'a++'b.!y. x<<y"
55.77 -apply (rule_tac x = "Isinl UU" in exI)
55.78 -apply (rule minimal_ssum [THEN allI])
55.79 -done
55.80 -
55.81 -(* ------------------------------------------------------------------------ *)
55.82 -(* Isinl, Isinr are monotone *)
55.83 -(* ------------------------------------------------------------------------ *)
55.84 -
55.85 -lemma monofun_Isinl: "monofun(Isinl)"
55.86 -
55.87 -apply (unfold monofun)
55.88 -apply (intro strip)
55.89 -apply (erule less_ssum3a [THEN iffD2])
55.90 -done
55.91 -
55.92 -lemma monofun_Isinr: "monofun(Isinr)"
55.93 -apply (unfold monofun)
55.94 -apply (intro strip)
55.95 -apply (erule less_ssum3b [THEN iffD2])
55.96 -done
55.97 -
55.98 -
55.99 -(* ------------------------------------------------------------------------ *)
55.100 -(* Iwhen is monotone in all arguments *)
55.101 -(* ------------------------------------------------------------------------ *)
55.102 -
55.103 -
55.104 -lemma monofun_Iwhen1: "monofun(Iwhen)"
55.105 -
55.106 -
55.107 -apply (unfold monofun)
55.108 -apply (intro strip)
55.109 -apply (rule less_fun [THEN iffD2])
55.110 -apply (intro strip)
55.111 -apply (rule less_fun [THEN iffD2])
55.112 -apply (intro strip)
55.113 -apply (rule_tac p = "xb" in IssumE)
55.114 -apply simp
55.115 -apply simp
55.116 -apply (erule monofun_cfun_fun)
55.117 -apply simp
55.118 -done
55.119 -
55.120 -lemma monofun_Iwhen2: "monofun(Iwhen(f))"
55.121 -apply (unfold monofun)
55.122 -apply (intro strip)
55.123 -apply (rule less_fun [THEN iffD2])
55.124 -apply (intro strip)
55.125 -apply (rule_tac p = "xa" in IssumE)
55.126 -apply simp
55.127 -apply simp
55.128 -apply simp
55.129 -apply (erule monofun_cfun_fun)
55.130 -done
55.131 -
55.132 -lemma monofun_Iwhen3: "monofun(Iwhen(f)(g))"
55.133 -apply (unfold monofun)
55.134 -apply (intro strip)
55.135 -apply (rule_tac p = "x" in IssumE)
55.136 -apply simp
55.137 -apply (rule_tac p = "y" in IssumE)
55.138 -apply simp
55.139 -apply (rule_tac P = "xa=UU" in notE)
55.140 -apply assumption
55.141 -apply (rule UU_I)
55.142 -apply (rule less_ssum3a [THEN iffD1])
55.143 -apply assumption
55.144 -apply simp
55.145 -apply (rule monofun_cfun_arg)
55.146 -apply (erule less_ssum3a [THEN iffD1])
55.147 -apply (simp del: Iwhen2)
55.148 -apply (rule_tac s = "UU" and t = "xa" in subst)
55.149 -apply (erule less_ssum3c [THEN iffD1, symmetric])
55.150 -apply simp
55.151 -apply (rule_tac p = "y" in IssumE)
55.152 -apply simp
55.153 -apply (simp only: less_ssum3d)
55.154 -apply (simp only: less_ssum3d)
55.155 -apply simp
55.156 -apply (rule monofun_cfun_arg)
55.157 -apply (erule less_ssum3b [THEN iffD1])
55.158 -done
55.159 -
55.160 -
55.161 -(* ------------------------------------------------------------------------ *)
55.162 -(* some kind of exhaustion rules for chains in 'a ++ 'b *)
55.163 -(* ------------------------------------------------------------------------ *)
55.164 -
55.165 -lemma ssum_lemma1: "[|~(!i.? x. Y(i::nat)=Isinl(x))|] ==> (? i.! x. Y(i)~=Isinl(x))"
55.166 -apply fast
55.167 -done
55.168 -
55.169 -lemma ssum_lemma2: "[|(? i.!x.(Y::nat => 'a++'b)(i::nat)~=Isinl(x::'a))|]
55.170 - ==> (? i y. (Y::nat => 'a++'b)(i::nat)=Isinr(y::'b) & y~=UU)"
55.171 -apply (erule exE)
55.172 -apply (rule_tac p = "Y (i) " in IssumE)
55.173 -apply (drule spec)
55.174 -apply (erule notE, assumption)
55.175 -apply (drule spec)
55.176 -apply (erule notE, assumption)
55.177 -apply fast
55.178 -done
55.179 -
55.180 -
55.181 -lemma ssum_lemma3: "[|chain(Y);(? i x. Y(i)=Isinr(x::'b) & (x::'b)~=UU)|]
55.182 - ==> (!i.? y. Y(i)=Isinr(y))"
55.183 -apply (erule exE)
55.184 -apply (erule exE)
55.185 -apply (rule allI)
55.186 -apply (rule_tac p = "Y (ia) " in IssumE)
55.187 -apply (rule exI)
55.188 -apply (rule trans)
55.189 -apply (rule_tac [2] strict_IsinlIsinr)
55.190 -apply assumption
55.191 -apply (erule_tac [2] exI)
55.192 -apply (erule conjE)
55.193 -apply (rule_tac m = "i" and n = "ia" in nat_less_cases)
55.194 -prefer 2 apply simp
55.195 -apply (rule exI, rule refl)
55.196 -apply (erule_tac P = "x=UU" in notE)
55.197 -apply (rule less_ssum3d [THEN iffD1])
55.198 -apply (erule_tac s = "Y (i) " and t = "Isinr (x) ::'a++'b" in subst)
55.199 -apply (erule_tac s = "Y (ia) " and t = "Isinl (xa) ::'a++'b" in subst)
55.200 -apply (erule chain_mono)
55.201 -apply assumption
55.202 -apply (erule_tac P = "xa=UU" in notE)
55.203 -apply (rule less_ssum3c [THEN iffD1])
55.204 -apply (erule_tac s = "Y (i) " and t = "Isinr (x) ::'a++'b" in subst)
55.205 -apply (erule_tac s = "Y (ia) " and t = "Isinl (xa) ::'a++'b" in subst)
55.206 -apply (erule chain_mono)
55.207 -apply assumption
55.208 -done
55.209 -
55.210 -lemma ssum_lemma4: "chain(Y) ==> (!i.? x. Y(i)=Isinl(x))|(!i.? y. Y(i)=Isinr(y))"
55.211 -apply (rule case_split_thm)
55.212 -apply (erule disjI1)
55.213 -apply (rule disjI2)
55.214 -apply (erule ssum_lemma3)
55.215 -apply (rule ssum_lemma2)
55.216 -apply (erule ssum_lemma1)
55.217 -done
55.218 -
55.219 -
55.220 -(* ------------------------------------------------------------------------ *)
55.221 -(* restricted surjectivity of Isinl *)
55.222 -(* ------------------------------------------------------------------------ *)
55.223 -
55.224 -lemma ssum_lemma5: "z=Isinl(x)==> Isinl((Iwhen (LAM x. x) (LAM y. UU))(z)) = z"
55.225 -apply simp
55.226 -apply (case_tac "x=UU")
55.227 -apply simp
55.228 -apply simp
55.229 -done
55.230 -
55.231 -(* ------------------------------------------------------------------------ *)
55.232 -(* restricted surjectivity of Isinr *)
55.233 -(* ------------------------------------------------------------------------ *)
55.234 -
55.235 -lemma ssum_lemma6: "z=Isinr(x)==> Isinr((Iwhen (LAM y. UU) (LAM x. x))(z)) = z"
55.236 -apply simp
55.237 -apply (case_tac "x=UU")
55.238 -apply simp
55.239 -apply simp
55.240 -done
55.241 -
55.242 -(* ------------------------------------------------------------------------ *)
55.243 -(* technical lemmas *)
55.244 -(* ------------------------------------------------------------------------ *)
55.245 -
55.246 -lemma ssum_lemma7: "[|Isinl(x) << z; x~=UU|] ==> ? y. z=Isinl(y) & y~=UU"
55.247 -apply (rule_tac p = "z" in IssumE)
55.248 -apply simp
55.249 -apply (erule notE)
55.250 -apply (rule antisym_less)
55.251 -apply (erule less_ssum3a [THEN iffD1])
55.252 -apply (rule minimal)
55.253 -apply fast
55.254 -apply simp
55.255 -apply (rule notE)
55.256 -apply (erule_tac [2] less_ssum3c [THEN iffD1])
55.257 -apply assumption
55.258 -done
55.259 -
55.260 -lemma ssum_lemma8: "[|Isinr(x) << z; x~=UU|] ==> ? y. z=Isinr(y) & y~=UU"
55.261 -apply (rule_tac p = "z" in IssumE)
55.262 -apply simp
55.263 -apply (erule notE)
55.264 -apply (erule less_ssum3d [THEN iffD1])
55.265 -apply simp
55.266 -apply (rule notE)
55.267 -apply (erule_tac [2] less_ssum3d [THEN iffD1])
55.268 -apply assumption
55.269 -apply fast
55.270 -done
55.271 -
55.272 -(* ------------------------------------------------------------------------ *)
55.273 -(* the type 'a ++ 'b is a cpo in three steps *)
55.274 -(* ------------------------------------------------------------------------ *)
55.275 -
55.276 -lemma lub_ssum1a: "[|chain(Y);(!i.? x. Y(i)=Isinl(x))|] ==>
55.277 - range(Y) <<| Isinl(lub(range(%i.(Iwhen (LAM x. x) (LAM y. UU))(Y i))))"
55.278 -apply (rule is_lubI)
55.279 -apply (rule ub_rangeI)
55.280 -apply (erule allE)
55.281 -apply (erule exE)
55.282 -apply (rule_tac t = "Y (i) " in ssum_lemma5 [THEN subst])
55.283 -apply assumption
55.284 -apply (rule monofun_Isinl [THEN monofunE, THEN spec, THEN spec, THEN mp])
55.285 -apply (rule is_ub_thelub)
55.286 -apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
55.287 -apply (rule_tac p = "u" in IssumE2)
55.288 -apply (rule_tac t = "u" in ssum_lemma5 [THEN subst])
55.289 -apply assumption
55.290 -apply (rule monofun_Isinl [THEN monofunE, THEN spec, THEN spec, THEN mp])
55.291 -apply (rule is_lub_thelub)
55.292 -apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
55.293 -apply (erule monofun_Iwhen3 [THEN ub2ub_monofun])
55.294 -apply simp
55.295 -apply (rule less_ssum3c [THEN iffD2])
55.296 -apply (rule chain_UU_I_inverse)
55.297 -apply (rule allI)
55.298 -apply (rule_tac p = "Y (i) " in IssumE)
55.299 -apply simp
55.300 -apply simp
55.301 -apply (erule notE)
55.302 -apply (rule less_ssum3c [THEN iffD1])
55.303 -apply (rule_tac t = "Isinl (x) " in subst)
55.304 -apply assumption
55.305 -apply (erule ub_rangeD)
55.306 -apply simp
55.307 -done
55.308 -
55.309 -
55.310 -lemma lub_ssum1b: "[|chain(Y);(!i.? x. Y(i)=Isinr(x))|] ==>
55.311 - range(Y) <<| Isinr(lub(range(%i.(Iwhen (LAM y. UU) (LAM x. x))(Y i))))"
55.312 -apply (rule is_lubI)
55.313 -apply (rule ub_rangeI)
55.314 -apply (erule allE)
55.315 -apply (erule exE)
55.316 -apply (rule_tac t = "Y (i) " in ssum_lemma6 [THEN subst])
55.317 -apply assumption
55.318 -apply (rule monofun_Isinr [THEN monofunE, THEN spec, THEN spec, THEN mp])
55.319 -apply (rule is_ub_thelub)
55.320 -apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
55.321 -apply (rule_tac p = "u" in IssumE2)
55.322 -apply simp
55.323 -apply (rule less_ssum3d [THEN iffD2])
55.324 -apply (rule chain_UU_I_inverse)
55.325 -apply (rule allI)
55.326 -apply (rule_tac p = "Y (i) " in IssumE)
55.327 -apply simp
55.328 -apply simp
55.329 -apply (erule notE)
55.330 -apply (rule less_ssum3d [THEN iffD1])
55.331 -apply (rule_tac t = "Isinr (y) " in subst)
55.332 -apply assumption
55.333 -apply (erule ub_rangeD)
55.334 -apply (rule_tac t = "u" in ssum_lemma6 [THEN subst])
55.335 -apply assumption
55.336 -apply (rule monofun_Isinr [THEN monofunE, THEN spec, THEN spec, THEN mp])
55.337 -apply (rule is_lub_thelub)
55.338 -apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
55.339 -apply (erule monofun_Iwhen3 [THEN ub2ub_monofun])
55.340 -done
55.341 -
55.342 -
55.343 -lemmas thelub_ssum1a = lub_ssum1a [THEN thelubI, standard]
55.344 -(*
55.345 -[| chain ?Y1; ! i. ? x. ?Y1 i = Isinl x |] ==>
55.346 - lub (range ?Y1) = Isinl
55.347 - (lub (range (%i. Iwhen (LAM x. x) (LAM y. UU) (?Y1 i))))
55.348 -*)
55.349 -
55.350 -lemmas thelub_ssum1b = lub_ssum1b [THEN thelubI, standard]
55.351 -(*
55.352 -[| chain ?Y1; ! i. ? x. ?Y1 i = Isinr x |] ==>
55.353 - lub (range ?Y1) = Isinr
55.354 - (lub (range (%i. Iwhen (LAM y. UU) (LAM x. x) (?Y1 i))))
55.355 -*)
55.356 -
55.357 -lemma cpo_ssum: "chain(Y::nat=>'a ++'b) ==> ? x. range(Y) <<|x"
55.358 -apply (rule ssum_lemma4 [THEN disjE])
55.359 -apply assumption
55.360 -apply (rule exI)
55.361 -apply (erule lub_ssum1a)
55.362 -apply assumption
55.363 -apply (rule exI)
55.364 -apply (erule lub_ssum1b)
55.365 -apply assumption
55.366 -done
55.367 -
55.368 -end
55.369 -
55.370 -
55.371 -
56.1 --- a/src/HOLCF/Ssum3.ML Fri Mar 04 18:53:46 2005 +0100
56.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
56.3 @@ -1,48 +0,0 @@
56.4 -
56.5 -(* legacy ML bindings *)
56.6 -
56.7 -val sinl_def = thm "sinl_def";
56.8 -val sinr_def = thm "sinr_def";
56.9 -val sscase_def = thm "sscase_def";
56.10 -val inst_ssum_pcpo = thm "inst_ssum_pcpo";
56.11 -val contlub_Isinl = thm "contlub_Isinl";
56.12 -val contlub_Isinr = thm "contlub_Isinr";
56.13 -val cont_Isinl = thm "cont_Isinl";
56.14 -val cont_Isinr = thm "cont_Isinr";
56.15 -val contlub_Iwhen1 = thm "contlub_Iwhen1";
56.16 -val contlub_Iwhen2 = thm "contlub_Iwhen2";
56.17 -val ssum_lemma9 = thm "ssum_lemma9";
56.18 -val ssum_lemma10 = thm "ssum_lemma10";
56.19 -val ssum_lemma11 = thm "ssum_lemma11";
56.20 -val ssum_lemma12 = thm "ssum_lemma12";
56.21 -val ssum_lemma13 = thm "ssum_lemma13";
56.22 -val contlub_Iwhen3 = thm "contlub_Iwhen3";
56.23 -val cont_Iwhen1 = thm "cont_Iwhen1";
56.24 -val cont_Iwhen2 = thm "cont_Iwhen2";
56.25 -val cont_Iwhen3 = thm "cont_Iwhen3";
56.26 -val strict_sinl = thm "strict_sinl";
56.27 -val strict_sinr = thm "strict_sinr";
56.28 -val noteq_sinlsinr = thm "noteq_sinlsinr";
56.29 -val inject_sinl = thm "inject_sinl";
56.30 -val inject_sinr = thm "inject_sinr";
56.31 -val defined_sinl = thm "defined_sinl";
56.32 -val defined_sinr = thm "defined_sinr";
56.33 -val Exh_Ssum1 = thm "Exh_Ssum1";
56.34 -val ssumE = thm "ssumE";
56.35 -val ssumE2 = thm "ssumE2";
56.36 -val sscase1 = thm "sscase1";
56.37 -val sscase2 = thm "sscase2";
56.38 -val sscase3 = thm "sscase3";
56.39 -val less_ssum4a = thm "less_ssum4a";
56.40 -val less_ssum4b = thm "less_ssum4b";
56.41 -val less_ssum4c = thm "less_ssum4c";
56.42 -val less_ssum4d = thm "less_ssum4d";
56.43 -val ssum_chainE = thm "ssum_chainE";
56.44 -val thelub_ssum2a = thm "thelub_ssum2a";
56.45 -val thelub_ssum2b = thm "thelub_ssum2b";
56.46 -val thelub_ssum2a_rev = thm "thelub_ssum2a_rev";
56.47 -val thelub_ssum2b_rev = thm "thelub_ssum2b_rev";
56.48 -val thelub_ssum3 = thm "thelub_ssum3";
56.49 -val sscase4 = thm "sscase4";
56.50 -val Ssum_rews = [strict_sinl, strict_sinr, defined_sinl, defined_sinr,
56.51 - sscase1, sscase2, sscase3]
57.1 --- a/src/HOLCF/Ssum3.thy Fri Mar 04 18:53:46 2005 +0100
57.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
57.3 @@ -1,624 +0,0 @@
57.4 -(* Title: HOLCF/ssum3.thy
57.5 - ID: $Id$
57.6 - Author: Franz Regensburger
57.7 - License: GPL (GNU GENERAL PUBLIC LICENSE)
57.8 -
57.9 -Class instance of ++ for class pcpo
57.10 -*)
57.11 -
57.12 -theory Ssum3 = Ssum2:
57.13 -
57.14 -instance "++" :: (pcpo,pcpo)pcpo
57.15 -apply (intro_classes)
57.16 -apply (erule cpo_ssum)
57.17 -apply (rule least_ssum)
57.18 -done
57.19 -
57.20 -consts
57.21 - sinl :: "'a -> ('a++'b)"
57.22 - sinr :: "'b -> ('a++'b)"
57.23 - sscase :: "('a->'c)->('b->'c)->('a ++ 'b)-> 'c"
57.24 -
57.25 -defs
57.26 -
57.27 -sinl_def: "sinl == (LAM x. Isinl(x))"
57.28 -sinr_def: "sinr == (LAM x. Isinr(x))"
57.29 -sscase_def: "sscase == (LAM f g s. Iwhen(f)(g)(s))"
57.30 -
57.31 -translations
57.32 -"case s of sinl$x => t1 | sinr$y => t2" == "sscase$(LAM x. t1)$(LAM y. t2)$s"
57.33 -
57.34 -(* Title: HOLCF/Ssum3.ML
57.35 - ID: $Id$
57.36 - Author: Franz Regensburger
57.37 - License: GPL (GNU GENERAL PUBLIC LICENSE)
57.38 -
57.39 -Class instance of ++ for class pcpo
57.40 -*)
57.41 -
57.42 -(* for compatibility with old HOLCF-Version *)
57.43 -lemma inst_ssum_pcpo: "UU = Isinl UU"
57.44 -apply (simp add: UU_def UU_ssum_def)
57.45 -done
57.46 -
57.47 -declare inst_ssum_pcpo [symmetric, simp]
57.48 -
57.49 -(* ------------------------------------------------------------------------ *)
57.50 -(* continuity for Isinl and Isinr *)
57.51 -(* ------------------------------------------------------------------------ *)
57.52 -
57.53 -lemma contlub_Isinl: "contlub(Isinl)"
57.54 -apply (rule contlubI)
57.55 -apply (intro strip)
57.56 -apply (rule trans)
57.57 -apply (rule_tac [2] thelub_ssum1a [symmetric])
57.58 -apply (rule_tac [3] allI)
57.59 -apply (rule_tac [3] exI)
57.60 -apply (rule_tac [3] refl)
57.61 -apply (erule_tac [2] monofun_Isinl [THEN ch2ch_monofun])
57.62 -apply (case_tac "lub (range (Y))=UU")
57.63 -apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
57.64 -apply assumption
57.65 -apply (rule_tac f = "Isinl" in arg_cong)
57.66 -apply (rule chain_UU_I_inverse [symmetric])
57.67 -apply (rule allI)
57.68 -apply (rule_tac s = "UU" and t = "Y (i) " in ssubst)
57.69 -apply (erule chain_UU_I [THEN spec])
57.70 -apply assumption
57.71 -apply (rule Iwhen1)
57.72 -apply (rule_tac f = "Isinl" in arg_cong)
57.73 -apply (rule lub_equal)
57.74 -apply assumption
57.75 -apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
57.76 -apply (erule monofun_Isinl [THEN ch2ch_monofun])
57.77 -apply (rule allI)
57.78 -apply (case_tac "Y (k) =UU")
57.79 -apply (erule ssubst)
57.80 -apply (rule Iwhen1[symmetric])
57.81 -apply simp
57.82 -done
57.83 -
57.84 -lemma contlub_Isinr: "contlub(Isinr)"
57.85 -apply (rule contlubI)
57.86 -apply (intro strip)
57.87 -apply (rule trans)
57.88 -apply (rule_tac [2] thelub_ssum1b [symmetric])
57.89 -apply (rule_tac [3] allI)
57.90 -apply (rule_tac [3] exI)
57.91 -apply (rule_tac [3] refl)
57.92 -apply (erule_tac [2] monofun_Isinr [THEN ch2ch_monofun])
57.93 -apply (case_tac "lub (range (Y))=UU")
57.94 -apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
57.95 -apply assumption
57.96 -apply (rule arg_cong, rule chain_UU_I_inverse [symmetric])
57.97 -apply (rule allI)
57.98 -apply (rule_tac s = "UU" and t = "Y (i) " in ssubst)
57.99 -apply (erule chain_UU_I [THEN spec])
57.100 -apply assumption
57.101 -apply (rule strict_IsinlIsinr [THEN subst])
57.102 -apply (rule Iwhen1)
57.103 -apply (rule arg_cong, rule lub_equal)
57.104 -apply assumption
57.105 -apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
57.106 -apply (erule monofun_Isinr [THEN ch2ch_monofun])
57.107 -apply (rule allI)
57.108 -apply (case_tac "Y (k) =UU")
57.109 -apply (simp only: Ssum0_ss)
57.110 -apply simp
57.111 -done
57.112 -
57.113 -lemma cont_Isinl: "cont(Isinl)"
57.114 -apply (rule monocontlub2cont)
57.115 -apply (rule monofun_Isinl)
57.116 -apply (rule contlub_Isinl)
57.117 -done
57.118 -
57.119 -lemma cont_Isinr: "cont(Isinr)"
57.120 -apply (rule monocontlub2cont)
57.121 -apply (rule monofun_Isinr)
57.122 -apply (rule contlub_Isinr)
57.123 -done
57.124 -
57.125 -declare cont_Isinl [iff] cont_Isinr [iff]
57.126 -
57.127 -
57.128 -(* ------------------------------------------------------------------------ *)
57.129 -(* continuity for Iwhen in the firts two arguments *)
57.130 -(* ------------------------------------------------------------------------ *)
57.131 -
57.132 -lemma contlub_Iwhen1: "contlub(Iwhen)"
57.133 -apply (rule contlubI)
57.134 -apply (intro strip)
57.135 -apply (rule trans)
57.136 -apply (rule_tac [2] thelub_fun [symmetric])
57.137 -apply (erule_tac [2] monofun_Iwhen1 [THEN ch2ch_monofun])
57.138 -apply (rule expand_fun_eq [THEN iffD2])
57.139 -apply (intro strip)
57.140 -apply (rule trans)
57.141 -apply (rule_tac [2] thelub_fun [symmetric])
57.142 -apply (rule_tac [2] ch2ch_fun)
57.143 -apply (erule_tac [2] monofun_Iwhen1 [THEN ch2ch_monofun])
57.144 -apply (rule expand_fun_eq [THEN iffD2])
57.145 -apply (intro strip)
57.146 -apply (rule_tac p = "xa" in IssumE)
57.147 -apply (simp only: Ssum0_ss)
57.148 -apply (rule lub_const [THEN thelubI, symmetric])
57.149 -apply simp
57.150 -apply (erule contlub_cfun_fun)
57.151 -apply simp
57.152 -apply (rule lub_const [THEN thelubI, symmetric])
57.153 -done
57.154 -
57.155 -lemma contlub_Iwhen2: "contlub(Iwhen(f))"
57.156 -apply (rule contlubI)
57.157 -apply (intro strip)
57.158 -apply (rule trans)
57.159 -apply (rule_tac [2] thelub_fun [symmetric])
57.160 -apply (erule_tac [2] monofun_Iwhen2 [THEN ch2ch_monofun])
57.161 -apply (rule expand_fun_eq [THEN iffD2])
57.162 -apply (intro strip)
57.163 -apply (rule_tac p = "x" in IssumE)
57.164 -apply (simp only: Ssum0_ss)
57.165 -apply (rule lub_const [THEN thelubI, symmetric])
57.166 -apply simp
57.167 -apply (rule lub_const [THEN thelubI, symmetric])
57.168 -apply simp
57.169 -apply (erule contlub_cfun_fun)
57.170 -done
57.171 -
57.172 -(* ------------------------------------------------------------------------ *)
57.173 -(* continuity for Iwhen in its third argument *)
57.174 -(* ------------------------------------------------------------------------ *)
57.175 -
57.176 -(* ------------------------------------------------------------------------ *)
57.177 -(* first 5 ugly lemmas *)
57.178 -(* ------------------------------------------------------------------------ *)
57.179 -
57.180 -lemma ssum_lemma9: "[| chain(Y); lub(range(Y)) = Isinl(x)|] ==> !i.? x. Y(i)=Isinl(x)"
57.181 -apply (intro strip)
57.182 -apply (rule_tac p = "Y (i) " in IssumE)
57.183 -apply (erule exI)
57.184 -apply (erule exI)
57.185 -apply (rule_tac P = "y=UU" in notE)
57.186 -apply assumption
57.187 -apply (rule less_ssum3d [THEN iffD1])
57.188 -apply (erule subst)
57.189 -apply (erule subst)
57.190 -apply (erule is_ub_thelub)
57.191 -done
57.192 -
57.193 -
57.194 -lemma ssum_lemma10: "[| chain(Y); lub(range(Y)) = Isinr(x)|] ==> !i.? x. Y(i)=Isinr(x)"
57.195 -apply (intro strip)
57.196 -apply (rule_tac p = "Y (i) " in IssumE)
57.197 -apply (rule exI)
57.198 -apply (erule trans)
57.199 -apply (rule strict_IsinlIsinr)
57.200 -apply (erule_tac [2] exI)
57.201 -apply (rule_tac P = "xa=UU" in notE)
57.202 -apply assumption
57.203 -apply (rule less_ssum3c [THEN iffD1])
57.204 -apply (erule subst)
57.205 -apply (erule subst)
57.206 -apply (erule is_ub_thelub)
57.207 -done
57.208 -
57.209 -lemma ssum_lemma11: "[| chain(Y); lub(range(Y)) = Isinl(UU) |] ==>
57.210 - Iwhen f g (lub(range Y)) = lub(range(%i. Iwhen f g (Y i)))"
57.211 -apply (simp only: Ssum0_ss)
57.212 -apply (rule chain_UU_I_inverse [symmetric])
57.213 -apply (rule allI)
57.214 -apply (rule_tac s = "Isinl (UU) " and t = "Y (i) " in subst)
57.215 -apply (rule inst_ssum_pcpo [THEN subst])
57.216 -apply (rule chain_UU_I [THEN spec, symmetric])
57.217 -apply assumption
57.218 -apply (erule inst_ssum_pcpo [THEN ssubst])
57.219 -apply (simp only: Ssum0_ss)
57.220 -done
57.221 -
57.222 -lemma ssum_lemma12: "[| chain(Y); lub(range(Y)) = Isinl(x); x ~= UU |] ==>
57.223 - Iwhen f g (lub(range Y)) = lub(range(%i. Iwhen f g (Y i)))"
57.224 -apply simp
57.225 -apply (rule_tac t = "x" in subst)
57.226 -apply (rule inject_Isinl)
57.227 -apply (rule trans)
57.228 -prefer 2 apply (assumption)
57.229 -apply (rule thelub_ssum1a [symmetric])
57.230 -apply assumption
57.231 -apply (erule ssum_lemma9)
57.232 -apply assumption
57.233 -apply (rule trans)
57.234 -apply (rule contlub_cfun_arg)
57.235 -apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
57.236 -apply assumption
57.237 -apply (rule lub_equal2)
57.238 -apply (rule chain_mono2 [THEN exE])
57.239 -prefer 2 apply (assumption)
57.240 -apply (rule chain_UU_I_inverse2)
57.241 -apply (subst inst_ssum_pcpo)
57.242 -apply (erule contrapos_np)
57.243 -apply (rule inject_Isinl)
57.244 -apply (rule trans)
57.245 -apply (erule sym)
57.246 -apply (erule notnotD)
57.247 -apply (rule exI)
57.248 -apply (intro strip)
57.249 -apply (rule ssum_lemma9 [THEN spec, THEN exE])
57.250 -apply assumption
57.251 -apply assumption
57.252 -apply (rule_tac t = "Y (i) " in ssubst)
57.253 -apply assumption
57.254 -apply (rule trans)
57.255 -apply (rule cfun_arg_cong)
57.256 -apply (rule Iwhen2)
57.257 -apply force
57.258 -apply (rule_tac t = "Y (i) " in ssubst)
57.259 -apply assumption
57.260 -apply auto
57.261 -apply (subst Iwhen2)
57.262 -apply force
57.263 -apply (rule refl)
57.264 -apply (rule monofun_Rep_CFun2 [THEN ch2ch_monofun])
57.265 -apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
57.266 -apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
57.267 -done
57.268 -
57.269 -
57.270 -lemma ssum_lemma13: "[| chain(Y); lub(range(Y)) = Isinr(x); x ~= UU |] ==>
57.271 - Iwhen f g (lub(range Y)) = lub(range(%i. Iwhen f g (Y i)))"
57.272 -apply simp
57.273 -apply (rule_tac t = "x" in subst)
57.274 -apply (rule inject_Isinr)
57.275 -apply (rule trans)
57.276 -prefer 2 apply (assumption)
57.277 -apply (rule thelub_ssum1b [symmetric])
57.278 -apply assumption
57.279 -apply (erule ssum_lemma10)
57.280 -apply assumption
57.281 -apply (rule trans)
57.282 -apply (rule contlub_cfun_arg)
57.283 -apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
57.284 -apply assumption
57.285 -apply (rule lub_equal2)
57.286 -apply (rule chain_mono2 [THEN exE])
57.287 -prefer 2 apply (assumption)
57.288 -apply (rule chain_UU_I_inverse2)
57.289 -apply (subst inst_ssum_pcpo)
57.290 -apply (erule contrapos_np)
57.291 -apply (rule inject_Isinr)
57.292 -apply (rule trans)
57.293 -apply (erule sym)
57.294 -apply (rule strict_IsinlIsinr [THEN subst])
57.295 -apply (erule notnotD)
57.296 -apply (rule exI)
57.297 -apply (intro strip)
57.298 -apply (rule ssum_lemma10 [THEN spec, THEN exE])
57.299 -apply assumption
57.300 -apply assumption
57.301 -apply (rule_tac t = "Y (i) " in ssubst)
57.302 -apply assumption
57.303 -apply (rule trans)
57.304 -apply (rule cfun_arg_cong)
57.305 -apply (rule Iwhen3)
57.306 -apply force
57.307 -apply (rule_tac t = "Y (i) " in ssubst)
57.308 -apply assumption
57.309 -apply (subst Iwhen3)
57.310 -apply force
57.311 -apply (rule_tac t = "Y (i) " in ssubst)
57.312 -apply assumption
57.313 -apply simp
57.314 -apply (rule monofun_Rep_CFun2 [THEN ch2ch_monofun])
57.315 -apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
57.316 -apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
57.317 -done
57.318 -
57.319 -
57.320 -lemma contlub_Iwhen3: "contlub(Iwhen(f)(g))"
57.321 -apply (rule contlubI)
57.322 -apply (intro strip)
57.323 -apply (rule_tac p = "lub (range (Y))" in IssumE)
57.324 -apply (erule ssum_lemma11)
57.325 -apply assumption
57.326 -apply (erule ssum_lemma12)
57.327 -apply assumption
57.328 -apply assumption
57.329 -apply (erule ssum_lemma13)
57.330 -apply assumption
57.331 -apply assumption
57.332 -done
57.333 -
57.334 -lemma cont_Iwhen1: "cont(Iwhen)"
57.335 -apply (rule monocontlub2cont)
57.336 -apply (rule monofun_Iwhen1)
57.337 -apply (rule contlub_Iwhen1)
57.338 -done
57.339 -
57.340 -lemma cont_Iwhen2: "cont(Iwhen(f))"
57.341 -apply (rule monocontlub2cont)
57.342 -apply (rule monofun_Iwhen2)
57.343 -apply (rule contlub_Iwhen2)
57.344 -done
57.345 -
57.346 -lemma cont_Iwhen3: "cont(Iwhen(f)(g))"
57.347 -apply (rule monocontlub2cont)
57.348 -apply (rule monofun_Iwhen3)
57.349 -apply (rule contlub_Iwhen3)
57.350 -done
57.351 -
57.352 -(* ------------------------------------------------------------------------ *)
57.353 -(* continuous versions of lemmas for 'a ++ 'b *)
57.354 -(* ------------------------------------------------------------------------ *)
57.355 -
57.356 -lemma strict_sinl: "sinl$UU =UU"
57.357 -
57.358 -apply (unfold sinl_def)
57.359 -apply (simp add: cont_Isinl)
57.360 -done
57.361 -declare strict_sinl [simp]
57.362 -
57.363 -lemma strict_sinr: "sinr$UU=UU"
57.364 -apply (unfold sinr_def)
57.365 -apply (simp add: cont_Isinr)
57.366 -done
57.367 -declare strict_sinr [simp]
57.368 -
57.369 -lemma noteq_sinlsinr:
57.370 - "sinl$a=sinr$b ==> a=UU & b=UU"
57.371 -apply (unfold sinl_def sinr_def)
57.372 -apply (auto dest!: noteq_IsinlIsinr)
57.373 -done
57.374 -
57.375 -lemma inject_sinl:
57.376 - "sinl$a1=sinl$a2==> a1=a2"
57.377 -apply (unfold sinl_def sinr_def)
57.378 -apply auto
57.379 -done
57.380 -
57.381 -lemma inject_sinr:
57.382 - "sinr$a1=sinr$a2==> a1=a2"
57.383 -apply (unfold sinl_def sinr_def)
57.384 -apply auto
57.385 -done
57.386 -
57.387 -declare inject_sinl [dest!] inject_sinr [dest!]
57.388 -
57.389 -lemma defined_sinl: "x~=UU ==> sinl$x ~= UU"
57.390 -apply (erule contrapos_nn)
57.391 -apply (rule inject_sinl)
57.392 -apply auto
57.393 -done
57.394 -declare defined_sinl [simp]
57.395 -
57.396 -lemma defined_sinr: "x~=UU ==> sinr$x ~= UU"
57.397 -apply (erule contrapos_nn)
57.398 -apply (rule inject_sinr)
57.399 -apply auto
57.400 -done
57.401 -declare defined_sinr [simp]
57.402 -
57.403 -lemma Exh_Ssum1:
57.404 - "z=UU | (? a. z=sinl$a & a~=UU) | (? b. z=sinr$b & b~=UU)"
57.405 -apply (unfold sinl_def sinr_def)
57.406 -apply simp
57.407 -apply (subst inst_ssum_pcpo)
57.408 -apply (rule Exh_Ssum)
57.409 -done
57.410 -
57.411 -
57.412 -lemma ssumE:
57.413 -assumes major: "p=UU ==> Q"
57.414 -assumes prem2: "!!x.[|p=sinl$x; x~=UU |] ==> Q"
57.415 -assumes prem3: "!!y.[|p=sinr$y; y~=UU |] ==> Q"
57.416 -shows "Q"
57.417 -apply (rule major [THEN IssumE])
57.418 -apply (subst inst_ssum_pcpo)
57.419 -apply assumption
57.420 -apply (rule prem2)
57.421 -prefer 2 apply (assumption)
57.422 -apply (simp add: sinl_def)
57.423 -apply (rule prem3)
57.424 -prefer 2 apply (assumption)
57.425 -apply (simp add: sinr_def)
57.426 -done
57.427 -
57.428 -
57.429 -lemma ssumE2:
57.430 -assumes preml: "!!x.[|p=sinl$x|] ==> Q"
57.431 -assumes premr: "!!y.[|p=sinr$y|] ==> Q"
57.432 -shows "Q"
57.433 -apply (rule IssumE2)
57.434 -apply (rule preml)
57.435 -apply (rule_tac [2] premr)
57.436 -apply (unfold sinl_def sinr_def)
57.437 -apply auto
57.438 -done
57.439 -
57.440 -lemmas ssum_conts = cont_lemmas1 cont_Iwhen1 cont_Iwhen2
57.441 - cont_Iwhen3 cont2cont_CF1L
57.442 -
57.443 -lemma sscase1:
57.444 - "sscase$f$g$UU = UU"
57.445 -apply (unfold sscase_def sinl_def sinr_def)
57.446 -apply (subst inst_ssum_pcpo)
57.447 -apply (subst beta_cfun)
57.448 -apply (intro ssum_conts)
57.449 -apply (subst beta_cfun)
57.450 -apply (intro ssum_conts)
57.451 -apply (subst beta_cfun)
57.452 -apply (intro ssum_conts)
57.453 -apply (simp only: Ssum0_ss)
57.454 -done
57.455 -declare sscase1 [simp]
57.456 -
57.457 -
57.458 -lemma sscase2:
57.459 - "x~=UU==> sscase$f$g$(sinl$x) = f$x"
57.460 -apply (unfold sscase_def sinl_def sinr_def)
57.461 -apply (simplesubst beta_cfun)
57.462 -apply (rule cont_Isinl)
57.463 -apply (subst beta_cfun)
57.464 -apply (intro ssum_conts)
57.465 -apply (subst beta_cfun)
57.466 -apply (intro ssum_conts)
57.467 -apply (subst beta_cfun)
57.468 -apply (intro ssum_conts)
57.469 -apply simp
57.470 -done
57.471 -declare sscase2 [simp]
57.472 -
57.473 -lemma sscase3:
57.474 - "x~=UU==> sscase$f$g$(sinr$x) = g$x"
57.475 -apply (unfold sscase_def sinl_def sinr_def)
57.476 -apply (simplesubst beta_cfun)
57.477 -apply (rule cont_Isinr)
57.478 -apply (subst beta_cfun)
57.479 -apply (intro ssum_conts)
57.480 -apply (subst beta_cfun)
57.481 -apply (intro ssum_conts)
57.482 -apply (subst beta_cfun)
57.483 -apply (intro ssum_conts)
57.484 -apply simp
57.485 -done
57.486 -declare sscase3 [simp]
57.487 -
57.488 -
57.489 -lemma less_ssum4a:
57.490 - "(sinl$x << sinl$y) = (x << y)"
57.491 -
57.492 -apply (unfold sinl_def sinr_def)
57.493 -apply (subst beta_cfun)
57.494 -apply (rule cont_Isinl)
57.495 -apply (subst beta_cfun)
57.496 -apply (rule cont_Isinl)
57.497 -apply (rule less_ssum3a)
57.498 -done
57.499 -
57.500 -lemma less_ssum4b:
57.501 - "(sinr$x << sinr$y) = (x << y)"
57.502 -apply (unfold sinl_def sinr_def)
57.503 -apply (subst beta_cfun)
57.504 -apply (rule cont_Isinr)
57.505 -apply (subst beta_cfun)
57.506 -apply (rule cont_Isinr)
57.507 -apply (rule less_ssum3b)
57.508 -done
57.509 -
57.510 -lemma less_ssum4c:
57.511 - "(sinl$x << sinr$y) = (x = UU)"
57.512 -apply (unfold sinl_def sinr_def)
57.513 -apply (simplesubst beta_cfun)
57.514 -apply (rule cont_Isinr)
57.515 -apply (subst beta_cfun)
57.516 -apply (rule cont_Isinl)
57.517 -apply (rule less_ssum3c)
57.518 -done
57.519 -
57.520 -lemma less_ssum4d:
57.521 - "(sinr$x << sinl$y) = (x = UU)"
57.522 -apply (unfold sinl_def sinr_def)
57.523 -apply (simplesubst beta_cfun)
57.524 -apply (rule cont_Isinl)
57.525 -apply (subst beta_cfun)
57.526 -apply (rule cont_Isinr)
57.527 -apply (rule less_ssum3d)
57.528 -done
57.529 -
57.530 -lemma ssum_chainE:
57.531 - "chain(Y) ==> (!i.? x.(Y i)=sinl$x)|(!i.? y.(Y i)=sinr$y)"
57.532 -apply (unfold sinl_def sinr_def)
57.533 -apply simp
57.534 -apply (erule ssum_lemma4)
57.535 -done
57.536 -
57.537 -
57.538 -lemma thelub_ssum2a:
57.539 -"[| chain(Y); !i.? x. Y(i) = sinl$x |] ==>
57.540 - lub(range(Y)) = sinl$(lub(range(%i. sscase$(LAM x. x)$(LAM y. UU)$(Y i))))"
57.541 -
57.542 -apply (unfold sinl_def sinr_def sscase_def)
57.543 -apply (subst beta_cfun)
57.544 -apply (rule cont_Isinl)
57.545 -apply (subst beta_cfun)
57.546 -apply (intro ssum_conts)
57.547 -apply (subst beta_cfun)
57.548 -apply (intro ssum_conts)
57.549 -apply (subst beta_cfun [THEN ext])
57.550 -apply (intro ssum_conts)
57.551 -apply (rule thelub_ssum1a)
57.552 -apply assumption
57.553 -apply (rule allI)
57.554 -apply (erule allE)
57.555 -apply (erule exE)
57.556 -apply (rule exI)
57.557 -apply (erule box_equals)
57.558 -apply (rule refl)
57.559 -apply simp
57.560 -done
57.561 -
57.562 -lemma thelub_ssum2b:
57.563 -"[| chain(Y); !i.? x. Y(i) = sinr$x |] ==>
57.564 - lub(range(Y)) = sinr$(lub(range(%i. sscase$(LAM y. UU)$(LAM x. x)$(Y i))))"
57.565 -apply (unfold sinl_def sinr_def sscase_def)
57.566 -apply (subst beta_cfun)
57.567 -apply (rule cont_Isinr)
57.568 -apply (subst beta_cfun)
57.569 -apply (intro ssum_conts)
57.570 -apply (subst beta_cfun)
57.571 -apply (intro ssum_conts)
57.572 -apply (subst beta_cfun [THEN ext])
57.573 -apply (intro ssum_conts)
57.574 -apply (rule thelub_ssum1b)
57.575 -apply assumption
57.576 -apply (rule allI)
57.577 -apply (erule allE)
57.578 -apply (erule exE)
57.579 -apply (rule exI)
57.580 -apply (erule box_equals)
57.581 -apply (rule refl)
57.582 -apply simp
57.583 -done
57.584 -
57.585 -lemma thelub_ssum2a_rev:
57.586 - "[| chain(Y); lub(range(Y)) = sinl$x|] ==> !i.? x. Y(i)=sinl$x"
57.587 -apply (unfold sinl_def sinr_def)
57.588 -apply simp
57.589 -apply (erule ssum_lemma9)
57.590 -apply simp
57.591 -done
57.592 -
57.593 -lemma thelub_ssum2b_rev:
57.594 - "[| chain(Y); lub(range(Y)) = sinr$x|] ==> !i.? x. Y(i)=sinr$x"
57.595 -apply (unfold sinl_def sinr_def)
57.596 -apply simp
57.597 -apply (erule ssum_lemma10)
57.598 -apply simp
57.599 -done
57.600 -
57.601 -lemma thelub_ssum3: "chain(Y) ==>
57.602 - lub(range(Y)) = sinl$(lub(range(%i. sscase$(LAM x. x)$(LAM y. UU)$(Y i))))
57.603 - | lub(range(Y)) = sinr$(lub(range(%i. sscase$(LAM y. UU)$(LAM x. x)$(Y i))))"
57.604 -apply (rule ssum_chainE [THEN disjE])
57.605 -apply assumption
57.606 -apply (rule disjI1)
57.607 -apply (erule thelub_ssum2a)
57.608 -apply assumption
57.609 -apply (rule disjI2)
57.610 -apply (erule thelub_ssum2b)
57.611 -apply assumption
57.612 -done
57.613 -
57.614 -lemma sscase4: "sscase$sinl$sinr$z=z"
57.615 -apply (rule_tac p = "z" in ssumE)
57.616 -apply auto
57.617 -done
57.618 -
57.619 -
57.620 -(* ------------------------------------------------------------------------ *)
57.621 -(* install simplifier for Ssum *)
57.622 -(* ------------------------------------------------------------------------ *)
57.623 -
57.624 -lemmas Ssum_rews = strict_sinl strict_sinr defined_sinl defined_sinr
57.625 - sscase1 sscase2 sscase3
57.626 -
57.627 -end
58.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
58.2 +++ b/src/HOLCF/Up.ML Fri Mar 04 23:12:36 2005 +0100
58.3 @@ -0,0 +1,62 @@
58.4 +
58.5 +(* legacy ML bindings *)
58.6 +
58.7 +val Iup_def = thm "Iup_def";
58.8 +val Ifup_def = thm "Ifup_def";
58.9 +val less_up_def = thm "less_up_def";
58.10 +val Abs_Up_inverse2 = thm "Abs_Up_inverse2";
58.11 +val Exh_Up = thm "Exh_Up";
58.12 +val inj_Abs_Up = thm "inj_Abs_Up";
58.13 +val inj_Rep_Up = thm "inj_Rep_Up";
58.14 +val inject_Iup = thm "inject_Iup";
58.15 +val defined_Iup = thm "defined_Iup";
58.16 +val upE = thm "upE";
58.17 +val Ifup1 = thm "Ifup1";
58.18 +val Ifup2 = thm "Ifup2";
58.19 +val less_up1a = thm "less_up1a";
58.20 +val less_up1b = thm "less_up1b";
58.21 +val less_up1c = thm "less_up1c";
58.22 +val refl_less_up = thm "refl_less_up";
58.23 +val antisym_less_up = thm "antisym_less_up";
58.24 +val trans_less_up = thm "trans_less_up";
58.25 +val inst_up_po = thm "inst_up_po";
58.26 +val minimal_up = thm "minimal_up";
58.27 +val UU_up_def = thm "UU_up_def";
58.28 +val least_up = thm "least_up";
58.29 +val less_up2b = thm "less_up2b";
58.30 +val less_up2c = thm "less_up2c";
58.31 +val monofun_Iup = thm "monofun_Iup";
58.32 +val monofun_Ifup1 = thm "monofun_Ifup1";
58.33 +val monofun_Ifup2 = thm "monofun_Ifup2";
58.34 +val up_lemma1 = thm "up_lemma1";
58.35 +val lub_up1a = thm "lub_up1a";
58.36 +val lub_up1b = thm "lub_up1b";
58.37 +val thelub_up1a = thm "thelub_up1a";
58.38 +val thelub_up1b = thm "thelub_up1b";
58.39 +val cpo_up = thm "cpo_up";
58.40 +val up_def = thm "up_def";
58.41 +val fup_def = thm "fup_def";
58.42 +val inst_up_pcpo = thm "inst_up_pcpo";
58.43 +val less_up3b = thm "less_up3b";
58.44 +val defined_Iup2 = thm "defined_Iup2";
58.45 +val contlub_Iup = thm "contlub_Iup";
58.46 +val cont_Iup = thm "cont_Iup";
58.47 +val contlub_Ifup1 = thm "contlub_Ifup1";
58.48 +val contlub_Ifup2 = thm "contlub_Ifup2";
58.49 +val cont_Ifup1 = thm "cont_Ifup1";
58.50 +val cont_Ifup2 = thm "cont_Ifup2";
58.51 +val Exh_Up1 = thm "Exh_Up1";
58.52 +val inject_up = thm "inject_up";
58.53 +val defined_up = thm "defined_up";
58.54 +val upE1 = thm "upE1";
58.55 +val fup1 = thm "fup1";
58.56 +val fup2 = thm "fup2";
58.57 +val less_up4b = thm "less_up4b";
58.58 +val less_up4c = thm "less_up4c";
58.59 +val thelub_up2a = thm "thelub_up2a";
58.60 +val thelub_up2b = thm "thelub_up2b";
58.61 +val up_lemma2 = thm "up_lemma2";
58.62 +val thelub_up2a_rev = thm "thelub_up2a_rev";
58.63 +val thelub_up2b_rev = thm "thelub_up2b_rev";
58.64 +val thelub_up3 = thm "thelub_up3";
58.65 +val fup3 = thm "fup3";
59.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
59.2 +++ b/src/HOLCF/Up.thy Fri Mar 04 23:12:36 2005 +0100
59.3 @@ -0,0 +1,625 @@
59.4 +(* Title: HOLCF/Up1.thy
59.5 + ID: $Id$
59.6 + Author: Franz Regensburger
59.7 + License: GPL (GNU GENERAL PUBLIC LICENSE)
59.8 +
59.9 +Lifting.
59.10 +*)
59.11 +
59.12 +header {* The type of lifted values *}
59.13 +
59.14 +theory Up = Cfun + Sum_Type + Datatype:
59.15 +
59.16 +(* new type for lifting *)
59.17 +
59.18 +typedef (Up) ('a) "u" = "{x::(unit + 'a).True}"
59.19 +by auto
59.20 +
59.21 +instance u :: (sq_ord)sq_ord ..
59.22 +
59.23 +consts
59.24 + Iup :: "'a => ('a)u"
59.25 + Ifup :: "('a->'b)=>('a)u => 'b"
59.26 +
59.27 +defs
59.28 + Iup_def: "Iup x == Abs_Up(Inr(x))"
59.29 + Ifup_def: "Ifup(f)(x)== case Rep_Up(x) of Inl(y) => UU | Inr(z) => f$z"
59.30 +
59.31 +defs (overloaded)
59.32 + less_up_def: "(op <<) == (%x1 x2. case Rep_Up(x1) of
59.33 + Inl(y1) => True
59.34 + | Inr(y2) => (case Rep_Up(x2) of Inl(z1) => False
59.35 + | Inr(z2) => y2<<z2))"
59.36 +
59.37 +lemma Abs_Up_inverse2: "Rep_Up (Abs_Up y) = y"
59.38 +apply (simp (no_asm) add: Up_def Abs_Up_inverse)
59.39 +done
59.40 +
59.41 +lemma Exh_Up: "z = Abs_Up(Inl ()) | (? x. z = Iup x)"
59.42 +apply (unfold Iup_def)
59.43 +apply (rule Rep_Up_inverse [THEN subst])
59.44 +apply (rule_tac s = "Rep_Up z" in sumE)
59.45 +apply (rule disjI1)
59.46 +apply (rule_tac f = "Abs_Up" in arg_cong)
59.47 +apply (rule unit_eq [THEN subst])
59.48 +apply assumption
59.49 +apply (rule disjI2)
59.50 +apply (rule exI)
59.51 +apply (rule_tac f = "Abs_Up" in arg_cong)
59.52 +apply assumption
59.53 +done
59.54 +
59.55 +lemma inj_Abs_Up: "inj(Abs_Up)"
59.56 +apply (rule inj_on_inverseI)
59.57 +apply (rule Abs_Up_inverse2)
59.58 +done
59.59 +
59.60 +lemma inj_Rep_Up: "inj(Rep_Up)"
59.61 +apply (rule inj_on_inverseI)
59.62 +apply (rule Rep_Up_inverse)
59.63 +done
59.64 +
59.65 +lemma inject_Iup: "Iup x=Iup y ==> x=y"
59.66 +apply (unfold Iup_def)
59.67 +apply (rule inj_Inr [THEN injD])
59.68 +apply (rule inj_Abs_Up [THEN injD])
59.69 +apply assumption
59.70 +done
59.71 +
59.72 +declare inject_Iup [dest!]
59.73 +
59.74 +lemma defined_Iup: "Iup x~=Abs_Up(Inl ())"
59.75 +apply (unfold Iup_def)
59.76 +apply (rule notI)
59.77 +apply (rule notE)
59.78 +apply (rule Inl_not_Inr)
59.79 +apply (rule sym)
59.80 +apply (erule inj_Abs_Up [THEN injD])
59.81 +done
59.82 +
59.83 +
59.84 +lemma upE: "[| p=Abs_Up(Inl ()) ==> Q; !!x. p=Iup(x)==>Q|] ==>Q"
59.85 +apply (rule Exh_Up [THEN disjE])
59.86 +apply fast
59.87 +apply (erule exE)
59.88 +apply fast
59.89 +done
59.90 +
59.91 +lemma Ifup1: "Ifup(f)(Abs_Up(Inl ()))=UU"
59.92 +apply (unfold Ifup_def)
59.93 +apply (subst Abs_Up_inverse2)
59.94 +apply (subst sum_case_Inl)
59.95 +apply (rule refl)
59.96 +done
59.97 +
59.98 +lemma Ifup2:
59.99 + "Ifup(f)(Iup(x))=f$x"
59.100 +apply (unfold Ifup_def Iup_def)
59.101 +apply (subst Abs_Up_inverse2)
59.102 +apply (subst sum_case_Inr)
59.103 +apply (rule refl)
59.104 +done
59.105 +
59.106 +lemmas Up0_ss = Ifup1 Ifup2
59.107 +
59.108 +declare Ifup1 [simp] Ifup2 [simp]
59.109 +
59.110 +lemma less_up1a:
59.111 + "Abs_Up(Inl ())<< z"
59.112 +apply (unfold less_up_def)
59.113 +apply (subst Abs_Up_inverse2)
59.114 +apply (subst sum_case_Inl)
59.115 +apply (rule TrueI)
59.116 +done
59.117 +
59.118 +lemma less_up1b:
59.119 + "~(Iup x) << (Abs_Up(Inl ()))"
59.120 +apply (unfold Iup_def less_up_def)
59.121 +apply (rule notI)
59.122 +apply (rule iffD1)
59.123 +prefer 2 apply (assumption)
59.124 +apply (subst Abs_Up_inverse2)
59.125 +apply (subst Abs_Up_inverse2)
59.126 +apply (subst sum_case_Inr)
59.127 +apply (subst sum_case_Inl)
59.128 +apply (rule refl)
59.129 +done
59.130 +
59.131 +lemma less_up1c:
59.132 + "(Iup x) << (Iup y)=(x<<y)"
59.133 +apply (unfold Iup_def less_up_def)
59.134 +apply (subst Abs_Up_inverse2)
59.135 +apply (subst Abs_Up_inverse2)
59.136 +apply (subst sum_case_Inr)
59.137 +apply (subst sum_case_Inr)
59.138 +apply (rule refl)
59.139 +done
59.140 +
59.141 +declare less_up1a [iff] less_up1b [iff] less_up1c [iff]
59.142 +
59.143 +lemma refl_less_up: "(p::'a u) << p"
59.144 +apply (rule_tac p = "p" in upE)
59.145 +apply auto
59.146 +done
59.147 +
59.148 +lemma antisym_less_up: "[|(p1::'a u) << p2;p2 << p1|] ==> p1=p2"
59.149 +apply (rule_tac p = "p1" in upE)
59.150 +apply simp
59.151 +apply (rule_tac p = "p2" in upE)
59.152 +apply (erule sym)
59.153 +apply simp
59.154 +apply (rule_tac p = "p2" in upE)
59.155 +apply simp
59.156 +apply simp
59.157 +apply (drule antisym_less, assumption)
59.158 +apply simp
59.159 +done
59.160 +
59.161 +lemma trans_less_up: "[|(p1::'a u) << p2;p2 << p3|] ==> p1 << p3"
59.162 +apply (rule_tac p = "p1" in upE)
59.163 +apply simp
59.164 +apply (rule_tac p = "p2" in upE)
59.165 +apply simp
59.166 +apply (rule_tac p = "p3" in upE)
59.167 +apply auto
59.168 +apply (blast intro: trans_less)
59.169 +done
59.170 +
59.171 +(* Class Instance u::(pcpo)po *)
59.172 +
59.173 +instance u :: (pcpo)po
59.174 +apply (intro_classes)
59.175 +apply (rule refl_less_up)
59.176 +apply (rule antisym_less_up, assumption+)
59.177 +apply (rule trans_less_up, assumption+)
59.178 +done
59.179 +
59.180 +(* for compatibility with old HOLCF-Version *)
59.181 +lemma inst_up_po: "(op <<)=(%x1 x2. case Rep_Up(x1) of
59.182 + Inl(y1) => True
59.183 + | Inr(y2) => (case Rep_Up(x2) of Inl(z1) => False
59.184 + | Inr(z2) => y2<<z2))"
59.185 +apply (fold less_up_def)
59.186 +apply (rule refl)
59.187 +done
59.188 +
59.189 +(* -------------------------------------------------------------------------*)
59.190 +(* type ('a)u is pointed *)
59.191 +(* ------------------------------------------------------------------------ *)
59.192 +
59.193 +lemma minimal_up: "Abs_Up(Inl ()) << z"
59.194 +apply (simp (no_asm) add: less_up1a)
59.195 +done
59.196 +
59.197 +lemmas UU_up_def = minimal_up [THEN minimal2UU, symmetric, standard]
59.198 +
59.199 +lemma least_up: "EX x::'a u. ALL y. x<<y"
59.200 +apply (rule_tac x = "Abs_Up (Inl ())" in exI)
59.201 +apply (rule minimal_up [THEN allI])
59.202 +done
59.203 +
59.204 +(* -------------------------------------------------------------------------*)
59.205 +(* access to less_up in class po *)
59.206 +(* ------------------------------------------------------------------------ *)
59.207 +
59.208 +lemma less_up2b: "~ Iup(x) << Abs_Up(Inl ())"
59.209 +apply (simp (no_asm) add: less_up1b)
59.210 +done
59.211 +
59.212 +lemma less_up2c: "(Iup(x)<<Iup(y)) = (x<<y)"
59.213 +apply (simp (no_asm) add: less_up1c)
59.214 +done
59.215 +
59.216 +(* ------------------------------------------------------------------------ *)
59.217 +(* Iup and Ifup are monotone *)
59.218 +(* ------------------------------------------------------------------------ *)
59.219 +
59.220 +lemma monofun_Iup: "monofun(Iup)"
59.221 +
59.222 +apply (unfold monofun)
59.223 +apply (intro strip)
59.224 +apply (erule less_up2c [THEN iffD2])
59.225 +done
59.226 +
59.227 +lemma monofun_Ifup1: "monofun(Ifup)"
59.228 +apply (unfold monofun)
59.229 +apply (intro strip)
59.230 +apply (rule less_fun [THEN iffD2])
59.231 +apply (intro strip)
59.232 +apply (rule_tac p = "xa" in upE)
59.233 +apply simp
59.234 +apply simp
59.235 +apply (erule monofun_cfun_fun)
59.236 +done
59.237 +
59.238 +lemma monofun_Ifup2: "monofun(Ifup(f))"
59.239 +apply (unfold monofun)
59.240 +apply (intro strip)
59.241 +apply (rule_tac p = "x" in upE)
59.242 +apply simp
59.243 +apply simp
59.244 +apply (rule_tac p = "y" in upE)
59.245 +apply simp
59.246 +apply simp
59.247 +apply (erule monofun_cfun_arg)
59.248 +done
59.249 +
59.250 +(* ------------------------------------------------------------------------ *)
59.251 +(* Some kind of surjectivity lemma *)
59.252 +(* ------------------------------------------------------------------------ *)
59.253 +
59.254 +lemma up_lemma1: "z=Iup(x) ==> Iup(Ifup(LAM x. x)(z)) = z"
59.255 +apply simp
59.256 +done
59.257 +
59.258 +(* ------------------------------------------------------------------------ *)
59.259 +(* ('a)u is a cpo *)
59.260 +(* ------------------------------------------------------------------------ *)
59.261 +
59.262 +lemma lub_up1a: "[|chain(Y);EX i x. Y(i)=Iup(x)|]
59.263 + ==> range(Y) <<| Iup(lub(range(%i.(Ifup (LAM x. x) (Y(i))))))"
59.264 +apply (rule is_lubI)
59.265 +apply (rule ub_rangeI)
59.266 +apply (rule_tac p = "Y (i) " in upE)
59.267 +apply (rule_tac s = "Abs_Up (Inl ())" and t = "Y (i) " in subst)
59.268 +apply (erule sym)
59.269 +apply (rule minimal_up)
59.270 +apply (rule_tac t = "Y (i) " in up_lemma1 [THEN subst])
59.271 +apply assumption
59.272 +apply (rule less_up2c [THEN iffD2])
59.273 +apply (rule is_ub_thelub)
59.274 +apply (erule monofun_Ifup2 [THEN ch2ch_monofun])
59.275 +apply (rule_tac p = "u" in upE)
59.276 +apply (erule exE)
59.277 +apply (erule exE)
59.278 +apply (rule_tac P = "Y (i) <<Abs_Up (Inl ())" in notE)
59.279 +apply (rule_tac s = "Iup (x) " and t = "Y (i) " in ssubst)
59.280 +apply assumption
59.281 +apply (rule less_up2b)
59.282 +apply (erule subst)
59.283 +apply (erule ub_rangeD)
59.284 +apply (rule_tac t = "u" in up_lemma1 [THEN subst])
59.285 +apply assumption
59.286 +apply (rule less_up2c [THEN iffD2])
59.287 +apply (rule is_lub_thelub)
59.288 +apply (erule monofun_Ifup2 [THEN ch2ch_monofun])
59.289 +apply (erule monofun_Ifup2 [THEN ub2ub_monofun])
59.290 +done
59.291 +
59.292 +lemma lub_up1b: "[|chain(Y); ALL i x. Y(i)~=Iup(x)|] ==> range(Y) <<| Abs_Up (Inl ())"
59.293 +apply (rule is_lubI)
59.294 +apply (rule ub_rangeI)
59.295 +apply (rule_tac p = "Y (i) " in upE)
59.296 +apply (rule_tac s = "Abs_Up (Inl ())" and t = "Y (i) " in ssubst)
59.297 +apply assumption
59.298 +apply (rule refl_less)
59.299 +apply (rule notE)
59.300 +apply (drule spec)
59.301 +apply (drule spec)
59.302 +apply assumption
59.303 +apply assumption
59.304 +apply (rule minimal_up)
59.305 +done
59.306 +
59.307 +lemmas thelub_up1a = lub_up1a [THEN thelubI, standard]
59.308 +(*
59.309 +[| chain ?Y1; EX i x. ?Y1 i = Iup x |] ==>
59.310 + lub (range ?Y1) = Iup (lub (range (%i. Iup (LAM x. x) (?Y1 i))))
59.311 +*)
59.312 +
59.313 +lemmas thelub_up1b = lub_up1b [THEN thelubI, standard]
59.314 +(*
59.315 +[| chain ?Y1; ! i x. ?Y1 i ~= Iup x |] ==>
59.316 + lub (range ?Y1) = UU_up
59.317 +*)
59.318 +
59.319 +lemma cpo_up: "chain(Y::nat=>('a)u) ==> EX x. range(Y) <<|x"
59.320 +apply (rule disjE)
59.321 +apply (rule_tac [2] exI)
59.322 +apply (erule_tac [2] lub_up1a)
59.323 +prefer 2 apply (assumption)
59.324 +apply (rule_tac [2] exI)
59.325 +apply (erule_tac [2] lub_up1b)
59.326 +prefer 2 apply (assumption)
59.327 +apply fast
59.328 +done
59.329 +
59.330 +(* Class instance of ('a)u for class pcpo *)
59.331 +
59.332 +instance u :: (pcpo)pcpo
59.333 +apply (intro_classes)
59.334 +apply (erule cpo_up)
59.335 +apply (rule least_up)
59.336 +done
59.337 +
59.338 +constdefs
59.339 + up :: "'a -> ('a)u"
59.340 + "up == (LAM x. Iup(x))"
59.341 + fup :: "('a->'c)-> ('a)u -> 'c"
59.342 + "fup == (LAM f p. Ifup(f)(p))"
59.343 +
59.344 +translations
59.345 +"case l of up$x => t1" == "fup$(LAM x. t1)$l"
59.346 +
59.347 +(* for compatibility with old HOLCF-Version *)
59.348 +lemma inst_up_pcpo: "UU = Abs_Up(Inl ())"
59.349 +apply (simp add: UU_def UU_up_def)
59.350 +done
59.351 +
59.352 +(* -------------------------------------------------------------------------*)
59.353 +(* some lemmas restated for class pcpo *)
59.354 +(* ------------------------------------------------------------------------ *)
59.355 +
59.356 +lemma less_up3b: "~ Iup(x) << UU"
59.357 +apply (subst inst_up_pcpo)
59.358 +apply (rule less_up2b)
59.359 +done
59.360 +
59.361 +lemma defined_Iup2: "Iup(x) ~= UU"
59.362 +apply (subst inst_up_pcpo)
59.363 +apply (rule defined_Iup)
59.364 +done
59.365 +declare defined_Iup2 [iff]
59.366 +
59.367 +(* ------------------------------------------------------------------------ *)
59.368 +(* continuity for Iup *)
59.369 +(* ------------------------------------------------------------------------ *)
59.370 +
59.371 +lemma contlub_Iup: "contlub(Iup)"
59.372 +apply (rule contlubI)
59.373 +apply (intro strip)
59.374 +apply (rule trans)
59.375 +apply (rule_tac [2] thelub_up1a [symmetric])
59.376 +prefer 3 apply fast
59.377 +apply (erule_tac [2] monofun_Iup [THEN ch2ch_monofun])
59.378 +apply (rule_tac f = "Iup" in arg_cong)
59.379 +apply (rule lub_equal)
59.380 +apply assumption
59.381 +apply (rule monofun_Ifup2 [THEN ch2ch_monofun])
59.382 +apply (erule monofun_Iup [THEN ch2ch_monofun])
59.383 +apply simp
59.384 +done
59.385 +
59.386 +lemma cont_Iup: "cont(Iup)"
59.387 +apply (rule monocontlub2cont)
59.388 +apply (rule monofun_Iup)
59.389 +apply (rule contlub_Iup)
59.390 +done
59.391 +declare cont_Iup [iff]
59.392 +
59.393 +(* ------------------------------------------------------------------------ *)
59.394 +(* continuity for Ifup *)
59.395 +(* ------------------------------------------------------------------------ *)
59.396 +
59.397 +lemma contlub_Ifup1: "contlub(Ifup)"
59.398 +apply (rule contlubI)
59.399 +apply (intro strip)
59.400 +apply (rule trans)
59.401 +apply (rule_tac [2] thelub_fun [symmetric])
59.402 +apply (erule_tac [2] monofun_Ifup1 [THEN ch2ch_monofun])
59.403 +apply (rule ext)
59.404 +apply (rule_tac p = "x" in upE)
59.405 +apply simp
59.406 +apply (rule lub_const [THEN thelubI, symmetric])
59.407 +apply simp
59.408 +apply (erule contlub_cfun_fun)
59.409 +done
59.410 +
59.411 +
59.412 +lemma contlub_Ifup2: "contlub(Ifup(f))"
59.413 +apply (rule contlubI)
59.414 +apply (intro strip)
59.415 +apply (rule disjE)
59.416 +defer 1
59.417 +apply (subst thelub_up1a)
59.418 +apply assumption
59.419 +apply assumption
59.420 +apply simp
59.421 +prefer 2
59.422 +apply (subst thelub_up1b)
59.423 +apply assumption
59.424 +apply assumption
59.425 +apply simp
59.426 +apply (rule chain_UU_I_inverse [symmetric])
59.427 +apply (rule allI)
59.428 +apply (rule_tac p = "Y(i)" in upE)
59.429 +apply simp
59.430 +apply simp
59.431 +apply (subst contlub_cfun_arg)
59.432 +apply (erule monofun_Ifup2 [THEN ch2ch_monofun])
59.433 +apply (rule lub_equal2)
59.434 +apply (rule_tac [2] monofun_Rep_CFun2 [THEN ch2ch_monofun])
59.435 +apply (erule_tac [2] monofun_Ifup2 [THEN ch2ch_monofun])
59.436 +apply (erule_tac [2] monofun_Ifup2 [THEN ch2ch_monofun])
59.437 +apply (rule chain_mono2 [THEN exE])
59.438 +prefer 2 apply (assumption)
59.439 +apply (erule exE)
59.440 +apply (erule exE)
59.441 +apply (rule exI)
59.442 +apply (rule_tac s = "Iup (x) " and t = "Y (i) " in ssubst)
59.443 +apply assumption
59.444 +apply (rule defined_Iup2)
59.445 +apply (rule exI)
59.446 +apply (intro strip)
59.447 +apply (rule_tac p = "Y (i) " in upE)
59.448 +prefer 2 apply simp
59.449 +apply (rule_tac P = "Y (i) = UU" in notE)
59.450 +apply fast
59.451 +apply (subst inst_up_pcpo)
59.452 +apply assumption
59.453 +apply fast
59.454 +done
59.455 +
59.456 +lemma cont_Ifup1: "cont(Ifup)"
59.457 +apply (rule monocontlub2cont)
59.458 +apply (rule monofun_Ifup1)
59.459 +apply (rule contlub_Ifup1)
59.460 +done
59.461 +
59.462 +lemma cont_Ifup2: "cont(Ifup(f))"
59.463 +apply (rule monocontlub2cont)
59.464 +apply (rule monofun_Ifup2)
59.465 +apply (rule contlub_Ifup2)
59.466 +done
59.467 +
59.468 +
59.469 +(* ------------------------------------------------------------------------ *)
59.470 +(* continuous versions of lemmas for ('a)u *)
59.471 +(* ------------------------------------------------------------------------ *)
59.472 +
59.473 +lemma Exh_Up1: "z = UU | (EX x. z = up$x)"
59.474 +
59.475 +apply (unfold up_def)
59.476 +apply simp
59.477 +apply (subst inst_up_pcpo)
59.478 +apply (rule Exh_Up)
59.479 +done
59.480 +
59.481 +lemma inject_up: "up$x=up$y ==> x=y"
59.482 +apply (unfold up_def)
59.483 +apply (rule inject_Iup)
59.484 +apply auto
59.485 +done
59.486 +
59.487 +lemma defined_up: " up$x ~= UU"
59.488 +apply (unfold up_def)
59.489 +apply auto
59.490 +done
59.491 +
59.492 +lemma upE1:
59.493 + "[| p=UU ==> Q; !!x. p=up$x==>Q|] ==>Q"
59.494 +apply (unfold up_def)
59.495 +apply (rule upE)
59.496 +apply (simp only: inst_up_pcpo)
59.497 +apply fast
59.498 +apply simp
59.499 +done
59.500 +
59.501 +lemmas up_conts = cont_lemmas1 cont_Iup cont_Ifup1 cont_Ifup2 cont2cont_CF1L
59.502 +
59.503 +lemma fup1: "fup$f$UU=UU"
59.504 +apply (unfold up_def fup_def)
59.505 +apply (subst inst_up_pcpo)
59.506 +apply (subst beta_cfun)
59.507 +apply (intro up_conts)
59.508 +apply (subst beta_cfun)
59.509 +apply (rule cont_Ifup2)
59.510 +apply simp
59.511 +done
59.512 +
59.513 +lemma fup2: "fup$f$(up$x)=f$x"
59.514 +apply (unfold up_def fup_def)
59.515 +apply (simplesubst beta_cfun)
59.516 +apply (rule cont_Iup)
59.517 +apply (subst beta_cfun)
59.518 +apply (intro up_conts)
59.519 +apply (subst beta_cfun)
59.520 +apply (rule cont_Ifup2)
59.521 +apply simp
59.522 +done
59.523 +
59.524 +lemma less_up4b: "~ up$x << UU"
59.525 +apply (unfold up_def fup_def)
59.526 +apply simp
59.527 +apply (rule less_up3b)
59.528 +done
59.529 +
59.530 +lemma less_up4c:
59.531 + "(up$x << up$y) = (x<<y)"
59.532 +apply (unfold up_def fup_def)
59.533 +apply simp
59.534 +done
59.535 +
59.536 +lemma thelub_up2a:
59.537 +"[| chain(Y); EX i x. Y(i) = up$x |] ==>
59.538 + lub(range(Y)) = up$(lub(range(%i. fup$(LAM x. x)$(Y i))))"
59.539 +apply (unfold up_def fup_def)
59.540 +apply (subst beta_cfun)
59.541 +apply (rule cont_Iup)
59.542 +apply (subst beta_cfun)
59.543 +apply (intro up_conts)
59.544 +apply (subst beta_cfun [THEN ext])
59.545 +apply (rule cont_Ifup2)
59.546 +apply (rule thelub_up1a)
59.547 +apply assumption
59.548 +apply (erule exE)
59.549 +apply (erule exE)
59.550 +apply (rule exI)
59.551 +apply (rule exI)
59.552 +apply (erule box_equals)
59.553 +apply (rule refl)
59.554 +apply simp
59.555 +done
59.556 +
59.557 +
59.558 +
59.559 +lemma thelub_up2b:
59.560 +"[| chain(Y); ! i x. Y(i) ~= up$x |] ==> lub(range(Y)) = UU"
59.561 +apply (unfold up_def fup_def)
59.562 +apply (subst inst_up_pcpo)
59.563 +apply (rule thelub_up1b)
59.564 +apply assumption
59.565 +apply (intro strip)
59.566 +apply (drule spec)
59.567 +apply (drule spec)
59.568 +apply simp
59.569 +done
59.570 +
59.571 +
59.572 +lemma up_lemma2: "(EX x. z = up$x) = (z~=UU)"
59.573 +apply (rule iffI)
59.574 +apply (erule exE)
59.575 +apply simp
59.576 +apply (rule defined_up)
59.577 +apply (rule_tac p = "z" in upE1)
59.578 +apply (erule notE)
59.579 +apply assumption
59.580 +apply (erule exI)
59.581 +done
59.582 +
59.583 +
59.584 +lemma thelub_up2a_rev: "[| chain(Y); lub(range(Y)) = up$x |] ==> EX i x. Y(i) = up$x"
59.585 +apply (rule exE)
59.586 +apply (rule chain_UU_I_inverse2)
59.587 +apply (rule up_lemma2 [THEN iffD1])
59.588 +apply (erule exI)
59.589 +apply (rule exI)
59.590 +apply (rule up_lemma2 [THEN iffD2])
59.591 +apply assumption
59.592 +done
59.593 +
59.594 +lemma thelub_up2b_rev: "[| chain(Y); lub(range(Y)) = UU |] ==> ! i x. Y(i) ~= up$x"
59.595 +apply (blast dest!: chain_UU_I [THEN spec] exI [THEN up_lemma2 [THEN iffD1]])
59.596 +done
59.597 +
59.598 +
59.599 +lemma thelub_up3: "chain(Y) ==> lub(range(Y)) = UU |
59.600 + lub(range(Y)) = up$(lub(range(%i. fup$(LAM x. x)$(Y i))))"
59.601 +apply (rule disjE)
59.602 +apply (rule_tac [2] disjI1)
59.603 +apply (rule_tac [2] thelub_up2b)
59.604 +prefer 2 apply (assumption)
59.605 +prefer 2 apply (assumption)
59.606 +apply (rule_tac [2] disjI2)
59.607 +apply (rule_tac [2] thelub_up2a)
59.608 +prefer 2 apply (assumption)
59.609 +prefer 2 apply (assumption)
59.610 +apply fast
59.611 +done
59.612 +
59.613 +lemma fup3: "fup$up$x=x"
59.614 +apply (rule_tac p = "x" in upE1)
59.615 +apply (simp add: fup1 fup2)
59.616 +apply (simp add: fup1 fup2)
59.617 +done
59.618 +
59.619 +(* ------------------------------------------------------------------------ *)
59.620 +(* install simplifier for ('a)u *)
59.621 +(* ------------------------------------------------------------------------ *)
59.622 +
59.623 +declare fup1 [simp] fup2 [simp] defined_up [simp]
59.624 +
59.625 +end
59.626 +
59.627 +
59.628 +
60.1 --- a/src/HOLCF/Up1.ML Fri Mar 04 18:53:46 2005 +0100
60.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
60.3 @@ -1,144 +0,0 @@
60.4 -(* Title: HOLCF/Up1.ML
60.5 - ID: $Id$
60.6 - Author: Franz Regensburger
60.7 -
60.8 -Lifting.
60.9 -*)
60.10 -
60.11 -Goal "Rep_Up (Abs_Up y) = y";
60.12 -by (simp_tac (simpset() addsimps [Up_def,Abs_Up_inverse]) 1);
60.13 -qed "Abs_Up_inverse2";
60.14 -
60.15 -Goalw [Iup_def] "z = Abs_Up(Inl ()) | (? x. z = Iup x)";
60.16 -by (rtac (Rep_Up_inverse RS subst) 1);
60.17 -by (res_inst_tac [("s","Rep_Up z")] sumE 1);
60.18 -by (rtac disjI1 1);
60.19 -by (res_inst_tac [("f","Abs_Up")] arg_cong 1);
60.20 -by (rtac (unit_eq RS subst) 1);
60.21 -by (atac 1);
60.22 -by (rtac disjI2 1);
60.23 -by (rtac exI 1);
60.24 -by (res_inst_tac [("f","Abs_Up")] arg_cong 1);
60.25 -by (atac 1);
60.26 -qed "Exh_Up";
60.27 -
60.28 -Goal "inj(Abs_Up)";
60.29 -by (rtac inj_inverseI 1);
60.30 -by (rtac Abs_Up_inverse2 1);
60.31 -qed "inj_Abs_Up";
60.32 -
60.33 -Goal "inj(Rep_Up)";
60.34 -by (rtac inj_inverseI 1);
60.35 -by (rtac Rep_Up_inverse 1);
60.36 -qed "inj_Rep_Up";
60.37 -
60.38 -Goalw [Iup_def] "Iup x=Iup y ==> x=y";
60.39 -by (rtac (inj_Inr RS injD) 1);
60.40 -by (rtac (inj_Abs_Up RS injD) 1);
60.41 -by (atac 1);
60.42 -qed "inject_Iup";
60.43 -
60.44 -AddSDs [inject_Iup];
60.45 -
60.46 -Goalw [Iup_def] "Iup x~=Abs_Up(Inl ())";
60.47 -by (rtac notI 1);
60.48 -by (rtac notE 1);
60.49 -by (rtac Inl_not_Inr 1);
60.50 -by (rtac sym 1);
60.51 -by (etac (inj_Abs_Up RS injD) 1);
60.52 -qed "defined_Iup";
60.53 -
60.54 -
60.55 -val prems = Goal "[| p=Abs_Up(Inl ()) ==> Q; !!x. p=Iup(x)==>Q|] ==>Q";
60.56 -by (rtac (Exh_Up RS disjE) 1);
60.57 -by (eresolve_tac prems 1);
60.58 -by (etac exE 1);
60.59 -by (eresolve_tac prems 1);
60.60 -qed "upE";
60.61 -
60.62 -Goalw [Ifup_def] "Ifup(f)(Abs_Up(Inl ()))=UU";
60.63 -by (stac Abs_Up_inverse2 1);
60.64 -by (stac sum_case_Inl 1);
60.65 -by (rtac refl 1);
60.66 -qed "Ifup1";
60.67 -
60.68 -Goalw [Ifup_def,Iup_def]
60.69 - "Ifup(f)(Iup(x))=f$x";
60.70 -by (stac Abs_Up_inverse2 1);
60.71 -by (stac sum_case_Inr 1);
60.72 -by (rtac refl 1);
60.73 -qed "Ifup2";
60.74 -
60.75 -val Up0_ss = (simpset_of Cfun3.thy) delsimps [range_composition]
60.76 - addsimps [Ifup1,Ifup2];
60.77 -
60.78 -Addsimps [Ifup1,Ifup2];
60.79 -
60.80 -Goalw [less_up_def]
60.81 - "Abs_Up(Inl ())<< z";
60.82 -by (stac Abs_Up_inverse2 1);
60.83 -by (stac sum_case_Inl 1);
60.84 -by (rtac TrueI 1);
60.85 -qed "less_up1a";
60.86 -
60.87 -Goalw [Iup_def,less_up_def]
60.88 - "~(Iup x) << (Abs_Up(Inl ()))";
60.89 -by (rtac notI 1);
60.90 -by (rtac iffD1 1);
60.91 -by (atac 2);
60.92 -by (stac Abs_Up_inverse2 1);
60.93 -by (stac Abs_Up_inverse2 1);
60.94 -by (stac sum_case_Inr 1);
60.95 -by (stac sum_case_Inl 1);
60.96 -by (rtac refl 1);
60.97 -qed "less_up1b";
60.98 -
60.99 -Goalw [Iup_def,less_up_def]
60.100 - "(Iup x) << (Iup y)=(x<<y)";
60.101 -by (stac Abs_Up_inverse2 1);
60.102 -by (stac Abs_Up_inverse2 1);
60.103 -by (stac sum_case_Inr 1);
60.104 -by (stac sum_case_Inr 1);
60.105 -by (rtac refl 1);
60.106 -qed "less_up1c";
60.107 -
60.108 -AddIffs [less_up1a, less_up1b, less_up1c];
60.109 -
60.110 -Goal "(p::'a u) << p";
60.111 -by (res_inst_tac [("p","p")] upE 1);
60.112 -by Auto_tac;
60.113 -qed "refl_less_up";
60.114 -
60.115 -Goal "[|(p1::'a u) << p2;p2 << p1|] ==> p1=p2";
60.116 -by (res_inst_tac [("p","p1")] upE 1);
60.117 -by (hyp_subst_tac 1);
60.118 -by (res_inst_tac [("p","p2")] upE 1);
60.119 -by (etac sym 1);
60.120 -by (hyp_subst_tac 1);
60.121 -by (res_inst_tac [("P","(Iup x) << (Abs_Up(Inl ()))")] notE 1);
60.122 -by (rtac less_up1b 1);
60.123 -by (atac 1);
60.124 -by (hyp_subst_tac 1);
60.125 -by (res_inst_tac [("p","p2")] upE 1);
60.126 -by (hyp_subst_tac 1);
60.127 -by (res_inst_tac [("P","(Iup x) << (Abs_Up(Inl ()))")] notE 1);
60.128 -by (rtac less_up1b 1);
60.129 -by (atac 1);
60.130 -by (blast_tac (claset() addIs [arg_cong, antisym_less, less_up1c RS iffD1]) 1);
60.131 -qed "antisym_less_up";
60.132 -
60.133 -Goal "[|(p1::'a u) << p2;p2 << p3|] ==> p1 << p3";
60.134 -by (res_inst_tac [("p","p1")] upE 1);
60.135 -by (hyp_subst_tac 1);
60.136 -by (rtac less_up1a 1);
60.137 -by (hyp_subst_tac 1);
60.138 -by (res_inst_tac [("p","p2")] upE 1);
60.139 -by (hyp_subst_tac 1);
60.140 -by (rtac notE 1);
60.141 -by (rtac less_up1b 1);
60.142 -by (atac 1);
60.143 -by (res_inst_tac [("p","p3")] upE 1);
60.144 -by Auto_tac;
60.145 -by (blast_tac (claset() addIs [trans_less]) 1);
60.146 -qed "trans_less_up";
60.147 -
61.1 --- a/src/HOLCF/Up1.thy Fri Mar 04 18:53:46 2005 +0100
61.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
61.3 @@ -1,27 +0,0 @@
61.4 -(* Title: HOLCF/Up1.thy
61.5 - ID: $Id$
61.6 - Author: Franz Regensburger
61.7 -
61.8 -Lifting.
61.9 -*)
61.10 -
61.11 -Up1 = Cfun3 + Sum_Type + Datatype +
61.12 -
61.13 -(* new type for lifting *)
61.14 -
61.15 -typedef (Up) ('a) "u" = "{x::(unit + 'a).True}"
61.16 -
61.17 -instance u :: (sq_ord)sq_ord
61.18 -
61.19 -consts
61.20 - Iup :: "'a => ('a)u"
61.21 - Ifup :: "('a->'b)=>('a)u => 'b"
61.22 -
61.23 -defs
61.24 - Iup_def "Iup x == Abs_Up(Inr(x))"
61.25 - Ifup_def "Ifup(f)(x)== case Rep_Up(x) of Inl(y) => UU | Inr(z) => f$z"
61.26 - less_up_def "(op <<) == (%x1 x2. case Rep_Up(x1) of
61.27 - Inl(y1) => True
61.28 - | Inr(y2) => (case Rep_Up(x2) of Inl(z1) => False
61.29 - | Inr(z2) => y2<<z2))"
61.30 -end
62.1 --- a/src/HOLCF/Up2.ML Fri Mar 04 18:53:46 2005 +0100
62.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
62.3 @@ -1,160 +0,0 @@
62.4 -(* Title: HOLCF/Up2.ML
62.5 - ID: $Id$
62.6 - Author: Franz Regensburger
62.7 -
62.8 -Class Instance u::(pcpo)po
62.9 -*)
62.10 -
62.11 -(* for compatibility with old HOLCF-Version *)
62.12 -Goal "(op <<)=(%x1 x2. case Rep_Up(x1) of \
62.13 -\ Inl(y1) => True \
62.14 -\ | Inr(y2) => (case Rep_Up(x2) of Inl(z1) => False \
62.15 -\ | Inr(z2) => y2<<z2))";
62.16 -by (fold_goals_tac [less_up_def]);
62.17 -by (rtac refl 1);
62.18 -qed "inst_up_po";
62.19 -
62.20 -(* -------------------------------------------------------------------------*)
62.21 -(* type ('a)u is pointed *)
62.22 -(* ------------------------------------------------------------------------ *)
62.23 -
62.24 -Goal "Abs_Up(Inl ()) << z";
62.25 -by (simp_tac (simpset() addsimps [less_up1a]) 1);
62.26 -qed "minimal_up";
62.27 -
62.28 -bind_thm ("UU_up_def",minimal_up RS minimal2UU RS sym);
62.29 -
62.30 -Goal "EX x::'a u. ALL y. x<<y";
62.31 -by (res_inst_tac [("x","Abs_Up(Inl ())")] exI 1);
62.32 -by (rtac (minimal_up RS allI) 1);
62.33 -qed "least_up";
62.34 -
62.35 -(* -------------------------------------------------------------------------*)
62.36 -(* access to less_up in class po *)
62.37 -(* ------------------------------------------------------------------------ *)
62.38 -
62.39 -Goal "~ Iup(x) << Abs_Up(Inl ())";
62.40 -by (simp_tac (simpset() addsimps [less_up1b]) 1);
62.41 -qed "less_up2b";
62.42 -
62.43 -Goal "(Iup(x)<<Iup(y)) = (x<<y)";
62.44 -by (simp_tac (simpset() addsimps [less_up1c]) 1);
62.45 -qed "less_up2c";
62.46 -
62.47 -(* ------------------------------------------------------------------------ *)
62.48 -(* Iup and Ifup are monotone *)
62.49 -(* ------------------------------------------------------------------------ *)
62.50 -
62.51 -Goalw [monofun] "monofun(Iup)";
62.52 -by (strip_tac 1);
62.53 -by (etac (less_up2c RS iffD2) 1);
62.54 -qed "monofun_Iup";
62.55 -
62.56 -Goalw [monofun] "monofun(Ifup)";
62.57 -by (strip_tac 1);
62.58 -by (rtac (less_fun RS iffD2) 1);
62.59 -by (strip_tac 1);
62.60 -by (res_inst_tac [("p","xa")] upE 1);
62.61 -by (asm_simp_tac Up0_ss 1);
62.62 -by (asm_simp_tac Up0_ss 1);
62.63 -by (etac monofun_cfun_fun 1);
62.64 -qed "monofun_Ifup1";
62.65 -
62.66 -Goalw [monofun] "monofun(Ifup(f))";
62.67 -by (strip_tac 1);
62.68 -by (res_inst_tac [("p","x")] upE 1);
62.69 -by (asm_simp_tac Up0_ss 1);
62.70 -by (asm_simp_tac Up0_ss 1);
62.71 -by (res_inst_tac [("p","y")] upE 1);
62.72 -by (hyp_subst_tac 1);
62.73 -by (rtac notE 1);
62.74 -by (rtac less_up2b 1);
62.75 -by (atac 1);
62.76 -by (asm_simp_tac Up0_ss 1);
62.77 -by (rtac monofun_cfun_arg 1);
62.78 -by (hyp_subst_tac 1);
62.79 -by (etac (less_up2c RS iffD1) 1);
62.80 -qed "monofun_Ifup2";
62.81 -
62.82 -(* ------------------------------------------------------------------------ *)
62.83 -(* SOME kind of surjectivity lemma *)
62.84 -(* ------------------------------------------------------------------------ *)
62.85 -
62.86 -Goal "z=Iup(x) ==> Iup(Ifup(LAM x. x)(z)) = z";
62.87 -by (asm_simp_tac Up0_ss 1);
62.88 -qed "up_lemma1";
62.89 -
62.90 -(* ------------------------------------------------------------------------ *)
62.91 -(* ('a)u is a cpo *)
62.92 -(* ------------------------------------------------------------------------ *)
62.93 -
62.94 -Goal "[|chain(Y);EX i x. Y(i)=Iup(x)|] \
62.95 -\ ==> range(Y) <<| Iup(lub(range(%i.(Ifup (LAM x. x) (Y(i))))))";
62.96 -by (rtac is_lubI 1);
62.97 -by (rtac ub_rangeI 1);
62.98 -by (res_inst_tac [("p","Y(i)")] upE 1);
62.99 -by (res_inst_tac [("s","Abs_Up (Inl ())"),("t","Y(i)")] subst 1);
62.100 -by (etac sym 1);
62.101 -by (rtac minimal_up 1);
62.102 -by (res_inst_tac [("t","Y(i)")] (up_lemma1 RS subst) 1);
62.103 -by (atac 1);
62.104 -by (rtac (less_up2c RS iffD2) 1);
62.105 -by (rtac is_ub_thelub 1);
62.106 -by (etac (monofun_Ifup2 RS ch2ch_monofun) 1);
62.107 -by (strip_tac 1);
62.108 -by (res_inst_tac [("p","u")] upE 1);
62.109 -by (etac exE 1);
62.110 -by (etac exE 1);
62.111 -by (res_inst_tac [("P","Y(i)<<Abs_Up (Inl ())")] notE 1);
62.112 -by (res_inst_tac [("s","Iup(x)"),("t","Y(i)")] ssubst 1);
62.113 -by (atac 1);
62.114 -by (rtac less_up2b 1);
62.115 -by (hyp_subst_tac 1);
62.116 -by (etac ub_rangeD 1);
62.117 -by (res_inst_tac [("t","u")] (up_lemma1 RS subst) 1);
62.118 -by (atac 1);
62.119 -by (rtac (less_up2c RS iffD2) 1);
62.120 -by (rtac is_lub_thelub 1);
62.121 -by (etac (monofun_Ifup2 RS ch2ch_monofun) 1);
62.122 -by (etac (monofun_Ifup2 RS ub2ub_monofun) 1);
62.123 -qed "lub_up1a";
62.124 -
62.125 -Goal "[|chain(Y); ALL i x. Y(i)~=Iup(x)|] ==> range(Y) <<| Abs_Up (Inl ())";
62.126 -by (rtac is_lubI 1);
62.127 -by (rtac ub_rangeI 1);
62.128 -by (res_inst_tac [("p","Y(i)")] upE 1);
62.129 -by (res_inst_tac [("s","Abs_Up (Inl ())"),("t","Y(i)")] ssubst 1);
62.130 -by (atac 1);
62.131 -by (rtac refl_less 1);
62.132 -by (rtac notE 1);
62.133 -by (dtac spec 1);
62.134 -by (dtac spec 1);
62.135 -by (atac 1);
62.136 -by (atac 1);
62.137 -by (strip_tac 1);
62.138 -by (rtac minimal_up 1);
62.139 -qed "lub_up1b";
62.140 -
62.141 -bind_thm ("thelub_up1a", lub_up1a RS thelubI);
62.142 -(*
62.143 -[| chain ?Y1; EX i x. ?Y1 i = Iup x |] ==>
62.144 - lub (range ?Y1) = Iup (lub (range (%i. Iup (LAM x. x) (?Y1 i))))
62.145 -*)
62.146 -
62.147 -bind_thm ("thelub_up1b", lub_up1b RS thelubI);
62.148 -(*
62.149 -[| chain ?Y1; ! i x. ?Y1 i ~= Iup x |] ==>
62.150 - lub (range ?Y1) = UU_up
62.151 -*)
62.152 -
62.153 -Goal "chain(Y::nat=>('a)u) ==> EX x. range(Y) <<|x";
62.154 -by (rtac disjE 1);
62.155 -by (rtac exI 2);
62.156 -by (etac lub_up1a 2);
62.157 -by (atac 2);
62.158 -by (rtac exI 2);
62.159 -by (etac lub_up1b 2);
62.160 -by (atac 2);
62.161 -by (fast_tac HOL_cs 1);
62.162 -qed "cpo_up";
62.163 -
63.1 --- a/src/HOLCF/Up2.thy Fri Mar 04 18:53:46 2005 +0100
63.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
63.3 @@ -1,15 +0,0 @@
63.4 -(* Title: HOLCF/Up2.thy
63.5 - ID: $Id$
63.6 - Author: Franz Regensburger
63.7 -
63.8 -Class Instance u::(pcpo)po
63.9 -*)
63.10 -
63.11 -Up2 = Up1 +
63.12 -
63.13 -instance u :: (pcpo)po (refl_less_up,antisym_less_up,trans_less_up)
63.14 -
63.15 -end
63.16 -
63.17 -
63.18 -
64.1 --- a/src/HOLCF/Up3.ML Fri Mar 04 18:53:46 2005 +0100
64.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
64.3 @@ -1,278 +0,0 @@
64.4 -(* Title: HOLCF/Up3.ML
64.5 - ID: $Id$
64.6 - Author: Franz Regensburger
64.7 -
64.8 -Class instance of ('a)u for class pcpo
64.9 -*)
64.10 -
64.11 -(* for compatibility with old HOLCF-Version *)
64.12 -Goal "UU = Abs_Up(Inl ())";
64.13 -by (simp_tac (HOL_ss addsimps [UU_def,UU_up_def]) 1);
64.14 -qed "inst_up_pcpo";
64.15 -
64.16 -(* -------------------------------------------------------------------------*)
64.17 -(* some lemmas restated for class pcpo *)
64.18 -(* ------------------------------------------------------------------------ *)
64.19 -
64.20 -Goal "~ Iup(x) << UU";
64.21 -by (stac inst_up_pcpo 1);
64.22 -by (rtac less_up2b 1);
64.23 -qed "less_up3b";
64.24 -
64.25 -Goal "Iup(x) ~= UU";
64.26 -by (stac inst_up_pcpo 1);
64.27 -by (rtac defined_Iup 1);
64.28 -qed "defined_Iup2";
64.29 -AddIffs [defined_Iup2];
64.30 -
64.31 -(* ------------------------------------------------------------------------ *)
64.32 -(* continuity for Iup *)
64.33 -(* ------------------------------------------------------------------------ *)
64.34 -
64.35 -Goal "contlub(Iup)";
64.36 -by (rtac contlubI 1);
64.37 -by (strip_tac 1);
64.38 -by (rtac trans 1);
64.39 -by (rtac (thelub_up1a RS sym) 2);
64.40 -by (fast_tac HOL_cs 3);
64.41 -by (etac (monofun_Iup RS ch2ch_monofun) 2);
64.42 -by (res_inst_tac [("f","Iup")] arg_cong 1);
64.43 -by (rtac lub_equal 1);
64.44 -by (atac 1);
64.45 -by (rtac (monofun_Ifup2 RS ch2ch_monofun) 1);
64.46 -by (etac (monofun_Iup RS ch2ch_monofun) 1);
64.47 -by (asm_simp_tac Up0_ss 1);
64.48 -qed "contlub_Iup";
64.49 -
64.50 -Goal "cont(Iup)";
64.51 -by (rtac monocontlub2cont 1);
64.52 -by (rtac monofun_Iup 1);
64.53 -by (rtac contlub_Iup 1);
64.54 -qed "cont_Iup";
64.55 -AddIffs [cont_Iup];
64.56 -
64.57 -(* ------------------------------------------------------------------------ *)
64.58 -(* continuity for Ifup *)
64.59 -(* ------------------------------------------------------------------------ *)
64.60 -
64.61 -Goal "contlub(Ifup)";
64.62 -by (rtac contlubI 1);
64.63 -by (strip_tac 1);
64.64 -by (rtac trans 1);
64.65 -by (rtac (thelub_fun RS sym) 2);
64.66 -by (etac (monofun_Ifup1 RS ch2ch_monofun) 2);
64.67 -by (rtac ext 1);
64.68 -by (res_inst_tac [("p","x")] upE 1);
64.69 -by (asm_simp_tac Up0_ss 1);
64.70 -by (rtac (lub_const RS thelubI RS sym) 1);
64.71 -by (asm_simp_tac Up0_ss 1);
64.72 -by (etac contlub_cfun_fun 1);
64.73 -qed "contlub_Ifup1";
64.74 -
64.75 -
64.76 -Goal "contlub(Ifup(f))";
64.77 -by (rtac contlubI 1);
64.78 -by (strip_tac 1);
64.79 -by (rtac disjE 1);
64.80 -by (stac thelub_up1a 2);
64.81 -by (atac 2);
64.82 -by (atac 2);
64.83 -by (asm_simp_tac Up0_ss 2);
64.84 -by (stac thelub_up1b 3);
64.85 -by (atac 3);
64.86 -by (atac 3);
64.87 -by (fast_tac HOL_cs 1);
64.88 -by (asm_simp_tac Up0_ss 2);
64.89 -by (rtac (chain_UU_I_inverse RS sym) 2);
64.90 -by (rtac allI 2);
64.91 -by (res_inst_tac [("p","Y(i)")] upE 2);
64.92 -by (asm_simp_tac Up0_ss 2);
64.93 -by (rtac notE 2);
64.94 -by (dtac spec 2);
64.95 -by (etac spec 2);
64.96 -by (atac 2);
64.97 -by (stac contlub_cfun_arg 1);
64.98 -by (etac (monofun_Ifup2 RS ch2ch_monofun) 1);
64.99 -by (rtac lub_equal2 1);
64.100 -by (rtac (monofun_Rep_CFun2 RS ch2ch_monofun) 2);
64.101 -by (etac (monofun_Ifup2 RS ch2ch_monofun) 2);
64.102 -by (etac (monofun_Ifup2 RS ch2ch_monofun) 2);
64.103 -by (rtac (chain_mono2 RS exE) 1);
64.104 -by (atac 2);
64.105 -by (etac exE 1);
64.106 -by (etac exE 1);
64.107 -by (rtac exI 1);
64.108 -by (res_inst_tac [("s","Iup(x)"),("t","Y(i)")] ssubst 1);
64.109 -by (atac 1);
64.110 -by (rtac defined_Iup2 1);
64.111 -by (rtac exI 1);
64.112 -by (strip_tac 1);
64.113 -by (res_inst_tac [("p","Y(i)")] upE 1);
64.114 -by (asm_simp_tac Up0_ss 2);
64.115 -by (res_inst_tac [("P","Y(i) = UU")] notE 1);
64.116 -by (fast_tac HOL_cs 1);
64.117 -by (stac inst_up_pcpo 1);
64.118 -by (atac 1);
64.119 -qed "contlub_Ifup2";
64.120 -
64.121 -Goal "cont(Ifup)";
64.122 -by (rtac monocontlub2cont 1);
64.123 -by (rtac monofun_Ifup1 1);
64.124 -by (rtac contlub_Ifup1 1);
64.125 -qed "cont_Ifup1";
64.126 -
64.127 -Goal "cont(Ifup(f))";
64.128 -by (rtac monocontlub2cont 1);
64.129 -by (rtac monofun_Ifup2 1);
64.130 -by (rtac contlub_Ifup2 1);
64.131 -qed "cont_Ifup2";
64.132 -
64.133 -
64.134 -(* ------------------------------------------------------------------------ *)
64.135 -(* continuous versions of lemmas for ('a)u *)
64.136 -(* ------------------------------------------------------------------------ *)
64.137 -
64.138 -Goalw [up_def] "z = UU | (EX x. z = up$x)";
64.139 -by (simp_tac (Up0_ss addsimps [cont_Iup]) 1);
64.140 -by (stac inst_up_pcpo 1);
64.141 -by (rtac Exh_Up 1);
64.142 -qed "Exh_Up1";
64.143 -
64.144 -Goalw [up_def] "up$x=up$y ==> x=y";
64.145 -by (rtac inject_Iup 1);
64.146 -by Auto_tac;
64.147 -qed "inject_up";
64.148 -
64.149 -Goalw [up_def] " up$x ~= UU";
64.150 -by Auto_tac;
64.151 -qed "defined_up";
64.152 -
64.153 -val prems = Goalw [up_def]
64.154 - "[| p=UU ==> Q; !!x. p=up$x==>Q|] ==>Q";
64.155 -by (rtac upE 1);
64.156 -by (resolve_tac prems 1);
64.157 -by (etac (inst_up_pcpo RS ssubst) 1);
64.158 -by (resolve_tac (tl prems) 1);
64.159 -by (asm_simp_tac (Up0_ss addsimps [cont_Iup]) 1);
64.160 -qed "upE1";
64.161 -
64.162 -val tac = (simp_tac (simpset() addsimps [cont_Iup,cont_Ifup1,
64.163 - cont_Ifup2,cont2cont_CF1L]) 1);
64.164 -
64.165 -Goalw [up_def,fup_def] "fup$f$UU=UU";
64.166 -by (stac inst_up_pcpo 1);
64.167 -by (stac beta_cfun 1);
64.168 -by tac;
64.169 -by (stac beta_cfun 1);
64.170 -by tac;
64.171 -by (simp_tac (Up0_ss addsimps [cont_Iup,cont_Ifup1,cont_Ifup2]) 1);
64.172 -qed "fup1";
64.173 -
64.174 -Goalw [up_def,fup_def] "fup$f$(up$x)=f$x";
64.175 -by (stac beta_cfun 1);
64.176 -by (rtac cont_Iup 1);
64.177 -by (stac beta_cfun 1);
64.178 -by tac;
64.179 -by (stac beta_cfun 1);
64.180 -by (rtac cont_Ifup2 1);
64.181 -by (simp_tac (Up0_ss addsimps [cont_Iup,cont_Ifup1,cont_Ifup2]) 1);
64.182 -qed "fup2";
64.183 -
64.184 -Goalw [up_def,fup_def] "~ up$x << UU";
64.185 -by (simp_tac (Up0_ss addsimps [cont_Iup]) 1);
64.186 -by (rtac less_up3b 1);
64.187 -qed "less_up4b";
64.188 -
64.189 -Goalw [up_def,fup_def]
64.190 - "(up$x << up$y) = (x<<y)";
64.191 -by (simp_tac (Up0_ss addsimps [cont_Iup]) 1);
64.192 -by (rtac less_up2c 1);
64.193 -qed "less_up4c";
64.194 -
64.195 -Goalw [up_def,fup_def]
64.196 -"[| chain(Y); EX i x. Y(i) = up$x |] ==>\
64.197 -\ lub(range(Y)) = up$(lub(range(%i. fup$(LAM x. x)$(Y i))))";
64.198 -by (stac beta_cfun 1);
64.199 -by tac;
64.200 -by (stac beta_cfun 1);
64.201 -by tac;
64.202 -by (stac (beta_cfun RS ext) 1);
64.203 -by tac;
64.204 -by (rtac thelub_up1a 1);
64.205 -by (atac 1);
64.206 -by (etac exE 1);
64.207 -by (etac exE 1);
64.208 -by (rtac exI 1);
64.209 -by (rtac exI 1);
64.210 -by (etac box_equals 1);
64.211 -by (rtac refl 1);
64.212 -by (simp_tac (Up0_ss addsimps [cont_Iup]) 1);
64.213 -qed "thelub_up2a";
64.214 -
64.215 -
64.216 -
64.217 -Goalw [up_def,fup_def]
64.218 -"[| chain(Y); ! i x. Y(i) ~= up$x |] ==> lub(range(Y)) = UU";
64.219 -by (stac inst_up_pcpo 1);
64.220 -by (rtac thelub_up1b 1);
64.221 -by (atac 1);
64.222 -by (strip_tac 1);
64.223 -by (dtac spec 1);
64.224 -by (dtac spec 1);
64.225 -by (asm_full_simp_tac (Up0_ss addsimps [cont_Iup]) 1);
64.226 -qed "thelub_up2b";
64.227 -
64.228 -
64.229 -Goal "(EX x. z = up$x) = (z~=UU)";
64.230 -by (rtac iffI 1);
64.231 -by (etac exE 1);
64.232 -by (hyp_subst_tac 1);
64.233 -by (rtac defined_up 1);
64.234 -by (res_inst_tac [("p","z")] upE1 1);
64.235 -by (etac notE 1);
64.236 -by (atac 1);
64.237 -by (etac exI 1);
64.238 -qed "up_lemma2";
64.239 -
64.240 -
64.241 -Goal "[| chain(Y); lub(range(Y)) = up$x |] ==> EX i x. Y(i) = up$x";
64.242 -by (rtac exE 1);
64.243 -by (rtac chain_UU_I_inverse2 1);
64.244 -by (rtac (up_lemma2 RS iffD1) 1);
64.245 -by (etac exI 1);
64.246 -by (rtac exI 1);
64.247 -by (rtac (up_lemma2 RS iffD2) 1);
64.248 -by (atac 1);
64.249 -qed "thelub_up2a_rev";
64.250 -
64.251 -Goal "[| chain(Y); lub(range(Y)) = UU |] ==> ! i x. Y(i) ~= up$x";
64.252 -by (blast_tac (claset() addSDs [chain_UU_I RS spec,
64.253 - exI RS (up_lemma2 RS iffD1)]) 1);
64.254 -qed "thelub_up2b_rev";
64.255 -
64.256 -
64.257 -Goal "chain(Y) ==> lub(range(Y)) = UU | \
64.258 -\ lub(range(Y)) = up$(lub(range(%i. fup$(LAM x. x)$(Y i))))";
64.259 -by (rtac disjE 1);
64.260 -by (rtac disjI1 2);
64.261 -by (rtac thelub_up2b 2);
64.262 -by (atac 2);
64.263 -by (atac 2);
64.264 -by (rtac disjI2 2);
64.265 -by (rtac thelub_up2a 2);
64.266 -by (atac 2);
64.267 -by (atac 2);
64.268 -by (fast_tac HOL_cs 1);
64.269 -qed "thelub_up3";
64.270 -
64.271 -Goal "fup$up$x=x";
64.272 -by (res_inst_tac [("p","x")] upE1 1);
64.273 -by (asm_simp_tac ((simpset_of Cfun3.thy) addsimps [fup1,fup2]) 1);
64.274 -by (asm_simp_tac ((simpset_of Cfun3.thy) addsimps [fup1,fup2]) 1);
64.275 -qed "fup3";
64.276 -
64.277 -(* ------------------------------------------------------------------------ *)
64.278 -(* install simplifier for ('a)u *)
64.279 -(* ------------------------------------------------------------------------ *)
64.280 -
64.281 -Addsimps [fup1,fup2,defined_up];
65.1 --- a/src/HOLCF/Up3.thy Fri Mar 04 18:53:46 2005 +0100
65.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
65.3 @@ -1,24 +0,0 @@
65.4 -(* Title: HOLCF/Up3.thy
65.5 - ID: $Id$
65.6 - Author: Franz Regensburger
65.7 -
65.8 -Class instance of ('a)u for class pcpo
65.9 -*)
65.10 -
65.11 -Up3 = Up2 +
65.12 -
65.13 -instance u :: (pcpo)pcpo (least_up,cpo_up)
65.14 -
65.15 -constdefs
65.16 - up :: "'a -> ('a)u"
65.17 - "up == (LAM x. Iup(x))"
65.18 - fup :: "('a->'c)-> ('a)u -> 'c"
65.19 - "fup == (LAM f p. Ifup(f)(p))"
65.20 -
65.21 -translations
65.22 -"case l of up$x => t1" == "fup$(LAM x. t1)$l"
65.23 -
65.24 -end
65.25 -
65.26 -
65.27 -