converted to new-style theories, and combined numbered files
authorhuffman
Fri, 04 Mar 2005 23:12:36 +0100
changeset 15576 efb95d0d01f7
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
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Cfun.ML	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,92 @@
+
+(* legacy ML bindings *)
+
+val less_cfun_def = thm "less_cfun_def";
+val Rep_Cfun = thm "Rep_Cfun";
+val Rep_Cfun_inverse = thm "Rep_Cfun_inverse";
+val Abs_Cfun_inverse = thm "Abs_Cfun_inverse";
+val refl_less_cfun = thm "refl_less_cfun";
+val antisym_less_cfun = thm "antisym_less_cfun";
+val trans_less_cfun = thm "trans_less_cfun";
+val cfun_cong = thm "cfun_cong";
+val cfun_fun_cong = thm "cfun_fun_cong";
+val cfun_arg_cong = thm "cfun_arg_cong";
+val Abs_Cfun_inverse2 = thm "Abs_Cfun_inverse2";
+val Cfunapp2 = thm "Cfunapp2";
+val beta_cfun = thm "beta_cfun";
+val inst_cfun_po = thm "inst_cfun_po";
+val less_cfun = thm "less_cfun";
+val minimal_cfun = thm "minimal_cfun";
+val UU_cfun_def = thm "UU_cfun_def";
+val least_cfun = thm "least_cfun";
+val cont_Rep_CFun2 = thm "cont_Rep_CFun2";
+val monofun_Rep_CFun2 = thm "monofun_Rep_CFun2";
+val contlub_Rep_CFun2 = thm "contlub_Rep_CFun2";
+val cont_cfun_arg = thm "cont_cfun_arg";
+val contlub_cfun_arg = thm "contlub_cfun_arg";
+val monofun_Rep_CFun1 = thm "monofun_Rep_CFun1";
+val monofun_cfun_fun = thm "monofun_cfun_fun";
+val monofun_cfun_arg = thm "monofun_cfun_arg";
+val chain_monofun = thm "chain_monofun";
+val monofun_cfun = thm "monofun_cfun";
+val strictI = thm "strictI";
+val ch2ch_Rep_CFunR = thm "ch2ch_Rep_CFunR";
+val ch2ch_Rep_CFunL = thm "ch2ch_Rep_CFunL";
+val lub_cfun_mono = thm "lub_cfun_mono";
+val ex_lubcfun = thm "ex_lubcfun";
+val cont_lubcfun = thm "cont_lubcfun";
+val lub_cfun = thm "lub_cfun";
+val thelub_cfun = thm "thelub_cfun";
+val cpo_cfun = thm "cpo_cfun";
+val ext_cfun = thm "ext_cfun";
+val semi_monofun_Abs_CFun = thm "semi_monofun_Abs_CFun";
+val less_cfun2 = thm "less_cfun2";
+val Istrictify_def = thm "Istrictify_def";
+val strictify_def = thm "strictify_def";
+val ID_def = thm "ID_def";
+val oo_def = thm "oo_def";
+val inst_cfun_pcpo = thm "inst_cfun_pcpo";
+val contlub_Rep_CFun1 = thm "contlub_Rep_CFun1";
+val cont_Rep_CFun1 = thm "cont_Rep_CFun1";
+val contlub_cfun_fun = thm "contlub_cfun_fun";
+val cont_cfun_fun = thm "cont_cfun_fun";
+val contlub_cfun = thm "contlub_cfun";
+val cont_cfun = thm "cont_cfun";
+val cont2cont_Rep_CFun = thm "cont2cont_Rep_CFun";
+val cont2mono_LAM = thm "cont2mono_LAM";
+val cont2cont_LAM = thm "cont2cont_LAM";
+val cont_lemmas1 = [cont_const, cont_id, cont_Rep_CFun2,
+                    cont2cont_Rep_CFun, cont2cont_LAM];
+val strict_Rep_CFun1 = thm "strict_Rep_CFun1";
+val Istrictify1 = thm "Istrictify1";
+val Istrictify2 = thm "Istrictify2";
+val monofun_Istrictify1 = thm "monofun_Istrictify1";
+val monofun_Istrictify2 = thm "monofun_Istrictify2";
+val contlub_Istrictify1 = thm "contlub_Istrictify1";
+val contlub_Istrictify2 = thm "contlub_Istrictify2";
+val cont_Istrictify1 = thm "cont_Istrictify1";
+val cont_Istrictify2 = thm "cont_Istrictify2";
+val strictify1 = thm "strictify1";
+val strictify2 = thm "strictify2";
+val chfin_Rep_CFunR = thm "chfin_Rep_CFunR";
+val iso_strict = thm "iso_strict";
+val isorep_defined = thm "isorep_defined";
+val isoabs_defined = thm "isoabs_defined";
+val chfin2chfin = thm "chfin2chfin";
+val flat2flat = thm "flat2flat";
+val flat_codom = thm "flat_codom";
+val ID1 = thm "ID1";
+val cfcomp1 = thm "cfcomp1";
+val cfcomp2 = thm "cfcomp2";
+val ID2 = thm "ID2";
+val ID3 = thm "ID3";
+val assoc_oo = thm "assoc_oo";
+
+structure Cfun =
+struct
+  val thy = the_context ();
+  val Istrictify_def = Istrictify_def;
+  val strictify_def = strictify_def;
+  val ID_def = ID_def;
+  val oo_def = oo_def;
+end;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Cfun.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,912 @@
+(*  Title:      HOLCF/Cfun1.thy
+    ID:         $Id$
+    Author:     Franz Regensburger
+    License:    GPL (GNU GENERAL PUBLIC LICENSE)
+
+Definition of the type ->  of continuous functions.
+
+*)
+
+header {* The type of continuous functions *}
+
+theory Cfun = Cont:
+
+defaultsort cpo
+
+typedef (CFun)  ('a, 'b) "->" (infixr 0) = "{f::'a => 'b. cont f}"
+by (rule exI, rule CfunI)
+
+(* to make << defineable *)
+instance "->"  :: (cpo,cpo)sq_ord ..
+
+syntax
+	Rep_CFun  :: "('a -> 'b) => ('a => 'b)" ("_$_" [999,1000] 999)
+                                                (* application      *)
+        Abs_CFun  :: "('a => 'b) => ('a -> 'b)" (binder "LAM " 10)
+                                                (* abstraction      *)
+        less_cfun :: "[('a -> 'b),('a -> 'b)]=>bool"
+
+syntax (xsymbols)
+  "->"		:: "[type, type] => type"      ("(_ \<rightarrow>/ _)" [1,0]0)
+  "LAM "	:: "[idts, 'a => 'b] => ('a -> 'b)"
+					("(3\<Lambda>_./ _)" [0, 10] 10)
+  Rep_CFun      :: "('a -> 'b) => ('a => 'b)"  ("(_\<cdot>_)" [999,1000] 999)
+
+syntax (HTML output)
+  Rep_CFun      :: "('a -> 'b) => ('a => 'b)"  ("(_\<cdot>_)" [999,1000] 999)
+
+defs (overloaded)
+  less_cfun_def: "(op <<) == (% fo1 fo2. Rep_CFun fo1 << Rep_CFun fo2 )"
+
+(* ------------------------------------------------------------------------ *)
+(* derive old type definition rules for Abs_CFun & Rep_CFun
+    *)
+(* Rep_CFun and Abs_CFun should be replaced by Rep_Cfun anf Abs_Cfun in future
+    *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Rep_Cfun: "Rep_CFun fo : CFun"
+apply (rule Rep_CFun)
+done
+
+lemma Rep_Cfun_inverse: "Abs_CFun (Rep_CFun fo) = fo"
+apply (rule Rep_CFun_inverse)
+done
+
+lemma Abs_Cfun_inverse: "f:CFun==>Rep_CFun(Abs_CFun f)=f"
+apply (erule Abs_CFun_inverse)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* less_cfun is a partial order on type 'a -> 'b                            *)
+(* ------------------------------------------------------------------------ *)
+
+lemma refl_less_cfun: "(f::'a->'b) << f"
+
+apply (unfold less_cfun_def)
+apply (rule refl_less)
+done
+
+lemma antisym_less_cfun: 
+        "[|(f1::'a->'b) << f2; f2 << f1|] ==> f1 = f2"
+apply (unfold less_cfun_def)
+apply (rule injD)
+apply (rule_tac [2] antisym_less)
+prefer 3 apply (assumption)
+prefer 2 apply (assumption)
+apply (rule inj_on_inverseI)
+apply (rule Rep_Cfun_inverse)
+done
+
+lemma trans_less_cfun: 
+        "[|(f1::'a->'b) << f2; f2 << f3|] ==> f1 << f3"
+apply (unfold less_cfun_def)
+apply (erule trans_less)
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* lemmas about application of continuous functions                         *)
+(* ------------------------------------------------------------------------ *)
+
+lemma cfun_cong: "[| f=g; x=y |] ==> f$x = g$y"
+apply (simp (no_asm_simp))
+done
+
+lemma cfun_fun_cong: "f=g ==> f$x = g$x"
+apply (simp (no_asm_simp))
+done
+
+lemma cfun_arg_cong: "x=y ==> f$x = f$y"
+apply (simp (no_asm_simp))
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* additional lemma about the isomorphism between -> and Cfun               *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Abs_Cfun_inverse2: "cont f ==> Rep_CFun (Abs_CFun f) = f"
+apply (rule Abs_Cfun_inverse)
+apply (unfold CFun_def)
+apply (erule mem_Collect_eq [THEN ssubst])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* simplification of application                                            *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Cfunapp2: "cont f ==> (Abs_CFun f)$x = f x"
+apply (erule Abs_Cfun_inverse2 [THEN fun_cong])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* beta - equality for continuous functions                                 *)
+(* ------------------------------------------------------------------------ *)
+
+lemma beta_cfun: "cont(c1) ==> (LAM x .c1 x)$u = c1 u"
+apply (rule Cfunapp2)
+apply assumption
+done
+
+
+(* Class Instance ->::(cpo,cpo)po *)
+
+instance "->"::(cpo,cpo)po
+apply (intro_classes)
+apply (rule refl_less_cfun)
+apply (rule antisym_less_cfun, assumption+)
+apply (rule trans_less_cfun, assumption+)
+done
+
+(* Class Instance ->::(cpo,cpo)po *)
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_cfun_po: "(op <<)=(%f1 f2. Rep_CFun f1 << Rep_CFun f2)"
+apply (fold less_cfun_def)
+apply (rule refl)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* access to less_cfun in class po                                          *)
+(* ------------------------------------------------------------------------ *)
+
+lemma less_cfun: "( f1 << f2 ) = (Rep_CFun(f1) << Rep_CFun(f2))"
+apply (simp (no_asm) add: inst_cfun_po)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Type 'a ->'b  is pointed                                                 *)
+(* ------------------------------------------------------------------------ *)
+
+lemma minimal_cfun: "Abs_CFun(% x. UU) << f"
+apply (subst less_cfun)
+apply (subst Abs_Cfun_inverse2)
+apply (rule cont_const)
+apply (rule minimal_fun)
+done
+
+lemmas UU_cfun_def = minimal_cfun [THEN minimal2UU, symmetric, standard]
+
+lemma least_cfun: "? x::'a->'b::pcpo.!y. x<<y"
+apply (rule_tac x = "Abs_CFun (% x. UU) " in exI)
+apply (rule minimal_cfun [THEN allI])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Rep_CFun yields continuous functions in 'a => 'b                             *)
+(* this is continuity of Rep_CFun in its 'second' argument                      *)
+(* cont_Rep_CFun2 ==> monofun_Rep_CFun2 & contlub_Rep_CFun2                            *)
+(* ------------------------------------------------------------------------ *)
+
+lemma cont_Rep_CFun2: "cont(Rep_CFun(fo))"
+apply (rule_tac P = "cont" in CollectD)
+apply (fold CFun_def)
+apply (rule Rep_Cfun)
+done
+
+lemmas monofun_Rep_CFun2 = cont_Rep_CFun2 [THEN cont2mono, standard]
+(* monofun(Rep_CFun(?fo1)) *)
+
+
+lemmas contlub_Rep_CFun2 = cont_Rep_CFun2 [THEN cont2contlub, standard]
+(* contlub(Rep_CFun(?fo1)) *)
+
+(* ------------------------------------------------------------------------ *)
+(* expanded thms cont_Rep_CFun2, contlub_Rep_CFun2                                 *)
+(* looks nice with mixfix syntac                                            *)
+(* ------------------------------------------------------------------------ *)
+
+lemmas cont_cfun_arg = cont_Rep_CFun2 [THEN contE, THEN spec, THEN mp]
+(* chain(?x1) ==> range (%i. ?fo3$(?x1 i)) <<| ?fo3$(lub (range ?x1))    *)
+ 
+lemmas contlub_cfun_arg = contlub_Rep_CFun2 [THEN contlubE, THEN spec, THEN mp]
+(* chain(?x1) ==> ?fo4$(lub (range ?x1)) = lub (range (%i. ?fo4$(?x1 i))) *)
+
+
+(* ------------------------------------------------------------------------ *)
+(* Rep_CFun is monotone in its 'first' argument                                 *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_Rep_CFun1: "monofun(Rep_CFun)"
+apply (unfold monofun)
+apply (intro strip)
+apply (erule less_cfun [THEN subst])
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* monotonicity of application Rep_CFun in mixfix syntax [_]_                   *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_cfun_fun: "f1 << f2 ==> f1$x << f2$x"
+apply (rule_tac x = "x" in spec)
+apply (rule less_fun [THEN subst])
+apply (erule monofun_Rep_CFun1 [THEN monofunE, THEN spec, THEN spec, THEN mp])
+done
+
+
+lemmas monofun_cfun_arg = monofun_Rep_CFun2 [THEN monofunE, THEN spec, THEN spec, THEN mp, standard]
+(* ?x2 << ?x1 ==> ?fo5$?x2 << ?fo5$?x1                                      *)
+
+lemma chain_monofun: "chain Y ==> chain (%i. f\<cdot>(Y i))"
+apply (rule chainI)
+apply (rule monofun_cfun_arg)
+apply (erule chainE)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* monotonicity of Rep_CFun in both arguments in mixfix syntax [_]_             *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_cfun: "[|f1<<f2;x1<<x2|] ==> f1$x1 << f2$x2"
+apply (rule trans_less)
+apply (erule monofun_cfun_arg)
+apply (erule monofun_cfun_fun)
+done
+
+
+lemma strictI: "f$x = UU ==> f$UU = UU"
+apply (rule eq_UU_iff [THEN iffD2])
+apply (erule subst)
+apply (rule minimal [THEN monofun_cfun_arg])
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* ch2ch - rules for the type 'a -> 'b                                      *)
+(* use MF2 lemmas from Cont.ML                                              *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ch2ch_Rep_CFunR: "chain(Y) ==> chain(%i. f$(Y i))"
+apply (erule monofun_Rep_CFun2 [THEN ch2ch_MF2R])
+done
+
+
+lemmas ch2ch_Rep_CFunL = monofun_Rep_CFun1 [THEN ch2ch_MF2L, standard]
+(* chain(?F) ==> chain (%i. ?F i$?x)                                  *)
+
+
+(* ------------------------------------------------------------------------ *)
+(*  the lub of a chain of continous functions is monotone                   *)
+(* use MF2 lemmas from Cont.ML                                              *)
+(* ------------------------------------------------------------------------ *)
+
+lemma lub_cfun_mono: "chain(F) ==> monofun(% x. lub(range(% j.(F j)$x)))"
+apply (rule lub_MF2_mono)
+apply (rule monofun_Rep_CFun1)
+apply (rule monofun_Rep_CFun2 [THEN allI])
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* a lemma about the exchange of lubs for type 'a -> 'b                     *)
+(* use MF2 lemmas from Cont.ML                                              *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ex_lubcfun: "[| chain(F); chain(Y) |] ==> 
+                lub(range(%j. lub(range(%i. F(j)$(Y i))))) = 
+                lub(range(%i. lub(range(%j. F(j)$(Y i)))))"
+apply (rule ex_lubMF2)
+apply (rule monofun_Rep_CFun1)
+apply (rule monofun_Rep_CFun2 [THEN allI])
+apply assumption
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* the lub of a chain of cont. functions is continuous                      *)
+(* ------------------------------------------------------------------------ *)
+
+lemma cont_lubcfun: "chain(F) ==> cont(% x. lub(range(% j. F(j)$x)))"
+apply (rule monocontlub2cont)
+apply (erule lub_cfun_mono)
+apply (rule contlubI)
+apply (intro strip)
+apply (subst contlub_cfun_arg [THEN ext])
+apply assumption
+apply (erule ex_lubcfun)
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* type 'a -> 'b is chain complete                                          *)
+(* ------------------------------------------------------------------------ *)
+
+lemma lub_cfun: "chain(CCF) ==> range(CCF) <<| (LAM x. lub(range(% i. CCF(i)$x)))"
+apply (rule is_lubI)
+apply (rule ub_rangeI)
+apply (subst less_cfun)
+apply (subst Abs_Cfun_inverse2)
+apply (erule cont_lubcfun)
+apply (rule lub_fun [THEN is_lubD1, THEN ub_rangeD])
+apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
+apply (subst less_cfun)
+apply (subst Abs_Cfun_inverse2)
+apply (erule cont_lubcfun)
+apply (rule lub_fun [THEN is_lub_lub])
+apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
+apply (erule monofun_Rep_CFun1 [THEN ub2ub_monofun])
+done
+
+lemmas thelub_cfun = lub_cfun [THEN thelubI, standard]
+(* 
+chain(?CCF1) ==>  lub (range ?CCF1) = (LAM x. lub (range (%i. ?CCF1 i$x)))
+*)
+
+lemma cpo_cfun: "chain(CCF::nat=>('a->'b)) ==> ? x. range(CCF) <<| x"
+apply (rule exI)
+apply (erule lub_cfun)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* Extensionality in 'a -> 'b                                               *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ext_cfun: "(!!x. f$x = g$x) ==> f = g"
+apply (rule_tac t = "f" in Rep_Cfun_inverse [THEN subst])
+apply (rule_tac t = "g" in Rep_Cfun_inverse [THEN subst])
+apply (rule_tac f = "Abs_CFun" in arg_cong)
+apply (rule ext)
+apply simp
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Monotonicity of Abs_CFun                                                     *)
+(* ------------------------------------------------------------------------ *)
+
+lemma semi_monofun_Abs_CFun: "[| cont(f); cont(g); f<<g|] ==> Abs_CFun(f)<<Abs_CFun(g)"
+apply (rule less_cfun [THEN iffD2])
+apply (subst Abs_Cfun_inverse2)
+apply assumption
+apply (subst Abs_Cfun_inverse2)
+apply assumption
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Extenionality wrt. << in 'a -> 'b                                        *)
+(* ------------------------------------------------------------------------ *)
+
+lemma less_cfun2: "(!!x. f$x << g$x) ==> f << g"
+apply (rule_tac t = "f" in Rep_Cfun_inverse [THEN subst])
+apply (rule_tac t = "g" in Rep_Cfun_inverse [THEN subst])
+apply (rule semi_monofun_Abs_CFun)
+apply (rule cont_Rep_CFun2)
+apply (rule cont_Rep_CFun2)
+apply (rule less_fun [THEN iffD2])
+apply (rule allI)
+apply simp
+done
+
+(* Class instance of  -> for class pcpo *)
+
+instance "->" :: (cpo,cpo)cpo
+by (intro_classes, rule cpo_cfun)
+
+instance "->" :: (cpo,pcpo)pcpo
+by (intro_classes, rule least_cfun)
+
+defaultsort pcpo
+
+consts  
+        Istrictify   :: "('a->'b)=>'a=>'b"
+        strictify    :: "('a->'b)->'a->'b"
+defs
+
+Istrictify_def:  "Istrictify f x == if x=UU then UU else f$x"    
+strictify_def:   "strictify == (LAM f x. Istrictify f x)"
+
+consts
+        ID      :: "('a::cpo) -> 'a"
+        cfcomp  :: "('b->'c)->(('a::cpo)->('b::cpo))->'a->('c::cpo)"
+
+syntax  "@oo"   :: "('b->'c)=>('a->'b)=>'a->'c" ("_ oo _" [101,100] 100)
+     
+translations    "f1 oo f2" == "cfcomp$f1$f2"
+
+defs
+
+  ID_def:        "ID ==(LAM x. x)"
+  oo_def:        "cfcomp == (LAM f g x. f$(g$x))" 
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_cfun_pcpo: "UU = Abs_CFun(%x. UU)"
+apply (simp add: UU_def UU_cfun_def)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* the contlub property for Rep_CFun its 'first' argument                       *)
+(* ------------------------------------------------------------------------ *)
+
+lemma contlub_Rep_CFun1: "contlub(Rep_CFun)"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule expand_fun_eq [THEN iffD2])
+apply (intro strip)
+apply (subst thelub_cfun)
+apply assumption
+apply (subst Cfunapp2)
+apply (erule cont_lubcfun)
+apply (subst thelub_fun)
+apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
+apply (rule refl)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* the cont property for Rep_CFun in its first argument                        *)
+(* ------------------------------------------------------------------------ *)
+
+lemma cont_Rep_CFun1: "cont(Rep_CFun)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Rep_CFun1)
+apply (rule contlub_Rep_CFun1)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* contlub, cont properties of Rep_CFun in its first argument in mixfix _[_]   *)
+(* ------------------------------------------------------------------------ *)
+
+lemma contlub_cfun_fun: 
+"chain(FY) ==> 
+  lub(range FY)$x = lub(range (%i. FY(i)$x))"
+apply (rule trans)
+apply (erule contlub_Rep_CFun1 [THEN contlubE, THEN spec, THEN mp, THEN fun_cong])
+apply (subst thelub_fun)
+apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
+apply (rule refl)
+done
+
+
+lemma cont_cfun_fun: 
+"chain(FY) ==> 
+  range(%i. FY(i)$x) <<| lub(range FY)$x"
+apply (rule thelubE)
+apply (erule ch2ch_Rep_CFunL)
+apply (erule contlub_cfun_fun [symmetric])
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* contlub, cont  properties of Rep_CFun in both argument in mixfix _[_]       *)
+(* ------------------------------------------------------------------------ *)
+
+lemma contlub_cfun: 
+"[|chain(FY);chain(TY)|] ==> 
+  (lub(range FY))$(lub(range TY)) = lub(range(%i. FY(i)$(TY i)))"
+apply (rule contlub_CF2)
+apply (rule cont_Rep_CFun1)
+apply (rule allI)
+apply (rule cont_Rep_CFun2)
+apply assumption
+apply assumption
+done
+
+lemma cont_cfun: 
+"[|chain(FY);chain(TY)|] ==> 
+  range(%i.(FY i)$(TY i)) <<| (lub (range FY))$(lub(range TY))"
+apply (rule thelubE)
+apply (rule monofun_Rep_CFun1 [THEN ch2ch_MF2LR])
+apply (rule allI)
+apply (rule monofun_Rep_CFun2)
+apply assumption
+apply assumption
+apply (erule contlub_cfun [symmetric])
+apply assumption
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* cont2cont lemma for Rep_CFun                                               *)
+(* ------------------------------------------------------------------------ *)
+
+lemma cont2cont_Rep_CFun: "[|cont(%x. ft x);cont(%x. tt x)|] ==> cont(%x. (ft x)$(tt x))"
+apply (best intro: cont2cont_app2 cont_const cont_Rep_CFun1 cont_Rep_CFun2)
+done
+
+
+
+(* ------------------------------------------------------------------------ *)
+(* cont2mono Lemma for %x. LAM y. c1(x)(y)                                  *)
+(* ------------------------------------------------------------------------ *)
+
+lemma cont2mono_LAM:
+assumes p1: "!!x. cont(c1 x)"
+assumes p2: "!!y. monofun(%x. c1 x y)"
+shows "monofun(%x. LAM y. c1 x y)"
+apply (rule monofunI)
+apply (intro strip)
+apply (subst less_cfun)
+apply (subst less_fun)
+apply (rule allI)
+apply (subst beta_cfun)
+apply (rule p1)
+apply (subst beta_cfun)
+apply (rule p1)
+apply (erule p2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* cont2cont Lemma for %x. LAM y. c1 x y)                                 *)
+(* ------------------------------------------------------------------------ *)
+
+lemma cont2cont_LAM:
+assumes p1: "!!x. cont(c1 x)"
+assumes p2: "!!y. cont(%x. c1 x y)"
+shows "cont(%x. LAM y. c1 x y)"
+apply (rule monocontlub2cont)
+apply (rule p1 [THEN cont2mono_LAM])
+apply (rule p2 [THEN cont2mono])
+apply (rule contlubI)
+apply (intro strip)
+apply (subst thelub_cfun)
+apply (rule p1 [THEN cont2mono_LAM, THEN ch2ch_monofun])
+apply (rule p2 [THEN cont2mono])
+apply assumption
+apply (rule_tac f = "Abs_CFun" in arg_cong)
+apply (rule ext)
+apply (subst p1 [THEN beta_cfun, THEN ext])
+apply (erule p2 [THEN cont2contlub, THEN contlubE, THEN spec, THEN mp])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* cont2cont tactic                                                       *)
+(* ------------------------------------------------------------------------ *)
+
+lemmas cont_lemmas1 = cont_const cont_id cont_Rep_CFun2
+                    cont2cont_Rep_CFun cont2cont_LAM
+
+declare cont_lemmas1 [simp]
+
+(* HINT: cont_tac is now installed in simplifier in Lift.ML ! *)
+
+(*val cont_tac = (fn i => (resolve_tac cont_lemmas i));*)
+(*val cont_tacR = (fn i => (REPEAT (cont_tac i)));*)
+
+(* ------------------------------------------------------------------------ *)
+(* function application _[_]  is strict in its first arguments              *)
+(* ------------------------------------------------------------------------ *)
+
+lemma strict_Rep_CFun1: "(UU::'a::cpo->'b)$x = (UU::'b)"
+apply (subst inst_cfun_pcpo)
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (rule refl)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* results about strictify                                                  *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Istrictify1: 
+        "Istrictify(f)(UU)= (UU)"
+apply (unfold Istrictify_def)
+apply (simp (no_asm))
+done
+
+lemma Istrictify2: 
+        "~x=UU ==> Istrictify(f)(x)=f$x"
+apply (unfold Istrictify_def)
+apply (simp (no_asm_simp))
+done
+
+lemma monofun_Istrictify1: "monofun(Istrictify)"
+apply (rule monofunI)
+apply (intro strip)
+apply (rule less_fun [THEN iffD2])
+apply (intro strip)
+apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
+apply (subst Istrictify2)
+apply assumption
+apply (subst Istrictify2)
+apply assumption
+apply (rule monofun_cfun_fun)
+apply assumption
+apply (erule ssubst)
+apply (subst Istrictify1)
+apply (subst Istrictify1)
+apply (rule refl_less)
+done
+
+lemma monofun_Istrictify2: "monofun(Istrictify(f))"
+apply (rule monofunI)
+apply (intro strip)
+apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
+apply (simplesubst Istrictify2)
+apply (erule notUU_I)
+apply assumption
+apply (subst Istrictify2)
+apply assumption
+apply (rule monofun_cfun_arg)
+apply assumption
+apply (erule ssubst)
+apply (subst Istrictify1)
+apply (rule minimal)
+done
+
+
+lemma contlub_Istrictify1: "contlub(Istrictify)"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule expand_fun_eq [THEN iffD2])
+apply (intro strip)
+apply (subst thelub_fun)
+apply (erule monofun_Istrictify1 [THEN ch2ch_monofun])
+apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
+apply (subst Istrictify2)
+apply assumption
+apply (subst Istrictify2 [THEN ext])
+apply assumption
+apply (subst thelub_cfun)
+apply assumption
+apply (subst beta_cfun)
+apply (rule cont_lubcfun)
+apply assumption
+apply (rule refl)
+apply (erule ssubst)
+apply (subst Istrictify1)
+apply (subst Istrictify1 [THEN ext])
+apply (rule chain_UU_I_inverse [symmetric])
+apply (rule refl [THEN allI])
+done
+
+lemma contlub_Istrictify2: "contlub(Istrictify(f::'a -> 'b))"
+apply (rule contlubI)
+apply (intro strip)
+apply (case_tac "lub (range (Y))= (UU::'a) ")
+apply (simp (no_asm_simp) add: Istrictify1 chain_UU_I_inverse chain_UU_I Istrictify1)
+apply (subst Istrictify2)
+apply assumption
+apply (rule_tac s = "lub (range (%i. f$ (Y i))) " in trans)
+apply (rule contlub_cfun_arg)
+apply assumption
+apply (rule lub_equal2)
+prefer 3 apply (best intro: ch2ch_monofun monofun_Istrictify2)
+prefer 2 apply (best intro: ch2ch_monofun monofun_Rep_CFun2)
+apply (rule chain_mono2 [THEN exE])
+prefer 2 apply (assumption)
+apply (erule chain_UU_I_inverse2)
+apply (blast intro: Istrictify2 [symmetric])
+done
+
+
+lemmas cont_Istrictify1 = contlub_Istrictify1 [THEN monofun_Istrictify1 [THEN monocontlub2cont], standard]
+
+lemmas cont_Istrictify2 = contlub_Istrictify2 [THEN monofun_Istrictify2 [THEN monocontlub2cont], standard]
+
+
+lemma strictify1: "strictify$f$UU=UU"
+apply (unfold strictify_def)
+apply (subst beta_cfun)
+apply (simp (no_asm) add: cont_Istrictify2 cont_Istrictify1 cont2cont_CF1L)
+apply (subst beta_cfun)
+apply (rule cont_Istrictify2)
+apply (rule Istrictify1)
+done
+
+lemma strictify2: "~x=UU ==> strictify$f$x=f$x"
+apply (unfold strictify_def)
+apply (subst beta_cfun)
+apply (simp (no_asm) add: cont_Istrictify2 cont_Istrictify1 cont2cont_CF1L)
+apply (subst beta_cfun)
+apply (rule cont_Istrictify2)
+apply (erule Istrictify2)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* Instantiate the simplifier                                               *)
+(* ------------------------------------------------------------------------ *)
+
+declare minimal [simp] refl_less [simp] beta_cfun [simp] strict_Rep_CFun1 [simp] strictify1 [simp] strictify2 [simp]
+
+
+(* ------------------------------------------------------------------------ *)
+(* use cont_tac as autotac.                                                *)
+(* ------------------------------------------------------------------------ *)
+
+(* HINT: cont_tac is now installed in simplifier in Lift.ML ! *)
+(*simpset_ref() := simpset() addsolver (K (DEPTH_SOLVE_1 o cont_tac));*)
+
+(* ------------------------------------------------------------------------ *)
+(* some lemmata for functions with flat/chfin domain/range types	    *)
+(* ------------------------------------------------------------------------ *)
+
+lemma chfin_Rep_CFunR: "chain (Y::nat => 'a::cpo->'b::chfin)  
+      ==> !s. ? n. lub(range(Y))$s = Y n$s"
+apply (rule allI)
+apply (subst contlub_cfun_fun)
+apply assumption
+apply (fast intro!: thelubI chfin lub_finch2 chfin2finch ch2ch_Rep_CFunL)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* continuous isomorphisms are strict                                       *)
+(* a prove for embedding projection pairs is similar                        *)
+(* ------------------------------------------------------------------------ *)
+
+lemma iso_strict: 
+"!!f g.[|!y. f$(g$y)=(y::'b) ; !x. g$(f$x)=(x::'a) |]  
+  ==> f$UU=UU & g$UU=UU"
+apply (rule conjI)
+apply (rule UU_I)
+apply (rule_tac s = "f$ (g$ (UU::'b))" and t = "UU::'b" in subst)
+apply (erule spec)
+apply (rule minimal [THEN monofun_cfun_arg])
+apply (rule UU_I)
+apply (rule_tac s = "g$ (f$ (UU::'a))" and t = "UU::'a" in subst)
+apply (erule spec)
+apply (rule minimal [THEN monofun_cfun_arg])
+done
+
+
+lemma isorep_defined: "[|!x. rep$(ab$x)=x;!y. ab$(rep$y)=y; z~=UU|] ==> rep$z ~= UU"
+apply (erule contrapos_nn)
+apply (drule_tac f = "ab" in cfun_arg_cong)
+apply (erule box_equals)
+apply fast
+apply (erule iso_strict [THEN conjunct1])
+apply assumption
+done
+
+lemma isoabs_defined: "[|!x. rep$(ab$x) = x;!y. ab$(rep$y)=y ; z~=UU|] ==> ab$z ~= UU"
+apply (erule contrapos_nn)
+apply (drule_tac f = "rep" in cfun_arg_cong)
+apply (erule box_equals)
+apply fast
+apply (erule iso_strict [THEN conjunct2])
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* propagation of flatness and chainfiniteness by continuous isomorphisms   *)
+(* ------------------------------------------------------------------------ *)
+
+lemma chfin2chfin: "!!f g.[|! Y::nat=>'a. chain Y --> (? n. max_in_chain n Y);  
+  !y. f$(g$y)=(y::'b) ; !x. g$(f$x)=(x::'a::chfin) |]  
+  ==> ! Y::nat=>'b. chain Y --> (? n. max_in_chain n Y)"
+apply (unfold max_in_chain_def)
+apply (intro strip)
+apply (rule exE)
+apply (rule_tac P = "chain (%i. g$ (Y i))" in mp)
+apply (erule spec)
+apply (erule ch2ch_Rep_CFunR)
+apply (rule exI)
+apply (intro strip)
+apply (rule_tac s = "f$ (g$ (Y x))" and t = "Y (x) " in subst)
+apply (erule spec)
+apply (rule_tac s = "f$ (g$ (Y j))" and t = "Y (j) " in subst)
+apply (erule spec)
+apply (rule cfun_arg_cong)
+apply (rule mp)
+apply (erule spec)
+apply assumption
+done
+
+
+lemma flat2flat: "!!f g.[|!x y::'a. x<<y --> x=UU | x=y;  
+  !y. f$(g$y)=(y::'b); !x. g$(f$x)=(x::'a)|] ==> !x y::'b. x<<y --> x=UU | x=y"
+apply (intro strip)
+apply (rule disjE)
+apply (rule_tac P = "g$x<<g$y" in mp)
+apply (erule_tac [2] monofun_cfun_arg)
+apply (drule spec)
+apply (erule spec)
+apply (rule disjI1)
+apply (rule trans)
+apply (rule_tac s = "f$ (g$x) " and t = "x" in subst)
+apply (erule spec)
+apply (erule cfun_arg_cong)
+apply (rule iso_strict [THEN conjunct1])
+apply assumption
+apply assumption
+apply (rule disjI2)
+apply (rule_tac s = "f$ (g$x) " and t = "x" in subst)
+apply (erule spec)
+apply (rule_tac s = "f$ (g$y) " and t = "y" in subst)
+apply (erule spec)
+apply (erule cfun_arg_cong)
+done
+
+(* ------------------------------------------------------------------------- *)
+(* a result about functions with flat codomain                               *)
+(* ------------------------------------------------------------------------- *)
+
+lemma flat_codom: "f$(x::'a)=(c::'b::flat) ==> f$(UU::'a)=(UU::'b) | (!z. f$(z::'a)=c)"
+apply (case_tac "f$ (x::'a) = (UU::'b) ")
+apply (rule disjI1)
+apply (rule UU_I)
+apply (rule_tac s = "f$ (x) " and t = "UU::'b" in subst)
+apply assumption
+apply (rule minimal [THEN monofun_cfun_arg])
+apply (case_tac "f$ (UU::'a) = (UU::'b) ")
+apply (erule disjI1)
+apply (rule disjI2)
+apply (rule allI)
+apply (erule subst)
+apply (rule_tac a = "f$ (UU::'a) " in refl [THEN box_equals])
+apply (rule_tac fo5 = "f" in minimal [THEN monofun_cfun_arg, THEN ax_flat [THEN spec, THEN spec, THEN mp], THEN disjE])
+apply simp
+apply assumption
+apply (rule_tac fo5 = "f" in minimal [THEN monofun_cfun_arg, THEN ax_flat [THEN spec, THEN spec, THEN mp], THEN disjE])
+apply simp
+apply assumption
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* Access to definitions                                                    *)
+(* ------------------------------------------------------------------------ *)
+
+
+lemma ID1: "ID$x=x"
+apply (unfold ID_def)
+apply (subst beta_cfun)
+apply (rule cont_id)
+apply (rule refl)
+done
+
+lemma cfcomp1: "(f oo g)=(LAM x. f$(g$x))"
+apply (unfold oo_def)
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (rule refl)
+done
+
+lemma cfcomp2: "(f oo g)$x=f$(g$x)"
+apply (subst cfcomp1)
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (rule refl)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* Show that interpretation of (pcpo,_->_) is a category                    *)
+(* The class of objects is interpretation of syntactical class pcpo         *)
+(* The class of arrows  between objects 'a and 'b is interpret. of 'a -> 'b *)
+(* The identity arrow is interpretation of ID                               *)
+(* The composition of f and g is interpretation of oo                       *)
+(* ------------------------------------------------------------------------ *)
+
+
+lemma ID2: "f oo ID = f "
+apply (rule ext_cfun)
+apply (subst cfcomp2)
+apply (subst ID1)
+apply (rule refl)
+done
+
+lemma ID3: "ID oo f = f "
+apply (rule ext_cfun)
+apply (subst cfcomp2)
+apply (subst ID1)
+apply (rule refl)
+done
+
+
+lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
+apply (rule ext_cfun)
+apply (rule_tac s = "f$ (g$ (h$x))" in trans)
+apply (subst cfcomp2)
+apply (subst cfcomp2)
+apply (rule refl)
+apply (subst cfcomp2)
+apply (subst cfcomp2)
+apply (rule refl)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Merge the different rewrite rules for the simplifier                     *)
+(* ------------------------------------------------------------------------ *)
+
+declare  ID1[simp] ID2[simp] ID3[simp] cfcomp2[simp]
+
+end
--- a/src/HOLCF/Cfun1.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,16 +0,0 @@
-
-(* legacy ML bindings *)
-
-val less_cfun_def = thm "less_cfun_def";
-val Rep_Cfun = thm "Rep_Cfun";
-val Rep_Cfun_inverse = thm "Rep_Cfun_inverse";
-val Abs_Cfun_inverse = thm "Abs_Cfun_inverse";
-val refl_less_cfun = thm "refl_less_cfun";
-val antisym_less_cfun = thm "antisym_less_cfun";
-val trans_less_cfun = thm "trans_less_cfun";
-val cfun_cong = thm "cfun_cong";
-val cfun_fun_cong = thm "cfun_fun_cong";
-val cfun_arg_cong = thm "cfun_arg_cong";
-val Abs_Cfun_inverse2 = thm "Abs_Cfun_inverse2";
-val Cfunapp2 = thm "Cfunapp2";
-val beta_cfun = thm "beta_cfun";
--- a/src/HOLCF/Cfun1.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,138 +0,0 @@
-(*  Title:      HOLCF/Cfun1.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Definition of the type ->  of continuous functions.
-
-*)
-
-theory Cfun1 = Cont:
-
-defaultsort cpo
-
-typedef (CFun)  ('a, 'b) "->" (infixr 0) = "{f::'a => 'b. cont f}"
-by (rule exI, rule CfunI)
-
-(* to make << defineable *)
-instance "->"  :: (cpo,cpo)sq_ord ..
-
-syntax
-	Rep_CFun  :: "('a -> 'b) => ('a => 'b)" ("_$_" [999,1000] 999)
-                                                (* application      *)
-        Abs_CFun  :: "('a => 'b) => ('a -> 'b)" (binder "LAM " 10)
-                                                (* abstraction      *)
-        less_cfun :: "[('a -> 'b),('a -> 'b)]=>bool"
-
-syntax (xsymbols)
-  "->"		:: "[type, type] => type"      ("(_ \<rightarrow>/ _)" [1,0]0)
-  "LAM "	:: "[idts, 'a => 'b] => ('a -> 'b)"
-					("(3\<Lambda>_./ _)" [0, 10] 10)
-  Rep_CFun      :: "('a -> 'b) => ('a => 'b)"  ("(_\<cdot>_)" [999,1000] 999)
-
-syntax (HTML output)
-  Rep_CFun      :: "('a -> 'b) => ('a => 'b)"  ("(_\<cdot>_)" [999,1000] 999)
-
-defs (overloaded)
-  less_cfun_def: "(op <<) == (% fo1 fo2. Rep_CFun fo1 << Rep_CFun fo2 )"
-
-(*  Title:      HOLCF/Cfun1.ML
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-The type ->  of continuous functions.
-*)
-
-(* ------------------------------------------------------------------------ *)
-(* derive old type definition rules for Abs_CFun & Rep_CFun
-    *)
-(* Rep_CFun and Abs_CFun should be replaced by Rep_Cfun anf Abs_Cfun in future
-    *)
-(* ------------------------------------------------------------------------ *)
-
-lemma Rep_Cfun: "Rep_CFun fo : CFun"
-apply (rule Rep_CFun)
-done
-
-lemma Rep_Cfun_inverse: "Abs_CFun (Rep_CFun fo) = fo"
-apply (rule Rep_CFun_inverse)
-done
-
-lemma Abs_Cfun_inverse: "f:CFun==>Rep_CFun(Abs_CFun f)=f"
-apply (erule Abs_CFun_inverse)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* less_cfun is a partial order on type 'a -> 'b                            *)
-(* ------------------------------------------------------------------------ *)
-
-lemma refl_less_cfun: "(f::'a->'b) << f"
-
-apply (unfold less_cfun_def)
-apply (rule refl_less)
-done
-
-lemma antisym_less_cfun: 
-        "[|(f1::'a->'b) << f2; f2 << f1|] ==> f1 = f2"
-apply (unfold less_cfun_def)
-apply (rule injD)
-apply (rule_tac [2] antisym_less)
-prefer 3 apply (assumption)
-prefer 2 apply (assumption)
-apply (rule inj_on_inverseI)
-apply (rule Rep_Cfun_inverse)
-done
-
-lemma trans_less_cfun: 
-        "[|(f1::'a->'b) << f2; f2 << f3|] ==> f1 << f3"
-apply (unfold less_cfun_def)
-apply (erule trans_less)
-apply assumption
-done
-
-(* ------------------------------------------------------------------------ *)
-(* lemmas about application of continuous functions                         *)
-(* ------------------------------------------------------------------------ *)
-
-lemma cfun_cong: "[| f=g; x=y |] ==> f$x = g$y"
-apply (simp (no_asm_simp))
-done
-
-lemma cfun_fun_cong: "f=g ==> f$x = g$x"
-apply (simp (no_asm_simp))
-done
-
-lemma cfun_arg_cong: "x=y ==> f$x = f$y"
-apply (simp (no_asm_simp))
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* additional lemma about the isomorphism between -> and Cfun               *)
-(* ------------------------------------------------------------------------ *)
-
-lemma Abs_Cfun_inverse2: "cont f ==> Rep_CFun (Abs_CFun f) = f"
-apply (rule Abs_Cfun_inverse)
-apply (unfold CFun_def)
-apply (erule mem_Collect_eq [THEN ssubst])
-done
-
-(* ------------------------------------------------------------------------ *)
-(* simplification of application                                            *)
-(* ------------------------------------------------------------------------ *)
-
-lemma Cfunapp2: "cont f ==> (Abs_CFun f)$x = f x"
-apply (erule Abs_Cfun_inverse2 [THEN fun_cong])
-done
-
-(* ------------------------------------------------------------------------ *)
-(* beta - equality for continuous functions                                 *)
-(* ------------------------------------------------------------------------ *)
-
-lemma beta_cfun: "cont(c1) ==> (LAM x .c1 x)$u = c1 u"
-apply (rule Cfunapp2)
-apply assumption
-done
-
-end
--- a/src/HOLCF/Cfun2.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,30 +0,0 @@
-
-(* legacy ML bindings *)
-
-val inst_cfun_po = thm "inst_cfun_po";
-val less_cfun = thm "less_cfun";
-val minimal_cfun = thm "minimal_cfun";
-val UU_cfun_def = thm "UU_cfun_def";
-val least_cfun = thm "least_cfun";
-val cont_Rep_CFun2 = thm "cont_Rep_CFun2";
-val monofun_Rep_CFun2 = thm "monofun_Rep_CFun2";
-val contlub_Rep_CFun2 = thm "contlub_Rep_CFun2";
-val cont_cfun_arg = thm "cont_cfun_arg";
-val contlub_cfun_arg = thm "contlub_cfun_arg";
-val monofun_Rep_CFun1 = thm "monofun_Rep_CFun1";
-val monofun_cfun_fun = thm "monofun_cfun_fun";
-val monofun_cfun_arg = thm "monofun_cfun_arg";
-val chain_monofun = thm "chain_monofun";
-val monofun_cfun = thm "monofun_cfun";
-val strictI = thm "strictI";
-val ch2ch_Rep_CFunR = thm "ch2ch_Rep_CFunR";
-val ch2ch_Rep_CFunL = thm "ch2ch_Rep_CFunL";
-val lub_cfun_mono = thm "lub_cfun_mono";
-val ex_lubcfun = thm "ex_lubcfun";
-val cont_lubcfun = thm "cont_lubcfun";
-val lub_cfun = thm "lub_cfun";
-val thelub_cfun = thm "thelub_cfun";
-val cpo_cfun = thm "cpo_cfun";
-val ext_cfun = thm "ext_cfun";
-val semi_monofun_Abs_CFun = thm "semi_monofun_Abs_CFun";
-val less_cfun2 = thm "less_cfun2";
--- a/src/HOLCF/Cfun2.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,267 +0,0 @@
-(*  Title:      HOLCF/Cfun2.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class Instance ->::(cpo,cpo)po
-
-*)
-
-theory Cfun2 = Cfun1:
-
-instance "->"::(cpo,cpo)po
-apply (intro_classes)
-apply (rule refl_less_cfun)
-apply (rule antisym_less_cfun, assumption+)
-apply (rule trans_less_cfun, assumption+)
-done
-
-(*  Title:      HOLCF/Cfun2
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class Instance ->::(cpo,cpo)po
-*)
-
-(* for compatibility with old HOLCF-Version *)
-lemma inst_cfun_po: "(op <<)=(%f1 f2. Rep_CFun f1 << Rep_CFun f2)"
-apply (fold less_cfun_def)
-apply (rule refl)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* access to less_cfun in class po                                          *)
-(* ------------------------------------------------------------------------ *)
-
-lemma less_cfun: "( f1 << f2 ) = (Rep_CFun(f1) << Rep_CFun(f2))"
-apply (simp (no_asm) add: inst_cfun_po)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Type 'a ->'b  is pointed                                                 *)
-(* ------------------------------------------------------------------------ *)
-
-lemma minimal_cfun: "Abs_CFun(% x. UU) << f"
-apply (subst less_cfun)
-apply (subst Abs_Cfun_inverse2)
-apply (rule cont_const)
-apply (rule minimal_fun)
-done
-
-lemmas UU_cfun_def = minimal_cfun [THEN minimal2UU, symmetric, standard]
-
-lemma least_cfun: "? x::'a->'b::pcpo.!y. x<<y"
-apply (rule_tac x = "Abs_CFun (% x. UU) " in exI)
-apply (rule minimal_cfun [THEN allI])
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Rep_CFun yields continuous functions in 'a => 'b                             *)
-(* this is continuity of Rep_CFun in its 'second' argument                      *)
-(* cont_Rep_CFun2 ==> monofun_Rep_CFun2 & contlub_Rep_CFun2                            *)
-(* ------------------------------------------------------------------------ *)
-
-lemma cont_Rep_CFun2: "cont(Rep_CFun(fo))"
-apply (rule_tac P = "cont" in CollectD)
-apply (fold CFun_def)
-apply (rule Rep_Cfun)
-done
-
-lemmas monofun_Rep_CFun2 = cont_Rep_CFun2 [THEN cont2mono, standard]
-(* monofun(Rep_CFun(?fo1)) *)
-
-
-lemmas contlub_Rep_CFun2 = cont_Rep_CFun2 [THEN cont2contlub, standard]
-(* contlub(Rep_CFun(?fo1)) *)
-
-(* ------------------------------------------------------------------------ *)
-(* expanded thms cont_Rep_CFun2, contlub_Rep_CFun2                                 *)
-(* looks nice with mixfix syntac                                            *)
-(* ------------------------------------------------------------------------ *)
-
-lemmas cont_cfun_arg = cont_Rep_CFun2 [THEN contE, THEN spec, THEN mp]
-(* chain(?x1) ==> range (%i. ?fo3$(?x1 i)) <<| ?fo3$(lub (range ?x1))    *)
- 
-lemmas contlub_cfun_arg = contlub_Rep_CFun2 [THEN contlubE, THEN spec, THEN mp]
-(* chain(?x1) ==> ?fo4$(lub (range ?x1)) = lub (range (%i. ?fo4$(?x1 i))) *)
-
-
-(* ------------------------------------------------------------------------ *)
-(* Rep_CFun is monotone in its 'first' argument                                 *)
-(* ------------------------------------------------------------------------ *)
-
-lemma monofun_Rep_CFun1: "monofun(Rep_CFun)"
-apply (unfold monofun)
-apply (intro strip)
-apply (erule less_cfun [THEN subst])
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* monotonicity of application Rep_CFun in mixfix syntax [_]_                   *)
-(* ------------------------------------------------------------------------ *)
-
-lemma monofun_cfun_fun: "f1 << f2 ==> f1$x << f2$x"
-apply (rule_tac x = "x" in spec)
-apply (rule less_fun [THEN subst])
-apply (erule monofun_Rep_CFun1 [THEN monofunE, THEN spec, THEN spec, THEN mp])
-done
-
-
-lemmas monofun_cfun_arg = monofun_Rep_CFun2 [THEN monofunE, THEN spec, THEN spec, THEN mp, standard]
-(* ?x2 << ?x1 ==> ?fo5$?x2 << ?fo5$?x1                                      *)
-
-lemma chain_monofun: "chain Y ==> chain (%i. f\<cdot>(Y i))"
-apply (rule chainI)
-apply (rule monofun_cfun_arg)
-apply (erule chainE)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* monotonicity of Rep_CFun in both arguments in mixfix syntax [_]_             *)
-(* ------------------------------------------------------------------------ *)
-
-lemma monofun_cfun: "[|f1<<f2;x1<<x2|] ==> f1$x1 << f2$x2"
-apply (rule trans_less)
-apply (erule monofun_cfun_arg)
-apply (erule monofun_cfun_fun)
-done
-
-
-lemma strictI: "f$x = UU ==> f$UU = UU"
-apply (rule eq_UU_iff [THEN iffD2])
-apply (erule subst)
-apply (rule minimal [THEN monofun_cfun_arg])
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* ch2ch - rules for the type 'a -> 'b                                      *)
-(* use MF2 lemmas from Cont.ML                                              *)
-(* ------------------------------------------------------------------------ *)
-
-lemma ch2ch_Rep_CFunR: "chain(Y) ==> chain(%i. f$(Y i))"
-apply (erule monofun_Rep_CFun2 [THEN ch2ch_MF2R])
-done
-
-
-lemmas ch2ch_Rep_CFunL = monofun_Rep_CFun1 [THEN ch2ch_MF2L, standard]
-(* chain(?F) ==> chain (%i. ?F i$?x)                                  *)
-
-
-(* ------------------------------------------------------------------------ *)
-(*  the lub of a chain of continous functions is monotone                   *)
-(* use MF2 lemmas from Cont.ML                                              *)
-(* ------------------------------------------------------------------------ *)
-
-lemma lub_cfun_mono: "chain(F) ==> monofun(% x. lub(range(% j.(F j)$x)))"
-apply (rule lub_MF2_mono)
-apply (rule monofun_Rep_CFun1)
-apply (rule monofun_Rep_CFun2 [THEN allI])
-apply assumption
-done
-
-(* ------------------------------------------------------------------------ *)
-(* a lemma about the exchange of lubs for type 'a -> 'b                     *)
-(* use MF2 lemmas from Cont.ML                                              *)
-(* ------------------------------------------------------------------------ *)
-
-lemma ex_lubcfun: "[| chain(F); chain(Y) |] ==> 
-                lub(range(%j. lub(range(%i. F(j)$(Y i))))) = 
-                lub(range(%i. lub(range(%j. F(j)$(Y i)))))"
-apply (rule ex_lubMF2)
-apply (rule monofun_Rep_CFun1)
-apply (rule monofun_Rep_CFun2 [THEN allI])
-apply assumption
-apply assumption
-done
-
-(* ------------------------------------------------------------------------ *)
-(* the lub of a chain of cont. functions is continuous                      *)
-(* ------------------------------------------------------------------------ *)
-
-lemma cont_lubcfun: "chain(F) ==> cont(% x. lub(range(% j. F(j)$x)))"
-apply (rule monocontlub2cont)
-apply (erule lub_cfun_mono)
-apply (rule contlubI)
-apply (intro strip)
-apply (subst contlub_cfun_arg [THEN ext])
-apply assumption
-apply (erule ex_lubcfun)
-apply assumption
-done
-
-(* ------------------------------------------------------------------------ *)
-(* type 'a -> 'b is chain complete                                          *)
-(* ------------------------------------------------------------------------ *)
-
-lemma lub_cfun: "chain(CCF) ==> range(CCF) <<| (LAM x. lub(range(% i. CCF(i)$x)))"
-apply (rule is_lubI)
-apply (rule ub_rangeI)
-apply (subst less_cfun)
-apply (subst Abs_Cfun_inverse2)
-apply (erule cont_lubcfun)
-apply (rule lub_fun [THEN is_lubD1, THEN ub_rangeD])
-apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
-apply (subst less_cfun)
-apply (subst Abs_Cfun_inverse2)
-apply (erule cont_lubcfun)
-apply (rule lub_fun [THEN is_lub_lub])
-apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
-apply (erule monofun_Rep_CFun1 [THEN ub2ub_monofun])
-done
-
-lemmas thelub_cfun = lub_cfun [THEN thelubI, standard]
-(* 
-chain(?CCF1) ==>  lub (range ?CCF1) = (LAM x. lub (range (%i. ?CCF1 i$x)))
-*)
-
-lemma cpo_cfun: "chain(CCF::nat=>('a->'b)) ==> ? x. range(CCF) <<| x"
-apply (rule exI)
-apply (erule lub_cfun)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* Extensionality in 'a -> 'b                                               *)
-(* ------------------------------------------------------------------------ *)
-
-lemma ext_cfun: "(!!x. f$x = g$x) ==> f = g"
-apply (rule_tac t = "f" in Rep_Cfun_inverse [THEN subst])
-apply (rule_tac t = "g" in Rep_Cfun_inverse [THEN subst])
-apply (rule_tac f = "Abs_CFun" in arg_cong)
-apply (rule ext)
-apply simp
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Monotonicity of Abs_CFun                                                     *)
-(* ------------------------------------------------------------------------ *)
-
-lemma semi_monofun_Abs_CFun: "[| cont(f); cont(g); f<<g|] ==> Abs_CFun(f)<<Abs_CFun(g)"
-apply (rule less_cfun [THEN iffD2])
-apply (subst Abs_Cfun_inverse2)
-apply assumption
-apply (subst Abs_Cfun_inverse2)
-apply assumption
-apply assumption
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Extenionality wrt. << in 'a -> 'b                                        *)
-(* ------------------------------------------------------------------------ *)
-
-lemma less_cfun2: "(!!x. f$x << g$x) ==> f << g"
-apply (rule_tac t = "f" in Rep_Cfun_inverse [THEN subst])
-apply (rule_tac t = "g" in Rep_Cfun_inverse [THEN subst])
-apply (rule semi_monofun_Abs_CFun)
-apply (rule cont_Rep_CFun2)
-apply (rule cont_Rep_CFun2)
-apply (rule less_fun [THEN iffD2])
-apply (rule allI)
-apply simp
-done
-
-end
--- a/src/HOLCF/Cfun3.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,52 +0,0 @@
-
-(* legacy ML bindings *)
-
-val Istrictify_def = thm "Istrictify_def";
-val strictify_def = thm "strictify_def";
-val ID_def = thm "ID_def";
-val oo_def = thm "oo_def";
-val inst_cfun_pcpo = thm "inst_cfun_pcpo";
-val contlub_Rep_CFun1 = thm "contlub_Rep_CFun1";
-val cont_Rep_CFun1 = thm "cont_Rep_CFun1";
-val contlub_cfun_fun = thm "contlub_cfun_fun";
-val cont_cfun_fun = thm "cont_cfun_fun";
-val contlub_cfun = thm "contlub_cfun";
-val cont_cfun = thm "cont_cfun";
-val cont2cont_Rep_CFun = thm "cont2cont_Rep_CFun";
-val cont2mono_LAM = thm "cont2mono_LAM";
-val cont2cont_LAM = thm "cont2cont_LAM";
-val cont_lemmas1 = [cont_const, cont_id, cont_Rep_CFun2,
-                    cont2cont_Rep_CFun, cont2cont_LAM];
-val strict_Rep_CFun1 = thm "strict_Rep_CFun1";
-val Istrictify1 = thm "Istrictify1";
-val Istrictify2 = thm "Istrictify2";
-val monofun_Istrictify1 = thm "monofun_Istrictify1";
-val monofun_Istrictify2 = thm "monofun_Istrictify2";
-val contlub_Istrictify1 = thm "contlub_Istrictify1";
-val contlub_Istrictify2 = thm "contlub_Istrictify2";
-val cont_Istrictify1 = thm "cont_Istrictify1";
-val cont_Istrictify2 = thm "cont_Istrictify2";
-val strictify1 = thm "strictify1";
-val strictify2 = thm "strictify2";
-val chfin_Rep_CFunR = thm "chfin_Rep_CFunR";
-val iso_strict = thm "iso_strict";
-val isorep_defined = thm "isorep_defined";
-val isoabs_defined = thm "isoabs_defined";
-val chfin2chfin = thm "chfin2chfin";
-val flat2flat = thm "flat2flat";
-val flat_codom = thm "flat_codom";
-val ID1 = thm "ID1";
-val cfcomp1 = thm "cfcomp1";
-val cfcomp2 = thm "cfcomp2";
-val ID2 = thm "ID2";
-val ID3 = thm "ID3";
-val assoc_oo = thm "assoc_oo";
-
-structure Cfun3 =
-struct
-  val thy = the_context ();
-  val Istrictify_def = Istrictify_def;
-  val strictify_def = strictify_def;
-  val ID_def = ID_def;
-  val oo_def = oo_def;
-end;
--- a/src/HOLCF/Cfun3.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,546 +0,0 @@
-(*  Title:      HOLCF/Cfun3.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class instance of  -> for class pcpo
-
-*)
-
-theory Cfun3 = Cfun2:
-
-instance "->" :: (cpo,cpo)cpo
-by (intro_classes, rule cpo_cfun)
-
-instance "->" :: (cpo,pcpo)pcpo
-by (intro_classes, rule least_cfun)
-
-defaultsort pcpo
-
-consts  
-        Istrictify   :: "('a->'b)=>'a=>'b"
-        strictify    :: "('a->'b)->'a->'b"
-defs
-
-Istrictify_def:  "Istrictify f x == if x=UU then UU else f$x"    
-strictify_def:   "strictify == (LAM f x. Istrictify f x)"
-
-consts
-        ID      :: "('a::cpo) -> 'a"
-        cfcomp  :: "('b->'c)->(('a::cpo)->('b::cpo))->'a->('c::cpo)"
-
-syntax  "@oo"   :: "('b->'c)=>('a->'b)=>'a->'c" ("_ oo _" [101,100] 100)
-     
-translations    "f1 oo f2" == "cfcomp$f1$f2"
-
-defs
-
-  ID_def:        "ID ==(LAM x. x)"
-  oo_def:        "cfcomp == (LAM f g x. f$(g$x))" 
-
-(*  Title:      HOLCF/Cfun3
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class instance of  -> for class pcpo
-*)
-
-(* for compatibility with old HOLCF-Version *)
-lemma inst_cfun_pcpo: "UU = Abs_CFun(%x. UU)"
-apply (simp add: UU_def UU_cfun_def)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* the contlub property for Rep_CFun its 'first' argument                       *)
-(* ------------------------------------------------------------------------ *)
-
-lemma contlub_Rep_CFun1: "contlub(Rep_CFun)"
-apply (rule contlubI)
-apply (intro strip)
-apply (rule expand_fun_eq [THEN iffD2])
-apply (intro strip)
-apply (subst thelub_cfun)
-apply assumption
-apply (subst Cfunapp2)
-apply (erule cont_lubcfun)
-apply (subst thelub_fun)
-apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
-apply (rule refl)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* the cont property for Rep_CFun in its first argument                        *)
-(* ------------------------------------------------------------------------ *)
-
-lemma cont_Rep_CFun1: "cont(Rep_CFun)"
-apply (rule monocontlub2cont)
-apply (rule monofun_Rep_CFun1)
-apply (rule contlub_Rep_CFun1)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* contlub, cont properties of Rep_CFun in its first argument in mixfix _[_]   *)
-(* ------------------------------------------------------------------------ *)
-
-lemma contlub_cfun_fun: 
-"chain(FY) ==> 
-  lub(range FY)$x = lub(range (%i. FY(i)$x))"
-apply (rule trans)
-apply (erule contlub_Rep_CFun1 [THEN contlubE, THEN spec, THEN mp, THEN fun_cong])
-apply (subst thelub_fun)
-apply (erule monofun_Rep_CFun1 [THEN ch2ch_monofun])
-apply (rule refl)
-done
-
-
-lemma cont_cfun_fun: 
-"chain(FY) ==> 
-  range(%i. FY(i)$x) <<| lub(range FY)$x"
-apply (rule thelubE)
-apply (erule ch2ch_Rep_CFunL)
-apply (erule contlub_cfun_fun [symmetric])
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* contlub, cont  properties of Rep_CFun in both argument in mixfix _[_]       *)
-(* ------------------------------------------------------------------------ *)
-
-lemma contlub_cfun: 
-"[|chain(FY);chain(TY)|] ==> 
-  (lub(range FY))$(lub(range TY)) = lub(range(%i. FY(i)$(TY i)))"
-apply (rule contlub_CF2)
-apply (rule cont_Rep_CFun1)
-apply (rule allI)
-apply (rule cont_Rep_CFun2)
-apply assumption
-apply assumption
-done
-
-lemma cont_cfun: 
-"[|chain(FY);chain(TY)|] ==> 
-  range(%i.(FY i)$(TY i)) <<| (lub (range FY))$(lub(range TY))"
-apply (rule thelubE)
-apply (rule monofun_Rep_CFun1 [THEN ch2ch_MF2LR])
-apply (rule allI)
-apply (rule monofun_Rep_CFun2)
-apply assumption
-apply assumption
-apply (erule contlub_cfun [symmetric])
-apply assumption
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* cont2cont lemma for Rep_CFun                                               *)
-(* ------------------------------------------------------------------------ *)
-
-lemma cont2cont_Rep_CFun: "[|cont(%x. ft x);cont(%x. tt x)|] ==> cont(%x. (ft x)$(tt x))"
-apply (best intro: cont2cont_app2 cont_const cont_Rep_CFun1 cont_Rep_CFun2)
-done
-
-
-
-(* ------------------------------------------------------------------------ *)
-(* cont2mono Lemma for %x. LAM y. c1(x)(y)                                  *)
-(* ------------------------------------------------------------------------ *)
-
-lemma cont2mono_LAM:
-assumes p1: "!!x. cont(c1 x)"
-assumes p2: "!!y. monofun(%x. c1 x y)"
-shows "monofun(%x. LAM y. c1 x y)"
-apply (rule monofunI)
-apply (intro strip)
-apply (subst less_cfun)
-apply (subst less_fun)
-apply (rule allI)
-apply (subst beta_cfun)
-apply (rule p1)
-apply (subst beta_cfun)
-apply (rule p1)
-apply (erule p2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
-done
-
-(* ------------------------------------------------------------------------ *)
-(* cont2cont Lemma for %x. LAM y. c1 x y)                                 *)
-(* ------------------------------------------------------------------------ *)
-
-lemma cont2cont_LAM:
-assumes p1: "!!x. cont(c1 x)"
-assumes p2: "!!y. cont(%x. c1 x y)"
-shows "cont(%x. LAM y. c1 x y)"
-apply (rule monocontlub2cont)
-apply (rule p1 [THEN cont2mono_LAM])
-apply (rule p2 [THEN cont2mono])
-apply (rule contlubI)
-apply (intro strip)
-apply (subst thelub_cfun)
-apply (rule p1 [THEN cont2mono_LAM, THEN ch2ch_monofun])
-apply (rule p2 [THEN cont2mono])
-apply assumption
-apply (rule_tac f = "Abs_CFun" in arg_cong)
-apply (rule ext)
-apply (subst p1 [THEN beta_cfun, THEN ext])
-apply (erule p2 [THEN cont2contlub, THEN contlubE, THEN spec, THEN mp])
-done
-
-(* ------------------------------------------------------------------------ *)
-(* cont2cont tactic                                                       *)
-(* ------------------------------------------------------------------------ *)
-
-lemmas cont_lemmas1 = cont_const cont_id cont_Rep_CFun2
-                    cont2cont_Rep_CFun cont2cont_LAM
-
-declare cont_lemmas1 [simp]
-
-(* HINT: cont_tac is now installed in simplifier in Lift.ML ! *)
-
-(*val cont_tac = (fn i => (resolve_tac cont_lemmas i));*)
-(*val cont_tacR = (fn i => (REPEAT (cont_tac i)));*)
-
-(* ------------------------------------------------------------------------ *)
-(* function application _[_]  is strict in its first arguments              *)
-(* ------------------------------------------------------------------------ *)
-
-lemma strict_Rep_CFun1: "(UU::'a::cpo->'b)$x = (UU::'b)"
-apply (subst inst_cfun_pcpo)
-apply (subst beta_cfun)
-apply (simp (no_asm))
-apply (rule refl)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* results about strictify                                                  *)
-(* ------------------------------------------------------------------------ *)
-
-lemma Istrictify1: 
-        "Istrictify(f)(UU)= (UU)"
-apply (unfold Istrictify_def)
-apply (simp (no_asm))
-done
-
-lemma Istrictify2: 
-        "~x=UU ==> Istrictify(f)(x)=f$x"
-apply (unfold Istrictify_def)
-apply (simp (no_asm_simp))
-done
-
-lemma monofun_Istrictify1: "monofun(Istrictify)"
-apply (rule monofunI)
-apply (intro strip)
-apply (rule less_fun [THEN iffD2])
-apply (intro strip)
-apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
-apply (subst Istrictify2)
-apply assumption
-apply (subst Istrictify2)
-apply assumption
-apply (rule monofun_cfun_fun)
-apply assumption
-apply (erule ssubst)
-apply (subst Istrictify1)
-apply (subst Istrictify1)
-apply (rule refl_less)
-done
-
-lemma monofun_Istrictify2: "monofun(Istrictify(f))"
-apply (rule monofunI)
-apply (intro strip)
-apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
-apply (simplesubst Istrictify2)
-apply (erule notUU_I)
-apply assumption
-apply (subst Istrictify2)
-apply assumption
-apply (rule monofun_cfun_arg)
-apply assumption
-apply (erule ssubst)
-apply (subst Istrictify1)
-apply (rule minimal)
-done
-
-
-lemma contlub_Istrictify1: "contlub(Istrictify)"
-apply (rule contlubI)
-apply (intro strip)
-apply (rule expand_fun_eq [THEN iffD2])
-apply (intro strip)
-apply (subst thelub_fun)
-apply (erule monofun_Istrictify1 [THEN ch2ch_monofun])
-apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
-apply (subst Istrictify2)
-apply assumption
-apply (subst Istrictify2 [THEN ext])
-apply assumption
-apply (subst thelub_cfun)
-apply assumption
-apply (subst beta_cfun)
-apply (rule cont_lubcfun)
-apply assumption
-apply (rule refl)
-apply (erule ssubst)
-apply (subst Istrictify1)
-apply (subst Istrictify1 [THEN ext])
-apply (rule chain_UU_I_inverse [symmetric])
-apply (rule refl [THEN allI])
-done
-
-lemma contlub_Istrictify2: "contlub(Istrictify(f::'a -> 'b))"
-apply (rule contlubI)
-apply (intro strip)
-apply (case_tac "lub (range (Y))= (UU::'a) ")
-apply (simp (no_asm_simp) add: Istrictify1 chain_UU_I_inverse chain_UU_I Istrictify1)
-apply (subst Istrictify2)
-apply assumption
-apply (rule_tac s = "lub (range (%i. f$ (Y i))) " in trans)
-apply (rule contlub_cfun_arg)
-apply assumption
-apply (rule lub_equal2)
-prefer 3 apply (best intro: ch2ch_monofun monofun_Istrictify2)
-prefer 2 apply (best intro: ch2ch_monofun monofun_Rep_CFun2)
-apply (rule chain_mono2 [THEN exE])
-prefer 2 apply (assumption)
-apply (erule chain_UU_I_inverse2)
-apply (blast intro: Istrictify2 [symmetric])
-done
-
-
-lemmas cont_Istrictify1 = contlub_Istrictify1 [THEN monofun_Istrictify1 [THEN monocontlub2cont], standard]
-
-lemmas cont_Istrictify2 = contlub_Istrictify2 [THEN monofun_Istrictify2 [THEN monocontlub2cont], standard]
-
-
-lemma strictify1: "strictify$f$UU=UU"
-apply (unfold strictify_def)
-apply (subst beta_cfun)
-apply (simp (no_asm) add: cont_Istrictify2 cont_Istrictify1 cont2cont_CF1L)
-apply (subst beta_cfun)
-apply (rule cont_Istrictify2)
-apply (rule Istrictify1)
-done
-
-lemma strictify2: "~x=UU ==> strictify$f$x=f$x"
-apply (unfold strictify_def)
-apply (subst beta_cfun)
-apply (simp (no_asm) add: cont_Istrictify2 cont_Istrictify1 cont2cont_CF1L)
-apply (subst beta_cfun)
-apply (rule cont_Istrictify2)
-apply (erule Istrictify2)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* Instantiate the simplifier                                               *)
-(* ------------------------------------------------------------------------ *)
-
-declare minimal [simp] refl_less [simp] beta_cfun [simp] strict_Rep_CFun1 [simp] strictify1 [simp] strictify2 [simp]
-
-
-(* ------------------------------------------------------------------------ *)
-(* use cont_tac as autotac.                                                *)
-(* ------------------------------------------------------------------------ *)
-
-(* HINT: cont_tac is now installed in simplifier in Lift.ML ! *)
-(*simpset_ref() := simpset() addsolver (K (DEPTH_SOLVE_1 o cont_tac));*)
-
-(* ------------------------------------------------------------------------ *)
-(* some lemmata for functions with flat/chfin domain/range types	    *)
-(* ------------------------------------------------------------------------ *)
-
-lemma chfin_Rep_CFunR: "chain (Y::nat => 'a::cpo->'b::chfin)  
-      ==> !s. ? n. lub(range(Y))$s = Y n$s"
-apply (rule allI)
-apply (subst contlub_cfun_fun)
-apply assumption
-apply (fast intro!: thelubI chfin lub_finch2 chfin2finch ch2ch_Rep_CFunL)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* continuous isomorphisms are strict                                       *)
-(* a prove for embedding projection pairs is similar                        *)
-(* ------------------------------------------------------------------------ *)
-
-lemma iso_strict: 
-"!!f g.[|!y. f$(g$y)=(y::'b) ; !x. g$(f$x)=(x::'a) |]  
-  ==> f$UU=UU & g$UU=UU"
-apply (rule conjI)
-apply (rule UU_I)
-apply (rule_tac s = "f$ (g$ (UU::'b))" and t = "UU::'b" in subst)
-apply (erule spec)
-apply (rule minimal [THEN monofun_cfun_arg])
-apply (rule UU_I)
-apply (rule_tac s = "g$ (f$ (UU::'a))" and t = "UU::'a" in subst)
-apply (erule spec)
-apply (rule minimal [THEN monofun_cfun_arg])
-done
-
-
-lemma isorep_defined: "[|!x. rep$(ab$x)=x;!y. ab$(rep$y)=y; z~=UU|] ==> rep$z ~= UU"
-apply (erule contrapos_nn)
-apply (drule_tac f = "ab" in cfun_arg_cong)
-apply (erule box_equals)
-apply fast
-apply (erule iso_strict [THEN conjunct1])
-apply assumption
-done
-
-lemma isoabs_defined: "[|!x. rep$(ab$x) = x;!y. ab$(rep$y)=y ; z~=UU|] ==> ab$z ~= UU"
-apply (erule contrapos_nn)
-apply (drule_tac f = "rep" in cfun_arg_cong)
-apply (erule box_equals)
-apply fast
-apply (erule iso_strict [THEN conjunct2])
-apply assumption
-done
-
-(* ------------------------------------------------------------------------ *)
-(* propagation of flatness and chainfiniteness by continuous isomorphisms   *)
-(* ------------------------------------------------------------------------ *)
-
-lemma chfin2chfin: "!!f g.[|! Y::nat=>'a. chain Y --> (? n. max_in_chain n Y);  
-  !y. f$(g$y)=(y::'b) ; !x. g$(f$x)=(x::'a::chfin) |]  
-  ==> ! Y::nat=>'b. chain Y --> (? n. max_in_chain n Y)"
-apply (unfold max_in_chain_def)
-apply (intro strip)
-apply (rule exE)
-apply (rule_tac P = "chain (%i. g$ (Y i))" in mp)
-apply (erule spec)
-apply (erule ch2ch_Rep_CFunR)
-apply (rule exI)
-apply (intro strip)
-apply (rule_tac s = "f$ (g$ (Y x))" and t = "Y (x) " in subst)
-apply (erule spec)
-apply (rule_tac s = "f$ (g$ (Y j))" and t = "Y (j) " in subst)
-apply (erule spec)
-apply (rule cfun_arg_cong)
-apply (rule mp)
-apply (erule spec)
-apply assumption
-done
-
-
-lemma flat2flat: "!!f g.[|!x y::'a. x<<y --> x=UU | x=y;  
-  !y. f$(g$y)=(y::'b); !x. g$(f$x)=(x::'a)|] ==> !x y::'b. x<<y --> x=UU | x=y"
-apply (intro strip)
-apply (rule disjE)
-apply (rule_tac P = "g$x<<g$y" in mp)
-apply (erule_tac [2] monofun_cfun_arg)
-apply (drule spec)
-apply (erule spec)
-apply (rule disjI1)
-apply (rule trans)
-apply (rule_tac s = "f$ (g$x) " and t = "x" in subst)
-apply (erule spec)
-apply (erule cfun_arg_cong)
-apply (rule iso_strict [THEN conjunct1])
-apply assumption
-apply assumption
-apply (rule disjI2)
-apply (rule_tac s = "f$ (g$x) " and t = "x" in subst)
-apply (erule spec)
-apply (rule_tac s = "f$ (g$y) " and t = "y" in subst)
-apply (erule spec)
-apply (erule cfun_arg_cong)
-done
-
-(* ------------------------------------------------------------------------- *)
-(* a result about functions with flat codomain                               *)
-(* ------------------------------------------------------------------------- *)
-
-lemma flat_codom: "f$(x::'a)=(c::'b::flat) ==> f$(UU::'a)=(UU::'b) | (!z. f$(z::'a)=c)"
-apply (case_tac "f$ (x::'a) = (UU::'b) ")
-apply (rule disjI1)
-apply (rule UU_I)
-apply (rule_tac s = "f$ (x) " and t = "UU::'b" in subst)
-apply assumption
-apply (rule minimal [THEN monofun_cfun_arg])
-apply (case_tac "f$ (UU::'a) = (UU::'b) ")
-apply (erule disjI1)
-apply (rule disjI2)
-apply (rule allI)
-apply (erule subst)
-apply (rule_tac a = "f$ (UU::'a) " in refl [THEN box_equals])
-apply (rule_tac fo5 = "f" in minimal [THEN monofun_cfun_arg, THEN ax_flat [THEN spec, THEN spec, THEN mp], THEN disjE])
-apply simp
-apply assumption
-apply (rule_tac fo5 = "f" in minimal [THEN monofun_cfun_arg, THEN ax_flat [THEN spec, THEN spec, THEN mp], THEN disjE])
-apply simp
-apply assumption
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* Access to definitions                                                    *)
-(* ------------------------------------------------------------------------ *)
-
-
-lemma ID1: "ID$x=x"
-apply (unfold ID_def)
-apply (subst beta_cfun)
-apply (rule cont_id)
-apply (rule refl)
-done
-
-lemma cfcomp1: "(f oo g)=(LAM x. f$(g$x))"
-apply (unfold oo_def)
-apply (subst beta_cfun)
-apply (simp (no_asm))
-apply (subst beta_cfun)
-apply (simp (no_asm))
-apply (rule refl)
-done
-
-lemma cfcomp2: "(f oo g)$x=f$(g$x)"
-apply (subst cfcomp1)
-apply (subst beta_cfun)
-apply (simp (no_asm))
-apply (rule refl)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* Show that interpretation of (pcpo,_->_) is a category                    *)
-(* The class of objects is interpretation of syntactical class pcpo         *)
-(* The class of arrows  between objects 'a and 'b is interpret. of 'a -> 'b *)
-(* The identity arrow is interpretation of ID                               *)
-(* The composition of f and g is interpretation of oo                       *)
-(* ------------------------------------------------------------------------ *)
-
-
-lemma ID2: "f oo ID = f "
-apply (rule ext_cfun)
-apply (subst cfcomp2)
-apply (subst ID1)
-apply (rule refl)
-done
-
-lemma ID3: "ID oo f = f "
-apply (rule ext_cfun)
-apply (subst cfcomp2)
-apply (subst ID1)
-apply (rule refl)
-done
-
-
-lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
-apply (rule ext_cfun)
-apply (rule_tac s = "f$ (g$ (h$x))" in trans)
-apply (subst cfcomp2)
-apply (subst cfcomp2)
-apply (rule refl)
-apply (subst cfcomp2)
-apply (subst cfcomp2)
-apply (rule refl)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Merge the different rewrite rules for the simplifier                     *)
-(* ------------------------------------------------------------------------ *)
-
-declare  ID1[simp] ID2[simp] ID3[simp] cfcomp2[simp]
-
-end
--- a/src/HOLCF/Cont.thy	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/Cont.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -6,7 +6,7 @@
     Results about continuity and monotonicity
 *)
 
-theory Cont = Fun3:
+theory Cont = FunCpo:
 
 (* 
 
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Cprod.ML	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,53 @@
+
+(* legacy ML bindings *)
+
+val less_cprod_def = thm "less_cprod_def";
+val refl_less_cprod = thm "refl_less_cprod";
+val antisym_less_cprod = thm "antisym_less_cprod";
+val trans_less_cprod = thm "trans_less_cprod";
+val inst_cprod_po = thm "inst_cprod_po";
+val less_cprod4c = thm "less_cprod4c";
+val minimal_cprod = thm "minimal_cprod";
+val UU_cprod_def = thm "UU_cprod_def";
+val least_cprod = thm "least_cprod";
+val monofun_pair1 = thm "monofun_pair1";
+val monofun_pair2 = thm "monofun_pair2";
+val monofun_pair = thm "monofun_pair";
+val monofun_fst = thm "monofun_fst";
+val monofun_snd = thm "monofun_snd";
+val lub_cprod = thm "lub_cprod";
+val thelub_cprod = thm "thelub_cprod";
+val cpo_cprod = thm "cpo_cprod";
+val cpair_def = thm "cpair_def";
+val cfst_def = thm "cfst_def";
+val csnd_def = thm "csnd_def";
+val csplit_def = thm "csplit_def";
+val CLet_def = thm "CLet_def";
+val inst_cprod_pcpo = thm "inst_cprod_pcpo";
+val Cprod3_lemma1 = thm "Cprod3_lemma1";
+val contlub_pair1 = thm "contlub_pair1";
+val Cprod3_lemma2 = thm "Cprod3_lemma2";
+val contlub_pair2 = thm "contlub_pair2";
+val cont_pair1 = thm "cont_pair1";
+val cont_pair2 = thm "cont_pair2";
+val contlub_fst = thm "contlub_fst";
+val contlub_snd = thm "contlub_snd";
+val cont_fst = thm "cont_fst";
+val cont_snd = thm "cont_snd";
+val beta_cfun_cprod = thm "beta_cfun_cprod";
+val inject_cpair = thm "inject_cpair";
+val inst_cprod_pcpo2 = thm "inst_cprod_pcpo2";
+val defined_cpair_rev = thm "defined_cpair_rev";
+val Exh_Cprod2 = thm "Exh_Cprod2";
+val cprodE = thm "cprodE";
+val cfst2 = thm "cfst2";
+val csnd2 = thm "csnd2";
+val cfst_strict = thm "cfst_strict";
+val csnd_strict = thm "csnd_strict";
+val surjective_pairing_Cprod2 = thm "surjective_pairing_Cprod2";
+val less_cprod5c = thm "less_cprod5c";
+val lub_cprod2 = thm "lub_cprod2";
+val thelub_cprod2 = thm "thelub_cprod2";
+val csplit2 = thm "csplit2";
+val csplit3 = thm "csplit3";
+val Cprod_rews = [cfst2, csnd2, csplit2]
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Cprod.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,493 @@
+(*  Title:      HOLCF/Cprod1.thy
+    ID:         $Id$
+    Author:     Franz Regensburger
+    License:    GPL (GNU GENERAL PUBLIC LICENSE)
+
+Partial ordering for cartesian product of HOL theory prod.thy
+*)
+
+header {* The cpo of cartesian products *}
+
+theory Cprod = Cfun:
+
+defaultsort cpo
+
+instance "*"::(sq_ord,sq_ord)sq_ord ..
+
+defs (overloaded)
+
+  less_cprod_def: "p1 << p2 == (fst p1<<fst p2 & snd p1 << snd p2)"
+
+(* ------------------------------------------------------------------------ *)
+(* less_cprod is a partial order on 'a * 'b                                 *)
+(* ------------------------------------------------------------------------ *)
+
+lemma refl_less_cprod: "(p::'a*'b) << p"
+apply (unfold less_cprod_def)
+apply simp
+done
+
+lemma antisym_less_cprod: "[|(p1::'a * 'b) << p2;p2 << p1|] ==> p1=p2"
+apply (unfold less_cprod_def)
+apply (rule injective_fst_snd)
+apply (fast intro: antisym_less)
+apply (fast intro: antisym_less)
+done
+
+lemma trans_less_cprod: 
+        "[|(p1::'a*'b) << p2;p2 << p3|] ==> p1 << p3"
+apply (unfold less_cprod_def)
+apply (rule conjI)
+apply (fast intro: trans_less)
+apply (fast intro: trans_less)
+done
+
+(* Class Instance *::(pcpo,pcpo)po *)
+
+defaultsort pcpo
+
+instance "*"::(cpo,cpo)po
+apply (intro_classes)
+apply (rule refl_less_cprod)
+apply (rule antisym_less_cprod, assumption+)
+apply (rule trans_less_cprod, assumption+)
+done
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_cprod_po: "(op <<)=(%x y. fst x<<fst y & snd x<<snd y)"
+apply (fold less_cprod_def)
+apply (rule refl)
+done
+
+lemma less_cprod4c: "(x1,y1) << (x2,y2) ==> x1 << x2 & y1 << y2"
+apply (simp add: inst_cprod_po)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* type cprod is pointed                                                    *)
+(* ------------------------------------------------------------------------ *)
+
+lemma minimal_cprod: "(UU,UU)<<p"
+apply (simp (no_asm) add: inst_cprod_po)
+done
+
+lemmas UU_cprod_def = minimal_cprod [THEN minimal2UU, symmetric, standard]
+
+lemma least_cprod: "EX x::'a*'b. ALL y. x<<y"
+apply (rule_tac x = " (UU,UU) " in exI)
+apply (rule minimal_cprod [THEN allI])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Pair <_,_>  is monotone in both arguments                                *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_pair1: "monofun Pair"
+
+apply (unfold monofun)
+apply (intro strip)
+apply (rule less_fun [THEN iffD2])
+apply (intro strip)
+apply (simp (no_asm_simp) add: inst_cprod_po)
+done
+
+lemma monofun_pair2: "monofun(Pair x)"
+apply (unfold monofun)
+apply (simp (no_asm_simp) add: inst_cprod_po)
+done
+
+lemma monofun_pair: "[|x1<<x2; y1<<y2|] ==> (x1::'a::cpo,y1::'b::cpo)<<(x2,y2)"
+apply (rule trans_less)
+apply (erule monofun_pair1 [THEN monofunE, THEN spec, THEN spec, THEN mp, THEN less_fun [THEN iffD1, THEN spec]])
+apply (erule monofun_pair2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* fst and snd are monotone                                                 *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_fst: "monofun fst"
+apply (unfold monofun)
+apply (intro strip)
+apply (rule_tac p = "x" in PairE)
+apply (rule_tac p = "y" in PairE)
+apply simp
+apply (erule less_cprod4c [THEN conjunct1])
+done
+
+lemma monofun_snd: "monofun snd"
+apply (unfold monofun)
+apply (intro strip)
+apply (rule_tac p = "x" in PairE)
+apply (rule_tac p = "y" in PairE)
+apply simp
+apply (erule less_cprod4c [THEN conjunct2])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* the type 'a * 'b is a cpo                                                *)
+(* ------------------------------------------------------------------------ *)
+
+lemma lub_cprod: 
+"chain S ==> range S<<|(lub(range(%i. fst(S i))),lub(range(%i. snd(S i))))"
+apply (rule is_lubI)
+apply (rule ub_rangeI)
+apply (rule_tac t = "S i" in surjective_pairing [THEN ssubst])
+apply (rule monofun_pair)
+apply (rule is_ub_thelub)
+apply (erule monofun_fst [THEN ch2ch_monofun])
+apply (rule is_ub_thelub)
+apply (erule monofun_snd [THEN ch2ch_monofun])
+apply (rule_tac t = "u" in surjective_pairing [THEN ssubst])
+apply (rule monofun_pair)
+apply (rule is_lub_thelub)
+apply (erule monofun_fst [THEN ch2ch_monofun])
+apply (erule monofun_fst [THEN ub2ub_monofun])
+apply (rule is_lub_thelub)
+apply (erule monofun_snd [THEN ch2ch_monofun])
+apply (erule monofun_snd [THEN ub2ub_monofun])
+done
+
+lemmas thelub_cprod = lub_cprod [THEN thelubI, standard]
+(*
+"chain ?S1 ==>
+ lub (range ?S1) =
+ (lub (range (%i. fst (?S1 i))), lub (range (%i. snd (?S1 i))))" : thm
+
+*)
+
+lemma cpo_cprod: "chain(S::nat=>'a::cpo*'b::cpo)==>EX x. range S<<| x"
+apply (rule exI)
+apply (erule lub_cprod)
+done
+
+(* Class instance of * for class pcpo and cpo. *)
+
+instance "*" :: (cpo,cpo)cpo
+by (intro_classes, rule cpo_cprod)
+
+instance "*" :: (pcpo,pcpo)pcpo
+by (intro_classes, rule least_cprod)
+
+consts
+        cpair        :: "'a::cpo -> 'b::cpo -> ('a*'b)" (* continuous pairing *)
+        cfst         :: "('a::cpo*'b::cpo)->'a"
+        csnd         :: "('a::cpo*'b::cpo)->'b"
+        csplit       :: "('a::cpo->'b::cpo->'c::cpo)->('a*'b)->'c"
+
+syntax
+        "@ctuple"    :: "['a, args] => 'a * 'b"         ("(1<_,/ _>)")
+
+translations
+        "<x, y, z>"   == "<x, <y, z>>"
+        "<x, y>"      == "cpair$x$y"
+
+defs
+cpair_def:       "cpair  == (LAM x y.(x,y))"
+cfst_def:        "cfst   == (LAM p. fst(p))"
+csnd_def:        "csnd   == (LAM p. snd(p))"      
+csplit_def:      "csplit == (LAM f p. f$(cfst$p)$(csnd$p))"
+
+
+
+(* introduce syntax for
+
+   Let <x,y> = e1; z = E2 in E3
+
+   and
+
+   LAM <x,y,z>.e
+*)
+
+constdefs
+  CLet           :: "'a -> ('a -> 'b) -> 'b"
+  "CLet == LAM s f. f$s"
+
+
+(* syntax for Let *)
+
+nonterminals
+  Cletbinds  Cletbind
+
+syntax
+  "_Cbind"  :: "[pttrn, 'a] => Cletbind"             ("(2_ =/ _)" 10)
+  ""        :: "Cletbind => Cletbinds"               ("_")
+  "_Cbinds" :: "[Cletbind, Cletbinds] => Cletbinds"  ("_;/ _")
+  "_CLet"   :: "[Cletbinds, 'a] => 'a"               ("(Let (_)/ in (_))" 10)
+
+translations
+  "_CLet (_Cbinds b bs) e"  == "_CLet b (_CLet bs e)"
+  "Let x = a in e"          == "CLet$a$(LAM x. e)"
+
+
+(* syntax for LAM <x,y,z>.e *)
+
+syntax
+  "_LAM"    :: "[patterns, 'a => 'b] => ('a -> 'b)"  ("(3LAM <_>./ _)" [0, 10] 10)
+
+translations
+  "LAM <x,y,zs>.b"        == "csplit$(LAM x. LAM <y,zs>.b)"
+  "LAM <x,y>. LAM zs. b"  <= "csplit$(LAM x y zs. b)"
+  "LAM <x,y>.b"           == "csplit$(LAM x y. b)"
+
+syntax (xsymbols)
+  "_LAM"    :: "[patterns, 'a => 'b] => ('a -> 'b)"  ("(3\\<Lambda>()<_>./ _)" [0, 10] 10)
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_cprod_pcpo: "UU = (UU,UU)"
+apply (simp add: UU_cprod_def[folded UU_def])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* continuity of (_,_) , fst, snd                                           *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Cprod3_lemma1: 
+"chain(Y::(nat=>'a::cpo)) ==> 
+  (lub(range(Y)),(x::'b::cpo)) = 
+  (lub(range(%i. fst(Y i,x))),lub(range(%i. snd(Y i,x))))"
+apply (rule_tac f1 = "Pair" in arg_cong [THEN cong])
+apply (rule lub_equal)
+apply assumption
+apply (rule monofun_fst [THEN ch2ch_monofun])
+apply (rule ch2ch_fun)
+apply (rule monofun_pair1 [THEN ch2ch_monofun])
+apply assumption
+apply (rule allI)
+apply (simp (no_asm))
+apply (rule sym)
+apply (simp (no_asm))
+apply (rule lub_const [THEN thelubI])
+done
+
+lemma contlub_pair1: "contlub(Pair)"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule expand_fun_eq [THEN iffD2])
+apply (intro strip)
+apply (subst lub_fun [THEN thelubI])
+apply (erule monofun_pair1 [THEN ch2ch_monofun])
+apply (rule trans)
+apply (rule_tac [2] thelub_cprod [symmetric])
+apply (rule_tac [2] ch2ch_fun)
+apply (erule_tac [2] monofun_pair1 [THEN ch2ch_monofun])
+apply (erule Cprod3_lemma1)
+done
+
+lemma Cprod3_lemma2: 
+"chain(Y::(nat=>'a::cpo)) ==> 
+  ((x::'b::cpo),lub(range Y)) = 
+  (lub(range(%i. fst(x,Y i))),lub(range(%i. snd(x, Y i))))"
+apply (rule_tac f1 = "Pair" in arg_cong [THEN cong])
+apply (rule sym)
+apply (simp (no_asm))
+apply (rule lub_const [THEN thelubI])
+apply (rule lub_equal)
+apply assumption
+apply (rule monofun_snd [THEN ch2ch_monofun])
+apply (rule monofun_pair2 [THEN ch2ch_monofun])
+apply assumption
+apply (rule allI)
+apply (simp (no_asm))
+done
+
+lemma contlub_pair2: "contlub(Pair(x))"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule trans)
+apply (rule_tac [2] thelub_cprod [symmetric])
+apply (erule_tac [2] monofun_pair2 [THEN ch2ch_monofun])
+apply (erule Cprod3_lemma2)
+done
+
+lemma cont_pair1: "cont(Pair)"
+apply (rule monocontlub2cont)
+apply (rule monofun_pair1)
+apply (rule contlub_pair1)
+done
+
+lemma cont_pair2: "cont(Pair(x))"
+apply (rule monocontlub2cont)
+apply (rule monofun_pair2)
+apply (rule contlub_pair2)
+done
+
+lemma contlub_fst: "contlub(fst)"
+apply (rule contlubI)
+apply (intro strip)
+apply (subst lub_cprod [THEN thelubI])
+apply assumption
+apply (simp (no_asm))
+done
+
+lemma contlub_snd: "contlub(snd)"
+apply (rule contlubI)
+apply (intro strip)
+apply (subst lub_cprod [THEN thelubI])
+apply assumption
+apply (simp (no_asm))
+done
+
+lemma cont_fst: "cont(fst)"
+apply (rule monocontlub2cont)
+apply (rule monofun_fst)
+apply (rule contlub_fst)
+done
+
+lemma cont_snd: "cont(snd)"
+apply (rule monocontlub2cont)
+apply (rule monofun_snd)
+apply (rule contlub_snd)
+done
+
+(* 
+ -------------------------------------------------------------------------- 
+ more lemmas for Cprod3.thy 
+ 
+ -------------------------------------------------------------------------- 
+*)
+
+(* ------------------------------------------------------------------------ *)
+(* convert all lemmas to the continuous versions                            *)
+(* ------------------------------------------------------------------------ *)
+
+lemma beta_cfun_cprod: 
+        "(LAM x y.(x,y))$a$b = (a,b)"
+apply (subst beta_cfun)
+apply (simp (no_asm) add: cont_pair1 cont_pair2 cont2cont_CF1L)
+apply (subst beta_cfun)
+apply (rule cont_pair2)
+apply (rule refl)
+done
+
+lemma inject_cpair: 
+        "<a,b> = <aa,ba>  ==> a=aa & b=ba"
+apply (unfold cpair_def)
+apply (drule beta_cfun_cprod [THEN subst])
+apply (drule beta_cfun_cprod [THEN subst])
+apply (erule Pair_inject)
+apply fast
+done
+
+lemma inst_cprod_pcpo2: "UU = <UU,UU>"
+apply (unfold cpair_def)
+apply (rule sym)
+apply (rule trans)
+apply (rule beta_cfun_cprod)
+apply (rule sym)
+apply (rule inst_cprod_pcpo)
+done
+
+lemma defined_cpair_rev: 
+ "<a,b> = UU ==> a = UU & b = UU"
+apply (drule inst_cprod_pcpo2 [THEN subst])
+apply (erule inject_cpair)
+done
+
+lemma Exh_Cprod2:
+        "? a b. z=<a,b>"
+apply (unfold cpair_def)
+apply (rule PairE)
+apply (rule exI)
+apply (rule exI)
+apply (erule beta_cfun_cprod [THEN ssubst])
+done
+
+lemma cprodE:
+assumes prems: "!!x y. [| p = <x,y> |] ==> Q"
+shows "Q"
+apply (rule PairE)
+apply (rule prems)
+apply (unfold cpair_def)
+apply (erule beta_cfun_cprod [THEN ssubst])
+done
+
+lemma cfst2: 
+        "cfst$<x,y> = x"
+apply (unfold cfst_def cpair_def)
+apply (subst beta_cfun_cprod)
+apply (subst beta_cfun)
+apply (rule cont_fst)
+apply (simp (no_asm))
+done
+
+lemma csnd2: 
+        "csnd$<x,y> = y"
+apply (unfold csnd_def cpair_def)
+apply (subst beta_cfun_cprod)
+apply (subst beta_cfun)
+apply (rule cont_snd)
+apply (simp (no_asm))
+done
+
+lemma cfst_strict: "cfst$UU = UU"
+apply (simp add: inst_cprod_pcpo2 cfst2)
+done
+
+lemma csnd_strict: "csnd$UU = UU"
+apply (simp add: inst_cprod_pcpo2 csnd2)
+done
+
+lemma surjective_pairing_Cprod2: "<cfst$p , csnd$p> = p"
+apply (unfold cfst_def csnd_def cpair_def)
+apply (subst beta_cfun_cprod)
+apply (simplesubst beta_cfun)
+apply (rule cont_snd)
+apply (subst beta_cfun)
+apply (rule cont_fst)
+apply (rule surjective_pairing [symmetric])
+done
+
+lemma less_cprod5c: 
+ "<xa,ya> << <x,y> ==> xa<<x & ya << y"
+apply (unfold cfst_def csnd_def cpair_def)
+apply (rule less_cprod4c)
+apply (drule beta_cfun_cprod [THEN subst])
+apply (drule beta_cfun_cprod [THEN subst])
+apply assumption
+done
+
+lemma lub_cprod2: 
+"[|chain(S)|] ==> range(S) <<|  
+  <(lub(range(%i. cfst$(S i)))) , lub(range(%i. csnd$(S i)))>"
+apply (unfold cfst_def csnd_def cpair_def)
+apply (subst beta_cfun_cprod)
+apply (simplesubst beta_cfun [THEN ext])
+apply (rule cont_snd)
+apply (subst beta_cfun [THEN ext])
+apply (rule cont_fst)
+apply (rule lub_cprod)
+apply assumption
+done
+
+lemmas thelub_cprod2 = lub_cprod2 [THEN thelubI, standard]
+(*
+chain ?S1 ==>
+ lub (range ?S1) =
+ <lub (range (%i. cfst$(?S1 i))), lub (range (%i. csnd$(?S1 i)))>" 
+*)
+lemma csplit2: 
+        "csplit$f$<x,y> = f$x$y"
+apply (unfold csplit_def)
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (simp (no_asm) add: cfst2 csnd2)
+done
+
+lemma csplit3: 
+  "csplit$cpair$z=z"
+apply (unfold csplit_def)
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (simp (no_asm) add: surjective_pairing_Cprod2)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* install simplifier for Cprod                                             *)
+(* ------------------------------------------------------------------------ *)
+
+declare cfst2 [simp] csnd2 [simp] csplit2 [simp]
+
+lemmas Cprod_rews = cfst2 csnd2 csplit2
+
+end
--- a/src/HOLCF/Cprod1.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-(*  Title:      HOLCF/Cprod1.ML
-    ID:         $Id$
-    Author:     Franz Regensburger
-
-Partial ordering for cartesian product of HOL theory Product_Type.thy
-*)
-
-
-(* ------------------------------------------------------------------------ *)
-(* less_cprod is a partial order on 'a * 'b                                 *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [less_cprod_def] "(p::'a*'b) << p";
-by (Simp_tac 1);
-qed "refl_less_cprod";
-
-Goalw [less_cprod_def] "[|(p1::'a * 'b) << p2;p2 << p1|] ==> p1=p2";
-by (rtac injective_fst_snd 1);
-by (fast_tac (HOL_cs addIs [antisym_less]) 1);
-by (fast_tac (HOL_cs addIs [antisym_less]) 1);
-qed "antisym_less_cprod";
-
-Goalw [less_cprod_def]
-        "[|(p1::'a*'b) << p2;p2 << p3|] ==> p1 << p3";
-by (rtac conjI 1);
-by (fast_tac (HOL_cs addIs [trans_less]) 1);
-by (fast_tac (HOL_cs addIs [trans_less]) 1);
-qed "trans_less_cprod";
--- a/src/HOLCF/Cprod1.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,18 +0,0 @@
-(*  Title:      HOLCF/Cprod1.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-
-Partial ordering for cartesian product of HOL theory prod.thy
-*)
-
-Cprod1 = Cfun3 +
-
-default cpo
-
-instance "*"::(sq_ord,sq_ord)sq_ord 
-
-defs
-
-  less_cprod_def "p1 << p2 == (fst p1<<fst p2 & snd p1 << snd p2)"
-
-end
--- a/src/HOLCF/Cprod2.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,118 +0,0 @@
-(*  Title:      HOLCF/Cprod2
-    ID:         $Id$
-    Author:     Franz Regensburger
-
-Class Instance *::(pcpo,pcpo)po
-*)
-
-(* for compatibility with old HOLCF-Version *)
-Goal "(op <<)=(%x y. fst x<<fst y & snd x<<snd y)";
-by (fold_goals_tac [less_cprod_def]);
-by (rtac refl 1);
-qed "inst_cprod_po";
-
-Goal "(x1,y1) << (x2,y2) ==> x1 << x2 & y1 << y2";
-by (asm_full_simp_tac (simpset() addsimps [inst_cprod_po]) 1);
-qed "less_cprod4c";
-
-(* ------------------------------------------------------------------------ *)
-(* type cprod is pointed                                                    *)
-(* ------------------------------------------------------------------------ *)
-
-Goal  "(UU,UU)<<p";
-by (simp_tac(simpset() addsimps[inst_cprod_po])1);
-qed "minimal_cprod";
-
-bind_thm ("UU_cprod_def",minimal_cprod RS minimal2UU RS sym);
-
-Goal "EX x::'a*'b. ALL y. x<<y";
-by (res_inst_tac [("x","(UU,UU)")] exI 1);
-by (rtac (minimal_cprod RS allI) 1);
-qed "least_cprod";
-
-(* ------------------------------------------------------------------------ *)
-(* Pair <_,_>  is monotone in both arguments                                *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [monofun]  "monofun Pair";
-by (strip_tac 1);
-by (rtac (less_fun RS iffD2) 1);
-by (strip_tac 1);
-by (asm_simp_tac (simpset() addsimps [inst_cprod_po]) 1);
-qed "monofun_pair1";
-
-Goalw [monofun]  "monofun(Pair x)";
-by (asm_simp_tac (simpset() addsimps [inst_cprod_po]) 1);
-qed "monofun_pair2";
-
-Goal "[|x1<<x2; y1<<y2|] ==> (x1::'a::cpo,y1::'b::cpo)<<(x2,y2)";
-by (rtac trans_less 1);
-by (rtac (monofun_pair1 RS monofunE RS spec RS spec RS mp RS (less_fun RS iffD1 RS spec)) 1);
-by (rtac (monofun_pair2 RS monofunE RS spec RS spec RS mp) 2);
-by (atac 1);
-by (atac 1);
-qed "monofun_pair";
-
-(* ------------------------------------------------------------------------ *)
-(* fst and snd are monotone                                                 *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [monofun]  "monofun fst";
-by (strip_tac 1);
-by (res_inst_tac [("p","x")] PairE 1);
-by (hyp_subst_tac 1);
-by (res_inst_tac [("p","y")] PairE 1);
-by (hyp_subst_tac 1);
-by (Asm_simp_tac  1);
-by (etac (less_cprod4c RS conjunct1) 1);
-qed "monofun_fst";
-
-Goalw [monofun]  "monofun snd";
-by (strip_tac 1);
-by (res_inst_tac [("p","x")] PairE 1);
-by (hyp_subst_tac 1);
-by (res_inst_tac [("p","y")] PairE 1);
-by (hyp_subst_tac 1);
-by (Asm_simp_tac  1);
-by (etac (less_cprod4c RS conjunct2) 1);
-qed "monofun_snd";
-
-(* ------------------------------------------------------------------------ *)
-(* the type 'a * 'b is a cpo                                                *)
-(* ------------------------------------------------------------------------ *)
-
-Goal 
-"chain S ==> range S<<|(lub(range(%i. fst(S i))),lub(range(%i. snd(S i))))";
-by (rtac (is_lubI) 1);
-by (rtac (ub_rangeI) 1);
-by (res_inst_tac [("t","S i")] (surjective_pairing RS ssubst) 1);
-by (rtac monofun_pair 1);
-by (rtac is_ub_thelub 1);
-by (etac (monofun_fst RS ch2ch_monofun) 1);
-by (rtac is_ub_thelub 1);
-by (etac (monofun_snd RS ch2ch_monofun) 1);
-by (strip_tac 1);
-by (res_inst_tac [("t","u")] (surjective_pairing RS ssubst) 1);
-by (rtac monofun_pair 1);
-by (rtac is_lub_thelub 1);
-by (etac (monofun_fst RS ch2ch_monofun) 1);
-by (etac (monofun_fst RS ub2ub_monofun) 1);
-by (rtac is_lub_thelub 1);
-by (etac (monofun_snd RS ch2ch_monofun) 1);
-by (etac (monofun_snd RS ub2ub_monofun) 1);
-qed "lub_cprod";
-
-bind_thm ("thelub_cprod", lub_cprod RS thelubI);
-(*
-"chain ?S1 ==>
- lub (range ?S1) =
- (lub (range (%i. fst (?S1 i))), lub (range (%i. snd (?S1 i))))" : thm
-
-*)
-
-Goal "chain(S::nat=>'a::cpo*'b::cpo)==>EX x. range S<<| x";
-by (rtac exI 1);
-by (etac lub_cprod 1);
-qed "cpo_cprod";
-
-
--- a/src/HOLCF/Cprod2.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,18 +0,0 @@
-(*  Title:      HOLCF/Cprod2.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-
-Class Instance *::(pcpo,pcpo)po
-
-*)
-
-Cprod2 = Cprod1 + 
-
-default pcpo
-
-instance "*"::(cpo,cpo)po 
-	(refl_less_cprod,antisym_less_cprod,trans_less_cprod)
-end
-
-
-
--- a/src/HOLCF/Cprod3.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,250 +0,0 @@
-(*  Title:      HOLCF/Cprod3
-    ID:         $Id$
-    Author:     Franz Regensburger
-
-Class instance of * for class pcpo and cpo.
-*)
-
-(* for compatibility with old HOLCF-Version *)
-Goal "UU = (UU,UU)";
-by (simp_tac (HOL_ss addsimps [UU_def,UU_cprod_def]) 1);
-qed "inst_cprod_pcpo";
-
-(* ------------------------------------------------------------------------ *)
-(* continuity of (_,_) , fst, snd                                           *)
-(* ------------------------------------------------------------------------ *)
-
-Goal 
-"chain(Y::(nat=>'a::cpo)) ==>\
-\ (lub(range(Y)),(x::'b::cpo)) =\
-\ (lub(range(%i. fst(Y i,x))),lub(range(%i. snd(Y i,x))))";
-by (res_inst_tac [("f1","Pair")] (arg_cong RS cong) 1);
-by (rtac lub_equal 1);
-by (atac 1);
-by (rtac (monofun_fst RS ch2ch_monofun) 1);
-by (rtac ch2ch_fun 1);
-by (rtac (monofun_pair1 RS ch2ch_monofun) 1);
-by (atac 1);
-by (rtac allI 1);
-by (Simp_tac 1);
-by (rtac sym 1);
-by (Simp_tac 1);
-by (rtac (lub_const RS thelubI) 1);
-qed "Cprod3_lemma1";
-
-Goal "contlub(Pair)";
-by (rtac contlubI 1);
-by (strip_tac 1);
-by (rtac (expand_fun_eq RS iffD2) 1);
-by (strip_tac 1);
-by (stac (lub_fun RS thelubI) 1);
-by (etac (monofun_pair1 RS ch2ch_monofun) 1);
-by (rtac trans 1);
-by (rtac (thelub_cprod RS sym) 2);
-by (rtac ch2ch_fun 2);
-by (etac (monofun_pair1 RS ch2ch_monofun) 2);
-by (etac Cprod3_lemma1 1);
-qed "contlub_pair1";
-
-Goal 
-"chain(Y::(nat=>'a::cpo)) ==>\
-\ ((x::'b::cpo),lub(range Y)) =\
-\ (lub(range(%i. fst(x,Y i))),lub(range(%i. snd(x, Y i))))";
-by (res_inst_tac [("f1","Pair")] (arg_cong RS cong) 1);
-by (rtac sym 1);
-by (Simp_tac 1);
-by (rtac (lub_const RS thelubI) 1);
-by (rtac lub_equal 1);
-by (atac 1);
-by (rtac (monofun_snd RS ch2ch_monofun) 1);
-by (rtac (monofun_pair2 RS ch2ch_monofun) 1);
-by (atac 1);
-by (rtac allI 1);
-by (Simp_tac 1);
-qed "Cprod3_lemma2";
-
-Goal "contlub(Pair(x))";
-by (rtac contlubI 1);
-by (strip_tac 1);
-by (rtac trans 1);
-by (rtac (thelub_cprod RS sym) 2);
-by (etac (monofun_pair2 RS ch2ch_monofun) 2);
-by (etac Cprod3_lemma2 1);
-qed "contlub_pair2";
-
-Goal "cont(Pair)";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_pair1 1);
-by (rtac contlub_pair1 1);
-qed "cont_pair1";
-
-Goal "cont(Pair(x))";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_pair2 1);
-by (rtac contlub_pair2 1);
-qed "cont_pair2";
-
-Goal "contlub(fst)";
-by (rtac contlubI 1);
-by (strip_tac 1);
-by (stac (lub_cprod RS thelubI) 1);
-by (atac 1);
-by (Simp_tac 1);
-qed "contlub_fst";
-
-Goal "contlub(snd)";
-by (rtac contlubI 1);
-by (strip_tac 1);
-by (stac (lub_cprod RS thelubI) 1);
-by (atac 1);
-by (Simp_tac 1);
-qed "contlub_snd";
-
-Goal "cont(fst)";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_fst 1);
-by (rtac contlub_fst 1);
-qed "cont_fst";
-
-Goal "cont(snd)";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_snd 1);
-by (rtac contlub_snd 1);
-qed "cont_snd";
-
-(* 
- -------------------------------------------------------------------------- 
- more lemmas for Cprod3.thy 
- 
- -------------------------------------------------------------------------- 
-*)
-
-(* ------------------------------------------------------------------------ *)
-(* convert all lemmas to the continuous versions                            *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [cpair_def]
-        "(LAM x y.(x,y))$a$b = (a,b)";
-by (stac beta_cfun 1);
-by (simp_tac (simpset() addsimps [cont_pair1,cont_pair2,cont2cont_CF1L]) 1);
-by (stac beta_cfun 1);
-by (rtac cont_pair2 1);
-by (rtac refl 1);
-qed "beta_cfun_cprod";
-
-Goalw [cpair_def]
-        " <a,b> = <aa,ba>  ==> a=aa & b=ba";
-by (dtac (beta_cfun_cprod RS subst) 1);
-by (dtac (beta_cfun_cprod RS subst) 1);
-by (etac Pair_inject 1);
-by (fast_tac HOL_cs 1);
-qed "inject_cpair";
-
-Goalw [cpair_def] "UU = <UU,UU>";
-by (rtac sym 1);
-by (rtac trans 1);
-by (rtac beta_cfun_cprod 1);
-by (rtac sym 1);
-by (rtac inst_cprod_pcpo 1);
-qed "inst_cprod_pcpo2";
-
-Goal
- "<a,b> = UU ==> a = UU & b = UU";
-by (dtac (inst_cprod_pcpo2 RS subst) 1);
-by (etac inject_cpair 1);
-qed "defined_cpair_rev";
-
-Goalw [cpair_def]
-        "? a b. z=<a,b>";
-by (rtac PairE 1);
-by (rtac exI 1);
-by (rtac exI 1);
-by (etac (beta_cfun_cprod RS ssubst) 1);
-qed "Exh_Cprod2";
-
-val prems = Goalw [cpair_def] "[|!!x y. [|p=<x,y> |] ==> Q|] ==> Q";
-by (rtac PairE 1);
-by (resolve_tac prems 1);
-by (etac (beta_cfun_cprod RS ssubst) 1);
-qed "cprodE";
-
-Goalw [cfst_def,cpair_def] 
-        "cfst$<x,y> = x";
-by (stac beta_cfun_cprod 1);
-by (stac beta_cfun 1);
-by (rtac cont_fst 1);
-by (Simp_tac  1);
-qed "cfst2";
-
-Goalw [csnd_def,cpair_def] 
-        "csnd$<x,y> = y";
-by (stac beta_cfun_cprod 1);
-by (stac beta_cfun 1);
-by (rtac cont_snd 1);
-by (Simp_tac  1);
-qed "csnd2";
-
-Goal "cfst$UU = UU";
-by (simp_tac (HOL_ss addsimps [inst_cprod_pcpo2,cfst2]) 1);
-qed "cfst_strict";
-
-Goal "csnd$UU = UU";
-by (simp_tac (HOL_ss addsimps [inst_cprod_pcpo2,csnd2]) 1);
-qed "csnd_strict";
-
-Goalw [cfst_def,csnd_def,cpair_def] "<cfst$p , csnd$p> = p";
-by (stac beta_cfun_cprod 1);
-by (stac beta_cfun 1);
-by (rtac cont_snd 1);
-by (stac beta_cfun 1);
-by (rtac cont_fst 1);
-by (rtac (surjective_pairing RS sym) 1);
-qed "surjective_pairing_Cprod2";
-
-Goalw [cfst_def,csnd_def,cpair_def]
- "<xa,ya> << <x,y> ==> xa<<x & ya << y";
-by (rtac less_cprod4c 1);
-by (dtac (beta_cfun_cprod RS subst) 1);
-by (dtac (beta_cfun_cprod RS subst) 1);
-by (atac 1);
-qed "less_cprod5c";
-
-Goalw [cfst_def,csnd_def,cpair_def]
-"[|chain(S)|] ==> range(S) <<| \
-\ <(lub(range(%i. cfst$(S i)))) , lub(range(%i. csnd$(S i)))>";
-by (stac beta_cfun_cprod 1);
-by (stac (beta_cfun RS ext) 1);
-by (rtac cont_snd 1);
-by (stac (beta_cfun RS ext) 1);
-by (rtac cont_fst 1);
-by (rtac lub_cprod 1);
-by (atac 1);
-qed "lub_cprod2";
-
-bind_thm ("thelub_cprod2", lub_cprod2 RS thelubI);
-(*
-chain ?S1 ==>
- lub (range ?S1) =
- <lub (range (%i. cfst$(?S1 i))), lub (range (%i. csnd$(?S1 i)))>" 
-*)
-Goalw [csplit_def]
-        "csplit$f$<x,y> = f$x$y";
-by (stac beta_cfun 1);
-by (Simp_tac 1);
-by (simp_tac (simpset() addsimps [cfst2,csnd2]) 1);
-qed "csplit2";
-
-Goalw [csplit_def]
-  "csplit$cpair$z=z";
-by (stac beta_cfun 1);
-by (Simp_tac 1);
-by (simp_tac (simpset() addsimps [surjective_pairing_Cprod2]) 1);
-qed "csplit3";
-
-(* ------------------------------------------------------------------------ *)
-(* install simplifier for Cprod                                             *)
-(* ------------------------------------------------------------------------ *)
-
-Addsimps [cfst2,csnd2,csplit2];
-
-val Cprod_rews = [cfst2,csnd2,csplit2];
--- a/src/HOLCF/Cprod3.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,77 +0,0 @@
-(*  Title:      HOLCF/Cprod3.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-
-Class instance of * for class pcpo and cpo.
-*)
-
-Cprod3 = Cprod2 +
-
-instance "*" :: (cpo,cpo)cpo   	  (cpo_cprod)
-instance "*" :: (pcpo,pcpo)pcpo   (least_cprod)
-
-consts
-        cpair        :: "'a -> 'b -> ('a*'b)" (* continuous pairing *)
-        cfst         :: "('a*'b)->'a"
-        csnd         :: "('a*'b)->'b"
-        csplit       :: "('a->'b->'c)->('a*'b)->'c"
-
-syntax
-        "@ctuple"    :: "['a, args] => 'a * 'b"         ("(1<_,/ _>)")
-
-translations
-        "<x, y, z>"   == "<x, <y, z>>"
-        "<x, y>"      == "cpair$x$y"
-
-defs
-cpair_def       "cpair  == (LAM x y.(x,y))"
-cfst_def        "cfst   == (LAM p. fst(p))"
-csnd_def        "csnd   == (LAM p. snd(p))"      
-csplit_def      "csplit == (LAM f p. f$(cfst$p)$(csnd$p))"
-
-
-
-(* introduce syntax for
-
-   Let <x,y> = e1; z = E2 in E3
-
-   and
-
-   LAM <x,y,z>.e
-*)
-
-constdefs
-  CLet           :: "'a -> ('a -> 'b) -> 'b"
-  "CLet == LAM s f. f$s"
-
-
-(* syntax for Let *)
-
-nonterminals
-  Cletbinds  Cletbind
-
-syntax
-  "_Cbind"  :: "[pttrn, 'a] => Cletbind"             ("(2_ =/ _)" 10)
-  ""        :: "Cletbind => Cletbinds"               ("_")
-  "_Cbinds" :: "[Cletbind, Cletbinds] => Cletbinds"  ("_;/ _")
-  "_CLet"   :: "[Cletbinds, 'a] => 'a"               ("(Let (_)/ in (_))" 10)
-
-translations
-  "_CLet (_Cbinds b bs) e"  == "_CLet b (_CLet bs e)"
-  "Let x = a in e"          == "CLet$a$(LAM x. e)"
-
-
-(* syntax for LAM <x,y,z>.e *)
-
-syntax
-  "_LAM"    :: "[patterns, 'a => 'b] => ('a -> 'b)"  ("(3LAM <_>./ _)" [0, 10] 10)
-
-translations
-  "LAM <x,y,zs>.b"        == "csplit$(LAM x. LAM <y,zs>.b)"
-  "LAM <x,y>. LAM zs. b"  <= "csplit$(LAM x y zs. b)"
-  "LAM <x,y>.b"           == "csplit$(LAM x y. b)"
-
-syntax (xsymbols)
-  "_LAM"    :: "[patterns, 'a => 'b] => ('a -> 'b)"  ("(3\\<Lambda>()<_>./ _)" [0, 10] 10)
-
-end
--- a/src/HOLCF/Fix.ML	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/Fix.ML	Fri Mar 04 23:12:36 2005 +0100
@@ -1,297 +1,93 @@
-(*  Title:      HOLCF/Fix.ML
-    ID:         $Id$
-    Author:     Franz Regensburger
 
-fixed point operator and admissibility
-*)
-
-(* ------------------------------------------------------------------------ *)
-(* derive inductive properties of iterate from primitive recursion          *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "iterate (Suc n) F x = iterate n F (F$x)";
-by (induct_tac "n" 1);
-by Auto_tac;  
-qed "iterate_Suc2";
-
-(* ------------------------------------------------------------------------ *)
-(* the sequence of function itertaions is a chain                           *)
-(* This property is essential since monotonicity of iterate makes no sense  *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [chain_def]  "x << F$x ==> chain (%i. iterate i F x)";
-by (strip_tac 1);
-by (induct_tac "i" 1);
-by Auto_tac;  
-by (etac monofun_cfun_arg 1);
-qed "chain_iterate2";
-
-
-Goal "chain (%i. iterate i F UU)";
-by (rtac chain_iterate2 1);
-by (rtac minimal 1);
-qed "chain_iterate";
-
-
-(* ------------------------------------------------------------------------ *)
-(* Kleene's fixed point theorems for continuous functions in pointed        *)
-(* omega cpo's                                                              *)
-(* ------------------------------------------------------------------------ *)
-
-
-Goalw [Ifix_def] "Ifix F =F$(Ifix F)";
-by (stac contlub_cfun_arg 1);
-by (rtac chain_iterate 1);
-by (rtac antisym_less 1);
-by (rtac lub_mono 1);
-by (rtac chain_iterate 1);
-by (rtac ch2ch_Rep_CFunR 1);
-by (rtac chain_iterate 1);
-by (rtac allI 1);
-by (rtac (iterate_Suc RS subst) 1);
-by (rtac (chain_iterate RS chainE) 1);
-by (rtac is_lub_thelub 1);
-by (rtac ch2ch_Rep_CFunR 1);
-by (rtac chain_iterate 1);
-by (rtac ub_rangeI 1);
-by (rtac (iterate_Suc RS subst) 1);
-by (rtac is_ub_thelub 1);
-by (rtac chain_iterate 1);
-qed "Ifix_eq";
-
-
-Goalw [Ifix_def] "F$x=x ==> Ifix(F) << x";
-by (rtac is_lub_thelub 1);
-by (rtac chain_iterate 1);
-by (rtac ub_rangeI 1);
-by (strip_tac 1);
-by (induct_tac "i" 1);
-by (Asm_simp_tac 1);
-by (Asm_simp_tac 1);
-by (res_inst_tac [("t","x")] subst 1);
-by (atac 1);
-by (etac monofun_cfun_arg 1);
-qed "Ifix_least";
-
-
-(* ------------------------------------------------------------------------ *)
-(* monotonicity and continuity of iterate                                   *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [monofun] "monofun(iterate(i))";
-by (strip_tac 1);
-by (induct_tac "i" 1);
-by (Asm_simp_tac 1);
-by (asm_full_simp_tac (simpset() addsimps [less_fun, monofun_cfun]) 1);
-qed "monofun_iterate";
-
-(* ------------------------------------------------------------------------ *)
-(* the following lemma uses contlub_cfun which itself is based on a         *)
-(* diagonalisation lemma for continuous functions with two arguments.       *)
-(* In this special case it is the application function Rep_CFun                 *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [contlub] "contlub(iterate(i))";
-by (strip_tac 1);
-by (induct_tac "i" 1);
-by (Asm_simp_tac 1);
-by (rtac (lub_const RS thelubI RS sym) 1);
-by (asm_simp_tac (simpset() delsimps [range_composition]) 1);
-by (rtac ext 1);
-by (stac thelub_fun 1);
-by (rtac chainI 1);
-by (rtac (less_fun RS iffD2) 1);
-by (rtac allI 1);
-by (rtac (chainE) 1);
-by (rtac (monofun_Rep_CFun1 RS ch2ch_MF2LR) 1);
-by (rtac allI 1);
-by (rtac monofun_Rep_CFun2 1);
-by (atac 1);
-by (rtac ch2ch_fun 1);
-by (rtac (monofun_iterate RS ch2ch_monofun) 1);
-by (atac 1);
-by (stac thelub_fun 1);
-by (rtac (monofun_iterate RS ch2ch_monofun) 1);
-by (atac 1);
-by (rtac contlub_cfun  1);
-by (atac 1);
-by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun) 1);
-qed "contlub_iterate";
-
-
-Goal "cont(iterate(i))";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_iterate 1);
-by (rtac contlub_iterate 1);
-qed "cont_iterate";
-
-(* ------------------------------------------------------------------------ *)
-(* a lemma about continuity of iterate in its third argument                *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "monofun(iterate n F)";
-by (rtac monofunI 1);
-by (strip_tac 1);
-by (induct_tac "n" 1);
-by (Asm_simp_tac 1);
-by (Asm_simp_tac 1);
-by (etac monofun_cfun_arg 1);
-qed "monofun_iterate2";
+(* legacy ML bindings *)
 
-Goal "contlub(iterate n F)";
-by (rtac contlubI 1);
-by (strip_tac 1);
-by (induct_tac "n" 1);
-by (Simp_tac 1);
-by (Simp_tac 1);
-by (res_inst_tac [("t","iterate n F (lub(range(%u. Y u)))"),
-                  ("s","lub(range(%i. iterate n F (Y i)))")] ssubst 1);
-by (atac 1);
-by (rtac contlub_cfun_arg 1);
-by (etac (monofun_iterate2 RS ch2ch_monofun) 1);
-qed "contlub_iterate2";
-
-Goal "cont (iterate n F)";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_iterate2 1);
-by (rtac contlub_iterate2 1);
-qed "cont_iterate2";
-
-(* ------------------------------------------------------------------------ *)
-(* monotonicity and continuity of Ifix                                      *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [monofun,Ifix_def] "monofun(Ifix)";
-by (strip_tac 1);
-by (rtac lub_mono 1);
-by (rtac chain_iterate 1);
-by (rtac chain_iterate 1);
-by (rtac allI 1);
-by (rtac (less_fun RS iffD1 RS spec) 1 THEN
-    etac (monofun_iterate RS monofunE RS spec RS spec RS mp) 1);
-qed "monofun_Ifix";
-
-(* ------------------------------------------------------------------------ *)
-(* since iterate is not monotone in its first argument, special lemmas must *)
-(* be derived for lubs in this argument                                     *)
-(* ------------------------------------------------------------------------ *)
-
-Goal   
-"chain(Y) ==> chain(%i. lub(range(%ia. iterate ia (Y i) UU)))";
-by (rtac chainI 1);
-by (strip_tac 1);
-by (rtac lub_mono 1);
-by (rtac chain_iterate 1);
-by (rtac chain_iterate 1);
-by (strip_tac 1);
-by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun RS chainE) 1);
-qed "chain_iterate_lub";
-
-(* ------------------------------------------------------------------------ *)
-(* this exchange lemma is analog to the one for monotone functions          *)
-(* observe that monotonicity is not really needed. The propagation of       *)
-(* chains is the essential argument which is usually derived from monot.    *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "chain(Y) ==>iterate n (lub(range Y)) y = lub(range(%i. iterate n (Y i) y))";
-by (rtac (thelub_fun RS subst) 1);
-by (etac (monofun_iterate RS ch2ch_monofun) 1);
-by (asm_simp_tac (simpset() addsimps [contlub_iterate RS contlubE]) 1);
-qed "contlub_Ifix_lemma1";
-
+val iterate_0 = thm "iterate_0";
+val iterate_Suc = thm "iterate_Suc";
+val Ifix_def = thm "Ifix_def";
+val fix_def = thm "fix_def";
+val adm_def = thm "adm_def";
+val admw_def = thm "admw_def";
+val iterate_Suc2 = thm "iterate_Suc2";
+val chain_iterate2 = thm "chain_iterate2";
+val chain_iterate = thm "chain_iterate";
+val Ifix_eq = thm "Ifix_eq";
+val Ifix_least = thm "Ifix_least";
+val monofun_iterate = thm "monofun_iterate";
+val contlub_iterate = thm "contlub_iterate";
+val cont_iterate = thm "cont_iterate";
+val monofun_iterate2 = thm "monofun_iterate2";
+val contlub_iterate2 = thm "contlub_iterate2";
+val cont_iterate2 = thm "cont_iterate2";
+val monofun_Ifix = thm "monofun_Ifix";
+val chain_iterate_lub = thm "chain_iterate_lub";
+val contlub_Ifix_lemma1 = thm "contlub_Ifix_lemma1";
+val ex_lub_iterate = thm "ex_lub_iterate";
+val contlub_Ifix = thm "contlub_Ifix";
+val cont_Ifix = thm "cont_Ifix";
+val fix_eq = thm "fix_eq";
+val fix_least = thm "fix_least";
+val fix_eqI = thm "fix_eqI";
+val fix_eq2 = thm "fix_eq2";
+val fix_eq3 = thm "fix_eq3";
+val fix_eq4 = thm "fix_eq4";
+val fix_eq5 = thm "fix_eq5";
+val Ifix_def2 = thm "Ifix_def2";
+val fix_def2 = thm "fix_def2";
+val admI = thm "admI";
+val triv_admI = thm "triv_admI";
+val admD = thm "admD";
+val admw_def2 = thm "admw_def2";
+val def_fix_ind = thm "def_fix_ind";
+val adm_impl_admw = thm "adm_impl_admw";
+val fix_ind = thm "fix_ind";
+val def_fix_ind = thm "def_fix_ind";
+val wfix_ind = thm "wfix_ind";
+val def_wfix_ind = thm "def_wfix_ind";
+val adm_max_in_chain = thm "adm_max_in_chain";
+val adm_chfin = thm "adm_chfin";
+val adm_chfindom = thm "adm_chfindom";
+val admI2 = thm "admI2";
+val adm_less = thm "adm_less";
+val adm_conj = thm "adm_conj";
+val adm_not_free = thm "adm_not_free";
+val adm_not_less = thm "adm_not_less";
+val adm_all = thm "adm_all";
+val adm_all2 = thm "adm_all2";
+val adm_subst = thm "adm_subst";
+val adm_UU_not_less = thm "adm_UU_not_less";
+val adm_not_UU = thm "adm_not_UU";
+val adm_eq = thm "adm_eq";
+val adm_disj_lemma1 = thm "adm_disj_lemma1";
+val adm_disj_lemma2 = thm "adm_disj_lemma2";
+val adm_disj_lemma3 = thm "adm_disj_lemma3";
+val adm_disj_lemma4 = thm "adm_disj_lemma4";
+val adm_disj_lemma5 = thm "adm_disj_lemma5";
+val adm_disj_lemma6 = thm "adm_disj_lemma6";
+val adm_disj_lemma7 = thm "adm_disj_lemma7";
+val adm_disj_lemma8 = thm "adm_disj_lemma8";
+val adm_disj_lemma9 = thm "adm_disj_lemma9";
+val adm_disj_lemma10 = thm "adm_disj_lemma10";
+val adm_disj_lemma12 = thm "adm_disj_lemma12";
+val adm_lemma11 = thm "adm_lemma11";
+val adm_disj = thm "adm_disj";
+val adm_imp = thm "adm_imp";
+val adm_iff = thm "adm_iff";
+val adm_not_conj = thm "adm_not_conj";
+val adm_lemmas = [adm_not_free, adm_imp, adm_disj, adm_eq, adm_not_UU,
+        adm_UU_not_less, adm_all2, adm_not_less, adm_not_conj, adm_iff]
 
-Goal  "chain(Y) ==>\
-\         lub(range(%i. lub(range(%ia. iterate i (Y ia) UU)))) =\
-\         lub(range(%i. lub(range(%ia. iterate ia (Y i) UU))))";
-by (rtac antisym_less 1);
-by (rtac is_lub_thelub 1);
-by (rtac (contlub_Ifix_lemma1 RS ext RS subst) 1);
-by (atac 1);
-by (rtac chain_iterate 1);
-by (rtac ub_rangeI 1);
-by (strip_tac 1);
-by (rtac lub_mono 1);
-by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun) 1);
-by (etac chain_iterate_lub 1);
-by (strip_tac 1);
-by (rtac is_ub_thelub 1);
-by (rtac chain_iterate 1);
-by (rtac is_lub_thelub 1);
-by (etac chain_iterate_lub 1);
-by (rtac ub_rangeI 1);
-by (strip_tac 1);
-by (rtac lub_mono 1);
-by (rtac chain_iterate 1);
-by (rtac (contlub_Ifix_lemma1 RS ext RS subst) 1);
-by (atac 1);
-by (rtac chain_iterate 1);
-by (strip_tac 1);
-by (rtac is_ub_thelub 1);
-by (etac (monofun_iterate RS ch2ch_monofun RS ch2ch_fun) 1);
-qed "ex_lub_iterate";
-
-
-Goalw [contlub,Ifix_def] "contlub(Ifix)";
-by (strip_tac 1);
-by (stac (contlub_Ifix_lemma1 RS ext) 1);
-by (atac 1);
-by (etac ex_lub_iterate 1);
-qed "contlub_Ifix";
-
-
-Goal "cont(Ifix)";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_Ifix 1);
-by (rtac contlub_Ifix 1);
-qed "cont_Ifix";
+structure Fix =
+struct
+  val thy = the_context ();
+  val Ifix_def = Ifix_def;
+  val fix_def = fix_def;
+  val adm_def = adm_def;
+  val admw_def = admw_def;
+end;
 
-(* ------------------------------------------------------------------------ *)
-(* propagate properties of Ifix to its continuous counterpart               *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [fix_def] "fix$F = F$(fix$F)";
-by (asm_simp_tac (simpset() addsimps [cont_Ifix]) 1);
-by (rtac Ifix_eq 1);
-qed "fix_eq";
-
-Goalw [fix_def] "F$x = x ==> fix$F << x";
-by (asm_simp_tac (simpset() addsimps [cont_Ifix]) 1);
-by (etac Ifix_least 1);
-qed "fix_least";
-
-
-Goal
-"[| F$x = x; !z. F$z = z --> x << z |] ==> x = fix$F";
-by (rtac antisym_less 1);
-by (etac allE 1);
-by (etac mp 1);
-by (rtac (fix_eq RS sym) 1);
-by (etac fix_least 1);
-qed "fix_eqI";
+fun fix_tac3 thm i  = ((rtac trans i) THEN (rtac (thm RS fix_eq3) i));
 
-
-Goal "f == fix$F ==> f = F$f";
-by (asm_simp_tac (simpset() addsimps [fix_eq RS sym]) 1);
-qed "fix_eq2";
-
-Goal "f == fix$F ==> f$x = F$f$x";
-by (etac (fix_eq2 RS cfun_fun_cong) 1);
-qed "fix_eq3";
-
-fun fix_tac3 thm i  = ((rtac trans i) THEN (rtac (thm RS fix_eq3) i)); 
-
-Goal "f = fix$F ==> f = F$f";
-by (hyp_subst_tac 1);
-by (rtac fix_eq 1);
-qed "fix_eq4";
-
-Goal "f = fix$F ==> f$x = F$f$x";
-by (rtac trans 1);
-by (etac (fix_eq4 RS cfun_fun_cong) 1);
-by (rtac refl 1);
-qed "fix_eq5";
-
-fun fix_tac5 thm i  = ((rtac trans i) THEN (rtac (thm RS fix_eq5) i)); 
+fun fix_tac5 thm i  = ((rtac trans i) THEN (rtac (thm RS fix_eq5) i));
 
 (* proves the unfolding theorem for function equations f = fix$... *)
 fun fix_prover thy fixeq s = prove_goal thy s (fn prems => [
@@ -313,416 +109,8 @@
 
 (* proves an application case for a function from its unfolding thm *)
 fun case_prover thy unfold s = prove_goal thy s (fn prems => [
-	(cut_facts_tac prems 1),
-	(rtac trans 1),
-	(stac unfold 1),
-	Auto_tac
-	]);
-
-(* ------------------------------------------------------------------------ *)
-(* better access to definitions                                             *)
-(* ------------------------------------------------------------------------ *)
-
-
-Goal "Ifix=(%x. lub(range(%i. iterate i x UU)))";
-by (rtac ext 1);
-by (rewtac Ifix_def);
-by (rtac refl 1);
-qed "Ifix_def2";
-
-(* ------------------------------------------------------------------------ *)
-(* direct connection between fix and iteration without Ifix                 *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [fix_def] "fix$F = lub(range(%i. iterate i F UU))";
-by (fold_goals_tac [Ifix_def]);
-by (asm_simp_tac (simpset() addsimps [cont_Ifix]) 1);
-qed "fix_def2";
-
-
-(* ------------------------------------------------------------------------ *)
-(* Lemmas about admissibility and fixed point induction                     *)
-(* ------------------------------------------------------------------------ *)
-
-(* ------------------------------------------------------------------------ *)
-(* access to definitions                                                    *)
-(* ------------------------------------------------------------------------ *)
-
-val prems = Goalw [adm_def]
-   "(!!Y. [| chain Y; !i. P (Y i) |] ==> P (lub (range Y))) ==> adm P";
-by (blast_tac (claset() addIs prems) 1);
-qed "admI";
-
-Goal "!x. P x ==> adm P";
-by (rtac admI 1);
-by (etac spec 1);
-qed "triv_admI";
-
-Goalw [adm_def] "[| adm(P); chain(Y); !i. P(Y(i)) |] ==> P(lub(range(Y)))";
-by (Blast_tac 1);
-qed "admD";
-
-Goalw [admw_def] "admw(P) = (!F.(!n. P(iterate n F UU)) -->\
-\                        P (lub(range(%i. iterate i F UU))))";
-by (rtac refl 1);
-qed "admw_def2";
-
-(* ------------------------------------------------------------------------ *)
-(* an admissible formula is also weak admissible                            *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [admw_def] "adm(P)==>admw(P)";
-by (strip_tac 1);
-by (etac admD 1);
-by (rtac chain_iterate 1);
-by (atac 1);
-qed "adm_impl_admw";
-
-(* ------------------------------------------------------------------------ *)
-(* fixed point induction                                                    *)
-(* ------------------------------------------------------------------------ *)
-
-val major::prems = Goal
-     "[| adm(P); P(UU); !!x. P(x) ==> P(F$x)|] ==> P(fix$F)";
-by (stac fix_def2 1);
-by (rtac (major RS admD) 1);
-by (rtac chain_iterate 1);
-by (rtac allI 1);
-by (induct_tac "i" 1);
-by (asm_simp_tac (simpset() addsimps (iterate_0::prems)) 1);
-by (asm_simp_tac (simpset() addsimps (iterate_Suc::prems)) 1);
-qed "fix_ind";
-
-val prems = Goal "[| f == fix$F; adm(P); \
-\       P(UU); !!x. P(x) ==> P(F$x)|] ==> P f";
-by (cut_facts_tac prems 1);
-by (asm_simp_tac HOL_ss 1);
-by (etac fix_ind 1);
-by (atac 1);
-by (eresolve_tac prems 1);
-qed "def_fix_ind";
-	
-(* ------------------------------------------------------------------------ *)
-(* computational induction for weak admissible formulae                     *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "[| admw(P); !n. P(iterate n F UU)|] ==> P(fix$F)";
-by (stac fix_def2 1);
-by (rtac (admw_def2 RS iffD1 RS spec RS mp) 1);
-by (atac 1);
-by (rtac allI 1);
-by (etac spec 1);
-qed "wfix_ind";
-
-Goal "[| f == fix$F; admw(P); \
-\       !n. P(iterate n F UU) |] ==> P f";
-by (asm_simp_tac HOL_ss 1);
-by (etac wfix_ind 1);
-by (atac 1);
-qed "def_wfix_ind";
-
-(* ------------------------------------------------------------------------ *)
-(* for chain-finite (easy) types every formula is admissible                *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [adm_def]
-"!Y. chain(Y::nat=>'a) --> (? n. max_in_chain n Y) ==> adm(P::'a=>bool)";
-by (strip_tac 1);
-by (rtac exE 1);
-by (rtac mp 1);
-by (etac spec 1);
-by (atac 1);
-by (stac (lub_finch1 RS thelubI) 1);
-by (atac 1);
-by (atac 1);
-by (etac spec 1);
-qed "adm_max_in_chain";
-
-bind_thm ("adm_chfin" ,chfin RS adm_max_in_chain);
-
-(* ------------------------------------------------------------------------ *)
-(* some lemmata for functions with flat/chfin domain/range types	    *)
-(* ------------------------------------------------------------------------ *)
-
-val _ = goalw thy [adm_def] "adm (%(u::'a::cpo->'b::chfin). P(u$s))";
-by (strip_tac 1);
-by (dtac chfin_Rep_CFunR 1);
-by (eres_inst_tac [("x","s")] allE 1);
-by (fast_tac (HOL_cs addss (simpset() addsimps [chfin])) 1);
-qed "adm_chfindom";
-
-(* adm_flat not needed any more, since it is a special case of adm_chfindom *)
-
-(* ------------------------------------------------------------------------ *)
-(* improved admisibility introduction                                       *)
-(* ------------------------------------------------------------------------ *)
-
-val prems = Goalw [adm_def]
- "(!!Y. [| chain Y; !i. P (Y i); !i. ? j. i < j & Y i ~= Y j & Y i << Y j |]\
-\ ==> P(lub (range Y))) ==> adm P";
-by (strip_tac 1);
-by (etac increasing_chain_adm_lemma 1);
-by (atac 1);
-by (eresolve_tac prems 1);
-by (atac 1);
-by (atac 1);
-qed "admI2";
-
-
-(* ------------------------------------------------------------------------ *)
-(* admissibility of special formulae and propagation                        *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [adm_def] "[|cont u;cont v|]==> adm(%x. u x << v x)";
-by (strip_tac 1);
-by (forw_inst_tac [("f","u")] (cont2mono RS ch2ch_monofun) 1);
-by (assume_tac  1);
-by (forw_inst_tac [("f","v")] (cont2mono RS ch2ch_monofun) 1);
-by (assume_tac  1);
-by (etac (cont2contlub RS contlubE RS spec RS mp RS ssubst) 1);
-by (atac 1);
-by (etac (cont2contlub RS contlubE RS spec RS mp RS ssubst) 1);
-by (atac 1);
-by (blast_tac (claset() addIs [lub_mono]) 1);
-qed "adm_less";
-Addsimps [adm_less];
-
-Goal   "[| adm P; adm Q |] ==> adm(%x. P x & Q x)";
-by (fast_tac (HOL_cs addEs [admD] addIs [admI]) 1);
-qed "adm_conj";
-Addsimps [adm_conj];
-
-Goalw [adm_def] "adm(%x. t)";
-by (fast_tac HOL_cs 1);
-qed "adm_not_free";
-Addsimps [adm_not_free];
-
-Goalw [adm_def] "cont t ==> adm(%x.~ (t x) << u)";
-by (strip_tac 1);
-by (rtac contrapos_nn 1);
-by (etac spec 1);
-by (rtac trans_less 1);
-by (atac 2);
-by (etac (cont2mono RS monofun_fun_arg) 1);
-by (rtac is_ub_thelub 1);
-by (atac 1);
-qed "adm_not_less";
-
-Goal   "!y. adm(P y) ==> adm(%x.!y. P y x)";
-by (fast_tac (HOL_cs addIs [admI] addEs [admD]) 1);
-qed "adm_all";
-
-bind_thm ("adm_all2", allI RS adm_all);
-
-Goal   "[|cont t; adm P|] ==> adm(%x. P (t x))";
-by (rtac admI 1);
-by (stac (cont2contlub RS contlubE RS spec RS mp) 1);
-by (atac 1);
-by (atac 1);
-by (etac admD 1);
-by (etac (cont2mono RS ch2ch_monofun) 1);
-by (atac 1);
-by (atac 1);
-qed "adm_subst";
-
-Goal "adm(%x.~ UU << t(x))";
-by (Simp_tac 1);
-qed "adm_UU_not_less";
-
-
-Goalw [adm_def] "cont(t)==> adm(%x.~ (t x) = UU)";
-by (strip_tac 1);
-by (rtac contrapos_nn 1);
-by (etac spec 1);
-by (rtac (chain_UU_I RS spec) 1);
-by (etac (cont2mono RS ch2ch_monofun) 1);
-by (atac 1);
-by (etac (cont2contlub RS contlubE RS spec RS mp RS subst) 1);
-by (atac 1);
-by (atac 1);
-qed "adm_not_UU";
-
-Goal "[|cont u ; cont v|]==> adm(%x. u x = v x)";
-by (asm_simp_tac (simpset() addsimps [po_eq_conv]) 1);
-qed "adm_eq";
-
-
-
-(* ------------------------------------------------------------------------ *)
-(* admissibility for disjunction is hard to prove. It takes 10 Lemmas       *)
-(* ------------------------------------------------------------------------ *)
-
-
-Goal  "!n. P(Y n)|Q(Y n) ==> (? i.!j. R i j --> Q(Y(j))) | (!i.? j. R i j & P(Y(j)))";
-by (Fast_tac 1);
-qed "adm_disj_lemma1";
-
-Goal "[| adm(Q); ? X. chain(X) & (!n. Q(X(n))) &\
-  \   lub(range(Y))=lub(range(X))|] ==> Q(lub(range(Y)))";
-by (force_tac (claset() addEs [admD], simpset()) 1);
-qed "adm_disj_lemma2";
-
-Goalw [chain_def]"chain Y ==> chain (%m. if m < Suc i then Y (Suc i) else Y m)";
-by (Asm_simp_tac 1);
-by (safe_tac HOL_cs);
-by (subgoal_tac "ia = i" 1);
-by (ALLGOALS Asm_simp_tac);
-qed "adm_disj_lemma3";
-
-Goal "!j. i < j --> Q(Y(j))  ==> !n. Q( if n < Suc i then Y(Suc i) else Y n)";
-by (Asm_simp_tac 1);
-qed "adm_disj_lemma4";
-
-Goal
-  "!!Y::nat=>'a::cpo. [| chain(Y); ! j. i < j --> Q(Y(j)) |] ==>\
-  \       lub(range(Y)) = lub(range(%m. if m< Suc(i) then Y(Suc(i)) else Y m))";
-by (safe_tac (HOL_cs addSIs [lub_equal2,adm_disj_lemma3]));
-by (atac 2);
-by (res_inst_tac [("x","i")] exI 1);
-by (Asm_simp_tac 1);
-qed "adm_disj_lemma5";
-
-Goal
-  "[| chain(Y::nat=>'a::cpo); ? i. ! j. i < j --> Q(Y(j)) |] ==>\
-  \         ? X. chain(X) & (! n. Q(X(n))) & lub(range(Y)) = lub(range(X))";
-by (etac exE 1);
-by (res_inst_tac [("x","%m. if m<Suc(i) then Y(Suc(i)) else Y m")] exI 1);
-by (rtac conjI 1);
-by (rtac adm_disj_lemma3 1);
-by (atac 1);
-by (rtac conjI 1);
-by (rtac adm_disj_lemma4 1);
-by (atac 1);
-by (rtac adm_disj_lemma5 1);
-by (atac 1);
-by (atac 1);
-qed "adm_disj_lemma6";
-
-Goal 
-  "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j))  |] ==>\
-  \         chain(%m. Y(Least(%j. m<j & P(Y(j)))))";
-by (rtac chainI 1);
-by (rtac chain_mono3 1);
-by (atac 1);
-by (rtac Least_le 1);
-by (rtac conjI 1);
-by (rtac Suc_lessD 1);
-by (etac allE 1);
-by (etac exE 1);
-by (rtac (LeastI RS conjunct1) 1);
-by (atac 1);
-by (etac allE 1);
-by (etac exE 1);
-by (rtac (LeastI RS conjunct2) 1);
-by (atac 1);
-qed "adm_disj_lemma7";
-
-Goal 
-  "[| ! i. ? j. i < j & P(Y(j)) |] ==> ! m. P(Y(LEAST j::nat. m<j & P(Y(j))))";
-by (strip_tac 1);
-by (etac allE 1);
-by (etac exE 1);
-by (etac (LeastI RS conjunct2) 1);
-qed "adm_disj_lemma8";
-
-Goal
-  "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>\
-  \         lub(range(Y)) = lub(range(%m. Y(Least(%j. m<j & P(Y(j))))))";
-by (rtac antisym_less 1);
-by (rtac lub_mono 1);
-by (atac 1);
-by (rtac adm_disj_lemma7 1);
-by (atac 1);
-by (atac 1);
-by (strip_tac 1);
-by (rtac (chain_mono) 1);
-by (atac 1);
-by (etac allE 1);
-by (etac exE 1);
-by (rtac (LeastI RS conjunct1) 1);
-by (atac 1);
-by (rtac lub_mono3 1);
-by (rtac adm_disj_lemma7 1);
-by (atac 1);
-by (atac 1);
-by (atac 1);
-by (strip_tac 1);
-by (rtac exI 1);
-by (rtac (chain_mono) 1);
-by (atac 1);
-by (rtac lessI 1);
-qed "adm_disj_lemma9";
-
-Goal "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>\
-  \         ? X. chain(X) & (! n. P(X(n))) & lub(range(Y)) = lub(range(X))";
-by (res_inst_tac [("x","%m. Y(Least(%j. m<j & P(Y(j))))")] exI 1);
-by (rtac conjI 1);
-by (rtac adm_disj_lemma7 1);
-by (atac 1);
-by (atac 1);
-by (rtac conjI 1);
-by (rtac adm_disj_lemma8 1);
-by (atac 1);
-by (rtac adm_disj_lemma9 1);
-by (atac 1);
-by (atac 1);
-qed "adm_disj_lemma10";
-
-Goal "[| adm(P); chain(Y);? i. ! j. i < j --> P(Y(j))|]==>P(lub(range(Y)))";
-by (etac adm_disj_lemma2 1);
-by (etac adm_disj_lemma6 1);
-by (atac 1);
-qed "adm_disj_lemma12";
-
-
-Goal
-"[| adm(P); chain(Y); ! i. ? j. i < j & P(Y(j)) |]==>P(lub(range(Y)))";
-by (etac adm_disj_lemma2 1);
-by (etac adm_disj_lemma10 1);
-by (atac 1);
-qed "adm_lemma11";
-
-Goal "[| adm P; adm Q |] ==> adm(%x. P x | Q x)";
-by (rtac admI 1);
-by (rtac (adm_disj_lemma1 RS disjE) 1);
-by (atac 1);
-by (rtac disjI2 1);
-by (etac adm_disj_lemma12 1);
-by (atac 1);
-by (atac 1);
-by (rtac disjI1 1);
-by (etac adm_lemma11 1);
-by (atac 1);
-by (atac 1);
-qed "adm_disj";
-
-Goal "[| adm(%x.~(P x)); adm Q |] ==> adm(%x. P x --> Q x)";
-by (subgoal_tac "(%x. P x --> Q x) = (%x. ~P x | Q x)" 1);
-by (etac ssubst 1);
-by (etac adm_disj 1);
-by (atac 1);
-by (Simp_tac 1);
-qed "adm_imp";
-
-Goal "[| adm (%x. P x --> Q x); adm (%x. Q x --> P x) |] \
-\           ==> adm (%x. P x = Q x)";
-by (subgoal_tac "(%x. P x = Q x) = (%x. (P x --> Q x) & (Q x --> P x))" 1);
-by (Asm_simp_tac 1);
-by (rtac ext 1);
-by (fast_tac HOL_cs 1);
-qed"adm_iff";
-
-
-Goal "[| adm (%x. ~ P x); adm (%x. ~ Q x) |] ==> adm (%x. ~ (P x & Q x))";
-by (subgoal_tac "(%x. ~ (P x & Q x)) = (%x. ~ P x | ~ Q x)" 1);
-by (rtac ext 2);
-by (fast_tac HOL_cs 2);
-by (etac ssubst 1);
-by (etac adm_disj 1);
-by (atac 1);
-qed "adm_not_conj";
-
-bind_thms ("adm_lemmas", [adm_not_free,adm_imp,adm_disj,adm_eq,adm_not_UU,
-        adm_UU_not_less,adm_all2,adm_not_less,adm_not_conj,adm_iff]);
-
-Addsimps adm_lemmas;
+        (cut_facts_tac prems 1),
+        (rtac trans 1),
+        (stac unfold 1),
+        Auto_tac
+        ]);
--- a/src/HOLCF/Fix.thy	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/Fix.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -1,34 +1,790 @@
 (*  Title:      HOLCF/Fix.thy
     ID:         $Id$
     Author:     Franz Regensburger
+    License:    GPL (GNU GENERAL PUBLIC LICENSE)
 
 definitions for fixed point operator and admissibility
 *)
 
-Fix = Cfun3 +
+theory Fix = Cfun:
 
 consts
 
 iterate	:: "nat=>('a->'a)=>'a=>'a"
 Ifix	:: "('a->'a)=>'a"
-fix	:: "('a->'a)->'a"
+"fix"	:: "('a->'a)->'a"
 adm		:: "('a::cpo=>bool)=>bool"
 admw		:: "('a=>bool)=>bool"
 
 primrec
-  iterate_0   "iterate 0 F x = x"
-  iterate_Suc "iterate (Suc n) F x  = F$(iterate n F x)"
+  iterate_0:   "iterate 0 F x = x"
+  iterate_Suc: "iterate (Suc n) F x  = F$(iterate n F x)"
 
 defs
 
-Ifix_def      "Ifix F == lub(range(%i. iterate i F UU))"
-fix_def       "fix == (LAM f. Ifix f)"
+Ifix_def:      "Ifix F == lub(range(%i. iterate i F UU))"
+fix_def:       "fix == (LAM f. Ifix f)"
 
-adm_def       "adm P == !Y. chain(Y) --> 
+adm_def:       "adm P == !Y. chain(Y) --> 
                         (!i. P(Y i)) --> P(lub(range Y))"
 
-admw_def      "admw P == !F. (!n. P (iterate n F UU)) -->
+admw_def:      "admw P == !F. (!n. P (iterate n F UU)) -->
                             P (lub(range (%i. iterate i F UU)))" 
 
+(*  Title:      HOLCF/Fix.ML
+    ID:         $Id$
+    Author:     Franz Regensburger
+    License:    GPL (GNU GENERAL PUBLIC LICENSE)
+
+fixed point operator and admissibility
+*)
+
+(* ------------------------------------------------------------------------ *)
+(* derive inductive properties of iterate from primitive recursion          *)
+(* ------------------------------------------------------------------------ *)
+
+lemma iterate_Suc2: "iterate (Suc n) F x = iterate n F (F$x)"
+apply (induct_tac "n")
+apply auto
+done
+
+(* ------------------------------------------------------------------------ *)
+(* the sequence of function itertaions is a chain                           *)
+(* This property is essential since monotonicity of iterate makes no sense  *)
+(* ------------------------------------------------------------------------ *)
+
+lemma chain_iterate2: "x << F$x ==> chain (%i. iterate i F x)"
+
+apply (unfold chain_def)
+apply (intro strip)
+apply (induct_tac "i")
+apply auto
+apply (erule monofun_cfun_arg)
+done
+
+
+lemma chain_iterate: "chain (%i. iterate i F UU)"
+apply (rule chain_iterate2)
+apply (rule minimal)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* Kleene's fixed point theorems for continuous functions in pointed        *)
+(* omega cpo's                                                              *)
+(* ------------------------------------------------------------------------ *)
+
+
+lemma Ifix_eq: "Ifix F =F$(Ifix F)"
+
+
+apply (unfold Ifix_def)
+apply (subst contlub_cfun_arg)
+apply (rule chain_iterate)
+apply (rule antisym_less)
+apply (rule lub_mono)
+apply (rule chain_iterate)
+apply (rule ch2ch_Rep_CFunR)
+apply (rule chain_iterate)
+apply (rule allI)
+apply (rule iterate_Suc [THEN subst])
+apply (rule chain_iterate [THEN chainE])
+apply (rule is_lub_thelub)
+apply (rule ch2ch_Rep_CFunR)
+apply (rule chain_iterate)
+apply (rule ub_rangeI)
+apply (rule iterate_Suc [THEN subst])
+apply (rule is_ub_thelub)
+apply (rule chain_iterate)
+done
+
+
+lemma Ifix_least: "F$x=x ==> Ifix(F) << x"
+
+apply (unfold Ifix_def)
+apply (rule is_lub_thelub)
+apply (rule chain_iterate)
+apply (rule ub_rangeI)
+apply (induct_tac "i")
+apply (simp (no_asm_simp))
+apply (simp (no_asm_simp))
+apply (rule_tac t = "x" in subst)
+apply assumption
+apply (erule monofun_cfun_arg)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* monotonicity and continuity of iterate                                   *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_iterate: "monofun(iterate(i))"
+apply (unfold monofun)
+apply (intro strip)
+apply (induct_tac "i")
+apply (simp (no_asm_simp))
+apply (simp add: less_fun monofun_cfun)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* the following lemma uses contlub_cfun which itself is based on a         *)
+(* diagonalisation lemma for continuous functions with two arguments.       *)
+(* In this special case it is the application function Rep_CFun                 *)
+(* ------------------------------------------------------------------------ *)
+
+lemma contlub_iterate: "contlub(iterate(i))"
+
+apply (unfold contlub)
+apply (intro strip)
+apply (induct_tac "i")
+apply (simp (no_asm_simp))
+apply (rule lub_const [THEN thelubI, symmetric])
+apply (simp (no_asm_simp) del: range_composition)
+apply (rule ext)
+apply (simplesubst thelub_fun)
+apply (rule chainI)
+apply (rule less_fun [THEN iffD2])
+apply (rule allI)
+apply (rule chainE)
+apply (rule monofun_Rep_CFun1 [THEN ch2ch_MF2LR])
+apply (rule allI)
+apply (rule monofun_Rep_CFun2)
+apply assumption
+apply (rule ch2ch_fun)
+apply (rule monofun_iterate [THEN ch2ch_monofun])
+apply assumption
+apply (subst thelub_fun)
+apply (rule monofun_iterate [THEN ch2ch_monofun])
+apply assumption
+apply (rule contlub_cfun)
+apply assumption
+apply (erule monofun_iterate [THEN ch2ch_monofun, THEN ch2ch_fun])
+done
+
+
+lemma cont_iterate: "cont(iterate(i))"
+apply (rule monocontlub2cont)
+apply (rule monofun_iterate)
+apply (rule contlub_iterate)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* a lemma about continuity of iterate in its third argument                *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_iterate2: "monofun(iterate n F)"
+apply (rule monofunI)
+apply (intro strip)
+apply (induct_tac "n")
+apply (simp (no_asm_simp))
+apply (simp (no_asm_simp))
+apply (erule monofun_cfun_arg)
+done
+
+lemma contlub_iterate2: "contlub(iterate n F)"
+apply (rule contlubI)
+apply (intro strip)
+apply (induct_tac "n")
+apply (simp (no_asm))
+apply (simp (no_asm))
+apply (rule_tac t = "iterate n F (lub (range (%u. Y u))) " and s = "lub (range (%i. iterate n F (Y i))) " in ssubst)
+apply assumption
+apply (rule contlub_cfun_arg)
+apply (erule monofun_iterate2 [THEN ch2ch_monofun])
+done
+
+lemma cont_iterate2: "cont (iterate n F)"
+apply (rule monocontlub2cont)
+apply (rule monofun_iterate2)
+apply (rule contlub_iterate2)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* monotonicity and continuity of Ifix                                      *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_Ifix: "monofun(Ifix)"
+
+apply (unfold monofun Ifix_def)
+apply (intro strip)
+apply (rule lub_mono)
+apply (rule chain_iterate)
+apply (rule chain_iterate)
+apply (rule allI)
+apply (rule less_fun [THEN iffD1, THEN spec], erule monofun_iterate [THEN monofunE, THEN spec, THEN spec, THEN mp])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* since iterate is not monotone in its first argument, special lemmas must *)
+(* be derived for lubs in this argument                                     *)
+(* ------------------------------------------------------------------------ *)
+
+lemma chain_iterate_lub: 
+"chain(Y) ==> chain(%i. lub(range(%ia. iterate ia (Y i) UU)))"
+apply (rule chainI)
+apply (rule lub_mono)
+apply (rule chain_iterate)
+apply (rule chain_iterate)
+apply (intro strip)
+apply (erule monofun_iterate [THEN ch2ch_monofun, THEN ch2ch_fun, THEN chainE])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* this exchange lemma is analog to the one for monotone functions          *)
+(* observe that monotonicity is not really needed. The propagation of       *)
+(* chains is the essential argument which is usually derived from monot.    *)
+(* ------------------------------------------------------------------------ *)
+
+lemma contlub_Ifix_lemma1: "chain(Y) ==>iterate n (lub(range Y)) y = lub(range(%i. iterate n (Y i) y))"
+apply (rule thelub_fun [THEN subst])
+apply (erule monofun_iterate [THEN ch2ch_monofun])
+apply (simp (no_asm_simp) add: contlub_iterate [THEN contlubE])
+done
+
+
+lemma ex_lub_iterate: "chain(Y) ==> 
+          lub(range(%i. lub(range(%ia. iterate i (Y ia) UU)))) = 
+          lub(range(%i. lub(range(%ia. iterate ia (Y i) UU))))"
+apply (rule antisym_less)
+apply (rule is_lub_thelub)
+apply (rule contlub_Ifix_lemma1 [THEN ext, THEN subst])
+apply assumption
+apply (rule chain_iterate)
+apply (rule ub_rangeI)
+apply (rule lub_mono)
+apply (erule monofun_iterate [THEN ch2ch_monofun, THEN ch2ch_fun])
+apply (erule chain_iterate_lub)
+apply (intro strip)
+apply (rule is_ub_thelub)
+apply (rule chain_iterate)
+apply (rule is_lub_thelub)
+apply (erule chain_iterate_lub)
+apply (rule ub_rangeI)
+apply (rule lub_mono)
+apply (rule chain_iterate)
+apply (rule contlub_Ifix_lemma1 [THEN ext, THEN subst])
+apply assumption
+apply (rule chain_iterate)
+apply (intro strip)
+apply (rule is_ub_thelub)
+apply (erule monofun_iterate [THEN ch2ch_monofun, THEN ch2ch_fun])
+done
+
+
+lemma contlub_Ifix: "contlub(Ifix)"
+
+apply (unfold contlub Ifix_def)
+apply (intro strip)
+apply (subst contlub_Ifix_lemma1 [THEN ext])
+apply assumption
+apply (erule ex_lub_iterate)
+done
+
+
+lemma cont_Ifix: "cont(Ifix)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Ifix)
+apply (rule contlub_Ifix)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* propagate properties of Ifix to its continuous counterpart               *)
+(* ------------------------------------------------------------------------ *)
+
+lemma fix_eq: "fix$F = F$(fix$F)"
+
+apply (unfold fix_def)
+apply (simp (no_asm_simp) add: cont_Ifix)
+apply (rule Ifix_eq)
+done
+
+lemma fix_least: "F$x = x ==> fix$F << x"
+apply (unfold fix_def)
+apply (simp (no_asm_simp) add: cont_Ifix)
+apply (erule Ifix_least)
+done
+
+
+lemma fix_eqI: 
+"[| F$x = x; !z. F$z = z --> x << z |] ==> x = fix$F"
+apply (rule antisym_less)
+apply (erule allE)
+apply (erule mp)
+apply (rule fix_eq [symmetric])
+apply (erule fix_least)
+done
+
+
+lemma fix_eq2: "f == fix$F ==> f = F$f"
+apply (simp (no_asm_simp) add: fix_eq [symmetric])
+done
+
+lemma fix_eq3: "f == fix$F ==> f$x = F$f$x"
+apply (erule fix_eq2 [THEN cfun_fun_cong])
+done
+
+(* fun fix_tac3 thm i  = ((rtac trans i) THEN (rtac (thm RS fix_eq3) i)) *)
+
+lemma fix_eq4: "f = fix$F ==> f = F$f"
+apply (erule ssubst)
+apply (rule fix_eq)
+done
+
+lemma fix_eq5: "f = fix$F ==> f$x = F$f$x"
+apply (rule trans)
+apply (erule fix_eq4 [THEN cfun_fun_cong])
+apply (rule refl)
+done
+
+(* fun fix_tac5 thm i  = ((rtac trans i) THEN (rtac (thm RS fix_eq5) i)) *)
+
+(* proves the unfolding theorem for function equations f = fix$... *)
+(*
+fun fix_prover thy fixeq s = prove_goal thy s (fn prems => [
+        (rtac trans 1),
+        (rtac (fixeq RS fix_eq4) 1),
+        (rtac trans 1),
+        (rtac beta_cfun 1),
+        (Simp_tac 1)
+        ])
+*)
+(* proves the unfolding theorem for function definitions f == fix$... *)
+(*
+fun fix_prover2 thy fixdef s = prove_goal thy s (fn prems => [
+        (rtac trans 1),
+        (rtac (fix_eq2) 1),
+        (rtac fixdef 1),
+        (rtac beta_cfun 1),
+        (Simp_tac 1)
+        ])
+*)
+(* proves an application case for a function from its unfolding thm *)
+(*
+fun case_prover thy unfold s = prove_goal thy s (fn prems => [
+	(cut_facts_tac prems 1),
+	(rtac trans 1),
+	(stac unfold 1),
+	Auto_tac
+	])
+*)
+(* ------------------------------------------------------------------------ *)
+(* better access to definitions                                             *)
+(* ------------------------------------------------------------------------ *)
+
+
+lemma Ifix_def2: "Ifix=(%x. lub(range(%i. iterate i x UU)))"
+apply (rule ext)
+apply (unfold Ifix_def)
+apply (rule refl)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* direct connection between fix and iteration without Ifix                 *)
+(* ------------------------------------------------------------------------ *)
+
+lemma fix_def2: "fix$F = lub(range(%i. iterate i F UU))"
+apply (unfold fix_def)
+apply (fold Ifix_def)
+apply (simp (no_asm_simp) add: cont_Ifix)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* Lemmas about admissibility and fixed point induction                     *)
+(* ------------------------------------------------------------------------ *)
+
+(* ------------------------------------------------------------------------ *)
+(* access to definitions                                                    *)
+(* ------------------------------------------------------------------------ *)
+
+lemma admI:
+   "(!!Y. [| chain Y; !i. P (Y i) |] ==> P (lub (range Y))) ==> adm P"
+apply (unfold adm_def)
+apply blast
+done
+
+lemma triv_admI: "!x. P x ==> adm P"
+apply (rule admI)
+apply (erule spec)
+done
+
+lemma admD: "[| adm(P); chain(Y); !i. P(Y(i)) |] ==> P(lub(range(Y)))"
+apply (unfold adm_def)
+apply blast
+done
+
+lemma admw_def2: "admw(P) = (!F.(!n. P(iterate n F UU)) --> 
+                         P (lub(range(%i. iterate i F UU))))"
+apply (unfold admw_def)
+apply (rule refl)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* an admissible formula is also weak admissible                            *)
+(* ------------------------------------------------------------------------ *)
+
+lemma adm_impl_admw: "adm(P)==>admw(P)"
+apply (unfold admw_def)
+apply (intro strip)
+apply (erule admD)
+apply (rule chain_iterate)
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* fixed point induction                                                    *)
+(* ------------------------------------------------------------------------ *)
+
+lemma fix_ind:
+     "[| adm(P); P(UU); !!x. P(x) ==> P(F$x)|] ==> P(fix$F)"
+apply (subst fix_def2)
+apply (erule admD)
+apply (rule chain_iterate)
+apply (rule allI)
+apply (induct_tac "i")
+apply simp
+apply simp
+done
+
+lemma def_fix_ind: "[| f == fix$F; adm(P);  
+        P(UU); !!x. P(x) ==> P(F$x)|] ==> P f"
+apply simp
+apply (erule fix_ind)
+apply assumption
+apply fast
+done
+	
+(* ------------------------------------------------------------------------ *)
+(* computational induction for weak admissible formulae                     *)
+(* ------------------------------------------------------------------------ *)
+
+lemma wfix_ind: "[| admw(P); !n. P(iterate n F UU)|] ==> P(fix$F)"
+apply (subst fix_def2)
+apply (rule admw_def2 [THEN iffD1, THEN spec, THEN mp])
+apply assumption
+apply (rule allI)
+apply (erule spec)
+done
+
+lemma def_wfix_ind: "[| f == fix$F; admw(P);  
+        !n. P(iterate n F UU) |] ==> P f"
+apply simp
+apply (erule wfix_ind)
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* for chain-finite (easy) types every formula is admissible                *)
+(* ------------------------------------------------------------------------ *)
+
+lemma adm_max_in_chain: 
+"!Y. chain(Y::nat=>'a) --> (? n. max_in_chain n Y) ==> adm(P::'a=>bool)"
+apply (unfold adm_def)
+apply (intro strip)
+apply (rule exE)
+apply (rule mp)
+apply (erule spec)
+apply assumption
+apply (subst lub_finch1 [THEN thelubI])
+apply assumption
+apply assumption
+apply (erule spec)
+done
+
+lemmas adm_chfin = chfin [THEN adm_max_in_chain, standard]
+
+(* ------------------------------------------------------------------------ *)
+(* some lemmata for functions with flat/chfin domain/range types	    *)
+(* ------------------------------------------------------------------------ *)
+
+lemma adm_chfindom: "adm (%(u::'a::cpo->'b::chfin). P(u$s))"
+apply (unfold adm_def)
+apply (intro strip)
+apply (drule chfin_Rep_CFunR)
+apply (erule_tac x = "s" in allE)
+apply clarsimp
+done
+
+(* adm_flat not needed any more, since it is a special case of adm_chfindom *)
+
+(* ------------------------------------------------------------------------ *)
+(* improved admisibility introduction                                       *)
+(* ------------------------------------------------------------------------ *)
+
+lemma admI2:
+ "(!!Y. [| chain Y; !i. P (Y i); !i. ? j. i < j & Y i ~= Y j & Y i << Y j |] 
+  ==> P(lub (range Y))) ==> adm P"
+apply (unfold adm_def)
+apply (intro strip)
+apply (erule increasing_chain_adm_lemma)
+apply assumption
+apply fast
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* admissibility of special formulae and propagation                        *)
+(* ------------------------------------------------------------------------ *)
+
+lemma adm_less: "[|cont u;cont v|]==> adm(%x. u x << v x)"
+apply (unfold adm_def)
+apply (intro strip)
+apply (frule_tac f = "u" in cont2mono [THEN ch2ch_monofun])
+apply assumption
+apply (frule_tac f = "v" in cont2mono [THEN ch2ch_monofun])
+apply assumption
+apply (erule cont2contlub [THEN contlubE, THEN spec, THEN mp, THEN ssubst])
+apply assumption
+apply (erule cont2contlub [THEN contlubE, THEN spec, THEN mp, THEN ssubst])
+apply assumption
+apply (blast intro: lub_mono)
+done
+declare adm_less [simp]
+
+lemma adm_conj: "[| adm P; adm Q |] ==> adm(%x. P x & Q x)"
+apply (fast elim: admD intro: admI)
+done
+declare adm_conj [simp]
+
+lemma adm_not_free: "adm(%x. t)"
+apply (unfold adm_def)
+apply fast
+done
+declare adm_not_free [simp]
+
+lemma adm_not_less: "cont t ==> adm(%x.~ (t x) << u)"
+apply (unfold adm_def)
+apply (intro strip)
+apply (rule contrapos_nn)
+apply (erule spec)
+apply (rule trans_less)
+prefer 2 apply (assumption)
+apply (erule cont2mono [THEN monofun_fun_arg])
+apply (rule is_ub_thelub)
+apply assumption
+done
+
+lemma adm_all: "!y. adm(P y) ==> adm(%x.!y. P y x)"
+apply (fast intro: admI elim: admD)
+done
+
+lemmas adm_all2 = allI [THEN adm_all, standard]
+
+lemma adm_subst: "[|cont t; adm P|] ==> adm(%x. P (t x))"
+apply (rule admI)
+apply (simplesubst cont2contlub [THEN contlubE, THEN spec, THEN mp])
+apply assumption
+apply assumption
+apply (erule admD)
+apply (erule cont2mono [THEN ch2ch_monofun])
+apply assumption
+apply assumption
+done
+
+lemma adm_UU_not_less: "adm(%x.~ UU << t(x))"
+apply (simp (no_asm))
+done
+
+
+lemma adm_not_UU: "cont(t)==> adm(%x.~ (t x) = UU)"
+
+apply (unfold adm_def)
+apply (intro strip)
+apply (rule contrapos_nn)
+apply (erule spec)
+apply (rule chain_UU_I [THEN spec])
+apply (erule cont2mono [THEN ch2ch_monofun])
+apply assumption
+apply (erule cont2contlub [THEN contlubE, THEN spec, THEN mp, THEN subst])
+apply assumption
+apply assumption
+done
+
+lemma adm_eq: "[|cont u ; cont v|]==> adm(%x. u x = v x)"
+apply (simp (no_asm_simp) add: po_eq_conv)
+done
+
+
+
+(* ------------------------------------------------------------------------ *)
+(* admissibility for disjunction is hard to prove. It takes 10 Lemmas       *)
+(* ------------------------------------------------------------------------ *)
+
+
+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)))"
+apply fast
+done
+
+lemma adm_disj_lemma2: "[| adm(Q); ? X. chain(X) & (!n. Q(X(n))) & 
+      lub(range(Y))=lub(range(X))|] ==> Q(lub(range(Y)))"
+apply (force elim: admD)
+done
+
+lemma adm_disj_lemma3: "chain Y ==> chain (%m. if m < Suc i then Y (Suc i) else Y m)"
+apply (unfold chain_def)
+apply (simp (no_asm_simp))
+apply safe
+apply (subgoal_tac "ia = i")
+apply (simp_all (no_asm_simp))
+done
+
+lemma adm_disj_lemma4: "!j. i < j --> Q(Y(j))  ==> !n. Q( if n < Suc i then Y(Suc i) else Y n)"
+apply (simp (no_asm_simp))
+done
+
+lemma adm_disj_lemma5: 
+  "!!Y::nat=>'a::cpo. [| chain(Y); ! j. i < j --> Q(Y(j)) |] ==> 
+          lub(range(Y)) = lub(range(%m. if m< Suc(i) then Y(Suc(i)) else Y m))"
+apply (safe intro!: lub_equal2 adm_disj_lemma3)
+prefer 2 apply (assumption)
+apply (rule_tac x = "i" in exI)
+apply (simp (no_asm_simp))
+done
+
+lemma adm_disj_lemma6: 
+  "[| chain(Y::nat=>'a::cpo); ? i. ! j. i < j --> Q(Y(j)) |] ==> 
+            ? X. chain(X) & (! n. Q(X(n))) & lub(range(Y)) = lub(range(X))"
+apply (erule exE)
+apply (rule_tac x = "%m. if m<Suc (i) then Y (Suc (i)) else Y m" in exI)
+apply (rule conjI)
+apply (rule adm_disj_lemma3)
+apply assumption
+apply (rule conjI)
+apply (rule adm_disj_lemma4)
+apply assumption
+apply (rule adm_disj_lemma5)
+apply assumption
+apply assumption
+done
+
+lemma adm_disj_lemma7: 
+  "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j))  |] ==> 
+            chain(%m. Y(Least(%j. m<j & P(Y(j)))))"
+apply (rule chainI)
+apply (rule chain_mono3)
+apply assumption
+apply (rule Least_le)
+apply (rule conjI)
+apply (rule Suc_lessD)
+apply (erule allE)
+apply (erule exE)
+apply (rule LeastI [THEN conjunct1])
+apply assumption
+apply (erule allE)
+apply (erule exE)
+apply (rule LeastI [THEN conjunct2])
+apply assumption
+done
+
+lemma adm_disj_lemma8: 
+  "[| ! i. ? j. i < j & P(Y(j)) |] ==> ! m. P(Y(LEAST j::nat. m<j & P(Y(j))))"
+apply (intro strip)
+apply (erule allE)
+apply (erule exE)
+apply (erule LeastI [THEN conjunct2])
+done
+
+lemma adm_disj_lemma9: 
+  "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==> 
+            lub(range(Y)) = lub(range(%m. Y(Least(%j. m<j & P(Y(j))))))"
+apply (rule antisym_less)
+apply (rule lub_mono)
+apply assumption
+apply (rule adm_disj_lemma7)
+apply assumption
+apply assumption
+apply (intro strip)
+apply (rule chain_mono)
+apply assumption
+apply (erule allE)
+apply (erule exE)
+apply (rule LeastI [THEN conjunct1])
+apply assumption
+apply (rule lub_mono3)
+apply (rule adm_disj_lemma7)
+apply assumption
+apply assumption
+apply assumption
+apply (intro strip)
+apply (rule exI)
+apply (rule chain_mono)
+apply assumption
+apply (rule lessI)
+done
+
+lemma adm_disj_lemma10: "[| chain(Y::nat=>'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==> 
+            ? X. chain(X) & (! n. P(X(n))) & lub(range(Y)) = lub(range(X))"
+apply (rule_tac x = "%m. Y (Least (%j. m<j & P (Y (j))))" in exI)
+apply (rule conjI)
+apply (rule adm_disj_lemma7)
+apply assumption
+apply assumption
+apply (rule conjI)
+apply (rule adm_disj_lemma8)
+apply assumption
+apply (rule adm_disj_lemma9)
+apply assumption
+apply assumption
+done
+
+lemma adm_disj_lemma12: "[| adm(P); chain(Y);? i. ! j. i < j --> P(Y(j))|]==>P(lub(range(Y)))"
+apply (erule adm_disj_lemma2)
+apply (erule adm_disj_lemma6)
+apply assumption
+done
+
+
+lemma adm_lemma11: 
+"[| adm(P); chain(Y); ! i. ? j. i < j & P(Y(j)) |]==>P(lub(range(Y)))"
+apply (erule adm_disj_lemma2)
+apply (erule adm_disj_lemma10)
+apply assumption
+done
+
+lemma adm_disj: "[| adm P; adm Q |] ==> adm(%x. P x | Q x)"
+apply (rule admI)
+apply (rule adm_disj_lemma1 [THEN disjE])
+apply assumption
+apply (rule disjI2)
+apply (erule adm_disj_lemma12)
+apply assumption
+apply assumption
+apply (rule disjI1)
+apply (erule adm_lemma11)
+apply assumption
+apply assumption
+done
+
+lemma adm_imp: "[| adm(%x.~(P x)); adm Q |] ==> adm(%x. P x --> Q x)"
+apply (subgoal_tac " (%x. P x --> Q x) = (%x. ~P x | Q x) ")
+apply (erule ssubst)
+apply (erule adm_disj)
+apply assumption
+apply (simp (no_asm))
+done
+
+lemma adm_iff: "[| adm (%x. P x --> Q x); adm (%x. Q x --> P x) |]  
+            ==> adm (%x. P x = Q x)"
+apply (subgoal_tac " (%x. P x = Q x) = (%x. (P x --> Q x) & (Q x --> P x))")
+apply (simp (no_asm_simp))
+apply (rule ext)
+apply fast
+done
+
+
+lemma adm_not_conj: "[| adm (%x. ~ P x); adm (%x. ~ Q x) |] ==> adm (%x. ~ (P x & Q x))"
+apply (subgoal_tac " (%x. ~ (P x & Q x)) = (%x. ~ P x | ~ Q x) ")
+apply (rule_tac [2] ext)
+prefer 2 apply fast
+apply (erule ssubst)
+apply (erule adm_disj)
+apply assumption
+done
+
+lemmas adm_lemmas = adm_not_free adm_imp adm_disj adm_eq adm_not_UU
+        adm_UU_not_less adm_all2 adm_not_less adm_not_conj adm_iff
+
+declare adm_lemmas [simp]
+
 end
 
--- a/src/HOLCF/Fun1.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,7 +0,0 @@
-
-(* legacy ML bindings *)
-
-val less_fun_def = thm "less_fun_def";
-val refl_less_fun = thm "refl_less_fun";
-val antisym_less_fun = thm "antisym_less_fun";
-val trans_less_fun = thm "trans_less_fun";
--- a/src/HOLCF/Fun1.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,65 +0,0 @@
-(*  Title:      HOLCF/Fun1.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Definition of the partial ordering for the type of all functions => (fun)
-
-REMARK: The ordering on 'a => 'b is only defined if 'b is in class po !!
-*)
-
-theory Fun1 = Pcpo:
-
-instance flat<chfin
-apply (intro_classes)
-apply (rule flat_imp_chfin)
-done
-
-(* to make << defineable: *)
-
-instance fun  :: (type, sq_ord) sq_ord ..
-
-defs (overloaded)
-  less_fun_def: "(op <<) == (%f1 f2.!x. f1 x << f2 x)"  
-
-(*  Title:      HOLCF/Fun1.ML
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Definition of the partial ordering for the type of all functions => (fun)
-*)
-
-(* ------------------------------------------------------------------------ *)
-(* less_fun is a partial order on 'a => 'b                                  *)
-(* ------------------------------------------------------------------------ *)
-
-lemma refl_less_fun: "(f::'a::type =>'b::po) << f"
-apply (unfold less_fun_def)
-apply (fast intro!: refl_less)
-done
-
-lemma antisym_less_fun:
-        "[|(f1::'a::type =>'b::po) << f2; f2 << f1|] ==> f1 = f2"
-apply (unfold less_fun_def)
-(* apply (cut_tac prems) *)
-apply (subst expand_fun_eq)
-apply (fast intro!: antisym_less)
-done
-
-lemma trans_less_fun:
-        "[|(f1::'a::type =>'b::po) << f2; f2 << f3 |] ==> f1 << f3"
-apply (unfold less_fun_def)
-(* apply (cut_tac prems) *)
-apply clarify
-apply (rule trans_less)
-apply (erule allE)
-apply assumption
-apply (erule allE, assumption)
-done
-
-end
-
-
-
-
--- a/src/HOLCF/Fun2.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,13 +0,0 @@
-
-(* legacy ML bindings *)
-
-val inst_fun_po = thm "inst_fun_po";
-val minimal_fun = thm "minimal_fun";
-val UU_fun_def = thm "UU_fun_def";
-val least_fun = thm "least_fun";
-val less_fun = thm "less_fun";
-val ch2ch_fun = thm "ch2ch_fun";
-val ub2ub_fun = thm "ub2ub_fun";
-val lub_fun = thm "lub_fun";
-val thelub_fun = thm "thelub_fun";
-val cpo_fun = thm "cpo_fun";
--- a/src/HOLCF/Fun2.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,111 +0,0 @@
-(*  Title:      HOLCF/Fun2.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-*)
-
-theory Fun2 = Fun1:
-
-(* default class is still type!*)
-
-instance fun  :: (type, po) po
-apply (intro_classes)
-apply (rule refl_less_fun)
-apply (rule antisym_less_fun, assumption+)
-apply (rule trans_less_fun, assumption+)
-done
-
-(*  Title:      HOLCF/Fun2.ML
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-*)
-
-(* for compatibility with old HOLCF-Version *)
-lemma inst_fun_po: "(op <<)=(%f g.!x. f x << g x)"
-apply (fold less_fun_def)
-apply (rule refl)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Type 'a::type => 'b::pcpo is pointed                                     *)
-(* ------------------------------------------------------------------------ *)
-
-lemma minimal_fun: "(%z. UU) << x"
-apply (simp (no_asm) add: inst_fun_po minimal)
-done
-
-lemmas UU_fun_def = minimal_fun [THEN minimal2UU, symmetric, standard]
-
-lemma least_fun: "? x::'a=>'b::pcpo.!y. x<<y"
-apply (rule_tac x = " (%z. UU) " in exI)
-apply (rule minimal_fun [THEN allI])
-done
-
-(* ------------------------------------------------------------------------ *)
-(* make the symbol << accessible for type fun                               *)
-(* ------------------------------------------------------------------------ *)
-
-lemma less_fun: "(f1 << f2) = (! x. f1(x) << f2(x))"
-apply (subst inst_fun_po)
-apply (rule refl)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* chains of functions yield chains in the po range                         *)
-(* ------------------------------------------------------------------------ *)
-
-lemma ch2ch_fun: "chain (S::nat=>('a=>'b::po)) ==> chain (%i. S i x)"
-
-apply (unfold chain_def)
-apply (simp add: less_fun)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* upper bounds of function chains yield upper bound in the po range        *)
-(* ------------------------------------------------------------------------ *)
-
-lemma ub2ub_fun: "range(S::nat=>('a::type => 'b::po)) <| u ==> range(%i. S i x) <| u(x)"
-apply (rule ub_rangeI)
-apply (drule ub_rangeD)
-apply (simp add: less_fun)
-apply auto
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Type 'a::type => 'b::pcpo is chain complete                              *)
-(* ------------------------------------------------------------------------ *)
-
-lemma lub_fun: "chain(S::nat=>('a::type => 'b::cpo)) ==>  
-         range(S) <<| (% x. lub(range(% i. S(i)(x))))"
-apply (rule is_lubI)
-apply (rule ub_rangeI)
-apply (subst less_fun)
-apply (rule allI)
-apply (rule is_ub_thelub)
-apply (erule ch2ch_fun)
-(* apply (intro strip) *)
-apply (subst less_fun)
-apply (rule allI)
-apply (rule is_lub_thelub)
-apply (erule ch2ch_fun)
-apply (erule ub2ub_fun)
-done
-
-lemmas thelub_fun = lub_fun [THEN thelubI, standard]
-(* chain ?S1 ==> lub (range ?S1) = (%x. lub (range (%i. ?S1 i x))) *)
-
-lemma cpo_fun: "chain(S::nat=>('a::type => 'b::cpo)) ==> ? x. range(S) <<| x"
-apply (rule exI)
-apply (erule lub_fun)
-done
-
-end
-
-
-
-
-
-
-
-
--- a/src/HOLCF/Fun3.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,4 +0,0 @@
-
-(* legacy ML bindings *)
-
-val inst_fun_pcpo = thm "inst_fun_pcpo";
--- a/src/HOLCF/Fun3.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,35 +0,0 @@
-(*  Title:      HOLCF/Fun3.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class instance of  => (fun) for class pcpo
-*)
-
-theory Fun3 = Fun2:
-
-(* default class is still type *)
-
-instance fun  :: (type, cpo) cpo
-apply (intro_classes)
-apply (erule cpo_fun)
-done
-
-instance fun  :: (type, pcpo)pcpo
-apply (intro_classes)
-apply (rule least_fun)
-done
-
-(*  Title:      HOLCF/Fun3.ML
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-*)
-
-(* for compatibility with old HOLCF-Version *)
-lemma inst_fun_pcpo: "UU = (%x. UU)"
-apply (simp add: UU_def UU_fun_def)
-done
-
-end
-
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/FunCpo.ML	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,18 @@
+
+(* legacy ML bindings *)
+
+val less_fun_def = thm "less_fun_def";
+val refl_less_fun = thm "refl_less_fun";
+val antisym_less_fun = thm "antisym_less_fun";
+val trans_less_fun = thm "trans_less_fun";
+val inst_fun_po = thm "inst_fun_po";
+val minimal_fun = thm "minimal_fun";
+val UU_fun_def = thm "UU_fun_def";
+val least_fun = thm "least_fun";
+val less_fun = thm "less_fun";
+val ch2ch_fun = thm "ch2ch_fun";
+val ub2ub_fun = thm "ub2ub_fun";
+val lub_fun = thm "lub_fun";
+val thelub_fun = thm "thelub_fun";
+val cpo_fun = thm "cpo_fun";
+val inst_fun_pcpo = thm "inst_fun_pcpo";
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/FunCpo.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,157 @@
+(*  Title:      HOLCF/Fun1.thy
+    ID:         $Id$
+    Author:     Franz Regensburger
+    License:    GPL (GNU GENERAL PUBLIC LICENSE)
+
+Definition of the partial ordering for the type of all functions => (fun)
+
+REMARK: The ordering on 'a => 'b is only defined if 'b is in class po !!
+
+Class instance of  => (fun) for class pcpo
+*)
+
+header {* Class instances for the type of all functions *}
+
+theory FunCpo = Pcpo:
+
+(* to make << defineable: *)
+
+instance fun  :: (type, sq_ord) sq_ord ..
+
+defs (overloaded)
+  less_fun_def: "(op <<) == (%f1 f2.!x. f1 x << f2 x)"  
+
+(* ------------------------------------------------------------------------ *)
+(* less_fun is a partial order on 'a => 'b                                  *)
+(* ------------------------------------------------------------------------ *)
+
+lemma refl_less_fun: "(f::'a::type =>'b::po) << f"
+apply (unfold less_fun_def)
+apply (fast intro!: refl_less)
+done
+
+lemma antisym_less_fun:
+        "[|(f1::'a::type =>'b::po) << f2; f2 << f1|] ==> f1 = f2"
+apply (unfold less_fun_def)
+(* apply (cut_tac prems) *)
+apply (subst expand_fun_eq)
+apply (fast intro!: antisym_less)
+done
+
+lemma trans_less_fun:
+        "[|(f1::'a::type =>'b::po) << f2; f2 << f3 |] ==> f1 << f3"
+apply (unfold less_fun_def)
+(* apply (cut_tac prems) *)
+apply clarify
+apply (rule trans_less)
+apply (erule allE)
+apply assumption
+apply (erule allE, assumption)
+done
+
+(* default class is still type!*)
+
+instance fun  :: (type, po) po
+apply (intro_classes)
+apply (rule refl_less_fun)
+apply (rule antisym_less_fun, assumption+)
+apply (rule trans_less_fun, assumption+)
+done
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_fun_po: "(op <<)=(%f g.!x. f x << g x)"
+apply (fold less_fun_def)
+apply (rule refl)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Type 'a::type => 'b::pcpo is pointed                                     *)
+(* ------------------------------------------------------------------------ *)
+
+lemma minimal_fun: "(%z. UU) << x"
+apply (simp (no_asm) add: inst_fun_po minimal)
+done
+
+lemmas UU_fun_def = minimal_fun [THEN minimal2UU, symmetric, standard]
+
+lemma least_fun: "? x::'a=>'b::pcpo.!y. x<<y"
+apply (rule_tac x = " (%z. UU) " in exI)
+apply (rule minimal_fun [THEN allI])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* make the symbol << accessible for type fun                               *)
+(* ------------------------------------------------------------------------ *)
+
+lemma less_fun: "(f1 << f2) = (! x. f1(x) << f2(x))"
+apply (subst inst_fun_po)
+apply (rule refl)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* chains of functions yield chains in the po range                         *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ch2ch_fun: "chain (S::nat=>('a=>'b::po)) ==> chain (%i. S i x)"
+apply (unfold chain_def)
+apply (simp add: less_fun)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* upper bounds of function chains yield upper bound in the po range        *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ub2ub_fun: "range(S::nat=>('a::type => 'b::po)) <| u ==> range(%i. S i x) <| u(x)"
+apply (rule ub_rangeI)
+apply (drule ub_rangeD)
+apply (simp add: less_fun)
+apply auto
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Type 'a::type => 'b::pcpo is chain complete                              *)
+(* ------------------------------------------------------------------------ *)
+
+lemma lub_fun: "chain(S::nat=>('a::type => 'b::cpo)) ==>  
+         range(S) <<| (% x. lub(range(% i. S(i)(x))))"
+apply (rule is_lubI)
+apply (rule ub_rangeI)
+apply (subst less_fun)
+apply (rule allI)
+apply (rule is_ub_thelub)
+apply (erule ch2ch_fun)
+(* apply (intro strip) *)
+apply (subst less_fun)
+apply (rule allI)
+apply (rule is_lub_thelub)
+apply (erule ch2ch_fun)
+apply (erule ub2ub_fun)
+done
+
+lemmas thelub_fun = lub_fun [THEN thelubI, standard]
+(* chain ?S1 ==> lub (range ?S1) = (%x. lub (range (%i. ?S1 i x))) *)
+
+lemma cpo_fun: "chain(S::nat=>('a::type => 'b::cpo)) ==> ? x. range(S) <<| x"
+apply (rule exI)
+apply (erule lub_fun)
+done
+
+(* default class is still type *)
+
+instance fun  :: (type, cpo) cpo
+apply (intro_classes)
+apply (erule cpo_fun)
+done
+
+instance fun  :: (type, pcpo)pcpo
+apply (intro_classes)
+apply (rule least_fun)
+done
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_fun_pcpo: "UU = (%x. UU)"
+apply (simp add: UU_def UU_fun_def)
+done
+
+end
+
--- a/src/HOLCF/HOLCF.thy	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/HOLCF.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -5,4 +5,4 @@
 Top theory for HOLCF system.
 *)
 
-HOLCF = Sprod3 + Ssum3 + Up3 + Lift + Discrete + One + Tr
+HOLCF = Sprod + Ssum + Up + Lift + Discrete + One + Tr
--- a/src/HOLCF/IsaMakefile	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/IsaMakefile	Fri Mar 04 23:12:36 2005 +0100
@@ -27,15 +27,15 @@
 HOL:
 	@cd $(SRC)/HOL; $(ISATOOL) make HOL
 
-$(OUT)/HOLCF: $(OUT)/HOL Cfun1.ML Cfun1.thy Cfun2.ML Cfun2.thy \
-  Cfun3.ML Cfun3.thy Cont.ML Cont.thy Cprod1.ML Cprod1.thy Cprod2.ML \
-  Cprod2.thy Cprod3.ML Cprod3.thy Discrete.thy Fix.ML Fix.thy Fun1.ML \
-  Fun1.thy Fun2.ML Fun2.thy Fun3.ML Fun3.thy HOLCF.ML HOLCF.thy Lift.ML \
-  Lift.thy One.ML One.thy Pcpo.ML Pcpo.thy Porder.ML Porder.thy Porder0.ML \
-  Porder0.thy ROOT.ML Sprod0.ML Sprod0.thy Sprod1.ML Sprod1.thy \
-  Sprod2.ML Sprod2.thy Sprod3.ML Sprod3.thy Ssum0.ML Ssum0.thy Ssum1.ML \
-  Ssum1.thy Ssum2.ML Ssum2.thy Ssum3.ML Ssum3.thy Tr.ML Tr.thy Up1.ML \
-  Up1.thy Up2.ML Up2.thy Up3.ML Up3.thy adm.ML cont_consts.ML \
+$(OUT)/HOLCF: $(OUT)/HOL Cfun.ML Cfun.thy \
+  Cont.ML Cont.thy Cprod.ML Cprod.thy \
+  Discrete.thy Fix.ML Fix.thy FunCpo.ML \
+  FunCpo.thy HOLCF.ML HOLCF.thy Lift.ML \
+  Lift.thy One.ML One.thy Pcpo.ML Pcpo.thy Porder.ML Porder.thy \
+  ROOT.ML Sprod.ML Sprod.thy \
+  Ssum.ML Ssum.thy \
+  Tr.ML Tr.thy Up.ML \
+  Up.thy adm.ML cont_consts.ML \
   domain/axioms.ML domain/extender.ML domain/interface.ML \
   domain/library.ML domain/syntax.ML domain/theorems.ML holcf_logic.ML \
   ex/Stream.thy
--- a/src/HOLCF/Lift.thy	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/Lift.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -5,7 +5,7 @@
 
 header {* Lifting types of class type to flat pcpo's *}
 
-theory Lift = Cprod3:
+theory Lift = Cprod:
 
 defaultsort type
 
--- a/src/HOLCF/One.ML	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/One.ML	Fri Mar 04 23:12:36 2005 +0100
@@ -1,42 +1,7 @@
-(*  Title:      HOLCF/One.ML
-    ID:         $Id$
-    Author:     Oscar Slotosch
 
-The unit domain.
-*)
-
-(* ------------------------------------------------------------------------ *)
-(* Exhaustion and Elimination for type one                                  *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [ONE_def] "t=UU | t = ONE";
-by (induct_tac "t" 1);
-by (Simp_tac 1);
-by (Simp_tac 1);
-qed "Exh_one";
+(* legacy ML bindings *)
 
-val prems = Goal "[| p=UU ==> Q; p = ONE ==>Q|] ==>Q";
-by (rtac (Exh_one RS disjE) 1);
-by (eresolve_tac prems 1);
-by (eresolve_tac prems 1);
-qed "oneE";
-
-(* ------------------------------------------------------------------------ *) 
-(* tactic for one-thms                                                      *)
-(* ------------------------------------------------------------------------ *)
-
-fun prover t = prove_goalw thy [ONE_def] t
- (fn prems =>
-        [
-	(asm_simp_tac (simpset() addsimps [inst_lift_po]) 1)
-	]);
-
-(* ------------------------------------------------------------------------ *)
-(* distinctness for type one : stored in a list                             *)
-(* ------------------------------------------------------------------------ *)
-
-val dist_less_one = map prover ["~ONE << UU"];
-
-val dist_eq_one = map prover ["ONE~=UU","UU~=ONE"];
-
-Addsimps (dist_less_one@dist_eq_one);
+val Exh_one = thm "Exh_one";
+val oneE = thm "oneE";
+val dist_less_one = thm "dist_less_one";
+val dist_eq_one = thms "dist_eq_one";
--- a/src/HOLCF/One.thy	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/One.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -1,11 +1,12 @@
 (*  Title:      HOLCF/One.thy
     ID:         $Id$
     Author:     Oscar Slotosch
+    License:    GPL (GNU GENERAL PUBLIC LICENSE)
 *)
 
-One = Lift +
+theory One = Lift:
 
-types one = unit lift
+types one = "unit lift"
 
 constdefs
   ONE :: "one"
@@ -14,4 +15,39 @@
 translations
   "one" <= (type) "unit lift" 
 
+(*  Title:      HOLCF/One.ML
+    ID:         $Id$
+    Author:     Oscar Slotosch
+    License:    GPL (GNU GENERAL PUBLIC LICENSE)
+
+The unit domain.
+*)
+
+(* ------------------------------------------------------------------------ *)
+(* Exhaustion and Elimination for type one                                  *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Exh_one: "t=UU | t = ONE"
+apply (unfold ONE_def)
+apply (induct t)
+apply simp
+apply simp
+done
+
+lemma oneE: "[| p=UU ==> Q; p = ONE ==>Q|] ==>Q"
+apply (rule Exh_one [THEN disjE])
+apply fast
+apply fast
+done
+
+lemma dist_less_one [simp]: "~ONE << UU"
+apply (unfold ONE_def)
+apply (simp add: inst_lift_po)
+done
+
+lemma dist_eq_one [simp]: "ONE~=UU" "UU~=ONE"
+apply (unfold ONE_def)
+apply (simp_all add: inst_lift_po)
+done
+
 end
--- a/src/HOLCF/Pcpo.thy	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/Pcpo.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -5,6 +5,9 @@
 
 introduction of the classes cpo and pcpo 
 *)
+
+header {* Classes cpo and pcpo *}
+
 theory Pcpo = Porder:
 
 (* The class cpo of chain complete partial orders *)
@@ -318,4 +321,10 @@
 apply (unfold max_in_chain_def)
 apply (fast dest: le_imp_less_or_eq elim: chain_mono)
 done
+
+instance flat<chfin
+apply (intro_classes)
+apply (rule flat_imp_chfin)
+done
+
 end 
--- a/src/HOLCF/Porder.ML	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/Porder.ML	Fri Mar 04 23:12:36 2005 +0100
@@ -1,6 +1,13 @@
 
 (* legacy ML bindings *)
 
+val refl_less = thm "refl_less";
+val antisym_less = thm "antisym_less";
+val trans_less = thm "trans_less";
+val minimal2UU = thm "minimal2UU";
+val antisym_less_inverse = thm "antisym_less_inverse";
+val box_less = thm "box_less";
+val po_eq_conv = thm "po_eq_conv";
 val is_ub_def = thm "is_ub_def";
 val is_lub_def = thm "is_lub_def";
 val tord_def = thm "tord_def";
--- a/src/HOLCF/Porder.thy	Fri Mar 04 18:53:46 2005 +0100
+++ b/src/HOLCF/Porder.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -3,10 +3,53 @@
     Author:     Franz Regensburger
     License:    GPL (GNU GENERAL PUBLIC LICENSE)
 
+Definition of class porder (partial order).
 Conservative extension of theory Porder0 by constant definitions 
 *)
 
-theory Porder = Porder0:
+header {* Type class of partial orders *}
+
+theory Porder = Main:
+
+	(* introduce a (syntactic) class for the constant << *)
+axclass sq_ord < type
+
+	(* characteristic constant << for po *)
+consts
+  "<<"          :: "['a,'a::sq_ord] => bool"        (infixl 55)
+
+syntax (xsymbols)
+  "op <<"       :: "['a,'a::sq_ord] => bool"        (infixl "\<sqsubseteq>" 55)
+
+axclass po < sq_ord
+        (* class axioms: *)
+refl_less [iff]: "x << x"        
+antisym_less:    "[|x << y; y << x |] ==> x = y"    
+trans_less:      "[|x << y; y << z |] ==> x << z"
+
+text {* minimal fixes least element *}
+
+lemma minimal2UU[OF allI] : "!x::'a::po. uu<<x ==> uu=(@u.!y. u<<y)"
+apply (blast intro: someI2 antisym_less)
+done
+
+text {* the reverse law of anti-symmetry of @{term "op <<"} *}
+
+lemma antisym_less_inverse: "(x::'a::po)=y ==> x << y & y << x"
+apply blast
+done
+
+lemma box_less: "[| (a::'a::po) << b; c << a; b << d|] ==> c << d"
+apply (erule trans_less)
+apply (erule trans_less)
+apply assumption
+done
+
+lemma po_eq_conv: "((x::'a::po)=y) = (x << y & y << x)"
+apply (fast elim!: antisym_less_inverse intro!: antisym_less)
+done
+
+subsection {* Constant definitions *}
 
 consts  
         "<|"    ::      "['a set,'a::po] => bool"       (infixl 55)
@@ -21,11 +64,9 @@
   "@LUB"	:: "('b => 'a) => 'a"	(binder "LUB " 10)
 
 translations
-
   "LUB x. t"	== "lub(range(%x. t))"
 
 syntax (xsymbols)
-
   "LUB "	:: "[idts, 'a] => 'a"		("(3\<Squnion>_./ _)"[0,10] 10)
 
 defs
@@ -46,18 +87,7 @@
 
 lub_def:          "lub S == (@x. S <<| x)"
 
-(*  Title:      HOLCF/Porder
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Conservative extension of theory Porder0 by constant definitions 
-*)
-
-(* ------------------------------------------------------------------------ *)
-(* lubs are unique                                                          *)
-(* ------------------------------------------------------------------------ *)
-
+text {* lubs are unique *}
 
 lemma unique_lub: 
         "[| S <<| x ; S <<| y |] ==> x=y"
@@ -65,9 +95,7 @@
 apply (blast intro: antisym_less)
 done
 
-(* ------------------------------------------------------------------------ *)
-(* chains are monotone functions                                            *)
-(* ------------------------------------------------------------------------ *)
+text {* chains are monotone functions *}
 
 lemma chain_mono [rule_format]: "chain F ==> x<y --> F x<<F y"
 apply (unfold chain_def)
@@ -82,10 +110,7 @@
 apply (blast intro: chain_mono)
 done
 
-
-(* ------------------------------------------------------------------------ *)
-(* The range of a chain is a totally ordered     <<                         *)
-(* ------------------------------------------------------------------------ *)
+text {* The range of a chain is a totally ordered *}
 
 lemma chain_tord: "chain(F) ==> tord(range(F))"
 apply (unfold tord_def)
@@ -94,10 +119,8 @@
 apply (fast intro: chain_mono)+
 done
 
+text {* technical lemmas about @{term lub} and @{term is_lub} *}
 
-(* ------------------------------------------------------------------------ *)
-(* technical lemmas about lub and is_lub                                    *)
-(* ------------------------------------------------------------------------ *)
 lemmas lub = lub_def [THEN meta_eq_to_obj_eq, standard]
 
 lemma lubI[OF exI]: "EX x. M <<| x ==> M <<| lub(M)"
@@ -111,15 +134,11 @@
 apply assumption
 done
 
-
-lemma lub_singleton: "lub{x} = x"
+lemma lub_singleton [simp]: "lub{x} = x"
 apply (simp (no_asm) add: thelubI is_lub_def is_ub_def)
 done
-declare lub_singleton [simp]
 
-(* ------------------------------------------------------------------------ *)
-(* access to some definition as inference rule                              *)
-(* ------------------------------------------------------------------------ *)
+text {* access to some definition as inference rule *}
 
 lemma is_lubD1: "S <<| x ==> S <| x"
 apply (unfold is_lub_def)
@@ -153,9 +172,7 @@
 apply (erule chainE)
 done
 
-(* ------------------------------------------------------------------------ *)
-(* technical lemmas about (least) upper bounds of chains                    *)
-(* ------------------------------------------------------------------------ *)
+text {* technical lemmas about (least) upper bounds of chains *}
 
 lemma ub_rangeD: "range S <| x  ==> S(i) << x"
 apply (unfold is_ub_def)
@@ -170,10 +187,7 @@
 lemmas is_ub_lub = is_lubD1 [THEN ub_rangeD, standard]
 (* range(?S1) <<| ?x1 ==> ?S1(?x) << ?x1                                    *)
 
-
-(* ------------------------------------------------------------------------ *)
-(* results about finite chains                                              *)
-(* ------------------------------------------------------------------------ *)
+text {* results about finite chains *}
 
 lemma lub_finch1: 
         "[| chain C; max_in_chain i C|] ==> range C <<| C i"
@@ -200,7 +214,6 @@
 apply blast
 done
 
-
 lemma bin_chain: "x<<y ==> chain (%i. if i=0 then x else y)"
 apply (rule chainI)
 apply (induct_tac "i")
@@ -222,17 +235,13 @@
 apply (simp (no_asm))
 done
 
-(* ------------------------------------------------------------------------ *)
-(* the maximal element in a chain is its lub                                *)
-(* ------------------------------------------------------------------------ *)
+text {* the maximal element in a chain is its lub *}
 
 lemma lub_chain_maxelem: "[| Y i = c;  ALL i. Y i<<c |] ==> lub(range Y) = c"
 apply (blast dest: ub_rangeD intro: thelubI is_lubI ub_rangeI)
 done
 
-(* ------------------------------------------------------------------------ *)
-(* the lub of a constant chain is the constant                              *)
-(* ------------------------------------------------------------------------ *)
+text {* the lub of a constant chain is the constant *}
 
 lemma lub_const: "range(%x. c) <<| c"
 apply (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
--- a/src/HOLCF/Porder0.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,10 +0,0 @@
-
-(* legacy ML bindings *)
-
-val refl_less = thm "refl_less";
-val antisym_less = thm "antisym_less";
-val trans_less = thm "trans_less";
-val minimal2UU = thm "minimal2UU";
-val antisym_less_inverse = thm "antisym_less_inverse";
-val box_less = thm "box_less";
-val po_eq_conv = thm "po_eq_conv";
--- a/src/HOLCF/Porder0.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,56 +0,0 @@
-(*  Title:      HOLCF/Porder0.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Definition of class porder (partial order).
-*)
-
-theory Porder0 = Main:
-
-	(* introduce a (syntactic) class for the constant << *)
-axclass sq_ord < type
-
-	(* characteristic constant << for po *)
-consts
-  "<<"          :: "['a,'a::sq_ord] => bool"        (infixl 55)
-
-syntax (xsymbols)
-  "op <<"       :: "['a,'a::sq_ord] => bool"        (infixl "\<sqsubseteq>" 55)
-
-axclass po < sq_ord
-        (* class axioms: *)
-refl_less:       "x << x"        
-antisym_less:    "[|x << y; y << x |] ==> x = y"    
-trans_less:      "[|x << y; y << z |] ==> x << z"
-
-declare refl_less [iff]
-
-(* ------------------------------------------------------------------------ *)
-(* minimal fixes least element                                              *)
-(* ------------------------------------------------------------------------ *)
-lemma minimal2UU[OF allI] : "!x::'a::po. uu<<x ==> uu=(@u.!y. u<<y)"
-apply (blast intro: someI2 antisym_less)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* the reverse law of anti--symmetrie of <<                                 *)
-(* ------------------------------------------------------------------------ *)
-
-lemma antisym_less_inverse: "(x::'a::po)=y ==> x << y & y << x"
-apply blast
-done
-
-
-lemma box_less: "[| (a::'a::po) << b; c << a; b << d|] ==> c << d"
-apply (erule trans_less)
-apply (erule trans_less)
-apply assumption
-done
-
-lemma po_eq_conv: "((x::'a::po)=y) = (x << y & y << x)"
-apply (fast elim!: antisym_less_inverse intro!: antisym_less)
-done
-end 
-
-
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Sprod.ML	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,101 @@
+
+(* legacy ML bindings *)
+
+val Ispair_def = thm "Ispair_def";
+val Isfst_def = thm "Isfst_def";
+val Issnd_def = thm "Issnd_def";
+val SprodI = thm "SprodI";
+val inj_on_Abs_Sprod = thm "inj_on_Abs_Sprod";
+val strict_Spair_Rep = thm "strict_Spair_Rep";
+val defined_Spair_Rep_rev = thm "defined_Spair_Rep_rev";
+val inject_Spair_Rep = thm "inject_Spair_Rep";
+val inject_Ispair = thm "inject_Ispair";
+val strict_Ispair = thm "strict_Ispair";
+val strict_Ispair1 = thm "strict_Ispair1";
+val strict_Ispair2 = thm "strict_Ispair2";
+val strict_Ispair_rev = thm "strict_Ispair_rev";
+val defined_Ispair_rev = thm "defined_Ispair_rev";
+val defined_Ispair = thm "defined_Ispair";
+val Exh_Sprod = thm "Exh_Sprod";
+val IsprodE = thm "IsprodE";
+val strict_Isfst = thm "strict_Isfst";
+val strict_Isfst1 = thm "strict_Isfst1";
+val strict_Isfst2 = thm "strict_Isfst2";
+val strict_Issnd = thm "strict_Issnd";
+val strict_Issnd1 = thm "strict_Issnd1";
+val strict_Issnd2 = thm "strict_Issnd2";
+val Isfst = thm "Isfst";
+val Issnd = thm "Issnd";
+val Isfst2 = thm "Isfst2";
+val Issnd2 = thm "Issnd2";
+val Sprod0_ss = [strict_Isfst1, strict_Isfst2, strict_Issnd1, strict_Issnd2,
+                 Isfst2, Issnd2]
+val defined_IsfstIssnd = thm "defined_IsfstIssnd";
+val surjective_pairing_Sprod = thm "surjective_pairing_Sprod";
+val Sel_injective_Sprod = thm "Sel_injective_Sprod";
+val less_sprod_def = thm "less_sprod_def";
+val refl_less_sprod = thm "refl_less_sprod";
+val antisym_less_sprod = thm "antisym_less_sprod";
+val trans_less_sprod = thm "trans_less_sprod";
+val inst_sprod_po = thm "inst_sprod_po";
+val minimal_sprod = thm "minimal_sprod";
+val UU_sprod_def = thm "UU_sprod_def";
+val least_sprod = thm "least_sprod";
+val monofun_Ispair1 = thm "monofun_Ispair1";
+val monofun_Ispair2 = thm "monofun_Ispair2";
+val monofun_Ispair = thm "monofun_Ispair";
+val monofun_Isfst = thm "monofun_Isfst";
+val monofun_Issnd = thm "monofun_Issnd";
+val lub_sprod = thm "lub_sprod";
+val thelub_sprod = thm "thelub_sprod";
+val cpo_sprod = thm "cpo_sprod";
+val spair_def = thm "spair_def";
+val sfst_def = thm "sfst_def";
+val ssnd_def = thm "ssnd_def";
+val ssplit_def = thm "ssplit_def";
+val inst_sprod_pcpo = thm "inst_sprod_pcpo";
+val sprod3_lemma1 = thm "sprod3_lemma1";
+val sprod3_lemma2 = thm "sprod3_lemma2";
+val sprod3_lemma3 = thm "sprod3_lemma3";
+val contlub_Ispair1 = thm "contlub_Ispair1";
+val sprod3_lemma4 = thm "sprod3_lemma4";
+val sprod3_lemma5 = thm "sprod3_lemma5";
+val sprod3_lemma6 = thm "sprod3_lemma6";
+val contlub_Ispair2 = thm "contlub_Ispair2";
+val cont_Ispair1 = thm "cont_Ispair1";
+val cont_Ispair2 = thm "cont_Ispair2";
+val contlub_Isfst = thm "contlub_Isfst";
+val contlub_Issnd = thm "contlub_Issnd";
+val cont_Isfst = thm "cont_Isfst";
+val cont_Issnd = thm "cont_Issnd";
+val spair_eq = thm "spair_eq";
+val beta_cfun_sprod = thm "beta_cfun_sprod";
+val inject_spair = thm "inject_spair";
+val inst_sprod_pcpo2 = thm "inst_sprod_pcpo2";
+val strict_spair = thm "strict_spair";
+val strict_spair1 = thm "strict_spair1";
+val strict_spair2 = thm "strict_spair2";
+val strict_spair_rev = thm "strict_spair_rev";
+val defined_spair_rev = thm "defined_spair_rev";
+val defined_spair = thm "defined_spair";
+val Exh_Sprod2 = thm "Exh_Sprod2";
+val sprodE = thm "sprodE";
+val strict_sfst = thm "strict_sfst";
+val strict_sfst1 = thm "strict_sfst1";
+val strict_sfst2 = thm "strict_sfst2";
+val strict_ssnd = thm "strict_ssnd";
+val strict_ssnd1 = thm "strict_ssnd1";
+val strict_ssnd2 = thm "strict_ssnd2";
+val sfst2 = thm "sfst2";
+val ssnd2 = thm "ssnd2";
+val defined_sfstssnd = thm "defined_sfstssnd";
+val surjective_pairing_Sprod2 = thm "surjective_pairing_Sprod2";
+val lub_sprod2 = thm "lub_sprod2";
+val thelub_sprod2 = thm "thelub_sprod2";
+val ssplit1 = thm "ssplit1";
+val ssplit2 = thm "ssplit2";
+val ssplit3 = thm "ssplit3";
+val Sprod_rews = [strict_sfst1, strict_sfst2,
+                strict_ssnd1, strict_ssnd2, sfst2, ssnd2, defined_spair,
+                ssplit1, ssplit2]
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Sprod.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,1029 @@
+(*  Title:      HOLCF/Sprod0.thy
+    ID:         $Id$
+    Author:     Franz Regensburger
+    License:    GPL (GNU GENERAL PUBLIC LICENSE)
+
+Strict product with typedef.
+*)
+
+header {* The type of strict products *}
+
+theory Sprod = Cfun:
+
+constdefs
+  Spair_Rep     :: "['a,'b] => ['a,'b] => bool"
+ "Spair_Rep == (%a b. %x y.(~a=UU & ~b=UU --> x=a  & y=b ))"
+
+typedef (Sprod)  ('a, 'b) "**" (infixr 20) = "{f. ? a b. f = Spair_Rep (a::'a) (b::'b)}"
+by auto
+
+syntax (xsymbols)
+  "**"		:: "[type, type] => type"	 ("(_ \<otimes>/ _)" [21,20] 20)
+syntax (HTML output)
+  "**"		:: "[type, type] => type"	 ("(_ \<otimes>/ _)" [21,20] 20)
+
+subsection {* @{term Ispair}, @{term Isfst}, and @{term Issnd} *}
+
+consts
+  Ispair        :: "['a,'b] => ('a ** 'b)"
+  Isfst         :: "('a ** 'b) => 'a"
+  Issnd         :: "('a ** 'b) => 'b"  
+
+defs
+   (*defining the abstract constants*)
+
+  Ispair_def:    "Ispair a b == Abs_Sprod(Spair_Rep a b)"
+
+  Isfst_def:     "Isfst(p) == @z.        (p=Ispair UU UU --> z=UU)
+                &(! a b. ~a=UU & ~b=UU & p=Ispair a b   --> z=a)"  
+
+  Issnd_def:     "Issnd(p) == @z.        (p=Ispair UU UU  --> z=UU)
+                &(! a b. ~a=UU & ~b=UU & p=Ispair a b    --> z=b)"  
+
+(* ------------------------------------------------------------------------ *)
+(* A non-emptyness result for Sprod                                         *)
+(* ------------------------------------------------------------------------ *)
+
+lemma SprodI: "(Spair_Rep a b):Sprod"
+apply (unfold Sprod_def)
+apply (rule CollectI, rule exI, rule exI, rule refl)
+done
+
+lemma inj_on_Abs_Sprod: "inj_on Abs_Sprod Sprod"
+apply (rule inj_on_inverseI)
+apply (erule Abs_Sprod_inverse)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Strictness and definedness of Spair_Rep                                  *)
+(* ------------------------------------------------------------------------ *)
+
+lemma strict_Spair_Rep: 
+ "(a=UU | b=UU) ==> (Spair_Rep a b) = (Spair_Rep UU UU)"
+apply (unfold Spair_Rep_def)
+apply (rule ext)
+apply (rule ext)
+apply (rule iffI)
+apply fast
+apply fast
+done
+
+lemma defined_Spair_Rep_rev: 
+ "(Spair_Rep a b) = (Spair_Rep UU UU) ==> (a=UU | b=UU)"
+apply (unfold Spair_Rep_def)
+apply (case_tac "a=UU|b=UU")
+apply assumption
+apply (fast dest: fun_cong)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* injectivity of Spair_Rep and Ispair                                      *)
+(* ------------------------------------------------------------------------ *)
+
+lemma inject_Spair_Rep: 
+"[|~aa=UU ; ~ba=UU ; Spair_Rep a b = Spair_Rep aa ba |] ==> a=aa & b=ba"
+
+apply (unfold Spair_Rep_def)
+apply (drule fun_cong)
+apply (drule fun_cong)
+apply (erule iffD1 [THEN mp])
+apply auto
+done
+
+lemma inject_Ispair: 
+        "[|~aa=UU ; ~ba=UU ; Ispair a b = Ispair aa ba |] ==> a=aa & b=ba"
+apply (unfold Ispair_def)
+apply (erule inject_Spair_Rep)
+apply assumption
+apply (erule inj_on_Abs_Sprod [THEN inj_onD])
+apply (rule SprodI)
+apply (rule SprodI)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* strictness and definedness of Ispair                                     *)
+(* ------------------------------------------------------------------------ *)
+
+lemma strict_Ispair: 
+ "(a=UU | b=UU) ==> Ispair a b = Ispair UU UU"
+apply (unfold Ispair_def)
+apply (erule strict_Spair_Rep [THEN arg_cong])
+done
+
+lemma strict_Ispair1: 
+        "Ispair UU b  = Ispair UU UU"
+apply (unfold Ispair_def)
+apply (rule strict_Spair_Rep [THEN arg_cong])
+apply (rule disjI1)
+apply (rule refl)
+done
+
+lemma strict_Ispair2: 
+        "Ispair a UU = Ispair UU UU"
+apply (unfold Ispair_def)
+apply (rule strict_Spair_Rep [THEN arg_cong])
+apply (rule disjI2)
+apply (rule refl)
+done
+
+lemma strict_Ispair_rev: "~Ispair x y = Ispair UU UU ==> ~x=UU & ~y=UU"
+apply (rule de_Morgan_disj [THEN subst])
+apply (erule contrapos_nn)
+apply (erule strict_Ispair)
+done
+
+lemma defined_Ispair_rev: 
+        "Ispair a b  = Ispair UU UU ==> (a = UU | b = UU)"
+apply (unfold Ispair_def)
+apply (rule defined_Spair_Rep_rev)
+apply (rule inj_on_Abs_Sprod [THEN inj_onD])
+apply assumption
+apply (rule SprodI)
+apply (rule SprodI)
+done
+
+lemma defined_Ispair: "[|a~=UU; b~=UU|] ==> (Ispair a b) ~= (Ispair UU UU)"
+apply (rule contrapos_nn)
+apply (erule_tac [2] defined_Ispair_rev)
+apply (rule de_Morgan_disj [THEN iffD2])
+apply (erule conjI)
+apply assumption
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* Exhaustion of the strict product **                                      *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Exh_Sprod:
+        "z=Ispair UU UU | (? a b. z=Ispair a b & a~=UU & b~=UU)"
+apply (unfold Ispair_def)
+apply (rule Rep_Sprod[unfolded Sprod_def, THEN CollectE])
+apply (erule exE)
+apply (erule exE)
+apply (rule excluded_middle [THEN disjE])
+apply (rule disjI2)
+apply (rule exI)
+apply (rule exI)
+apply (rule conjI)
+apply (rule Rep_Sprod_inverse [symmetric, THEN trans])
+apply (erule arg_cong)
+apply (rule de_Morgan_disj [THEN subst])
+apply assumption
+apply (rule disjI1)
+apply (rule Rep_Sprod_inverse [symmetric, THEN trans])
+apply (rule_tac f = "Abs_Sprod" in arg_cong)
+apply (erule trans)
+apply (erule strict_Spair_Rep)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* general elimination rule for strict product                              *)
+(* ------------------------------------------------------------------------ *)
+
+lemma IsprodE:
+assumes prem1: "p=Ispair UU UU ==> Q"
+assumes prem2: "!!x y. [|p=Ispair x y; x~=UU ; y~=UU|] ==> Q"
+shows "Q"
+apply (rule Exh_Sprod [THEN disjE])
+apply (erule prem1)
+apply (erule exE)
+apply (erule exE)
+apply (erule conjE)
+apply (erule conjE)
+apply (erule prem2)
+apply assumption
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* some results about the selectors Isfst, Issnd                            *)
+(* ------------------------------------------------------------------------ *)
+
+lemma strict_Isfst: "p=Ispair UU UU ==> Isfst p = UU"
+apply (unfold Isfst_def)
+apply (rule some_equality)
+apply (rule conjI)
+apply fast
+apply (intro strip)
+apply (rule_tac P = "Ispair UU UU = Ispair a b" in notE)
+apply (rule not_sym)
+apply (rule defined_Ispair)
+apply (fast+)
+done
+
+lemma strict_Isfst1 [simp]: "Isfst(Ispair UU y) = UU"
+apply (subst strict_Ispair1)
+apply (rule strict_Isfst)
+apply (rule refl)
+done
+
+lemma strict_Isfst2 [simp]: "Isfst(Ispair x UU) = UU"
+apply (subst strict_Ispair2)
+apply (rule strict_Isfst)
+apply (rule refl)
+done
+
+lemma strict_Issnd: "p=Ispair UU UU ==>Issnd p=UU"
+apply (unfold Issnd_def)
+apply (rule some_equality)
+apply (rule conjI)
+apply fast
+apply (intro strip)
+apply (rule_tac P = "Ispair UU UU = Ispair a b" in notE)
+apply (rule not_sym)
+apply (rule defined_Ispair)
+apply (fast+)
+done
+
+lemma strict_Issnd1 [simp]: "Issnd(Ispair UU y) = UU"
+apply (subst strict_Ispair1)
+apply (rule strict_Issnd)
+apply (rule refl)
+done
+
+lemma strict_Issnd2 [simp]: "Issnd(Ispair x UU) = UU"
+apply (subst strict_Ispair2)
+apply (rule strict_Issnd)
+apply (rule refl)
+done
+
+lemma Isfst: "[|x~=UU ;y~=UU |] ==> Isfst(Ispair x y) = x"
+apply (unfold Isfst_def)
+apply (rule some_equality)
+apply (rule conjI)
+apply (intro strip)
+apply (rule_tac P = "Ispair x y = Ispair UU UU" in notE)
+apply (erule defined_Ispair)
+apply assumption
+apply assumption
+apply (intro strip)
+apply (rule inject_Ispair [THEN conjunct1])
+prefer 3 apply fast
+apply (fast+)
+done
+
+lemma Issnd: "[|x~=UU ;y~=UU |] ==> Issnd(Ispair x y) = y"
+apply (unfold Issnd_def)
+apply (rule some_equality)
+apply (rule conjI)
+apply (intro strip)
+apply (rule_tac P = "Ispair x y = Ispair UU UU" in notE)
+apply (erule defined_Ispair)
+apply assumption
+apply assumption
+apply (intro strip)
+apply (rule inject_Ispair [THEN conjunct2])
+prefer 3 apply fast
+apply (fast+)
+done
+
+lemma Isfst2: "y~=UU ==>Isfst(Ispair x y)=x"
+apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
+apply (erule Isfst)
+apply assumption
+apply (erule ssubst)
+apply (rule strict_Isfst1)
+done
+
+lemma Issnd2: "~x=UU ==>Issnd(Ispair x y)=y"
+apply (rule_tac Q = "y=UU" in excluded_middle [THEN disjE])
+apply (erule Issnd)
+apply assumption
+apply (erule ssubst)
+apply (rule strict_Issnd2)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* instantiate the simplifier                                               *)
+(* ------------------------------------------------------------------------ *)
+
+lemmas Sprod0_ss = strict_Isfst1 strict_Isfst2 strict_Issnd1 strict_Issnd2
+                 Isfst2 Issnd2
+
+declare Isfst2 [simp] Issnd2 [simp]
+
+lemma defined_IsfstIssnd: "p~=Ispair UU UU ==> Isfst p ~= UU & Issnd p ~= UU"
+apply (rule_tac p = "p" in IsprodE)
+apply simp
+apply (erule ssubst)
+apply (rule conjI)
+apply (simp add: Sprod0_ss)
+apply (simp add: Sprod0_ss)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* Surjective pairing: equivalent to Exh_Sprod                              *)
+(* ------------------------------------------------------------------------ *)
+
+lemma surjective_pairing_Sprod: "z = Ispair(Isfst z)(Issnd z)"
+apply (rule_tac z1 = "z" in Exh_Sprod [THEN disjE])
+apply (simp add: Sprod0_ss)
+apply (erule exE)
+apply (erule exE)
+apply (simp add: Sprod0_ss)
+done
+
+lemma Sel_injective_Sprod: "[|Isfst x = Isfst y; Issnd x = Issnd y|] ==> x = y"
+apply (subgoal_tac "Ispair (Isfst x) (Issnd x) =Ispair (Isfst y) (Issnd y) ")
+apply (simp (no_asm_use) add: surjective_pairing_Sprod[symmetric])
+apply simp
+done
+
+subsection {* The strict product is a partial order *}
+
+instance "**"::(sq_ord,sq_ord)sq_ord ..
+
+defs (overloaded)
+  less_sprod_def: "p1 << p2 == Isfst p1 << Isfst p2 & Issnd p1 << Issnd p2"
+
+(* ------------------------------------------------------------------------ *)
+(* less_sprod is a partial order on Sprod                                   *)
+(* ------------------------------------------------------------------------ *)
+
+lemma refl_less_sprod: "(p::'a ** 'b) << p"
+apply (unfold less_sprod_def)
+apply (fast intro: refl_less)
+done
+
+lemma antisym_less_sprod: 
+        "[|(p1::'a ** 'b) << p2;p2 << p1|] ==> p1=p2"
+apply (unfold less_sprod_def)
+apply (rule Sel_injective_Sprod)
+apply (fast intro: antisym_less)
+apply (fast intro: antisym_less)
+done
+
+lemma trans_less_sprod: 
+        "[|(p1::'a**'b) << p2;p2 << p3|] ==> p1 << p3"
+apply (unfold less_sprod_def)
+apply (blast intro: trans_less)
+done
+
+instance "**"::(pcpo,pcpo)po
+by intro_classes
+  (assumption | rule refl_less_sprod antisym_less_sprod trans_less_sprod)+
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_sprod_po: "(op <<)=(%x y. Isfst x<<Isfst y&Issnd x<<Issnd y)"
+apply (fold less_sprod_def)
+apply (rule refl)
+done
+
+subsection {* The strict product is pointed *}
+(* ------------------------------------------------------------------------ *)
+(* type sprod is pointed                                                    *)
+(* ------------------------------------------------------------------------ *)
+(*
+lemma minimal_sprod: "Ispair UU UU << p"
+apply (simp add: inst_sprod_po minimal)
+done
+
+lemmas UU_sprod_def = minimal_sprod [THEN minimal2UU, symmetric, standard]
+
+lemma least_sprod: "? x::'a**'b.!y. x<<y"
+apply (rule_tac x = "Ispair UU UU" in exI)
+apply (rule minimal_sprod [THEN allI])
+done
+*)
+(* ------------------------------------------------------------------------ *)
+(* Ispair is monotone in both arguments                                     *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_Ispair1: "monofun(Ispair)"
+apply (unfold monofun)
+apply (intro strip)
+apply (rule less_fun [THEN iffD2])
+apply (intro strip)
+apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
+apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
+apply (frule notUU_I)
+apply assumption
+apply (simp_all add: Sprod0_ss inst_sprod_po refl_less minimal)
+done
+
+lemma monofun_Ispair2: "monofun(Ispair(x))"
+apply (unfold monofun)
+apply (intro strip)
+apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
+apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
+apply (frule notUU_I)
+apply assumption
+apply (simp_all add: Sprod0_ss inst_sprod_po refl_less minimal)
+done
+
+lemma monofun_Ispair: "[|x1<<x2; y1<<y2|] ==> Ispair x1 y1 << Ispair x2 y2"
+apply (rule trans_less)
+apply (rule monofun_Ispair1 [THEN monofunE, THEN spec, THEN spec, THEN mp, THEN less_fun [THEN iffD1, THEN spec]])
+prefer 2 apply (rule monofun_Ispair2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
+apply assumption
+apply assumption
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Isfst and Issnd are monotone                                             *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_Isfst: "monofun(Isfst)"
+apply (unfold monofun)
+apply (simp add: inst_sprod_po)
+done
+
+lemma monofun_Issnd: "monofun(Issnd)"
+apply (unfold monofun)
+apply (simp add: inst_sprod_po)
+done
+
+subsection {* The strict product is a cpo *}
+(* ------------------------------------------------------------------------ *)
+(* the type 'a ** 'b is a cpo                                               *)
+(* ------------------------------------------------------------------------ *)
+
+lemma lub_sprod: 
+"[|chain(S)|] ==> range(S) <<|  
+  Ispair (lub(range(%i. Isfst(S i)))) (lub(range(%i. Issnd(S i))))"
+apply (rule is_lubI)
+apply (rule ub_rangeI)
+apply (rule_tac t = "S (i) " in surjective_pairing_Sprod [THEN ssubst])
+apply (rule monofun_Ispair)
+apply (rule is_ub_thelub)
+apply (erule monofun_Isfst [THEN ch2ch_monofun])
+apply (rule is_ub_thelub)
+apply (erule monofun_Issnd [THEN ch2ch_monofun])
+apply (rule_tac t = "u" in surjective_pairing_Sprod [THEN ssubst])
+apply (rule monofun_Ispair)
+apply (rule is_lub_thelub)
+apply (erule monofun_Isfst [THEN ch2ch_monofun])
+apply (erule monofun_Isfst [THEN ub2ub_monofun])
+apply (rule is_lub_thelub)
+apply (erule monofun_Issnd [THEN ch2ch_monofun])
+apply (erule monofun_Issnd [THEN ub2ub_monofun])
+done
+
+lemmas thelub_sprod = lub_sprod [THEN thelubI, standard]
+
+lemma cpo_sprod: "chain(S::nat=>'a**'b)==>? x. range(S)<<| x"
+apply (rule exI)
+apply (erule lub_sprod)
+done
+
+instance "**" :: (pcpo, pcpo) cpo
+by intro_classes (rule cpo_sprod)
+
+
+subsection {* The strict product is a pcpo *}
+
+lemma minimal_sprod: "Ispair UU UU << p"
+apply (simp add: inst_sprod_po minimal)
+done
+
+lemmas UU_sprod_def = minimal_sprod [THEN minimal2UU, symmetric, standard]
+
+lemma least_sprod: "? x::'a**'b.!y. x<<y"
+apply (rule_tac x = "Ispair UU UU" in exI)
+apply (rule minimal_sprod [THEN allI])
+done
+
+instance "**" :: (pcpo, pcpo) pcpo
+by intro_classes (rule least_sprod)
+
+
+subsection {* Other constants *}
+
+consts  
+  spair		:: "'a -> 'b -> ('a**'b)" (* continuous strict pairing *)
+  sfst		:: "('a**'b)->'a"
+  ssnd		:: "('a**'b)->'b"
+  ssplit	:: "('a->'b->'c)->('a**'b)->'c"
+
+syntax  
+  "@stuple"	:: "['a, args] => 'a ** 'b"	("(1'(:_,/ _:'))")
+
+translations
+        "(:x, y, z:)"   == "(:x, (:y, z:):)"
+        "(:x, y:)"      == "spair$x$y"
+
+defs
+spair_def:       "spair  == (LAM x y. Ispair x y)"
+sfst_def:        "sfst   == (LAM p. Isfst p)"
+ssnd_def:        "ssnd   == (LAM p. Issnd p)"     
+ssplit_def:      "ssplit == (LAM f. strictify$(LAM p. f$(sfst$p)$(ssnd$p)))"
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_sprod_pcpo: "UU = Ispair UU UU"
+apply (simp add: UU_def UU_sprod_def)
+done
+
+declare inst_sprod_pcpo [symmetric, simp]
+
+(* ------------------------------------------------------------------------ *)
+(* continuity of Ispair, Isfst, Issnd                                       *)
+(* ------------------------------------------------------------------------ *)
+
+lemma sprod3_lemma1: 
+"[| chain(Y);  x~= UU;  lub(range(Y))~= UU |] ==> 
+  Ispair (lub(range Y)) x = 
+  Ispair (lub(range(%i. Isfst(Ispair(Y i) x))))  
+         (lub(range(%i. Issnd(Ispair(Y i) x))))"
+apply (rule_tac f1 = "Ispair" in arg_cong [THEN cong])
+apply (rule lub_equal)
+apply assumption
+apply (rule monofun_Isfst [THEN ch2ch_monofun])
+apply (rule ch2ch_fun)
+apply (rule monofun_Ispair1 [THEN ch2ch_monofun])
+apply assumption
+apply (rule allI)
+apply (simp (no_asm_simp))
+apply (rule sym)
+apply (drule chain_UU_I_inverse2)
+apply (erule exE)
+apply (rule lub_chain_maxelem)
+apply (erule Issnd2)
+apply (rule allI)
+apply (rename_tac "j")
+apply (case_tac "Y (j) =UU")
+apply auto
+done
+
+lemma sprod3_lemma2: 
+"[| chain(Y); x ~= UU; lub(range(Y)) = UU |] ==> 
+    Ispair (lub(range Y)) x = 
+    Ispair (lub(range(%i. Isfst(Ispair(Y i) x)))) 
+           (lub(range(%i. Issnd(Ispair(Y i) x))))"
+apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
+apply assumption
+apply (rule trans)
+apply (rule strict_Ispair1)
+apply (rule strict_Ispair [symmetric])
+apply (rule disjI1)
+apply (rule chain_UU_I_inverse)
+apply auto
+apply (erule chain_UU_I [THEN spec])
+apply assumption
+done
+
+
+lemma sprod3_lemma3: 
+"[| chain(Y); x = UU |] ==> 
+           Ispair (lub(range Y)) x = 
+           Ispair (lub(range(%i. Isfst(Ispair (Y i) x)))) 
+                  (lub(range(%i. Issnd(Ispair (Y i) x))))"
+apply (erule ssubst)
+apply (rule trans)
+apply (rule strict_Ispair2)
+apply (rule strict_Ispair [symmetric])
+apply (rule disjI1)
+apply (rule chain_UU_I_inverse)
+apply (rule allI)
+apply (simp add: Sprod0_ss)
+done
+
+lemma contlub_Ispair1: "contlub(Ispair)"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule expand_fun_eq [THEN iffD2])
+apply (intro strip)
+apply (subst lub_fun [THEN thelubI])
+apply (erule monofun_Ispair1 [THEN ch2ch_monofun])
+apply (rule trans)
+apply (rule_tac [2] thelub_sprod [symmetric])
+apply (rule_tac [2] ch2ch_fun)
+apply (erule_tac [2] monofun_Ispair1 [THEN ch2ch_monofun])
+apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
+apply (rule_tac Q = "lub (range (Y))=UU" in excluded_middle [THEN disjE])
+apply (erule sprod3_lemma1)
+apply assumption
+apply assumption
+apply (erule sprod3_lemma2)
+apply assumption
+apply assumption
+apply (erule sprod3_lemma3)
+apply assumption
+done
+
+lemma sprod3_lemma4: 
+"[| chain(Y); x ~= UU; lub(range(Y)) ~= UU |] ==> 
+          Ispair x (lub(range Y)) = 
+          Ispair (lub(range(%i. Isfst (Ispair x (Y i))))) 
+                 (lub(range(%i. Issnd (Ispair x (Y i)))))"
+apply (rule_tac f1 = "Ispair" in arg_cong [THEN cong])
+apply (rule sym)
+apply (drule chain_UU_I_inverse2)
+apply (erule exE)
+apply (rule lub_chain_maxelem)
+apply (erule Isfst2)
+apply (rule allI)
+apply (rename_tac "j")
+apply (case_tac "Y (j) =UU")
+apply auto
+done
+
+lemma sprod3_lemma5: 
+"[| chain(Y); x ~= UU; lub(range(Y)) = UU |] ==> 
+          Ispair x (lub(range Y)) = 
+          Ispair (lub(range(%i. Isfst(Ispair x (Y i))))) 
+                 (lub(range(%i. Issnd(Ispair x (Y i)))))"
+apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
+apply assumption
+apply (rule trans)
+apply (rule strict_Ispair2)
+apply (rule strict_Ispair [symmetric])
+apply (rule disjI2)
+apply (rule chain_UU_I_inverse)
+apply (rule allI)
+apply (simp add: Sprod0_ss)
+apply (erule chain_UU_I [THEN spec])
+apply assumption
+done
+
+lemma sprod3_lemma6: 
+"[| chain(Y); x = UU |] ==> 
+          Ispair x (lub(range Y)) = 
+          Ispair (lub(range(%i. Isfst (Ispair x (Y i))))) 
+                 (lub(range(%i. Issnd (Ispair x (Y i)))))"
+apply (rule_tac s = "UU" and t = "x" in ssubst)
+apply assumption
+apply (rule trans)
+apply (rule strict_Ispair1)
+apply (rule strict_Ispair [symmetric])
+apply (rule disjI1)
+apply (rule chain_UU_I_inverse)
+apply (rule allI)
+apply (simp add: Sprod0_ss)
+done
+
+lemma contlub_Ispair2: "contlub(Ispair(x))"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule trans)
+apply (rule_tac [2] thelub_sprod [symmetric])
+apply (erule_tac [2] monofun_Ispair2 [THEN ch2ch_monofun])
+apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
+apply (rule_tac Q = "lub (range (Y))=UU" in excluded_middle [THEN disjE])
+apply (erule sprod3_lemma4)
+apply assumption
+apply assumption
+apply (erule sprod3_lemma5)
+apply assumption
+apply assumption
+apply (erule sprod3_lemma6)
+apply assumption
+done
+
+lemma cont_Ispair1: "cont(Ispair)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Ispair1)
+apply (rule contlub_Ispair1)
+done
+
+lemma cont_Ispair2: "cont(Ispair(x))"
+apply (rule monocontlub2cont)
+apply (rule monofun_Ispair2)
+apply (rule contlub_Ispair2)
+done
+
+lemma contlub_Isfst: "contlub(Isfst)"
+apply (rule contlubI)
+apply (intro strip)
+apply (subst lub_sprod [THEN thelubI])
+apply assumption
+apply (rule_tac Q = "lub (range (%i. Issnd (Y (i))))=UU" in excluded_middle [THEN disjE])
+apply (simp add: Sprod0_ss)
+apply (rule_tac s = "UU" and t = "lub (range (%i. Issnd (Y (i))))" in ssubst)
+apply assumption
+apply (rule trans)
+apply (simp add: Sprod0_ss)
+apply (rule sym)
+apply (rule chain_UU_I_inverse)
+apply (rule allI)
+apply (rule strict_Isfst)
+apply (rule contrapos_np)
+apply (erule_tac [2] defined_IsfstIssnd [THEN conjunct2])
+apply (fast dest!: monofun_Issnd [THEN ch2ch_monofun, THEN chain_UU_I, THEN spec])
+done
+
+lemma contlub_Issnd: "contlub(Issnd)"
+apply (rule contlubI)
+apply (intro strip)
+apply (subst lub_sprod [THEN thelubI])
+apply assumption
+apply (rule_tac Q = "lub (range (%i. Isfst (Y (i))))=UU" in excluded_middle [THEN disjE])
+apply (simp add: Sprod0_ss)
+apply (rule_tac s = "UU" and t = "lub (range (%i. Isfst (Y (i))))" in ssubst)
+apply assumption
+apply (simp add: Sprod0_ss)
+apply (rule sym)
+apply (rule chain_UU_I_inverse)
+apply (rule allI)
+apply (rule strict_Issnd)
+apply (rule contrapos_np)
+apply (erule_tac [2] defined_IsfstIssnd [THEN conjunct1])
+apply (fast dest!: monofun_Isfst [THEN ch2ch_monofun, THEN chain_UU_I, THEN spec])
+done
+
+lemma cont_Isfst: "cont(Isfst)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Isfst)
+apply (rule contlub_Isfst)
+done
+
+lemma cont_Issnd: "cont(Issnd)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Issnd)
+apply (rule contlub_Issnd)
+done
+
+lemma spair_eq: "[|x1=x2;y1=y2|] ==> (:x1,y1:) = (:x2,y2:)"
+apply fast
+done
+
+(* ------------------------------------------------------------------------ *)
+(* convert all lemmas to the continuous versions                            *)
+(* ------------------------------------------------------------------------ *)
+
+lemma beta_cfun_sprod [simp]: 
+        "(LAM x y. Ispair x y)$a$b = Ispair a b"
+apply (subst beta_cfun)
+apply (simp (no_asm) add: cont_Ispair2 cont_Ispair1 cont2cont_CF1L)
+apply (subst beta_cfun)
+apply (rule cont_Ispair2)
+apply (rule refl)
+done
+
+lemma inject_spair: 
+        "[| aa~=UU ; ba~=UU ; (:a,b:)=(:aa,ba:) |] ==> a=aa & b=ba"
+apply (unfold spair_def)
+apply (erule inject_Ispair)
+apply assumption
+apply (erule box_equals)
+apply (rule beta_cfun_sprod)
+apply (rule beta_cfun_sprod)
+done
+
+lemma inst_sprod_pcpo2: "UU = (:UU,UU:)"
+apply (unfold spair_def)
+apply (rule sym)
+apply (rule trans)
+apply (rule beta_cfun_sprod)
+apply (rule sym)
+apply (rule inst_sprod_pcpo)
+done
+
+lemma strict_spair: 
+        "(a=UU | b=UU) ==> (:a,b:)=UU"
+apply (unfold spair_def)
+apply (rule trans)
+apply (rule beta_cfun_sprod)
+apply (rule trans)
+apply (rule_tac [2] inst_sprod_pcpo [symmetric])
+apply (erule strict_Ispair)
+done
+
+lemma strict_spair1: "(:UU,b:) = UU"
+apply (unfold spair_def)
+apply (subst beta_cfun_sprod)
+apply (rule trans)
+apply (rule_tac [2] inst_sprod_pcpo [symmetric])
+apply (rule strict_Ispair1)
+done
+
+lemma strict_spair2: "(:a,UU:) = UU"
+apply (unfold spair_def)
+apply (subst beta_cfun_sprod)
+apply (rule trans)
+apply (rule_tac [2] inst_sprod_pcpo [symmetric])
+apply (rule strict_Ispair2)
+done
+
+declare strict_spair1 [simp] strict_spair2 [simp]
+
+lemma strict_spair_rev: "(:x,y:)~=UU ==> ~x=UU & ~y=UU"
+apply (unfold spair_def)
+apply (rule strict_Ispair_rev)
+apply auto
+done
+
+lemma defined_spair_rev: "(:a,b:) = UU ==> (a = UU | b = UU)"
+apply (unfold spair_def)
+apply (rule defined_Ispair_rev)
+apply auto
+done
+
+lemma defined_spair: 
+        "[|a~=UU; b~=UU|] ==> (:a,b:) ~= UU"
+apply (unfold spair_def)
+apply (subst beta_cfun_sprod)
+apply (subst inst_sprod_pcpo)
+apply (erule defined_Ispair)
+apply assumption
+done
+
+lemma Exh_Sprod2:
+        "z=UU | (? a b. z=(:a,b:) & a~=UU & b~=UU)"
+apply (unfold spair_def)
+apply (rule Exh_Sprod [THEN disjE])
+apply (rule disjI1)
+apply (subst inst_sprod_pcpo)
+apply assumption
+apply (rule disjI2)
+apply (erule exE)
+apply (erule exE)
+apply (rule exI)
+apply (rule exI)
+apply (rule conjI)
+apply (subst beta_cfun_sprod)
+apply fast
+apply fast
+done
+
+
+lemma sprodE:
+assumes prem1: "p=UU ==> Q"
+assumes prem2: "!!x y. [| p=(:x,y:); x~=UU; y~=UU|] ==> Q"
+shows "Q"
+apply (rule IsprodE)
+apply (rule prem1)
+apply (subst inst_sprod_pcpo)
+apply assumption
+apply (rule prem2)
+prefer 2 apply (assumption)
+prefer 2 apply (assumption)
+apply (unfold spair_def)
+apply (subst beta_cfun_sprod)
+apply assumption
+done
+
+
+lemma strict_sfst: 
+        "p=UU==>sfst$p=UU"
+apply (unfold sfst_def)
+apply (subst beta_cfun)
+apply (rule cont_Isfst)
+apply (rule strict_Isfst)
+apply (rule inst_sprod_pcpo [THEN subst])
+apply assumption
+done
+
+lemma strict_sfst1: 
+        "sfst$(:UU,y:) = UU"
+apply (unfold sfst_def spair_def)
+apply (subst beta_cfun_sprod)
+apply (subst beta_cfun)
+apply (rule cont_Isfst)
+apply (rule strict_Isfst1)
+done
+ 
+lemma strict_sfst2: 
+        "sfst$(:x,UU:) = UU"
+apply (unfold sfst_def spair_def)
+apply (subst beta_cfun_sprod)
+apply (subst beta_cfun)
+apply (rule cont_Isfst)
+apply (rule strict_Isfst2)
+done
+
+lemma strict_ssnd: 
+        "p=UU==>ssnd$p=UU"
+apply (unfold ssnd_def)
+apply (subst beta_cfun)
+apply (rule cont_Issnd)
+apply (rule strict_Issnd)
+apply (rule inst_sprod_pcpo [THEN subst])
+apply assumption
+done
+
+lemma strict_ssnd1: 
+        "ssnd$(:UU,y:) = UU"
+apply (unfold ssnd_def spair_def)
+apply (subst beta_cfun_sprod)
+apply (subst beta_cfun)
+apply (rule cont_Issnd)
+apply (rule strict_Issnd1)
+done
+
+lemma strict_ssnd2: 
+        "ssnd$(:x,UU:) = UU"
+apply (unfold ssnd_def spair_def)
+apply (subst beta_cfun_sprod)
+apply (subst beta_cfun)
+apply (rule cont_Issnd)
+apply (rule strict_Issnd2)
+done
+
+lemma sfst2: 
+        "y~=UU ==>sfst$(:x,y:)=x"
+apply (unfold sfst_def spair_def)
+apply (subst beta_cfun_sprod)
+apply (subst beta_cfun)
+apply (rule cont_Isfst)
+apply (erule Isfst2)
+done
+
+lemma ssnd2: 
+        "x~=UU ==>ssnd$(:x,y:)=y"
+apply (unfold ssnd_def spair_def)
+apply (subst beta_cfun_sprod)
+apply (subst beta_cfun)
+apply (rule cont_Issnd)
+apply (erule Issnd2)
+done
+
+
+lemma defined_sfstssnd: 
+        "p~=UU ==> sfst$p ~=UU & ssnd$p ~=UU"
+apply (unfold sfst_def ssnd_def spair_def)
+apply (simplesubst beta_cfun)
+apply (rule cont_Issnd)
+apply (subst beta_cfun)
+apply (rule cont_Isfst)
+apply (rule defined_IsfstIssnd)
+apply (rule inst_sprod_pcpo [THEN subst])
+apply assumption
+done
+ 
+lemma surjective_pairing_Sprod2: "(:sfst$p , ssnd$p:) = p"
+apply (unfold sfst_def ssnd_def spair_def)
+apply (subst beta_cfun_sprod)
+apply (simplesubst beta_cfun)
+apply (rule cont_Issnd)
+apply (subst beta_cfun)
+apply (rule cont_Isfst)
+apply (rule surjective_pairing_Sprod [symmetric])
+done
+
+lemma lub_sprod2: 
+"chain(S) ==> range(S) <<|  
+               (: lub(range(%i. sfst$(S i))), lub(range(%i. ssnd$(S i))) :)"
+apply (unfold sfst_def ssnd_def spair_def)
+apply (subst beta_cfun_sprod)
+apply (simplesubst beta_cfun [THEN ext])
+apply (rule cont_Issnd)
+apply (subst beta_cfun [THEN ext])
+apply (rule cont_Isfst)
+apply (erule lub_sprod)
+done
+
+
+lemmas thelub_sprod2 = lub_sprod2 [THEN thelubI, standard]
+(*
+ "chain ?S1 ==>
+ lub (range ?S1) =
+ (:lub (range (%i. sfst$(?S1 i))), lub (range (%i. ssnd$(?S1 i))):)" : thm
+*)
+
+lemma ssplit1: 
+        "ssplit$f$UU=UU"
+apply (unfold ssplit_def)
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (subst strictify1)
+apply (rule refl)
+done
+
+lemma ssplit2: 
+        "[|x~=UU;y~=UU|] ==> ssplit$f$(:x,y:)= f$x$y"
+apply (unfold ssplit_def)
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (subst strictify2)
+apply (rule defined_spair)
+apply assumption
+apply assumption
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (subst sfst2)
+apply assumption
+apply (subst ssnd2)
+apply assumption
+apply (rule refl)
+done
+
+
+lemma ssplit3: 
+  "ssplit$spair$z=z"
+apply (unfold ssplit_def)
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (case_tac "z=UU")
+apply (erule ssubst)
+apply (rule strictify1)
+apply (rule trans)
+apply (rule strictify2)
+apply assumption
+apply (subst beta_cfun)
+apply (simp (no_asm))
+apply (rule surjective_pairing_Sprod2)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* install simplifier for Sprod                                             *)
+(* ------------------------------------------------------------------------ *)
+
+lemmas Sprod_rews = strict_sfst1 strict_sfst2
+                strict_ssnd1 strict_ssnd2 sfst2 ssnd2 defined_spair
+                ssplit1 ssplit2
+declare Sprod_rews [simp]
+
+end
--- a/src/HOLCF/Sprod0.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,35 +0,0 @@
-
-(* legacy ML bindings *)
-
-val Ispair_def = thm "Ispair_def";
-val Isfst_def = thm "Isfst_def";
-val Issnd_def = thm "Issnd_def";
-val SprodI = thm "SprodI";
-val inj_on_Abs_Sprod = thm "inj_on_Abs_Sprod";
-val strict_Spair_Rep = thm "strict_Spair_Rep";
-val defined_Spair_Rep_rev = thm "defined_Spair_Rep_rev";
-val inject_Spair_Rep = thm "inject_Spair_Rep";
-val inject_Ispair = thm "inject_Ispair";
-val strict_Ispair = thm "strict_Ispair";
-val strict_Ispair1 = thm "strict_Ispair1";
-val strict_Ispair2 = thm "strict_Ispair2";
-val strict_Ispair_rev = thm "strict_Ispair_rev";
-val defined_Ispair_rev = thm "defined_Ispair_rev";
-val defined_Ispair = thm "defined_Ispair";
-val Exh_Sprod = thm "Exh_Sprod";
-val IsprodE = thm "IsprodE";
-val strict_Isfst = thm "strict_Isfst";
-val strict_Isfst1 = thm "strict_Isfst1";
-val strict_Isfst2 = thm "strict_Isfst2";
-val strict_Issnd = thm "strict_Issnd";
-val strict_Issnd1 = thm "strict_Issnd1";
-val strict_Issnd2 = thm "strict_Issnd2";
-val Isfst = thm "Isfst";
-val Issnd = thm "Issnd";
-val Isfst2 = thm "Isfst2";
-val Issnd2 = thm "Issnd2";
-val Sprod0_ss = [strict_Isfst1, strict_Isfst2, strict_Issnd1, strict_Issnd2,
-                 Isfst2, Issnd2]
-val defined_IsfstIssnd = thm "defined_IsfstIssnd";
-val surjective_pairing_Sprod = thm "surjective_pairing_Sprod";
-val Sel_injective_Sprod = thm "Sel_injective_Sprod";
--- a/src/HOLCF/Sprod0.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,353 +0,0 @@
-(*  Title:      HOLCF/Sprod0.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Strict product with typedef.
-*)
-
-theory Sprod0 = Cfun3:
-
-constdefs
-  Spair_Rep     :: "['a,'b] => ['a,'b] => bool"
- "Spair_Rep == (%a b. %x y.(~a=UU & ~b=UU --> x=a  & y=b ))"
-
-typedef (Sprod)  ('a, 'b) "**" (infixr 20) = "{f. ? a b. f = Spair_Rep (a::'a) (b::'b)}"
-by auto
-
-syntax (xsymbols)
-  "**"		:: "[type, type] => type"	 ("(_ \<otimes>/ _)" [21,20] 20)
-syntax (HTML output)
-  "**"		:: "[type, type] => type"	 ("(_ \<otimes>/ _)" [21,20] 20)
-
-consts
-  Ispair        :: "['a,'b] => ('a ** 'b)"
-  Isfst         :: "('a ** 'b) => 'a"
-  Issnd         :: "('a ** 'b) => 'b"  
-
-defs
-   (*defining the abstract constants*)
-
-  Ispair_def:    "Ispair a b == Abs_Sprod(Spair_Rep a b)"
-
-  Isfst_def:     "Isfst(p) == @z.        (p=Ispair UU UU --> z=UU)
-                &(! a b. ~a=UU & ~b=UU & p=Ispair a b   --> z=a)"  
-
-  Issnd_def:     "Issnd(p) == @z.        (p=Ispair UU UU  --> z=UU)
-                &(! a b. ~a=UU & ~b=UU & p=Ispair a b    --> z=b)"  
-
-(*  Title:      HOLCF/Sprod0
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Strict product with typedef.
-*)
-
-(* ------------------------------------------------------------------------ *)
-(* A non-emptyness result for Sprod                                         *)
-(* ------------------------------------------------------------------------ *)
-
-lemma SprodI: "(Spair_Rep a b):Sprod"
-apply (unfold Sprod_def)
-apply (rule CollectI, rule exI, rule exI, rule refl)
-done
-
-lemma inj_on_Abs_Sprod: "inj_on Abs_Sprod Sprod"
-apply (rule inj_on_inverseI)
-apply (erule Abs_Sprod_inverse)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Strictness and definedness of Spair_Rep                                  *)
-(* ------------------------------------------------------------------------ *)
-
-lemma strict_Spair_Rep: 
- "(a=UU | b=UU) ==> (Spair_Rep a b) = (Spair_Rep UU UU)"
-apply (unfold Spair_Rep_def)
-apply (rule ext)
-apply (rule ext)
-apply (rule iffI)
-apply fast
-apply fast
-done
-
-lemma defined_Spair_Rep_rev: 
- "(Spair_Rep a b) = (Spair_Rep UU UU) ==> (a=UU | b=UU)"
-apply (unfold Spair_Rep_def)
-apply (case_tac "a=UU|b=UU")
-apply assumption
-apply (fast dest: fun_cong)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* injectivity of Spair_Rep and Ispair                                      *)
-(* ------------------------------------------------------------------------ *)
-
-lemma inject_Spair_Rep: 
-"[|~aa=UU ; ~ba=UU ; Spair_Rep a b = Spair_Rep aa ba |] ==> a=aa & b=ba"
-
-apply (unfold Spair_Rep_def)
-apply (drule fun_cong)
-apply (drule fun_cong)
-apply (erule iffD1 [THEN mp])
-apply auto
-done
-
-
-lemma inject_Ispair: 
-        "[|~aa=UU ; ~ba=UU ; Ispair a b = Ispair aa ba |] ==> a=aa & b=ba"
-apply (unfold Ispair_def)
-apply (erule inject_Spair_Rep)
-apply assumption
-apply (erule inj_on_Abs_Sprod [THEN inj_onD])
-apply (rule SprodI)
-apply (rule SprodI)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* strictness and definedness of Ispair                                     *)
-(* ------------------------------------------------------------------------ *)
-
-lemma strict_Ispair: 
- "(a=UU | b=UU) ==> Ispair a b = Ispair UU UU"
-apply (unfold Ispair_def)
-apply (erule strict_Spair_Rep [THEN arg_cong])
-done
-
-lemma strict_Ispair1: 
-        "Ispair UU b  = Ispair UU UU"
-apply (unfold Ispair_def)
-apply (rule strict_Spair_Rep [THEN arg_cong])
-apply (rule disjI1)
-apply (rule refl)
-done
-
-lemma strict_Ispair2: 
-        "Ispair a UU = Ispair UU UU"
-apply (unfold Ispair_def)
-apply (rule strict_Spair_Rep [THEN arg_cong])
-apply (rule disjI2)
-apply (rule refl)
-done
-
-lemma strict_Ispair_rev: "~Ispair x y = Ispair UU UU ==> ~x=UU & ~y=UU"
-apply (rule de_Morgan_disj [THEN subst])
-apply (erule contrapos_nn)
-apply (erule strict_Ispair)
-done
-
-lemma defined_Ispair_rev: 
-        "Ispair a b  = Ispair UU UU ==> (a = UU | b = UU)"
-apply (unfold Ispair_def)
-apply (rule defined_Spair_Rep_rev)
-apply (rule inj_on_Abs_Sprod [THEN inj_onD])
-apply assumption
-apply (rule SprodI)
-apply (rule SprodI)
-done
-
-lemma defined_Ispair: "[|a~=UU; b~=UU|] ==> (Ispair a b) ~= (Ispair UU UU)"
-apply (rule contrapos_nn)
-apply (erule_tac [2] defined_Ispair_rev)
-apply (rule de_Morgan_disj [THEN iffD2])
-apply (erule conjI)
-apply assumption
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* Exhaustion of the strict product **                                      *)
-(* ------------------------------------------------------------------------ *)
-
-lemma Exh_Sprod:
-        "z=Ispair UU UU | (? a b. z=Ispair a b & a~=UU & b~=UU)"
-apply (unfold Ispair_def)
-apply (rule Rep_Sprod[unfolded Sprod_def, THEN CollectE])
-apply (erule exE)
-apply (erule exE)
-apply (rule excluded_middle [THEN disjE])
-apply (rule disjI2)
-apply (rule exI)
-apply (rule exI)
-apply (rule conjI)
-apply (rule Rep_Sprod_inverse [symmetric, THEN trans])
-apply (erule arg_cong)
-apply (rule de_Morgan_disj [THEN subst])
-apply assumption
-apply (rule disjI1)
-apply (rule Rep_Sprod_inverse [symmetric, THEN trans])
-apply (rule_tac f = "Abs_Sprod" in arg_cong)
-apply (erule trans)
-apply (erule strict_Spair_Rep)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* general elimination rule for strict product                              *)
-(* ------------------------------------------------------------------------ *)
-
-lemma IsprodE:
-assumes prem1: "p=Ispair UU UU ==> Q"
-assumes prem2: "!!x y. [|p=Ispair x y; x~=UU ; y~=UU|] ==> Q"
-shows "Q"
-apply (rule Exh_Sprod [THEN disjE])
-apply (erule prem1)
-apply (erule exE)
-apply (erule exE)
-apply (erule conjE)
-apply (erule conjE)
-apply (erule prem2)
-apply assumption
-apply assumption
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* some results about the selectors Isfst, Issnd                            *)
-(* ------------------------------------------------------------------------ *)
-
-lemma strict_Isfst: "p=Ispair UU UU ==> Isfst p = UU"
-apply (unfold Isfst_def)
-apply (rule some_equality)
-apply (rule conjI)
-apply fast
-apply (intro strip)
-apply (rule_tac P = "Ispair UU UU = Ispair a b" in notE)
-apply (rule not_sym)
-apply (rule defined_Ispair)
-apply (fast+)
-done
-
-
-lemma strict_Isfst1: "Isfst(Ispair UU y) = UU"
-apply (subst strict_Ispair1)
-apply (rule strict_Isfst)
-apply (rule refl)
-done
-
-declare strict_Isfst1 [simp]
-
-lemma strict_Isfst2: "Isfst(Ispair x UU) = UU"
-apply (subst strict_Ispair2)
-apply (rule strict_Isfst)
-apply (rule refl)
-done
-
-declare strict_Isfst2 [simp]
-
-
-lemma strict_Issnd: "p=Ispair UU UU ==>Issnd p=UU"
-
-apply (unfold Issnd_def)
-apply (rule some_equality)
-apply (rule conjI)
-apply fast
-apply (intro strip)
-apply (rule_tac P = "Ispair UU UU = Ispair a b" in notE)
-apply (rule not_sym)
-apply (rule defined_Ispair)
-apply (fast+)
-done
-
-lemma strict_Issnd1: "Issnd(Ispair UU y) = UU"
-apply (subst strict_Ispair1)
-apply (rule strict_Issnd)
-apply (rule refl)
-done
-
-declare strict_Issnd1 [simp]
-
-lemma strict_Issnd2: "Issnd(Ispair x UU) = UU"
-apply (subst strict_Ispair2)
-apply (rule strict_Issnd)
-apply (rule refl)
-done
-
-declare strict_Issnd2 [simp]
-
-lemma Isfst: "[|x~=UU ;y~=UU |] ==> Isfst(Ispair x y) = x"
-apply (unfold Isfst_def)
-apply (rule some_equality)
-apply (rule conjI)
-apply (intro strip)
-apply (rule_tac P = "Ispair x y = Ispair UU UU" in notE)
-apply (erule defined_Ispair)
-apply assumption
-apply assumption
-apply (intro strip)
-apply (rule inject_Ispair [THEN conjunct1])
-prefer 3 apply fast
-apply (fast+)
-done
-
-lemma Issnd: "[|x~=UU ;y~=UU |] ==> Issnd(Ispair x y) = y"
-apply (unfold Issnd_def)
-apply (rule some_equality)
-apply (rule conjI)
-apply (intro strip)
-apply (rule_tac P = "Ispair x y = Ispair UU UU" in notE)
-apply (erule defined_Ispair)
-apply assumption
-apply assumption
-apply (intro strip)
-apply (rule inject_Ispair [THEN conjunct2])
-prefer 3 apply fast
-apply (fast+)
-done
-
-lemma Isfst2: "y~=UU ==>Isfst(Ispair x y)=x"
-apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
-apply (erule Isfst)
-apply assumption
-apply (erule ssubst)
-apply (rule strict_Isfst1)
-done
-
-lemma Issnd2: "~x=UU ==>Issnd(Ispair x y)=y"
-apply (rule_tac Q = "y=UU" in excluded_middle [THEN disjE])
-apply (erule Issnd)
-apply assumption
-apply (erule ssubst)
-apply (rule strict_Issnd2)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* instantiate the simplifier                                               *)
-(* ------------------------------------------------------------------------ *)
-
-lemmas Sprod0_ss = strict_Isfst1 strict_Isfst2 strict_Issnd1 strict_Issnd2
-                 Isfst2 Issnd2
-
-declare Isfst2 [simp] Issnd2 [simp]
-
-lemma defined_IsfstIssnd: "p~=Ispair UU UU ==> Isfst p ~= UU & Issnd p ~= UU"
-apply (rule_tac p = "p" in IsprodE)
-apply simp
-apply (erule ssubst)
-apply (rule conjI)
-apply (simp add: Sprod0_ss)
-apply (simp add: Sprod0_ss)
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* Surjective pairing: equivalent to Exh_Sprod                              *)
-(* ------------------------------------------------------------------------ *)
-
-lemma surjective_pairing_Sprod: "z = Ispair(Isfst z)(Issnd z)"
-apply (rule_tac z1 = "z" in Exh_Sprod [THEN disjE])
-apply (simp add: Sprod0_ss)
-apply (erule exE)
-apply (erule exE)
-apply (simp add: Sprod0_ss)
-done
-
-lemma Sel_injective_Sprod: "[|Isfst x = Isfst y; Issnd x = Issnd y|] ==> x = y"
-apply (subgoal_tac "Ispair (Isfst x) (Issnd x) =Ispair (Isfst y) (Issnd y) ")
-apply (simp (no_asm_use) add: surjective_pairing_Sprod[symmetric])
-apply simp
-done
-
-end
--- a/src/HOLCF/Sprod1.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,7 +0,0 @@
-
-(* legacy ML bindings *)
-
-val less_sprod_def = thm "less_sprod_def";
-val refl_less_sprod = thm "refl_less_sprod";
-val antisym_less_sprod = thm "antisym_less_sprod";
-val trans_less_sprod = thm "trans_less_sprod";
--- a/src/HOLCF/Sprod1.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,46 +0,0 @@
-(*  Title:      HOLCF/sprod1.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Partial ordering for the strict product.
-*)
-
-theory Sprod1 = Sprod0:
-
-instance "**"::(sq_ord,sq_ord)sq_ord ..
-
-defs (overloaded)
-  less_sprod_def: "p1 << p2 == Isfst p1 << Isfst p2 & Issnd p1 << Issnd p2"
-
-(*  Title:      HOLCF/Sprod1.ML
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-*)
-
-(* ------------------------------------------------------------------------ *)
-(* less_sprod is a partial order on Sprod                                   *)
-(* ------------------------------------------------------------------------ *)
-
-lemma refl_less_sprod: "(p::'a ** 'b) << p"
-
-apply (unfold less_sprod_def)
-apply (fast intro: refl_less)
-done
-
-lemma antisym_less_sprod: 
-        "[|(p1::'a ** 'b) << p2;p2 << p1|] ==> p1=p2"
-apply (unfold less_sprod_def)
-apply (rule Sel_injective_Sprod)
-apply (fast intro: antisym_less)
-apply (fast intro: antisym_less)
-done
-
-lemma trans_less_sprod: 
-        "[|(p1::'a**'b) << p2;p2 << p3|] ==> p1 << p3"
-apply (unfold less_sprod_def)
-apply (blast intro: trans_less)
-done
-
-end
--- a/src/HOLCF/Sprod2.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,15 +0,0 @@
-
-(* legacy ML bindings *)
-
-val inst_sprod_po = thm "inst_sprod_po";
-val minimal_sprod = thm "minimal_sprod";
-val UU_sprod_def = thm "UU_sprod_def";
-val least_sprod = thm "least_sprod";
-val monofun_Ispair1 = thm "monofun_Ispair1";
-val monofun_Ispair2 = thm "monofun_Ispair2";
-val monofun_Ispair = thm "monofun_Ispair";
-val monofun_Isfst = thm "monofun_Isfst";
-val monofun_Issnd = thm "monofun_Issnd";
-val lub_sprod = thm "lub_sprod";
-val thelub_sprod = thm "thelub_sprod";
-val cpo_sprod = thm "cpo_sprod";
--- a/src/HOLCF/Sprod2.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,132 +0,0 @@
-(*  Title:      HOLCF/Sprod2.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class Instance **::(pcpo,pcpo)po
-*)
-
-theory Sprod2 = Sprod1:
-
-instance "**"::(pcpo,pcpo)po 
-apply (intro_classes)
-apply (rule refl_less_sprod)
-apply (rule antisym_less_sprod, assumption+)
-apply (rule trans_less_sprod, assumption+)
-done
-
-(*  Title:      HOLCF/Sprod2.ML
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class Instance **::(pcpo,pcpo)po
-*)
-
-(* for compatibility with old HOLCF-Version *)
-lemma inst_sprod_po: "(op <<)=(%x y. Isfst x<<Isfst y&Issnd x<<Issnd y)"
-apply (fold less_sprod_def)
-apply (rule refl)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* type sprod is pointed                                                    *)
-(* ------------------------------------------------------------------------ *)
-
-lemma minimal_sprod: "Ispair UU UU << p"
-apply (simp add: inst_sprod_po minimal)
-done
-
-lemmas UU_sprod_def = minimal_sprod [THEN minimal2UU, symmetric, standard]
-
-lemma least_sprod: "? x::'a**'b.!y. x<<y"
-apply (rule_tac x = "Ispair UU UU" in exI)
-apply (rule minimal_sprod [THEN allI])
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Ispair is monotone in both arguments                                     *)
-(* ------------------------------------------------------------------------ *)
-
-lemma monofun_Ispair1: "monofun(Ispair)"
-
-apply (unfold monofun)
-apply (intro strip)
-apply (rule less_fun [THEN iffD2])
-apply (intro strip)
-apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
-apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
-apply (frule notUU_I)
-apply assumption
-apply (simp_all add: Sprod0_ss inst_sprod_po refl_less minimal)
-done
-
-lemma monofun_Ispair2: "monofun(Ispair(x))"
-apply (unfold monofun)
-apply (intro strip)
-apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
-apply (rule_tac Q = "xa=UU" in excluded_middle [THEN disjE])
-apply (frule notUU_I)
-apply assumption
-apply (simp_all add: Sprod0_ss inst_sprod_po refl_less minimal)
-done
-
-lemma monofun_Ispair: "[|x1<<x2; y1<<y2|] ==> Ispair x1 y1 << Ispair x2 y2"
-apply (rule trans_less)
-apply (rule monofun_Ispair1 [THEN monofunE, THEN spec, THEN spec, THEN mp, THEN less_fun [THEN iffD1, THEN spec]])
-prefer 2 apply (rule monofun_Ispair2 [THEN monofunE, THEN spec, THEN spec, THEN mp])
-apply assumption
-apply assumption
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Isfst and Issnd are monotone                                             *)
-(* ------------------------------------------------------------------------ *)
-
-lemma monofun_Isfst: "monofun(Isfst)"
-
-apply (unfold monofun)
-apply (simp add: inst_sprod_po)
-done
-
-lemma monofun_Issnd: "monofun(Issnd)"
-apply (unfold monofun)
-apply (simp add: inst_sprod_po)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* the type 'a ** 'b is a cpo                                               *)
-(* ------------------------------------------------------------------------ *)
-
-lemma lub_sprod: 
-"[|chain(S)|] ==> range(S) <<|  
-  Ispair (lub(range(%i. Isfst(S i)))) (lub(range(%i. Issnd(S i))))"
-apply (rule is_lubI)
-apply (rule ub_rangeI)
-apply (rule_tac t = "S (i) " in surjective_pairing_Sprod [THEN ssubst])
-apply (rule monofun_Ispair)
-apply (rule is_ub_thelub)
-apply (erule monofun_Isfst [THEN ch2ch_monofun])
-apply (rule is_ub_thelub)
-apply (erule monofun_Issnd [THEN ch2ch_monofun])
-apply (rule_tac t = "u" in surjective_pairing_Sprod [THEN ssubst])
-apply (rule monofun_Ispair)
-apply (rule is_lub_thelub)
-apply (erule monofun_Isfst [THEN ch2ch_monofun])
-apply (erule monofun_Isfst [THEN ub2ub_monofun])
-apply (rule is_lub_thelub)
-apply (erule monofun_Issnd [THEN ch2ch_monofun])
-apply (erule monofun_Issnd [THEN ub2ub_monofun])
-done
-
-lemmas thelub_sprod = lub_sprod [THEN thelubI, standard]
-
-
-lemma cpo_sprod: "chain(S::nat=>'a**'b)==>? x. range(S)<<| x"
-apply (rule exI)
-apply (erule lub_sprod)
-done
-
-end
-
-
--- a/src/HOLCF/Sprod3.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,53 +0,0 @@
-
-(* legacy ML bindings *)
-
-val spair_def = thm "spair_def";
-val sfst_def = thm "sfst_def";
-val ssnd_def = thm "ssnd_def";
-val ssplit_def = thm "ssplit_def";
-val inst_sprod_pcpo = thm "inst_sprod_pcpo";
-val sprod3_lemma1 = thm "sprod3_lemma1";
-val sprod3_lemma2 = thm "sprod3_lemma2";
-val sprod3_lemma3 = thm "sprod3_lemma3";
-val contlub_Ispair1 = thm "contlub_Ispair1";
-val sprod3_lemma4 = thm "sprod3_lemma4";
-val sprod3_lemma5 = thm "sprod3_lemma5";
-val sprod3_lemma6 = thm "sprod3_lemma6";
-val contlub_Ispair2 = thm "contlub_Ispair2";
-val cont_Ispair1 = thm "cont_Ispair1";
-val cont_Ispair2 = thm "cont_Ispair2";
-val contlub_Isfst = thm "contlub_Isfst";
-val contlub_Issnd = thm "contlub_Issnd";
-val cont_Isfst = thm "cont_Isfst";
-val cont_Issnd = thm "cont_Issnd";
-val spair_eq = thm "spair_eq";
-val beta_cfun_sprod = thm "beta_cfun_sprod";
-val inject_spair = thm "inject_spair";
-val inst_sprod_pcpo2 = thm "inst_sprod_pcpo2";
-val strict_spair = thm "strict_spair";
-val strict_spair1 = thm "strict_spair1";
-val strict_spair2 = thm "strict_spair2";
-val strict_spair_rev = thm "strict_spair_rev";
-val defined_spair_rev = thm "defined_spair_rev";
-val defined_spair = thm "defined_spair";
-val Exh_Sprod2 = thm "Exh_Sprod2";
-val sprodE = thm "sprodE";
-val strict_sfst = thm "strict_sfst";
-val strict_sfst1 = thm "strict_sfst1";
-val strict_sfst2 = thm "strict_sfst2";
-val strict_ssnd = thm "strict_ssnd";
-val strict_ssnd1 = thm "strict_ssnd1";
-val strict_ssnd2 = thm "strict_ssnd2";
-val sfst2 = thm "sfst2";
-val ssnd2 = thm "ssnd2";
-val defined_sfstssnd = thm "defined_sfstssnd";
-val surjective_pairing_Sprod2 = thm "surjective_pairing_Sprod2";
-val lub_sprod2 = thm "lub_sprod2";
-val thelub_sprod2 = thm "thelub_sprod2";
-val ssplit1 = thm "ssplit1";
-val ssplit2 = thm "ssplit2";
-val ssplit3 = thm "ssplit3";
-val Sprod_rews = [strict_sfst1, strict_sfst2,
-                strict_ssnd1, strict_ssnd2, sfst2, ssnd2, defined_spair,
-                ssplit1, ssplit2]
-
--- a/src/HOLCF/Sprod3.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,565 +0,0 @@
-(*  Title:      HOLCF/sprod3.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class instance of  ** for class pcpo
-*)
-
-theory Sprod3 = Sprod2:
-
-instance "**" :: (pcpo,pcpo)pcpo
-apply (intro_classes)
-apply (erule cpo_sprod)
-apply (rule least_sprod)
-done
-
-consts  
-  spair		:: "'a -> 'b -> ('a**'b)" (* continuous strict pairing *)
-  sfst		:: "('a**'b)->'a"
-  ssnd		:: "('a**'b)->'b"
-  ssplit	:: "('a->'b->'c)->('a**'b)->'c"
-
-syntax  
-  "@stuple"	:: "['a, args] => 'a ** 'b"	("(1'(:_,/ _:'))")
-
-translations
-        "(:x, y, z:)"   == "(:x, (:y, z:):)"
-        "(:x, y:)"      == "spair$x$y"
-
-defs
-spair_def:       "spair  == (LAM x y. Ispair x y)"
-sfst_def:        "sfst   == (LAM p. Isfst p)"
-ssnd_def:        "ssnd   == (LAM p. Issnd p)"     
-ssplit_def:      "ssplit == (LAM f. strictify$(LAM p. f$(sfst$p)$(ssnd$p)))"
-
-(*  Title:      HOLCF/Sprod3
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class instance of  ** for class pcpo
-*)
-
-(* for compatibility with old HOLCF-Version *)
-lemma inst_sprod_pcpo: "UU = Ispair UU UU"
-apply (simp add: UU_def UU_sprod_def)
-done
-
-declare inst_sprod_pcpo [symmetric, simp]
-
-(* ------------------------------------------------------------------------ *)
-(* continuity of Ispair, Isfst, Issnd                                       *)
-(* ------------------------------------------------------------------------ *)
-
-lemma sprod3_lemma1: 
-"[| chain(Y);  x~= UU;  lub(range(Y))~= UU |] ==> 
-  Ispair (lub(range Y)) x = 
-  Ispair (lub(range(%i. Isfst(Ispair(Y i) x))))  
-         (lub(range(%i. Issnd(Ispair(Y i) x))))"
-apply (rule_tac f1 = "Ispair" in arg_cong [THEN cong])
-apply (rule lub_equal)
-apply assumption
-apply (rule monofun_Isfst [THEN ch2ch_monofun])
-apply (rule ch2ch_fun)
-apply (rule monofun_Ispair1 [THEN ch2ch_monofun])
-apply assumption
-apply (rule allI)
-apply (simp (no_asm_simp))
-apply (rule sym)
-apply (drule chain_UU_I_inverse2)
-apply (erule exE)
-apply (rule lub_chain_maxelem)
-apply (erule Issnd2)
-apply (rule allI)
-apply (rename_tac "j")
-apply (case_tac "Y (j) =UU")
-apply auto
-done
-
-lemma sprod3_lemma2: 
-"[| chain(Y); x ~= UU; lub(range(Y)) = UU |] ==> 
-    Ispair (lub(range Y)) x = 
-    Ispair (lub(range(%i. Isfst(Ispair(Y i) x)))) 
-           (lub(range(%i. Issnd(Ispair(Y i) x))))"
-apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
-apply assumption
-apply (rule trans)
-apply (rule strict_Ispair1)
-apply (rule strict_Ispair [symmetric])
-apply (rule disjI1)
-apply (rule chain_UU_I_inverse)
-apply auto
-apply (erule chain_UU_I [THEN spec])
-apply assumption
-done
-
-
-lemma sprod3_lemma3: 
-"[| chain(Y); x = UU |] ==> 
-           Ispair (lub(range Y)) x = 
-           Ispair (lub(range(%i. Isfst(Ispair (Y i) x)))) 
-                  (lub(range(%i. Issnd(Ispair (Y i) x))))"
-apply (erule ssubst)
-apply (rule trans)
-apply (rule strict_Ispair2)
-apply (rule strict_Ispair [symmetric])
-apply (rule disjI1)
-apply (rule chain_UU_I_inverse)
-apply (rule allI)
-apply (simp add: Sprod0_ss)
-done
-
-lemma contlub_Ispair1: "contlub(Ispair)"
-apply (rule contlubI)
-apply (intro strip)
-apply (rule expand_fun_eq [THEN iffD2])
-apply (intro strip)
-apply (subst lub_fun [THEN thelubI])
-apply (erule monofun_Ispair1 [THEN ch2ch_monofun])
-apply (rule trans)
-apply (rule_tac [2] thelub_sprod [symmetric])
-apply (rule_tac [2] ch2ch_fun)
-apply (erule_tac [2] monofun_Ispair1 [THEN ch2ch_monofun])
-apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
-apply (rule_tac Q = "lub (range (Y))=UU" in excluded_middle [THEN disjE])
-apply (erule sprod3_lemma1)
-apply assumption
-apply assumption
-apply (erule sprod3_lemma2)
-apply assumption
-apply assumption
-apply (erule sprod3_lemma3)
-apply assumption
-done
-
-lemma sprod3_lemma4: 
-"[| chain(Y); x ~= UU; lub(range(Y)) ~= UU |] ==> 
-          Ispair x (lub(range Y)) = 
-          Ispair (lub(range(%i. Isfst (Ispair x (Y i))))) 
-                 (lub(range(%i. Issnd (Ispair x (Y i)))))"
-apply (rule_tac f1 = "Ispair" in arg_cong [THEN cong])
-apply (rule sym)
-apply (drule chain_UU_I_inverse2)
-apply (erule exE)
-apply (rule lub_chain_maxelem)
-apply (erule Isfst2)
-apply (rule allI)
-apply (rename_tac "j")
-apply (case_tac "Y (j) =UU")
-apply auto
-done
-
-lemma sprod3_lemma5: 
-"[| chain(Y); x ~= UU; lub(range(Y)) = UU |] ==> 
-          Ispair x (lub(range Y)) = 
-          Ispair (lub(range(%i. Isfst(Ispair x (Y i))))) 
-                 (lub(range(%i. Issnd(Ispair x (Y i)))))"
-apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
-apply assumption
-apply (rule trans)
-apply (rule strict_Ispair2)
-apply (rule strict_Ispair [symmetric])
-apply (rule disjI2)
-apply (rule chain_UU_I_inverse)
-apply (rule allI)
-apply (simp add: Sprod0_ss)
-apply (erule chain_UU_I [THEN spec])
-apply assumption
-done
-
-lemma sprod3_lemma6: 
-"[| chain(Y); x = UU |] ==> 
-          Ispair x (lub(range Y)) = 
-          Ispair (lub(range(%i. Isfst (Ispair x (Y i))))) 
-                 (lub(range(%i. Issnd (Ispair x (Y i)))))"
-apply (rule_tac s = "UU" and t = "x" in ssubst)
-apply assumption
-apply (rule trans)
-apply (rule strict_Ispair1)
-apply (rule strict_Ispair [symmetric])
-apply (rule disjI1)
-apply (rule chain_UU_I_inverse)
-apply (rule allI)
-apply (simp add: Sprod0_ss)
-done
-
-lemma contlub_Ispair2: "contlub(Ispair(x))"
-apply (rule contlubI)
-apply (intro strip)
-apply (rule trans)
-apply (rule_tac [2] thelub_sprod [symmetric])
-apply (erule_tac [2] monofun_Ispair2 [THEN ch2ch_monofun])
-apply (rule_tac Q = "x=UU" in excluded_middle [THEN disjE])
-apply (rule_tac Q = "lub (range (Y))=UU" in excluded_middle [THEN disjE])
-apply (erule sprod3_lemma4)
-apply assumption
-apply assumption
-apply (erule sprod3_lemma5)
-apply assumption
-apply assumption
-apply (erule sprod3_lemma6)
-apply assumption
-done
-
-lemma cont_Ispair1: "cont(Ispair)"
-apply (rule monocontlub2cont)
-apply (rule monofun_Ispair1)
-apply (rule contlub_Ispair1)
-done
-
-
-lemma cont_Ispair2: "cont(Ispair(x))"
-apply (rule monocontlub2cont)
-apply (rule monofun_Ispair2)
-apply (rule contlub_Ispair2)
-done
-
-lemma contlub_Isfst: "contlub(Isfst)"
-apply (rule contlubI)
-apply (intro strip)
-apply (subst lub_sprod [THEN thelubI])
-apply assumption
-apply (rule_tac Q = "lub (range (%i. Issnd (Y (i))))=UU" in excluded_middle [THEN disjE])
-apply (simp add: Sprod0_ss)
-apply (rule_tac s = "UU" and t = "lub (range (%i. Issnd (Y (i))))" in ssubst)
-apply assumption
-apply (rule trans)
-apply (simp add: Sprod0_ss)
-apply (rule sym)
-apply (rule chain_UU_I_inverse)
-apply (rule allI)
-apply (rule strict_Isfst)
-apply (rule contrapos_np)
-apply (erule_tac [2] defined_IsfstIssnd [THEN conjunct2])
-apply (fast dest!: monofun_Issnd [THEN ch2ch_monofun, THEN chain_UU_I, THEN spec])
-done
-
-lemma contlub_Issnd: "contlub(Issnd)"
-apply (rule contlubI)
-apply (intro strip)
-apply (subst lub_sprod [THEN thelubI])
-apply assumption
-apply (rule_tac Q = "lub (range (%i. Isfst (Y (i))))=UU" in excluded_middle [THEN disjE])
-apply (simp add: Sprod0_ss)
-apply (rule_tac s = "UU" and t = "lub (range (%i. Isfst (Y (i))))" in ssubst)
-apply assumption
-apply (simp add: Sprod0_ss)
-apply (rule sym)
-apply (rule chain_UU_I_inverse)
-apply (rule allI)
-apply (rule strict_Issnd)
-apply (rule contrapos_np)
-apply (erule_tac [2] defined_IsfstIssnd [THEN conjunct1])
-apply (fast dest!: monofun_Isfst [THEN ch2ch_monofun, THEN chain_UU_I, THEN spec])
-done
-
-lemma cont_Isfst: "cont(Isfst)"
-apply (rule monocontlub2cont)
-apply (rule monofun_Isfst)
-apply (rule contlub_Isfst)
-done
-
-lemma cont_Issnd: "cont(Issnd)"
-apply (rule monocontlub2cont)
-apply (rule monofun_Issnd)
-apply (rule contlub_Issnd)
-done
-
-lemma spair_eq: "[|x1=x2;y1=y2|] ==> (:x1,y1:) = (:x2,y2:)"
-apply fast
-done
-
-(* ------------------------------------------------------------------------ *)
-(* convert all lemmas to the continuous versions                            *)
-(* ------------------------------------------------------------------------ *)
-
-lemma beta_cfun_sprod: 
-        "(LAM x y. Ispair x y)$a$b = Ispair a b"
-apply (subst beta_cfun)
-apply (simp (no_asm) add: cont_Ispair2 cont_Ispair1 cont2cont_CF1L)
-apply (subst beta_cfun)
-apply (rule cont_Ispair2)
-apply (rule refl)
-done
-
-declare beta_cfun_sprod [simp]
-
-lemma inject_spair: 
-        "[| aa~=UU ; ba~=UU ; (:a,b:)=(:aa,ba:) |] ==> a=aa & b=ba"
-apply (unfold spair_def)
-apply (erule inject_Ispair)
-apply assumption
-apply (erule box_equals)
-apply (rule beta_cfun_sprod)
-apply (rule beta_cfun_sprod)
-done
-
-lemma inst_sprod_pcpo2: "UU = (:UU,UU:)"
-apply (unfold spair_def)
-apply (rule sym)
-apply (rule trans)
-apply (rule beta_cfun_sprod)
-apply (rule sym)
-apply (rule inst_sprod_pcpo)
-done
-
-lemma strict_spair: 
-        "(a=UU | b=UU) ==> (:a,b:)=UU"
-apply (unfold spair_def)
-apply (rule trans)
-apply (rule beta_cfun_sprod)
-apply (rule trans)
-apply (rule_tac [2] inst_sprod_pcpo [symmetric])
-apply (erule strict_Ispair)
-done
-
-lemma strict_spair1: "(:UU,b:) = UU"
-apply (unfold spair_def)
-apply (subst beta_cfun_sprod)
-apply (rule trans)
-apply (rule_tac [2] inst_sprod_pcpo [symmetric])
-apply (rule strict_Ispair1)
-done
-
-lemma strict_spair2: "(:a,UU:) = UU"
-apply (unfold spair_def)
-apply (subst beta_cfun_sprod)
-apply (rule trans)
-apply (rule_tac [2] inst_sprod_pcpo [symmetric])
-apply (rule strict_Ispair2)
-done
-
-declare strict_spair1 [simp] strict_spair2 [simp]
-
-lemma strict_spair_rev: "(:x,y:)~=UU ==> ~x=UU & ~y=UU"
-apply (unfold spair_def)
-apply (rule strict_Ispair_rev)
-apply auto
-done
-
-lemma defined_spair_rev: "(:a,b:) = UU ==> (a = UU | b = UU)"
-apply (unfold spair_def)
-apply (rule defined_Ispair_rev)
-apply auto
-done
-
-lemma defined_spair: 
-        "[|a~=UU; b~=UU|] ==> (:a,b:) ~= UU"
-apply (unfold spair_def)
-apply (subst beta_cfun_sprod)
-apply (subst inst_sprod_pcpo)
-apply (erule defined_Ispair)
-apply assumption
-done
-
-lemma Exh_Sprod2:
-        "z=UU | (? a b. z=(:a,b:) & a~=UU & b~=UU)"
-apply (unfold spair_def)
-apply (rule Exh_Sprod [THEN disjE])
-apply (rule disjI1)
-apply (subst inst_sprod_pcpo)
-apply assumption
-apply (rule disjI2)
-apply (erule exE)
-apply (erule exE)
-apply (rule exI)
-apply (rule exI)
-apply (rule conjI)
-apply (subst beta_cfun_sprod)
-apply fast
-apply fast
-done
-
-
-lemma sprodE:
-assumes prem1: "p=UU ==> Q"
-assumes prem2: "!!x y. [| p=(:x,y:); x~=UU; y~=UU|] ==> Q"
-shows "Q"
-apply (rule IsprodE)
-apply (rule prem1)
-apply (subst inst_sprod_pcpo)
-apply assumption
-apply (rule prem2)
-prefer 2 apply (assumption)
-prefer 2 apply (assumption)
-apply (unfold spair_def)
-apply (subst beta_cfun_sprod)
-apply assumption
-done
-
-
-lemma strict_sfst: 
-        "p=UU==>sfst$p=UU"
-apply (unfold sfst_def)
-apply (subst beta_cfun)
-apply (rule cont_Isfst)
-apply (rule strict_Isfst)
-apply (rule inst_sprod_pcpo [THEN subst])
-apply assumption
-done
-
-lemma strict_sfst1: 
-        "sfst$(:UU,y:) = UU"
-apply (unfold sfst_def spair_def)
-apply (subst beta_cfun_sprod)
-apply (subst beta_cfun)
-apply (rule cont_Isfst)
-apply (rule strict_Isfst1)
-done
- 
-lemma strict_sfst2: 
-        "sfst$(:x,UU:) = UU"
-apply (unfold sfst_def spair_def)
-apply (subst beta_cfun_sprod)
-apply (subst beta_cfun)
-apply (rule cont_Isfst)
-apply (rule strict_Isfst2)
-done
-
-lemma strict_ssnd: 
-        "p=UU==>ssnd$p=UU"
-apply (unfold ssnd_def)
-apply (subst beta_cfun)
-apply (rule cont_Issnd)
-apply (rule strict_Issnd)
-apply (rule inst_sprod_pcpo [THEN subst])
-apply assumption
-done
-
-lemma strict_ssnd1: 
-        "ssnd$(:UU,y:) = UU"
-apply (unfold ssnd_def spair_def)
-apply (subst beta_cfun_sprod)
-apply (subst beta_cfun)
-apply (rule cont_Issnd)
-apply (rule strict_Issnd1)
-done
-
-lemma strict_ssnd2: 
-        "ssnd$(:x,UU:) = UU"
-apply (unfold ssnd_def spair_def)
-apply (subst beta_cfun_sprod)
-apply (subst beta_cfun)
-apply (rule cont_Issnd)
-apply (rule strict_Issnd2)
-done
-
-lemma sfst2: 
-        "y~=UU ==>sfst$(:x,y:)=x"
-apply (unfold sfst_def spair_def)
-apply (subst beta_cfun_sprod)
-apply (subst beta_cfun)
-apply (rule cont_Isfst)
-apply (erule Isfst2)
-done
-
-lemma ssnd2: 
-        "x~=UU ==>ssnd$(:x,y:)=y"
-apply (unfold ssnd_def spair_def)
-apply (subst beta_cfun_sprod)
-apply (subst beta_cfun)
-apply (rule cont_Issnd)
-apply (erule Issnd2)
-done
-
-
-lemma defined_sfstssnd: 
-        "p~=UU ==> sfst$p ~=UU & ssnd$p ~=UU"
-apply (unfold sfst_def ssnd_def spair_def)
-apply (simplesubst beta_cfun)
-apply (rule cont_Issnd)
-apply (subst beta_cfun)
-apply (rule cont_Isfst)
-apply (rule defined_IsfstIssnd)
-apply (rule inst_sprod_pcpo [THEN subst])
-apply assumption
-done
- 
-lemma surjective_pairing_Sprod2: "(:sfst$p , ssnd$p:) = p"
- 
-apply (unfold sfst_def ssnd_def spair_def)
-apply (subst beta_cfun_sprod)
-apply (simplesubst beta_cfun)
-apply (rule cont_Issnd)
-apply (subst beta_cfun)
-apply (rule cont_Isfst)
-apply (rule surjective_pairing_Sprod [symmetric])
-done
-
-lemma lub_sprod2: 
-"chain(S) ==> range(S) <<|  
-               (: lub(range(%i. sfst$(S i))), lub(range(%i. ssnd$(S i))) :)"
-apply (unfold sfst_def ssnd_def spair_def)
-apply (subst beta_cfun_sprod)
-apply (simplesubst beta_cfun [THEN ext])
-apply (rule cont_Issnd)
-apply (subst beta_cfun [THEN ext])
-apply (rule cont_Isfst)
-apply (erule lub_sprod)
-done
-
-
-lemmas thelub_sprod2 = lub_sprod2 [THEN thelubI, standard]
-(*
- "chain ?S1 ==>
- lub (range ?S1) =
- (:lub (range (%i. sfst$(?S1 i))), lub (range (%i. ssnd$(?S1 i))):)" : thm
-*)
-
-lemma ssplit1: 
-        "ssplit$f$UU=UU"
-
-apply (unfold ssplit_def)
-apply (subst beta_cfun)
-apply (simp (no_asm))
-apply (subst strictify1)
-apply (rule refl)
-done
-
-lemma ssplit2: 
-        "[|x~=UU;y~=UU|] ==> ssplit$f$(:x,y:)= f$x$y"
-apply (unfold ssplit_def)
-apply (subst beta_cfun)
-apply (simp (no_asm))
-apply (subst strictify2)
-apply (rule defined_spair)
-apply assumption
-apply assumption
-apply (subst beta_cfun)
-apply (simp (no_asm))
-apply (subst sfst2)
-apply assumption
-apply (subst ssnd2)
-apply assumption
-apply (rule refl)
-done
-
-
-lemma ssplit3: 
-  "ssplit$spair$z=z"
-
-apply (unfold ssplit_def)
-apply (subst beta_cfun)
-apply (simp (no_asm))
-apply (case_tac "z=UU")
-apply (erule ssubst)
-apply (rule strictify1)
-apply (rule trans)
-apply (rule strictify2)
-apply assumption
-apply (subst beta_cfun)
-apply (simp (no_asm))
-apply (rule surjective_pairing_Sprod2)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* install simplifier for Sprod                                             *)
-(* ------------------------------------------------------------------------ *)
-
-lemmas Sprod_rews = strict_sfst1 strict_sfst2
-                strict_ssnd1 strict_ssnd2 sfst2 ssnd2 defined_spair
-                ssplit1 ssplit2
-declare Sprod_rews [simp]
-
-end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Ssum.ML	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,112 @@
+
+(* legacy ML bindings *)
+
+val Isinl_def = thm "Isinl_def";
+val Isinr_def = thm "Isinr_def";
+val Iwhen_def = thm "Iwhen_def";
+val SsumIl = thm "SsumIl";
+val SsumIr = thm "SsumIr";
+val inj_on_Abs_Ssum = thm "inj_on_Abs_Ssum";
+val strict_SinlSinr_Rep = thm "strict_SinlSinr_Rep";
+val strict_IsinlIsinr = thm "strict_IsinlIsinr";
+val noteq_SinlSinr_Rep = thm "noteq_SinlSinr_Rep";
+val noteq_IsinlIsinr = thm "noteq_IsinlIsinr";
+val inject_Sinl_Rep1 = thm "inject_Sinl_Rep1";
+val inject_Sinr_Rep1 = thm "inject_Sinr_Rep1";
+val inject_Sinl_Rep2 = thm "inject_Sinl_Rep2";
+val inject_Sinr_Rep2 = thm "inject_Sinr_Rep2";
+val inject_Sinl_Rep = thm "inject_Sinl_Rep";
+val inject_Sinr_Rep = thm "inject_Sinr_Rep";
+val inject_Isinl = thm "inject_Isinl";
+val inject_Isinr = thm "inject_Isinr";
+val inject_Isinl_rev = thm "inject_Isinl_rev";
+val inject_Isinr_rev = thm "inject_Isinr_rev";
+val Exh_Ssum = thm "Exh_Ssum";
+val IssumE = thm "IssumE";
+val IssumE2 = thm "IssumE2";
+val Iwhen1 = thm "Iwhen1";
+val Iwhen2 = thm "Iwhen2";
+val Iwhen3 = thm "Iwhen3";
+val less_ssum_def = thm "less_ssum_def";
+val less_ssum1a = thm "less_ssum1a";
+val less_ssum1b = thm "less_ssum1b";
+val less_ssum1c = thm "less_ssum1c";
+val less_ssum1d = thm "less_ssum1d";
+val less_ssum2a = thm "less_ssum2a";
+val less_ssum2b = thm "less_ssum2b";
+val less_ssum2c = thm "less_ssum2c";
+val less_ssum2d = thm "less_ssum2d";
+val refl_less_ssum = thm "refl_less_ssum";
+val antisym_less_ssum = thm "antisym_less_ssum";
+val trans_less_ssum = thm "trans_less_ssum";
+val inst_ssum_po = thm "inst_ssum_po";
+val less_ssum3a = thm "less_ssum3a";
+val less_ssum3b = thm "less_ssum3b";
+val less_ssum3c = thm "less_ssum3c";
+val less_ssum3d = thm "less_ssum3d";
+val minimal_ssum = thm "minimal_ssum";
+val UU_ssum_def = thm "UU_ssum_def";
+val least_ssum = thm "least_ssum";
+val monofun_Isinl = thm "monofun_Isinl";
+val monofun_Isinr = thm "monofun_Isinr";
+val monofun_Iwhen1 = thm "monofun_Iwhen1";
+val monofun_Iwhen2 = thm "monofun_Iwhen2";
+val monofun_Iwhen3 = thm "monofun_Iwhen3";
+val ssum_lemma1 = thm "ssum_lemma1";
+val ssum_lemma2 = thm "ssum_lemma2";
+val ssum_lemma3 = thm "ssum_lemma3";
+val ssum_lemma4 = thm "ssum_lemma4";
+val ssum_lemma5 = thm "ssum_lemma5";
+val ssum_lemma6 = thm "ssum_lemma6";
+val ssum_lemma7 = thm "ssum_lemma7";
+val ssum_lemma8 = thm "ssum_lemma8";
+val lub_ssum1a = thm "lub_ssum1a";
+val lub_ssum1b = thm "lub_ssum1b";
+val thelub_ssum1a = thm "thelub_ssum1a";
+val thelub_ssum1b = thm "thelub_ssum1b";
+val cpo_ssum = thm "cpo_ssum";
+val sinl_def = thm "sinl_def";
+val sinr_def = thm "sinr_def";
+val sscase_def = thm "sscase_def";
+val inst_ssum_pcpo = thm "inst_ssum_pcpo";
+val contlub_Isinl = thm "contlub_Isinl";
+val contlub_Isinr = thm "contlub_Isinr";
+val cont_Isinl = thm "cont_Isinl";
+val cont_Isinr = thm "cont_Isinr";
+val contlub_Iwhen1 = thm "contlub_Iwhen1";
+val contlub_Iwhen2 = thm "contlub_Iwhen2";
+val ssum_lemma9 = thm "ssum_lemma9";
+val ssum_lemma10 = thm "ssum_lemma10";
+val ssum_lemma11 = thm "ssum_lemma11";
+val ssum_lemma12 = thm "ssum_lemma12";
+val ssum_lemma13 = thm "ssum_lemma13";
+val contlub_Iwhen3 = thm "contlub_Iwhen3";
+val cont_Iwhen1 = thm "cont_Iwhen1";
+val cont_Iwhen2 = thm "cont_Iwhen2";
+val cont_Iwhen3 = thm "cont_Iwhen3";
+val strict_sinl = thm "strict_sinl";
+val strict_sinr = thm "strict_sinr";
+val noteq_sinlsinr = thm "noteq_sinlsinr";
+val inject_sinl = thm "inject_sinl";
+val inject_sinr = thm "inject_sinr";
+val defined_sinl = thm "defined_sinl";
+val defined_sinr = thm "defined_sinr";
+val Exh_Ssum1 = thm "Exh_Ssum1";
+val ssumE = thm "ssumE";
+val ssumE2 = thm "ssumE2";
+val sscase1 = thm "sscase1";
+val sscase2 = thm "sscase2";
+val sscase3 = thm "sscase3";
+val less_ssum4a = thm "less_ssum4a";
+val less_ssum4b = thm "less_ssum4b";
+val less_ssum4c = thm "less_ssum4c";
+val less_ssum4d = thm "less_ssum4d";
+val ssum_chainE = thm "ssum_chainE";
+val thelub_ssum2a = thm "thelub_ssum2a";
+val thelub_ssum2b = thm "thelub_ssum2b";
+val thelub_ssum2a_rev = thm "thelub_ssum2a_rev";
+val thelub_ssum2b_rev = thm "thelub_ssum2b_rev";
+val thelub_ssum3 = thm "thelub_ssum3";
+val sscase4 = thm "sscase4";
+val Ssum_rews = [strict_sinl, strict_sinr, defined_sinl, defined_sinr,
+                sscase1, sscase2, sscase3]
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Ssum.thy	Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,1565 @@
+(*  Title:      HOLCF/Ssum0.thy
+    ID:         $Id$
+    Author:     Franz Regensburger
+    License:    GPL (GNU GENERAL PUBLIC LICENSE)
+
+Strict sum with typedef
+*)
+
+header {* The type of strict sums *}
+
+theory Ssum = Cfun:
+
+constdefs
+  Sinl_Rep      :: "['a,'a,'b,bool]=>bool"
+ "Sinl_Rep == (%a.%x y p. (a~=UU --> x=a & p))"
+  Sinr_Rep      :: "['b,'a,'b,bool]=>bool"
+ "Sinr_Rep == (%b.%x y p.(b~=UU --> y=b & ~p))"
+
+typedef (Ssum)  ('a, 'b) "++" (infixr 10) = 
+	"{f.(? a. f=Sinl_Rep(a::'a))|(? b. f=Sinr_Rep(b::'b))}"
+by auto
+
+syntax (xsymbols)
+  "++"		:: "[type, type] => type"	("(_ \<oplus>/ _)" [21, 20] 20)
+syntax (HTML output)
+  "++"		:: "[type, type] => type"	("(_ \<oplus>/ _)" [21, 20] 20)
+
+consts
+  Isinl         :: "'a => ('a ++ 'b)"
+  Isinr         :: "'b => ('a ++ 'b)"
+  Iwhen         :: "('a->'c)=>('b->'c)=>('a ++ 'b)=> 'c"
+
+defs   (*defining the abstract constants*)
+  Isinl_def:     "Isinl(a) == Abs_Ssum(Sinl_Rep(a))"
+  Isinr_def:     "Isinr(b) == Abs_Ssum(Sinr_Rep(b))"
+
+  Iwhen_def:     "Iwhen(f)(g)(s) == @z.
+                                    (s=Isinl(UU) --> z=UU)
+                        &(!a. a~=UU & s=Isinl(a) --> z=f$a)  
+                        &(!b. b~=UU & s=Isinr(b) --> z=g$b)"  
+
+(* ------------------------------------------------------------------------ *)
+(* A non-emptyness result for Sssum                                         *)
+(* ------------------------------------------------------------------------ *)
+
+lemma SsumIl: "Sinl_Rep(a):Ssum"
+apply (unfold Ssum_def)
+apply blast
+done
+
+lemma SsumIr: "Sinr_Rep(a):Ssum"
+apply (unfold Ssum_def)
+apply blast
+done
+
+lemma inj_on_Abs_Ssum: "inj_on Abs_Ssum Ssum"
+apply (rule inj_on_inverseI)
+apply (erule Abs_Ssum_inverse)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Strictness of Sinr_Rep, Sinl_Rep and Isinl, Isinr                        *)
+(* ------------------------------------------------------------------------ *)
+
+lemma strict_SinlSinr_Rep: 
+ "Sinl_Rep(UU) = Sinr_Rep(UU)"
+apply (unfold Sinr_Rep_def Sinl_Rep_def)
+apply (rule ext)
+apply (rule ext)
+apply (rule ext)
+apply fast
+done
+
+lemma strict_IsinlIsinr: 
+ "Isinl(UU) = Isinr(UU)"
+apply (unfold Isinl_def Isinr_def)
+apply (rule strict_SinlSinr_Rep [THEN arg_cong])
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* distinctness of  Sinl_Rep, Sinr_Rep and Isinl, Isinr                     *)
+(* ------------------------------------------------------------------------ *)
+
+lemma noteq_SinlSinr_Rep: 
+        "(Sinl_Rep(a) = Sinr_Rep(b)) ==> a=UU & b=UU"
+apply (unfold Sinl_Rep_def Sinr_Rep_def)
+apply (blast dest!: fun_cong)
+done
+
+
+lemma noteq_IsinlIsinr: 
+        "Isinl(a)=Isinr(b) ==> a=UU & b=UU"
+apply (unfold Isinl_def Isinr_def)
+apply (rule noteq_SinlSinr_Rep)
+apply (erule inj_on_Abs_Ssum [THEN inj_onD])
+apply (rule SsumIl)
+apply (rule SsumIr)
+done
+
+
+
+(* ------------------------------------------------------------------------ *)
+(* injectivity of Sinl_Rep, Sinr_Rep and Isinl, Isinr                       *)
+(* ------------------------------------------------------------------------ *)
+
+lemma inject_Sinl_Rep1: "(Sinl_Rep(a) = Sinl_Rep(UU)) ==> a=UU"
+apply (unfold Sinl_Rep_def)
+apply (blast dest!: fun_cong)
+done
+
+lemma inject_Sinr_Rep1: "(Sinr_Rep(b) = Sinr_Rep(UU)) ==> b=UU"
+apply (unfold Sinr_Rep_def)
+apply (blast dest!: fun_cong)
+done
+
+lemma inject_Sinl_Rep2: 
+"[| a1~=UU ; a2~=UU ; Sinl_Rep(a1)=Sinl_Rep(a2) |] ==> a1=a2"
+apply (unfold Sinl_Rep_def)
+apply (blast dest!: fun_cong)
+done
+
+lemma inject_Sinr_Rep2: 
+"[|b1~=UU ; b2~=UU ; Sinr_Rep(b1)=Sinr_Rep(b2) |] ==> b1=b2"
+apply (unfold Sinr_Rep_def)
+apply (blast dest!: fun_cong)
+done
+
+lemma inject_Sinl_Rep: "Sinl_Rep(a1)=Sinl_Rep(a2) ==> a1=a2"
+apply (case_tac "a1=UU")
+apply simp
+apply (rule inject_Sinl_Rep1 [symmetric])
+apply (erule sym)
+apply (case_tac "a2=UU")
+apply simp
+apply (drule inject_Sinl_Rep1)
+apply simp
+apply (erule inject_Sinl_Rep2)
+apply assumption
+apply assumption
+done
+
+lemma inject_Sinr_Rep: "Sinr_Rep(b1)=Sinr_Rep(b2) ==> b1=b2"
+apply (case_tac "b1=UU")
+apply simp
+apply (rule inject_Sinr_Rep1 [symmetric])
+apply (erule sym)
+apply (case_tac "b2=UU")
+apply simp
+apply (drule inject_Sinr_Rep1)
+apply simp
+apply (erule inject_Sinr_Rep2)
+apply assumption
+apply assumption
+done
+
+lemma inject_Isinl: "Isinl(a1)=Isinl(a2)==> a1=a2"
+apply (unfold Isinl_def)
+apply (rule inject_Sinl_Rep)
+apply (erule inj_on_Abs_Ssum [THEN inj_onD])
+apply (rule SsumIl)
+apply (rule SsumIl)
+done
+
+lemma inject_Isinr: "Isinr(b1)=Isinr(b2) ==> b1=b2"
+apply (unfold Isinr_def)
+apply (rule inject_Sinr_Rep)
+apply (erule inj_on_Abs_Ssum [THEN inj_onD])
+apply (rule SsumIr)
+apply (rule SsumIr)
+done
+
+declare inject_Isinl [dest!] inject_Isinr [dest!]
+
+lemma inject_Isinl_rev: "a1~=a2 ==> Isinl(a1) ~= Isinl(a2)"
+apply blast
+done
+
+lemma inject_Isinr_rev: "b1~=b2 ==> Isinr(b1) ~= Isinr(b2)"
+apply blast
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Exhaustion of the strict sum ++                                          *)
+(* choice of the bottom representation is arbitrary                         *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Exh_Ssum: 
+        "z=Isinl(UU) | (? a. z=Isinl(a) & a~=UU) | (? b. z=Isinr(b) & b~=UU)"
+apply (unfold Isinl_def Isinr_def)
+apply (rule Rep_Ssum[unfolded Ssum_def, THEN CollectE])
+apply (erule disjE)
+apply (erule exE)
+apply (case_tac "z= Abs_Ssum (Sinl_Rep (UU))")
+apply (erule disjI1)
+apply (rule disjI2)
+apply (rule disjI1)
+apply (rule exI)
+apply (rule conjI)
+apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
+apply (erule arg_cong)
+apply (rule_tac Q = "Sinl_Rep (a) =Sinl_Rep (UU) " in contrapos_nn)
+apply (erule_tac [2] arg_cong)
+apply (erule contrapos_nn)
+apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
+apply (rule trans)
+apply (erule arg_cong)
+apply (erule arg_cong)
+apply (erule exE)
+apply (case_tac "z= Abs_Ssum (Sinl_Rep (UU))")
+apply (erule disjI1)
+apply (rule disjI2)
+apply (rule disjI2)
+apply (rule exI)
+apply (rule conjI)
+apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
+apply (erule arg_cong)
+apply (rule_tac Q = "Sinr_Rep (b) =Sinl_Rep (UU) " in contrapos_nn)
+prefer 2 apply simp
+apply (rule strict_SinlSinr_Rep [symmetric])
+apply (erule contrapos_nn)
+apply (rule Rep_Ssum_inverse [symmetric, THEN trans])
+apply (rule trans)
+apply (erule arg_cong)
+apply (erule arg_cong)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* elimination rules for the strict sum ++                                  *)
+(* ------------------------------------------------------------------------ *)
+
+lemma IssumE:
+        "[|p=Isinl(UU) ==> Q ; 
+        !!x.[|p=Isinl(x); x~=UU |] ==> Q; 
+        !!y.[|p=Isinr(y); y~=UU |] ==> Q|] ==> Q"
+apply (rule Exh_Ssum [THEN disjE])
+apply auto
+done
+
+lemma IssumE2:
+"[| !!x. [| p = Isinl(x) |] ==> Q;   !!y. [| p = Isinr(y) |] ==> Q |] ==>Q"
+apply (rule IssumE)
+apply auto
+done
+
+
+
+
+(* ------------------------------------------------------------------------ *)
+(* rewrites for Iwhen                                                       *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Iwhen1: 
+        "Iwhen f g (Isinl UU) = UU"
+apply (unfold Iwhen_def)
+apply (rule some_equality)
+apply (rule conjI)
+apply fast
+apply (rule conjI)
+apply (intro strip)
+apply (rule_tac P = "a=UU" in notE)
+apply fast
+apply (rule inject_Isinl)
+apply (rule sym)
+apply fast
+apply (intro strip)
+apply (rule_tac P = "b=UU" in notE)
+apply fast
+apply (rule inject_Isinr)
+apply (rule sym)
+apply (rule strict_IsinlIsinr [THEN subst])
+apply fast
+apply fast
+done
+
+
+lemma Iwhen2: 
+        "x~=UU ==> Iwhen f g (Isinl x) = f$x"
+apply (unfold Iwhen_def)
+apply (rule some_equality)
+prefer 2 apply fast
+apply (rule conjI)
+apply (intro strip)
+apply (rule_tac P = "x=UU" in notE)
+apply assumption
+apply (rule inject_Isinl)
+apply assumption
+apply (rule conjI)
+apply (intro strip)
+apply (rule cfun_arg_cong)
+apply (rule inject_Isinl)
+apply fast
+apply (intro strip)
+apply (rule_tac P = "Isinl (x) = Isinr (b) " in notE)
+prefer 2 apply fast
+apply (rule contrapos_nn)
+apply (erule_tac [2] noteq_IsinlIsinr)
+apply fast
+done
+
+lemma Iwhen3: 
+        "y~=UU ==> Iwhen f g (Isinr y) = g$y"
+apply (unfold Iwhen_def)
+apply (rule some_equality)
+prefer 2 apply fast
+apply (rule conjI)
+apply (intro strip)
+apply (rule_tac P = "y=UU" in notE)
+apply assumption
+apply (rule inject_Isinr)
+apply (rule strict_IsinlIsinr [THEN subst])
+apply assumption
+apply (rule conjI)
+apply (intro strip)
+apply (rule_tac P = "Isinr (y) = Isinl (a) " in notE)
+prefer 2 apply fast
+apply (rule contrapos_nn)
+apply (erule_tac [2] sym [THEN noteq_IsinlIsinr])
+apply fast
+apply (intro strip)
+apply (rule cfun_arg_cong)
+apply (rule inject_Isinr)
+apply fast
+done
+
+(* ------------------------------------------------------------------------ *)
+(* instantiate the simplifier                                               *)
+(* ------------------------------------------------------------------------ *)
+
+lemmas Ssum0_ss = strict_IsinlIsinr[symmetric] Iwhen1 Iwhen2 Iwhen3
+
+declare Ssum0_ss [simp]
+
+(* Partial ordering for the strict sum ++ *)
+
+instance "++"::(pcpo,pcpo)sq_ord ..
+
+defs (overloaded)
+  less_ssum_def: "(op <<) == (%s1 s2.@z.
+         (! u x. s1=Isinl u & s2=Isinl x --> z = u << x)
+        &(! v y. s1=Isinr v & s2=Isinr y --> z = v << y)
+        &(! u y. s1=Isinl u & s2=Isinr y --> z = (u = UU))
+        &(! v x. s1=Isinr v & s2=Isinl x --> z = (v = UU)))"
+
+lemma less_ssum1a: 
+"[|s1=Isinl(x::'a); s2=Isinl(y::'a)|] ==> s1 << s2 = (x << y)"
+apply (unfold less_ssum_def)
+apply (rule some_equality)
+apply (drule_tac [2] conjunct1)
+apply (drule_tac [2] spec)
+apply (drule_tac [2] spec)
+apply (erule_tac [2] mp)
+prefer 2 apply fast
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule inject_Isinl)
+apply (drule inject_Isinl)
+apply simp
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule noteq_IsinlIsinr[OF sym])
+apply simp
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule inject_Isinl)
+apply (drule noteq_IsinlIsinr[OF sym])
+apply simp
+apply (rule eq_UU_iff[symmetric])
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule noteq_IsinlIsinr[OF sym])
+apply simp
+done
+
+
+lemma less_ssum1b: 
+"[|s1=Isinr(x::'b); s2=Isinr(y::'b)|] ==> s1 << s2 = (x << y)"
+apply (unfold less_ssum_def)
+apply (rule some_equality)
+apply (drule_tac [2] conjunct2)
+apply (drule_tac [2] conjunct1)
+apply (drule_tac [2] spec)
+apply (drule_tac [2] spec)
+apply (erule_tac [2] mp)
+prefer 2 apply fast
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule noteq_IsinlIsinr)
+apply (drule noteq_IsinlIsinr)
+apply simp
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule inject_Isinr)
+apply (drule inject_Isinr)
+apply simp
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule noteq_IsinlIsinr)
+apply (drule inject_Isinr)
+apply simp
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule inject_Isinr)
+apply (drule noteq_IsinlIsinr)
+apply simp
+apply (rule eq_UU_iff[symmetric])
+done
+
+
+lemma less_ssum1c: 
+"[|s1=Isinl(x::'a); s2=Isinr(y::'b)|] ==> s1 << s2 = ((x::'a) = UU)"
+apply (unfold less_ssum_def)
+apply (rule some_equality)
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule inject_Isinl)
+apply (drule noteq_IsinlIsinr)
+apply simp
+apply (rule eq_UU_iff)
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule noteq_IsinlIsinr[OF sym])
+apply (drule inject_Isinr)
+apply simp
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule inject_Isinl)
+apply (drule inject_Isinr)
+apply simp
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule noteq_IsinlIsinr[OF sym])
+apply (drule noteq_IsinlIsinr)
+apply simp
+apply (drule conjunct2)
+apply (drule conjunct2)
+apply (drule conjunct1)
+apply (drule spec)
+apply (drule spec)
+apply (erule mp)
+apply fast
+done
+
+
+lemma less_ssum1d: 
+"[|s1=Isinr(x); s2=Isinl(y)|] ==> s1 << s2 = (x = UU)"
+apply (unfold less_ssum_def)
+apply (rule some_equality)
+apply (drule_tac [2] conjunct2)
+apply (drule_tac [2] conjunct2)
+apply (drule_tac [2] conjunct2)
+apply (drule_tac [2] spec)
+apply (drule_tac [2] spec)
+apply (erule_tac [2] mp)
+prefer 2 apply fast
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule noteq_IsinlIsinr)
+apply (drule inject_Isinl)
+apply simp
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule noteq_IsinlIsinr[OF sym])
+apply (drule inject_Isinr)
+apply simp
+apply (rule eq_UU_iff)
+apply (rule conjI)
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule noteq_IsinlIsinr)
+apply (drule noteq_IsinlIsinr[OF sym])
+apply simp
+apply (intro strip)
+apply (erule conjE)
+apply simp
+apply (drule inject_Isinr)
+apply simp
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* optimize lemmas about less_ssum                                          *)
+(* ------------------------------------------------------------------------ *)
+
+lemma less_ssum2a: "(Isinl x) << (Isinl y) = (x << y)"
+apply (rule less_ssum1a)
+apply (rule refl)
+apply (rule refl)
+done
+
+lemma less_ssum2b: "(Isinr x) << (Isinr y) = (x << y)"
+apply (rule less_ssum1b)
+apply (rule refl)
+apply (rule refl)
+done
+
+lemma less_ssum2c: "(Isinl x) << (Isinr y) = (x = UU)"
+apply (rule less_ssum1c)
+apply (rule refl)
+apply (rule refl)
+done
+
+lemma less_ssum2d: "(Isinr x) << (Isinl y) = (x = UU)"
+apply (rule less_ssum1d)
+apply (rule refl)
+apply (rule refl)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* less_ssum is a partial order on ++                                     *)
+(* ------------------------------------------------------------------------ *)
+
+lemma refl_less_ssum: "(p::'a++'b) << p"
+apply (rule_tac p = "p" in IssumE2)
+apply (erule ssubst)
+apply (rule less_ssum2a [THEN iffD2])
+apply (rule refl_less)
+apply (erule ssubst)
+apply (rule less_ssum2b [THEN iffD2])
+apply (rule refl_less)
+done
+
+lemma antisym_less_ssum: "[|(p1::'a++'b) << p2; p2 << p1|] ==> p1=p2"
+apply (rule_tac p = "p1" in IssumE2)
+apply simp
+apply (rule_tac p = "p2" in IssumE2)
+apply simp
+apply (rule_tac f = "Isinl" in arg_cong)
+apply (rule antisym_less)
+apply (erule less_ssum2a [THEN iffD1])
+apply (erule less_ssum2a [THEN iffD1])
+apply simp
+apply (erule less_ssum2d [THEN iffD1, THEN ssubst])
+apply (erule less_ssum2c [THEN iffD1, THEN ssubst])
+apply (rule strict_IsinlIsinr)
+apply simp
+apply (rule_tac p = "p2" in IssumE2)
+apply simp
+apply (erule less_ssum2c [THEN iffD1, THEN ssubst])
+apply (erule less_ssum2d [THEN iffD1, THEN ssubst])
+apply (rule strict_IsinlIsinr [symmetric])
+apply simp
+apply (rule_tac f = "Isinr" in arg_cong)
+apply (rule antisym_less)
+apply (erule less_ssum2b [THEN iffD1])
+apply (erule less_ssum2b [THEN iffD1])
+done
+
+lemma trans_less_ssum: "[|(p1::'a++'b) << p2; p2 << p3|] ==> p1 << p3"
+apply (rule_tac p = "p1" in IssumE2)
+apply simp
+apply (rule_tac p = "p3" in IssumE2)
+apply simp
+apply (rule less_ssum2a [THEN iffD2])
+apply (rule_tac p = "p2" in IssumE2)
+apply simp
+apply (rule trans_less)
+apply (erule less_ssum2a [THEN iffD1])
+apply (erule less_ssum2a [THEN iffD1])
+apply simp
+apply (erule less_ssum2c [THEN iffD1, THEN ssubst])
+apply (rule minimal)
+apply simp
+apply (rule less_ssum2c [THEN iffD2])
+apply (rule_tac p = "p2" in IssumE2)
+apply simp
+apply (rule UU_I)
+apply (rule trans_less)
+apply (erule less_ssum2a [THEN iffD1])
+apply (rule antisym_less_inverse [THEN conjunct1])
+apply (erule less_ssum2c [THEN iffD1])
+apply simp
+apply (erule less_ssum2c [THEN iffD1])
+apply simp
+apply (rule_tac p = "p3" in IssumE2)
+apply simp
+apply (rule less_ssum2d [THEN iffD2])
+apply (rule_tac p = "p2" in IssumE2)
+apply simp
+apply (erule less_ssum2d [THEN iffD1])
+apply simp
+apply (rule UU_I)
+apply (rule trans_less)
+apply (erule less_ssum2b [THEN iffD1])
+apply (rule antisym_less_inverse [THEN conjunct1])
+apply (erule less_ssum2d [THEN iffD1])
+apply simp
+apply (rule less_ssum2b [THEN iffD2])
+apply (rule_tac p = "p2" in IssumE2)
+apply simp
+apply (erule less_ssum2d [THEN iffD1, THEN ssubst])
+apply (rule minimal)
+apply simp
+apply (rule trans_less)
+apply (erule less_ssum2b [THEN iffD1])
+apply (erule less_ssum2b [THEN iffD1])
+done
+
+(* Class Instance ++::(pcpo,pcpo)po *)
+
+instance "++"::(pcpo,pcpo)po
+apply (intro_classes)
+apply (rule refl_less_ssum)
+apply (rule antisym_less_ssum, assumption+)
+apply (rule trans_less_ssum, assumption+)
+done
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_ssum_po: "(op <<)=(%s1 s2.@z.
+         (! u x. s1=Isinl u & s2=Isinl x --> z = u << x)
+        &(! v y. s1=Isinr v & s2=Isinr y --> z = v << y)
+        &(! u y. s1=Isinl u & s2=Isinr y --> z = (u = UU))
+        &(! v x. s1=Isinr v & s2=Isinl x --> z = (v = UU)))"
+apply (fold less_ssum_def)
+apply (rule refl)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* access to less_ssum in class po                                          *)
+(* ------------------------------------------------------------------------ *)
+
+lemma less_ssum3a: "Isinl x << Isinl y = x << y"
+apply (simp (no_asm) add: less_ssum2a)
+done
+
+lemma less_ssum3b: "Isinr x << Isinr y = x << y"
+apply (simp (no_asm) add: less_ssum2b)
+done
+
+lemma less_ssum3c: "Isinl x << Isinr y = (x = UU)"
+apply (simp (no_asm) add: less_ssum2c)
+done
+
+lemma less_ssum3d: "Isinr x << Isinl y = (x = UU)"
+apply (simp (no_asm) add: less_ssum2d)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* type ssum ++ is pointed                                                  *)
+(* ------------------------------------------------------------------------ *)
+
+lemma minimal_ssum: "Isinl UU << s"
+apply (rule_tac p = "s" in IssumE2)
+apply simp
+apply (rule less_ssum3a [THEN iffD2])
+apply (rule minimal)
+apply simp
+apply (subst strict_IsinlIsinr)
+apply (rule less_ssum3b [THEN iffD2])
+apply (rule minimal)
+done
+
+lemmas UU_ssum_def = minimal_ssum [THEN minimal2UU, symmetric, standard]
+
+lemma least_ssum: "? x::'a++'b.!y. x<<y"
+apply (rule_tac x = "Isinl UU" in exI)
+apply (rule minimal_ssum [THEN allI])
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Isinl, Isinr are monotone                                                *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_Isinl: "monofun(Isinl)"
+apply (unfold monofun)
+apply (intro strip)
+apply (erule less_ssum3a [THEN iffD2])
+done
+
+lemma monofun_Isinr: "monofun(Isinr)"
+apply (unfold monofun)
+apply (intro strip)
+apply (erule less_ssum3b [THEN iffD2])
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* Iwhen is monotone in all arguments                                       *)
+(* ------------------------------------------------------------------------ *)
+
+
+lemma monofun_Iwhen1: "monofun(Iwhen)"
+apply (unfold monofun)
+apply (intro strip)
+apply (rule less_fun [THEN iffD2])
+apply (intro strip)
+apply (rule less_fun [THEN iffD2])
+apply (intro strip)
+apply (rule_tac p = "xb" in IssumE)
+apply simp
+apply simp
+apply (erule monofun_cfun_fun)
+apply simp
+done
+
+lemma monofun_Iwhen2: "monofun(Iwhen(f))"
+apply (unfold monofun)
+apply (intro strip)
+apply (rule less_fun [THEN iffD2])
+apply (intro strip)
+apply (rule_tac p = "xa" in IssumE)
+apply simp
+apply simp
+apply simp
+apply (erule monofun_cfun_fun)
+done
+
+lemma monofun_Iwhen3: "monofun(Iwhen(f)(g))"
+apply (unfold monofun)
+apply (intro strip)
+apply (rule_tac p = "x" in IssumE)
+apply simp
+apply (rule_tac p = "y" in IssumE)
+apply simp
+apply (rule_tac P = "xa=UU" in notE)
+apply assumption
+apply (rule UU_I)
+apply (rule less_ssum3a [THEN iffD1])
+apply assumption
+apply simp
+apply (rule monofun_cfun_arg)
+apply (erule less_ssum3a [THEN iffD1])
+apply (simp del: Iwhen2)
+apply (rule_tac s = "UU" and t = "xa" in subst)
+apply (erule less_ssum3c [THEN iffD1, symmetric])
+apply simp
+apply (rule_tac p = "y" in IssumE)
+apply simp
+apply (simp only: less_ssum3d)
+apply (simp only: less_ssum3d)
+apply simp
+apply (rule monofun_cfun_arg)
+apply (erule less_ssum3b [THEN iffD1])
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* some kind of exhaustion rules for chains in 'a ++ 'b                     *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ssum_lemma1: "[|~(!i.? x. Y(i::nat)=Isinl(x))|] ==> (? i.! x. Y(i)~=Isinl(x))"
+apply fast
+done
+
+lemma ssum_lemma2: "[|(? i.!x.(Y::nat => 'a++'b)(i::nat)~=Isinl(x::'a))|]   
+      ==> (? i y. (Y::nat => 'a++'b)(i::nat)=Isinr(y::'b) & y~=UU)"
+apply (erule exE)
+apply (rule_tac p = "Y (i) " in IssumE)
+apply (drule spec)
+apply (erule notE, assumption)
+apply (drule spec)
+apply (erule notE, assumption)
+apply fast
+done
+
+
+lemma ssum_lemma3: "[|chain(Y);(? i x. Y(i)=Isinr(x::'b) & (x::'b)~=UU)|]  
+      ==> (!i.? y. Y(i)=Isinr(y))"
+apply (erule exE)
+apply (erule exE)
+apply (rule allI)
+apply (rule_tac p = "Y (ia) " in IssumE)
+apply (rule exI)
+apply (rule trans)
+apply (rule_tac [2] strict_IsinlIsinr)
+apply assumption
+apply (erule_tac [2] exI)
+apply (erule conjE)
+apply (rule_tac m = "i" and n = "ia" in nat_less_cases)
+prefer 2 apply simp
+apply (rule exI, rule refl)
+apply (erule_tac P = "x=UU" in notE)
+apply (rule less_ssum3d [THEN iffD1])
+apply (erule_tac s = "Y (i) " and t = "Isinr (x) ::'a++'b" in subst)
+apply (erule_tac s = "Y (ia) " and t = "Isinl (xa) ::'a++'b" in subst)
+apply (erule chain_mono)
+apply assumption
+apply (erule_tac P = "xa=UU" in notE)
+apply (rule less_ssum3c [THEN iffD1])
+apply (erule_tac s = "Y (i) " and t = "Isinr (x) ::'a++'b" in subst)
+apply (erule_tac s = "Y (ia) " and t = "Isinl (xa) ::'a++'b" in subst)
+apply (erule chain_mono)
+apply assumption
+done
+
+lemma ssum_lemma4: "chain(Y) ==> (!i.? x. Y(i)=Isinl(x))|(!i.? y. Y(i)=Isinr(y))"
+apply (rule case_split_thm)
+apply (erule disjI1)
+apply (rule disjI2)
+apply (erule ssum_lemma3)
+apply (rule ssum_lemma2)
+apply (erule ssum_lemma1)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* restricted surjectivity of Isinl                                         *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ssum_lemma5: "z=Isinl(x)==> Isinl((Iwhen (LAM x. x) (LAM y. UU))(z)) = z"
+apply simp
+apply (case_tac "x=UU")
+apply simp
+apply simp
+done
+
+(* ------------------------------------------------------------------------ *)
+(* restricted surjectivity of Isinr                                         *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ssum_lemma6: "z=Isinr(x)==> Isinr((Iwhen (LAM y. UU) (LAM x. x))(z)) = z"
+apply simp
+apply (case_tac "x=UU")
+apply simp
+apply simp
+done
+
+(* ------------------------------------------------------------------------ *)
+(* technical lemmas                                                         *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ssum_lemma7: "[|Isinl(x) << z; x~=UU|] ==> ? y. z=Isinl(y) & y~=UU"
+apply (rule_tac p = "z" in IssumE)
+apply simp
+apply (erule notE)
+apply (rule antisym_less)
+apply (erule less_ssum3a [THEN iffD1])
+apply (rule minimal)
+apply fast
+apply simp
+apply (rule notE)
+apply (erule_tac [2] less_ssum3c [THEN iffD1])
+apply assumption
+done
+
+lemma ssum_lemma8: "[|Isinr(x) << z; x~=UU|] ==> ? y. z=Isinr(y) & y~=UU"
+apply (rule_tac p = "z" in IssumE)
+apply simp
+apply (erule notE)
+apply (erule less_ssum3d [THEN iffD1])
+apply simp
+apply (rule notE)
+apply (erule_tac [2] less_ssum3d [THEN iffD1])
+apply assumption
+apply fast
+done
+
+(* ------------------------------------------------------------------------ *)
+(* the type 'a ++ 'b is a cpo in three steps                                *)
+(* ------------------------------------------------------------------------ *)
+
+lemma lub_ssum1a: "[|chain(Y);(!i.? x. Y(i)=Isinl(x))|] ==> 
+      range(Y) <<| Isinl(lub(range(%i.(Iwhen (LAM x. x) (LAM y. UU))(Y i))))"
+apply (rule is_lubI)
+apply (rule ub_rangeI)
+apply (erule allE)
+apply (erule exE)
+apply (rule_tac t = "Y (i) " in ssum_lemma5 [THEN subst])
+apply assumption
+apply (rule monofun_Isinl [THEN monofunE, THEN spec, THEN spec, THEN mp])
+apply (rule is_ub_thelub)
+apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply (rule_tac p = "u" in IssumE2)
+apply (rule_tac t = "u" in ssum_lemma5 [THEN subst])
+apply assumption
+apply (rule monofun_Isinl [THEN monofunE, THEN spec, THEN spec, THEN mp])
+apply (rule is_lub_thelub)
+apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply (erule monofun_Iwhen3 [THEN ub2ub_monofun])
+apply simp
+apply (rule less_ssum3c [THEN iffD2])
+apply (rule chain_UU_I_inverse)
+apply (rule allI)
+apply (rule_tac p = "Y (i) " in IssumE)
+apply simp
+apply simp
+apply (erule notE)
+apply (rule less_ssum3c [THEN iffD1])
+apply (rule_tac t = "Isinl (x) " in subst)
+apply assumption
+apply (erule ub_rangeD)
+apply simp
+done
+
+
+lemma lub_ssum1b: "[|chain(Y);(!i.? x. Y(i)=Isinr(x))|] ==> 
+      range(Y) <<| Isinr(lub(range(%i.(Iwhen (LAM y. UU) (LAM x. x))(Y i))))"
+apply (rule is_lubI)
+apply (rule ub_rangeI)
+apply (erule allE)
+apply (erule exE)
+apply (rule_tac t = "Y (i) " in ssum_lemma6 [THEN subst])
+apply assumption
+apply (rule monofun_Isinr [THEN monofunE, THEN spec, THEN spec, THEN mp])
+apply (rule is_ub_thelub)
+apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply (rule_tac p = "u" in IssumE2)
+apply simp
+apply (rule less_ssum3d [THEN iffD2])
+apply (rule chain_UU_I_inverse)
+apply (rule allI)
+apply (rule_tac p = "Y (i) " in IssumE)
+apply simp
+apply simp
+apply (erule notE)
+apply (rule less_ssum3d [THEN iffD1])
+apply (rule_tac t = "Isinr (y) " in subst)
+apply assumption
+apply (erule ub_rangeD)
+apply (rule_tac t = "u" in ssum_lemma6 [THEN subst])
+apply assumption
+apply (rule monofun_Isinr [THEN monofunE, THEN spec, THEN spec, THEN mp])
+apply (rule is_lub_thelub)
+apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply (erule monofun_Iwhen3 [THEN ub2ub_monofun])
+done
+
+
+lemmas thelub_ssum1a = lub_ssum1a [THEN thelubI, standard]
+(*
+[| chain ?Y1; ! i. ? x. ?Y1 i = Isinl x |] ==>
+ lub (range ?Y1) = Isinl
+ (lub (range (%i. Iwhen (LAM x. x) (LAM y. UU) (?Y1 i))))
+*)
+
+lemmas thelub_ssum1b = lub_ssum1b [THEN thelubI, standard]
+(*
+[| chain ?Y1; ! i. ? x. ?Y1 i = Isinr x |] ==>
+ lub (range ?Y1) = Isinr
+ (lub (range (%i. Iwhen (LAM y. UU) (LAM x. x) (?Y1 i))))
+*)
+
+lemma cpo_ssum: "chain(Y::nat=>'a ++'b) ==> ? x. range(Y) <<|x"
+apply (rule ssum_lemma4 [THEN disjE])
+apply assumption
+apply (rule exI)
+apply (erule lub_ssum1a)
+apply assumption
+apply (rule exI)
+apply (erule lub_ssum1b)
+apply assumption
+done
+
+(* Class instance of  ++ for class pcpo *)
+
+instance "++" :: (pcpo,pcpo)pcpo
+apply (intro_classes)
+apply (erule cpo_ssum)
+apply (rule least_ssum)
+done
+
+consts  
+        sinl    :: "'a -> ('a++'b)" 
+        sinr    :: "'b -> ('a++'b)" 
+        sscase  :: "('a->'c)->('b->'c)->('a ++ 'b)-> 'c"
+
+defs
+
+sinl_def:        "sinl   == (LAM x. Isinl(x))"
+sinr_def:        "sinr   == (LAM x. Isinr(x))"
+sscase_def:      "sscase   == (LAM f g s. Iwhen(f)(g)(s))"
+
+translations
+"case s of sinl$x => t1 | sinr$y => t2" == "sscase$(LAM x. t1)$(LAM y. t2)$s"
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_ssum_pcpo: "UU = Isinl UU"
+apply (simp add: UU_def UU_ssum_def)
+done
+
+declare inst_ssum_pcpo [symmetric, simp]
+
+(* ------------------------------------------------------------------------ *)
+(* continuity for Isinl and Isinr                                           *)
+(* ------------------------------------------------------------------------ *)
+
+lemma contlub_Isinl: "contlub(Isinl)"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule trans)
+apply (rule_tac [2] thelub_ssum1a [symmetric])
+apply (rule_tac [3] allI)
+apply (rule_tac [3] exI)
+apply (rule_tac [3] refl)
+apply (erule_tac [2] monofun_Isinl [THEN ch2ch_monofun])
+apply (case_tac "lub (range (Y))=UU")
+apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
+apply assumption
+apply (rule_tac f = "Isinl" in arg_cong)
+apply (rule chain_UU_I_inverse [symmetric])
+apply (rule allI)
+apply (rule_tac s = "UU" and t = "Y (i) " in ssubst)
+apply (erule chain_UU_I [THEN spec])
+apply assumption
+apply (rule Iwhen1)
+apply (rule_tac f = "Isinl" in arg_cong)
+apply (rule lub_equal)
+apply assumption
+apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply (erule monofun_Isinl [THEN ch2ch_monofun])
+apply (rule allI)
+apply (case_tac "Y (k) =UU")
+apply (erule ssubst)
+apply (rule Iwhen1[symmetric])
+apply simp
+done
+
+lemma contlub_Isinr: "contlub(Isinr)"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule trans)
+apply (rule_tac [2] thelub_ssum1b [symmetric])
+apply (rule_tac [3] allI)
+apply (rule_tac [3] exI)
+apply (rule_tac [3] refl)
+apply (erule_tac [2] monofun_Isinr [THEN ch2ch_monofun])
+apply (case_tac "lub (range (Y))=UU")
+apply (rule_tac s = "UU" and t = "lub (range (Y))" in ssubst)
+apply assumption
+apply (rule arg_cong, rule chain_UU_I_inverse [symmetric])
+apply (rule allI)
+apply (rule_tac s = "UU" and t = "Y (i) " in ssubst)
+apply (erule chain_UU_I [THEN spec])
+apply assumption
+apply (rule strict_IsinlIsinr [THEN subst])
+apply (rule Iwhen1)
+apply (rule arg_cong, rule lub_equal)
+apply assumption
+apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply (erule monofun_Isinr [THEN ch2ch_monofun])
+apply (rule allI)
+apply (case_tac "Y (k) =UU")
+apply (simp only: Ssum0_ss)
+apply simp
+done
+
+lemma cont_Isinl: "cont(Isinl)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Isinl)
+apply (rule contlub_Isinl)
+done
+
+lemma cont_Isinr: "cont(Isinr)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Isinr)
+apply (rule contlub_Isinr)
+done
+
+declare cont_Isinl [iff] cont_Isinr [iff]
+
+
+(* ------------------------------------------------------------------------ *)
+(* continuity for Iwhen in the firts two arguments                          *)
+(* ------------------------------------------------------------------------ *)
+
+lemma contlub_Iwhen1: "contlub(Iwhen)"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule trans)
+apply (rule_tac [2] thelub_fun [symmetric])
+apply (erule_tac [2] monofun_Iwhen1 [THEN ch2ch_monofun])
+apply (rule expand_fun_eq [THEN iffD2])
+apply (intro strip)
+apply (rule trans)
+apply (rule_tac [2] thelub_fun [symmetric])
+apply (rule_tac [2] ch2ch_fun)
+apply (erule_tac [2] monofun_Iwhen1 [THEN ch2ch_monofun])
+apply (rule expand_fun_eq [THEN iffD2])
+apply (intro strip)
+apply (rule_tac p = "xa" in IssumE)
+apply (simp only: Ssum0_ss)
+apply (rule lub_const [THEN thelubI, symmetric])
+apply simp
+apply (erule contlub_cfun_fun)
+apply simp
+apply (rule lub_const [THEN thelubI, symmetric])
+done
+
+lemma contlub_Iwhen2: "contlub(Iwhen(f))"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule trans)
+apply (rule_tac [2] thelub_fun [symmetric])
+apply (erule_tac [2] monofun_Iwhen2 [THEN ch2ch_monofun])
+apply (rule expand_fun_eq [THEN iffD2])
+apply (intro strip)
+apply (rule_tac p = "x" in IssumE)
+apply (simp only: Ssum0_ss)
+apply (rule lub_const [THEN thelubI, symmetric])
+apply simp
+apply (rule lub_const [THEN thelubI, symmetric])
+apply simp
+apply (erule contlub_cfun_fun)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* continuity for Iwhen in its third argument                               *)
+(* ------------------------------------------------------------------------ *)
+
+(* ------------------------------------------------------------------------ *)
+(* first 5 ugly lemmas                                                      *)
+(* ------------------------------------------------------------------------ *)
+
+lemma ssum_lemma9: "[| chain(Y); lub(range(Y)) = Isinl(x)|] ==> !i.? x. Y(i)=Isinl(x)"
+apply (intro strip)
+apply (rule_tac p = "Y (i) " in IssumE)
+apply (erule exI)
+apply (erule exI)
+apply (rule_tac P = "y=UU" in notE)
+apply assumption
+apply (rule less_ssum3d [THEN iffD1])
+apply (erule subst)
+apply (erule subst)
+apply (erule is_ub_thelub)
+done
+
+
+lemma ssum_lemma10: "[| chain(Y); lub(range(Y)) = Isinr(x)|] ==> !i.? x. Y(i)=Isinr(x)"
+apply (intro strip)
+apply (rule_tac p = "Y (i) " in IssumE)
+apply (rule exI)
+apply (erule trans)
+apply (rule strict_IsinlIsinr)
+apply (erule_tac [2] exI)
+apply (rule_tac P = "xa=UU" in notE)
+apply assumption
+apply (rule less_ssum3c [THEN iffD1])
+apply (erule subst)
+apply (erule subst)
+apply (erule is_ub_thelub)
+done
+
+lemma ssum_lemma11: "[| chain(Y); lub(range(Y)) = Isinl(UU) |] ==> 
+    Iwhen f g (lub(range Y)) = lub(range(%i. Iwhen f g (Y i)))"
+apply (simp only: Ssum0_ss)
+apply (rule chain_UU_I_inverse [symmetric])
+apply (rule allI)
+apply (rule_tac s = "Isinl (UU) " and t = "Y (i) " in subst)
+apply (rule inst_ssum_pcpo [THEN subst])
+apply (rule chain_UU_I [THEN spec, symmetric])
+apply assumption
+apply (erule inst_ssum_pcpo [THEN ssubst])
+apply (simp only: Ssum0_ss)
+done
+
+lemma ssum_lemma12: "[| chain(Y); lub(range(Y)) = Isinl(x); x ~= UU |] ==> 
+    Iwhen f g (lub(range Y)) = lub(range(%i. Iwhen f g (Y i)))"
+apply simp
+apply (rule_tac t = "x" in subst)
+apply (rule inject_Isinl)
+apply (rule trans)
+prefer 2 apply (assumption)
+apply (rule thelub_ssum1a [symmetric])
+apply assumption
+apply (erule ssum_lemma9)
+apply assumption
+apply (rule trans)
+apply (rule contlub_cfun_arg)
+apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply assumption
+apply (rule lub_equal2)
+apply (rule chain_mono2 [THEN exE])
+prefer 2 apply (assumption)
+apply (rule chain_UU_I_inverse2)
+apply (subst inst_ssum_pcpo)
+apply (erule contrapos_np)
+apply (rule inject_Isinl)
+apply (rule trans)
+apply (erule sym)
+apply (erule notnotD)
+apply (rule exI)
+apply (intro strip)
+apply (rule ssum_lemma9 [THEN spec, THEN exE])
+apply assumption
+apply assumption
+apply (rule_tac t = "Y (i) " in ssubst)
+apply assumption
+apply (rule trans)
+apply (rule cfun_arg_cong)
+apply (rule Iwhen2)
+apply force
+apply (rule_tac t = "Y (i) " in ssubst)
+apply assumption
+apply auto
+apply (subst Iwhen2)
+apply force
+apply (rule refl)
+apply (rule monofun_Rep_CFun2 [THEN ch2ch_monofun])
+apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
+done
+
+
+lemma ssum_lemma13: "[| chain(Y); lub(range(Y)) = Isinr(x); x ~= UU |] ==> 
+    Iwhen f g (lub(range Y)) = lub(range(%i. Iwhen f g (Y i)))"
+apply simp
+apply (rule_tac t = "x" in subst)
+apply (rule inject_Isinr)
+apply (rule trans)
+prefer 2 apply (assumption)
+apply (rule thelub_ssum1b [symmetric])
+apply assumption
+apply (erule ssum_lemma10)
+apply assumption
+apply (rule trans)
+apply (rule contlub_cfun_arg)
+apply (rule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply assumption
+apply (rule lub_equal2)
+apply (rule chain_mono2 [THEN exE])
+prefer 2 apply (assumption)
+apply (rule chain_UU_I_inverse2)
+apply (subst inst_ssum_pcpo)
+apply (erule contrapos_np)
+apply (rule inject_Isinr)
+apply (rule trans)
+apply (erule sym)
+apply (rule strict_IsinlIsinr [THEN subst])
+apply (erule notnotD)
+apply (rule exI)
+apply (intro strip)
+apply (rule ssum_lemma10 [THEN spec, THEN exE])
+apply assumption
+apply assumption
+apply (rule_tac t = "Y (i) " in ssubst)
+apply assumption
+apply (rule trans)
+apply (rule cfun_arg_cong)
+apply (rule Iwhen3)
+apply force
+apply (rule_tac t = "Y (i) " in ssubst)
+apply assumption
+apply (subst Iwhen3)
+apply force
+apply (rule_tac t = "Y (i) " in ssubst)
+apply assumption
+apply simp
+apply (rule monofun_Rep_CFun2 [THEN ch2ch_monofun])
+apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
+apply (erule monofun_Iwhen3 [THEN ch2ch_monofun])
+done
+
+
+lemma contlub_Iwhen3: "contlub(Iwhen(f)(g))"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule_tac p = "lub (range (Y))" in IssumE)
+apply (erule ssum_lemma11)
+apply assumption
+apply (erule ssum_lemma12)
+apply assumption
+apply assumption
+apply (erule ssum_lemma13)
+apply assumption
+apply assumption
+done
+
+lemma cont_Iwhen1: "cont(Iwhen)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Iwhen1)
+apply (rule contlub_Iwhen1)
+done
+
+lemma cont_Iwhen2: "cont(Iwhen(f))"
+apply (rule monocontlub2cont)
+apply (rule monofun_Iwhen2)
+apply (rule contlub_Iwhen2)
+done
+
+lemma cont_Iwhen3: "cont(Iwhen(f)(g))"
+apply (rule monocontlub2cont)
+apply (rule monofun_Iwhen3)
+apply (rule contlub_Iwhen3)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* continuous versions of lemmas for 'a ++ 'b                               *)
+(* ------------------------------------------------------------------------ *)
+
+lemma strict_sinl [simp]: "sinl$UU =UU"
+apply (unfold sinl_def)
+apply (simp add: cont_Isinl)
+done
+
+lemma strict_sinr [simp]: "sinr$UU=UU"
+apply (unfold sinr_def)
+apply (simp add: cont_Isinr)
+done
+
+lemma noteq_sinlsinr: 
+        "sinl$a=sinr$b ==> a=UU & b=UU"
+apply (unfold sinl_def sinr_def)
+apply (auto dest!: noteq_IsinlIsinr)
+done
+
+lemma inject_sinl: 
+        "sinl$a1=sinl$a2==> a1=a2"
+apply (unfold sinl_def sinr_def)
+apply auto
+done
+
+lemma inject_sinr: 
+        "sinr$a1=sinr$a2==> a1=a2"
+apply (unfold sinl_def sinr_def)
+apply auto
+done
+
+declare inject_sinl [dest!] inject_sinr [dest!]
+
+lemma defined_sinl [simp]: "x~=UU ==> sinl$x ~= UU"
+apply (erule contrapos_nn)
+apply (rule inject_sinl)
+apply auto
+done
+
+lemma defined_sinr [simp]: "x~=UU ==> sinr$x ~= UU"
+apply (erule contrapos_nn)
+apply (rule inject_sinr)
+apply auto
+done
+
+lemma Exh_Ssum1: 
+        "z=UU | (? a. z=sinl$a & a~=UU) | (? b. z=sinr$b & b~=UU)"
+apply (unfold sinl_def sinr_def)
+apply simp
+apply (subst inst_ssum_pcpo)
+apply (rule Exh_Ssum)
+done
+
+
+lemma ssumE:
+assumes major: "p=UU ==> Q"
+assumes prem2: "!!x.[|p=sinl$x; x~=UU |] ==> Q"
+assumes prem3: "!!y.[|p=sinr$y; y~=UU |] ==> Q"
+shows "Q"
+apply (rule major [THEN IssumE])
+apply (subst inst_ssum_pcpo)
+apply assumption
+apply (rule prem2)
+prefer 2 apply (assumption)
+apply (simp add: sinl_def)
+apply (rule prem3)
+prefer 2 apply (assumption)
+apply (simp add: sinr_def)
+done
+
+
+lemma ssumE2:
+assumes preml: "!!x.[|p=sinl$x|] ==> Q"
+assumes premr: "!!y.[|p=sinr$y|] ==> Q"
+shows "Q"
+apply (rule IssumE2)
+apply (rule preml)
+apply (rule_tac [2] premr)
+apply (unfold sinl_def sinr_def)
+apply auto
+done
+
+lemmas ssum_conts = cont_lemmas1 cont_Iwhen1 cont_Iwhen2
+                cont_Iwhen3 cont2cont_CF1L
+
+lemma sscase1 [simp]: 
+        "sscase$f$g$UU = UU"
+apply (unfold sscase_def sinl_def sinr_def)
+apply (subst inst_ssum_pcpo)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (simp only: Ssum0_ss)
+done
+
+lemma sscase2 [simp]: 
+        "x~=UU==> sscase$f$g$(sinl$x) = f$x"
+apply (unfold sscase_def sinl_def sinr_def)
+apply (simplesubst beta_cfun)
+apply (rule cont_Isinl)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply simp
+done
+
+lemma sscase3 [simp]: 
+        "x~=UU==> sscase$f$g$(sinr$x) = g$x"
+apply (unfold sscase_def sinl_def sinr_def)
+apply (simplesubst beta_cfun)
+apply (rule cont_Isinr)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply simp
+done
+
+lemma less_ssum4a: 
+        "(sinl$x << sinl$y) = (x << y)"
+apply (unfold sinl_def sinr_def)
+apply (subst beta_cfun)
+apply (rule cont_Isinl)
+apply (subst beta_cfun)
+apply (rule cont_Isinl)
+apply (rule less_ssum3a)
+done
+
+lemma less_ssum4b: 
+        "(sinr$x << sinr$y) = (x << y)"
+apply (unfold sinl_def sinr_def)
+apply (subst beta_cfun)
+apply (rule cont_Isinr)
+apply (subst beta_cfun)
+apply (rule cont_Isinr)
+apply (rule less_ssum3b)
+done
+
+lemma less_ssum4c: 
+        "(sinl$x << sinr$y) = (x = UU)"
+apply (unfold sinl_def sinr_def)
+apply (simplesubst beta_cfun)
+apply (rule cont_Isinr)
+apply (subst beta_cfun)
+apply (rule cont_Isinl)
+apply (rule less_ssum3c)
+done
+
+lemma less_ssum4d: 
+        "(sinr$x << sinl$y) = (x = UU)"
+apply (unfold sinl_def sinr_def)
+apply (simplesubst beta_cfun)
+apply (rule cont_Isinl)
+apply (subst beta_cfun)
+apply (rule cont_Isinr)
+apply (rule less_ssum3d)
+done
+
+lemma ssum_chainE: 
+        "chain(Y) ==> (!i.? x.(Y i)=sinl$x)|(!i.? y.(Y i)=sinr$y)"
+apply (unfold sinl_def sinr_def)
+apply simp
+apply (erule ssum_lemma4)
+done
+
+lemma thelub_ssum2a: 
+"[| chain(Y); !i.? x. Y(i) = sinl$x |] ==>  
+    lub(range(Y)) = sinl$(lub(range(%i. sscase$(LAM x. x)$(LAM y. UU)$(Y i))))"
+apply (unfold sinl_def sinr_def sscase_def)
+apply (subst beta_cfun)
+apply (rule cont_Isinl)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun [THEN ext])
+apply (intro ssum_conts)
+apply (rule thelub_ssum1a)
+apply assumption
+apply (rule allI)
+apply (erule allE)
+apply (erule exE)
+apply (rule exI)
+apply (erule box_equals)
+apply (rule refl)
+apply simp
+done
+
+lemma thelub_ssum2b: 
+"[| chain(Y); !i.? x. Y(i) = sinr$x |] ==>  
+    lub(range(Y)) = sinr$(lub(range(%i. sscase$(LAM y. UU)$(LAM x. x)$(Y i))))"
+apply (unfold sinl_def sinr_def sscase_def)
+apply (subst beta_cfun)
+apply (rule cont_Isinr)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun)
+apply (intro ssum_conts)
+apply (subst beta_cfun [THEN ext])
+apply (intro ssum_conts)
+apply (rule thelub_ssum1b)
+apply assumption
+apply (rule allI)
+apply (erule allE)
+apply (erule exE)
+apply (rule exI)
+apply (erule box_equals)
+apply (rule refl)
+apply simp
+done
+
+lemma thelub_ssum2a_rev: 
+        "[| chain(Y); lub(range(Y)) = sinl$x|] ==> !i.? x. Y(i)=sinl$x"
+apply (unfold sinl_def sinr_def)
+apply simp
+apply (erule ssum_lemma9)
+apply simp
+done
+
+lemma thelub_ssum2b_rev: 
+     "[| chain(Y); lub(range(Y)) = sinr$x|] ==> !i.? x. Y(i)=sinr$x"
+apply (unfold sinl_def sinr_def)
+apply simp
+apply (erule ssum_lemma10)
+apply simp
+done
+
+lemma thelub_ssum3: "chain(Y) ==>  
+    lub(range(Y)) = sinl$(lub(range(%i. sscase$(LAM x. x)$(LAM y. UU)$(Y i)))) 
+  | lub(range(Y)) = sinr$(lub(range(%i. sscase$(LAM y. UU)$(LAM x. x)$(Y i))))"
+apply (rule ssum_chainE [THEN disjE])
+apply assumption
+apply (rule disjI1)
+apply (erule thelub_ssum2a)
+apply assumption
+apply (rule disjI2)
+apply (erule thelub_ssum2b)
+apply assumption
+done
+
+lemma sscase4: "sscase$sinl$sinr$z=z"
+apply (rule_tac p = "z" in ssumE)
+apply auto
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* install simplifier for Ssum                                              *)
+(* ------------------------------------------------------------------------ *)
+
+lemmas Ssum_rews = strict_sinl strict_sinr defined_sinl defined_sinr
+                sscase1 sscase2 sscase3
+
+end
--- a/src/HOLCF/Ssum0.ML	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,29 +0,0 @@
-
-(* legacy ML bindings *)
-
-val Isinl_def = thm "Isinl_def";
-val Isinr_def = thm "Isinr_def";
-val Iwhen_def = thm "Iwhen_def";
-val SsumIl = thm "SsumIl";
-val SsumIr = thm "SsumIr";
-val inj_on_Abs_Ssum = thm "inj_on_Abs_Ssum";
-val strict_SinlSinr_Rep = thm "strict_SinlSinr_Rep";
-val strict_IsinlIsinr = thm "strict_IsinlIsinr";
-val noteq_SinlSinr_Rep = thm "noteq_SinlSinr_Rep";
-val noteq_IsinlIsinr = thm "noteq_IsinlIsinr";
-val inject_Sinl_Rep1 = thm "inject_Sinl_Rep1";
-val inject_Sinr_Rep1 = thm "inject_Sinr_Rep1";
-val inject_Sinl_Rep2 = thm "inject_Sinl_Rep2";
-val inject_Sinr_Rep2 = thm "inject_Sinr_Rep2";
-val inject_Sinl_Rep = thm "inject_Sinl_Rep";
-val inject_Sinr_Rep = thm "inject_Sinr_Rep";
-val inject_Isinl = thm "inject_Isinl";
-val inject_Isinr = thm "inject_Isinr";
-val inject_Isinl_rev = thm "inject_Isinl_rev";
-val inject_Isinr_rev = thm "inject_Isinr_rev";
-val Exh_Ssum = thm "Exh_Ssum";
-val IssumE = thm "IssumE";
-val IssumE2 = thm "IssumE2";
-val Iwhen1 = thm "Iwhen1";
-val Iwhen2 = thm "Iwhen2";
-val Iwhen3 = thm "Iwhen3";
--- a/src/HOLCF/Ssum0.thy	Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,344 +0,0 @@
-(*  Title:      HOLCF/Ssum0.thy
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Strict sum with typedef
-*)
-
-theory Ssum0 = Cfun3:
-
-constdefs
-  Sinl_Rep      :: "['a,'a,'b,bool]=>bool"
- "Sinl_Rep == (%a.%x y p. (a~=UU --> x=a & p))"
-  Sinr_Rep      :: "['b,'a,'b,bool]=>bool"
- "Sinr_Rep == (%b.%x y p.(b~=UU --> y=b & ~p))"
-
-typedef (Ssum)  ('a, 'b) "++" (infixr 10) = 
-	"{f.(? a. f=Sinl_Rep(a::'a))|(? b. f=Sinr_Rep(b::'b))}"
-by auto
-
-syntax (xsymbols)
-  "++"		:: "[type, type] => type"	("(_ \<oplus>/ _)" [21, 20] 20)
-syntax (HTML output)
-  "++"		:: "[type, type] => type"	("(_ \<oplus>/ _)" [21, 20] 20)
-
-consts
-  Isinl         :: "'a => ('a ++ 'b)"
-  Isinr         :: "'b => ('a ++ 'b)"
-  Iwhen         :: "('a->'c)=>('b->'c)=>('a ++ 'b)=> 'c"
-
-defs   (*defining the abstract constants*)
-  Isinl_def:     "Isinl(a) == Abs_Ssum(Sinl_Rep(a))"
-  Isinr_def:     "Isinr(b) == Abs_Ssum(Sinr_Rep(b))"
-
-  Iwhen_def:     "Iwhen(f)(g)(s) == @z.
-                                    (s=Isinl(UU) --> z=UU)
-                        &(!a. a~=UU & s=Isinl(a) --> z=f$a)  
-                        &(!b. b~=UU & s=Isinr(b) --> z=g$b)"  
-
-(*  Title:      HOLCF/Ssum0.ML
-    ID:         $Id$
-    Author:     Franz Regensburger
-    License:    GPL (GNU GENERAL PUBLIC LICENSE)
-
-Strict sum with typedef
-*)
-
-(* ------------------------------------------------------------------------ *)
-(* A non-emptyness result for Sssum                                         *)
-(* ------------------------------------------------------------------------ *)
-
-lemma SsumIl: "Sinl_Rep(a):Ssum"
-apply (unfold Ssum_def)
-apply blast
-done
-
-lemma SsumIr: "Sinr_Rep(a):Ssum"
-apply (unfold Ssum_def)
-apply blast
-done
-
-lemma inj_on_Abs_Ssum: "inj_on Abs_Ssum Ssum"
-apply (rule inj_on_inverseI)
-apply (erule Abs_Ssum_inverse)
-done
-
-(* ------------------------------------------------------------------------ *)
-(* Strictness of Sinr_Rep, Sinl_Rep and Isinl, Isinr                        *)
-(* ------------------------------------------------------------------------ *)
-
-lemma strict_SinlSinr_Rep: 
- "Sinl_Rep(UU) = Sinr_Rep(UU)"
-
-apply (unfold Sinr_Rep_def Sinl_Rep_def)
-apply (rule ext)
-apply (rule ext)
-apply (rule ext)
-apply fast
-done
-
-lemma strict_IsinlIsinr: 
- "Isinl(UU) = Isinr(UU)"
-apply (unfold Isinl_def Isinr_def)
-apply (rule strict_SinlSinr_Rep [THEN arg_cong])
-done
-
-
-(* ------------------------------------------------------------------------ *)
-(* distinctness of  Sinl_Rep, Sinr_Rep and Isinl, Isinr                     *)
-(* ------------------------------------------------------------------------ *)
-
-lemma noteq_SinlSinr_Rep: 
-        "(Sinl_Rep(a) = Sinr_Rep(b)) ==> a=UU & b=UU"
-
-apply (unfold Sinl_Rep_def Sinr_Rep_def)
-apply (blast dest!: fun_cong)
-done
-
-
-lemma noteq_IsinlIsinr: 
-        "Isinl(a)=Isinr(b) ==> a=UU & b=UU"
-
-apply (unfold Isinl_def Isinr_def)
-apply (rule noteq_SinlSinr_Rep)
-apply (erule inj_on_Abs_Ssum [THEN inj_onD])
-apply (rule SsumIl)
-apply (rule SsumIr)
-done
-
-
-
-(* ------------------------------------------------------------------------ *)
-(* injectivity of Sinl_Rep, Sinr_Rep and Isinl, Isinr                       *)
-(* ------------------------------------------------------------------------ *)
-
-lemma inject_Sinl_Rep1: "(Sinl_Rep(a) = Sinl_Rep(UU)) ==> a=UU"
-apply (unfold Sinl_Rep_def)
-apply (blast dest!: fun_cong)
-done
-
-lemma inject_Sinr_Rep1: "(Sinr_Rep(b) = Sinr_Rep(UU)) ==> b=UU"
-apply (unfold Sinr_Rep_def)
-apply (blast dest!: fun_cong)
-done
-
-lemma inject_Sinl_Rep2: 
-"[| a1~=UU ; a2~=UU ; Sinl_Rep(a1)=Sinl_Rep(a2) |] ==> a1=a2"
-apply (unfold Sinl_Rep_def)
-apply (blast dest!: fun_cong)
-done
-
-lemma inject_Sinr_Rep2: 
-"[|b1~=UU ; b2~=UU ; Sinr_Rep(b1)=Sinr_Rep(b2) |] ==> b1=b2"