converted to new-style theories, and combined numbered files
authorhuffman
Fri Mar 04 23:12:36 2005 +0100 (2005-03-04)
changeset 15576efb95d0d01f7
parent 15575 63babb1ee883
child 15577 e16da3068ad6
converted to new-style theories, and combined numbered files
src/HOLCF/Cfun.ML
src/HOLCF/Cfun.thy
src/HOLCF/Cfun1.ML
src/HOLCF/Cfun1.thy
src/HOLCF/Cfun2.ML
src/HOLCF/Cfun2.thy
src/HOLCF/Cfun3.ML
src/HOLCF/Cfun3.thy
src/HOLCF/Cont.thy
src/HOLCF/Cprod.ML
src/HOLCF/Cprod.thy
src/HOLCF/Cprod1.ML
src/HOLCF/Cprod1.thy
src/HOLCF/Cprod2.ML
src/HOLCF/Cprod2.thy
src/HOLCF/Cprod3.ML
src/HOLCF/Cprod3.thy
src/HOLCF/Fix.ML
src/HOLCF/Fix.thy
src/HOLCF/Fun1.ML
src/HOLCF/Fun1.thy
src/HOLCF/Fun2.ML
src/HOLCF/Fun2.thy
src/HOLCF/Fun3.ML
src/HOLCF/Fun3.thy
src/HOLCF/FunCpo.ML
src/HOLCF/FunCpo.thy
src/HOLCF/HOLCF.thy
src/HOLCF/IsaMakefile
src/HOLCF/Lift.thy
src/HOLCF/One.ML
src/HOLCF/One.thy
src/HOLCF/Pcpo.thy
src/HOLCF/Porder.ML
src/HOLCF/Porder.thy
src/HOLCF/Porder0.ML
src/HOLCF/Porder0.thy
src/HOLCF/Sprod.ML
src/HOLCF/Sprod.thy
src/HOLCF/Sprod0.ML
src/HOLCF/Sprod0.thy
src/HOLCF/Sprod1.ML
src/HOLCF/Sprod1.thy
src/HOLCF/Sprod2.ML
src/HOLCF/Sprod2.thy
src/HOLCF/Sprod3.ML
src/HOLCF/Sprod3.thy
src/HOLCF/Ssum.ML
src/HOLCF/Ssum.thy
src/HOLCF/Ssum0.ML
src/HOLCF/Ssum0.thy
src/HOLCF/Ssum1.ML
src/HOLCF/Ssum1.thy
src/HOLCF/Ssum2.ML
src/HOLCF/Ssum2.thy
src/HOLCF/Ssum3.ML
src/HOLCF/Ssum3.thy
src/HOLCF/Up.ML
src/HOLCF/Up.thy
src/HOLCF/Up1.ML
src/HOLCF/Up1.thy
src/HOLCF/Up2.ML
src/HOLCF/Up2.thy
src/HOLCF/Up3.ML
src/HOLCF/Up3.thy
     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 -
   18.11 -(* ------------------------------------------------------------------------ *)
   18.12 -(* derive inductive properties of iterate from primitive recursion          *)
   18.13 -(* ------------------------------------------------------------------------ *)
   18.14 -
   18.15 -Goal "iterate (Suc n) F x = iterate n F (F$x)";
   18.16 -by (induct_tac "n" 1);
   18.17 -by Auto_tac;  
   18.18 -qed "iterate_Suc2";
   18.19 -
   18.20 -(* ------------------------------------------------------------------------ *)
   18.21 -(* the sequence of function itertaions is a chain                           *)
   18.22 -(* This property is essential since monotonicity of iterate makes no sense  *)
   18.23 -(* ------------------------------------------------------------------------ *)
   18.24 -
   18.25 -Goalw [chain_def]  "x << F$x ==> chain (%i. iterate i F x)";
   18.26 -by (strip_tac 1);
   18.27 -by (induct_tac "i" 1);
   18.28 -by Auto_tac;  
   18.29 -by (etac monofun_cfun_arg 1);
   18.30 -qed "chain_iterate2";
   18.31 -
   18.32 -
   18.33 -Goal "chain (%i. iterate i F UU)";
   18.34 -by (rtac chain_iterate2 1);
   18.35 -by (rtac minimal 1);
   18.36 -qed "chain_iterate";
   18.37 -
   18.38 -
   18.39 -(* ------------------------------------------------------------------------ *)
   18.40 -(* Kleene's fixed point theorems for continuous functions in pointed        *)
   18.41 -(* omega cpo's                                                              *)
   18.42 -(* ------------------------------------------------------------------------ *)
   18.43 -
   18.44 -
   18.45 -Goalw [Ifix_def] "Ifix F =F$(Ifix F)";
   18.46 -by (stac contlub_cfun_arg 1);
   18.47 -by (rtac chain_iterate 1);
   18.48 -by (rtac antisym_less 1);
   18.49 -by (rtac lub_mono 1);
   18.50 -by (rtac chain_iterate 1);
   18.51 -by (rtac ch2ch_Rep_CFunR 1);
   18.52 -by (rtac chain_iterate 1);
   18.53 -by (rtac allI 1);
   18.54 -by (rtac (iterate_Suc RS subst) 1);
   18.55 -by (rtac (chain_iterate RS chainE) 1);
   18.56 -by (rtac is_lub_thelub 1);
   18.57 -by (rtac ch2ch_Rep_CFunR 1);
   18.58 -by (rtac chain_iterate 1);
   18.59 -by (rtac ub_rangeI 1);
   18.60 -by (rtac (iterate_Suc RS subst) 1);
   18.61 -by (rtac is_ub_thelub 1);
   18.62 -by (rtac chain_iterate 1);
   18.63 -qed "Ifix_eq";
   18.64 -
   18.65 -
   18.66 -Goalw [Ifix_def] "F$x=x ==> Ifix(F) << x";
   18.67 -by (rtac is_lub_thelub 1);
   18.68 -by (rtac chain_iterate 1);
   18.69 -by (rtac ub_rangeI 1);
   18.70 -by (strip_tac 1);
   18.71 -by (induct_tac "i" 1);
   18.72 -by (Asm_simp_tac 1);
   18.73 -by (Asm_simp_tac 1);
   18.74 -by (res_inst_tac [("t","x")] subst 1);
   18.75 -by (atac 1);
   18.76 -by (etac monofun_cfun_arg 1);
   18.77 -qed "Ifix_least";
   18.78 -
   18.79 -
   18.80 -(* ------------------------------------------------------------------------ *)
   18.81 -(* monotonicity and continuity of iterate                                   *)
   18.82 -(* ------------------------------------------------------------------------ *)
   18.83 -
   18.84 -Goalw [monofun] "monofun(iterate(i))";
   18.85 -by (strip_tac 1);
   18.86 -by (induct_tac "i" 1);
   18.87 -by (Asm_simp_tac 1);
   18.88 -by (asm_full_simp_tac (simpset() addsimps [less_fun, monofun_cfun]) 1);
   18.89 -qed "monofun_iterate";
   18.90 -
   18.91 -(* ------------------------------------------------------------------------ *)
   18.92 -(* the following lemma uses contlub_cfun which itself is based on a         *)
   18.93 -(* diagonalisation lemma for continuous functions with two arguments.       *)
   18.94 -(* In this special case it is the application function Rep_CFun                 *)
   18.95 -(* ------------------------------------------------------------------------ *)
   18.96 -
   18.97 -Goalw [contlub] "contlub(iterate(i))";
   18.98 -by (strip_tac 1);
   18.99 -by (induct_tac "i" 1);
  18.100 -by (Asm_simp_tac 1);
  18.101 -by (rtac (lub_const RS thelubI RS sym) 1);
  18.102 -by (asm_simp_tac (simpset() delsimps [range_composition]) 1);
  18.103 -by (rtac ext 1);
  18.104 -by (stac thelub_fun 1);
  18.105 -by (rtac chainI 1);
  18.106 -by (rtac (less_fun RS iffD2) 1);
  18.107 -by (rtac allI 1);
  18.108 -by (rtac (chainE) 1);
  18.109 -by (rtac (monofun_Rep_CFun1 RS ch2ch_MF2LR) 1);
  18.110 -by (rtac allI 1);
  18.111 -by (rtac monofun_Rep_CFun2 1);
  18.112 -by (atac 1);
  18.113 -by (rtac ch2ch_fun 1);
  18.114 -by (rtac (monofun_iterate RS ch2ch_monofun) 1);
  18.115 -by (atac 1);
  18.116 -by (stac thelub_fun 1);
  18.117 -by (rtac (monofun_iterate RS ch2ch_monofun) 1);
  18.118 -by (atac 1);
  18.119 -by (rtac contlub_cfun  1);
  18.120 -by (atac 1);
  18.121 -by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun) 1);
  18.122 -qed "contlub_iterate";
  18.123 -
  18.124 -
  18.125 -Goal "cont(iterate(i))";
  18.126 -by (rtac monocontlub2cont 1);
  18.127 -by (rtac monofun_iterate 1);
  18.128 -by (rtac contlub_iterate 1);
  18.129 -qed "cont_iterate";
  18.130 -
  18.131 -(* ------------------------------------------------------------------------ *)
  18.132 -(* a lemma about continuity of iterate in its third argument                *)
  18.133 -(* ------------------------------------------------------------------------ *)
  18.134 -
  18.135 -Goal "monofun(iterate n F)";
  18.136 -by (rtac monofunI 1);
  18.137 -by (strip_tac 1);
  18.138 -by (induct_tac "n" 1);
  18.139 -by (Asm_simp_tac 1);
  18.140 -by (Asm_simp_tac 1);
  18.141 -by (etac monofun_cfun_arg 1);
  18.142 -qed "monofun_iterate2";
  18.143 +(* legacy ML bindings *)
  18.144  
  18.145 -Goal "contlub(iterate n F)";
  18.146 -by (rtac contlubI 1);
  18.147 -by (strip_tac 1);
  18.148 -by (induct_tac "n" 1);
  18.149 -by (Simp_tac 1);
  18.150 -by (Simp_tac 1);
  18.151 -by (res_inst_tac [("t","iterate n F (lub(range(%u. Y u)))"),
  18.152 -                  ("s","lub(range(%i. iterate n F (Y i)))")] ssubst 1);
  18.153 -by (atac 1);
  18.154 -by (rtac contlub_cfun_arg 1);
  18.155 -by (etac (monofun_iterate2 RS ch2ch_monofun) 1);
  18.156 -qed "contlub_iterate2";
  18.157 -
  18.158 -Goal "cont (iterate n F)";
  18.159 -by (rtac monocontlub2cont 1);
  18.160 -by (rtac monofun_iterate2 1);
  18.161 -by (rtac contlub_iterate2 1);
  18.162 -qed "cont_iterate2";
  18.163 -
  18.164 -(* ------------------------------------------------------------------------ *)
  18.165 -(* monotonicity and continuity of Ifix                                      *)
  18.166 -(* ------------------------------------------------------------------------ *)
  18.167 -
  18.168 -Goalw [monofun,Ifix_def] "monofun(Ifix)";
  18.169 -by (strip_tac 1);
  18.170 -by (rtac lub_mono 1);
  18.171 -by (rtac chain_iterate 1);
  18.172 -by (rtac chain_iterate 1);
  18.173 -by (rtac allI 1);
  18.174 -by (rtac (less_fun RS iffD1 RS spec) 1 THEN
  18.175 -    etac (monofun_iterate RS monofunE RS spec RS spec RS mp) 1);
  18.176 -qed "monofun_Ifix";
  18.177 -
  18.178 -(* ------------------------------------------------------------------------ *)
  18.179 -(* since iterate is not monotone in its first argument, special lemmas must *)
  18.180 -(* be derived for lubs in this argument                                     *)
  18.181 -(* ------------------------------------------------------------------------ *)
  18.182 -
  18.183 -Goal   
  18.184 -"chain(Y) ==> chain(%i. lub(range(%ia. iterate ia (Y i) UU)))";
  18.185 -by (rtac chainI 1);
  18.186 -by (strip_tac 1);
  18.187 -by (rtac lub_mono 1);
  18.188 -by (rtac chain_iterate 1);
  18.189 -by (rtac chain_iterate 1);
  18.190 -by (strip_tac 1);
  18.191 -by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun RS chainE) 1);
  18.192 -qed "chain_iterate_lub";
  18.193 -
  18.194 -(* ------------------------------------------------------------------------ *)
  18.195 -(* this exchange lemma is analog to the one for monotone functions          *)
  18.196 -(* observe that monotonicity is not really needed. The propagation of       *)
  18.197 -(* chains is the essential argument which is usually derived from monot.    *)
  18.198 -(* ------------------------------------------------------------------------ *)
  18.199 -
  18.200 -Goal "chain(Y) ==>iterate n (lub(range Y)) y = lub(range(%i. iterate n (Y i) y))";
  18.201 -by (rtac (thelub_fun RS subst) 1);
  18.202 -by (etac (monofun_iterate RS ch2ch_monofun) 1);
  18.203 -by (asm_simp_tac (simpset() addsimps [contlub_iterate RS contlubE]) 1);
  18.204 -qed "contlub_Ifix_lemma1";
  18.205 -
  18.206 +val iterate_0 = thm "iterate_0";
  18.207 +val iterate_Suc = thm "iterate_Suc";
  18.208 +val Ifix_def = thm "Ifix_def";
  18.209 +val fix_def = thm "fix_def";
  18.210 +val adm_def = thm "adm_def";
  18.211 +val admw_def = thm "admw_def";
  18.212 +val iterate_Suc2 = thm "iterate_Suc2";
  18.213 +val chain_iterate2 = thm "chain_iterate2";
  18.214 +val chain_iterate = thm "chain_iterate";
  18.215 +val Ifix_eq = thm "Ifix_eq";
  18.216 +val Ifix_least = thm "Ifix_least";
  18.217 +val monofun_iterate = thm "monofun_iterate";
  18.218 +val contlub_iterate = thm "contlub_iterate";
  18.219 +val cont_iterate = thm "cont_iterate";
  18.220 +val monofun_iterate2 = thm "monofun_iterate2";
  18.221 +val contlub_iterate2 = thm "contlub_iterate2";
  18.222 +val cont_iterate2 = thm "cont_iterate2";
  18.223 +val monofun_Ifix = thm "monofun_Ifix";
  18.224 +val chain_iterate_lub = thm "chain_iterate_lub";
  18.225 +val contlub_Ifix_lemma1 = thm "contlub_Ifix_lemma1";
  18.226 +val ex_lub_iterate = thm "ex_lub_iterate";
  18.227 +val contlub_Ifix = thm "contlub_Ifix";
  18.228 +val cont_Ifix = thm "cont_Ifix";
  18.229 +val fix_eq = thm "fix_eq";
  18.230 +val fix_least = thm "fix_least";
  18.231 +val fix_eqI = thm "fix_eqI";
  18.232 +val fix_eq2 = thm "fix_eq2";
  18.233 +val fix_eq3 = thm "fix_eq3";
  18.234 +val fix_eq4 = thm "fix_eq4";
  18.235 +val fix_eq5 = thm "fix_eq5";
  18.236 +val Ifix_def2 = thm "Ifix_def2";
  18.237 +val fix_def2 = thm "fix_def2";
  18.238 +val admI = thm "admI";
  18.239 +val triv_admI = thm "triv_admI";
  18.240 +val admD = thm "admD";
  18.241 +val admw_def2 = thm "admw_def2";
  18.242 +val def_fix_ind = thm "def_fix_ind";
  18.243 +val adm_impl_admw = thm "adm_impl_admw";
  18.244 +val fix_ind = thm "fix_ind";
  18.245 +val def_fix_ind = thm "def_fix_ind";
  18.246 +val wfix_ind = thm "wfix_ind";
  18.247 +val def_wfix_ind = thm "def_wfix_ind";
  18.248 +val adm_max_in_chain = thm "adm_max_in_chain";
  18.249 +val adm_chfin = thm "adm_chfin";
  18.250 +val adm_chfindom = thm "adm_chfindom";
  18.251 +val admI2 = thm "admI2";
  18.252 +val adm_less = thm "adm_less";
  18.253 +val adm_conj = thm "adm_conj";
  18.254 +val adm_not_free = thm "adm_not_free";
  18.255 +val adm_not_less = thm "adm_not_less";
  18.256 +val adm_all = thm "adm_all";
  18.257 +val adm_all2 = thm "adm_all2";
  18.258 +val adm_subst = thm "adm_subst";
  18.259 +val adm_UU_not_less = thm "adm_UU_not_less";
  18.260 +val adm_not_UU = thm "adm_not_UU";
  18.261 +val adm_eq = thm "adm_eq";
  18.262 +val adm_disj_lemma1 = thm "adm_disj_lemma1";
  18.263 +val adm_disj_lemma2 = thm "adm_disj_lemma2";
  18.264 +val adm_disj_lemma3 = thm "adm_disj_lemma3";
  18.265 +val adm_disj_lemma4 = thm "adm_disj_lemma4";
  18.266 +val adm_disj_lemma5 = thm "adm_disj_lemma5";
  18.267 +val adm_disj_lemma6 = thm "adm_disj_lemma6";
  18.268 +val adm_disj_lemma7 = thm "adm_disj_lemma7";
  18.269 +val adm_disj_lemma8 = thm "adm_disj_lemma8";
  18.270 +val adm_disj_lemma9 = thm "adm_disj_lemma9";
  18.271 +val adm_disj_lemma10 = thm "adm_disj_lemma10";
  18.272 +val adm_disj_lemma12 = thm "adm_disj_lemma12";
  18.273 +val adm_lemma11 = thm "adm_lemma11";
  18.274 +val adm_disj = thm "adm_disj";
  18.275 +val adm_imp = thm "adm_imp";
  18.276 +val adm_iff = thm "adm_iff";
  18.277 +val adm_not_conj = thm "adm_not_conj";
  18.278 +val adm_lemmas = [adm_not_free, adm_imp, adm_disj, adm_eq, adm_not_UU,
  18.279 +        adm_UU_not_less, adm_all2, adm_not_less, adm_not_conj, adm_iff]
  18.280  
  18.281 -Goal  "chain(Y) ==>\
  18.282 -\         lub(range(%i. lub(range(%ia. iterate i (Y ia) UU)))) =\
  18.283 -\         lub(range(%i. lub(range(%ia. iterate ia (Y i) UU))))";
  18.284 -by (rtac antisym_less 1);
  18.285 -by (rtac is_lub_thelub 1);
  18.286 -by (rtac (contlub_Ifix_lemma1 RS ext RS subst) 1);
  18.287 -by (atac 1);
  18.288 -by (rtac chain_iterate 1);
  18.289 -by (rtac ub_rangeI 1);
  18.290 -by (strip_tac 1);
  18.291 -by (rtac lub_mono 1);
  18.292 -by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun) 1);
  18.293 -by (etac chain_iterate_lub 1);
  18.294 -by (strip_tac 1);
  18.295 -by (rtac is_ub_thelub 1);
  18.296 -by (rtac chain_iterate 1);
  18.297 -by (rtac is_lub_thelub 1);
  18.298 -by (etac chain_iterate_lub 1);
  18.299 -by (rtac ub_rangeI 1);
  18.300 -by (strip_tac 1);
  18.301 -by (rtac lub_mono 1);
  18.302 -by (rtac chain_iterate 1);
  18.303 -by (rtac (contlub_Ifix_lemma1 RS ext RS subst) 1);
  18.304 -by (atac 1);
  18.305 -by (rtac chain_iterate 1);
  18.306 -by (strip_tac 1);
  18.307 -by (rtac is_ub_thelub 1);
  18.308 -by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun) 1);
  18.309 -qed "ex_lub_iterate";
  18.310 -
  18.311 -
  18.312 -Goalw [contlub,Ifix_def] "contlub(Ifix)";
  18.313 -by (strip_tac 1);
  18.314 -by (stac (contlub_Ifix_lemma1 RS ext) 1);
  18.315 -by (atac 1);
  18.316 -by (etac ex_lub_iterate 1);
  18.317 -qed "contlub_Ifix";
  18.318 -
  18.319 -
  18.320 -Goal "cont(Ifix)";
  18.321 -by (rtac monocontlub2cont 1);
  18.322 -by (rtac monofun_Ifix 1);
  18.323 -by (rtac contlub_Ifix 1);
  18.324 -qed "cont_Ifix";
  18.325 +structure Fix =
  18.326 +struct
  18.327 +  val thy = the_context ();
  18.328 +  val Ifix_def = Ifix_def;
  18.329 +  val fix_def = fix_def;
  18.330 +  val adm_def = adm_def;
  18.331 +  val admw_def = admw_def;
  18.332 +end;
  18.333  
  18.334 -(* ------------------------------------------------------------------------ *)
  18.335 -(* propagate properties of Ifix to its continuous counterpart               *)
  18.336 -(* ------------------------------------------------------------------------ *)
  18.337 -
  18.338 -Goalw [fix_def] "fix$F = F$(fix$F)";
  18.339 -by (asm_simp_tac (simpset() addsimps [cont_Ifix]) 1);
  18.340 -by (rtac Ifix_eq 1);
  18.341 -qed "fix_eq";
  18.342 -
  18.343 -Goalw [fix_def] "F$x = x ==> fix$F << x";
  18.344 -by (asm_simp_tac (simpset() addsimps [cont_Ifix]) 1);
  18.345 -by (etac Ifix_least 1);
  18.346 -qed "fix_least";
  18.347 -
  18.348 -
  18.349 -Goal
  18.350 -"[| F$x = x; !z. F$z = z --> x << z |] ==> x = fix$F";
  18.351 -by (rtac antisym_less 1);
  18.352 -by (etac allE 1);
  18.353 -by (etac mp 1);
  18.354 -by (rtac (fix_eq RS sym) 1);
  18.355 -by (etac fix_least 1);
  18.356 -qed "fix_eqI";
  18.357 +fun fix_tac3 thm i  = ((rtac trans i) THEN (rtac (thm RS fix_eq3) i));
  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 -
   31.11 -(* ------------------------------------------------------------------------ *)
   31.12 -(* Exhaustion and Elimination for type one                                  *)
   31.13 -(* ------------------------------------------------------------------------ *)
   31.14 -
   31.15 -Goalw [ONE_def] "t=UU | t = ONE";
   31.16 -by (induct_tac "t" 1);
   31.17 -by (Simp_tac 1);
   31.18 -by (Simp_tac 1);
   31.19 -qed "Exh_one";
   31.20 +(* legacy ML bindings *)
   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) =