# HG changeset patch # User huffman # Date 1109974356 -3600 # Node ID efb95d0d01f7258047b067cbf176f17d3260ba06 # Parent 63babb1ee8834ee21ccb06e6b8e70ec905ed6925 converted to new-style theories, and combined numbered files diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cfun.ML --- /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; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cfun.thy --- /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" ("(_ \/ _)" [1,0]0) + "LAM " :: "[idts, 'a => 'b] => ('a -> 'b)" + ("(3\_./ _)" [0, 10] 10) + Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("(_\_)" [999,1000] 999) + +syntax (HTML output) + Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("(_\_)" [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< '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\(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< 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< Abs_CFun(f)< '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< x=UU | x=y; + !y. f$(g$y)=(y::'b); !x. g$(f$x)=(x::'a)|] ==> !x y::'b. x< x=UU | x=y" +apply (intro strip) +apply (rule disjE) +apply (rule_tac P = "g$x< 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cfun1.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cfun1.thy --- 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" ("(_ \/ _)" [1,0]0) - "LAM " :: "[idts, 'a => 'b] => ('a -> 'b)" - ("(3\_./ _)" [0, 10] 10) - Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("(_\_)" [999,1000] 999) - -syntax (HTML output) - Rep_CFun :: "('a -> 'b) => ('a => 'b)" ("(_\_)" [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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cfun2.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cfun2.thy --- 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< '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\(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< 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< Abs_CFun(f)< '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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cfun3.ML --- 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; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cfun3.thy --- 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< x=UU | x=y; - !y. f$(g$y)=(y::'b); !x. g$(f$x)=(x::'a)|] ==> !x y::'b. x< x=UU | x=y" -apply (intro strip) -apply (rule disjE) -apply (rule_tac P = "g$x< 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cont.thy --- 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: (* diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cprod.ML --- /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] diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cprod.thy --- /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< 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< x1 << x2 & y1 << y2" +apply (simp add: inst_cprod_po) +done + +(* ------------------------------------------------------------------------ *) +(* type cprod is pointed *) +(* ------------------------------------------------------------------------ *) + +lemma minimal_cprod: "(UU,UU)< 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< (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 + "" == ">" + "" == "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 = e1; z = E2 in E3 + + and + + LAM .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 .e *) + +syntax + "_LAM" :: "[patterns, 'a => 'b] => ('a -> 'b)" ("(3LAM <_>./ _)" [0, 10] 10) + +translations + "LAM .b" == "csplit$(LAM x. LAM .b)" + "LAM . LAM zs. b" <= "csplit$(LAM x y zs. b)" + "LAM .b" == "csplit$(LAM x y. b)" + +syntax (xsymbols) + "_LAM" :: "[patterns, 'a => 'b] => ('a -> 'b)" ("(3\\()<_>./ _)" [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=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 = " +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: + " = UU ==> a = UU & b = UU" +apply (drule inst_cprod_pcpo2 [THEN subst]) +apply (erule inject_cpair) +done + +lemma Exh_Cprod2: + "? a b. z=" +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 = |] ==> 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" +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$ = 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: " = 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< 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) = + " +*) +lemma csplit2: + "csplit$f$ = 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cprod1.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cprod1.thy --- 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< 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)< 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< (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"; - - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cprod2.thy --- 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 - - - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cprod3.ML --- 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=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 = "; -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 - " = 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="; -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= |] ==> 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"; -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$ = 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] " = 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< 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) = - " -*) -Goalw [csplit_def] - "csplit$f$ = 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]; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Cprod3.thy --- 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 - "" == ">" - "" == "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 = e1; z = E2 in E3 - - and - - LAM .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 .e *) - -syntax - "_LAM" :: "[patterns, 'a => 'b] => ('a -> 'b)" ("(3LAM <_>./ _)" [0, 10] 10) - -translations - "LAM .b" == "csplit$(LAM x. LAM .b)" - "LAM . LAM zs. b" <= "csplit$(LAM x y zs. b)" - "LAM .b" == "csplit$(LAM x y. b)" - -syntax (xsymbols) - "_LAM" :: "[patterns, 'a => 'b] => ('a -> 'b)" ("(3\\()<_>./ _)" [0, 10] 10) - -end diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Fix.ML --- 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'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>\ - \ chain(%m. Y(Least(%j. m ! m. P(Y(LEAST j::nat. m'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==>\ - \ lub(range(Y)) = lub(range(%m. Y(Least(%j. m'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 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 + ]); diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Fix.thy --- 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'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==> + chain(%m. Y(Least(%j. m ! m. P(Y(LEAST j::nat. m'a::cpo); ! i. ? j. i < j & P(Y(j)) |] ==> + lub(range(Y)) = lub(range(%m. Y(Least(%j. m'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 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Fun1.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Fun1.thy --- 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 (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 - - - - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Fun2.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Fun2.thy --- 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<('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 - - - - - - - - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Fun3.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Fun3.thy --- 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 - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/FunCpo.ML --- /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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/FunCpo.thy --- /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<('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 + diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/HOLCF.thy --- 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/IsaMakefile --- 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Lift.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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/One.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/One.thy --- 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Pcpo.thy --- 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 bool" (infixl 55) + +syntax (xsymbols) + "op <<" :: "['a,'a::sq_ord] => bool" (infixl "\" 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< uu=(@u.!y. u< 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\_./ _)"[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 F x< 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< 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< 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) diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Porder0.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Porder0.thy --- 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 "\" 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< uu=(@u.!y. u< 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 - - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod.ML --- /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] + diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod.thy --- /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" ("(_ \/ _)" [21,20] 20) +syntax (HTML output) + "**" :: "[type, type] => type" ("(_ \/ _)" [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< 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< '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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod0.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod0.thy --- 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" ("(_ \/ _)" [21,20] 20) -syntax (HTML output) - "**" :: "[type, type] => type" ("(_ \/ _)" [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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod1.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod1.thy --- 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod2.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod2.thy --- 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< 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 - - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod3.ML --- 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] - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Sprod3.thy --- 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum.ML --- /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] diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum.thy --- /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" ("(_ \/ _)" [21, 20] 20) +syntax (HTML output) + "++" :: "[type, type] => type" ("(_ \/ _)" [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< (? 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum0.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum0.thy --- 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" ("(_ \/ _)" [21, 20] 20) -syntax (HTML output) - "++" :: "[type, type] => type" ("(_ \/ _)" [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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum1.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum1.thy --- 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 - - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum2.ML --- 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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum2.thy --- 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< (? 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 - - - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum3.ML --- 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] diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Ssum3.thy --- 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 diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Up.ML --- /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"; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Up.thy --- /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< 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< 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< 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) < 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< + 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 + + + diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Up1.ML --- 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< 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"; - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Up1.thy --- 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< True \ -\ | Inr(y2) => (case Rep_Up(x2) of Inl(z1) => False \ -\ | Inr(z2) => y2< 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)< 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"; - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Up2.thy --- 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 - - - diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Up3.ML --- 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<\ -\ 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]; diff -r 63babb1ee883 -r efb95d0d01f7 src/HOLCF/Up3.thy --- 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 - - -