--- /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"
-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]
-
-end
--- a/src/HOLCF/Ssum1.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 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";
--- a/src/HOLCF/Ssum1.thy Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,314 +0,0 @@
-(* Title: HOLCF/Ssum1.thy
- ID: $Id$
- Author: Franz Regensburger
- License: GPL (GNU GENERAL PUBLIC LICENSE)
-
-Partial ordering for the strict sum ++
-*)
-
-theory Ssum1 = Ssum0:
-
-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)))"
-
-(* Title: HOLCF/Ssum1.ML
- ID: $Id$
- Author: Franz Regensburger
- License: GPL (GNU GENERAL PUBLIC LICENSE)
-
-Partial ordering for the strict sum ++
-*)
-
-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
-
-end
-
-
--- a/src/HOLCF/Ssum2.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 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";
--- a/src/HOLCF/Ssum2.thy Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,368 +0,0 @@
-(* Title: HOLCF/ssum2.thy
- ID: $Id$
- Author: Franz Regensburger
- License: GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class Instance ++::(pcpo,pcpo)po
-*)
-
-theory Ssum2 = Ssum1:
-
-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
-
-(* Title: HOLCF/Ssum2.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_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
-
-end
-
-
-
--- a/src/HOLCF/Ssum3.ML Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,48 +0,0 @@
-
-(* legacy ML bindings *)
-
-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]
--- a/src/HOLCF/Ssum3.thy Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,624 +0,0 @@
-(* Title: HOLCF/ssum3.thy
- ID: $Id$
- Author: Franz Regensburger
- License: GPL (GNU GENERAL PUBLIC LICENSE)
-
-Class instance of ++ for class pcpo
-*)
-
-theory Ssum3 = Ssum2:
-
-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"
-
-(* Title: HOLCF/Ssum3.ML
- 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_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: "sinl$UU =UU"
-
-apply (unfold sinl_def)
-apply (simp add: cont_Isinl)
-done
-declare strict_sinl [simp]
-
-lemma strict_sinr: "sinr$UU=UU"
-apply (unfold sinr_def)
-apply (simp add: cont_Isinr)
-done
-declare strict_sinr [simp]
-
-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: "x~=UU ==> sinl$x ~= UU"
-apply (erule contrapos_nn)
-apply (rule inject_sinl)
-apply auto
-done
-declare defined_sinl [simp]
-
-lemma defined_sinr: "x~=UU ==> sinr$x ~= UU"
-apply (erule contrapos_nn)
-apply (rule inject_sinr)
-apply auto
-done
-declare defined_sinr [simp]
-
-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:
- "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
-declare sscase1 [simp]
-
-
-lemma sscase2:
- "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
-declare sscase2 [simp]
-
-lemma sscase3:
- "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
-declare sscase3 [simp]
-
-
-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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Up.ML Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,62 @@
+
+(* legacy ML bindings *)
+
+val Iup_def = thm "Iup_def";
+val Ifup_def = thm "Ifup_def";
+val less_up_def = thm "less_up_def";
+val Abs_Up_inverse2 = thm "Abs_Up_inverse2";
+val Exh_Up = thm "Exh_Up";
+val inj_Abs_Up = thm "inj_Abs_Up";
+val inj_Rep_Up = thm "inj_Rep_Up";
+val inject_Iup = thm "inject_Iup";
+val defined_Iup = thm "defined_Iup";
+val upE = thm "upE";
+val Ifup1 = thm "Ifup1";
+val Ifup2 = thm "Ifup2";
+val less_up1a = thm "less_up1a";
+val less_up1b = thm "less_up1b";
+val less_up1c = thm "less_up1c";
+val refl_less_up = thm "refl_less_up";
+val antisym_less_up = thm "antisym_less_up";
+val trans_less_up = thm "trans_less_up";
+val inst_up_po = thm "inst_up_po";
+val minimal_up = thm "minimal_up";
+val UU_up_def = thm "UU_up_def";
+val least_up = thm "least_up";
+val less_up2b = thm "less_up2b";
+val less_up2c = thm "less_up2c";
+val monofun_Iup = thm "monofun_Iup";
+val monofun_Ifup1 = thm "monofun_Ifup1";
+val monofun_Ifup2 = thm "monofun_Ifup2";
+val up_lemma1 = thm "up_lemma1";
+val lub_up1a = thm "lub_up1a";
+val lub_up1b = thm "lub_up1b";
+val thelub_up1a = thm "thelub_up1a";
+val thelub_up1b = thm "thelub_up1b";
+val cpo_up = thm "cpo_up";
+val up_def = thm "up_def";
+val fup_def = thm "fup_def";
+val inst_up_pcpo = thm "inst_up_pcpo";
+val less_up3b = thm "less_up3b";
+val defined_Iup2 = thm "defined_Iup2";
+val contlub_Iup = thm "contlub_Iup";
+val cont_Iup = thm "cont_Iup";
+val contlub_Ifup1 = thm "contlub_Ifup1";
+val contlub_Ifup2 = thm "contlub_Ifup2";
+val cont_Ifup1 = thm "cont_Ifup1";
+val cont_Ifup2 = thm "cont_Ifup2";
+val Exh_Up1 = thm "Exh_Up1";
+val inject_up = thm "inject_up";
+val defined_up = thm "defined_up";
+val upE1 = thm "upE1";
+val fup1 = thm "fup1";
+val fup2 = thm "fup2";
+val less_up4b = thm "less_up4b";
+val less_up4c = thm "less_up4c";
+val thelub_up2a = thm "thelub_up2a";
+val thelub_up2b = thm "thelub_up2b";
+val up_lemma2 = thm "up_lemma2";
+val thelub_up2a_rev = thm "thelub_up2a_rev";
+val thelub_up2b_rev = thm "thelub_up2b_rev";
+val thelub_up3 = thm "thelub_up3";
+val fup3 = thm "fup3";
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Up.thy Fri Mar 04 23:12:36 2005 +0100
@@ -0,0 +1,625 @@
+(* Title: HOLCF/Up1.thy
+ ID: $Id$
+ Author: Franz Regensburger
+ License: GPL (GNU GENERAL PUBLIC LICENSE)
+
+Lifting.
+*)
+
+header {* The type of lifted values *}
+
+theory Up = Cfun + Sum_Type + Datatype:
+
+(* new type for lifting *)
+
+typedef (Up) ('a) "u" = "{x::(unit + 'a).True}"
+by auto
+
+instance u :: (sq_ord)sq_ord ..
+
+consts
+ Iup :: "'a => ('a)u"
+ Ifup :: "('a->'b)=>('a)u => 'b"
+
+defs
+ Iup_def: "Iup x == Abs_Up(Inr(x))"
+ Ifup_def: "Ifup(f)(x)== case Rep_Up(x) of Inl(y) => UU | Inr(z) => f$z"
+
+defs (overloaded)
+ less_up_def: "(op <<) == (%x1 x2. case Rep_Up(x1) of
+ Inl(y1) => True
+ | Inr(y2) => (case Rep_Up(x2) of Inl(z1) => False
+ | Inr(z2) => y2<<z2))"
+
+lemma Abs_Up_inverse2: "Rep_Up (Abs_Up y) = y"
+apply (simp (no_asm) add: Up_def Abs_Up_inverse)
+done
+
+lemma Exh_Up: "z = Abs_Up(Inl ()) | (? x. z = Iup x)"
+apply (unfold Iup_def)
+apply (rule Rep_Up_inverse [THEN subst])
+apply (rule_tac s = "Rep_Up z" in sumE)
+apply (rule disjI1)
+apply (rule_tac f = "Abs_Up" in arg_cong)
+apply (rule unit_eq [THEN subst])
+apply assumption
+apply (rule disjI2)
+apply (rule exI)
+apply (rule_tac f = "Abs_Up" in arg_cong)
+apply assumption
+done
+
+lemma inj_Abs_Up: "inj(Abs_Up)"
+apply (rule inj_on_inverseI)
+apply (rule Abs_Up_inverse2)
+done
+
+lemma inj_Rep_Up: "inj(Rep_Up)"
+apply (rule inj_on_inverseI)
+apply (rule Rep_Up_inverse)
+done
+
+lemma inject_Iup: "Iup x=Iup y ==> x=y"
+apply (unfold Iup_def)
+apply (rule inj_Inr [THEN injD])
+apply (rule inj_Abs_Up [THEN injD])
+apply assumption
+done
+
+declare inject_Iup [dest!]
+
+lemma defined_Iup: "Iup x~=Abs_Up(Inl ())"
+apply (unfold Iup_def)
+apply (rule notI)
+apply (rule notE)
+apply (rule Inl_not_Inr)
+apply (rule sym)
+apply (erule inj_Abs_Up [THEN injD])
+done
+
+
+lemma upE: "[| p=Abs_Up(Inl ()) ==> Q; !!x. p=Iup(x)==>Q|] ==>Q"
+apply (rule Exh_Up [THEN disjE])
+apply fast
+apply (erule exE)
+apply fast
+done
+
+lemma Ifup1: "Ifup(f)(Abs_Up(Inl ()))=UU"
+apply (unfold Ifup_def)
+apply (subst Abs_Up_inverse2)
+apply (subst sum_case_Inl)
+apply (rule refl)
+done
+
+lemma Ifup2:
+ "Ifup(f)(Iup(x))=f$x"
+apply (unfold Ifup_def Iup_def)
+apply (subst Abs_Up_inverse2)
+apply (subst sum_case_Inr)
+apply (rule refl)
+done
+
+lemmas Up0_ss = Ifup1 Ifup2
+
+declare Ifup1 [simp] Ifup2 [simp]
+
+lemma less_up1a:
+ "Abs_Up(Inl ())<< z"
+apply (unfold less_up_def)
+apply (subst Abs_Up_inverse2)
+apply (subst sum_case_Inl)
+apply (rule TrueI)
+done
+
+lemma less_up1b:
+ "~(Iup x) << (Abs_Up(Inl ()))"
+apply (unfold Iup_def less_up_def)
+apply (rule notI)
+apply (rule iffD1)
+prefer 2 apply (assumption)
+apply (subst Abs_Up_inverse2)
+apply (subst Abs_Up_inverse2)
+apply (subst sum_case_Inr)
+apply (subst sum_case_Inl)
+apply (rule refl)
+done
+
+lemma less_up1c:
+ "(Iup x) << (Iup y)=(x<<y)"
+apply (unfold Iup_def less_up_def)
+apply (subst Abs_Up_inverse2)
+apply (subst Abs_Up_inverse2)
+apply (subst sum_case_Inr)
+apply (subst sum_case_Inr)
+apply (rule refl)
+done
+
+declare less_up1a [iff] less_up1b [iff] less_up1c [iff]
+
+lemma refl_less_up: "(p::'a u) << p"
+apply (rule_tac p = "p" in upE)
+apply auto
+done
+
+lemma antisym_less_up: "[|(p1::'a u) << p2;p2 << p1|] ==> p1=p2"
+apply (rule_tac p = "p1" in upE)
+apply simp
+apply (rule_tac p = "p2" in upE)
+apply (erule sym)
+apply simp
+apply (rule_tac p = "p2" in upE)
+apply simp
+apply simp
+apply (drule antisym_less, assumption)
+apply simp
+done
+
+lemma trans_less_up: "[|(p1::'a u) << p2;p2 << p3|] ==> p1 << p3"
+apply (rule_tac p = "p1" in upE)
+apply simp
+apply (rule_tac p = "p2" in upE)
+apply simp
+apply (rule_tac p = "p3" in upE)
+apply auto
+apply (blast intro: trans_less)
+done
+
+(* Class Instance u::(pcpo)po *)
+
+instance u :: (pcpo)po
+apply (intro_classes)
+apply (rule refl_less_up)
+apply (rule antisym_less_up, assumption+)
+apply (rule trans_less_up, assumption+)
+done
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_up_po: "(op <<)=(%x1 x2. case Rep_Up(x1) of
+ Inl(y1) => True
+ | Inr(y2) => (case Rep_Up(x2) of Inl(z1) => False
+ | Inr(z2) => y2<<z2))"
+apply (fold less_up_def)
+apply (rule refl)
+done
+
+(* -------------------------------------------------------------------------*)
+(* type ('a)u is pointed *)
+(* ------------------------------------------------------------------------ *)
+
+lemma minimal_up: "Abs_Up(Inl ()) << z"
+apply (simp (no_asm) add: less_up1a)
+done
+
+lemmas UU_up_def = minimal_up [THEN minimal2UU, symmetric, standard]
+
+lemma least_up: "EX x::'a u. ALL y. x<<y"
+apply (rule_tac x = "Abs_Up (Inl ())" in exI)
+apply (rule minimal_up [THEN allI])
+done
+
+(* -------------------------------------------------------------------------*)
+(* access to less_up in class po *)
+(* ------------------------------------------------------------------------ *)
+
+lemma less_up2b: "~ Iup(x) << Abs_Up(Inl ())"
+apply (simp (no_asm) add: less_up1b)
+done
+
+lemma less_up2c: "(Iup(x)<<Iup(y)) = (x<<y)"
+apply (simp (no_asm) add: less_up1c)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Iup and Ifup are monotone *)
+(* ------------------------------------------------------------------------ *)
+
+lemma monofun_Iup: "monofun(Iup)"
+
+apply (unfold monofun)
+apply (intro strip)
+apply (erule less_up2c [THEN iffD2])
+done
+
+lemma monofun_Ifup1: "monofun(Ifup)"
+apply (unfold monofun)
+apply (intro strip)
+apply (rule less_fun [THEN iffD2])
+apply (intro strip)
+apply (rule_tac p = "xa" in upE)
+apply simp
+apply simp
+apply (erule monofun_cfun_fun)
+done
+
+lemma monofun_Ifup2: "monofun(Ifup(f))"
+apply (unfold monofun)
+apply (intro strip)
+apply (rule_tac p = "x" in upE)
+apply simp
+apply simp
+apply (rule_tac p = "y" in upE)
+apply simp
+apply simp
+apply (erule monofun_cfun_arg)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* Some kind of surjectivity lemma *)
+(* ------------------------------------------------------------------------ *)
+
+lemma up_lemma1: "z=Iup(x) ==> Iup(Ifup(LAM x. x)(z)) = z"
+apply simp
+done
+
+(* ------------------------------------------------------------------------ *)
+(* ('a)u is a cpo *)
+(* ------------------------------------------------------------------------ *)
+
+lemma lub_up1a: "[|chain(Y);EX i x. Y(i)=Iup(x)|]
+ ==> range(Y) <<| Iup(lub(range(%i.(Ifup (LAM x. x) (Y(i))))))"
+apply (rule is_lubI)
+apply (rule ub_rangeI)
+apply (rule_tac p = "Y (i) " in upE)
+apply (rule_tac s = "Abs_Up (Inl ())" and t = "Y (i) " in subst)
+apply (erule sym)
+apply (rule minimal_up)
+apply (rule_tac t = "Y (i) " in up_lemma1 [THEN subst])
+apply assumption
+apply (rule less_up2c [THEN iffD2])
+apply (rule is_ub_thelub)
+apply (erule monofun_Ifup2 [THEN ch2ch_monofun])
+apply (rule_tac p = "u" in upE)
+apply (erule exE)
+apply (erule exE)
+apply (rule_tac P = "Y (i) <<Abs_Up (Inl ())" in notE)
+apply (rule_tac s = "Iup (x) " and t = "Y (i) " in ssubst)
+apply assumption
+apply (rule less_up2b)
+apply (erule subst)
+apply (erule ub_rangeD)
+apply (rule_tac t = "u" in up_lemma1 [THEN subst])
+apply assumption
+apply (rule less_up2c [THEN iffD2])
+apply (rule is_lub_thelub)
+apply (erule monofun_Ifup2 [THEN ch2ch_monofun])
+apply (erule monofun_Ifup2 [THEN ub2ub_monofun])
+done
+
+lemma lub_up1b: "[|chain(Y); ALL i x. Y(i)~=Iup(x)|] ==> range(Y) <<| Abs_Up (Inl ())"
+apply (rule is_lubI)
+apply (rule ub_rangeI)
+apply (rule_tac p = "Y (i) " in upE)
+apply (rule_tac s = "Abs_Up (Inl ())" and t = "Y (i) " in ssubst)
+apply assumption
+apply (rule refl_less)
+apply (rule notE)
+apply (drule spec)
+apply (drule spec)
+apply assumption
+apply assumption
+apply (rule minimal_up)
+done
+
+lemmas thelub_up1a = lub_up1a [THEN thelubI, standard]
+(*
+[| chain ?Y1; EX i x. ?Y1 i = Iup x |] ==>
+ lub (range ?Y1) = Iup (lub (range (%i. Iup (LAM x. x) (?Y1 i))))
+*)
+
+lemmas thelub_up1b = lub_up1b [THEN thelubI, standard]
+(*
+[| chain ?Y1; ! i x. ?Y1 i ~= Iup x |] ==>
+ lub (range ?Y1) = UU_up
+*)
+
+lemma cpo_up: "chain(Y::nat=>('a)u) ==> EX x. range(Y) <<|x"
+apply (rule disjE)
+apply (rule_tac [2] exI)
+apply (erule_tac [2] lub_up1a)
+prefer 2 apply (assumption)
+apply (rule_tac [2] exI)
+apply (erule_tac [2] lub_up1b)
+prefer 2 apply (assumption)
+apply fast
+done
+
+(* Class instance of ('a)u for class pcpo *)
+
+instance u :: (pcpo)pcpo
+apply (intro_classes)
+apply (erule cpo_up)
+apply (rule least_up)
+done
+
+constdefs
+ up :: "'a -> ('a)u"
+ "up == (LAM x. Iup(x))"
+ fup :: "('a->'c)-> ('a)u -> 'c"
+ "fup == (LAM f p. Ifup(f)(p))"
+
+translations
+"case l of up$x => t1" == "fup$(LAM x. t1)$l"
+
+(* for compatibility with old HOLCF-Version *)
+lemma inst_up_pcpo: "UU = Abs_Up(Inl ())"
+apply (simp add: UU_def UU_up_def)
+done
+
+(* -------------------------------------------------------------------------*)
+(* some lemmas restated for class pcpo *)
+(* ------------------------------------------------------------------------ *)
+
+lemma less_up3b: "~ Iup(x) << UU"
+apply (subst inst_up_pcpo)
+apply (rule less_up2b)
+done
+
+lemma defined_Iup2: "Iup(x) ~= UU"
+apply (subst inst_up_pcpo)
+apply (rule defined_Iup)
+done
+declare defined_Iup2 [iff]
+
+(* ------------------------------------------------------------------------ *)
+(* continuity for Iup *)
+(* ------------------------------------------------------------------------ *)
+
+lemma contlub_Iup: "contlub(Iup)"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule trans)
+apply (rule_tac [2] thelub_up1a [symmetric])
+prefer 3 apply fast
+apply (erule_tac [2] monofun_Iup [THEN ch2ch_monofun])
+apply (rule_tac f = "Iup" in arg_cong)
+apply (rule lub_equal)
+apply assumption
+apply (rule monofun_Ifup2 [THEN ch2ch_monofun])
+apply (erule monofun_Iup [THEN ch2ch_monofun])
+apply simp
+done
+
+lemma cont_Iup: "cont(Iup)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Iup)
+apply (rule contlub_Iup)
+done
+declare cont_Iup [iff]
+
+(* ------------------------------------------------------------------------ *)
+(* continuity for Ifup *)
+(* ------------------------------------------------------------------------ *)
+
+lemma contlub_Ifup1: "contlub(Ifup)"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule trans)
+apply (rule_tac [2] thelub_fun [symmetric])
+apply (erule_tac [2] monofun_Ifup1 [THEN ch2ch_monofun])
+apply (rule ext)
+apply (rule_tac p = "x" in upE)
+apply simp
+apply (rule lub_const [THEN thelubI, symmetric])
+apply simp
+apply (erule contlub_cfun_fun)
+done
+
+
+lemma contlub_Ifup2: "contlub(Ifup(f))"
+apply (rule contlubI)
+apply (intro strip)
+apply (rule disjE)
+defer 1
+apply (subst thelub_up1a)
+apply assumption
+apply assumption
+apply simp
+prefer 2
+apply (subst thelub_up1b)
+apply assumption
+apply assumption
+apply simp
+apply (rule chain_UU_I_inverse [symmetric])
+apply (rule allI)
+apply (rule_tac p = "Y(i)" in upE)
+apply simp
+apply simp
+apply (subst contlub_cfun_arg)
+apply (erule monofun_Ifup2 [THEN ch2ch_monofun])
+apply (rule lub_equal2)
+apply (rule_tac [2] monofun_Rep_CFun2 [THEN ch2ch_monofun])
+apply (erule_tac [2] monofun_Ifup2 [THEN ch2ch_monofun])
+apply (erule_tac [2] monofun_Ifup2 [THEN ch2ch_monofun])
+apply (rule chain_mono2 [THEN exE])
+prefer 2 apply (assumption)
+apply (erule exE)
+apply (erule exE)
+apply (rule exI)
+apply (rule_tac s = "Iup (x) " and t = "Y (i) " in ssubst)
+apply assumption
+apply (rule defined_Iup2)
+apply (rule exI)
+apply (intro strip)
+apply (rule_tac p = "Y (i) " in upE)
+prefer 2 apply simp
+apply (rule_tac P = "Y (i) = UU" in notE)
+apply fast
+apply (subst inst_up_pcpo)
+apply assumption
+apply fast
+done
+
+lemma cont_Ifup1: "cont(Ifup)"
+apply (rule monocontlub2cont)
+apply (rule monofun_Ifup1)
+apply (rule contlub_Ifup1)
+done
+
+lemma cont_Ifup2: "cont(Ifup(f))"
+apply (rule monocontlub2cont)
+apply (rule monofun_Ifup2)
+apply (rule contlub_Ifup2)
+done
+
+
+(* ------------------------------------------------------------------------ *)
+(* continuous versions of lemmas for ('a)u *)
+(* ------------------------------------------------------------------------ *)
+
+lemma Exh_Up1: "z = UU | (EX x. z = up$x)"
+
+apply (unfold up_def)
+apply simp
+apply (subst inst_up_pcpo)
+apply (rule Exh_Up)
+done
+
+lemma inject_up: "up$x=up$y ==> x=y"
+apply (unfold up_def)
+apply (rule inject_Iup)
+apply auto
+done
+
+lemma defined_up: " up$x ~= UU"
+apply (unfold up_def)
+apply auto
+done
+
+lemma upE1:
+ "[| p=UU ==> Q; !!x. p=up$x==>Q|] ==>Q"
+apply (unfold up_def)
+apply (rule upE)
+apply (simp only: inst_up_pcpo)
+apply fast
+apply simp
+done
+
+lemmas up_conts = cont_lemmas1 cont_Iup cont_Ifup1 cont_Ifup2 cont2cont_CF1L
+
+lemma fup1: "fup$f$UU=UU"
+apply (unfold up_def fup_def)
+apply (subst inst_up_pcpo)
+apply (subst beta_cfun)
+apply (intro up_conts)
+apply (subst beta_cfun)
+apply (rule cont_Ifup2)
+apply simp
+done
+
+lemma fup2: "fup$f$(up$x)=f$x"
+apply (unfold up_def fup_def)
+apply (simplesubst beta_cfun)
+apply (rule cont_Iup)
+apply (subst beta_cfun)
+apply (intro up_conts)
+apply (subst beta_cfun)
+apply (rule cont_Ifup2)
+apply simp
+done
+
+lemma less_up4b: "~ up$x << UU"
+apply (unfold up_def fup_def)
+apply simp
+apply (rule less_up3b)
+done
+
+lemma less_up4c:
+ "(up$x << up$y) = (x<<y)"
+apply (unfold up_def fup_def)
+apply simp
+done
+
+lemma thelub_up2a:
+"[| chain(Y); EX i x. Y(i) = up$x |] ==>
+ lub(range(Y)) = up$(lub(range(%i. fup$(LAM x. x)$(Y i))))"
+apply (unfold up_def fup_def)
+apply (subst beta_cfun)
+apply (rule cont_Iup)
+apply (subst beta_cfun)
+apply (intro up_conts)
+apply (subst beta_cfun [THEN ext])
+apply (rule cont_Ifup2)
+apply (rule thelub_up1a)
+apply assumption
+apply (erule exE)
+apply (erule exE)
+apply (rule exI)
+apply (rule exI)
+apply (erule box_equals)
+apply (rule refl)
+apply simp
+done
+
+
+
+lemma thelub_up2b:
+"[| chain(Y); ! i x. Y(i) ~= up$x |] ==> lub(range(Y)) = UU"
+apply (unfold up_def fup_def)
+apply (subst inst_up_pcpo)
+apply (rule thelub_up1b)
+apply assumption
+apply (intro strip)
+apply (drule spec)
+apply (drule spec)
+apply simp
+done
+
+
+lemma up_lemma2: "(EX x. z = up$x) = (z~=UU)"
+apply (rule iffI)
+apply (erule exE)
+apply simp
+apply (rule defined_up)
+apply (rule_tac p = "z" in upE1)
+apply (erule notE)
+apply assumption
+apply (erule exI)
+done
+
+
+lemma thelub_up2a_rev: "[| chain(Y); lub(range(Y)) = up$x |] ==> EX i x. Y(i) = up$x"
+apply (rule exE)
+apply (rule chain_UU_I_inverse2)
+apply (rule up_lemma2 [THEN iffD1])
+apply (erule exI)
+apply (rule exI)
+apply (rule up_lemma2 [THEN iffD2])
+apply assumption
+done
+
+lemma thelub_up2b_rev: "[| chain(Y); lub(range(Y)) = UU |] ==> ! i x. Y(i) ~= up$x"
+apply (blast dest!: chain_UU_I [THEN spec] exI [THEN up_lemma2 [THEN iffD1]])
+done
+
+
+lemma thelub_up3: "chain(Y) ==> lub(range(Y)) = UU |
+ lub(range(Y)) = up$(lub(range(%i. fup$(LAM x. x)$(Y i))))"
+apply (rule disjE)
+apply (rule_tac [2] disjI1)
+apply (rule_tac [2] thelub_up2b)
+prefer 2 apply (assumption)
+prefer 2 apply (assumption)
+apply (rule_tac [2] disjI2)
+apply (rule_tac [2] thelub_up2a)
+prefer 2 apply (assumption)
+prefer 2 apply (assumption)
+apply fast
+done
+
+lemma fup3: "fup$up$x=x"
+apply (rule_tac p = "x" in upE1)
+apply (simp add: fup1 fup2)
+apply (simp add: fup1 fup2)
+done
+
+(* ------------------------------------------------------------------------ *)
+(* install simplifier for ('a)u *)
+(* ------------------------------------------------------------------------ *)
+
+declare fup1 [simp] fup2 [simp] defined_up [simp]
+
+end
+
+
+
--- a/src/HOLCF/Up1.ML Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,144 +0,0 @@
-(* Title: HOLCF/Up1.ML
- ID: $Id$
- Author: Franz Regensburger
-
-Lifting.
-*)
-
-Goal "Rep_Up (Abs_Up y) = y";
-by (simp_tac (simpset() addsimps [Up_def,Abs_Up_inverse]) 1);
-qed "Abs_Up_inverse2";
-
-Goalw [Iup_def] "z = Abs_Up(Inl ()) | (? x. z = Iup x)";
-by (rtac (Rep_Up_inverse RS subst) 1);
-by (res_inst_tac [("s","Rep_Up z")] sumE 1);
-by (rtac disjI1 1);
-by (res_inst_tac [("f","Abs_Up")] arg_cong 1);
-by (rtac (unit_eq RS subst) 1);
-by (atac 1);
-by (rtac disjI2 1);
-by (rtac exI 1);
-by (res_inst_tac [("f","Abs_Up")] arg_cong 1);
-by (atac 1);
-qed "Exh_Up";
-
-Goal "inj(Abs_Up)";
-by (rtac inj_inverseI 1);
-by (rtac Abs_Up_inverse2 1);
-qed "inj_Abs_Up";
-
-Goal "inj(Rep_Up)";
-by (rtac inj_inverseI 1);
-by (rtac Rep_Up_inverse 1);
-qed "inj_Rep_Up";
-
-Goalw [Iup_def] "Iup x=Iup y ==> x=y";
-by (rtac (inj_Inr RS injD) 1);
-by (rtac (inj_Abs_Up RS injD) 1);
-by (atac 1);
-qed "inject_Iup";
-
-AddSDs [inject_Iup];
-
-Goalw [Iup_def] "Iup x~=Abs_Up(Inl ())";
-by (rtac notI 1);
-by (rtac notE 1);
-by (rtac Inl_not_Inr 1);
-by (rtac sym 1);
-by (etac (inj_Abs_Up RS injD) 1);
-qed "defined_Iup";
-
-
-val prems = Goal "[| p=Abs_Up(Inl ()) ==> Q; !!x. p=Iup(x)==>Q|] ==>Q";
-by (rtac (Exh_Up RS disjE) 1);
-by (eresolve_tac prems 1);
-by (etac exE 1);
-by (eresolve_tac prems 1);
-qed "upE";
-
-Goalw [Ifup_def] "Ifup(f)(Abs_Up(Inl ()))=UU";
-by (stac Abs_Up_inverse2 1);
-by (stac sum_case_Inl 1);
-by (rtac refl 1);
-qed "Ifup1";
-
-Goalw [Ifup_def,Iup_def]
- "Ifup(f)(Iup(x))=f$x";
-by (stac Abs_Up_inverse2 1);
-by (stac sum_case_Inr 1);
-by (rtac refl 1);
-qed "Ifup2";
-
-val Up0_ss = (simpset_of Cfun3.thy) delsimps [range_composition]
- addsimps [Ifup1,Ifup2];
-
-Addsimps [Ifup1,Ifup2];
-
-Goalw [less_up_def]
- "Abs_Up(Inl ())<< z";
-by (stac Abs_Up_inverse2 1);
-by (stac sum_case_Inl 1);
-by (rtac TrueI 1);
-qed "less_up1a";
-
-Goalw [Iup_def,less_up_def]
- "~(Iup x) << (Abs_Up(Inl ()))";
-by (rtac notI 1);
-by (rtac iffD1 1);
-by (atac 2);
-by (stac Abs_Up_inverse2 1);
-by (stac Abs_Up_inverse2 1);
-by (stac sum_case_Inr 1);
-by (stac sum_case_Inl 1);
-by (rtac refl 1);
-qed "less_up1b";
-
-Goalw [Iup_def,less_up_def]
- "(Iup x) << (Iup y)=(x<<y)";
-by (stac Abs_Up_inverse2 1);
-by (stac Abs_Up_inverse2 1);
-by (stac sum_case_Inr 1);
-by (stac sum_case_Inr 1);
-by (rtac refl 1);
-qed "less_up1c";
-
-AddIffs [less_up1a, less_up1b, less_up1c];
-
-Goal "(p::'a u) << p";
-by (res_inst_tac [("p","p")] upE 1);
-by Auto_tac;
-qed "refl_less_up";
-
-Goal "[|(p1::'a u) << p2;p2 << p1|] ==> p1=p2";
-by (res_inst_tac [("p","p1")] upE 1);
-by (hyp_subst_tac 1);
-by (res_inst_tac [("p","p2")] upE 1);
-by (etac sym 1);
-by (hyp_subst_tac 1);
-by (res_inst_tac [("P","(Iup x) << (Abs_Up(Inl ()))")] notE 1);
-by (rtac less_up1b 1);
-by (atac 1);
-by (hyp_subst_tac 1);
-by (res_inst_tac [("p","p2")] upE 1);
-by (hyp_subst_tac 1);
-by (res_inst_tac [("P","(Iup x) << (Abs_Up(Inl ()))")] notE 1);
-by (rtac less_up1b 1);
-by (atac 1);
-by (blast_tac (claset() addIs [arg_cong, antisym_less, less_up1c RS iffD1]) 1);
-qed "antisym_less_up";
-
-Goal "[|(p1::'a u) << p2;p2 << p3|] ==> p1 << p3";
-by (res_inst_tac [("p","p1")] upE 1);
-by (hyp_subst_tac 1);
-by (rtac less_up1a 1);
-by (hyp_subst_tac 1);
-by (res_inst_tac [("p","p2")] upE 1);
-by (hyp_subst_tac 1);
-by (rtac notE 1);
-by (rtac less_up1b 1);
-by (atac 1);
-by (res_inst_tac [("p","p3")] upE 1);
-by Auto_tac;
-by (blast_tac (claset() addIs [trans_less]) 1);
-qed "trans_less_up";
-
--- a/src/HOLCF/Up1.thy Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,27 +0,0 @@
-(* Title: HOLCF/Up1.thy
- ID: $Id$
- Author: Franz Regensburger
-
-Lifting.
-*)
-
-Up1 = Cfun3 + Sum_Type + Datatype +
-
-(* new type for lifting *)
-
-typedef (Up) ('a) "u" = "{x::(unit + 'a).True}"
-
-instance u :: (sq_ord)sq_ord
-
-consts
- Iup :: "'a => ('a)u"
- Ifup :: "('a->'b)=>('a)u => 'b"
-
-defs
- Iup_def "Iup x == Abs_Up(Inr(x))"
- Ifup_def "Ifup(f)(x)== case Rep_Up(x) of Inl(y) => UU | Inr(z) => f$z"
- less_up_def "(op <<) == (%x1 x2. case Rep_Up(x1) of
- Inl(y1) => True
- | Inr(y2) => (case Rep_Up(x2) of Inl(z1) => False
- | Inr(z2) => y2<<z2))"
-end
--- a/src/HOLCF/Up2.ML Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,160 +0,0 @@
-(* Title: HOLCF/Up2.ML
- ID: $Id$
- Author: Franz Regensburger
-
-Class Instance u::(pcpo)po
-*)
-
-(* for compatibility with old HOLCF-Version *)
-Goal "(op <<)=(%x1 x2. case Rep_Up(x1) of \
-\ Inl(y1) => True \
-\ | Inr(y2) => (case Rep_Up(x2) of Inl(z1) => False \
-\ | Inr(z2) => y2<<z2))";
-by (fold_goals_tac [less_up_def]);
-by (rtac refl 1);
-qed "inst_up_po";
-
-(* -------------------------------------------------------------------------*)
-(* type ('a)u is pointed *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "Abs_Up(Inl ()) << z";
-by (simp_tac (simpset() addsimps [less_up1a]) 1);
-qed "minimal_up";
-
-bind_thm ("UU_up_def",minimal_up RS minimal2UU RS sym);
-
-Goal "EX x::'a u. ALL y. x<<y";
-by (res_inst_tac [("x","Abs_Up(Inl ())")] exI 1);
-by (rtac (minimal_up RS allI) 1);
-qed "least_up";
-
-(* -------------------------------------------------------------------------*)
-(* access to less_up in class po *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "~ Iup(x) << Abs_Up(Inl ())";
-by (simp_tac (simpset() addsimps [less_up1b]) 1);
-qed "less_up2b";
-
-Goal "(Iup(x)<<Iup(y)) = (x<<y)";
-by (simp_tac (simpset() addsimps [less_up1c]) 1);
-qed "less_up2c";
-
-(* ------------------------------------------------------------------------ *)
-(* Iup and Ifup are monotone *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [monofun] "monofun(Iup)";
-by (strip_tac 1);
-by (etac (less_up2c RS iffD2) 1);
-qed "monofun_Iup";
-
-Goalw [monofun] "monofun(Ifup)";
-by (strip_tac 1);
-by (rtac (less_fun RS iffD2) 1);
-by (strip_tac 1);
-by (res_inst_tac [("p","xa")] upE 1);
-by (asm_simp_tac Up0_ss 1);
-by (asm_simp_tac Up0_ss 1);
-by (etac monofun_cfun_fun 1);
-qed "monofun_Ifup1";
-
-Goalw [monofun] "monofun(Ifup(f))";
-by (strip_tac 1);
-by (res_inst_tac [("p","x")] upE 1);
-by (asm_simp_tac Up0_ss 1);
-by (asm_simp_tac Up0_ss 1);
-by (res_inst_tac [("p","y")] upE 1);
-by (hyp_subst_tac 1);
-by (rtac notE 1);
-by (rtac less_up2b 1);
-by (atac 1);
-by (asm_simp_tac Up0_ss 1);
-by (rtac monofun_cfun_arg 1);
-by (hyp_subst_tac 1);
-by (etac (less_up2c RS iffD1) 1);
-qed "monofun_Ifup2";
-
-(* ------------------------------------------------------------------------ *)
-(* SOME kind of surjectivity lemma *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "z=Iup(x) ==> Iup(Ifup(LAM x. x)(z)) = z";
-by (asm_simp_tac Up0_ss 1);
-qed "up_lemma1";
-
-(* ------------------------------------------------------------------------ *)
-(* ('a)u is a cpo *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "[|chain(Y);EX i x. Y(i)=Iup(x)|] \
-\ ==> range(Y) <<| Iup(lub(range(%i.(Ifup (LAM x. x) (Y(i))))))";
-by (rtac is_lubI 1);
-by (rtac ub_rangeI 1);
-by (res_inst_tac [("p","Y(i)")] upE 1);
-by (res_inst_tac [("s","Abs_Up (Inl ())"),("t","Y(i)")] subst 1);
-by (etac sym 1);
-by (rtac minimal_up 1);
-by (res_inst_tac [("t","Y(i)")] (up_lemma1 RS subst) 1);
-by (atac 1);
-by (rtac (less_up2c RS iffD2) 1);
-by (rtac is_ub_thelub 1);
-by (etac (monofun_Ifup2 RS ch2ch_monofun) 1);
-by (strip_tac 1);
-by (res_inst_tac [("p","u")] upE 1);
-by (etac exE 1);
-by (etac exE 1);
-by (res_inst_tac [("P","Y(i)<<Abs_Up (Inl ())")] notE 1);
-by (res_inst_tac [("s","Iup(x)"),("t","Y(i)")] ssubst 1);
-by (atac 1);
-by (rtac less_up2b 1);
-by (hyp_subst_tac 1);
-by (etac ub_rangeD 1);
-by (res_inst_tac [("t","u")] (up_lemma1 RS subst) 1);
-by (atac 1);
-by (rtac (less_up2c RS iffD2) 1);
-by (rtac is_lub_thelub 1);
-by (etac (monofun_Ifup2 RS ch2ch_monofun) 1);
-by (etac (monofun_Ifup2 RS ub2ub_monofun) 1);
-qed "lub_up1a";
-
-Goal "[|chain(Y); ALL i x. Y(i)~=Iup(x)|] ==> range(Y) <<| Abs_Up (Inl ())";
-by (rtac is_lubI 1);
-by (rtac ub_rangeI 1);
-by (res_inst_tac [("p","Y(i)")] upE 1);
-by (res_inst_tac [("s","Abs_Up (Inl ())"),("t","Y(i)")] ssubst 1);
-by (atac 1);
-by (rtac refl_less 1);
-by (rtac notE 1);
-by (dtac spec 1);
-by (dtac spec 1);
-by (atac 1);
-by (atac 1);
-by (strip_tac 1);
-by (rtac minimal_up 1);
-qed "lub_up1b";
-
-bind_thm ("thelub_up1a", lub_up1a RS thelubI);
-(*
-[| chain ?Y1; EX i x. ?Y1 i = Iup x |] ==>
- lub (range ?Y1) = Iup (lub (range (%i. Iup (LAM x. x) (?Y1 i))))
-*)
-
-bind_thm ("thelub_up1b", lub_up1b RS thelubI);
-(*
-[| chain ?Y1; ! i x. ?Y1 i ~= Iup x |] ==>
- lub (range ?Y1) = UU_up
-*)
-
-Goal "chain(Y::nat=>('a)u) ==> EX x. range(Y) <<|x";
-by (rtac disjE 1);
-by (rtac exI 2);
-by (etac lub_up1a 2);
-by (atac 2);
-by (rtac exI 2);
-by (etac lub_up1b 2);
-by (atac 2);
-by (fast_tac HOL_cs 1);
-qed "cpo_up";
-
--- a/src/HOLCF/Up2.thy Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,15 +0,0 @@
-(* Title: HOLCF/Up2.thy
- ID: $Id$
- Author: Franz Regensburger
-
-Class Instance u::(pcpo)po
-*)
-
-Up2 = Up1 +
-
-instance u :: (pcpo)po (refl_less_up,antisym_less_up,trans_less_up)
-
-end
-
-
-
--- a/src/HOLCF/Up3.ML Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,278 +0,0 @@
-(* Title: HOLCF/Up3.ML
- ID: $Id$
- Author: Franz Regensburger
-
-Class instance of ('a)u for class pcpo
-*)
-
-(* for compatibility with old HOLCF-Version *)
-Goal "UU = Abs_Up(Inl ())";
-by (simp_tac (HOL_ss addsimps [UU_def,UU_up_def]) 1);
-qed "inst_up_pcpo";
-
-(* -------------------------------------------------------------------------*)
-(* some lemmas restated for class pcpo *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "~ Iup(x) << UU";
-by (stac inst_up_pcpo 1);
-by (rtac less_up2b 1);
-qed "less_up3b";
-
-Goal "Iup(x) ~= UU";
-by (stac inst_up_pcpo 1);
-by (rtac defined_Iup 1);
-qed "defined_Iup2";
-AddIffs [defined_Iup2];
-
-(* ------------------------------------------------------------------------ *)
-(* continuity for Iup *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "contlub(Iup)";
-by (rtac contlubI 1);
-by (strip_tac 1);
-by (rtac trans 1);
-by (rtac (thelub_up1a RS sym) 2);
-by (fast_tac HOL_cs 3);
-by (etac (monofun_Iup RS ch2ch_monofun) 2);
-by (res_inst_tac [("f","Iup")] arg_cong 1);
-by (rtac lub_equal 1);
-by (atac 1);
-by (rtac (monofun_Ifup2 RS ch2ch_monofun) 1);
-by (etac (monofun_Iup RS ch2ch_monofun) 1);
-by (asm_simp_tac Up0_ss 1);
-qed "contlub_Iup";
-
-Goal "cont(Iup)";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_Iup 1);
-by (rtac contlub_Iup 1);
-qed "cont_Iup";
-AddIffs [cont_Iup];
-
-(* ------------------------------------------------------------------------ *)
-(* continuity for Ifup *)
-(* ------------------------------------------------------------------------ *)
-
-Goal "contlub(Ifup)";
-by (rtac contlubI 1);
-by (strip_tac 1);
-by (rtac trans 1);
-by (rtac (thelub_fun RS sym) 2);
-by (etac (monofun_Ifup1 RS ch2ch_monofun) 2);
-by (rtac ext 1);
-by (res_inst_tac [("p","x")] upE 1);
-by (asm_simp_tac Up0_ss 1);
-by (rtac (lub_const RS thelubI RS sym) 1);
-by (asm_simp_tac Up0_ss 1);
-by (etac contlub_cfun_fun 1);
-qed "contlub_Ifup1";
-
-
-Goal "contlub(Ifup(f))";
-by (rtac contlubI 1);
-by (strip_tac 1);
-by (rtac disjE 1);
-by (stac thelub_up1a 2);
-by (atac 2);
-by (atac 2);
-by (asm_simp_tac Up0_ss 2);
-by (stac thelub_up1b 3);
-by (atac 3);
-by (atac 3);
-by (fast_tac HOL_cs 1);
-by (asm_simp_tac Up0_ss 2);
-by (rtac (chain_UU_I_inverse RS sym) 2);
-by (rtac allI 2);
-by (res_inst_tac [("p","Y(i)")] upE 2);
-by (asm_simp_tac Up0_ss 2);
-by (rtac notE 2);
-by (dtac spec 2);
-by (etac spec 2);
-by (atac 2);
-by (stac contlub_cfun_arg 1);
-by (etac (monofun_Ifup2 RS ch2ch_monofun) 1);
-by (rtac lub_equal2 1);
-by (rtac (monofun_Rep_CFun2 RS ch2ch_monofun) 2);
-by (etac (monofun_Ifup2 RS ch2ch_monofun) 2);
-by (etac (monofun_Ifup2 RS ch2ch_monofun) 2);
-by (rtac (chain_mono2 RS exE) 1);
-by (atac 2);
-by (etac exE 1);
-by (etac exE 1);
-by (rtac exI 1);
-by (res_inst_tac [("s","Iup(x)"),("t","Y(i)")] ssubst 1);
-by (atac 1);
-by (rtac defined_Iup2 1);
-by (rtac exI 1);
-by (strip_tac 1);
-by (res_inst_tac [("p","Y(i)")] upE 1);
-by (asm_simp_tac Up0_ss 2);
-by (res_inst_tac [("P","Y(i) = UU")] notE 1);
-by (fast_tac HOL_cs 1);
-by (stac inst_up_pcpo 1);
-by (atac 1);
-qed "contlub_Ifup2";
-
-Goal "cont(Ifup)";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_Ifup1 1);
-by (rtac contlub_Ifup1 1);
-qed "cont_Ifup1";
-
-Goal "cont(Ifup(f))";
-by (rtac monocontlub2cont 1);
-by (rtac monofun_Ifup2 1);
-by (rtac contlub_Ifup2 1);
-qed "cont_Ifup2";
-
-
-(* ------------------------------------------------------------------------ *)
-(* continuous versions of lemmas for ('a)u *)
-(* ------------------------------------------------------------------------ *)
-
-Goalw [up_def] "z = UU | (EX x. z = up$x)";
-by (simp_tac (Up0_ss addsimps [cont_Iup]) 1);
-by (stac inst_up_pcpo 1);
-by (rtac Exh_Up 1);
-qed "Exh_Up1";
-
-Goalw [up_def] "up$x=up$y ==> x=y";
-by (rtac inject_Iup 1);
-by Auto_tac;
-qed "inject_up";
-
-Goalw [up_def] " up$x ~= UU";
-by Auto_tac;
-qed "defined_up";
-
-val prems = Goalw [up_def]
- "[| p=UU ==> Q; !!x. p=up$x==>Q|] ==>Q";
-by (rtac upE 1);
-by (resolve_tac prems 1);
-by (etac (inst_up_pcpo RS ssubst) 1);
-by (resolve_tac (tl prems) 1);
-by (asm_simp_tac (Up0_ss addsimps [cont_Iup]) 1);
-qed "upE1";
-
-val tac = (simp_tac (simpset() addsimps [cont_Iup,cont_Ifup1,
- cont_Ifup2,cont2cont_CF1L]) 1);
-
-Goalw [up_def,fup_def] "fup$f$UU=UU";
-by (stac inst_up_pcpo 1);
-by (stac beta_cfun 1);
-by tac;
-by (stac beta_cfun 1);
-by tac;
-by (simp_tac (Up0_ss addsimps [cont_Iup,cont_Ifup1,cont_Ifup2]) 1);
-qed "fup1";
-
-Goalw [up_def,fup_def] "fup$f$(up$x)=f$x";
-by (stac beta_cfun 1);
-by (rtac cont_Iup 1);
-by (stac beta_cfun 1);
-by tac;
-by (stac beta_cfun 1);
-by (rtac cont_Ifup2 1);
-by (simp_tac (Up0_ss addsimps [cont_Iup,cont_Ifup1,cont_Ifup2]) 1);
-qed "fup2";
-
-Goalw [up_def,fup_def] "~ up$x << UU";
-by (simp_tac (Up0_ss addsimps [cont_Iup]) 1);
-by (rtac less_up3b 1);
-qed "less_up4b";
-
-Goalw [up_def,fup_def]
- "(up$x << up$y) = (x<<y)";
-by (simp_tac (Up0_ss addsimps [cont_Iup]) 1);
-by (rtac less_up2c 1);
-qed "less_up4c";
-
-Goalw [up_def,fup_def]
-"[| chain(Y); EX i x. Y(i) = up$x |] ==>\
-\ lub(range(Y)) = up$(lub(range(%i. fup$(LAM x. x)$(Y i))))";
-by (stac beta_cfun 1);
-by tac;
-by (stac beta_cfun 1);
-by tac;
-by (stac (beta_cfun RS ext) 1);
-by tac;
-by (rtac thelub_up1a 1);
-by (atac 1);
-by (etac exE 1);
-by (etac exE 1);
-by (rtac exI 1);
-by (rtac exI 1);
-by (etac box_equals 1);
-by (rtac refl 1);
-by (simp_tac (Up0_ss addsimps [cont_Iup]) 1);
-qed "thelub_up2a";
-
-
-
-Goalw [up_def,fup_def]
-"[| chain(Y); ! i x. Y(i) ~= up$x |] ==> lub(range(Y)) = UU";
-by (stac inst_up_pcpo 1);
-by (rtac thelub_up1b 1);
-by (atac 1);
-by (strip_tac 1);
-by (dtac spec 1);
-by (dtac spec 1);
-by (asm_full_simp_tac (Up0_ss addsimps [cont_Iup]) 1);
-qed "thelub_up2b";
-
-
-Goal "(EX x. z = up$x) = (z~=UU)";
-by (rtac iffI 1);
-by (etac exE 1);
-by (hyp_subst_tac 1);
-by (rtac defined_up 1);
-by (res_inst_tac [("p","z")] upE1 1);
-by (etac notE 1);
-by (atac 1);
-by (etac exI 1);
-qed "up_lemma2";
-
-
-Goal "[| chain(Y); lub(range(Y)) = up$x |] ==> EX i x. Y(i) = up$x";
-by (rtac exE 1);
-by (rtac chain_UU_I_inverse2 1);
-by (rtac (up_lemma2 RS iffD1) 1);
-by (etac exI 1);
-by (rtac exI 1);
-by (rtac (up_lemma2 RS iffD2) 1);
-by (atac 1);
-qed "thelub_up2a_rev";
-
-Goal "[| chain(Y); lub(range(Y)) = UU |] ==> ! i x. Y(i) ~= up$x";
-by (blast_tac (claset() addSDs [chain_UU_I RS spec,
- exI RS (up_lemma2 RS iffD1)]) 1);
-qed "thelub_up2b_rev";
-
-
-Goal "chain(Y) ==> lub(range(Y)) = UU | \
-\ lub(range(Y)) = up$(lub(range(%i. fup$(LAM x. x)$(Y i))))";
-by (rtac disjE 1);
-by (rtac disjI1 2);
-by (rtac thelub_up2b 2);
-by (atac 2);
-by (atac 2);
-by (rtac disjI2 2);
-by (rtac thelub_up2a 2);
-by (atac 2);
-by (atac 2);
-by (fast_tac HOL_cs 1);
-qed "thelub_up3";
-
-Goal "fup$up$x=x";
-by (res_inst_tac [("p","x")] upE1 1);
-by (asm_simp_tac ((simpset_of Cfun3.thy) addsimps [fup1,fup2]) 1);
-by (asm_simp_tac ((simpset_of Cfun3.thy) addsimps [fup1,fup2]) 1);
-qed "fup3";
-
-(* ------------------------------------------------------------------------ *)
-(* install simplifier for ('a)u *)
-(* ------------------------------------------------------------------------ *)
-
-Addsimps [fup1,fup2,defined_up];
--- a/src/HOLCF/Up3.thy Fri Mar 04 18:53:46 2005 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,24 +0,0 @@
-(* Title: HOLCF/Up3.thy
- ID: $Id$
- Author: Franz Regensburger
-
-Class instance of ('a)u for class pcpo
-*)
-
-Up3 = Up2 +
-
-instance u :: (pcpo)pcpo (least_up,cpo_up)
-
-constdefs
- up :: "'a -> ('a)u"
- "up == (LAM x. Iup(x))"
- fup :: "('a->'c)-> ('a)u -> 'c"
- "fup == (LAM f p. Ifup(f)(p))"
-
-translations
-"case l of up$x => t1" == "fup$(LAM x. t1)$l"
-
-end
-
-
-