added 8bit pragmas
authorregensbu
Fri Oct 06 17:25:24 1995 +0100 (1995-10-06)
changeset 1274ea0668a1c0ba
parent 1273 6960ec882bca
child 1275 5d68da443a9f
added 8bit pragmas
added directory ax_ops for sections axioms and ops
added directory domain for sections domain and generated
this is the type definition package of David Oheimb
src/HOLCF/Cfun1.thy
src/HOLCF/Cont.thy
src/HOLCF/Cprod3.ML
src/HOLCF/Cprod3.thy
src/HOLCF/Dlist.ML
src/HOLCF/Dlist.thy
src/HOLCF/Dnat.ML
src/HOLCF/Dnat.thy
src/HOLCF/Dnat2.ML
src/HOLCF/Dnat2.thy
src/HOLCF/Fix.ML
src/HOLCF/HOLCF.ML
src/HOLCF/HOLCF.thy
src/HOLCF/Holcfb.thy
src/HOLCF/Lift3.ML
src/HOLCF/Lift3.thy
src/HOLCF/Makefile
src/HOLCF/One.thy
src/HOLCF/Pcpo.thy
src/HOLCF/Porder.thy
src/HOLCF/Porder0.thy
src/HOLCF/README
src/HOLCF/ROOT.ML
src/HOLCF/Sprod0.ML
src/HOLCF/Sprod0.thy
src/HOLCF/Sprod3.ML
src/HOLCF/Sprod3.thy
src/HOLCF/Ssum0.ML
src/HOLCF/Ssum0.thy
src/HOLCF/Ssum3.ML
src/HOLCF/Ssum3.thy
src/HOLCF/Stream.ML
src/HOLCF/Stream.thy
src/HOLCF/Stream2.ML
src/HOLCF/Stream2.thy
src/HOLCF/Tr1.thy
src/HOLCF/ax_ops/holcflogic.ML
src/HOLCF/ax_ops/install.tex
src/HOLCF/ax_ops/thy_axioms.ML
src/HOLCF/ax_ops/thy_ops.ML
src/HOLCF/ax_ops/thy_syntax.ML
src/HOLCF/domain/axioms.ML
src/HOLCF/domain/extender.ML
src/HOLCF/domain/interface.ML
src/HOLCF/domain/library.ML
src/HOLCF/domain/syntax.ML
src/HOLCF/domain/theorems.ML
src/HOLCF/ex/Coind.ML
src/HOLCF/ex/Coind.thy
src/HOLCF/ex/Dagstuhl.ML
src/HOLCF/ex/Dagstuhl.thy
src/HOLCF/ex/Fix2.ML
src/HOLCF/ex/Fix2.thy
src/HOLCF/ex/Hoare.ML
src/HOLCF/ex/Loop.ML
src/HOLCF/ex/Loop.thy
src/HOLCF/ex/ROOT.ML
src/HOLCF/explicit_domains/Coind.ML
src/HOLCF/explicit_domains/Coind.thy
src/HOLCF/explicit_domains/Dagstuhl.ML
src/HOLCF/explicit_domains/Dagstuhl.thy
src/HOLCF/explicit_domains/Dlist.ML
src/HOLCF/explicit_domains/Dlist.thy
src/HOLCF/explicit_domains/Dnat.ML
src/HOLCF/explicit_domains/Dnat.thy
src/HOLCF/explicit_domains/Dnat2.ML
src/HOLCF/explicit_domains/Dnat2.thy
src/HOLCF/explicit_domains/Focus_ex.ML
src/HOLCF/explicit_domains/Focus_ex.thy
src/HOLCF/explicit_domains/README
src/HOLCF/explicit_domains/ROOT.ML
src/HOLCF/explicit_domains/Stream.ML
src/HOLCF/explicit_domains/Stream.thy
src/HOLCF/explicit_domains/Stream2.ML
src/HOLCF/explicit_domains/Stream2.thy
     1.1 --- a/src/HOLCF/Cfun1.thy	Fri Oct 06 16:17:08 1995 +0100
     1.2 +++ b/src/HOLCF/Cfun1.thy	Fri Oct 06 17:25:24 1995 +0100
     1.3 @@ -47,4 +47,11 @@
     1.4    (*defining the abstract constants*)
     1.5    less_cfun_def		"less_cfun fo1 fo2 == ( fapp fo1 << fapp fo2 )"
     1.6  
     1.7 +(* start 8bit 1 *)
     1.8 +(* end 8bit 1 *)
     1.9 +
    1.10 +
    1.11  end
    1.12 +
    1.13 +(* start 8bit 2 *)
    1.14 +(* end 8bit 2 *)
     2.1 --- a/src/HOLCF/Cont.thy	Fri Oct 06 16:17:08 1995 +0100
     2.2 +++ b/src/HOLCF/Cont.thy	Fri Oct 06 17:25:24 1995 +0100
     2.3 @@ -27,15 +27,15 @@
     2.4  
     2.5  monofun		"monofun(f) == ! x y. x << y --> f(x) << f(y)"
     2.6  
     2.7 -contlub		"contlub(f) == ! Y. is_chain(Y) --> \
     2.8 -\				f(lub(range(Y))) = lub(range(% i.f(Y(i))))"
     2.9 +contlub		"contlub(f) == ! Y. is_chain(Y) --> 
    2.10 +				f(lub(range(Y))) = lub(range(% i.f(Y(i))))"
    2.11  
    2.12 -cont		"cont(f)   == ! Y. is_chain(Y) --> \
    2.13 -\				range(% i.f(Y(i))) <<| f(lub(range(Y)))"
    2.14 +cont		"cont(f)   == ! Y. is_chain(Y) --> 
    2.15 +				range(% i.f(Y(i))) <<| f(lub(range(Y)))"
    2.16  
    2.17  (* ------------------------------------------------------------------------ *)
    2.18  (* the main purpose of cont.thy is to show:                                 *)
    2.19 -(*              monofun(f) & contlub(f)  <==> cont(f)                      *)
    2.20 +(*              monofun(f) & contlub(f)  <==> cont(f)                       *)
    2.21  (* ------------------------------------------------------------------------ *)
    2.22  
    2.23  end
     3.1 --- a/src/HOLCF/Cprod3.ML	Fri Oct 06 16:17:08 1995 +0100
     3.2 +++ b/src/HOLCF/Cprod3.ML	Fri Oct 06 17:25:24 1995 +0100
     3.3 @@ -314,3 +314,4 @@
     3.4  
     3.5  Addsimps [cfst2,csnd2,csplit2];
     3.6  
     3.7 +val Cprod_rews = [cfst2,csnd2,csplit2];
     4.1 --- a/src/HOLCF/Cprod3.thy	Fri Oct 06 16:17:08 1995 +0100
     4.2 +++ b/src/HOLCF/Cprod3.thy	Fri Oct 06 17:25:24 1995 +0100
     4.3 @@ -36,6 +36,53 @@
     4.4  csnd_def	"csnd   == (LAM p.snd(p))"	
     4.5  csplit_def	"csplit == (LAM f p.f`(cfst`p)`(csnd`p))"
     4.6  
     4.7 +
     4.8 +
     4.9 +(* introduce syntax for
    4.10 +
    4.11 +   Let <x,y> = e1; z = E2 in E3
    4.12 +
    4.13 +   and
    4.14 +
    4.15 +   <x,y,z>.e
    4.16 +*)
    4.17 +
    4.18 +types
    4.19 +  Cletbinds  Cletbind 
    4.20 +
    4.21 +consts
    4.22 +  CLet           :: "'a -> ('a -> 'b) -> 'b"
    4.23 +
    4.24 +syntax
    4.25 +  (* syntax for Let *) 
    4.26 +
    4.27 +  "_Cbind"  :: "[pttrn, 'a] => Cletbind"             ("(2_ =/ _)" 10)
    4.28 +  ""        :: "Cletbind => Cletbinds"               ("_")
    4.29 +  "_Cbinds" :: "[Cletbind, Cletbinds] => Cletbinds"  ("_;/ _")
    4.30 +  "_CLet"   :: "[Cletbinds, 'a] => 'a"                ("(Let (_)/ in (_))" 10)
    4.31 +
    4.32 +translations
    4.33 +  (* translation for Let *)
    4.34 +  "_CLet (_Cbinds b bs) e"  == "_CLet b (_CLet bs e)"
    4.35 +  "Let x = a in e"          == "CLet`a`(LAM x.e)"
    4.36 +
    4.37 +defs
    4.38 +  (* Misc Definitions *)
    4.39 +  CLet_def       "CLet == LAM s. LAM f.f`s"
    4.40 +
    4.41 +
    4.42 +syntax
    4.43 +  (* syntax for LAM <x,y,z>.E *)
    4.44 +  "@Cpttrn"  :: "[pttrn,pttrns] => pttrn"              ("<_,/_>")
    4.45 +
    4.46 +translations
    4.47 +  (* translations for LAM <x,y,z>.E *)
    4.48 +  "LAM <x,y,zs>.b"   == "csplit`(LAM x.LAM <y,zs>.b)"
    4.49 +  "LAM <x,y>.b"      == "csplit`(LAM x.LAM y.b)"
    4.50 +  (* reverse translation <= does not work yet !! *)
    4.51 +
    4.52 +(* start 8bit 1 *)
    4.53 +(* end 8bit 1 *)
    4.54  end
    4.55  
    4.56  
     5.1 --- a/src/HOLCF/Dlist.ML	Fri Oct 06 16:17:08 1995 +0100
     5.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3 @@ -1,564 +0,0 @@
     5.4 -(*  Title: 	HOLCF/dlist.ML
     5.5 -    Author: 	Franz Regensburger
     5.6 -    ID:         $ $
     5.7 -    Copyright   1994 Technische Universitaet Muenchen
     5.8 -
     5.9 -Lemmas for dlist.thy
    5.10 -*)
    5.11 -
    5.12 -open Dlist;
    5.13 -
    5.14 -(* ------------------------------------------------------------------------*)
    5.15 -(* The isomorphisms dlist_rep_iso and dlist_abs_iso are strict             *)
    5.16 -(* ------------------------------------------------------------------------*)
    5.17 -
    5.18 -val dlist_iso_strict= dlist_rep_iso RS (dlist_abs_iso RS 
    5.19 -	(allI  RSN (2,allI RS iso_strict)));
    5.20 -
    5.21 -val dlist_rews = [dlist_iso_strict RS conjunct1,
    5.22 -		dlist_iso_strict RS conjunct2];
    5.23 -
    5.24 -(* ------------------------------------------------------------------------*)
    5.25 -(* Properties of dlist_copy                                                *)
    5.26 -(* ------------------------------------------------------------------------*)
    5.27 -
    5.28 -val temp = prove_goalw Dlist.thy  [dlist_copy_def] "dlist_copy`f`UU=UU"
    5.29 - (fn prems =>
    5.30 -	[
    5.31 -	(asm_simp_tac (!simpset addsimps 
    5.32 -		(dlist_rews @ [dlist_abs_iso,dlist_rep_iso])) 1)
    5.33 -	]);
    5.34 -
    5.35 -val dlist_copy = [temp];
    5.36 -
    5.37 -
    5.38 -val temp = prove_goalw Dlist.thy  [dlist_copy_def,dnil_def] 
    5.39 -    "dlist_copy`f`dnil=dnil"
    5.40 - (fn prems =>
    5.41 -	[
    5.42 -	(asm_simp_tac (!simpset addsimps 
    5.43 -		(dlist_rews @ [dlist_abs_iso,dlist_rep_iso])) 1)
    5.44 -	]);
    5.45 -
    5.46 -val dlist_copy = temp :: dlist_copy;
    5.47 -
    5.48 -
    5.49 -val temp = prove_goalw Dlist.thy  [dlist_copy_def,dcons_def] 
    5.50 -	"xl~=UU ==> dlist_copy`f`(dcons`x`xl)= dcons`x`(f`xl)"
    5.51 - (fn prems =>
    5.52 -	[
    5.53 -	(cut_facts_tac prems 1),
    5.54 -	(asm_simp_tac (!simpset addsimps 
    5.55 -		(dlist_rews @ [dlist_abs_iso,dlist_rep_iso])) 1),
    5.56 -	(res_inst_tac [("Q","x=UU")] classical2 1),
    5.57 -	(Asm_simp_tac  1),
    5.58 -	(asm_simp_tac (!simpset addsimps [defined_spair]) 1)
    5.59 -	]);
    5.60 -
    5.61 -val dlist_copy = temp :: dlist_copy;
    5.62 -
    5.63 -val dlist_rews =  dlist_copy @ dlist_rews; 
    5.64 -
    5.65 -(* ------------------------------------------------------------------------*)
    5.66 -(* Exhaustion and elimination for dlists                                   *)
    5.67 -(* ------------------------------------------------------------------------*)
    5.68 -
    5.69 -qed_goalw "Exh_dlist" Dlist.thy [dcons_def,dnil_def]
    5.70 -	"l = UU | l = dnil | (? x xl. x~=UU &xl~=UU & l = dcons`x`xl)"
    5.71 - (fn prems =>
    5.72 -	[
    5.73 -	(Simp_tac 1),
    5.74 -	(rtac (dlist_rep_iso RS subst) 1),
    5.75 -	(res_inst_tac [("p","dlist_rep`l")] ssumE 1),
    5.76 -	(rtac disjI1 1),
    5.77 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
    5.78 -	(rtac disjI2 1),
    5.79 -	(rtac disjI1 1),
    5.80 -	(res_inst_tac [("p","x")] oneE 1),
    5.81 -	(contr_tac 1),
    5.82 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
    5.83 -	(rtac disjI2 1),
    5.84 -	(rtac disjI2 1),
    5.85 -	(res_inst_tac [("p","y")] sprodE 1),
    5.86 -	(contr_tac 1),
    5.87 -	(rtac exI 1),
    5.88 -	(rtac exI 1),
    5.89 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
    5.90 -	(fast_tac HOL_cs 1)
    5.91 -	]);
    5.92 -
    5.93 -
    5.94 -qed_goal "dlistE" Dlist.thy 
    5.95 -"[| l=UU ==> Q; l=dnil ==> Q;!!x xl.[|l=dcons`x`xl;x~=UU;xl~=UU|]==>Q|]==>Q"
    5.96 - (fn prems =>
    5.97 -	[
    5.98 -	(rtac (Exh_dlist RS disjE) 1),
    5.99 -	(eresolve_tac prems 1),
   5.100 -	(etac disjE 1),
   5.101 -	(eresolve_tac prems 1),
   5.102 -	(etac exE 1),
   5.103 -	(etac exE 1),
   5.104 -	(resolve_tac prems 1),
   5.105 -	(fast_tac HOL_cs 1),
   5.106 -	(fast_tac HOL_cs 1),
   5.107 -	(fast_tac HOL_cs 1)
   5.108 -	]);
   5.109 -
   5.110 -(* ------------------------------------------------------------------------*)
   5.111 -(* Properties of dlist_when                                                *)
   5.112 -(* ------------------------------------------------------------------------*)
   5.113 -
   5.114 -val temp = prove_goalw  Dlist.thy  [dlist_when_def] "dlist_when`f1`f2`UU=UU"
   5.115 - (fn prems =>
   5.116 -	[
   5.117 -	(asm_simp_tac (!simpset addsimps [dlist_iso_strict]) 1)
   5.118 -	]);
   5.119 -
   5.120 -val dlist_when = [temp];
   5.121 -
   5.122 -val temp = prove_goalw  Dlist.thy [dlist_when_def,dnil_def]
   5.123 - "dlist_when`f1`f2`dnil= f1"
   5.124 - (fn prems =>
   5.125 -	[
   5.126 -	(asm_simp_tac (!simpset addsimps [dlist_abs_iso]) 1)
   5.127 -	]);
   5.128 -
   5.129 -val dlist_when = temp::dlist_when;
   5.130 -
   5.131 -val temp = prove_goalw  Dlist.thy [dlist_when_def,dcons_def]
   5.132 - "[|x~=UU;xl~=UU|] ==> dlist_when`f1`f2`(dcons`x`xl)= f2`x`xl"
   5.133 - (fn prems =>
   5.134 -	[
   5.135 -	(cut_facts_tac prems 1),
   5.136 -	(asm_simp_tac (!simpset addsimps [dlist_abs_iso,defined_spair]) 1)
   5.137 -	]);
   5.138 -
   5.139 -val dlist_when = temp::dlist_when;
   5.140 -
   5.141 -val dlist_rews = dlist_when @ dlist_rews;
   5.142 -
   5.143 -(* ------------------------------------------------------------------------*)
   5.144 -(* Rewrites for  discriminators and  selectors                             *)
   5.145 -(* ------------------------------------------------------------------------*)
   5.146 -
   5.147 -fun prover defs thm = prove_goalw Dlist.thy defs thm
   5.148 - (fn prems =>
   5.149 -	[
   5.150 -	(simp_tac (!simpset addsimps dlist_rews) 1)
   5.151 -	]);
   5.152 -
   5.153 -val dlist_discsel = [
   5.154 -	prover [is_dnil_def] "is_dnil`UU=UU",
   5.155 -	prover [is_dcons_def] "is_dcons`UU=UU",
   5.156 -	prover [dhd_def] "dhd`UU=UU",
   5.157 -	prover [dtl_def] "dtl`UU=UU"
   5.158 -	];
   5.159 -
   5.160 -fun prover defs thm = prove_goalw Dlist.thy defs thm
   5.161 - (fn prems =>
   5.162 -	[
   5.163 -	(cut_facts_tac prems 1),
   5.164 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
   5.165 -	]);
   5.166 -
   5.167 -val dlist_discsel = [
   5.168 -prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
   5.169 -  "is_dnil`dnil=TT",
   5.170 -prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
   5.171 -  "[|x~=UU;xl~=UU|] ==> is_dnil`(dcons`x`xl)=FF",
   5.172 -prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
   5.173 -  "is_dcons`dnil=FF",
   5.174 -prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
   5.175 -  "[|x~=UU;xl~=UU|] ==> is_dcons`(dcons`x`xl)=TT",
   5.176 -prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
   5.177 -  "dhd`dnil=UU",
   5.178 -prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
   5.179 -  "[|x~=UU;xl~=UU|] ==> dhd`(dcons`x`xl)=x",
   5.180 -prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
   5.181 -  "dtl`dnil=UU",
   5.182 -prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
   5.183 -  "[|x~=UU;xl~=UU|] ==> dtl`(dcons`x`xl)=xl"] @ dlist_discsel;
   5.184 -
   5.185 -val dlist_rews = dlist_discsel @ dlist_rews;
   5.186 -
   5.187 -(* ------------------------------------------------------------------------*)
   5.188 -(* Definedness and strictness                                              *)
   5.189 -(* ------------------------------------------------------------------------*)
   5.190 -
   5.191 -fun prover contr thm = prove_goal Dlist.thy thm
   5.192 - (fn prems =>
   5.193 -	[
   5.194 -	(res_inst_tac [("P1",contr)] classical3 1),
   5.195 -	(simp_tac (!simpset addsimps dlist_rews) 1),
   5.196 -	(dtac sym 1),
   5.197 -	(Asm_simp_tac  1),
   5.198 -	(simp_tac (!simpset addsimps (prems @ dlist_rews)) 1)
   5.199 -	]);
   5.200 -
   5.201 -
   5.202 -val dlist_constrdef = [
   5.203 -prover "is_dnil`(UU::'a dlist) ~= UU" "dnil~=(UU::'a dlist)",
   5.204 -prover "is_dcons`(UU::'a dlist) ~= UU" 
   5.205 -	"[|x~=UU;xl~=UU|]==>dcons`(x::'a)`xl ~= UU"
   5.206 - ];
   5.207 -
   5.208 -
   5.209 -fun prover defs thm = prove_goalw Dlist.thy defs thm
   5.210 - (fn prems =>
   5.211 -	[
   5.212 -	(simp_tac (!simpset addsimps dlist_rews) 1)
   5.213 -	]);
   5.214 -
   5.215 -val dlist_constrdef = [
   5.216 -	prover [dcons_def] "dcons`UU`xl=UU",
   5.217 -	prover [dcons_def] "dcons`x`UU=UU"
   5.218 -	] @ dlist_constrdef;
   5.219 -
   5.220 -val dlist_rews = dlist_constrdef @ dlist_rews;
   5.221 -
   5.222 -
   5.223 -(* ------------------------------------------------------------------------*)
   5.224 -(* Distinctness wrt. << and =                                              *)
   5.225 -(* ------------------------------------------------------------------------*)
   5.226 -
   5.227 -val temp = prove_goal Dlist.thy  "~dnil << dcons`(x::'a)`xl"
   5.228 - (fn prems =>
   5.229 -	[
   5.230 -	(res_inst_tac [("P1","TT << FF")] classical3 1),
   5.231 -	(resolve_tac dist_less_tr 1),
   5.232 -	(dres_inst_tac [("fo5","is_dnil")] monofun_cfun_arg 1),
   5.233 -	(etac box_less 1),
   5.234 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.235 -	(res_inst_tac [("Q","(x::'a)=UU")] classical2 1),
   5.236 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.237 -	(res_inst_tac [("Q","(xl ::'a dlist)=UU")] classical2 1),
   5.238 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.239 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
   5.240 -	]);
   5.241 -
   5.242 -val dlist_dist_less = [temp];
   5.243 -
   5.244 -val temp = prove_goal Dlist.thy  "[|x~=UU;xl~=UU|]==>~ dcons`x`xl << dnil"
   5.245 - (fn prems =>
   5.246 -	[
   5.247 -	(cut_facts_tac prems 1),
   5.248 -	(res_inst_tac [("P1","TT << FF")] classical3 1),
   5.249 -	(resolve_tac dist_less_tr 1),
   5.250 -	(dres_inst_tac [("fo5","is_dcons")] monofun_cfun_arg 1),
   5.251 -	(etac box_less 1),
   5.252 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.253 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
   5.254 -	]);
   5.255 -
   5.256 -val dlist_dist_less = temp::dlist_dist_less;
   5.257 -
   5.258 -val temp = prove_goal Dlist.thy  "dnil ~= dcons`x`xl"
   5.259 - (fn prems =>
   5.260 -	[
   5.261 -	(res_inst_tac [("Q","x=UU")] classical2 1),
   5.262 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.263 -	(res_inst_tac [("Q","xl=UU")] classical2 1),
   5.264 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.265 -	(res_inst_tac [("P1","TT = FF")] classical3 1),
   5.266 -	(resolve_tac dist_eq_tr 1),
   5.267 -	(dres_inst_tac [("f","is_dnil")] cfun_arg_cong 1),
   5.268 -	(etac box_equals 1),
   5.269 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.270 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
   5.271 -	]);
   5.272 -
   5.273 -val dlist_dist_eq = [temp,temp RS not_sym];
   5.274 -
   5.275 -val dlist_rews = dlist_dist_less @ dlist_dist_eq @ dlist_rews;
   5.276 -
   5.277 -(* ------------------------------------------------------------------------*)
   5.278 -(* Invertibility                                                           *)
   5.279 -(* ------------------------------------------------------------------------*)
   5.280 -
   5.281 -val temp = prove_goal Dlist.thy "[|x1~=UU; y1~=UU;x2~=UU; y2~=UU;\
   5.282 -\ dcons`x1`x2 << dcons`y1`y2 |] ==> x1<< y1 & x2 << y2"
   5.283 - (fn prems =>
   5.284 -	[
   5.285 -	(cut_facts_tac prems 1),
   5.286 -	(rtac conjI 1),
   5.287 -	(dres_inst_tac [("fo5","dlist_when`UU`(LAM x l.x)")] monofun_cfun_arg 1),
   5.288 -	(etac box_less 1),
   5.289 -	(asm_simp_tac (!simpset addsimps dlist_when) 1),
   5.290 -	(asm_simp_tac (!simpset addsimps dlist_when) 1),
   5.291 -	(dres_inst_tac [("fo5","dlist_when`UU`(LAM x l.l)")] monofun_cfun_arg 1),
   5.292 -	(etac box_less 1),
   5.293 -	(asm_simp_tac (!simpset addsimps dlist_when) 1),
   5.294 -	(asm_simp_tac (!simpset addsimps dlist_when) 1)
   5.295 -	]);
   5.296 -
   5.297 -val dlist_invert =[temp];
   5.298 -
   5.299 -(* ------------------------------------------------------------------------*)
   5.300 -(* Injectivity                                                             *)
   5.301 -(* ------------------------------------------------------------------------*)
   5.302 -
   5.303 -val temp = prove_goal Dlist.thy "[|x1~=UU; y1~=UU;x2~=UU; y2~=UU;\
   5.304 -\ dcons`x1`x2 = dcons`y1`y2 |] ==> x1= y1 & x2 = y2"
   5.305 - (fn prems =>
   5.306 -	[
   5.307 -	(cut_facts_tac prems 1),
   5.308 -	(rtac conjI 1),
   5.309 -	(dres_inst_tac [("f","dlist_when`UU`(LAM x l.x)")] cfun_arg_cong 1),
   5.310 -	(etac box_equals 1),
   5.311 -	(asm_simp_tac (!simpset addsimps dlist_when) 1),
   5.312 -	(asm_simp_tac (!simpset addsimps dlist_when) 1),
   5.313 -	(dres_inst_tac [("f","dlist_when`UU`(LAM x l.l)")] cfun_arg_cong 1),
   5.314 -	(etac box_equals 1),
   5.315 -	(asm_simp_tac (!simpset addsimps dlist_when) 1),
   5.316 -	(asm_simp_tac (!simpset addsimps dlist_when) 1)
   5.317 -	]);
   5.318 -
   5.319 -val dlist_inject = [temp];
   5.320 - 
   5.321 -
   5.322 -(* ------------------------------------------------------------------------*)
   5.323 -(* definedness for  discriminators and  selectors                          *)
   5.324 -(* ------------------------------------------------------------------------*)
   5.325 -
   5.326 -fun prover thm = prove_goal Dlist.thy thm
   5.327 - (fn prems =>
   5.328 -	[
   5.329 -	(cut_facts_tac prems 1),
   5.330 -	(rtac dlistE 1),
   5.331 -	(contr_tac 1),
   5.332 -	(REPEAT (asm_simp_tac (!simpset addsimps dlist_discsel) 1))
   5.333 -	]);
   5.334 -
   5.335 -val dlist_discsel_def = 
   5.336 -	[
   5.337 -	prover "l~=UU ==> is_dnil`l~=UU", 
   5.338 -	prover "l~=UU ==> is_dcons`l~=UU" 
   5.339 -	];
   5.340 -
   5.341 -val dlist_rews = dlist_discsel_def @ dlist_rews;
   5.342 -
   5.343 -(* ------------------------------------------------------------------------*)
   5.344 -(* enhance the simplifier                                                  *)
   5.345 -(* ------------------------------------------------------------------------*)
   5.346 -
   5.347 -qed_goal "dhd2" Dlist.thy "xl~=UU ==> dhd`(dcons`x`xl)=x"
   5.348 - (fn prems =>
   5.349 -	[
   5.350 -	(cut_facts_tac prems 1),
   5.351 -	(res_inst_tac [("Q","x=UU")] classical2 1),
   5.352 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.353 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
   5.354 -	]);
   5.355 -
   5.356 -qed_goal "dtl2" Dlist.thy "x~=UU ==> dtl`(dcons`x`xl)=xl"
   5.357 - (fn prems =>
   5.358 -	[
   5.359 -	(cut_facts_tac prems 1),
   5.360 -	(res_inst_tac [("Q","xl=UU")] classical2 1),
   5.361 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.362 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
   5.363 -	]);
   5.364 -
   5.365 -val dlist_rews = dhd2 :: dtl2 :: dlist_rews;
   5.366 -
   5.367 -(* ------------------------------------------------------------------------*)
   5.368 -(* Properties dlist_take                                                   *)
   5.369 -(* ------------------------------------------------------------------------*)
   5.370 -
   5.371 -val temp = prove_goalw Dlist.thy [dlist_take_def] "dlist_take n`UU=UU"
   5.372 - (fn prems =>
   5.373 -	[
   5.374 -	(res_inst_tac [("n","n")] natE 1),
   5.375 -	(Asm_simp_tac 1),
   5.376 -	(Asm_simp_tac 1),
   5.377 -	(simp_tac (!simpset addsimps dlist_rews) 1)
   5.378 -	]);
   5.379 -
   5.380 -val dlist_take = [temp];
   5.381 -
   5.382 -val temp = prove_goalw Dlist.thy [dlist_take_def] "dlist_take 0`xs=UU"
   5.383 - (fn prems =>
   5.384 -	[
   5.385 -	(Asm_simp_tac 1)
   5.386 -	]);
   5.387 -
   5.388 -val dlist_take = temp::dlist_take;
   5.389 -
   5.390 -val temp = prove_goalw Dlist.thy [dlist_take_def]
   5.391 -	"dlist_take (Suc n)`dnil=dnil"
   5.392 - (fn prems =>
   5.393 -	[
   5.394 -	(Asm_simp_tac 1),
   5.395 -	(simp_tac (!simpset addsimps dlist_rews) 1)
   5.396 -	]);
   5.397 -
   5.398 -val dlist_take = temp::dlist_take;
   5.399 -
   5.400 -val temp = prove_goalw Dlist.thy [dlist_take_def]
   5.401 -  "dlist_take (Suc n)`(dcons`x`xl)= dcons`x`(dlist_take n`xl)"
   5.402 - (fn prems =>
   5.403 -	[
   5.404 -	(res_inst_tac [("Q","x=UU")] classical2 1),
   5.405 -	(Asm_simp_tac 1),
   5.406 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.407 -	(res_inst_tac [("Q","xl=UU")] classical2 1),
   5.408 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.409 -	(Asm_simp_tac 1),
   5.410 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.411 -	(res_inst_tac [("n","n")] natE 1),
   5.412 -	(Asm_simp_tac 1),
   5.413 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.414 -	(Asm_simp_tac 1),
   5.415 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.416 -	(Asm_simp_tac 1),
   5.417 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
   5.418 -	]);
   5.419 -
   5.420 -val dlist_take = temp::dlist_take;
   5.421 -
   5.422 -val dlist_rews = dlist_take @ dlist_rews;
   5.423 -
   5.424 -(* ------------------------------------------------------------------------*)
   5.425 -(* take lemma for dlists                                                  *)
   5.426 -(* ------------------------------------------------------------------------*)
   5.427 -
   5.428 -fun prover reach defs thm  = prove_goalw Dlist.thy defs thm
   5.429 - (fn prems =>
   5.430 -	[
   5.431 -	(res_inst_tac [("t","l1")] (reach RS subst) 1),
   5.432 -	(res_inst_tac [("t","l2")] (reach RS subst) 1),
   5.433 -	(rtac (fix_def2 RS ssubst) 1),
   5.434 -	(rtac (contlub_cfun_fun RS ssubst) 1),
   5.435 -	(rtac is_chain_iterate 1),
   5.436 -	(rtac (contlub_cfun_fun RS ssubst) 1),
   5.437 -	(rtac is_chain_iterate 1),
   5.438 -	(rtac lub_equal 1),
   5.439 -	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
   5.440 -	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
   5.441 -	(rtac allI 1),
   5.442 -	(resolve_tac prems 1)
   5.443 -	]);
   5.444 -
   5.445 -val dlist_take_lemma = prover dlist_reach  [dlist_take_def]
   5.446 -	"(!!n.dlist_take n`l1 = dlist_take n`l2) ==> l1=l2";
   5.447 -
   5.448 -
   5.449 -(* ------------------------------------------------------------------------*)
   5.450 -(* Co -induction for dlists                                               *)
   5.451 -(* ------------------------------------------------------------------------*)
   5.452 -
   5.453 -qed_goalw "dlist_coind_lemma" Dlist.thy [dlist_bisim_def] 
   5.454 -"dlist_bisim R ==> ! p q. R p q --> dlist_take n`p = dlist_take n`q"
   5.455 - (fn prems =>
   5.456 -	[
   5.457 -	(cut_facts_tac prems 1),
   5.458 -	(nat_ind_tac "n" 1),
   5.459 -	(simp_tac (!simpset addsimps dlist_rews) 1),
   5.460 -	(strip_tac 1),
   5.461 -	((etac allE 1) THEN (etac allE 1) THEN (etac (mp RS disjE) 1)),
   5.462 -	(atac 1),
   5.463 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.464 -	(etac disjE 1),
   5.465 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.466 -	(etac exE 1),
   5.467 -	(etac exE 1),
   5.468 -	(etac exE 1),
   5.469 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.470 -	(REPEAT (etac conjE 1)),
   5.471 -	(rtac cfun_arg_cong 1),
   5.472 -	(fast_tac HOL_cs 1)
   5.473 -	]);
   5.474 -
   5.475 -qed_goal "dlist_coind" Dlist.thy "[|dlist_bisim R ; R p q |] ==> p = q"
   5.476 - (fn prems =>
   5.477 -	[
   5.478 -	(rtac dlist_take_lemma 1),
   5.479 -	(rtac (dlist_coind_lemma RS spec RS spec RS mp) 1),
   5.480 -	(resolve_tac prems 1),
   5.481 -	(resolve_tac prems 1)
   5.482 -	]);
   5.483 -
   5.484 -(* ------------------------------------------------------------------------*)
   5.485 -(* structural induction                                                    *)
   5.486 -(* ------------------------------------------------------------------------*)
   5.487 -
   5.488 -qed_goal "dlist_finite_ind" Dlist.thy
   5.489 -"[|P(UU);P(dnil);\
   5.490 -\  !! x l1.[|x~=UU;l1~=UU;P(l1)|] ==> P(dcons`x`l1)\
   5.491 -\  |] ==> !l.P(dlist_take n`l)"
   5.492 - (fn prems =>
   5.493 -	[
   5.494 -	(nat_ind_tac "n" 1),
   5.495 -	(simp_tac (!simpset addsimps dlist_rews) 1),
   5.496 -	(resolve_tac prems 1),
   5.497 -	(rtac allI 1),
   5.498 -	(res_inst_tac [("l","l")] dlistE 1),
   5.499 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.500 -	(resolve_tac prems 1),
   5.501 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.502 -	(resolve_tac prems 1),
   5.503 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.504 -	(res_inst_tac [("Q","dlist_take n1`xl=UU")] classical2 1),
   5.505 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.506 -	(resolve_tac prems 1),
   5.507 -	(resolve_tac prems 1),
   5.508 -	(atac 1),
   5.509 -	(atac 1),
   5.510 -	(etac spec 1)
   5.511 -	]);
   5.512 -
   5.513 -qed_goal "dlist_all_finite_lemma1" Dlist.thy
   5.514 -"!l.dlist_take n`l=UU |dlist_take n`l=l"
   5.515 - (fn prems =>
   5.516 -	[
   5.517 -	(nat_ind_tac "n" 1),
   5.518 -	(simp_tac (!simpset addsimps dlist_rews) 1),
   5.519 -	(rtac allI 1),
   5.520 -	(res_inst_tac [("l","l")] dlistE 1),
   5.521 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.522 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.523 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.524 -	(eres_inst_tac [("x","xl")] allE 1),
   5.525 -	(etac disjE 1),
   5.526 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.527 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
   5.528 -	]);
   5.529 -
   5.530 -qed_goal "dlist_all_finite_lemma2" Dlist.thy "? n.dlist_take n`l=l"
   5.531 - (fn prems =>
   5.532 -	[
   5.533 -	(res_inst_tac [("Q","l=UU")] classical2 1),
   5.534 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.535 -	(subgoal_tac "(!n.dlist_take n`l=UU) |(? n.dlist_take n`l = l)" 1),
   5.536 -	(etac disjE 1),
   5.537 -	(eres_inst_tac [("P","l=UU")] notE 1),
   5.538 -	(rtac dlist_take_lemma 1),
   5.539 -	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   5.540 -	(atac 1),
   5.541 -	(subgoal_tac "!n.!l.dlist_take n`l=UU |dlist_take n`l=l" 1),
   5.542 -	(fast_tac HOL_cs 1),
   5.543 -	(rtac allI 1),
   5.544 -	(rtac dlist_all_finite_lemma1 1)
   5.545 -	]);
   5.546 -
   5.547 -qed_goalw "dlist_all_finite" Dlist.thy [dlist_finite_def] "dlist_finite(l)"
   5.548 - (fn prems =>
   5.549 -	[
   5.550 -	(rtac  dlist_all_finite_lemma2 1)
   5.551 -	]);
   5.552 -
   5.553 -qed_goal "dlist_ind" Dlist.thy
   5.554 -"[|P(UU);P(dnil);\
   5.555 -\  !! x l1.[|x~=UU;l1~=UU;P(l1)|] ==> P(dcons`x`l1)|] ==> P(l)"
   5.556 - (fn prems =>
   5.557 -	[
   5.558 -	(rtac (dlist_all_finite_lemma2 RS exE) 1),
   5.559 -	(etac subst 1),
   5.560 -	(rtac (dlist_finite_ind RS spec) 1),
   5.561 -	(REPEAT (resolve_tac prems 1)),
   5.562 -	(REPEAT (atac 1))
   5.563 -	]);
   5.564 -
   5.565 -
   5.566 -
   5.567 -
     6.1 --- a/src/HOLCF/Dlist.thy	Fri Oct 06 16:17:08 1995 +0100
     6.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.3 @@ -1,126 +0,0 @@
     6.4 -(*  Title: 	HOLCF/dlist.thy
     6.5 -
     6.6 -    Author: 	Franz Regensburger
     6.7 -    ID:         $ $
     6.8 -    Copyright   1994 Technische Universitaet Muenchen
     6.9 -
    6.10 -Theory for finite lists  'a dlist = one ++ ('a ** 'a dlist)
    6.11 -
    6.12 -The type is axiomatized as the least solution of the domain equation above.
    6.13 -The functor term that specifies the domain equation is: 
    6.14 -
    6.15 -  FT = <++,K_{one},<**,K_{'a},I>>
    6.16 -
    6.17 -For details see chapter 5 of:
    6.18 -
    6.19 -[Franz Regensburger] HOLCF: Eine konservative Erweiterung von HOL um LCF,
    6.20 -                     Dissertation, Technische Universit"at M"unchen, 1994
    6.21 -
    6.22 -
    6.23 -*)
    6.24 -
    6.25 -Dlist = Stream2 +
    6.26 -
    6.27 -types dlist 1
    6.28 -
    6.29 -(* ----------------------------------------------------------------------- *)
    6.30 -(* arity axiom is validated by semantic reasoning                          *)
    6.31 -(* partial ordering is implicit in the isomorphism axioms and their cont.  *)
    6.32 -
    6.33 -arities dlist::(pcpo)pcpo
    6.34 -
    6.35 -consts
    6.36 -
    6.37 -(* ----------------------------------------------------------------------- *)
    6.38 -(* essential constants                                                     *)
    6.39 -
    6.40 -dlist_rep	:: "('a dlist) -> (one ++ 'a ** 'a dlist)"
    6.41 -dlist_abs	:: "(one ++ 'a ** 'a dlist) -> ('a dlist)"
    6.42 -
    6.43 -(* ----------------------------------------------------------------------- *)
    6.44 -(* abstract constants and auxiliary constants                              *)
    6.45 -
    6.46 -dlist_copy	:: "('a dlist -> 'a dlist) ->'a dlist -> 'a dlist"
    6.47 -
    6.48 -dnil            :: "'a dlist"
    6.49 -dcons		:: "'a -> 'a dlist -> 'a dlist"
    6.50 -dlist_when	:: " 'b -> ('a -> 'a dlist -> 'b) -> 'a dlist -> 'b"
    6.51 -is_dnil    	:: "'a dlist -> tr"
    6.52 -is_dcons	:: "'a dlist -> tr"
    6.53 -dhd		:: "'a dlist -> 'a"
    6.54 -dtl		:: "'a dlist -> 'a dlist"
    6.55 -dlist_take	:: "nat => 'a dlist -> 'a dlist"
    6.56 -dlist_finite	:: "'a dlist => bool"
    6.57 -dlist_bisim	:: "('a dlist => 'a dlist => bool) => bool"
    6.58 -
    6.59 -rules
    6.60 -
    6.61 -(* ----------------------------------------------------------------------- *)
    6.62 -(* axiomatization of recursive type 'a dlist                               *)
    6.63 -(* ----------------------------------------------------------------------- *)
    6.64 -(* ('a dlist,dlist_abs) is the initial F-algebra where                     *)
    6.65 -(* F is the locally continuous functor determined by functor term FT.      *)
    6.66 -(* domain equation: 'a dlist = one ++ ('a ** 'a dlist)                     *)
    6.67 -(* functor term:    FT = <++,K_{one},<**,K_{'a},I>>                        *)
    6.68 -(* ----------------------------------------------------------------------- *)
    6.69 -(* dlist_abs is an isomorphism with inverse dlist_rep                      *)
    6.70 -(* identity is the least endomorphism on 'a dlist                          *)
    6.71 -
    6.72 -dlist_abs_iso	"dlist_rep`(dlist_abs`x) = x"
    6.73 -dlist_rep_iso	"dlist_abs`(dlist_rep`x) = x"
    6.74 -dlist_copy_def	"dlist_copy == (LAM f. dlist_abs oo \
    6.75 -\ 		(sswhen`sinl`(sinr oo (ssplit`(LAM x y. (|x,f`y|) ))))\
    6.76 -\                                oo dlist_rep)"
    6.77 -dlist_reach	"(fix`dlist_copy)`x=x"
    6.78 -
    6.79 -
    6.80 -defs
    6.81 -(* ----------------------------------------------------------------------- *)
    6.82 -(* properties of additional constants                                      *)
    6.83 -(* ----------------------------------------------------------------------- *)
    6.84 -(* constructors                                                            *)
    6.85 -
    6.86 -dnil_def	"dnil  == dlist_abs`(sinl`one)"
    6.87 -dcons_def	"dcons == (LAM x l. dlist_abs`(sinr`(|x,l|) ))"
    6.88 -
    6.89 -(* ----------------------------------------------------------------------- *)
    6.90 -(* discriminator functional                                                *)
    6.91 -
    6.92 -dlist_when_def 
    6.93 -"dlist_when == (LAM f1 f2 l.\
    6.94 -\   sswhen`(LAM x.f1) `(ssplit`(LAM x l.f2`x`l)) `(dlist_rep`l))"
    6.95 -
    6.96 -(* ----------------------------------------------------------------------- *)
    6.97 -(* discriminators and selectors                                            *)
    6.98 -
    6.99 -is_dnil_def	"is_dnil  == dlist_when`TT`(LAM x l.FF)"
   6.100 -is_dcons_def	"is_dcons == dlist_when`FF`(LAM x l.TT)"
   6.101 -dhd_def		"dhd == dlist_when`UU`(LAM x l.x)"
   6.102 -dtl_def		"dtl == dlist_when`UU`(LAM x l.l)"
   6.103 -
   6.104 -(* ----------------------------------------------------------------------- *)
   6.105 -(* the taker for dlists                                                   *)
   6.106 -
   6.107 -dlist_take_def "dlist_take == (%n.iterate n dlist_copy UU)"
   6.108 -
   6.109 -(* ----------------------------------------------------------------------- *)
   6.110 -
   6.111 -dlist_finite_def	"dlist_finite == (%s.? n.dlist_take n`s=s)"
   6.112 -
   6.113 -(* ----------------------------------------------------------------------- *)
   6.114 -(* definition of bisimulation is determined by domain equation             *)
   6.115 -(* simplification and rewriting for abstract constants yields def below    *)
   6.116 -
   6.117 -dlist_bisim_def "dlist_bisim ==
   6.118 - ( %R.!l1 l2.
   6.119 - 	R l1 l2 -->
   6.120 -  ((l1=UU & l2=UU) |
   6.121 -   (l1=dnil & l2=dnil) |
   6.122 -   (? x l11 l21. x~=UU & l11~=UU & l21~=UU & 
   6.123 -               l1=dcons`x`l11 & l2 = dcons`x`l21 & R l11 l21)))"
   6.124 -
   6.125 -end
   6.126 -
   6.127 -
   6.128 -
   6.129 -
     7.1 --- a/src/HOLCF/Dnat.ML	Fri Oct 06 16:17:08 1995 +0100
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,534 +0,0 @@
     7.4 -(*  Title: 	HOLCF/dnat.ML
     7.5 -    ID:         $Id$
     7.6 -    Author: 	Franz Regensburger
     7.7 -    Copyright   1993 Technische Universitaet Muenchen
     7.8 -
     7.9 -Lemmas for dnat.thy 
    7.10 -*)
    7.11 -
    7.12 -open Dnat;
    7.13 -
    7.14 -(* ------------------------------------------------------------------------*)
    7.15 -(* The isomorphisms dnat_rep_iso and dnat_abs_iso are strict               *)
    7.16 -(* ------------------------------------------------------------------------*)
    7.17 -
    7.18 -val dnat_iso_strict = dnat_rep_iso RS (dnat_abs_iso RS 
    7.19 -	(allI  RSN (2,allI RS iso_strict)));
    7.20 -
    7.21 -val dnat_rews = [dnat_iso_strict RS conjunct1,
    7.22 -		dnat_iso_strict RS conjunct2];
    7.23 -
    7.24 -(* ------------------------------------------------------------------------*)
    7.25 -(* Properties of dnat_copy                                                 *)
    7.26 -(* ------------------------------------------------------------------------*)
    7.27 -
    7.28 -fun prover defs thm =  prove_goalw Dnat.thy defs thm
    7.29 - (fn prems =>
    7.30 -	[
    7.31 -	(cut_facts_tac prems 1),
    7.32 -	(asm_simp_tac (!simpset addsimps 
    7.33 -		(dnat_rews @ [dnat_abs_iso,dnat_rep_iso])) 1)
    7.34 -	]);
    7.35 -
    7.36 -val dnat_copy = 
    7.37 -	[
    7.38 -	prover [dnat_copy_def] "dnat_copy`f`UU=UU",
    7.39 -	prover [dnat_copy_def,dzero_def] "dnat_copy`f`dzero= dzero",
    7.40 -	prover [dnat_copy_def,dsucc_def] 
    7.41 -		"n~=UU ==> dnat_copy`f`(dsucc`n) = dsucc`(f`n)"
    7.42 -	];
    7.43 -
    7.44 -val dnat_rews =  dnat_copy @ dnat_rews; 
    7.45 -
    7.46 -(* ------------------------------------------------------------------------*)
    7.47 -(* Exhaustion and elimination for dnat                                     *)
    7.48 -(* ------------------------------------------------------------------------*)
    7.49 -
    7.50 -qed_goalw "Exh_dnat" Dnat.thy [dsucc_def,dzero_def]
    7.51 -	"n = UU | n = dzero | (? x . x~=UU & n = dsucc`x)"
    7.52 - (fn prems =>
    7.53 -	[
    7.54 -	(Simp_tac  1),
    7.55 -	(rtac (dnat_rep_iso RS subst) 1),
    7.56 -	(res_inst_tac [("p","dnat_rep`n")] ssumE 1),
    7.57 -	(rtac disjI1 1),
    7.58 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
    7.59 -	(rtac (disjI1 RS disjI2) 1),
    7.60 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
    7.61 -	(res_inst_tac [("p","x")] oneE 1),
    7.62 -	(contr_tac 1),
    7.63 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
    7.64 -	(rtac (disjI2 RS disjI2) 1),
    7.65 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
    7.66 -	(fast_tac HOL_cs 1)
    7.67 -	]);
    7.68 -
    7.69 -qed_goal "dnatE" Dnat.thy 
    7.70 - "[| n=UU ==> Q; n=dzero ==> Q; !!x.[|n=dsucc`x;x~=UU|]==>Q|]==>Q"
    7.71 - (fn prems =>
    7.72 -	[
    7.73 -	(rtac (Exh_dnat RS disjE) 1),
    7.74 -	(eresolve_tac prems 1),
    7.75 -	(etac disjE 1),
    7.76 -	(eresolve_tac prems 1),
    7.77 -	(REPEAT (etac exE 1)),
    7.78 -	(resolve_tac prems 1),
    7.79 -	(fast_tac HOL_cs 1),
    7.80 -	(fast_tac HOL_cs 1)
    7.81 -	]);
    7.82 -
    7.83 -(* ------------------------------------------------------------------------*)
    7.84 -(* Properties of dnat_when                                                 *)
    7.85 -(* ------------------------------------------------------------------------*)
    7.86 -
    7.87 -fun prover defs thm =  prove_goalw Dnat.thy defs thm
    7.88 - (fn prems =>
    7.89 -	[
    7.90 -	(cut_facts_tac prems 1),
    7.91 -	(asm_simp_tac (!simpset addsimps 
    7.92 -		(dnat_rews @ [dnat_abs_iso,dnat_rep_iso])) 1)
    7.93 -	]);
    7.94 -
    7.95 -
    7.96 -val dnat_when = [
    7.97 -	prover [dnat_when_def] "dnat_when`c`f`UU=UU",
    7.98 -	prover [dnat_when_def,dzero_def] "dnat_when`c`f`dzero=c",
    7.99 -	prover [dnat_when_def,dsucc_def] 
   7.100 -		"n~=UU ==> dnat_when`c`f`(dsucc`n)=f`n"
   7.101 -	];
   7.102 -
   7.103 -val dnat_rews = dnat_when @ dnat_rews;
   7.104 -
   7.105 -(* ------------------------------------------------------------------------*)
   7.106 -(* Rewrites for  discriminators and  selectors                             *)
   7.107 -(* ------------------------------------------------------------------------*)
   7.108 -
   7.109 -fun prover defs thm = prove_goalw Dnat.thy defs thm
   7.110 - (fn prems =>
   7.111 -	[
   7.112 -	(simp_tac (!simpset addsimps dnat_rews) 1)
   7.113 -	]);
   7.114 -
   7.115 -val dnat_discsel = [
   7.116 -	prover [is_dzero_def] "is_dzero`UU=UU",
   7.117 -	prover [is_dsucc_def] "is_dsucc`UU=UU",
   7.118 -	prover [dpred_def] "dpred`UU=UU"
   7.119 -	];
   7.120 -
   7.121 -
   7.122 -fun prover defs thm = prove_goalw Dnat.thy defs thm
   7.123 - (fn prems =>
   7.124 -	[
   7.125 -	(cut_facts_tac prems 1),
   7.126 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
   7.127 -	]);
   7.128 -
   7.129 -val dnat_discsel = [
   7.130 -	prover [is_dzero_def] "is_dzero`dzero=TT",
   7.131 -	prover [is_dzero_def] "n~=UU ==>is_dzero`(dsucc`n)=FF",
   7.132 -	prover [is_dsucc_def] "is_dsucc`dzero=FF",
   7.133 -	prover [is_dsucc_def] "n~=UU ==> is_dsucc`(dsucc`n)=TT",
   7.134 -	prover [dpred_def] "dpred`dzero=UU",
   7.135 -	prover [dpred_def] "n~=UU ==> dpred`(dsucc`n)=n"
   7.136 -	] @ dnat_discsel;
   7.137 -
   7.138 -val dnat_rews = dnat_discsel @ dnat_rews;
   7.139 -
   7.140 -(* ------------------------------------------------------------------------*)
   7.141 -(* Definedness and strictness                                              *)
   7.142 -(* ------------------------------------------------------------------------*)
   7.143 -
   7.144 -fun prover contr thm = prove_goal Dnat.thy thm
   7.145 - (fn prems =>
   7.146 -	[
   7.147 -	(res_inst_tac [("P1",contr)] classical3 1),
   7.148 -	(simp_tac (!simpset addsimps dnat_rews) 1),
   7.149 -	(dtac sym 1),
   7.150 -	(Asm_simp_tac  1),
   7.151 -	(simp_tac (!simpset addsimps (prems @ dnat_rews)) 1)
   7.152 -	]);
   7.153 -
   7.154 -val dnat_constrdef = [
   7.155 -	prover "is_dzero`UU ~= UU" "dzero~=UU",
   7.156 -	prover "is_dsucc`UU ~= UU" "n~=UU ==> dsucc`n~=UU"
   7.157 -	]; 
   7.158 -
   7.159 -
   7.160 -fun prover defs thm = prove_goalw Dnat.thy defs thm
   7.161 - (fn prems =>
   7.162 -	[
   7.163 -	(simp_tac (!simpset addsimps dnat_rews) 1)
   7.164 -	]);
   7.165 -
   7.166 -val dnat_constrdef = [
   7.167 -	prover [dsucc_def] "dsucc`UU=UU"
   7.168 -	] @ dnat_constrdef;
   7.169 -
   7.170 -val dnat_rews = dnat_constrdef @ dnat_rews;
   7.171 -
   7.172 -
   7.173 -(* ------------------------------------------------------------------------*)
   7.174 -(* Distinctness wrt. << and =                                              *)
   7.175 -(* ------------------------------------------------------------------------*)
   7.176 -
   7.177 -val temp = prove_goal Dnat.thy  "~dzero << dsucc`n"
   7.178 - (fn prems =>
   7.179 -	[
   7.180 -	(res_inst_tac [("P1","TT << FF")] classical3 1),
   7.181 -	(resolve_tac dist_less_tr 1),
   7.182 -	(dres_inst_tac [("fo5","is_dzero")] monofun_cfun_arg 1),
   7.183 -	(etac box_less 1),
   7.184 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.185 -	(res_inst_tac [("Q","n=UU")] classical2 1),
   7.186 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.187 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
   7.188 -	]);
   7.189 -
   7.190 -val dnat_dist_less = [temp];
   7.191 -
   7.192 -val temp = prove_goal Dnat.thy  "n~=UU ==> ~dsucc`n << dzero"
   7.193 - (fn prems =>
   7.194 -	[
   7.195 -	(cut_facts_tac prems 1),
   7.196 -	(res_inst_tac [("P1","TT << FF")] classical3 1),
   7.197 -	(resolve_tac dist_less_tr 1),
   7.198 -	(dres_inst_tac [("fo5","is_dsucc")] monofun_cfun_arg 1),
   7.199 -	(etac box_less 1),
   7.200 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.201 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
   7.202 -	]);
   7.203 -
   7.204 -val dnat_dist_less = temp::dnat_dist_less;
   7.205 -
   7.206 -val temp = prove_goal Dnat.thy   "dzero ~= dsucc`n"
   7.207 - (fn prems =>
   7.208 -	[
   7.209 -	(res_inst_tac [("Q","n=UU")] classical2 1),
   7.210 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.211 -	(res_inst_tac [("P1","TT = FF")] classical3 1),
   7.212 -	(resolve_tac dist_eq_tr 1),
   7.213 -	(dres_inst_tac [("f","is_dzero")] cfun_arg_cong 1),
   7.214 -	(etac box_equals 1),
   7.215 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.216 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
   7.217 -	]);
   7.218 -
   7.219 -val dnat_dist_eq = [temp, temp RS not_sym];
   7.220 -
   7.221 -val dnat_rews = dnat_dist_less @ dnat_dist_eq @ dnat_rews;
   7.222 -
   7.223 -(* ------------------------------------------------------------------------*)
   7.224 -(* Invertibility                                                           *)
   7.225 -(* ------------------------------------------------------------------------*)
   7.226 -
   7.227 -val dnat_invert = 
   7.228 -	[
   7.229 -prove_goal Dnat.thy 
   7.230 -"[|x1~=UU; y1~=UU; dsucc`x1 << dsucc`y1 |] ==> x1<< y1"
   7.231 - (fn prems =>
   7.232 -	[
   7.233 -	(cut_facts_tac prems 1),
   7.234 -	(dres_inst_tac [("fo5","dnat_when`c`(LAM x.x)")] monofun_cfun_arg 1),
   7.235 -	(etac box_less 1),
   7.236 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.237 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
   7.238 -	])
   7.239 -	];
   7.240 -
   7.241 -(* ------------------------------------------------------------------------*)
   7.242 -(* Injectivity                                                             *)
   7.243 -(* ------------------------------------------------------------------------*)
   7.244 -
   7.245 -val dnat_inject = 
   7.246 -	[
   7.247 -prove_goal Dnat.thy 
   7.248 -"[|x1~=UU; y1~=UU; dsucc`x1 = dsucc`y1 |] ==> x1= y1"
   7.249 - (fn prems =>
   7.250 -	[
   7.251 -	(cut_facts_tac prems 1),
   7.252 -	(dres_inst_tac [("f","dnat_when`c`(LAM x.x)")] cfun_arg_cong 1),
   7.253 -	(etac box_equals 1),
   7.254 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.255 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
   7.256 -	])
   7.257 -	];
   7.258 -
   7.259 -(* ------------------------------------------------------------------------*)
   7.260 -(* definedness for  discriminators and  selectors                          *)
   7.261 -(* ------------------------------------------------------------------------*)
   7.262 -
   7.263 -
   7.264 -fun prover thm = prove_goal Dnat.thy thm
   7.265 - (fn prems =>
   7.266 -	[
   7.267 -	(cut_facts_tac prems 1),
   7.268 -	(rtac dnatE 1),
   7.269 -	(contr_tac 1),
   7.270 -	(REPEAT (asm_simp_tac (!simpset addsimps dnat_rews) 1))
   7.271 -	]);
   7.272 -
   7.273 -val dnat_discsel_def = 
   7.274 -	[
   7.275 -	prover  "n~=UU ==> is_dzero`n ~= UU",
   7.276 -	prover  "n~=UU ==> is_dsucc`n ~= UU"
   7.277 -	];
   7.278 -
   7.279 -val dnat_rews = dnat_discsel_def @ dnat_rews;
   7.280 -
   7.281 - 
   7.282 -(* ------------------------------------------------------------------------*)
   7.283 -(* Properties dnat_take                                                    *)
   7.284 -(* ------------------------------------------------------------------------*)
   7.285 -val temp = prove_goalw Dnat.thy [dnat_take_def] "dnat_take n`UU = UU"
   7.286 - (fn prems =>
   7.287 -	[
   7.288 -	(res_inst_tac [("n","n")] natE 1),
   7.289 -	(Asm_simp_tac 1),
   7.290 -	(Asm_simp_tac 1),
   7.291 -	(simp_tac (!simpset addsimps dnat_rews) 1)
   7.292 -	]);
   7.293 -
   7.294 -val dnat_take = [temp];
   7.295 -
   7.296 -val temp = prove_goalw Dnat.thy [dnat_take_def] "dnat_take 0`xs = UU"
   7.297 - (fn prems =>
   7.298 -	[
   7.299 -	(Asm_simp_tac 1)
   7.300 -	]);
   7.301 -
   7.302 -val dnat_take = temp::dnat_take;
   7.303 -
   7.304 -val temp = prove_goalw Dnat.thy [dnat_take_def]
   7.305 -	"dnat_take (Suc n)`dzero=dzero"
   7.306 - (fn prems =>
   7.307 -	[
   7.308 -	(Asm_simp_tac 1),
   7.309 -	(simp_tac (!simpset addsimps dnat_rews) 1)
   7.310 -	]);
   7.311 -
   7.312 -val dnat_take = temp::dnat_take;
   7.313 -
   7.314 -val temp = prove_goalw Dnat.thy [dnat_take_def]
   7.315 -  "dnat_take (Suc n)`(dsucc`xs)=dsucc`(dnat_take n ` xs)"
   7.316 - (fn prems =>
   7.317 -	[
   7.318 -	(res_inst_tac [("Q","xs=UU")] classical2 1),
   7.319 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.320 -	(Asm_simp_tac 1),
   7.321 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.322 -	(res_inst_tac [("n","n")] natE 1),
   7.323 -	(Asm_simp_tac 1),
   7.324 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.325 -	(Asm_simp_tac 1),
   7.326 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.327 -	(Asm_simp_tac 1),
   7.328 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
   7.329 -	]);
   7.330 -
   7.331 -val dnat_take = temp::dnat_take;
   7.332 -
   7.333 -val dnat_rews = dnat_take @ dnat_rews;
   7.334 -
   7.335 -
   7.336 -(* ------------------------------------------------------------------------*)
   7.337 -(* take lemma for dnats                                                  *)
   7.338 -(* ------------------------------------------------------------------------*)
   7.339 -
   7.340 -fun prover reach defs thm  = prove_goalw Dnat.thy defs thm
   7.341 - (fn prems =>
   7.342 -	[
   7.343 -	(res_inst_tac [("t","s1")] (reach RS subst) 1),
   7.344 -	(res_inst_tac [("t","s2")] (reach RS subst) 1),
   7.345 -	(rtac (fix_def2 RS ssubst) 1),
   7.346 -	(rtac (contlub_cfun_fun RS ssubst) 1),
   7.347 -	(rtac is_chain_iterate 1),
   7.348 -	(rtac (contlub_cfun_fun RS ssubst) 1),
   7.349 -	(rtac is_chain_iterate 1),
   7.350 -	(rtac lub_equal 1),
   7.351 -	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
   7.352 -	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
   7.353 -	(rtac allI 1),
   7.354 -	(resolve_tac prems 1)
   7.355 -	]);
   7.356 -
   7.357 -val dnat_take_lemma = prover dnat_reach  [dnat_take_def]
   7.358 -	"(!!n.dnat_take n`s1 = dnat_take n`s2) ==> s1=s2";
   7.359 -
   7.360 -
   7.361 -(* ------------------------------------------------------------------------*)
   7.362 -(* Co -induction for dnats                                                 *)
   7.363 -(* ------------------------------------------------------------------------*)
   7.364 -
   7.365 -qed_goalw "dnat_coind_lemma" Dnat.thy [dnat_bisim_def] 
   7.366 -"dnat_bisim R ==> ! p q. R p q --> dnat_take n`p = dnat_take n`q"
   7.367 - (fn prems =>
   7.368 -	[
   7.369 -	(cut_facts_tac prems 1),
   7.370 -	(nat_ind_tac "n" 1),
   7.371 -	(simp_tac (!simpset addsimps dnat_take) 1),
   7.372 -	(strip_tac 1),
   7.373 -	((etac allE 1) THEN (etac allE 1) THEN (etac (mp RS disjE) 1)),
   7.374 -	(atac 1),
   7.375 -	(asm_simp_tac (!simpset addsimps dnat_take) 1),
   7.376 -	(etac disjE 1),
   7.377 -	(asm_simp_tac (!simpset addsimps dnat_take) 1),
   7.378 -	(etac exE 1),
   7.379 -	(etac exE 1),
   7.380 -	(asm_simp_tac (!simpset addsimps dnat_take) 1),
   7.381 -	(REPEAT (etac conjE 1)),
   7.382 -	(rtac cfun_arg_cong 1),
   7.383 -	(fast_tac HOL_cs 1)
   7.384 -	]);
   7.385 -
   7.386 -qed_goal "dnat_coind" Dnat.thy "[|dnat_bisim R;R p q|] ==> p = q"
   7.387 - (fn prems =>
   7.388 -	[
   7.389 -	(rtac dnat_take_lemma 1),
   7.390 -	(rtac (dnat_coind_lemma RS spec RS spec RS mp) 1),
   7.391 -	(resolve_tac prems 1),
   7.392 -	(resolve_tac prems 1)
   7.393 -	]);
   7.394 -
   7.395 -
   7.396 -(* ------------------------------------------------------------------------*)
   7.397 -(* structural induction for admissible predicates                          *)
   7.398 -(* ------------------------------------------------------------------------*)
   7.399 -
   7.400 -(* not needed any longer
   7.401 -qed_goal "dnat_ind" Dnat.thy
   7.402 -"[| adm(P);\
   7.403 -\   P(UU);\
   7.404 -\   P(dzero);\
   7.405 -\   !! s1.[|s1~=UU ; P(s1)|] ==> P(dsucc`s1)|] ==> P(s)"
   7.406 - (fn prems =>
   7.407 -	[
   7.408 -	(rtac (dnat_reach RS subst) 1),
   7.409 -	(res_inst_tac [("x","s")] spec 1),
   7.410 -	(rtac fix_ind 1),
   7.411 -	(rtac adm_all2 1),
   7.412 -	(rtac adm_subst 1),
   7.413 -	(cont_tacR 1),
   7.414 -	(resolve_tac prems 1),
   7.415 -	(Simp_tac 1),
   7.416 -	(resolve_tac prems 1),
   7.417 -	(strip_tac 1),
   7.418 -	(res_inst_tac [("n","xa")] dnatE 1),
   7.419 -	(asm_simp_tac (!simpset addsimps dnat_copy) 1),
   7.420 -	(resolve_tac prems 1),
   7.421 -	(asm_simp_tac (!simpset addsimps dnat_copy) 1),
   7.422 -	(resolve_tac prems 1),
   7.423 -	(asm_simp_tac (!simpset addsimps dnat_copy) 1),
   7.424 -	(res_inst_tac [("Q","x`xb=UU")] classical2 1),
   7.425 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.426 -	(resolve_tac prems 1),
   7.427 -	(eresolve_tac prems 1),
   7.428 -	(etac spec 1)
   7.429 -	]);
   7.430 -*)
   7.431 -
   7.432 -qed_goal "dnat_finite_ind" Dnat.thy
   7.433 -"[|P(UU);P(dzero);\
   7.434 -\  !! s1.[|s1~=UU;P(s1)|] ==> P(dsucc`s1)\
   7.435 -\  |] ==> !s.P(dnat_take n`s)"
   7.436 - (fn prems =>
   7.437 -	[
   7.438 -	(nat_ind_tac "n" 1),
   7.439 -	(simp_tac (!simpset addsimps dnat_rews) 1),
   7.440 -	(resolve_tac prems 1),
   7.441 -	(rtac allI 1),
   7.442 -	(res_inst_tac [("n","s")] dnatE 1),
   7.443 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.444 -	(resolve_tac prems 1),
   7.445 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.446 -	(resolve_tac prems 1),
   7.447 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.448 -	(res_inst_tac [("Q","dnat_take n1`x=UU")] classical2 1),
   7.449 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.450 -	(resolve_tac prems 1),
   7.451 -	(resolve_tac prems 1),
   7.452 -	(atac 1),
   7.453 -	(etac spec 1)
   7.454 -	]);
   7.455 -
   7.456 -qed_goal "dnat_all_finite_lemma1" Dnat.thy
   7.457 -"!s.dnat_take n`s=UU |dnat_take n`s=s"
   7.458 - (fn prems =>
   7.459 -	[
   7.460 -	(nat_ind_tac "n" 1),
   7.461 -	(simp_tac (!simpset addsimps dnat_rews) 1),
   7.462 -	(rtac allI 1),
   7.463 -	(res_inst_tac [("n","s")] dnatE 1),
   7.464 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.465 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.466 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.467 -	(eres_inst_tac [("x","x")] allE 1),
   7.468 -	(etac disjE 1),
   7.469 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.470 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
   7.471 -	]);
   7.472 -
   7.473 -qed_goal "dnat_all_finite_lemma2" Dnat.thy "? n.dnat_take n`s=s"
   7.474 - (fn prems =>
   7.475 -	[
   7.476 -	(res_inst_tac [("Q","s=UU")] classical2 1),
   7.477 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.478 -	(subgoal_tac "(!n.dnat_take(n)`s=UU) |(? n.dnat_take(n)`s=s)" 1),
   7.479 -	(etac disjE 1),
   7.480 -	(eres_inst_tac [("P","s=UU")] notE 1),
   7.481 -	(rtac dnat_take_lemma 1),
   7.482 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.483 -	(atac 1),
   7.484 -	(subgoal_tac "!n.!s.dnat_take(n)`s=UU |dnat_take(n)`s=s" 1),
   7.485 -	(fast_tac HOL_cs 1),
   7.486 -	(rtac allI 1),
   7.487 -	(rtac dnat_all_finite_lemma1 1)
   7.488 -	]);
   7.489 -
   7.490 -
   7.491 -qed_goal "dnat_ind" Dnat.thy
   7.492 -"[|P(UU);P(dzero);\
   7.493 -\  !! s1.[|s1~=UU;P(s1)|] ==> P(dsucc`s1)\
   7.494 -\  |] ==> P(s)"
   7.495 - (fn prems =>
   7.496 -	[
   7.497 -	(rtac (dnat_all_finite_lemma2 RS exE) 1),
   7.498 -	(etac subst 1),
   7.499 -	(rtac (dnat_finite_ind RS spec) 1),
   7.500 -	(REPEAT (resolve_tac prems 1)),
   7.501 -	(REPEAT (atac 1))
   7.502 -	]);
   7.503 -
   7.504 -
   7.505 -qed_goalw "dnat_flat" Dnat.thy [flat_def] "flat(dzero)"
   7.506 - (fn prems =>
   7.507 -	[
   7.508 -	(rtac allI 1),
   7.509 -	(res_inst_tac [("s","x")] dnat_ind 1),
   7.510 -	(fast_tac HOL_cs 1),
   7.511 -	(rtac allI 1),
   7.512 -	(res_inst_tac [("n","y")] dnatE 1),
   7.513 -	(fast_tac (HOL_cs addSIs [UU_I]) 1),
   7.514 -	(Asm_simp_tac 1),
   7.515 -	(asm_simp_tac (!simpset addsimps dnat_dist_less) 1),
   7.516 -	(rtac allI 1),
   7.517 -	(res_inst_tac [("n","y")] dnatE 1),
   7.518 -	(fast_tac (HOL_cs addSIs [UU_I]) 1),
   7.519 -	(asm_simp_tac (!simpset addsimps dnat_dist_less) 1),
   7.520 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   7.521 -	(strip_tac 1),
   7.522 -	(subgoal_tac "s1<<xa" 1),
   7.523 -	(etac allE 1),
   7.524 -	(dtac mp 1),
   7.525 -	(atac 1),
   7.526 -	(etac disjE 1),
   7.527 -	(contr_tac 1),
   7.528 -	(Asm_simp_tac 1),
   7.529 -	(resolve_tac  dnat_invert 1),
   7.530 -	(REPEAT (atac 1))
   7.531 -	]);
   7.532 -
   7.533 -
   7.534 -
   7.535 -
   7.536 -
   7.537 -
     8.1 --- a/src/HOLCF/Dnat.thy	Fri Oct 06 16:17:08 1995 +0100
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,110 +0,0 @@
     8.4 -(*  Title: 	HOLCF/dnat.thy
     8.5 -    ID:         $Id$
     8.6 -    Author: 	Franz Regensburger
     8.7 -    Copyright   1993 Technische Universitaet Muenchen
     8.8 -
     8.9 -Theory for the domain of natural numbers  dnat = one ++ dnat
    8.10 -
    8.11 -The type is axiomatized as the least solution of the domain equation above.
    8.12 -The functor term that specifies the domain equation is: 
    8.13 -
    8.14 -  FT = <++,K_{one},I>
    8.15 -
    8.16 -For details see chapter 5 of:
    8.17 -
    8.18 -[Franz Regensburger] HOLCF: Eine konservative Erweiterung von HOL um LCF,
    8.19 -                     Dissertation, Technische Universit"at M"unchen, 1994
    8.20 -
    8.21 -*)
    8.22 -
    8.23 -Dnat = HOLCF +
    8.24 -
    8.25 -types dnat 0
    8.26 -
    8.27 -(* ----------------------------------------------------------------------- *)
    8.28 -(* arrity axiom is valuated by semantical reasoning                        *)
    8.29 -
    8.30 -arities dnat::pcpo
    8.31 -
    8.32 -consts
    8.33 -
    8.34 -(* ----------------------------------------------------------------------- *)
    8.35 -(* essential constants                                                     *)
    8.36 -
    8.37 -dnat_rep	:: " dnat -> (one ++ dnat)"
    8.38 -dnat_abs	:: "(one ++ dnat) -> dnat"
    8.39 -
    8.40 -(* ----------------------------------------------------------------------- *)
    8.41 -(* abstract constants and auxiliary constants                              *)
    8.42 -
    8.43 -dnat_copy	:: "(dnat -> dnat) -> dnat -> dnat"
    8.44 -
    8.45 -dzero		:: "dnat"
    8.46 -dsucc		:: "dnat -> dnat"
    8.47 -dnat_when	:: "'b -> (dnat -> 'b) -> dnat -> 'b"
    8.48 -is_dzero	:: "dnat -> tr"
    8.49 -is_dsucc	:: "dnat -> tr"
    8.50 -dpred		:: "dnat -> dnat"
    8.51 -dnat_take	:: "nat => dnat -> dnat"
    8.52 -dnat_bisim	:: "(dnat => dnat => bool) => bool"
    8.53 -
    8.54 -rules
    8.55 -
    8.56 -(* ----------------------------------------------------------------------- *)
    8.57 -(* axiomatization of recursive type dnat                                   *)
    8.58 -(* ----------------------------------------------------------------------- *)
    8.59 -(* (dnat,dnat_abs) is the initial F-algebra where                          *)
    8.60 -(* F is the locally continuous functor determined by functor term FT.      *)
    8.61 -(* domain equation: dnat = one ++ dnat                                     *)
    8.62 -(* functor term:    FT = <++,K_{one},I>                                    *) 
    8.63 -(* ----------------------------------------------------------------------- *)
    8.64 -(* dnat_abs is an isomorphism with inverse dnat_rep                        *)
    8.65 -(* identity is the least endomorphism on dnat                              *)
    8.66 -
    8.67 -dnat_abs_iso	"dnat_rep`(dnat_abs`x) = x"
    8.68 -dnat_rep_iso	"dnat_abs`(dnat_rep`x) = x"
    8.69 -dnat_copy_def	"dnat_copy == (LAM f. dnat_abs oo 
    8.70 -		 (sswhen`sinl`(sinr oo f)) oo dnat_rep )"
    8.71 -dnat_reach	"(fix`dnat_copy)`x=x"
    8.72 -
    8.73 -
    8.74 -defs
    8.75 -(* ----------------------------------------------------------------------- *)
    8.76 -(* properties of additional constants                                      *)
    8.77 -(* ----------------------------------------------------------------------- *)
    8.78 -(* constructors                                                            *)
    8.79 -
    8.80 -dzero_def	"dzero == dnat_abs`(sinl`one)"
    8.81 -dsucc_def	"dsucc == (LAM n. dnat_abs`(sinr`n))"
    8.82 -
    8.83 -(* ----------------------------------------------------------------------- *)
    8.84 -(* discriminator functional                                                *)
    8.85 -
    8.86 -dnat_when_def	"dnat_when == (LAM f1 f2 n.sswhen`(LAM x.f1)`f2`(dnat_rep`n))"
    8.87 -
    8.88 -
    8.89 -(* ----------------------------------------------------------------------- *)
    8.90 -(* discriminators and selectors                                            *)
    8.91 -
    8.92 -is_dzero_def	"is_dzero == dnat_when`TT`(LAM x.FF)"
    8.93 -is_dsucc_def	"is_dsucc == dnat_when`FF`(LAM x.TT)"
    8.94 -dpred_def	"dpred == dnat_when`UU`(LAM x.x)"
    8.95 -
    8.96 -
    8.97 -(* ----------------------------------------------------------------------- *)
    8.98 -(* the taker for dnats                                                   *)
    8.99 -
   8.100 -dnat_take_def "dnat_take == (%n.iterate n dnat_copy UU)"
   8.101 -
   8.102 -(* ----------------------------------------------------------------------- *)
   8.103 -(* definition of bisimulation is determined by domain equation             *)
   8.104 -(* simplification and rewriting for abstract constants yields def below    *)
   8.105 -
   8.106 -dnat_bisim_def "dnat_bisim ==
   8.107 -(%R.!s1 s2.
   8.108 - 	R s1 s2 -->
   8.109 -  ((s1=UU & s2=UU) |(s1=dzero & s2=dzero) |
   8.110 -  (? s11 s21. s11~=UU & s21~=UU & s1=dsucc`s11 &
   8.111 -		 s2 = dsucc`s21 & R s11 s21)))"
   8.112 -
   8.113 -end
     9.1 --- a/src/HOLCF/Dnat2.ML	Fri Oct 06 16:17:08 1995 +0100
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,52 +0,0 @@
     9.4 -(*  Title: 	HOLCF/dnat2.ML
     9.5 -    ID:         $Id$
     9.6 -    Author: 	Franz Regensburger
     9.7 -    Copyright   1993 Technische Universitaet Muenchen
     9.8 -
     9.9 -Lemmas for theory Dnat2.thy
    9.10 -*)
    9.11 -
    9.12 -open Dnat2;
    9.13 -
    9.14 -
    9.15 -(* ------------------------------------------------------------------------- *)
    9.16 -(* expand fixed point properties                                             *)
    9.17 -(* ------------------------------------------------------------------------- *)
    9.18 -
    9.19 -val iterator_def2 = fix_prover2 Dnat2.thy iterator_def 
    9.20 -	"iterator = (LAM n f x. dnat_when`x`(LAM m.f`(iterator`m`f`x)) `n)";
    9.21 -
    9.22 -(* ------------------------------------------------------------------------- *)
    9.23 -(* recursive  properties                                                     *)
    9.24 -(* ------------------------------------------------------------------------- *)
    9.25 -
    9.26 -qed_goal "iterator1" Dnat2.thy "iterator`UU`f`x = UU"
    9.27 - (fn prems =>
    9.28 -	[
    9.29 -	(rtac (iterator_def2 RS ssubst) 1),
    9.30 -	(simp_tac (!simpset addsimps dnat_when) 1)
    9.31 -	]);
    9.32 -
    9.33 -qed_goal "iterator2" Dnat2.thy "iterator`dzero`f`x = x"
    9.34 - (fn prems =>
    9.35 -	[
    9.36 -	(rtac (iterator_def2 RS ssubst) 1),
    9.37 -	(simp_tac (!simpset addsimps dnat_when) 1)
    9.38 -	]);
    9.39 -
    9.40 -qed_goal "iterator3" Dnat2.thy 
    9.41 -"n~=UU ==> iterator`(dsucc`n)`f`x = f`(iterator`n`f`x)"
    9.42 - (fn prems =>
    9.43 -	[
    9.44 -	(cut_facts_tac prems 1),
    9.45 -	(rtac trans 1),
    9.46 -	(rtac (iterator_def2 RS ssubst) 1),
    9.47 -	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
    9.48 -	(rtac refl 1)
    9.49 -	]);
    9.50 -
    9.51 -val dnat2_rews = 
    9.52 -	[iterator1, iterator2, iterator3];
    9.53 -
    9.54 -
    9.55 -
    10.1 --- a/src/HOLCF/Dnat2.thy	Fri Oct 06 16:17:08 1995 +0100
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,29 +0,0 @@
    10.4 -(*  Title: 	HOLCF/dnat2.thy
    10.5 -    ID:         $Id$
    10.6 -    Author: 	Franz Regensburger
    10.7 -    Copyright   1993 Technische Universitaet Muenchen
    10.8 -
    10.9 -Additional constants for dnat
   10.10 -
   10.11 -*)
   10.12 -
   10.13 -Dnat2 = Dnat +
   10.14 -
   10.15 -consts
   10.16 -
   10.17 -iterator	:: "dnat -> ('a -> 'a) -> 'a -> 'a"
   10.18 -
   10.19 -
   10.20 -defs
   10.21 -
   10.22 -iterator_def	"iterator == fix`(LAM h n f x.
   10.23 -			dnat_when `x `(LAM m.f`(h`m`f`x)) `n)"
   10.24 -end
   10.25 -
   10.26 -(*
   10.27 -
   10.28 -		iterator`UU`f`x = UU
   10.29 -		iterator`dzero`f`x = x
   10.30 -      n~=UU --> iterator`(dsucc`n)`f`x = f`(iterator`n`f`x)
   10.31 -*)
   10.32 -
    11.1 --- a/src/HOLCF/Fix.ML	Fri Oct 06 16:17:08 1995 +0100
    11.2 +++ b/src/HOLCF/Fix.ML	Fri Oct 06 17:25:24 1995 +0100
    11.3 @@ -341,6 +341,19 @@
    11.4  	]);
    11.5  
    11.6  
    11.7 +qed_goal "fix_eqI" Fix.thy
    11.8 +"[| F`x = x; !z. F`z = z --> x << z |] ==> x = fix`F"
    11.9 + (fn prems =>
   11.10 +	[
   11.11 +	(cut_facts_tac prems 1),
   11.12 +	(rtac antisym_less 1),
   11.13 +	(etac allE 1),
   11.14 +	(etac mp 1),
   11.15 +	(rtac (fix_eq RS sym) 1),
   11.16 +	(etac fix_least 1)
   11.17 +	]);
   11.18 +
   11.19 +
   11.20  qed_goal "fix_eq2" Fix.thy "f == fix`F ==> f = F`f"
   11.21   (fn prems =>
   11.22  	[
    12.1 --- a/src/HOLCF/HOLCF.ML	Fri Oct 06 16:17:08 1995 +0100
    12.2 +++ b/src/HOLCF/HOLCF.ML	Fri Oct 06 17:25:24 1995 +0100
    12.3 @@ -8,3 +8,5 @@
    12.4  
    12.5  Addsimps (one_when @ dist_less_one @ dist_eq_one @ dist_less_tr @ dist_eq_tr
    12.6            @ tr_when @ andalso_thms @ orelse_thms @ neg_thms @ ifte_thms);
    12.7 +
    12.8 +val HOLCF_ss = !simpset;
    13.1 --- a/src/HOLCF/HOLCF.thy	Fri Oct 06 16:17:08 1995 +0100
    13.2 +++ b/src/HOLCF/HOLCF.thy	Fri Oct 06 17:25:24 1995 +0100
    13.3 @@ -8,6 +8,5 @@
    13.4  
    13.5  *)
    13.6  
    13.7 -HOLCF = Tr2 
    13.8 +HOLCF = Tr2
    13.9  
   13.10 -
    14.1 --- a/src/HOLCF/Holcfb.thy	Fri Oct 06 16:17:08 1995 +0100
    14.2 +++ b/src/HOLCF/Holcfb.thy	Fri Oct 06 17:25:24 1995 +0100
    14.3 @@ -10,16 +10,12 @@
    14.4  Holcfb = Nat + 
    14.5  
    14.6  consts
    14.7 -
    14.8 -theleast     :: "(nat=>bool)=>nat"
    14.9 -
   14.10 +	theleast     :: "(nat=>bool)=>nat"
   14.11  defs
   14.12  
   14.13  theleast_def    "theleast P == (@z.(P z & (!n.P n --> z<=n)))"
   14.14  
   14.15 -end
   14.16 -
   14.17 +(* start 8bit 1 *)
   14.18 +(* end 8bit 1 *)
   14.19  
   14.20 -
   14.21 -
   14.22 -
   14.23 +end
    15.1 --- a/src/HOLCF/Lift3.ML	Fri Oct 06 16:17:08 1995 +0100
    15.2 +++ b/src/HOLCF/Lift3.ML	Fri Oct 06 17:25:24 1995 +0100
    15.3 @@ -347,3 +347,4 @@
    15.4  (* ------------------------------------------------------------------------ *)
    15.5  
    15.6  val lift_rews = [lift1,lift2,defined_up];
    15.7 +
    16.1 --- a/src/HOLCF/Lift3.thy	Fri Oct 06 16:17:08 1995 +0100
    16.2 +++ b/src/HOLCF/Lift3.thy	Fri Oct 06 17:25:24 1995 +0100
    16.3 @@ -24,6 +24,12 @@
    16.4  	up_def		"up     == (LAM x.Iup(x))"
    16.5  	lift_def	"lift   == (LAM f p.Ilift(f)(p))"
    16.6  
    16.7 +translations
    16.8 +"case l of up`x => t1" == "lift`(LAM x.t1)`l"
    16.9 +
   16.10 +(* start 8bit 1 *)
   16.11 +(* end 8bit 1 *)
   16.12 +
   16.13  end
   16.14  
   16.15  
    17.1 --- a/src/HOLCF/Makefile	Fri Oct 06 16:17:08 1995 +0100
    17.2 +++ b/src/HOLCF/Makefile	Fri Oct 06 17:25:24 1995 +0100
    17.3 @@ -23,8 +23,7 @@
    17.4         Sprod0.thy Sprod1.thy Sprod2.thy Sprod3.thy \
    17.5         Ssum0.thy Ssum1.thy Ssum2.thy Ssum3.thy \
    17.6         Lift1.thy Lift2.thy Lift3.thy Fix.thy ccc1.thy One.thy \
    17.7 -       Tr1.thy Tr2.thy HOLCF.thy Dnat.thy Dnat2.thy \
    17.8 -       Stream.thy Stream2.thy Dlist.thy 
    17.9 +       Tr1.thy Tr2.thy HOLCF.thy 
   17.10  
   17.11  FILES = ROOT.ML Porder0.thy  $(THYS) $(THYS:.thy=.ML)
   17.12  
    18.1 --- a/src/HOLCF/One.thy	Fri Oct 06 16:17:08 1995 +0100
    18.2 +++ b/src/HOLCF/One.thy	Fri Oct 06 17:25:24 1995 +0100
    18.3 @@ -35,6 +35,10 @@
    18.4  defs
    18.5    one_def	"one == abs_one`(up`UU)"
    18.6    one_when_def "one_when == (LAM c u.lift`(LAM x.c)`(rep_one`u))"
    18.7 +
    18.8 +translations
    18.9 +  "case l of one => t1" == "one_when`t1`l"
   18.10 +
   18.11  end
   18.12  
   18.13  
    19.1 --- a/src/HOLCF/Pcpo.thy	Fri Oct 06 16:17:08 1995 +0100
    19.2 +++ b/src/HOLCF/Pcpo.thy	Fri Oct 06 17:25:24 1995 +0100
    19.3 @@ -5,11 +5,14 @@
    19.4  
    19.5  consts	
    19.6  	UU :: "'a::pcpo"	
    19.7 +
    19.8  rules
    19.9  
   19.10 -minimal	"UU << x"	
   19.11 -cpo	"is_chain(S) ==> ? x. range(S) <<| (x::'a::pcpo)" 
   19.12 +	minimal	"UU << x"	
   19.13 +	cpo	"is_chain(S) ==> ? x. range(S) <<| (x::'a::pcpo)" 
   19.14  
   19.15  inst_void_pcpo	"(UU::void) = UU_void"
   19.16  
   19.17 +(* start 8bit 1 *)
   19.18 +(* end 8bit 1 *)
   19.19  end 
    20.1 --- a/src/HOLCF/Porder.thy	Fri Oct 06 16:17:08 1995 +0100
    20.2 +++ b/src/HOLCF/Porder.thy	Fri Oct 06 17:25:24 1995 +0100
    20.3 @@ -42,6 +42,9 @@
    20.4  
    20.5  lub		"lub(S) = (@x. S <<| x)"
    20.6  
    20.7 +(* start 8bit 1 *)
    20.8 +(* end 8bit 1 *)
    20.9 +
   20.10  end 
   20.11  
   20.12  
    21.1 --- a/src/HOLCF/Porder0.thy	Fri Oct 06 16:17:08 1995 +0100
    21.2 +++ b/src/HOLCF/Porder0.thy	Fri Oct 06 17:25:24 1995 +0100
    21.3 @@ -39,4 +39,12 @@
    21.4  
    21.5  inst_void_po	"((op <<)::[void,void]=>bool) = less_void"
    21.6  
    21.7 +(* start 8bit 1 *)
    21.8 +(* end 8bit 1 *)
    21.9 +
   21.10  end 
   21.11 +
   21.12 +
   21.13 +
   21.14 +
   21.15 +
    22.1 --- a/src/HOLCF/README	Fri Oct 06 16:17:08 1995 +0100
    22.2 +++ b/src/HOLCF/README	Fri Oct 06 17:25:24 1995 +0100
    22.3 @@ -2,10 +2,10 @@
    22.4  ==========================================================
    22.5  
    22.6  Author:     Franz Regensburger
    22.7 -Copyright   1993,1994 Technische Universitaet Muenchen
    22.8 +Copyright   1995 Technische Universitaet Muenchen
    22.9  
   22.10 -Version: 1.5
   22.11 -Date: 14.10.94
   22.12 +Version: 2.0
   22.13 +Date: 16.08.95
   22.14  
   22.15  A detailed description of the entire development can be found in 
   22.16  
   22.17 @@ -19,3 +19,6 @@
   22.18  28.06.95 The old uncurried version of HOLCF is no longer supported
   22.19  	 in the distribution.
   22.20   
   22.21 +18.08.95 added sections axioms, ops, domain, genertated
   22.22 +	 and 8bit support
   22.23 +
    23.1 --- a/src/HOLCF/ROOT.ML	Fri Oct 06 16:17:08 1995 +0100
    23.2 +++ b/src/HOLCF/ROOT.ML	Fri Oct 06 17:25:24 1995 +0100
    23.3 @@ -7,16 +7,37 @@
    23.4  Should be executed in subdirectory HOLCF.
    23.5  *)
    23.6  
    23.7 -val banner = "Higher-order Logic of Computable Functions; curried version";
    23.8 +val banner = "HOLCF with sections axioms,ops,domain,generated";
    23.9 +init_thy_reader();
   23.10 +
   23.11 +(* start 8bit 1 *)
   23.12 +(* end 8bit 1 *)
   23.13 +
   23.14  writeln banner;
   23.15  print_depth 1;
   23.16  
   23.17 -init_thy_reader();
   23.18 +use_thy "HOLCF";
   23.19 +
   23.20 +(* install sections: axioms, ops *)
   23.21 +
   23.22 +use "ax_ops/holcflogic.ML";
   23.23 +use "ax_ops/thy_axioms.ML";
   23.24 +use "ax_ops/thy_ops.ML";
   23.25 +use "ax_ops/thy_syntax.ML";
   23.26 +
   23.27 +
   23.28 +(* install sections: domain, generated *)
   23.29  
   23.30 -use_thy "Fix";
   23.31 -use_thy "Dlist";
   23.32 +use "domain/library";
   23.33 +use "domain/syntax";
   23.34 +use "domain/axioms";
   23.35 +use "domain/theorems";
   23.36 +use "domain/extender";
   23.37 +use "domain/interface";
   23.38  
   23.39 -use "../Pure/install_pp.ML";
   23.40 -print_depth 8;  
   23.41 +init_thy_reader();
   23.42 +init_pps ();
   23.43 +
   23.44 +print_depth 100;  
   23.45  
   23.46  val HOLCF_build_completed = ();	(*indicate successful build*)
    24.1 --- a/src/HOLCF/Sprod0.ML	Fri Oct 06 16:17:08 1995 +0100
    24.2 +++ b/src/HOLCF/Sprod0.ML	Fri Oct 06 17:25:24 1995 +0100
    24.3 @@ -343,7 +343,6 @@
    24.4  Addsimps [strict_Isfst1,strict_Isfst2,strict_Issnd1,strict_Issnd2,
    24.5  	  Isfst2,Issnd2];
    24.6  
    24.7 -
    24.8  qed_goal "defined_IsfstIssnd" Sprod0.thy 
    24.9  	"p~=Ispair UU UU ==> Isfst p ~= UU & Issnd p ~= UU"
   24.10   (fn prems =>
    25.1 --- a/src/HOLCF/Sprod0.thy	Fri Oct 06 16:17:08 1995 +0100
    25.2 +++ b/src/HOLCF/Sprod0.thy	Fri Oct 06 17:25:24 1995 +0100
    25.3 @@ -50,5 +50,8 @@
    25.4  					(p=Ispair UU UU  --> z=UU)
    25.5  		&(! a b. ~a=UU & ~b=UU & p=Ispair a b    --> z=b)"  
    25.6  
    25.7 +(* start 8bit 1 *)
    25.8 +(* end 8bit 1 *)
    25.9 +
   25.10  end
   25.11  
    26.1 --- a/src/HOLCF/Sprod3.ML	Fri Oct 06 16:17:08 1995 +0100
    26.2 +++ b/src/HOLCF/Sprod3.ML	Fri Oct 06 17:25:24 1995 +0100
    26.3 @@ -675,8 +675,10 @@
    26.4  (* install simplifier for Sprod                                             *)
    26.5  (* ------------------------------------------------------------------------ *)
    26.6  
    26.7 +val Sprod_rews = [strict_spair1,strict_spair2,strict_sfst1,strict_sfst2,
    26.8 +		strict_ssnd1,strict_ssnd2,sfst2,ssnd2,defined_spair,
    26.9 +		ssplit1,ssplit2];
   26.10 +
   26.11  Addsimps [strict_spair1,strict_spair2,strict_sfst1,strict_sfst2,
   26.12  	  strict_ssnd1,strict_ssnd2,sfst2,ssnd2,
   26.13  	  ssplit1,ssplit2];
   26.14 -
   26.15 -
    27.1 --- a/src/HOLCF/Sprod3.thy	Fri Oct 06 16:17:08 1995 +0100
    27.2 +++ b/src/HOLCF/Sprod3.thy	Fri Oct 06 17:25:24 1995 +0100
    27.3 @@ -33,6 +33,9 @@
    27.4  ssnd_def	"ssnd   == (LAM p.Issnd p)"	
    27.5  ssplit_def	"ssplit == (LAM f. strictify`(LAM p.f`(sfst`p)`(ssnd`p)))"
    27.6  
    27.7 +(* start 8bit 1 *)
    27.8 +(* end 8bit 1 *)
    27.9 +
   27.10  end
   27.11  
   27.12  
    28.1 --- a/src/HOLCF/Ssum0.ML	Fri Oct 06 16:17:08 1995 +0100
    28.2 +++ b/src/HOLCF/Ssum0.ML	Fri Oct 06 17:25:24 1995 +0100
    28.3 @@ -389,5 +389,3 @@
    28.4  (* ------------------------------------------------------------------------ *)
    28.5  
    28.6  Addsimps [(strict_IsinlIsinr RS sym),Iwhen1,Iwhen2,Iwhen3];
    28.7 -
    28.8 -
    29.1 --- a/src/HOLCF/Ssum0.thy	Fri Oct 06 16:17:08 1995 +0100
    29.2 +++ b/src/HOLCF/Ssum0.thy	Fri Oct 06 17:25:24 1995 +0100
    29.3 @@ -51,5 +51,7 @@
    29.4  			&(!a. a~=UU & s=Isinl(a) --> z=f`a)  
    29.5  			&(!b. b~=UU & s=Isinr(b) --> z=g`b)"  
    29.6  
    29.7 +(* start 8bit 1 *)
    29.8 +(* end 8bit 1 *)
    29.9  end
   29.10  
    30.1 --- a/src/HOLCF/Ssum3.ML	Fri Oct 06 16:17:08 1995 +0100
    30.2 +++ b/src/HOLCF/Ssum3.ML	Fri Oct 06 17:25:24 1995 +0100
    30.3 @@ -724,4 +724,8 @@
    30.4  (* install simplifier for Ssum                                              *)
    30.5  (* ------------------------------------------------------------------------ *)
    30.6  
    30.7 -Addsimps [strict_sinl,strict_sinr,sswhen1,sswhen2,sswhen3];
    30.8 +val Ssum_rews = [strict_sinl,strict_sinr,defined_sinl,defined_sinr,
    30.9 +		sswhen1,sswhen2,sswhen3];
   30.10 +
   30.11 +Addsimps [strict_sinl,strict_sinr,defined_sinl,defined_sinr,
   30.12 +		sswhen1,sswhen2,sswhen3];
    31.1 --- a/src/HOLCF/Ssum3.thy	Fri Oct 06 16:17:08 1995 +0100
    31.2 +++ b/src/HOLCF/Ssum3.thy	Fri Oct 06 17:25:24 1995 +0100
    31.3 @@ -26,4 +26,10 @@
    31.4  sinr_def	"sinr   == (LAM x.Isinr(x))"
    31.5  sswhen_def	"sswhen   == (LAM f g s.Iwhen(f)(g)(s))"
    31.6  
    31.7 +translations
    31.8 +"case s of sinl`x => t1 | sinr`y => t2" == "sswhen`(LAM x.t1)`(LAM y.t2)`s"
    31.9 +
   31.10 +(* start 8bit 1 *)
   31.11 +(* end 8bit 1 *)
   31.12 +
   31.13  end
    32.1 --- a/src/HOLCF/Stream.ML	Fri Oct 06 16:17:08 1995 +0100
    32.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    32.3 @@ -1,840 +0,0 @@
    32.4 -(*  Title: 	HOLCF/stream.ML
    32.5 -    ID:         $Id$
    32.6 -    Author: 	Franz Regensburger
    32.7 -    Copyright   1993 Technische Universitaet Muenchen
    32.8 -
    32.9 -Lemmas for stream.thy
   32.10 -*)
   32.11 -
   32.12 -open Stream;
   32.13 -
   32.14 -(* ------------------------------------------------------------------------*)
   32.15 -(* The isomorphisms stream_rep_iso and stream_abs_iso are strict           *)
   32.16 -(* ------------------------------------------------------------------------*)
   32.17 -
   32.18 -val stream_iso_strict= stream_rep_iso RS (stream_abs_iso RS 
   32.19 -	(allI  RSN (2,allI RS iso_strict)));
   32.20 -
   32.21 -val stream_rews = [stream_iso_strict RS conjunct1,
   32.22 -		stream_iso_strict RS conjunct2];
   32.23 -
   32.24 -(* ------------------------------------------------------------------------*)
   32.25 -(* Properties of stream_copy                                               *)
   32.26 -(* ------------------------------------------------------------------------*)
   32.27 -
   32.28 -fun prover defs thm =  prove_goalw Stream.thy defs thm
   32.29 - (fn prems =>
   32.30 -	[
   32.31 -	(cut_facts_tac prems 1),
   32.32 -	(asm_simp_tac (!simpset addsimps 
   32.33 -		(stream_rews @ [stream_abs_iso,stream_rep_iso])) 1)
   32.34 -	]);
   32.35 -
   32.36 -val stream_copy = 
   32.37 -	[
   32.38 -	prover [stream_copy_def] "stream_copy`f`UU=UU",
   32.39 -	prover [stream_copy_def,scons_def] 
   32.40 -	"x~=UU ==> stream_copy`f`(scons`x`xs)= scons`x`(f`xs)"
   32.41 -	];
   32.42 -
   32.43 -val stream_rews =  stream_copy @ stream_rews; 
   32.44 -
   32.45 -(* ------------------------------------------------------------------------*)
   32.46 -(* Exhaustion and elimination for streams                                  *)
   32.47 -(* ------------------------------------------------------------------------*)
   32.48 -
   32.49 -qed_goalw "Exh_stream" Stream.thy [scons_def]
   32.50 -	"s = UU | (? x xs. x~=UU & s = scons`x`xs)"
   32.51 - (fn prems =>
   32.52 -	[
   32.53 -	(Simp_tac 1),
   32.54 -	(rtac (stream_rep_iso RS subst) 1),
   32.55 -	(res_inst_tac [("p","stream_rep`s")] sprodE 1),
   32.56 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
   32.57 -	(Asm_simp_tac  1),
   32.58 -	(res_inst_tac [("p","y")] liftE1 1),
   32.59 -	(contr_tac 1),
   32.60 -	(rtac disjI2 1),
   32.61 -	(rtac exI 1),
   32.62 -	(rtac exI 1),
   32.63 -	(etac conjI 1),
   32.64 -	(Asm_simp_tac  1)
   32.65 -	]);
   32.66 -
   32.67 -qed_goal "streamE" Stream.thy 
   32.68 -	"[| s=UU ==> Q; !!x xs.[|s=scons`x`xs;x~=UU|]==>Q|]==>Q"
   32.69 - (fn prems =>
   32.70 -	[
   32.71 -	(rtac (Exh_stream RS disjE) 1),
   32.72 -	(eresolve_tac prems 1),
   32.73 -	(etac exE 1),
   32.74 -	(etac exE 1),
   32.75 -	(resolve_tac prems 1),
   32.76 -	(fast_tac HOL_cs 1),
   32.77 -	(fast_tac HOL_cs 1)
   32.78 -	]);
   32.79 -
   32.80 -(* ------------------------------------------------------------------------*)
   32.81 -(* Properties of stream_when                                               *)
   32.82 -(* ------------------------------------------------------------------------*)
   32.83 -
   32.84 -fun prover defs thm =  prove_goalw Stream.thy defs thm
   32.85 - (fn prems =>
   32.86 -	[
   32.87 -	(cut_facts_tac prems 1),
   32.88 -	(asm_simp_tac (!simpset addsimps 
   32.89 -		(stream_rews @ [stream_abs_iso,stream_rep_iso])) 1)
   32.90 -	]);
   32.91 -
   32.92 -
   32.93 -val stream_when = [
   32.94 -	prover [stream_when_def] "stream_when`f`UU=UU",
   32.95 -	prover [stream_when_def,scons_def] 
   32.96 -		"x~=UU ==> stream_when`f`(scons`x`xs)= f`x`xs"
   32.97 -	];
   32.98 -
   32.99 -val stream_rews = stream_when @ stream_rews;
  32.100 -
  32.101 -(* ------------------------------------------------------------------------*)
  32.102 -(* Rewrites for  discriminators and  selectors                             *)
  32.103 -(* ------------------------------------------------------------------------*)
  32.104 -
  32.105 -fun prover defs thm = prove_goalw Stream.thy defs thm
  32.106 - (fn prems =>
  32.107 -	[
  32.108 -	(simp_tac (!simpset addsimps stream_rews) 1)
  32.109 -	]);
  32.110 -
  32.111 -val stream_discsel = [
  32.112 -	prover [is_scons_def] "is_scons`UU=UU",
  32.113 -	prover [shd_def] "shd`UU=UU",
  32.114 -	prover [stl_def] "stl`UU=UU"
  32.115 -	];
  32.116 -
  32.117 -fun prover defs thm = prove_goalw Stream.thy defs thm
  32.118 - (fn prems =>
  32.119 -	[
  32.120 -	(cut_facts_tac prems 1),
  32.121 -	(asm_simp_tac (!simpset addsimps stream_rews) 1)
  32.122 -	]);
  32.123 -
  32.124 -val stream_discsel = [
  32.125 -prover [is_scons_def,shd_def,stl_def] "x~=UU ==> is_scons`(scons`x`xs)=TT",
  32.126 -prover [is_scons_def,shd_def,stl_def] "x~=UU ==> shd`(scons`x`xs)=x",
  32.127 -prover [is_scons_def,shd_def,stl_def] "x~=UU ==> stl`(scons`x`xs)=xs"
  32.128 -	] @ stream_discsel;
  32.129 -
  32.130 -val stream_rews = stream_discsel @ stream_rews;
  32.131 -
  32.132 -(* ------------------------------------------------------------------------*)
  32.133 -(* Definedness and strictness                                              *)
  32.134 -(* ------------------------------------------------------------------------*)
  32.135 -
  32.136 -fun prover contr thm = prove_goal Stream.thy thm
  32.137 - (fn prems =>
  32.138 -	[
  32.139 -	(res_inst_tac [("P1",contr)] classical3 1),
  32.140 -	(simp_tac (!simpset addsimps stream_rews) 1),
  32.141 -	(dtac sym 1),
  32.142 -	(Asm_simp_tac 1),
  32.143 -	(simp_tac (!simpset addsimps (prems @ stream_rews)) 1)
  32.144 -	]);
  32.145 -
  32.146 -val stream_constrdef = [
  32.147 -	prover "is_scons`(UU::'a stream)~=UU" "x~=UU ==> scons`(x::'a)`xs~=UU"
  32.148 -	]; 
  32.149 -
  32.150 -fun prover defs thm = prove_goalw Stream.thy defs thm
  32.151 - (fn prems =>
  32.152 -	[
  32.153 -	(simp_tac (!simpset addsimps stream_rews) 1)
  32.154 -	]);
  32.155 -
  32.156 -val stream_constrdef = [
  32.157 -	prover [scons_def] "scons`UU`xs=UU"
  32.158 -	] @ stream_constrdef;
  32.159 -
  32.160 -val stream_rews = stream_constrdef @ stream_rews;
  32.161 -
  32.162 -
  32.163 -(* ------------------------------------------------------------------------*)
  32.164 -(* Distinctness wrt. << and =                                              *)
  32.165 -(* ------------------------------------------------------------------------*)
  32.166 -
  32.167 -
  32.168 -(* ------------------------------------------------------------------------*)
  32.169 -(* Invertibility                                                           *)
  32.170 -(* ------------------------------------------------------------------------*)
  32.171 -
  32.172 -val stream_invert =
  32.173 -	[
  32.174 -prove_goal Stream.thy "[|x1~=UU; y1~=UU;\
  32.175 -\ scons`x1`x2 << scons`y1`y2|] ==> x1<< y1 & x2 << y2"
  32.176 - (fn prems =>
  32.177 -	[
  32.178 -	(cut_facts_tac prems 1),
  32.179 -	(rtac conjI 1),
  32.180 -	(dres_inst_tac [("fo5","stream_when`(LAM x l.x)")] monofun_cfun_arg 1),
  32.181 -	(etac box_less 1),
  32.182 -	(asm_simp_tac (!simpset addsimps stream_when) 1),
  32.183 -	(asm_simp_tac (!simpset addsimps stream_when) 1),
  32.184 -	(dres_inst_tac [("fo5","stream_when`(LAM x l.l)")] monofun_cfun_arg 1),
  32.185 -	(etac box_less 1),
  32.186 -	(asm_simp_tac (!simpset addsimps stream_when) 1),
  32.187 -	(asm_simp_tac (!simpset addsimps stream_when) 1)
  32.188 -	])
  32.189 -	];
  32.190 -
  32.191 -(* ------------------------------------------------------------------------*)
  32.192 -(* Injectivity                                                             *)
  32.193 -(* ------------------------------------------------------------------------*)
  32.194 -
  32.195 -val stream_inject = 
  32.196 -	[
  32.197 -prove_goal Stream.thy "[|x1~=UU; y1~=UU;\
  32.198 -\ scons`x1`x2 = scons`y1`y2 |] ==> x1= y1 & x2 = y2"
  32.199 - (fn prems =>
  32.200 -	[
  32.201 -	(cut_facts_tac prems 1),
  32.202 -	(rtac conjI 1),
  32.203 -	(dres_inst_tac [("f","stream_when`(LAM x l.x)")] cfun_arg_cong 1),
  32.204 -	(etac box_equals 1),
  32.205 -	(asm_simp_tac (!simpset addsimps stream_when) 1),
  32.206 -	(asm_simp_tac (!simpset addsimps stream_when) 1),
  32.207 -	(dres_inst_tac [("f","stream_when`(LAM x l.l)")] cfun_arg_cong 1),
  32.208 -	(etac box_equals 1),
  32.209 -	(asm_simp_tac (!simpset addsimps stream_when) 1),
  32.210 -	(asm_simp_tac (!simpset addsimps stream_when) 1)
  32.211 -	])
  32.212 -	];
  32.213 -
  32.214 -(* ------------------------------------------------------------------------*)
  32.215 -(* definedness for  discriminators and  selectors                          *)
  32.216 -(* ------------------------------------------------------------------------*)
  32.217 -
  32.218 -fun prover thm = prove_goal Stream.thy thm
  32.219 - (fn prems =>
  32.220 -	[
  32.221 -	(cut_facts_tac prems 1),
  32.222 -	(rtac streamE 1),
  32.223 -	(contr_tac 1),
  32.224 -	(REPEAT (asm_simp_tac (!simpset addsimps stream_discsel) 1))
  32.225 -	]);
  32.226 -
  32.227 -val stream_discsel_def = 
  32.228 -	[
  32.229 -	prover "s~=UU ==> is_scons`s ~= UU", 
  32.230 -	prover "s~=UU ==> shd`s ~=UU" 
  32.231 -	];
  32.232 -
  32.233 -val stream_rews = stream_discsel_def @ stream_rews;
  32.234 -
  32.235 -
  32.236 -(* ------------------------------------------------------------------------*)
  32.237 -(* Properties stream_take                                                  *)
  32.238 -(* ------------------------------------------------------------------------*)
  32.239 -
  32.240 -val stream_take =
  32.241 -	[
  32.242 -prove_goalw Stream.thy [stream_take_def] "stream_take n`UU = UU"
  32.243 - (fn prems =>
  32.244 -	[
  32.245 -	(res_inst_tac [("n","n")] natE 1),
  32.246 -	(Asm_simp_tac 1),
  32.247 -	(Asm_simp_tac 1),
  32.248 -	(simp_tac (!simpset addsimps stream_rews) 1)
  32.249 -	]),
  32.250 -prove_goalw Stream.thy [stream_take_def] "stream_take 0`xs=UU"
  32.251 - (fn prems =>
  32.252 -	[
  32.253 -	(Asm_simp_tac 1)
  32.254 -	])];
  32.255 -
  32.256 -fun prover thm = prove_goalw Stream.thy [stream_take_def] thm
  32.257 - (fn prems =>
  32.258 -	[
  32.259 -	(cut_facts_tac prems 1),
  32.260 -	(Simp_tac 1),
  32.261 -	(asm_simp_tac (!simpset addsimps stream_rews) 1)
  32.262 -	]);
  32.263 -
  32.264 -val stream_take = [
  32.265 -prover 
  32.266 -  "x~=UU ==> stream_take (Suc n)`(scons`x`xs) = scons`x`(stream_take n`xs)"
  32.267 -	] @ stream_take;
  32.268 -
  32.269 -val stream_rews = stream_take @ stream_rews;
  32.270 -
  32.271 -(* ------------------------------------------------------------------------*)
  32.272 -(* enhance the simplifier                                                  *)
  32.273 -(* ------------------------------------------------------------------------*)
  32.274 -
  32.275 -qed_goal "stream_copy2" Stream.thy 
  32.276 -     "stream_copy`f`(scons`x`xs) = scons`x`(f`xs)"
  32.277 - (fn prems =>
  32.278 -	[
  32.279 -	(res_inst_tac [("Q","x=UU")] classical2 1),
  32.280 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.281 -	(asm_simp_tac (!simpset addsimps stream_rews) 1)
  32.282 -	]);
  32.283 -
  32.284 -qed_goal "shd2" Stream.thy "shd`(scons`x`xs) = x"
  32.285 - (fn prems =>
  32.286 -	[
  32.287 -	(res_inst_tac [("Q","x=UU")] classical2 1),
  32.288 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.289 -	(asm_simp_tac (!simpset addsimps stream_rews) 1)
  32.290 -	]);
  32.291 -
  32.292 -qed_goal "stream_take2" Stream.thy 
  32.293 - "stream_take (Suc n)`(scons`x`xs) = scons`x`(stream_take n`xs)"
  32.294 - (fn prems =>
  32.295 -	[
  32.296 -	(res_inst_tac [("Q","x=UU")] classical2 1),
  32.297 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.298 -	(asm_simp_tac (!simpset addsimps stream_rews) 1)
  32.299 -	]);
  32.300 -
  32.301 -val stream_rews = [stream_iso_strict RS conjunct1,
  32.302 -		   stream_iso_strict RS conjunct2,
  32.303 -                   hd stream_copy, stream_copy2]
  32.304 -                  @ stream_when
  32.305 -                  @ [hd stream_discsel,shd2] @ (tl (tl stream_discsel))  
  32.306 -                  @ stream_constrdef
  32.307 -                  @ stream_discsel_def
  32.308 -                  @ [ stream_take2] @ (tl stream_take);
  32.309 -
  32.310 -
  32.311 -(* ------------------------------------------------------------------------*)
  32.312 -(* take lemma for streams                                                  *)
  32.313 -(* ------------------------------------------------------------------------*)
  32.314 -
  32.315 -fun prover reach defs thm  = prove_goalw Stream.thy defs thm
  32.316 - (fn prems =>
  32.317 -	[
  32.318 -	(res_inst_tac [("t","s1")] (reach RS subst) 1),
  32.319 -	(res_inst_tac [("t","s2")] (reach RS subst) 1),
  32.320 -	(rtac (fix_def2 RS ssubst) 1),
  32.321 -	(rtac (contlub_cfun_fun RS ssubst) 1),
  32.322 -	(rtac is_chain_iterate 1),
  32.323 -	(rtac (contlub_cfun_fun RS ssubst) 1),
  32.324 -	(rtac is_chain_iterate 1),
  32.325 -	(rtac lub_equal 1),
  32.326 -	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
  32.327 -	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
  32.328 -	(rtac allI 1),
  32.329 -	(resolve_tac prems 1)
  32.330 -	]);
  32.331 -
  32.332 -val stream_take_lemma = prover stream_reach  [stream_take_def]
  32.333 -	"(!!n.stream_take n`s1 = stream_take n`s2) ==> s1=s2";
  32.334 -
  32.335 -
  32.336 -qed_goal "stream_reach2" Stream.thy  "lub(range(%i.stream_take i`s))=s"
  32.337 - (fn prems =>
  32.338 -	[
  32.339 -	(res_inst_tac [("t","s")] (stream_reach RS subst) 1),
  32.340 -	(rtac (fix_def2 RS ssubst) 1),
  32.341 -	(rewrite_goals_tac [stream_take_def]),
  32.342 -	(rtac (contlub_cfun_fun RS ssubst) 1),
  32.343 -	(rtac is_chain_iterate 1),
  32.344 -	(rtac refl 1)
  32.345 -	]);
  32.346 -
  32.347 -(* ------------------------------------------------------------------------*)
  32.348 -(* Co -induction for streams                                               *)
  32.349 -(* ------------------------------------------------------------------------*)
  32.350 -
  32.351 -qed_goalw "stream_coind_lemma" Stream.thy [stream_bisim_def] 
  32.352 -"stream_bisim R ==> ! p q. R p q --> stream_take n`p = stream_take n`q"
  32.353 - (fn prems =>
  32.354 -	[
  32.355 -	(cut_facts_tac prems 1),
  32.356 -	(nat_ind_tac "n" 1),
  32.357 -	(simp_tac (!simpset addsimps stream_rews) 1),
  32.358 -	(strip_tac 1),
  32.359 -	((etac allE 1) THEN (etac allE 1) THEN (etac (mp RS disjE) 1)),
  32.360 -	(atac 1),
  32.361 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.362 -	(etac exE 1),
  32.363 -	(etac exE 1),
  32.364 -	(etac exE 1),
  32.365 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.366 -	(REPEAT (etac conjE 1)),
  32.367 -	(rtac cfun_arg_cong 1),
  32.368 -	(fast_tac HOL_cs 1)
  32.369 -	]);
  32.370 -
  32.371 -qed_goal "stream_coind" Stream.thy "[|stream_bisim R ;R p q|] ==> p = q"
  32.372 - (fn prems =>
  32.373 -	[
  32.374 -	(rtac stream_take_lemma 1),
  32.375 -	(rtac (stream_coind_lemma RS spec RS spec RS mp) 1),
  32.376 -	(resolve_tac prems 1),
  32.377 -	(resolve_tac prems 1)
  32.378 -	]);
  32.379 -
  32.380 -(* ------------------------------------------------------------------------*)
  32.381 -(* structural induction for admissible predicates                          *)
  32.382 -(* ------------------------------------------------------------------------*)
  32.383 -
  32.384 -qed_goal "stream_finite_ind" Stream.thy
  32.385 -"[|P(UU);\
  32.386 -\  !! x s1.[|x~=UU;P(s1)|] ==> P(scons`x`s1)\
  32.387 -\  |] ==> !s.P(stream_take n`s)"
  32.388 - (fn prems =>
  32.389 -	[
  32.390 -	(nat_ind_tac "n" 1),
  32.391 -	(simp_tac (!simpset addsimps stream_rews) 1),
  32.392 -	(resolve_tac prems 1),
  32.393 -	(rtac allI 1),
  32.394 -	(res_inst_tac [("s","s")] streamE 1),
  32.395 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.396 -	(resolve_tac prems 1),
  32.397 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.398 -	(resolve_tac prems 1),
  32.399 -	(atac 1),
  32.400 -	(etac spec 1)
  32.401 -	]);
  32.402 -
  32.403 -qed_goalw "stream_finite_ind2" Stream.thy  [stream_finite_def]
  32.404 -"(!!n.P(stream_take n`s)) ==>  stream_finite(s) -->P(s)"
  32.405 - (fn prems =>
  32.406 -	[
  32.407 -	(strip_tac 1),
  32.408 -	(etac exE 1),
  32.409 -	(etac subst 1),
  32.410 -	(resolve_tac prems 1)
  32.411 -	]);
  32.412 -
  32.413 -qed_goal "stream_finite_ind3" Stream.thy 
  32.414 -"[|P(UU);\
  32.415 -\  !! x s1.[|x~=UU;P(s1)|] ==> P(scons`x`s1)\
  32.416 -\  |] ==> stream_finite(s) --> P(s)"
  32.417 - (fn prems =>
  32.418 -	[
  32.419 -	(rtac stream_finite_ind2 1),
  32.420 -	(rtac (stream_finite_ind RS spec) 1),
  32.421 -	(REPEAT (resolve_tac prems 1)),
  32.422 -	(REPEAT (atac 1))
  32.423 -	]);
  32.424 -
  32.425 -(* prove induction using definition of admissibility 
  32.426 -   stream_reach rsp. stream_reach2 
  32.427 -   and finite induction stream_finite_ind *)
  32.428 -
  32.429 -qed_goal "stream_ind" Stream.thy
  32.430 -"[|adm(P);\
  32.431 -\  P(UU);\
  32.432 -\  !! x s1.[|x~=UU;P(s1)|] ==> P(scons`x`s1)\
  32.433 -\  |] ==> P(s)"
  32.434 - (fn prems =>
  32.435 -	[
  32.436 -	(rtac (stream_reach2 RS subst) 1),
  32.437 -	(rtac (adm_def2 RS iffD1 RS spec RS mp RS mp) 1),
  32.438 -	(resolve_tac prems 1),
  32.439 -	(SELECT_GOAL (rewrite_goals_tac [stream_take_def]) 1),
  32.440 -	(rtac ch2ch_fappL 1),
  32.441 -	(rtac is_chain_iterate 1),
  32.442 -	(rtac allI 1),
  32.443 -	(rtac (stream_finite_ind RS spec) 1),
  32.444 -	(REPEAT (resolve_tac prems 1)),
  32.445 -	(REPEAT (atac 1))
  32.446 -	]);
  32.447 -
  32.448 -(* prove induction with usual LCF-Method using fixed point induction *)
  32.449 -qed_goal "stream_ind" Stream.thy
  32.450 -"[|adm(P);\
  32.451 -\  P(UU);\
  32.452 -\  !! x s1.[|x~=UU;P(s1)|] ==> P(scons`x`s1)\
  32.453 -\  |] ==> P(s)"
  32.454 - (fn prems =>
  32.455 -	[
  32.456 -	(rtac (stream_reach RS subst) 1),
  32.457 -	(res_inst_tac [("x","s")] spec 1),
  32.458 -	(rtac wfix_ind 1),
  32.459 -	(rtac adm_impl_admw 1),
  32.460 -	(REPEAT (resolve_tac adm_thms 1)),
  32.461 -	(rtac adm_subst 1),
  32.462 -	(cont_tacR 1),
  32.463 -	(resolve_tac prems 1),
  32.464 -	(rtac allI 1),
  32.465 -	(rtac (rewrite_rule [stream_take_def] stream_finite_ind) 1),
  32.466 -	(REPEAT (resolve_tac prems 1)),
  32.467 -	(REPEAT (atac 1))
  32.468 -	]);
  32.469 -
  32.470 -
  32.471 -(* ------------------------------------------------------------------------*)
  32.472 -(* simplify use of Co-induction                                            *)
  32.473 -(* ------------------------------------------------------------------------*)
  32.474 -
  32.475 -qed_goal "surjectiv_scons" Stream.thy "scons`(shd`s)`(stl`s)=s"
  32.476 - (fn prems =>
  32.477 -	[
  32.478 -	(res_inst_tac [("s","s")] streamE 1),
  32.479 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.480 -	(asm_simp_tac (!simpset addsimps stream_rews) 1)
  32.481 -	]);
  32.482 -
  32.483 -
  32.484 -qed_goalw "stream_coind_lemma2" Stream.thy [stream_bisim_def]
  32.485 -"!s1 s2. R s1 s2 --> shd`s1 = shd`s2 & R (stl`s1) (stl`s2) ==> stream_bisim R"
  32.486 - (fn prems =>
  32.487 -	[
  32.488 -	(cut_facts_tac prems 1),
  32.489 -	(strip_tac 1),
  32.490 -	(etac allE 1),
  32.491 -	(etac allE 1),
  32.492 -	(dtac mp 1),
  32.493 -	(atac 1),
  32.494 -	(etac conjE 1),
  32.495 -	(res_inst_tac [("Q","s1 = UU & s2 = UU")] classical2 1),
  32.496 -	(rtac disjI1 1),
  32.497 -	(fast_tac HOL_cs 1),
  32.498 -	(rtac disjI2 1),
  32.499 -	(rtac disjE 1),
  32.500 -	(etac (de_morgan2 RS ssubst) 1),
  32.501 -	(res_inst_tac [("x","shd`s1")] exI 1),
  32.502 -	(res_inst_tac [("x","stl`s1")] exI 1),
  32.503 -	(res_inst_tac [("x","stl`s2")] exI 1),
  32.504 -	(rtac conjI 1),
  32.505 -	(eresolve_tac stream_discsel_def 1),
  32.506 -	(asm_simp_tac (!simpset addsimps stream_rews addsimps [surjectiv_scons]) 1),
  32.507 -	(eres_inst_tac [("s","shd`s1"),("t","shd`s2")] subst 1),
  32.508 -	(simp_tac (!simpset addsimps stream_rews addsimps [surjectiv_scons]) 1),
  32.509 -	(res_inst_tac [("x","shd`s2")] exI 1),
  32.510 -	(res_inst_tac [("x","stl`s1")] exI 1),
  32.511 -	(res_inst_tac [("x","stl`s2")] exI 1),
  32.512 -	(rtac conjI 1),
  32.513 -	(eresolve_tac stream_discsel_def 1),
  32.514 -	(asm_simp_tac (!simpset addsimps stream_rews addsimps [surjectiv_scons]) 1),
  32.515 -	(res_inst_tac [("s","shd`s1"),("t","shd`s2")] ssubst 1),
  32.516 -	(etac sym 1),
  32.517 -	(simp_tac (!simpset addsimps stream_rews addsimps [surjectiv_scons]) 1)
  32.518 -	]);
  32.519 -
  32.520 -
  32.521 -(* ------------------------------------------------------------------------*)
  32.522 -(* theorems about finite and infinite streams                              *)
  32.523 -(* ------------------------------------------------------------------------*)
  32.524 -
  32.525 -(* ----------------------------------------------------------------------- *)
  32.526 -(* 2 lemmas about stream_finite                                            *)
  32.527 -(* ----------------------------------------------------------------------- *)
  32.528 -
  32.529 -qed_goalw "stream_finite_UU" Stream.thy [stream_finite_def]
  32.530 -	 "stream_finite(UU)"
  32.531 - (fn prems =>
  32.532 -	[
  32.533 -	(rtac exI 1),
  32.534 -	(simp_tac (!simpset addsimps stream_rews) 1)
  32.535 -	]);
  32.536 -
  32.537 -qed_goal "inf_stream_not_UU" Stream.thy  "~stream_finite(s)  ==> s ~= UU"
  32.538 - (fn prems =>
  32.539 -	[
  32.540 -	(cut_facts_tac prems 1),
  32.541 -	(etac swap 1),
  32.542 -	(dtac notnotD 1),
  32.543 -	(hyp_subst_tac  1),
  32.544 -	(rtac stream_finite_UU 1)
  32.545 -	]);
  32.546 -
  32.547 -(* ----------------------------------------------------------------------- *)
  32.548 -(* a lemma about shd                                                       *)
  32.549 -(* ----------------------------------------------------------------------- *)
  32.550 -
  32.551 -qed_goal "stream_shd_lemma1" Stream.thy "shd`s=UU --> s=UU"
  32.552 - (fn prems =>
  32.553 -	[
  32.554 -	(res_inst_tac [("s","s")] streamE 1),
  32.555 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.556 -	(hyp_subst_tac 1),
  32.557 -	(asm_simp_tac (!simpset addsimps stream_rews) 1)
  32.558 -	]);
  32.559 -
  32.560 -
  32.561 -(* ----------------------------------------------------------------------- *)
  32.562 -(* lemmas about stream_take                                                *)
  32.563 -(* ----------------------------------------------------------------------- *)
  32.564 -
  32.565 -qed_goal "stream_take_lemma1" Stream.thy 
  32.566 - "!x xs.x~=UU --> \
  32.567 -\  stream_take (Suc n)`(scons`x`xs) = scons`x`xs --> stream_take n`xs=xs"
  32.568 - (fn prems =>
  32.569 -	[
  32.570 -	(rtac allI 1),
  32.571 -	(rtac allI 1),
  32.572 -	(rtac impI 1),
  32.573 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.574 -	(strip_tac 1),
  32.575 -	(rtac ((hd stream_inject) RS conjunct2) 1),
  32.576 -	(atac 1),
  32.577 -	(atac 1),
  32.578 -	(atac 1)
  32.579 -	]);
  32.580 -
  32.581 -
  32.582 -qed_goal "stream_take_lemma2" Stream.thy 
  32.583 - "! s2. stream_take n`s2 = s2 --> stream_take (Suc n)`s2=s2"
  32.584 - (fn prems =>
  32.585 -	[
  32.586 -	(nat_ind_tac "n" 1),
  32.587 -	(simp_tac (!simpset addsimps stream_rews) 1),
  32.588 -	(strip_tac 1 ),
  32.589 -	(hyp_subst_tac  1),
  32.590 -	(simp_tac (!simpset addsimps stream_rews) 1),
  32.591 -	(rtac allI 1),
  32.592 -	(res_inst_tac [("s","s2")] streamE 1),
  32.593 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.594 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.595 -	(strip_tac 1 ),
  32.596 -	(subgoal_tac "stream_take n1`xs = xs" 1),
  32.597 -	(rtac ((hd stream_inject) RS conjunct2) 2),
  32.598 -	(atac 4),
  32.599 -	(atac 2),
  32.600 -	(atac 2),
  32.601 -	(rtac cfun_arg_cong 1),
  32.602 -	(fast_tac HOL_cs 1)
  32.603 -	]);
  32.604 -
  32.605 -qed_goal "stream_take_lemma3" Stream.thy 
  32.606 - "!x xs.x~=UU --> \
  32.607 -\  stream_take n`(scons`x`xs) = scons`x`xs --> stream_take n`xs=xs"
  32.608 - (fn prems =>
  32.609 -	[
  32.610 -	(nat_ind_tac "n" 1),
  32.611 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.612 -	(strip_tac 1 ),
  32.613 -	(res_inst_tac [("P","scons`x`xs=UU")] notE 1),
  32.614 -	(eresolve_tac stream_constrdef 1),
  32.615 -	(etac sym 1),
  32.616 -	(strip_tac 1 ),
  32.617 -	(rtac (stream_take_lemma2 RS spec RS mp) 1),
  32.618 -	(res_inst_tac [("x1.1","x")] ((hd stream_inject) RS conjunct2) 1),
  32.619 -	(atac 1),
  32.620 -	(atac 1),
  32.621 -	(etac (stream_take2 RS subst) 1)
  32.622 -	]);
  32.623 -
  32.624 -qed_goal "stream_take_lemma4" Stream.thy 
  32.625 - "!x xs.\
  32.626 -\stream_take n`xs=xs --> stream_take (Suc n)`(scons`x`xs) = scons`x`xs"
  32.627 - (fn prems =>
  32.628 -	[
  32.629 -	(nat_ind_tac "n" 1),
  32.630 -	(simp_tac (!simpset addsimps stream_rews) 1),
  32.631 -	(simp_tac (!simpset addsimps stream_rews) 1)
  32.632 -	]);
  32.633 -
  32.634 -(* ---- *)
  32.635 -
  32.636 -qed_goal "stream_take_lemma5" Stream.thy 
  32.637 -"!s. stream_take n`s=s --> iterate n stl s=UU"
  32.638 - (fn prems =>
  32.639 -	[
  32.640 -	(nat_ind_tac "n" 1),
  32.641 -	(Simp_tac 1),
  32.642 -	(simp_tac (!simpset addsimps stream_rews) 1),
  32.643 -	(strip_tac 1),
  32.644 -	(res_inst_tac [("s","s")] streamE 1),
  32.645 -	(hyp_subst_tac 1),
  32.646 -	(rtac (iterate_Suc2 RS ssubst) 1),
  32.647 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.648 -	(rtac (iterate_Suc2 RS ssubst) 1),
  32.649 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.650 -	(etac allE 1),
  32.651 -	(etac mp 1),
  32.652 -	(hyp_subst_tac 1),
  32.653 -	(etac (stream_take_lemma1 RS spec RS spec RS mp RS mp) 1),
  32.654 -	(atac 1)
  32.655 -	]);
  32.656 -
  32.657 -qed_goal "stream_take_lemma6" Stream.thy 
  32.658 -"!s.iterate n stl s =UU --> stream_take n`s=s"
  32.659 - (fn prems =>
  32.660 -	[
  32.661 -	(nat_ind_tac "n" 1),
  32.662 -	(Simp_tac 1),
  32.663 -	(strip_tac 1),
  32.664 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.665 -	(rtac allI 1),
  32.666 -	(res_inst_tac [("s","s")] streamE 1),
  32.667 -	(hyp_subst_tac 1),
  32.668 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  32.669 -	(hyp_subst_tac 1),
  32.670 -	(rtac (iterate_Suc2 RS ssubst) 1),
  32.671 -	(asm_simp_tac (!simpset addsimps stream_rews) 1)
  32.672 -	]);
  32.673 -
  32.674 -qed_goal "stream_take_lemma7" Stream.thy 
  32.675 -"(iterate n stl s=UU) = (stream_take n`s=s)"
  32.676 - (fn prems =>
  32.677 -	[
  32.678 -	(rtac iffI 1),
  32.679 -	(etac (stream_take_lemma6 RS spec RS mp) 1),
  32.680 -	(etac (stream_take_lemma5 RS spec RS mp) 1)
  32.681 -	]);
  32.682 -
  32.683 -
  32.684 -qed_goal "stream_take_lemma8" Stream.thy
  32.685 -"[|adm(P); !n. ? m. n < m & P (stream_take m`s)|] ==> P(s)"
  32.686 - (fn prems =>
  32.687 -	[
  32.688 -	(cut_facts_tac prems 1),
  32.689 -	(rtac (stream_reach2 RS subst) 1),
  32.690 -	(rtac adm_disj_lemma11 1),
  32.691 -	(atac 1),
  32.692 -	(atac 2),
  32.693 -	(rewrite_goals_tac [stream_take_def]),
  32.694 -	(rtac ch2ch_fappL 1),
  32.695 -	(rtac is_chain_iterate 1)
  32.696 -	]);
  32.697 -
  32.698 -(* ----------------------------------------------------------------------- *)
  32.699 -(* lemmas stream_finite                                                    *)
  32.700 -(* ----------------------------------------------------------------------- *)
  32.701 -
  32.702 -qed_goalw "stream_finite_lemma1" Stream.thy [stream_finite_def]
  32.703 - "stream_finite(xs) ==> stream_finite(scons`x`xs)"
  32.704 - (fn prems =>
  32.705 -	[
  32.706 -	(cut_facts_tac prems 1),
  32.707 -	(etac exE 1),
  32.708 -	(rtac exI 1),
  32.709 -	(etac (stream_take_lemma4 RS spec RS spec RS mp) 1)
  32.710 -	]);
  32.711 -
  32.712 -qed_goalw "stream_finite_lemma2" Stream.thy [stream_finite_def]
  32.713 - "[|x~=UU; stream_finite(scons`x`xs)|] ==> stream_finite(xs)"
  32.714 - (fn prems =>
  32.715 -	[
  32.716 -	(cut_facts_tac prems 1),
  32.717 -	(etac exE 1),
  32.718 -	(rtac exI 1),
  32.719 -	(etac (stream_take_lemma3 RS spec RS spec RS mp RS mp) 1),
  32.720 -	(atac 1)
  32.721 -	]);
  32.722 -
  32.723 -qed_goal "stream_finite_lemma3" Stream.thy 
  32.724 - "x~=UU ==> stream_finite(scons`x`xs) = stream_finite(xs)"
  32.725 - (fn prems =>
  32.726 -	[
  32.727 -	(cut_facts_tac prems 1),
  32.728 -	(rtac iffI 1),
  32.729 -	(etac stream_finite_lemma2 1),
  32.730 -	(atac 1),
  32.731 -	(etac stream_finite_lemma1 1)
  32.732 -	]);
  32.733 -
  32.734 -
  32.735 -qed_goalw "stream_finite_lemma5" Stream.thy [stream_finite_def]
  32.736 - "(!n. s1 << s2  --> stream_take n`s2 = s2 --> stream_finite(s1))\
  32.737 -\=(s1 << s2  --> stream_finite(s2) --> stream_finite(s1))"
  32.738 - (fn prems =>
  32.739 -	[
  32.740 -	(rtac iffI 1),
  32.741 -	(fast_tac HOL_cs 1),
  32.742 -	(fast_tac HOL_cs 1)
  32.743 -	]);
  32.744 -
  32.745 -qed_goal "stream_finite_lemma6" Stream.thy
  32.746 - "!s1 s2. s1 << s2  --> stream_take n`s2 = s2 --> stream_finite(s1)"
  32.747 - (fn prems =>
  32.748 -	[
  32.749 -	(nat_ind_tac "n" 1),
  32.750 -	(simp_tac (!simpset addsimps stream_rews) 1),
  32.751 -	(strip_tac 1 ),
  32.752 -	(hyp_subst_tac  1),
  32.753 -	(dtac UU_I 1),
  32.754 -	(hyp_subst_tac  1),
  32.755 -	(rtac stream_finite_UU 1),
  32.756 -	(rtac allI 1),
  32.757 -	(rtac allI 1),
  32.758 -	(res_inst_tac [("s","s1")] streamE 1),
  32.759 -	(hyp_subst_tac  1),
  32.760 -	(strip_tac 1 ),
  32.761 -	(rtac stream_finite_UU 1),
  32.762 -	(hyp_subst_tac  1),
  32.763 -	(res_inst_tac [("s","s2")] streamE 1),
  32.764 -	(hyp_subst_tac  1),
  32.765 -	(strip_tac 1 ),
  32.766 -	(dtac UU_I 1),
  32.767 -	(asm_simp_tac(!simpset addsimps (stream_rews @ [stream_finite_UU])) 1),
  32.768 -	(hyp_subst_tac  1),
  32.769 -	(simp_tac (!simpset addsimps stream_rews) 1),
  32.770 -	(strip_tac 1 ),
  32.771 -	(rtac stream_finite_lemma1 1),
  32.772 -	(subgoal_tac "xs << xsa" 1),
  32.773 -	(subgoal_tac "stream_take n1`xsa = xsa" 1),
  32.774 -	(fast_tac HOL_cs 1),
  32.775 -	(res_inst_tac  [("x1.1","xa"),("y1.1","xa")] 
  32.776 -                   ((hd stream_inject) RS conjunct2) 1),
  32.777 -	(atac 1),
  32.778 -	(atac 1),
  32.779 -	(atac 1),
  32.780 -	(res_inst_tac [("x1.1","x"),("y1.1","xa")]
  32.781 -	 ((hd stream_invert) RS conjunct2) 1),
  32.782 -	(atac 1),
  32.783 -	(atac 1),
  32.784 -	(atac 1)
  32.785 -	]);
  32.786 -
  32.787 -qed_goal "stream_finite_lemma7" Stream.thy 
  32.788 -"s1 << s2  --> stream_finite(s2) --> stream_finite(s1)"
  32.789 - (fn prems =>
  32.790 -	[
  32.791 -	(rtac (stream_finite_lemma5 RS iffD1) 1),
  32.792 -	(rtac allI 1),
  32.793 -	(rtac (stream_finite_lemma6 RS spec RS spec) 1)
  32.794 -	]);
  32.795 -
  32.796 -qed_goalw "stream_finite_lemma8" Stream.thy [stream_finite_def]
  32.797 -"stream_finite(s) = (? n. iterate n stl s = UU)"
  32.798 - (fn prems =>
  32.799 -	[
  32.800 -	(simp_tac (!simpset addsimps [stream_take_lemma7]) 1)
  32.801 -	]);
  32.802 -
  32.803 -
  32.804 -(* ----------------------------------------------------------------------- *)
  32.805 -(* admissibility of ~stream_finite                                         *)
  32.806 -(* ----------------------------------------------------------------------- *)
  32.807 -
  32.808 -qed_goalw "adm_not_stream_finite" Stream.thy [adm_def]
  32.809 - "adm(%s. ~ stream_finite(s))"
  32.810 - (fn prems =>
  32.811 -	[
  32.812 -	(strip_tac 1 ),
  32.813 -	(res_inst_tac [("P1","!i. ~ stream_finite(Y(i))")] classical3 1),
  32.814 -	(atac 2),
  32.815 -	(subgoal_tac "!i.stream_finite(Y(i))" 1),
  32.816 -	(fast_tac HOL_cs 1),
  32.817 -	(rtac allI 1),
  32.818 -	(rtac (stream_finite_lemma7 RS mp RS mp) 1),
  32.819 -	(etac is_ub_thelub 1),
  32.820 -	(atac 1)
  32.821 -	]);
  32.822 -
  32.823 -(* ----------------------------------------------------------------------- *)
  32.824 -(* alternative prove for admissibility of ~stream_finite                   *)
  32.825 -(* show that stream_finite(s) = (? n. iterate n stl s = UU)                *)
  32.826 -(* and prove adm. of ~(? n. iterate n stl s = UU)                          *)
  32.827 -(* proof uses theorems stream_take_lemma5-7; stream_finite_lemma8          *)
  32.828 -(* ----------------------------------------------------------------------- *)
  32.829 -
  32.830 -
  32.831 -qed_goal "adm_not_stream_finite" Stream.thy "adm(%s. ~ stream_finite(s))"
  32.832 - (fn prems =>
  32.833 -	[
  32.834 -	(subgoal_tac "(!s.(~stream_finite(s))=(!n.iterate n stl s ~=UU))" 1),
  32.835 -	(etac (adm_cong RS iffD2)1),
  32.836 -	(REPEAT(resolve_tac adm_thms 1)),
  32.837 -	(rtac  cont_iterate2 1),
  32.838 -	(rtac allI 1),
  32.839 -	(rtac (stream_finite_lemma8 RS ssubst) 1),
  32.840 -	(fast_tac HOL_cs 1)
  32.841 -	]);
  32.842 -
  32.843 -
    33.1 --- a/src/HOLCF/Stream.thy	Fri Oct 06 16:17:08 1995 +0100
    33.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    33.3 @@ -1,115 +0,0 @@
    33.4 -(*  Title: 	HOLCF/stream.thy
    33.5 -    ID:         $Id$
    33.6 -    Author: 	Franz Regensburger
    33.7 -    Copyright   1993 Technische Universitaet Muenchen
    33.8 -
    33.9 -Theory for streams without defined empty stream 
   33.10 -  'a stream = 'a ** ('a stream)u
   33.11 -
   33.12 -The type is axiomatized as the least solution of the domain equation above.
   33.13 -The functor term that specifies the domain equation is: 
   33.14 -
   33.15 -  FT = <**,K_{'a},U>
   33.16 -
   33.17 -For details see chapter 5 of:
   33.18 -
   33.19 -[Franz Regensburger] HOLCF: Eine konservative Erweiterung von HOL um LCF,
   33.20 -                     Dissertation, Technische Universit"at M"unchen, 1994
   33.21 -*)
   33.22 -
   33.23 -Stream = Dnat2 +
   33.24 -
   33.25 -types stream 1
   33.26 -
   33.27 -(* ----------------------------------------------------------------------- *)
   33.28 -(* arity axiom is validated by semantic reasoning                          *)
   33.29 -(* partial ordering is implicit in the isomorphism axioms and their cont.  *)
   33.30 -
   33.31 -arities stream::(pcpo)pcpo
   33.32 -
   33.33 -consts
   33.34 -
   33.35 -(* ----------------------------------------------------------------------- *)
   33.36 -(* essential constants                                                     *)
   33.37 -
   33.38 -stream_rep	:: "('a stream) -> ('a ** ('a stream)u)"
   33.39 -stream_abs	:: "('a ** ('a stream)u) -> ('a stream)"
   33.40 -
   33.41 -(* ----------------------------------------------------------------------- *)
   33.42 -(* abstract constants and auxiliary constants                              *)
   33.43 -
   33.44 -stream_copy	:: "('a stream -> 'a stream) ->'a stream -> 'a stream"
   33.45 -
   33.46 -scons		:: "'a -> 'a stream -> 'a stream"
   33.47 -stream_when	:: "('a -> 'a stream -> 'b) -> 'a stream -> 'b"
   33.48 -is_scons	:: "'a stream -> tr"
   33.49 -shd		:: "'a stream -> 'a"
   33.50 -stl		:: "'a stream -> 'a stream"
   33.51 -stream_take	:: "nat => 'a stream -> 'a stream"
   33.52 -stream_finite	:: "'a stream => bool"
   33.53 -stream_bisim	:: "('a stream => 'a stream => bool) => bool"
   33.54 -
   33.55 -rules
   33.56 -
   33.57 -(* ----------------------------------------------------------------------- *)
   33.58 -(* axiomatization of recursive type 'a stream                              *)
   33.59 -(* ----------------------------------------------------------------------- *)
   33.60 -(* ('a stream,stream_abs) is the initial F-algebra where                   *)
   33.61 -(* F is the locally continuous functor determined by functor term FT.      *)
   33.62 -(* domain equation: 'a stream = 'a ** ('a stream)u                         *)
   33.63 -(* functor term:    FT = <**,K_{'a},U>                                     *)
   33.64 -(* ----------------------------------------------------------------------- *)
   33.65 -(* stream_abs is an isomorphism with inverse stream_rep                    *)
   33.66 -(* identity is the least endomorphism on 'a stream                         *)
   33.67 -
   33.68 -stream_abs_iso	"stream_rep`(stream_abs`x) = x"
   33.69 -stream_rep_iso	"stream_abs`(stream_rep`x) = x"
   33.70 -stream_copy_def	"stream_copy == (LAM f. stream_abs oo 
   33.71 - 		(ssplit`(LAM x y. (|x , (lift`(up oo f))`y|) )) oo stream_rep)"
   33.72 -stream_reach	"(fix`stream_copy)`x = x"
   33.73 -
   33.74 -defs
   33.75 -(* ----------------------------------------------------------------------- *)
   33.76 -(* properties of additional constants                                      *)
   33.77 -(* ----------------------------------------------------------------------- *)
   33.78 -(* constructors                                                            *)
   33.79 -
   33.80 -scons_def	"scons == (LAM x l. stream_abs`(| x, up`l |))"
   33.81 -
   33.82 -(* ----------------------------------------------------------------------- *)
   33.83 -(* discriminator functional                                                *)
   33.84 -
   33.85 -stream_when_def 
   33.86 -"stream_when == (LAM f l.ssplit `(LAM x l.f`x`(lift`ID`l)) `(stream_rep`l))"
   33.87 -
   33.88 -(* ----------------------------------------------------------------------- *)
   33.89 -(* discriminators and selectors                                            *)
   33.90 -
   33.91 -is_scons_def	"is_scons == stream_when`(LAM x l.TT)"
   33.92 -shd_def		"shd == stream_when`(LAM x l.x)"
   33.93 -stl_def		"stl == stream_when`(LAM x l.l)"
   33.94 -
   33.95 -(* ----------------------------------------------------------------------- *)
   33.96 -(* the taker for streams                                                   *)
   33.97 -
   33.98 -stream_take_def "stream_take == (%n.iterate n stream_copy UU)"
   33.99 -
  33.100 -(* ----------------------------------------------------------------------- *)
  33.101 -
  33.102 -stream_finite_def	"stream_finite == (%s.? n.stream_take n `s=s)"
  33.103 -
  33.104 -(* ----------------------------------------------------------------------- *)
  33.105 -(* definition of bisimulation is determined by domain equation             *)
  33.106 -(* simplification and rewriting for abstract constants yields def below    *)
  33.107 -
  33.108 -stream_bisim_def "stream_bisim ==
  33.109 -(%R.!s1 s2.
  33.110 - 	R s1 s2 -->
  33.111 -  ((s1=UU & s2=UU) |
  33.112 -  (? x s11 s21. x~=UU & s1=scons`x`s11 & s2 = scons`x`s21 & R s11 s21)))"
  33.113 -
  33.114 -end
  33.115 -
  33.116 -
  33.117 -
  33.118 -
    34.1 --- a/src/HOLCF/Stream2.ML	Fri Oct 06 16:17:08 1995 +0100
    34.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    34.3 @@ -1,43 +0,0 @@
    34.4 -(*  Title: 	HOLCF/stream2.ML
    34.5 -    ID:         $Id$
    34.6 -    Author: 	Franz Regensburger
    34.7 -    Copyright   1993 Technische Universitaet Muenchen
    34.8 -
    34.9 -Lemmas for theory Stream2.thy
   34.10 -*)
   34.11 -
   34.12 -open Stream2;
   34.13 -
   34.14 -(* ------------------------------------------------------------------------- *)
   34.15 -(* expand fixed point properties                                             *)
   34.16 -(* ------------------------------------------------------------------------- *)
   34.17 -
   34.18 -val smap_def2 = fix_prover2 Stream2.thy smap_def 
   34.19 -	"smap = (LAM f s. stream_when`(LAM x l.scons`(f`x) `(smap`f`l)) `s)";
   34.20 -
   34.21 -
   34.22 -(* ------------------------------------------------------------------------- *)
   34.23 -(* recursive  properties                                                     *)
   34.24 -(* ------------------------------------------------------------------------- *)
   34.25 -
   34.26 -
   34.27 -qed_goal "smap1" Stream2.thy "smap`f`UU = UU"
   34.28 - (fn prems =>
   34.29 -	[
   34.30 -	(rtac (smap_def2 RS ssubst) 1),
   34.31 -	(simp_tac (!simpset addsimps stream_when) 1)
   34.32 -	]);
   34.33 -
   34.34 -qed_goal "smap2" Stream2.thy 
   34.35 -	"x~=UU ==> smap`f`(scons`x`xs) = scons `(f`x) `(smap`f`xs)"
   34.36 - (fn prems =>
   34.37 -	[
   34.38 -	(cut_facts_tac prems 1),
   34.39 -	(rtac trans 1),
   34.40 -	(rtac (smap_def2 RS ssubst) 1),
   34.41 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
   34.42 -	(rtac refl 1)
   34.43 -	]);
   34.44 -
   34.45 -
   34.46 -val stream2_rews = [smap1, smap2];
    35.1 --- a/src/HOLCF/Stream2.thy	Fri Oct 06 16:17:08 1995 +0100
    35.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    35.3 @@ -1,29 +0,0 @@
    35.4 -(*  Title: 	HOLCF/stream2.thy
    35.5 -    ID:         $Id$
    35.6 -    Author: 	Franz Regensburger
    35.7 -    Copyright   1993 Technische Universitaet Muenchen
    35.8 -
    35.9 -Additional constants for stream
   35.10 -*)
   35.11 -
   35.12 -Stream2 = Stream +
   35.13 -
   35.14 -consts
   35.15 -
   35.16 -smap		:: "('a -> 'b) -> 'a stream -> 'b stream"
   35.17 -
   35.18 -defs
   35.19 -
   35.20 -smap_def
   35.21 -  "smap == fix`(LAM h f s. stream_when`(LAM x l.scons `(f`x) `(h`f`l)) `s)"
   35.22 -
   35.23 -
   35.24 -end
   35.25 -      
   35.26 -
   35.27 -(*
   35.28 -		smap`f`UU = UU
   35.29 -      x~=UU --> smap`f`(scons`x`xs) = scons `(f`x) `(smap`f`xs)
   35.30 -
   35.31 -*)
   35.32 -
    36.1 --- a/src/HOLCF/Tr1.thy	Fri Oct 06 16:17:08 1995 +0100
    36.2 +++ b/src/HOLCF/Tr1.thy	Fri Oct 06 17:25:24 1995 +0100
    36.3 @@ -41,4 +41,9 @@
    36.4  
    36.5    tr_when_def "tr_when == 
    36.6  	(LAM e1 e2 t. sswhen`(LAM x.e1)`(LAM y.e2)`(rep_tr`t))"
    36.7 +
    36.8 +(* start 8bit 1 *)
    36.9 +(* end 8bit 1 *)
   36.10 +
   36.11 +
   36.12  end
    37.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    37.2 +++ b/src/HOLCF/ax_ops/holcflogic.ML	Fri Oct 06 17:25:24 1995 +0100
    37.3 @@ -0,0 +1,64 @@
    37.4 +(*
    37.5 +    ID:         $Id$
    37.6 +    Author:     Tobias Mayr
    37.7 +
    37.8 +Additional term and type constructors, extension of Pure/term.ML, logic.ML
    37.9 +and HOL/hologic.ML
   37.10 +
   37.11 +TODO:
   37.12 +
   37.13 +*)
   37.14 +
   37.15 +signature HOLCFLOGIC =
   37.16 +sig
   37.17 + val True  : term;
   37.18 + val False : term;
   37.19 + val Imp   : term;
   37.20 + val And   : term;
   37.21 + val Not   : term;
   37.22 + val mkNot : term -> term;                (* negates, no Trueprop *)
   37.23 + val mkNotEqUU : term -> term;            (* Trueprop(x ~= UU) *)
   37.24 + val mkNotEqUU_in : term -> term -> term; (* "v~=UU ==> t" *)
   37.25 + val ==>     : typ * typ -> typ;          (* Infix operation typ constructor *)
   37.26 + val mkOpApp : term -> term -> term;      (* Ops application (f ` x) *)
   37.27 + val mkCPair : term -> term -> term;      (* cpair constructor *)
   37.28 +end;
   37.29 +
   37.30 +structure HOLCFlogic : HOLCFLOGIC =
   37.31 +struct
   37.32 +open Logic 
   37.33 +open HOLogic
   37.34 +
   37.35 +val True = Const("True",boolT);
   37.36 +val False = Const("False",boolT);
   37.37 +val Imp = Const("op -->",boolT --> boolT --> boolT);
   37.38 +val And = Const("op &",boolT --> boolT --> boolT);
   37.39 +val Not = Const("not",boolT --> boolT);   
   37.40 +
   37.41 +fun mkNot A = Not $ A; (* negates, no Trueprop *)
   37.42 +
   37.43 +(* Trueprop(x ~= UU) *)
   37.44 +fun mkNotEqUU v = mk_Trueprop(mkNot(mk_eq(v,Const("UU",fastype_of v))));
   37.45 +
   37.46 +(* mkNotEqUU_in v t = "v~=UU ==> t" *)
   37.47 +fun mkNotEqUU_in vterm term = 
   37.48 +   mk_implies(mkNotEqUU vterm,term)
   37.49 +
   37.50 +
   37.51 +infixr 6 ==>; (* the analogon to --> for operations *)
   37.52 +fun a ==> b = Type("->",[a,b]);
   37.53 +
   37.54 +(* Ops application (f ` x) *)
   37.55 +fun mkOpApp (f as Const(_,ft as Type("->",[xt,rt]))) x =
   37.56 +     Const("fapp",ft --> xt --> rt) $ f $ x
   37.57 +  | mkOpApp f x = (print(f);error("Internal error: mkOpApp: wrong args"));
   37.58 +
   37.59 +(* cpair constructor *)
   37.60 +fun mkCPair x y = let val tx = fastype_of x
   37.61 +                       val ty = fastype_of y
   37.62 +                   in  
   37.63 +      Const("fapp",(ty==>Type("*",[tx,ty]))-->ty-->Type("*",[tx,ty])) $
   37.64 +      (mkOpApp (Const("cpair",tx ==> ty ==> Type("*",[tx,ty]))) x) $ y
   37.65 +                   end;
   37.66 +
   37.67 +end;
    38.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    38.2 +++ b/src/HOLCF/ax_ops/install.tex	Fri Oct 06 17:25:24 1995 +0100
    38.3 @@ -0,0 +1,25 @@
    38.4 +
    38.5 +Um diese Erweiterung zu installieren, gen\"ugt es nat\"urlich nicht, die
    38.6 +Sourcefiles nach {\tt isabelle/src/HOLCF} zu kopieren, 
    38.7 +es mu\ss\ au\ss erdem ROOT.ML
    38.8 +folgenderma\ss en abge\"andert werden:\\
    38.9 +Die Zeile 
   38.10 +\begin{verbatim}
   38.11 +init_thy_reader();
   38.12 +\end{verbatim}
   38.13 +wird ersetzt durch die Zeilen 
   38.14 +\begin{verbatim}
   38.15 +use "holcflogic.ML";
   38.16 +use "thy_axioms.ML";
   38.17 +use "thy_ops.ML";
   38.18 +use "thy_syntax.ML";
   38.19 +\end{verbatim}
   38.20 +abschliessend wird die {\tt HOLCF}--Database neu erzeugt:\\
   38.21 +{\tt make -f Makefile}\\
   38.22 +(Vorraussetzung ist nat\"urlich, da\ss\ die {\tt ISABELLE...}--Environment
   38.23 +Variablen korrekt, wie im Makefile beschrieben, gesetzt sind.)
   38.24 +
   38.25 +Die Installation ist damit abgeschlossen.
   38.26 +
   38.27 +
   38.28 + 
   38.29 \ No newline at end of file
    39.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    39.2 +++ b/src/HOLCF/ax_ops/thy_axioms.ML	Fri Oct 06 17:25:24 1995 +0100
    39.3 @@ -0,0 +1,216 @@
    39.4 +(*
    39.5 +    ID:         $Id$
    39.6 +    Author:     Tobias Mayr
    39.7 +
    39.8 +Additional theory file section for HOLCF: axioms 
    39.9 +There's an elaborate but german description of this program
   39.10 +and a short english description of the new sections,
   39.11 +write to mayrt@informatik.tu-muenchen.de.
   39.12 +
   39.13 +TODO:
   39.14 +
   39.15 +*)
   39.16 +
   39.17 +(*** new section of HOLCF : axioms 
   39.18 +     since rules are already internally called axioms,
   39.19 +     the new section is internally called ext_axioms res. eaxms *)
   39.20 +
   39.21 +signature THY_AXIOMS =
   39.22 +sig
   39.23 + (* theory extenders : *)
   39.24 + val add_ext_axioms   : (string * string) list -> (string * string) list
   39.25 +                        -> (string * string) list -> theory -> theory;
   39.26 + val add_ext_axioms_i : (string * (typ option)) list -> 
   39.27 +                        (string * (typ option)) list ->
   39.28 +                        (string * term) list -> theory -> theory;
   39.29 + val axioms_keywords    : string list;
   39.30 + val axioms_sections    : (string * (ThyParse.token list -> 
   39.31 +                        (string * string) * ThyParse.token list)) list;
   39.32 +end;
   39.33 +
   39.34 +structure ThyAxioms : THY_AXIOMS =
   39.35 +struct
   39.36 +
   39.37 +open HOLCFlogic;
   39.38 +
   39.39 +(** library ******************************************************)
   39.40 +
   39.41 +fun apsnd_of_three f = fn (a,b,c) => (a,f b,c);
   39.42 +
   39.43 +fun is_elem e list = exists (fn y => e=y) list
   39.44 +
   39.45 +fun without l1 l2 = (* l1 without the elements of l2 *)
   39.46 +  filter (fn x => (not (is_elem x l2))) l1;
   39.47 +
   39.48 +fun conc [e:string] = e
   39.49 +  | conc (head::tail) = head^", "^(conc tail)
   39.50 +  | conc [] = "";
   39.51 +
   39.52 +fun appear varlist = (* all (x,_) for which (x,_) is in varlist *)
   39.53 +  filter (fn x => (exists (fn y => (fst x)=(fst y)) varlist)) 
   39.54 +
   39.55 +
   39.56 +(* all non unique elements of a list *)
   39.57 +fun doubles (hd::tl) = if   (is_elem hd tl)
   39.58 +                       then (hd::(doubles tl))
   39.59 +                       else (doubles tl)
   39.60 +  | doubles _ = [];
   39.61 +
   39.62 +
   39.63 +(* The main functions are the section parser ext_axiom_decls and the 
   39.64 +   theory extender add_ext_axioms. *)
   39.65 +
   39.66 +(** theory extender : add_ext_axioms *)
   39.67 +
   39.68 +(* forms a function from constrained varnames to their constraints 
   39.69 +   these constraints are then used local to each axiom, as an argument
   39.70 +   of read_def_cterm. Called by add_ext_axioms. *)
   39.71 +fun get_constraints_of_str sign ((vname,vtyp)::tail) = 
   39.72 +   if (vtyp <> "")
   39.73 +   then ((fn (x,_)=> if x=vname 
   39.74 +                      then Some (#T (rep_ctyp (read_ctyp sign vtyp)))
   39.75 +                      else raise Match)
   39.76 +        orelf (get_constraints_of_str sign tail))
   39.77 +   else (get_constraints_of_str sign tail)
   39.78 +  | get_constraints_of_str sign [] = K None;
   39.79 +
   39.80 +(* does the same job for allready parsed optional constraints. 
   39.81 +   Called by add_ext_axioms_i. *)
   39.82 +fun get_constraints_of_typ sign ((vname,vtyp)::tail) = 
   39.83 +   if (is_some vtyp)
   39.84 +   then ((fn (x,_)=> if x=vname 
   39.85 +                      then vtyp
   39.86 +                      else raise Match)
   39.87 +        orelf (get_constraints_of_typ sign tail))
   39.88 +   else (get_constraints_of_typ sign tail)
   39.89 +  | get_constraints_of_typ sign [] = K None;
   39.90 +
   39.91 +
   39.92 +(* applies mkNotEqUU_in on the axiom and every Free that appears in the list
   39.93 +   and in the axiom. Called by check_and_extend. *)
   39.94 +fun add_prem axiom [] = axiom
   39.95 +  | add_prem axiom (vname::tl) =
   39.96 + let val vterm = find_first (fn x => ((#1 o dest_Free) x = vname))
   39.97 +                            (term_frees axiom)
   39.98 + in 
   39.99 +   add_prem  
  39.100 +     (if (is_some vterm) 
  39.101 +      then mkNotEqUU_in (the vterm) axiom
  39.102 +      else axiom)
  39.103 +     tl
  39.104 + end
  39.105 +
  39.106 +(* checks for uniqueness and completeness of var/defvar declarations, 
  39.107 +   and enriches the axiom term with premises. Called by add_ext_axioms(_i).*)
  39.108 +fun check_and_extend sign defvarl varl axiom =
  39.109 +  let
  39.110 +   val names_of_frees =  map (fst o dest_Free) 
  39.111 +                             (term_frees axiom);
  39.112 +   val all_decl_varnames = (defvarl @ varl);
  39.113 +   val undeclared = without names_of_frees all_decl_varnames;
  39.114 +   val doubles = doubles all_decl_varnames
  39.115 +  in
  39.116 +   if (doubles <> [])
  39.117 +   then 
  39.118 +    (error("Multiple declarations of one identifier in section axioms :\n"
  39.119 +           ^(conc doubles)))
  39.120 +   else ();
  39.121 +   if (undeclared <> [])
  39.122 +   then 
  39.123 +    (error("Undeclared identifiers in section axioms : \n"
  39.124 +           ^(conc undeclared)))
  39.125 +   else (); 
  39.126 +   add_prem axiom (rev defvarl)
  39.127 +  end; 
  39.128 +
  39.129 +(* the next five only differ from the original add_axioms' subfunctions
  39.130 +   in the constraints argument for read_def_cterm *) 
  39.131 +local
  39.132 + fun err_in_axm name =
  39.133 +   error ("The error(s) above occurred in axiom " ^ quote name); 
  39.134 +
  39.135 + fun no_vars tm =
  39.136 +   if null (term_vars tm) andalso null (term_tvars tm) then tm
  39.137 +   else error "Illegal schematic variable(s) in term"; 
  39.138 +
  39.139 + fun read_ext_cterm sign constraints = 
  39.140 +   #1 o read_def_cterm (sign, constraints, K None) [] true;
  39.141 +
  39.142 + (* only for add_ext_axioms (working on strings) *)
  39.143 + fun read_ext_axm sg constraints (name,str) =
  39.144 +   (name, no_vars (term_of (read_ext_cterm sg constraints (str, propT))))
  39.145 +    handle ERROR => err_in_axm name;
  39.146 +
  39.147 + (* only for add_ext_axioms_i (working on terms) *)
  39.148 + fun read_ext_axm_terms sg constraints (name,term) =
  39.149 +   (name, no_vars (#2(Sign.infer_types sg constraints  (K None) [] true 
  39.150 +                                       ([term], propT))))
  39.151 +    handle ERROR => err_in_axm name;
  39.152 +
  39.153 +in
  39.154 +
  39.155 +(******* THE THEORY EXTENDERS THEMSELVES *****)
  39.156 + fun add_ext_axioms varlist defvarlist axioms theory =
  39.157 +  let val {sign, ...} = rep_theory theory;
  39.158 +      val constraints = get_constraints_of_str sign (defvarlist@varlist)
  39.159 +  in
  39.160 +    add_axioms_i (map (apsnd 
  39.161 +     (check_and_extend sign (map fst defvarlist) (map fst varlist)) o
  39.162 +               (read_ext_axm sign constraints)) axioms) theory
  39.163 +  end 
  39.164 +
  39.165 + fun add_ext_axioms_i varlist defvarlist axiom_terms theory =
  39.166 +  let val {sign, ...} = rep_theory theory;
  39.167 +      val constraints = get_constraints_of_typ sign (defvarlist@varlist)
  39.168 +  in
  39.169 +    add_axioms_i (map (apsnd (check_and_extend sign 
  39.170 +                               (map fst defvarlist) (map fst varlist)) o
  39.171 +                   (read_ext_axm_terms sign constraints)) axiom_terms) theory
  39.172 +  end
  39.173 +end;
  39.174 +
  39.175 +
  39.176 +(******** SECTION PARSER : ext_axiom_decls **********)
  39.177 +local 
  39.178 + open ThyParse 
  39.179 +
  39.180 + (* as in the pure section 'rules' : 
  39.181 +    making the "val thmname = get_axiom thy thmname" list *)
  39.182 + val mk_list_of_pairs = mk_big_list o map (mk_pair o apfst quote);
  39.183 + fun mk_val ax = "val " ^ ax ^ " = get_axiom thy " ^ quote ax ^ ";";
  39.184 + val mk_vals = cat_lines o map mk_val;
  39.185 +
  39.186 + (* making the call for the theory extender *) 
  39.187 + fun mk_eaxms_decls ((vars,defvars),axms) = 
  39.188 +     ( "|> ThyAxioms.add_ext_axioms \n  " ^ 
  39.189 +       (mk_list_of_pairs vars) ^ "\n  " ^
  39.190 +       (mk_list_of_pairs defvars) ^ "\n  " ^
  39.191 +       (mk_list_of_pairs axms),
  39.192 +       mk_vals (map fst axms));
  39.193 +
  39.194 + (* parsing the concrete syntax *)    
  39.195 +
  39.196 + val axiom_decls = (repeat1 (ident -- !! string));
  39.197 +
  39.198 + val varlist = "vars" $$-- 
  39.199 +                 repeat1 (ident -- optional ("::" $$-- string) "\"\"");
  39.200 +
  39.201 + val defvarlist = "defvars" $$-- 
  39.202 +                    repeat1 (ident -- optional ("::" $$-- string) "\"\""); 
  39.203 +
  39.204 +in
  39.205 +
  39.206 + val ext_axiom_decls = (optional varlist []) -- (optional defvarlist [])
  39.207 +                         -- ("in" $$-- axiom_decls) >> mk_eaxms_decls;
  39.208 +end; (* local *)
  39.209 +
  39.210 +
  39.211 +(**** new keywords and sections ************************************)
  39.212 +
  39.213 +val axioms_keywords = ["vars", "defvars","in"];
  39.214 +     (* "::" is already a pure keyword *)
  39.215 +
  39.216 +val axioms_sections = [("axioms" , ext_axiom_decls)]
  39.217 +                       
  39.218 +end; (* the structure *)
  39.219 +
    40.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    40.2 +++ b/src/HOLCF/ax_ops/thy_ops.ML	Fri Oct 06 17:25:24 1995 +0100
    40.3 @@ -0,0 +1,439 @@
    40.4 +(*  TTITLEF/thy_ops.ML
    40.5 +    ID:         $Id$
    40.6 +    Author:     Tobias Mayr
    40.7 +
    40.8 +Additional theory file section for HOLCF: ops 
    40.9 +There's an elaborate but german description of this program,
   40.10 +write to mayrt@informatik.tu-muenchen.de.
   40.11 +For a short english description of the new sections
   40.12 +write to regensbu@informatik.tu-muenchen.de. 
   40.13 +
   40.14 +TODO: vielleicht AST-Darstellung mit "op name" statt _I_...
   40.15 +
   40.16 +*)
   40.17 +
   40.18 +signature THY_OPS =
   40.19 +sig
   40.20 + (* continuous mixfixes (extension of datatype PrivateSyntax.Mixfix.mixfix) *)
   40.21 + datatype cmixfix =
   40.22 +    Mixfix of PrivateSyntax.Mixfix.mixfix |
   40.23 +    CInfixl of int | 
   40.24 +    CInfixr of int |
   40.25 +    CMixfix of string * int list *int;
   40.26 +
   40.27 + exception CINFIX of cmixfix;
   40.28 + val cmixfix_to_mixfix : cmixfix ->  PrivateSyntax.Mixfix.mixfix;
   40.29 +
   40.30 + (* theory extenders : *)
   40.31 + val add_ops          : {curried: bool, total: bool, strict: bool} ->
   40.32 +                        (string * string * cmixfix) list -> theory -> theory;
   40.33 + val add_ops_i        : {curried: bool, total: bool, strict: bool} ->
   40.34 +                        (string * typ * cmixfix) list -> theory -> theory;
   40.35 + val ops_keywords  : string list;
   40.36 + val ops_sections  : (string * (ThyParse.token list -> 
   40.37 +                        (string * string) * ThyParse.token list)) list;
   40.38 + val opt_cmixfix: ThyParse.token list -> (string * ThyParse.token list);
   40.39 + val const_name    : string -> cmixfix -> string;
   40.40 +end;
   40.41 +
   40.42 +structure ThyOps : THY_OPS =
   40.43 +struct
   40.44 +
   40.45 +open HOLCFlogic;
   40.46 +
   40.47 +(** library ******************************************************)
   40.48 +
   40.49 +(* abbreviations *)
   40.50 +val internal = fst; (* cinfix-ops will have diffrent internal/external names *)
   40.51 +val external = snd;
   40.52 +
   40.53 +fun apsnd_of_three f = fn (a,b,c) => (a,f b,c);
   40.54 +
   40.55 +
   40.56 +(******** ops ********************)
   40.57 +
   40.58 +(* the extended copy of mixfix *)
   40.59 +datatype cmixfix =
   40.60 +    Mixfix of PrivateSyntax.Mixfix.mixfix |
   40.61 +    CInfixl of int |
   40.62 +    CInfixr of int |
   40.63 +    CMixfix of string * int list *int;
   40.64 +
   40.65 +exception CINFIX of cmixfix;
   40.66 +
   40.67 +fun cmixfix_to_mixfix (Mixfix x) = x
   40.68 +  | cmixfix_to_mixfix x = raise CINFIX x;
   40.69 +
   40.70 +
   40.71 +(** theory extender : add_ops *)
   40.72 +
   40.73 +(* generating the declarations of the new constants. *************
   40.74 +   cinfix names x are internally non infix (renamed by mk_internal_name) 
   40.75 +   and externally non continous infix function names (changed by op_to_fun).
   40.76 +   Thus the cinfix declaration is splitted in an 'oldstyle' decl,
   40.77 +   which is NoSyn (non infix) and is added by add_consts_i,
   40.78 +   and an syn(tactic) decl, which is an infix function (not operation)
   40.79 +   added by add_syntax_i, so that it can appear in input strings, but 
   40.80 +   not in terms.
   40.81 +   The interface between internal and external names is realized by 
   40.82 +   transrules A x B <=> _x ' A ' B (generated by xrules_of) 
   40.83 +   The boolean argument 'curried' distinguishes between curried and
   40.84 +   tupeled syntax of operation application *)
   40.85 +   
   40.86 +local
   40.87 + fun strip ("'" :: c :: cs) = c :: strip cs
   40.88 +   | strip ["'"] = []
   40.89 +   | strip (c :: cs) = c :: strip cs
   40.90 +   | strip [] = [];
   40.91 +
   40.92 + val strip_esc = implode o strip o explode;
   40.93 +
   40.94 + fun infix_name c = "op " ^ strip_esc c;
   40.95 +in
   40.96 +  val mk_internal_name = infix_name;
   40.97 +(*
   40.98 +(* changing e.g. 'ab' to '_I_97_98'. 
   40.99 +   Called by oldstyle, xrules_of, strictness_axms and totality_axms. *)
  40.100 +  fun mk_internal_name name =
  40.101 +  let fun alphanum (s::ss) = "_"^(string_of_int (ord s))^(alphanum ss)
  40.102 +        | alphanum [] = "";
  40.103 +  in 
  40.104 +      "_I"^(alphanum o explode) name
  40.105 +  end;
  40.106 +*)
  40.107 + (* extension of Pure/Syntax/mixfix.ML: SynExt.const_name *)
  40.108 + fun const_name c (CInfixl _) = mk_internal_name c
  40.109 +   | const_name c (CInfixr _) = mk_internal_name c
  40.110 +   | const_name c (CMixfix _) = c
  40.111 +   | const_name c (Mixfix  x) = Syntax.const_name c x;
  40.112 +end;
  40.113 +
  40.114 +(* Changing a->b->c res. a*b->c to a=>b=>c. Called by syn_decls. *) 
  40.115 +(*####*)
  40.116 +fun op_to_fun true  sign (Type("->" ,[larg,t]))=
  40.117 +					 Type("fun",[larg,op_to_fun true sign t])
  40.118 +  | op_to_fun false sign (Type("->",[args,res])) = let
  40.119 +		fun otf (Type("*",[larg,rargs])) = Type("fun",[larg,otf rargs])
  40.120 +		|   otf t			 = Type("fun",[t,res]);
  40.121 +		in otf args end
  40.122 +  | op_to_fun _     sign t = t(*error("Wrong type for cinfix/cmixfix : "^
  40.123 +                              (Sign.string_of_typ sign t))*);
  40.124 +(*####*)
  40.125 +
  40.126 +(* oldstyle is called by add_ext_axioms(_i) *)
  40.127 +    (* the first part is just copying the homomorphic part of the structures *)
  40.128 +fun oldstyle ((name,typ,Mixfix(x))::tl) = 
  40.129 +         (name,typ,x)::(oldstyle tl)
  40.130 +  | oldstyle ((name,typ,CInfixl(i))::tl) = 
  40.131 +         (mk_internal_name name,typ,PrivateSyntax.Mixfix.NoSyn)::
  40.132 +         (oldstyle tl)
  40.133 +  | oldstyle ((name,typ,CInfixr(i))::tl) =
  40.134 +         (mk_internal_name name,typ,PrivateSyntax.Mixfix.NoSyn)::
  40.135 +         (oldstyle tl) 
  40.136 +  | oldstyle ((name,typ,CMixfix(x))::tl) =
  40.137 +         (name,typ,PrivateSyntax.Mixfix.NoSyn)::
  40.138 +         (oldstyle tl) 
  40.139 +  | oldstyle [] = [];
  40.140 +
  40.141 +(* generating the external purely syntactical infix functions. 
  40.142 +   Called by add_ext_axioms(_i) *)
  40.143 +fun syn_decls curried sign ((name,typ,CInfixl(i))::tl) =
  40.144 +     (name,op_to_fun curried sign typ,PrivateSyntax.Mixfix.Infixl(i))::
  40.145 +      (syn_decls curried sign tl)
  40.146 +  | syn_decls curried sign ((name,typ,CInfixr(i))::tl) =
  40.147 +     (name,op_to_fun curried sign typ,PrivateSyntax.Mixfix.Infixr(i))::
  40.148 +      (syn_decls curried sign tl)
  40.149 +  | syn_decls curried sign ((name,typ,CMixfix(x))::tl) =
  40.150 +(*####
  40.151 +     ("@"^name,op_to_fun curried sign typ,PrivateSyntax.Mixfix.Mixfix(x))::
  40.152 +####**)
  40.153 +     (name,op_to_fun curried sign typ,PrivateSyntax.Mixfix.Mixfix(x))::
  40.154 +
  40.155 +      (syn_decls curried sign tl)
  40.156 +  | syn_decls curried sign (_::tl) = syn_decls curried sign tl
  40.157 +  | syn_decls _ _ [] = [];
  40.158 +
  40.159 +(* generating the translation rules. Called by add_ext_axioms(_i) *)
  40.160 +local open PrivateSyntax.Ast in 
  40.161 +fun xrules_of true ((name,typ,CInfixl(i))::tail) = 
  40.162 +    ((mk_appl (Constant (mk_internal_name name)) [Variable "A",Variable "B"]) <->
  40.163 +     (mk_appl (Constant "@fapp") [(mk_appl (Constant "@fapp") [
  40.164 +      Constant (mk_internal_name name),Variable "A"]),Variable "B"]))
  40.165 +    ::xrules_of true tail
  40.166 +  | xrules_of true ((name,typ,CInfixr(i))::tail) = 
  40.167 +    ((mk_appl (Constant (mk_internal_name name)) [Variable "A",Variable "B"]) <->
  40.168 +     (mk_appl (Constant "@fapp") [(mk_appl (Constant "@fapp") [
  40.169 +      Constant (mk_internal_name name),Variable "A"]),Variable "B"]))
  40.170 +    ::xrules_of true tail
  40.171 +(*####*)
  40.172 +  | xrules_of true ((name,typ,CMixfix(_))::tail) = let
  40.173 +	fun argnames n (Type("->" ,[_,t]))= chr n :: argnames (n+1) t
  40.174 +	|   argnames _ _ = [];
  40.175 +	val names = argnames (ord"A") typ;
  40.176 +	in if names = [] then [] else [mk_appl (Constant name) (map Variable names)<->
  40.177 +	    foldl (fn (t,arg) => (mk_appl (Constant "@fapp") [t,Variable arg]))
  40.178 +		  (Constant name,names)] end
  40.179 +    @xrules_of true tail
  40.180 +(*####*)
  40.181 +  | xrules_of false ((name,typ,CInfixl(i))::tail) = 
  40.182 +    ((mk_appl (Constant (mk_internal_name name)) [Variable "A",Variable "B"]) <->
  40.183 +    (mk_appl (Constant "@fapp") [ Constant(mk_internal_name name),
  40.184 +     (mk_appl (Constant "@ctuple") [Variable "A",Variable "B"])]))
  40.185 +    ::xrules_of false tail
  40.186 +  | xrules_of false ((name,typ,CInfixr(i))::tail) = 
  40.187 +    ((mk_appl (Constant (mk_internal_name name)) [Variable "A",Variable "B"]) <->
  40.188 +    (mk_appl (Constant "@fapp") [ Constant(mk_internal_name name),
  40.189 +     (mk_appl (Constant "@ctuple") [Variable "A",Variable "B"])]))
  40.190 +    ::xrules_of false tail
  40.191 +(*####*)
  40.192 +  | xrules_of false ((name,typ,CMixfix(_))::tail) = let
  40.193 +	fun foldr' f l =
  40.194 +	  let fun itr []  = raise LIST "foldr'"
  40.195 +	        | itr [a] = a
  40.196 +	        | itr (a::l) = f(a, itr l)
  40.197 +	  in  itr l end;
  40.198 +	fun argnames n (Type("*" ,[_,t]))= chr n :: argnames (n+1) t
  40.199 +	|   argnames n _ = [chr n];
  40.200 +	val vars = map Variable (case typ of (Type("->" ,[t,_])) =>argnames (ord"A") t
  40.201 +					     | _ => []);
  40.202 +	in if vars = [] then [] else [mk_appl (Constant name) vars <->
  40.203 +	    (mk_appl (Constant "@fapp") [Constant name, case vars of [v] => v
  40.204 +		| args => mk_appl (Constant "@ctuple") [hd args,foldr' (fn (t,arg) => 
  40.205 +				mk_appl (Constant "_args") [t,arg]) (tl args)]])]
  40.206 +	end
  40.207 +    @xrules_of false tail
  40.208 +(*####*)
  40.209 +  | xrules_of c ((name,typ,Mixfix(_))::tail) = xrules_of c tail
  40.210 +  | xrules_of _ [] = [];
  40.211 +end; 
  40.212 +(**** producing the new axioms ****************)
  40.213 +
  40.214 +datatype arguments = Curried_args of ((typ*typ) list) |
  40.215 +                     Tupeled_args of (typ list);
  40.216 +
  40.217 +fun num_of_args (Curried_args l) = length l
  40.218 +  | num_of_args (Tupeled_args l) = length l;
  40.219 +
  40.220 +fun types_of (Curried_args l) = map fst l
  40.221 +  | types_of (Tupeled_args l) = l;
  40.222 +
  40.223 +fun mk_mkNotEqUU_vars (typ::tl) cnt = mkNotEqUU (Free("x"^(string_of_int cnt),typ))::
  40.224 +                            (mk_mkNotEqUU_vars tl (cnt+1))
  40.225 +  | mk_mkNotEqUU_vars [] _ = [];
  40.226 +
  40.227 +local
  40.228 + (* T1*...*Tn goes to [T1,...,Tn] *)
  40.229 + fun args_of_tupel (Type("*",[left,right])) = left::(args_of_tupel right)
  40.230 +   | args_of_tupel T = [T];
  40.231 + 
  40.232 + (* A1->...->An->R goes to [(A1,B1),...,(An,Bn)] where Bi=Ai->...->An->R 
  40.233 +    Bi is the Type of the function that is applied to an Ai type argument *)
  40.234 + fun args_of_curried (typ as (Type("->",[S,T]))) = 
  40.235 +      (S,typ) :: args_of_curried T
  40.236 +   | args_of_curried _ = [];
  40.237 +in
  40.238 + fun args_of_op true typ = Curried_args(rev(args_of_curried typ))
  40.239 +   | args_of_op false (typ as (Type("->",[S,T]))) = 
  40.240 +      Tupeled_args(args_of_tupel S)
  40.241 +   | args_of_op false _ = Tupeled_args([]);
  40.242 +end;
  40.243 +
  40.244 +(* generates for the type t the type of the fapp constant 
  40.245 +   that will be applied to t *)
  40.246 +fun mk_fapp_typ (typ as Type("->",argl)) = Type("fun",[typ,Type("fun",argl)]) 
  40.247 +  | mk_fapp_typ t = (print t;
  40.248 +                    error("Internal error:mk_fapp_typ: wrong argument\n"));
  40.249 +                    
  40.250 +fun mk_arg_tupel_UU uu_pos [typ] n = 
  40.251 +     if n<>uu_pos then Free("x"^(string_of_int n),typ)
  40.252 +                  else Const("UU",typ)
  40.253 +  | mk_arg_tupel_UU uu_pos (typ::tail) n = 
  40.254 +     mkCPair
  40.255 +     (if n<>uu_pos then Free("x"^(string_of_int n),typ) 
  40.256 +                   else Const("UU",typ))
  40.257 +     (mk_arg_tupel_UU uu_pos tail (n+1))
  40.258 +  | mk_arg_tupel_UU _ [] _ = error("Internal error:mk_arg_tupel: empty list");
  40.259 +
  40.260 +fun mk_app_UU cnt uu_pos fname (Curried_args((typ,ftyp)::tl)) = 
  40.261 +     Const("fapp",mk_fapp_typ ftyp) $
  40.262 +     (mk_app_UU (cnt-1) uu_pos fname (Curried_args tl))$ 
  40.263 +     (if cnt = uu_pos then Const("UU",typ)
  40.264 +                      else Free("x"^(string_of_int cnt),typ))
  40.265 +  | mk_app_UU _ _ (name,typ) (Curried_args []) = Const(name,typ)
  40.266 +  | mk_app_UU cnt uu_pos (name,typ) (Tupeled_args []) = Const(name,typ)
  40.267 +  | mk_app_UU cnt uu_pos (name,typ) (Tupeled_args list) = 
  40.268 +     Const("fapp",mk_fapp_typ typ) $ Const(name,typ) $ 
  40.269 +     mk_arg_tupel_UU uu_pos list 0;
  40.270 +
  40.271 +fun mk_app cnt fname args = mk_app_UU cnt (~1) fname args;
  40.272 +
  40.273 +(* producing the strictness axioms *)
  40.274 +local
  40.275 + fun s_axm_of curried name typ args num cnt = 
  40.276 +       if cnt = num then 
  40.277 +        error("Internal error: s_axm_of: arg is no operation "^(external name))
  40.278 +       else 
  40.279 +       let val app = mk_app_UU (num-1) cnt (internal name,typ) args
  40.280 +           val equation = HOLogic.mk_eq(app,Const("UU",fastype_of app)) 
  40.281 +       in 
  40.282 +        if cnt = num-1 then equation
  40.283 +        else And $ equation $
  40.284 +             s_axm_of curried name typ args num (cnt+1)
  40.285 +       end;
  40.286 +in
  40.287 + fun strictness_axms curried ((rawname,typ,cmixfix)::tail) =
  40.288 +  let val name = case cmixfix of
  40.289 +                      (CInfixl _) => (mk_internal_name rawname,rawname)
  40.290 +                    | (CInfixr _) => (mk_internal_name rawname,rawname)
  40.291 +                    |  _          => (rawname,rawname)
  40.292 +      val args = args_of_op curried typ;
  40.293 +      val num  = num_of_args args;
  40.294 +  in
  40.295 +      ((external name)^"_strict",
  40.296 +       if num <> 0
  40.297 +       then HOLogic.mk_Trueprop(s_axm_of curried name typ args num 0) 
  40.298 +       else HOLogic.mk_Trueprop(True)) :: strictness_axms curried tail
  40.299 +  end
  40.300 +   | strictness_axms _ [] = [];
  40.301 +end; (*local*)
  40.302 +
  40.303 +(* producing the totality axioms *)
  40.304 +
  40.305 +fun totality_axms curried ((rawname,typ,cmixfix)::tail) =
  40.306 + let val name  = case cmixfix of
  40.307 +                     (CInfixl _) => (mk_internal_name rawname,rawname)
  40.308 +                   | (CInfixr _) => (mk_internal_name rawname,rawname)
  40.309 +                   | _           => (rawname,rawname)
  40.310 +     val args  = args_of_op curried typ;
  40.311 +     val prems = mk_mkNotEqUU_vars (if curried then rev (types_of args)
  40.312 +                                           else (types_of args)) 0;
  40.313 +     val term  = mk_app (num_of_args args - 1) (internal name,typ) args;
  40.314 + in
  40.315 +     ((external name)^"_total", 
  40.316 +      if num_of_args args <> 0 
  40.317 +      then Logic.list_implies (prems,mkNotEqUU term)
  40.318 +      else HOLogic.mk_Trueprop(True)) :: totality_axms curried tail
  40.319 + end
  40.320 +  | totality_axms _ [] = [];
  40.321 +
  40.322 +
  40.323 +
  40.324 +(* the theory extenders ****************************)
  40.325 +
  40.326 +fun add_ops {curried,strict,total} raw_decls thy =
  40.327 +  let val {sign,...} = rep_theory thy;
  40.328 +      val decls = map (apsnd_of_three (typ_of o read_ctyp sign)) raw_decls;
  40.329 +      val oldstyledecls = oldstyle decls;
  40.330 +      val syndecls = syn_decls curried sign decls;
  40.331 +      val xrules = xrules_of curried decls;
  40.332 +      val s_axms = (if strict then strictness_axms curried decls else []);
  40.333 +      val t_axms = (if total  then totality_axms   curried decls else []);
  40.334 +  in 
  40.335 +  add_trrules_i xrules (add_axioms_i (s_axms @ t_axms) 
  40.336 +                     (add_syntax_i syndecls (add_consts_i oldstyledecls thy)))
  40.337 +  end;
  40.338 +
  40.339 +fun add_ops_i {curried,strict,total} decls thy =
  40.340 +  let val {sign,...} = rep_theory thy;
  40.341 +      val oldstyledecls = oldstyle decls;
  40.342 +      val syndecls = syn_decls curried sign decls;
  40.343 +      val xrules = xrules_of curried decls;
  40.344 +      val s_axms = (if strict then strictness_axms curried decls else []);
  40.345 +      val t_axms = (if total  then totality_axms   curried decls else []);
  40.346 +  in 
  40.347 +  add_trrules_i xrules (add_axioms_i (s_axms @ t_axms) 
  40.348 +                     (add_syntax_i syndecls (add_consts_i oldstyledecls thy)))
  40.349 +  end;
  40.350 +
  40.351 +
  40.352 +(* parser: ops_decls ********************************)
  40.353 +
  40.354 +local open ThyParse 
  40.355 +in
  40.356 +(* the following is an adapted version of const_decls from thy_parse.ML *)
  40.357 +
  40.358 +val names1 = list1 name;
  40.359 +
  40.360 +val split_decls = flat o map (fn (xs, y) => map (rpair y) xs);
  40.361 +
  40.362 +fun mk_triple2 (x, (y, z)) = mk_triple (x, y, z);
  40.363 +
  40.364 +fun mk_strict_vals [] = ""
  40.365 +  | mk_strict_vals [name] =
  40.366 +      "get_axiom thy \""^name^"_strict\"\n"
  40.367 +  | mk_strict_vals (name::tail) =
  40.368 +      "get_axiom thy \""^name^"_strict\",\n"^
  40.369 +      mk_strict_vals tail;
  40.370 +  
  40.371 +fun mk_total_vals [] = ""
  40.372 +  | mk_total_vals [name] = 
  40.373 +      "get_axiom thy \""^name^"_total\"\n"
  40.374 +  | mk_total_vals (name::tail) =
  40.375 +      "get_axiom thy \""^name^"_total\",\n"^
  40.376 +      mk_total_vals tail;
  40.377 +
  40.378 +fun mk_ops_decls (((curried,strict),total),list) =
  40.379 +          (* call for the theory extender *)
  40.380 +           ("|> ThyOps.add_ops \n"^
  40.381 +            "{ curried = "^curried^" , strict = "^strict^
  40.382 +               " , total = "^total^" } \n"^
  40.383 +            (mk_big_list o map mk_triple2) list^";\n"^
  40.384 +            "val strict_axms = []; val total_axms = [];\nval thy = thy\n",
  40.385 +          (* additional declarations *)
  40.386 +            (if strict="true" then "val strict_axms = strict_axms @ [\n"^
  40.387 +               mk_strict_vals (map (strip_quotes o fst) list)^
  40.388 +               "];\n"             
  40.389 +             else "")^
  40.390 +            (if total="true" then "val total_axms = total_axms @ [\n"^
  40.391 +               mk_total_vals (map (strip_quotes o fst) list)^
  40.392 +               "];\n"             
  40.393 +             else ""));
  40.394 +
  40.395 +(* mixfix annotations *)
  40.396 +
  40.397 +fun cat_parens pre1 pre2 s = cat pre1 (parens (cat pre2 s));
  40.398 +
  40.399 +val infxl = "infixl" $$-- !! nat >> cat_parens "ThyOps.Mixfix" "Infixl";
  40.400 +val infxr = "infixr" $$-- !! nat >> cat_parens "ThyOps.Mixfix" "Infixr";
  40.401 +
  40.402 +val cinfxl = "cinfixl" $$-- !! nat >> cat "ThyOps.CInfixl";
  40.403 +val cinfxr = "cinfixr" $$-- !! nat >> cat "ThyOps.CInfixr";
  40.404 +
  40.405 +val opt_pris = optional ("[" $$-- !! (list nat --$$ "]")) [] >> mk_list;
  40.406 +
  40.407 +val cmixfx = "cmixfix" $$-- string -- !! (opt_pris -- optional nat "max_pri")
  40.408 +  >> (cat "ThyOps.CMixfix" o mk_triple2);
  40.409 +
  40.410 +val bindr = "binder" $$--
  40.411 +  !! (string -- ( ("[" $$-- nat --$$ "]") -- nat
  40.412 +                || nat >> (fn n => (n,n))
  40.413 +     )          )
  40.414 +  >> (cat_parens "ThyOps.Mixfix" "Binder" o mk_triple2);
  40.415 +
  40.416 +val mixfx = string -- !! (opt_pris -- optional nat "max_pri")
  40.417 +  >> (cat_parens "ThyOps.Mixfix" "Mixfix" o mk_triple2);
  40.418 +
  40.419 +fun opt_syn fx = optional ("(" $$-- fx --$$ ")") "ThyOps.Mixfix NoSyn";
  40.420 +
  40.421 +val opt_cmixfix = opt_syn (mixfx || infxl || infxr || bindr || 
  40.422 +                              cinfxl || cinfxr || cmixfx);
  40.423 +
  40.424 +fun ops_decls toks= 
  40.425 +               (optional ($$ "curried" >> K "true") "false" --
  40.426 +                optional ($$ "strict" >> K "true") "false" --
  40.427 +                optional ($$ "total" >> K "true") "false" -- 
  40.428 +                (repeat1 (names1 --$$ "::" -- !! (string -- opt_cmixfix)) 
  40.429 +                 >> split_decls)
  40.430 +                >> mk_ops_decls) toks
  40.431 +
  40.432 +end;
  40.433 +
  40.434 +(*** new keywords and sections: ******************************************)
  40.435 +
  40.436 +val ops_keywords = ["curried","strict","total","cinfixl","cinfixr","cmixfix"];
  40.437 +     (* "::" is already a pure keyword *)
  40.438 +
  40.439 +val ops_sections = [("ops"    , ops_decls) ];
  40.440 +
  40.441 +end; (* the structure ThyOps *)
  40.442 +
    41.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    41.2 +++ b/src/HOLCF/ax_ops/thy_syntax.ML	Fri Oct 06 17:25:24 1995 +0100
    41.3 @@ -0,0 +1,36 @@
    41.4 +(*  Title:      HOLCF/thy_syntax.ML
    41.5 +    ID:         $Id$
    41.6 +    Author:     Tobias Mayr
    41.7 +
    41.8 +Installation of the additional theory file sections for HOLCF: axioms , ops 
    41.9 +There's an elaborate but german description of this extension
   41.10 +and a short english description of the new sections,
   41.11 +write to mayrt@informatik.tu-muenchen.de.
   41.12 +
   41.13 +TODO:
   41.14 +
   41.15 +*)
   41.16 +
   41.17 +(* use "holcflogics.ML"; 
   41.18 +   use "thy_axioms.ML";
   41.19 +   use "thy_ops.ML";      should already have been done in ROOT.ML *)
   41.20 +
   41.21 +structure ThySynData : THY_SYN_DATA =
   41.22 +struct
   41.23 +
   41.24 +open HOLCFlogic;
   41.25 +
   41.26 +val user_keywords = (*####*)filter_out (fn s => s mem (ThyAxioms.axioms_keywords@
   41.27 +		    ThyOps.ops_keywords)) (*####*)ThySynData.user_keywords @ 
   41.28 +                    ThyAxioms.axioms_keywords @ 
   41.29 +                    ThyOps.ops_keywords;
   41.30 +
   41.31 +val user_sections = (*####*)filter_out (fn (s,_) => s mem (map fst (
   41.32 +		    ThyAxioms.axioms_sections@ ThyOps.ops_sections))) (*####*)
   41.33 +		      ThySynData.user_sections @
   41.34 +                    ThyAxioms.axioms_sections @
   41.35 +                    ThyOps.ops_sections;
   41.36 +end;
   41.37 +
   41.38 +structure ThySyn = ThySynFun(ThySynData);
   41.39 +init_thy_reader ();
    42.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    42.2 +++ b/src/HOLCF/domain/axioms.ML	Fri Oct 06 17:25:24 1995 +0100
    42.3 @@ -0,0 +1,161 @@
    42.4 +(* axioms.ML
    42.5 +   ID:         $Id$
    42.6 +   Author : David von Oheimb
    42.7 +   Created: 31-May-95
    42.8 +   Updated: 12-Jun-95 axioms for discriminators, selectors and induction
    42.9 +   Updated: 19-Jun-95 axiom for bisimulation
   42.10 +   Updated: 28-Jul-95 gen_by-section
   42.11 +   Updated: 29-Aug-95 simultaneous domain equations
   42.12 +   Copyright 1995 TU Muenchen
   42.13 +*)
   42.14 +
   42.15 +
   42.16 +structure Domain_Axioms = struct
   42.17 +
   42.18 +local
   42.19 +
   42.20 +open Domain_Library;
   42.21 +infixr 0 ===>;infixr 0 ==>;infix 0 == ; 
   42.22 +infix 1 ===; infix 1 ~= ; infix 1 <<; infix 1 ~<<;
   42.23 +infix 9 `   ; infix 9 `% ; infix 9 `%%; infixr 9 oo;
   42.24 +
   42.25 +fun infer_types thy' = map (inferT_axm (sign_of thy'));
   42.26 +
   42.27 +fun calc_axioms comp_dname (eqs : eq list) n (((dname,_),cons) : eq)=
   42.28 +let
   42.29 +
   42.30 +(* ----- axioms and definitions concerning the isomorphism ------------------------ *)
   42.31 +
   42.32 +  val dc_abs = %%(dname^"_abs");
   42.33 +  val dc_rep = %%(dname^"_rep");
   42.34 +  val x_name'= "x";
   42.35 +  val x_name = idx_name eqs x_name' (n+1);
   42.36 +
   42.37 +  val ax_abs_iso = (dname^"_abs_iso",mk_trp(dc_rep`(dc_abs`%x_name') === %x_name'));
   42.38 +  val ax_rep_iso = (dname^"_rep_iso",mk_trp(dc_abs`(dc_rep`%x_name') === %x_name'));
   42.39 +
   42.40 +  val ax_when_def = (dname^"_when_def",%%(dname^"_when") == 
   42.41 +	   foldr (uncurry /\ ) (when_funs cons, /\x_name'((when_body cons (fn (x,y) =>
   42.42 +				Bound(1+length cons+x-y)))`(dc_rep`Bound 0))));
   42.43 +
   42.44 +  val ax_copy_def = let
   42.45 +    fun simp_oo (Const ("fapp", _) $ (Const ("fapp", _) $ 
   42.46 + 		 Const ("cfcomp", _) $ fc) $ Const ("ID", _)) = fc
   42.47 +    |   simp_oo t = t;
   42.48 +    fun simp_app (Const ("fapp", _) $ Const ("ID", _) $ t) = t
   42.49 +    |   simp_app t = t;
   42.50 +	fun mk_arg m n arg  = (if is_lazy arg 
   42.51 +			       then fn t => %%"lift"`(simp_oo (%%"up" oo t)) else Id)
   42.52 +			      (if_rec arg (cproj (Bound (2*min[n,m])) eqs) (%%"ID"));
   42.53 +	fun mk_prod (t1,t2)  = %%"ssplit"`(/\ "x" (/\ "y" (%%"spair"`
   42.54 +					 simp_app(t1`Bound 1)`simp_app(t2`Bound 0))));
   42.55 +	fun one_con (_,args) = if args = [] then %%"ID" else
   42.56 +			       foldr' mk_prod (mapn (mk_arg (length args-1)) 1 args);
   42.57 +	fun mk_sum  (t1,t2)  = %%"sswhen"`(simp_oo (%%"sinl" oo t1))
   42.58 +					 `(simp_oo (%%"sinr" oo t2));
   42.59 +	in (dname^"_copy_def", %%(dname^"_copy") == /\"f" 
   42.60 +			  (dc_abs oo foldr' mk_sum (map one_con cons) oo dc_rep)) end;
   42.61 +
   42.62 +(* ----- definitions concerning the constructors, discriminators and selectors ---- *)
   42.63 +
   42.64 +  val axs_con_def = let
   42.65 +	fun idxs z x arg = (if is_lazy arg then fn x => %%"up"`x else Id)(Bound(z-x));
   42.66 +	fun prms [] = %%"one"
   42.67 +	|   prms vs = foldr' (fn(x,t)=> %%"spair"`x`t) (mapn (idxs (length vs)) 1 vs);
   42.68 +	val injs    = bin_branchr (fn l=> l@["l"]) (fn l=> l@["r"]);
   42.69 +	fun cdef ((con,args),injs) = (extern_name con ^"_def",%%con == 
   42.70 +		 foldr /\# (args,dc_abs`
   42.71 +		(foldr (fn (i,t) => %%("sin"^i)`t ) (injs, prms args))));
   42.72 +	in map cdef (cons~~(mapn (fn n => K(injs [] cons n)) 0 cons)) end;
   42.73 +
   42.74 +  val axs_dis_def = let
   42.75 +	fun ddef (con,_) = (dis_name con ^"_def",%%(dis_name con) == 
   42.76 +		 mk_cfapp(%%(dname^"_when"),map 
   42.77 +			(fn (con',args) => (foldr /\#
   42.78 +			   (args,if con'=con then %%"TT" else %%"FF"))) cons))
   42.79 +	in map ddef cons end;
   42.80 +
   42.81 +  val axs_sel_def = let
   42.82 +	fun sdef con n arg = (sel_of arg^"_def",%%(sel_of arg) == 
   42.83 +		 mk_cfapp(%%(dname^"_when"),map 
   42.84 +			(fn (con',args) => if con'<>con then %%"UU" else
   42.85 +			 foldr /\# (args,Bound (length args - n))) cons));
   42.86 +	in flat(map (fn (con,args) => mapn (sdef con) 1 args) cons) end;
   42.87 +
   42.88 +
   42.89 +(* ----- axiom and definitions concerning induction ------------------------------- *)
   42.90 +
   42.91 +  fun cproj' T = cproj T eqs n;
   42.92 +  val ax_reach    = (dname^"_reach"   , mk_trp(cproj'(%%"fix"`%%(comp_dname^"_copy"))
   42.93 +					`%x_name === %x_name));
   42.94 +  val ax_take_def = (dname^"_take_def",%%(dname^"_take") == mk_lam("n",
   42.95 +		    cproj'(%%"iterate" $ Bound 0 $ %%(comp_dname^"_copy") $ %%"UU")));
   42.96 +  val ax_finite_def = (dname^"_finite_def",%%(dname^"_finite") == mk_lam(x_name,
   42.97 +	mk_ex("n",(%%(dname^"_take") $ Bound 0)`Bound 1 === Bound 1)));
   42.98 +
   42.99 +in [ax_abs_iso, ax_rep_iso, ax_when_def, ax_copy_def] @
  42.100 +    axs_con_def @ axs_dis_def @ axs_sel_def @
  42.101 +   [ax_reach, ax_take_def, ax_finite_def] end;
  42.102 +
  42.103 +
  42.104 +in (* local *)
  42.105 +
  42.106 +fun add_axioms (comp_dname, eqs : eq list) thy' =let
  42.107 +  val dnames = map (fst o fst) eqs;
  42.108 +  val x_name = idx_name dnames "x"; 
  42.109 +  fun copy_app dname = %%(dname^"_copy")`Bound 0;
  42.110 +  val ax_copy_def  = (comp_dname^"_copy_def" , %%(comp_dname^"_copy") ==
  42.111 +					   /\"f"(foldr' cpair (map copy_app dnames)));
  42.112 +  val ax_bisim_def = (comp_dname^"_bisim_def",%%(comp_dname^"_bisim") == mk_lam("R",
  42.113 +    let
  42.114 +      fun one_con (con,args) = let
  42.115 +	val nonrec_args = filter_out is_rec args;
  42.116 +	val    rec_args = filter     is_rec args;
  42.117 +	val nonrecs_cnt = length nonrec_args;
  42.118 +	val    recs_cnt = length    rec_args;
  42.119 +	val allargs     = nonrec_args @ rec_args
  42.120 +				      @ map (upd_vname (fn s=> s^"'")) rec_args;
  42.121 +	val allvns      = map vname allargs;
  42.122 +	fun vname_arg s arg = if is_rec arg then vname arg^s else vname arg;
  42.123 +	val vns1        = map (vname_arg "" ) args;
  42.124 +	val vns2        = map (vname_arg "'") args;
  42.125 +	val allargs_cnt = nonrecs_cnt + 2*recs_cnt;
  42.126 +	val rec_idxs    = (recs_cnt-1) downto 0;
  42.127 +	val nonlazy_idxs = map snd (filter_out (fn (arg,_) => is_lazy arg)
  42.128 +					   (allargs~~((allargs_cnt-1) downto 0)));
  42.129 +	fun rel_app i ra = proj (Bound(allargs_cnt+2)) dnames (rec_of ra) $ 
  42.130 +			   Bound (2*recs_cnt-i) $ Bound (recs_cnt-i);
  42.131 +	val capps = foldr mk_conj (mapn rel_app 1 rec_args,
  42.132 +	 mk_conj(Bound(allargs_cnt+1)===mk_cfapp(%%con,map (bound_arg allvns) vns1),
  42.133 +		 Bound(allargs_cnt+0)===mk_cfapp(%%con,map (bound_arg allvns) vns2)));
  42.134 +        in foldr mk_ex (allvns, foldr mk_conj 
  42.135 +				      (map (defined o Bound) nonlazy_idxs,capps)) end;
  42.136 +      fun one_comp n (_,cons) = mk_all(x_name (n+1), mk_all(x_name (n+1)^"'", mk_imp(
  42.137 +	 		proj (Bound 2) dnames n $ Bound 1 $ Bound 0,
  42.138 +         foldr' mk_disj (mk_conj(Bound 1 === UU,Bound 0 === UU)::map one_con cons))));
  42.139 +    in foldr' mk_conj (mapn one_comp 0 eqs)end ));
  42.140 +  val thy_axs = flat (mapn (calc_axioms comp_dname eqs) 0 eqs) @
  42.141 +		(if length eqs>1 then [ax_copy_def] else []) @ [ax_bisim_def];
  42.142 +in thy' |> add_axioms_i (infer_types thy' thy_axs) end;
  42.143 +
  42.144 +
  42.145 +fun add_gen_by ((tname,finite),(typs,cnstrs)) thy' = let
  42.146 +  fun pred_name typ ="P"^(if typs=[typ] then "" else string_of_int(1+find(typ,typs)));
  42.147 +  fun lift_adm t = lift (fn typ => %%"adm" $ %(pred_name typ)) 
  42.148 +			(if finite then [] else typs,t);
  42.149 +  fun lift_pred_UU t = lift (fn typ => %(pred_name typ) $ UU) (typs,t);
  42.150 +  fun one_cnstr (cnstr,vns,(args,res)) = let 
  42.151 +			val rec_args = filter (fn (_,typ) => typ mem typs)(vns~~args);
  42.152 +			val app = mk_cfapp(%%cnstr,map (bound_arg vns) vns);
  42.153 +		     in foldr mk_All (vns,
  42.154 +			 lift (fn (vn,typ) => %(pred_name typ) $ bound_arg vns vn)
  42.155 +			      (rec_args,defined app ==> %(pred_name res)$app)) end;
  42.156 +  fun one_conc typ = let val pn = pred_name typ in
  42.157 +		     %pn $ %("x"^implode(tl(explode pn))) end;
  42.158 +  val concl = mk_trp(foldr' mk_conj (map one_conc typs));
  42.159 +  val induct =(tname^"_induct",lift_adm(lift_pred_UU(
  42.160 +			foldr (op ===>) (map one_cnstr cnstrs,concl))));
  42.161 +in thy' |> add_axioms_i (infer_types thy' [induct]) end;
  42.162 +
  42.163 +end; (* local *)
  42.164 +end; (* struct *)
    43.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    43.2 +++ b/src/HOLCF/domain/extender.ML	Fri Oct 06 17:25:24 1995 +0100
    43.3 @@ -0,0 +1,123 @@
    43.4 +(* extender.ML
    43.5 +   ID:         $Id$
    43.6 +   Author : David von Oheimb
    43.7 +   Created: 17-May-95
    43.8 +   Updated: 31-May-95 extracted syntax.ML, theorems.ML
    43.9 +   Updated: 07-Jul-95 streamlined format of cons list
   43.10 +   Updated: 21-Jul-95 gen_by-section
   43.11 +   Updated: 28-Aug-95 simultaneous domain equations
   43.12 +   Copyright 1995 TU Muenchen
   43.13 +*)
   43.14 +
   43.15 +
   43.16 +structure Extender =
   43.17 +struct
   43.18 +
   43.19 +local
   43.20 +
   43.21 +open Domain_Library;
   43.22 +
   43.23 +(* ----- general testing and preprocessing of constructor list -------------------- *)
   43.24 +
   43.25 +  fun check_domain(eqs':((string * typ list) *
   43.26 +		  (string * ThyOps.cmixfix * (bool*string*typ) list) list) list) = let
   43.27 +    val dtnvs = map fst eqs';
   43.28 +    val cons' = flat (map snd eqs');
   43.29 +    val test_dupl_typs = (case duplicates (map fst dtnvs) of 
   43.30 +	[] => false | dups => error ("Duplicate types: " ^ commas_quote dups));
   43.31 +    val test_dupl_cons = (case duplicates (map first cons') of 
   43.32 +	[] => false | dups => error ("Duplicate constructors: " ^ commas_quote dups));
   43.33 +    val test_dupl_sels = (case duplicates(map second (flat(map third cons'))) of
   43.34 +        [] => false | dups => error ("Duplicate selectors: "^commas_quote dups));
   43.35 +    val test_dupl_tvars = let fun vname (TFree(v,_)) = v
   43.36 +			      |   vname _            = Imposs "extender:vname";
   43.37 +			  in exists (fn tvars => case duplicates (map vname tvars) of
   43.38 +	[] => false | dups => error ("Duplicate type arguments: " ^commas_quote dups))
   43.39 +	(map snd dtnvs) end;
   43.40 +    (*test for free type variables and invalid use of recursive type*)
   43.41 +    val analyse_types = forall (fn ((_,typevars),cons') => 
   43.42 +	forall (fn con' => let
   43.43 +	  val types = map third (third con');
   43.44 +          fun analyse(t as TFree(v,_)) = t mem typevars orelse
   43.45 +					error ("Free type variable " ^ v ^ " on rhs.")
   43.46 +	    | analyse(Type(s,typl)) = (case assoc (dtnvs,s) of None => analyses typl
   43.47 +				      | Some tvs => tvs = typl orelse 
   43.48 +		       error ("Recursion of type " ^ s ^ " with different arguments"))
   43.49 +	    | analyse(TVar _) = Imposs "extender:analyse"
   43.50 +	  and analyses ts = forall analyse ts;
   43.51 +	  in analyses types end) cons' 
   43.52 +	) eqs';
   43.53 +    in true end; (* let *)
   43.54 +
   43.55 +  fun check_gen_by thy' (typs': string list,cnstrss': string list list) = let
   43.56 +    val test_dupl_typs = (case duplicates typs' of [] => false
   43.57 +	  | dups => error ("Duplicate types: " ^ commas_quote dups));
   43.58 +    val test_dupl_cnstrs = map (fn cnstrs' => (case duplicates cnstrs' of [] => false
   43.59 +	  | dups => error ("Duplicate constructors: " ^ commas_quote dups))) cnstrss';
   43.60 +    val tsig = #tsig(Sign.rep_sg(sign_of thy'));
   43.61 +    val tycons = map fst (#tycons(Type.rep_tsig tsig));
   43.62 +    val test_types = forall(fn t=>t mem tycons orelse error("Unknown type: "^t))typs';
   43.63 +    val cnstrss = let
   43.64 +	fun type_of c = case (Sign.const_type(sign_of thy') c) of Some t => t
   43.65 +				| None => error ("Unknown constructor: "^c);
   43.66 +	fun args_result_type (t as (Type(tn,[arg,rest]))) = 
   43.67 +			if tn = "->" orelse tn = "=>"
   43.68 +			then let val (ts,r) = args_result_type rest in (arg::ts,r) end
   43.69 +			else ([],t)
   43.70 +	|   args_result_type t = ([],t);
   43.71 +    in map (map (fn cn => let val (args,res) = args_result_type (type_of cn) in
   43.72 +	                 (cn,mk_var_names args,(args,res)) end)) cnstrss' 
   43.73 +	: (string * 			(* operator name of constr *)
   43.74 +	   string list *		(* argument name list *)
   43.75 +	   (typ list *			(* argument types *)
   43.76 +	    typ))			(* result type *)
   43.77 +	  list list end;
   43.78 +    fun test_equal_type tn (cn,_,(_,rt)) = fst (type_name_vars rt) = tn orelse
   43.79 +			       error("Inappropriate result type for constructor "^cn);
   43.80 +    val typs = map (fn (tn, cnstrs) => 
   43.81 +		     (map (test_equal_type tn) cnstrs; snd(third(hd(cnstrs)))))
   43.82 +		   (typs'~~cnstrss);
   43.83 +    val test_typs = map (fn (typ,cnstrs) => 
   43.84 +			if not (Type.typ_instance(tsig,typ,TVar(("'a",0),["pcpo"])))
   43.85 +			then error("Not a pcpo type: "^fst(type_name_vars typ))
   43.86 +			else map (fn (cn,_,(_,rt)) => rt=typ 
   43.87 +		 	  orelse error("Non-identical result types for constructors "^
   43.88 +			  first(hd cnstrs)^" and "^ cn )) cnstrs) (typs~~cnstrss);
   43.89 +    val proper_args = let
   43.90 +	fun occurs tn (Type(tn',ts)) = (tn'=tn) orelse exists (occurs tn) ts
   43.91 +	|   occurs _  _              = false;
   43.92 +	fun proper_arg cn atyp = forall (fn typ => let 
   43.93 +				   val tn = fst(type_name_vars typ) 
   43.94 +				   in atyp=typ orelse not (occurs tn atyp) orelse 
   43.95 +				      error("Illegal use of type "^ tn ^
   43.96 +					 " as argument of constructor " ^cn)end )typs;
   43.97 +	fun proper_curry (cn,_,(args,_)) = forall (proper_arg cn) args;
   43.98 +    in map (map proper_curry) cnstrss end;
   43.99 +  in (typs, flat cnstrss) end;
  43.100 +
  43.101 +(* ----- calls for building new thy and thms -------------------------------------- *)
  43.102 +
  43.103 +in
  43.104 +
  43.105 +  fun add_domain (comp_dname,eqs') thy'' = let
  43.106 +    val ok_dummy = check_domain eqs';
  43.107 +    val thy' = thy'' |> Domain_Syntax.add_syntax (comp_dname,eqs');
  43.108 +    val dts  = map (Type o fst) eqs';
  43.109 +    fun cons cons' = (map (fn (con,syn,args) =>
  43.110 +	(ThyOps.const_name con syn,
  43.111 +	 map (fn ((lazy,sel,tp),vn) => ((lazy,
  43.112 +					 find (tp,dts) handle LIST "find" => ~1),
  43.113 +					sel,vn))
  43.114 +	     (args~~(mk_var_names(map third args)))
  43.115 +	 )) cons') : cons list;
  43.116 +    val eqs = map (fn (dtnvs,cons') => (dtnvs,cons cons')) eqs' : eq list;
  43.117 +    val thy         = thy' |> Domain_Axioms.add_axioms (comp_dname,eqs);
  43.118 +  in (thy,eqs) end;
  43.119 +
  43.120 +  fun add_gen_by ((tname,finite),(typs',cnstrss')) thy' = let
  43.121 +   val (typs,cnstrs) = check_gen_by thy' (typs',cnstrss');
  43.122 +  in
  43.123 +   Domain_Axioms.add_gen_by ((tname,finite),(typs,cnstrs)) thy' end;
  43.124 +
  43.125 +end (* local *)
  43.126 +end (* struct *)
    44.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    44.2 +++ b/src/HOLCF/domain/interface.ML	Fri Oct 06 17:25:24 1995 +0100
    44.3 @@ -0,0 +1,165 @@
    44.4 +(* interface.ML
    44.5 +   ID:         $Id$
    44.6 +   Author:      David von Oheimb
    44.7 +   Created: 17-May-95
    44.8 +   Updated: 24-May-95
    44.9 +   Updated: 03-Jun-95 incremental change of ThySyn
   44.10 +   Updated: 11-Jul-95 use of ThyOps for cinfixes
   44.11 +   Updated: 21-Jul-95 gen_by-section
   44.12 +   Updated: 29-Aug-95 simultaneous domain equations
   44.13 +   Updated: 25-Aug-95 better syntax for simultaneous domain equations
   44.14 +   Copyright 1995 TU Muenchen
   44.15 +*)
   44.16 +
   44.17 +local
   44.18 +
   44.19 +structure ThySynData: THY_SYN_DATA = (* overwrites old version of ThySynData!!!!!!! *)
   44.20 +struct
   44.21 +
   44.22 +local 
   44.23 +  open ThyParse;
   44.24 +  open Domain_Library;
   44.25 +
   44.26 +(* ----- generation of bindings for axioms and theorems in trailer of .thy.ML ----- *)
   44.27 +
   44.28 +  fun gt_ax         name   = "get_axiom thy "^quote name;
   44.29 +  fun gen_val dname name   = "val "^name^" = " ^gt_ax (dname^"_"^name)^";";
   44.30 +  fun gen_vall      name l = "val "^name^" = " ^mk_list l^";";
   44.31 +  val rews1 = "iso_rews @ when_rews @\n\
   44.32 + 	      \con_rews @ sel_rews @ dis_rews @ dists_eq @ dists_le @\n\
   44.33 +	      \copy_rews";
   44.34 +
   44.35 +  fun gen_domain eqname num ((dname,_), cons') = let
   44.36 +    val axioms1 = ["abs_iso", "rep_iso", "when_def"];
   44.37 +		   (* con_defs , sel_defs, dis_defs *) 
   44.38 +    val axioms2 = ["copy_def"];
   44.39 +    val theorems = 
   44.40 +	"iso_rews, exhaust, cases, when_rews, con_rews, sel_rews, dis_rews,\n    \
   44.41 +	\dists_eq, dists_le, inverts, injects, copy_rews";
   44.42 +    in
   44.43 +      "structure "^dname^" = struct\n"^
   44.44 +      cat_lines(map (gen_val dname) axioms1)^"\n"^
   44.45 +      gen_vall"con_defs"(map(fn (con,_,_) => gt_ax(strip_esc con^"_def")) cons')^"\n"^
   44.46 +      gen_vall"sel_defs"(flat(map (fn (_,_,args) => map (fn (_,sel,_) => 
   44.47 +					     gt_ax(sel^"_def")) args)    cons'))^"\n"^
   44.48 +      gen_vall"dis_defs"(map(fn (con,_,_) => gt_ax(dis_name_ con^"_def")) 
   44.49 +								          cons')^"\n"^
   44.50 +      cat_lines(map (gen_val dname) axioms2)^"\n"^
   44.51 +      "val ("^ theorems ^") =\n\
   44.52 +      \Domain_Theorems.theorems thy "^eqname^";\n" ^
   44.53 +      (if num > 1 then "val rews = " ^rews1 ^";\n" else "")
   44.54 +    end;
   44.55 +
   44.56 +  fun mk_domain (eqs'') = let
   44.57 +    val dtnvs  = map (type_name_vars o fst) eqs'';
   44.58 +    val dnames = map fst dtnvs;
   44.59 +    val num = length dnames;
   44.60 +    val comp_dname = implode (separate "_" dnames);
   44.61 +    val conss' = map (fn (dname,cons'') =>
   44.62 +      let
   44.63 +	fun sel n m = upd_second (fn None   => dname^"_sel_"^(string_of_int n)^
   44.64 +							 "_"^(string_of_int m)
   44.65 +				  |  Some s => s)
   44.66 +	fun fill_sels n con = upd_third (mapn (sel n) 1) con;
   44.67 +      in mapn fill_sels 1 cons'' end) (dnames~~(map snd eqs''));
   44.68 +    val eqs' = dtnvs~~conss';
   44.69 +
   44.70 +(* ----- generation of argument string for calling add_domain --------------------- *)
   44.71 +
   44.72 +    fun mk_tnv (n,v) = mk_pair(quote n,mk_list(map mk_typ v))
   44.73 +    and mk_typ (TFree(name,sort)) = "TFree"^mk_pair(quote name,makestring sort)
   44.74 +    |   mk_typ (Type (name,args)) = "Type" ^mk_tnv(name,args)
   44.75 +    |   mk_typ _                  = Imposs "interface:mk_typ";
   44.76 +    fun mk_conslist cons' = mk_list (map 
   44.77 +	  (fn (c,syn,ts)=>mk_triple(quote c,syn,mk_list
   44.78 +     (map (fn (b,s ,tp) =>mk_triple(makestring(b:bool),quote s,
   44.79 +				    mk_typ tp)) ts))) cons');
   44.80 +    in
   44.81 +      ("val (thy, "^comp_dname^"_equations) = thy |> Extender.add_domain \n"
   44.82 +      ^ mk_pair(quote comp_dname,
   44.83 +		mk_list(map (fn (t,cs)=> mk_pair (mk_tnv t,mk_conslist cs)) eqs'))
   44.84 +      ^ ";\nval thy = thy",
   44.85 +      let
   44.86 +	fun plural s = if num > 1 then s^"s" else "["^s^"]";
   44.87 +	val comp_axioms   = [(* copy, *) "take_def", "finite_def", "reach" 
   44.88 +			     (*, "bisim_def" *)];
   44.89 +	val comp_theorems = "take_rews, " ^ implode (separate ", " (map plural
   44.90 +				["take_lemma","finite"]))^", finite_ind, ind, coind";
   44.91 +	fun eqname n = "(hd(funpow "^string_of_int n^" tl "^comp_dname^"_equations), "
   44.92 +							   ^comp_dname^"_equations)";
   44.93 +	fun collect sep name = if num = 1 then name else
   44.94 +			   implode (separate sep (map (fn s => s^"."^name) dnames));
   44.95 +      in
   44.96 +	implode (separate "end; (* struct *)\n\n" 
   44.97 +		 (mapn (fn n => gen_domain (eqname n) num) 0 eqs'))^(if num > 1 then
   44.98 +	"end; (* struct *)\n\n\
   44.99 +	\structure "^comp_dname^" = struct\n" else "") ^
  44.100 +	 (if num > 1 then gen_val comp_dname "copy_def" ^"\n" else "") ^
  44.101 +	 implode ((map (fn s => gen_vall (plural s)
  44.102 +		  (map (fn dn => gt_ax(dn ^ "_" ^ s)) dnames) ^"\n") comp_axioms)) ^
  44.103 +	 gen_val comp_dname "bisim_def" ^"\n\
  44.104 +        \val ("^ comp_theorems ^") =\n\
  44.105 +	\Domain_Theorems.comp_theorems thy \
  44.106 +	\(" ^ quote comp_dname   ^ ","^ comp_dname ^"_equations,\n\
  44.107 +	\ ["^collect "," "cases"    ^"],\n\
  44.108 +	\ "^ collect "@" "con_rews " ^",\n\
  44.109 +	\ "^ collect "@" "copy_rews" ^");\n\
  44.110 +	\val rews = "^(if num>1 then collect" @ " "rews"else rews1)^ " @ take_rews;\n\
  44.111 +	\end; (* struct *)"
  44.112 +      end
  44.113 +      ) end;
  44.114 +
  44.115 +  fun mk_gen_by (finite,eqs) = let
  44.116 +      val typs    = map fst eqs;
  44.117 +      val cnstrss = map snd eqs;
  44.118 +      val tname = implode (separate "_" typs) in
  44.119 +      ("|> Extender.add_gen_by "
  44.120 +      ^ mk_pair(mk_pair(quote tname,makestring (finite:bool)),
  44.121 +		mk_pair(mk_list(map quote typs), 
  44.122 +			mk_list (map (fn cns => mk_list(map quote cns)) cnstrss))),
  44.123 +      "val "^tname^"_induct = " ^gt_ax (tname^"_induct")^";") end;
  44.124 +
  44.125 +(* ----- parser for domain declaration equation ----------------------------------- *)
  44.126 +
  44.127 +(**
  44.128 +  val sort = name >> (fn s => [strip_quotes s])
  44.129 +	  || "{" $$-- !! (list (name >> strip_quotes) --$$ "}");
  44.130 +  val tvar = (type_var -- (optional ("::" $$-- !! sort) ["pcpo"])) >> TFree
  44.131 +**)
  44.132 +  val tvar = type_var >> (fn tv => TFree(strip_quotes tv,["pcpo"]));
  44.133 +
  44.134 +  val type_args = "(" $$-- !! (list1 tvar --$$ ")")
  44.135 +	       || tvar  >> (fn x => [x])
  44.136 +	       || empty >> K [];
  44.137 +  val con_typ     = type_args -- ident >> (fn (x,y) => Type(y,x));
  44.138 +  val typ         = con_typ 
  44.139 +		 || tvar;
  44.140 +  val domain_arg  = "(" $$-- (optional ($$ "lazy" >> K true) false)
  44.141 +			  -- (optional ((ident >> Some) --$$ "::") None)
  44.142 +			  -- typ --$$ ")" >> (fn ((lazy,sel),tp) => (lazy,sel,tp))
  44.143 +		 || ident >> (fn x => (false,None,Type(x,[])))
  44.144 +		 || tvar  >> (fn x => (false,None,x));
  44.145 +  val domain_cons = (name >> strip_quotes) -- !! (repeat domain_arg) 
  44.146 +		    -- ThyOps.opt_cmixfix
  44.147 +		    >> (fn ((con,args),syn) => (con,syn,args));
  44.148 +in
  44.149 +  val domain_decl = (enum1 "," (con_typ --$$ "="  -- !! 
  44.150 +			       (enum1 "|" domain_cons))) 	    >> mk_domain;
  44.151 +  val gen_by_decl = (optional ($$ "finite" >> K true) false) -- 
  44.152 +		    (enum1 "," (ident   --$$ "by" -- !!
  44.153 +			       (enum1 "|" (name >> strip_quotes)))) >> mk_gen_by;
  44.154 +end;
  44.155 +
  44.156 +val user_keywords = "lazy"::"by"::"finite"::
  44.157 +		(**)filter_out (fn s=>s="lazy" orelse s="by" orelse s="finite")(**)
  44.158 +		    ThySynData.user_keywords;
  44.159 +val user_sections = ("domain", domain_decl)::("generated", gen_by_decl)::
  44.160 +		(**)filter_out (fn (s,_)=>s="domain" orelse s="generated")(**)
  44.161 +		    ThySynData.user_sections;
  44.162 +end;
  44.163 +
  44.164 +in
  44.165 +
  44.166 +structure ThySyn = ThySynFun(ThySynData); (* overwrites old version of ThySyn!!!!!! *)
  44.167 +
  44.168 +end; (* local *)
  44.169 \ No newline at end of file
    45.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    45.2 +++ b/src/HOLCF/domain/library.ML	Fri Oct 06 17:25:24 1995 +0100
    45.3 @@ -0,0 +1,202 @@
    45.4 +(* library.ML
    45.5 +   ID:         $Id$
    45.6 +   Author:      David von Oheimb
    45.7 +   Created: 18-Jul-95 extracted from syntax.ML, axioms.ML, extender.ML, interface.ML
    45.8 +   Updated: 30-Aug-95
    45.9 +   Copyright 1995 TU Muenchen
   45.10 +*)
   45.11 +
   45.12 +(* ----- general support ---------------------------------------------------------- *)
   45.13 +
   45.14 +fun Id x = x;
   45.15 +
   45.16 +fun mapn f n []      = []
   45.17 +|   mapn f n (x::xs) = (f n x) :: mapn f (n+1) xs;
   45.18 +
   45.19 +fun foldr'' f (l,f2) =
   45.20 +  let fun itr []  = raise LIST "foldr''"
   45.21 +        | itr [a] = f2 a
   45.22 +        | itr (a::l) = f(a, itr l)
   45.23 +  in  itr l  end;
   45.24 +fun foldr' f l = foldr'' f (l,Id);
   45.25 +fun map_cumulr f start xs = foldr (fn (x,(ys,res)) => case f(x,res) of (y,res2) => 
   45.26 +						      (y::ys,res2)) (xs,([],start));
   45.27 +
   45.28 +
   45.29 +fun first  (x,_,_) = x; fun second (_,x,_) = x; fun third  (_,_,x) = x;
   45.30 +fun upd_first  f (x,y,z) = (f x,   y,   z);
   45.31 +fun upd_second f (x,y,z) = (  x, f y,   z);
   45.32 +fun upd_third  f (x,y,z) = (  x,   y, f z);
   45.33 +
   45.34 +(* fn : ('a -> 'a) -> ('a -> 'a) -> 'a -> 'b list -> int -> 'a *)
   45.35 +fun bin_branchr f1 f2 y is j = let
   45.36 +fun bb y 1 _ = y
   45.37 +|   bb y _ 0 = f1 y
   45.38 +|   bb y i j = if i=2 then (f2 y) else bb (f2 y) (i-1) (j-1)
   45.39 +in bb y (length is) j end;
   45.40 +
   45.41 +fun atomize thm = case concl_of thm of
   45.42 +      _ $ (Const("op &",_) $ _ $ _)       => atomize (thm RS conjunct1) @
   45.43 +				             atomize (thm RS conjunct2)
   45.44 +    | _ $ (Const("All" ,_) $ Abs (s,_,_)) => atomize (thm RS 
   45.45 +					     (read_instantiate [("x","?"^s)] spec))
   45.46 +    | _				      => [thm];
   45.47 +
   45.48 +(* ----- specific support for domain ---------------------------------------------- *)
   45.49 +
   45.50 +structure Domain_Library = struct
   45.51 +
   45.52 +exception Impossible of string;
   45.53 +fun Imposs msg = raise Impossible ("Domain:"^msg);
   45.54 +
   45.55 +(* ----- name handling ----- *)
   45.56 +
   45.57 +val strip_esc = let
   45.58 +  fun strip ("'" :: c :: cs) = c :: strip cs
   45.59 +  |   strip ["'"] = []
   45.60 +  |   strip (c :: cs) = c :: strip cs
   45.61 +  |   strip [] = [];
   45.62 +in implode o strip o explode end;
   45.63 +
   45.64 +fun extern_name con = case explode con of 
   45.65 +		   ("o"::"p"::" "::rest) => implode rest
   45.66 +		   | _ => con;
   45.67 +fun dis_name  con = "is_"^ (extern_name con);
   45.68 +fun dis_name_ con = "is_"^ (strip_esc   con);
   45.69 +
   45.70 +(*make distinct names out of the type list, 
   45.71 +  forbidding "o", "x..","f..","P.." as names *)
   45.72 +(*a number string is added if necessary *)
   45.73 +fun mk_var_names types : string list = let
   45.74 +    fun typid (Type  (id,_)   ) = hd     (explode id)
   45.75 +      | typid (TFree (id,_)   ) = hd (tl (explode id))
   45.76 +      | typid (TVar ((id,_),_)) = hd (tl (explode id));
   45.77 +    fun nonreserved id = let val cs = explode id in
   45.78 +			 if not(hd cs mem ["x","f","P"]) then id
   45.79 +			 else implode(chr(1+ord (hd cs))::tl cs) end;
   45.80 +    fun index_vnames(vn::vns,tab) =
   45.81 +          (case assoc(tab,vn) of
   45.82 +             None => if vn mem vns
   45.83 +                     then (vn^"1") :: index_vnames(vns,(vn,2)::tab)
   45.84 +                     else  vn      :: index_vnames(vns,        tab)
   45.85 +           | Some(i) => (vn^(string_of_int i)) :: index_vnames(vns,(vn,i+1)::tab))
   45.86 +      | index_vnames([],tab) = [];
   45.87 +in index_vnames(map (nonreserved o typid) types,[("o",1)]) end;
   45.88 +
   45.89 +fun type_name_vars (Type(name,typevars)) = (name,typevars)
   45.90 +|   type_name_vars _                     = Imposs "library:type_name_vars";
   45.91 +
   45.92 +(* ----- support for type and mixfix expressions ----- *)
   45.93 +
   45.94 +fun mk_tvar s = TFree("'"^s,["pcpo"]);
   45.95 +fun mk_typ t (S,T) = Type(t,[S,T]);
   45.96 +infixr 5 -->;
   45.97 +infixr 6 ~>; val op ~> = mk_typ "->";
   45.98 +val NoSyn' = ThyOps.Mixfix NoSyn;
   45.99 +
  45.100 +(* ----- constructor list handling ----- *)
  45.101 +
  45.102 +type cons = (string *			(* operator name of constr *)
  45.103 +	    ((bool*int)*		(*  (lazy,recursive element or ~1) *)
  45.104 +	      string*			(*   selector name    *)
  45.105 +	      string)			(*   argument name    *)
  45.106 +	    list);			(* argument list      *)
  45.107 +type eq = (string *		(* name      of abstracted type *)
  45.108 +	   typ list) *		(* arguments of abstracted type *)
  45.109 +	  cons list;		(* represented type, as a constructor list *)
  45.110 +
  45.111 +val rec_of    = snd o first;
  45.112 +val is_lazy   = fst o first;
  45.113 +val sel_of    =       second;
  45.114 +val     vname =       third;
  45.115 +val upd_vname =   upd_third;
  45.116 +fun is_rec         arg = rec_of arg >=0;
  45.117 +fun is_nonlazy_rec arg = is_rec arg andalso not (is_lazy arg);
  45.118 +fun nonlazy args       = map vname (filter_out is_lazy args);
  45.119 +fun is_one_con_one_arg p cons = length cons = 1 andalso let val args = snd(hd cons) in
  45.120 +				length args = 1 andalso p (hd args) end;
  45.121 +
  45.122 +(* ----- support for term expressions ----- *)
  45.123 +
  45.124 +fun % s = Free(s,dummyT);
  45.125 +fun %# arg = %(vname arg);
  45.126 +fun %% s = Const(s,dummyT);
  45.127 +
  45.128 +local open HOLogic in
  45.129 +val mk_trp = mk_Trueprop;
  45.130 +fun mk_conj (S,T) = conj $ S $ T;
  45.131 +fun mk_disj (S,T) = disj $ S $ T;
  45.132 +fun mk_imp  (S,T) = imp  $ S $ T;
  45.133 +fun mk_lam  (x,T) = Abs(x,dummyT,T);
  45.134 +fun mk_all  (x,P) = HOLogic.mk_all (x,dummyT,P);
  45.135 +local 
  45.136 +		    fun tf (Type (s,args)) = foldl (op $) (%s,map tf args)
  45.137 +		    |   tf (TFree(s,_   )) = %s
  45.138 +		    |   tf _              = Imposs "mk_constrainall";
  45.139 +in
  45.140 +fun mk_constrain      (typ,T) = %%"_constrain" $ T $ tf typ;
  45.141 +fun mk_constrainall (x,typ,P) = %%"All" $ (%%"_constrainAbs"$Abs(x,dummyT,P)$tf typ);
  45.142 +end;
  45.143 +			
  45.144 +fun mk_ex   (x,P) = mk_exists (x,dummyT,P);
  45.145 +fun mk_not     P  = Const("not" ,boolT --> boolT) $ P;
  45.146 +end;
  45.147 +
  45.148 +fun mk_All  (x,P) = %%"all" $ mk_lam(x,P); (* meta universal quantification *)
  45.149 +
  45.150 +infixr 0 ===>;fun S ===> T = Const("==>", dummyT) $ S $ T;
  45.151 +infixr 0 ==>;fun S ==> T = mk_trp S ===> mk_trp T;
  45.152 +infix 0 ==;  fun S ==  T = Const("==", dummyT) $ S $ T;
  45.153 +infix 1 ===; fun S === T = Const("op =", dummyT) $ S $ T;
  45.154 +infix 1 ~=;  fun S ~=  T = mk_not (S === T);
  45.155 +infix 1 <<;  fun S <<  T = Const("op <<", dummyT) $ S $ T;
  45.156 +infix 1 ~<<; fun S ~<< T = mk_not (S << T);
  45.157 +
  45.158 +infix 9 `  ; fun f`  x = %%"fapp" $ f $ x;
  45.159 +infix 9 `% ; fun f`% s = f` % s;
  45.160 +infix 9 `%%; fun f`%%s = f` %%s;
  45.161 +fun mk_cfapp (F,As) = foldl (op `) (F,As);
  45.162 +fun con_app2 con f args = mk_cfapp(%%con,map f args);
  45.163 +fun con_app con = con_app2 con %#;
  45.164 +fun if_rec  arg f y   = if is_rec arg then f (rec_of arg) else y;
  45.165 +fun app_rec_arg p arg = if_rec arg (fn n => fn x => (p n)`x) Id (%# arg);
  45.166 +val cproj    = bin_branchr (fn S => %%"cfst"`S) (fn S => %%"csnd"`S);
  45.167 +val  proj    = bin_branchr (fn S => %%"fst" $S) (fn S => %%"snd" $S);
  45.168 +fun lift tfn = foldr (fn (x,t)=> (mk_trp(tfn x) ===> t));
  45.169 +
  45.170 +fun /\ v T = %%"fabs" $ mk_lam(v,T);
  45.171 +fun /\# (arg,T) = /\ (vname arg) T;
  45.172 +infixr 9 oo; fun S oo T = %%"cfcomp"`S`T;
  45.173 +val UU = %%"UU";
  45.174 +fun strict f = f`UU === UU;
  45.175 +fun defined t = t ~= UU;
  45.176 +fun cpair (S,T) = %%"cpair"`S`T;
  45.177 +fun lift_defined f = lift (fn x => defined (f x));
  45.178 +fun bound_arg vns v = Bound(length vns-find(v,vns)-1);
  45.179 +
  45.180 +fun cont_eta_contract (Const("fabs",TT) $ Abs(a,T,body)) = 
  45.181 +      (case cont_eta_contract body  of
  45.182 +        body' as (Const("fapp",Ta) $ f $ Bound 0) => 
  45.183 +	  if not (0 mem loose_bnos f) then incr_boundvars ~1 f 
  45.184 +	  else   Const("fabs",TT) $ Abs(a,T,body')
  45.185 +      | body' => Const("fabs",TT) $ Abs(a,T,body'))
  45.186 +|   cont_eta_contract(f$t) = cont_eta_contract f $ cont_eta_contract t
  45.187 +|   cont_eta_contract t    = t;
  45.188 +
  45.189 +fun idx_name dnames s n = s ^ (if length dnames = 1 then "" else string_of_int n);
  45.190 +fun when_funs cons = if length cons = 1 then ["f"] 
  45.191 +		     else mapn (fn n => K("f"^(string_of_int n))) 1 cons;
  45.192 +fun when_body cons funarg = let
  45.193 +	fun one_fun n (_,[]  ) = /\ "dummy" (funarg(1,n))
  45.194 +	|   one_fun n (_,args) = let
  45.195 +		val l2 = length args;
  45.196 +		fun idxs m arg = (if is_lazy arg then fn x=> %%"lift"`%%"ID"`x
  45.197 +					         else Id) (Bound(l2-m));
  45.198 +		in cont_eta_contract (foldr'' 
  45.199 +			 (fn (a,t) => %%"ssplit"`(/\# (a,t)))
  45.200 +			 (args,
  45.201 +			  fn a => /\# (a,(mk_cfapp(funarg (l2,n),mapn idxs 1 args))))
  45.202 +			 ) end;
  45.203 +in foldr' (fn (x,y)=> %%"sswhen"`x`y) (mapn one_fun 1 cons) end;
  45.204 +
  45.205 +end; (* struct *)
    46.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    46.2 +++ b/src/HOLCF/domain/syntax.ML	Fri Oct 06 17:25:24 1995 +0100
    46.3 @@ -0,0 +1,128 @@
    46.4 +(* syntax.ML
    46.5 +   ID:         $Id$
    46.6 +   Author:  David von Oheimb
    46.7 +   Created: 31-May-95
    46.8 +   Updated: 16-Aug-95 case translation
    46.9 +   Updated: 28-Aug-95 corrections for case translation, simultaneous domain equations
   46.10 +   Copyright 1995 TU Muenchen
   46.11 +*)
   46.12 +
   46.13 +
   46.14 +structure Domain_Syntax = struct 
   46.15 +
   46.16 +local 
   46.17 +
   46.18 +open Domain_Library;
   46.19 +infixr 5 -->; infixr 6 ~>;
   46.20 +fun calc_syntax dtypeprod ((dname,typevars),
   46.21 +		(cons':(string*ThyOps.cmixfix*(bool*string*typ) list) list))=
   46.22 +let
   46.23 +(* ----- constants concerning the isomorphism ------------------------------------- *)
   46.24 +
   46.25 +local
   46.26 +  fun opt_lazy (lazy,_,t) = if lazy then Type("u",[t]) else t
   46.27 +  fun prod (_,_,args) = if args = [] then Type("one",[])
   46.28 +				     else foldr' (mk_typ "**") (map opt_lazy args);
   46.29 +
   46.30 +in
   46.31 +  val dtype  = Type(dname,typevars);
   46.32 +  val dtype2 = foldr' (mk_typ "++") (map prod cons');
   46.33 +  val const_rep  = (dname^"_rep" ,              dtype  ~> dtype2, NoSyn');
   46.34 +  val const_abs  = (dname^"_abs" ,              dtype2 ~> dtype , NoSyn');
   46.35 +  val const_copy = (dname^"_copy", dtypeprod ~> dtype  ~> dtype , NoSyn');
   46.36 +end;
   46.37 +
   46.38 +(* ----- constants concerning the constructors, discriminators and selectors ------ *)
   46.39 +
   46.40 +fun is_infix (ThyOps.CInfixl       _ ) = true
   46.41 +|   is_infix (ThyOps.CInfixr       _ ) = true
   46.42 +|   is_infix (ThyOps.Mixfix(Infixl _)) = true
   46.43 +|   is_infix (ThyOps.Mixfix(Infixr _)) = true
   46.44 +|   is_infix  _                        = false;
   46.45 +
   46.46 +local
   46.47 +  val escape = let
   46.48 +	fun esc (c :: cs) = if c mem ["'","_","(",")","/"] then "'" :: c :: esc cs
   46.49 +							   else        c :: esc cs
   46.50 +	|   esc []        = []
   46.51 +	in implode o esc o explode end;
   46.52 +  fun freetvar s = if (mk_tvar s) mem typevars then freetvar ("t"^s) else mk_tvar s;
   46.53 +  fun when_type (_   ,_,args) = foldr (op ~>)       (map third args,freetvar "t");
   46.54 +  fun con       (name,s,args) = (name,foldr (op ~>) (map third args,dtype),s);
   46.55 +  fun dis       (con ,s,_   ) = (dis_name_ con, dtype~>Type("tr",[]),
   46.56 +			 	 ThyOps.Mixfix(Mixfix("is'_"^
   46.57 +				 (if is_infix s then Id else escape)con,[],max_pri)));
   46.58 +  fun sel       (_   ,_,args) = map (fn(_,sel,typ)=>(sel,dtype ~> typ,NoSyn'))args;
   46.59 +in
   46.60 +  val const_when = (dname^"_when", foldr (op ~>) ((map when_type cons'),
   46.61 +						 dtype ~> freetvar "t"), NoSyn');
   46.62 +  val consts_con = map con cons';
   46.63 +  val consts_dis = map dis cons';
   46.64 +  val consts_sel = flat(map sel cons');
   46.65 +end;
   46.66 +
   46.67 +(* ----- constants concerning induction ------------------------------------------- *)
   46.68 +
   46.69 +  val const_take   = (dname^"_take"  ,Type("nat",[]) --> dtype ~> dtype    ,NoSyn');
   46.70 +  val const_finite = (dname^"_finite",dtype-->HOLogic.boolT		   ,NoSyn');
   46.71 +
   46.72 +(* ----- case translation --------------------------------------------------------- *)
   46.73 +
   46.74 +local open Syntax in
   46.75 +  val case_trans = let 
   46.76 +	fun c_ast con syn = Constant (ThyOps.const_name con syn);
   46.77 +	fun expvar n      = Variable ("e"^(string_of_int n));
   46.78 +	fun argvar n m _  = Variable ("a"^(string_of_int n)^"_"^(string_of_int m));
   46.79 +	fun app s (l,r)   = mk_appl (Constant s) [l,r];
   46.80 +	fun case1 n (con,syn,args) = mk_appl (Constant "@case1")
   46.81 +		 [if is_infix syn
   46.82 +		  then mk_appl (c_ast con syn) (mapn (argvar n) 1 args)
   46.83 +		  else foldl (app "@fapp") (c_ast con syn, (mapn (argvar n) 1 args)),
   46.84 +		  expvar n];
   46.85 +	fun arg1 n (con,_,args) = if args = [] then expvar n
   46.86 +				  else mk_appl (Constant "LAM ") 
   46.87 +		 [foldr' (app "_idts") (mapn (argvar n) 1 args) , expvar n];
   46.88 +  in mk_appl (Constant "@case") [Variable "x", foldr'
   46.89 +				 (fn (c,cs) => mk_appl (Constant "@case2") [c,cs])
   46.90 +				 (mapn case1 1 cons')] <->
   46.91 +     mk_appl (Constant "@fapp") [foldl 
   46.92 +				 (fn (w,a ) => mk_appl (Constant "@fapp" ) [w,a ])
   46.93 +				 (Constant (dname^"_when"),mapn arg1 1 cons'),
   46.94 +				 Variable "x"]
   46.95 +  end;
   46.96 +end;
   46.97 +
   46.98 +in ([const_rep, const_abs, const_when, const_copy] @ 
   46.99 +     consts_con @ consts_dis @ consts_sel @
  46.100 +    [const_take, const_finite],
  46.101 +    [case_trans])
  46.102 +end; (* let *)
  46.103 +
  46.104 +(* ----- putting all the syntax stuff together ------------------------------------ *)
  46.105 +
  46.106 +in (* local *)
  46.107 +
  46.108 +fun add_syntax (comp_dname,eqs': ((string * typ list) *
  46.109 +		(string * ThyOps.cmixfix * (bool*string*typ) list) list) list) thy'' =
  46.110 +let
  46.111 +  fun thy_type  (dname,typevars)  = (dname, length typevars, NoSyn);
  46.112 +  fun thy_arity (dname,typevars)  = (dname, map (K ["pcpo"]) typevars, ["pcpo"]); 
  46.113 +  (**                 (fn TFree(_,sort) => sort | _ => Imposs "syntax:thy_arities")**)
  46.114 +  val thy_types   = map (thy_type  o fst) eqs';
  46.115 +  val thy_arities = map (thy_arity o fst) eqs';
  46.116 +  val dtypes      = map (Type      o fst) eqs';
  46.117 +  val funprod = foldr' (mk_typ "*") (map (fn tp => tp ~> tp                  )dtypes);
  46.118 +  val relprod = foldr' (mk_typ "*") (map (fn tp => tp--> tp --> HOLogic.boolT)dtypes);
  46.119 +  val const_copy   = (comp_dname^"_copy"  ,funprod ~> funprod       , NoSyn');
  46.120 +  val const_bisim  = (comp_dname^"_bisim" ,relprod --> HOLogic.boolT, NoSyn');
  46.121 +  val ctt           = map (calc_syntax funprod) eqs';
  46.122 +  val add_cur_ops_i = ThyOps.add_ops_i {curried=true, strict=false, total=false};
  46.123 +in thy'' |> add_types      thy_types
  46.124 +	 |> add_arities    thy_arities
  46.125 +	 |> add_cur_ops_i (flat(map fst ctt))
  46.126 +	 |> add_cur_ops_i ((if length eqs'>1 then [const_copy] else[])@[const_bisim])
  46.127 +	 |> add_trrules_i (flat(map snd ctt))
  46.128 +end; (* let *)
  46.129 +
  46.130 +end; (* local *)
  46.131 +end; (* struct *)
    47.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    47.2 +++ b/src/HOLCF/domain/theorems.ML	Fri Oct 06 17:25:24 1995 +0100
    47.3 @@ -0,0 +1,596 @@
    47.4 +(* theorems.ML
    47.5 +   ID:         $Id$
    47.6 +   Author : David von Oheimb
    47.7 +   Created: 06-Jun-95
    47.8 +   Updated: 08-Jun-95 first proof from cterms
    47.9 +   Updated: 26-Jun-95 proofs for exhaustion thms
   47.10 +   Updated: 27-Jun-95 proofs for discriminators, constructors and selectors
   47.11 +   Updated: 06-Jul-95 proofs for distinctness, invertibility and injectivity
   47.12 +   Updated: 17-Jul-95 proofs for induction rules
   47.13 +   Updated: 19-Jul-95 proof for co-induction rule
   47.14 +   Updated: 28-Aug-95 definedness theorems for selectors (completion)
   47.15 +   Updated: 05-Sep-95 simultaneous domain equations (main part)
   47.16 +   Updated: 11-Sep-95 simultaneous domain equations (coding finished)
   47.17 +   Updated: 13-Sep-95 simultaneous domain equations (debugging)
   47.18 +   Copyright 1995 TU Muenchen
   47.19 +*)
   47.20 +
   47.21 +
   47.22 +structure Domain_Theorems = struct
   47.23 +
   47.24 +local
   47.25 +
   47.26 +open Domain_Library;
   47.27 +infixr 0 ===>;infixr 0 ==>;infix 0 == ; 
   47.28 +infix 1 ===; infix 1 ~= ; infix 1 <<; infix 1 ~<<;
   47.29 +infix 9 `   ; infix 9 `% ; infix 9 `%%; infixr 9 oo;
   47.30 +
   47.31 +(* ----- general proof facilities ------------------------------------------------- *)
   47.32 +
   47.33 +fun inferT sg pre_tm = #2(Sign.infer_types sg (K None)(K None)[]true([pre_tm],propT));
   47.34 +
   47.35 +(*
   47.36 +infix 0 y;
   47.37 +val b=0;
   47.38 +fun _ y t = by t;
   47.39 +fun  g  defs t = let val sg = sign_of thy;
   47.40 +		     val ct = Thm.cterm_of sg (inferT sg t);
   47.41 +		 in goalw_cterm defs ct end;
   47.42 +*)
   47.43 +
   47.44 +fun pg'' thy defs t = let val sg = sign_of thy;
   47.45 +		          val ct = Thm.cterm_of sg (inferT sg t);
   47.46 +		      in prove_goalw_cterm defs ct end;
   47.47 +fun pg'  thy defs t tacsf=pg'' thy defs t (fn []   => tacsf 
   47.48 +					    | prems=> (cut_facts_tac prems 1)::tacsf);
   47.49 +
   47.50 +fun REPEAT_DETERM_UNTIL p tac = 
   47.51 +let fun drep st = if p st then Sequence.single st
   47.52 +			  else (case Sequence.pull(tapply(tac,st)) of
   47.53 +		                  None        => Sequence.null
   47.54 +				| Some(st',_) => drep st')
   47.55 +in Tactic drep end;
   47.56 +val UNTIL_SOLVED = REPEAT_DETERM_UNTIL (has_fewer_prems 1);
   47.57 +
   47.58 +local val trueI2 = prove_goal HOL.thy "f~=x ==> True" (fn prems => [rtac TrueI 1]) in
   47.59 +val kill_neq_tac = dtac trueI2 end;
   47.60 +fun case_UU_tac rews i v =	res_inst_tac [("Q",v^"=UU")] classical2 i THEN
   47.61 +				asm_simp_tac (HOLCF_ss addsimps rews) i;
   47.62 +
   47.63 +val chain_tac = REPEAT_DETERM o resolve_tac 
   47.64 +		[is_chain_iterate, ch2ch_fappR, ch2ch_fappL];
   47.65 +
   47.66 +(* ----- general proofs ----------------------------------------------------------- *)
   47.67 +
   47.68 +val swap3 = prove_goal HOL.thy "[| Q ==> P; ~P |] ==> ~Q" (fn prems => [
   47.69 +                                cut_facts_tac prems 1,
   47.70 +                                etac swap 1,
   47.71 +                                dtac notnotD 1,
   47.72 +				etac (hd prems) 1]);
   47.73 +
   47.74 +val dist_eqI = prove_goal Porder0.thy "~ x << y ==> x ~= y" (fn prems => [
   47.75 +				cut_facts_tac prems 1,
   47.76 +				etac swap 1,
   47.77 +				dtac notnotD 1,
   47.78 +				asm_simp_tac HOLCF_ss 1]);
   47.79 +val cfst_strict  = prove_goal Cprod3.thy "cfst`UU = UU" (fn _ => [
   47.80 +				(simp_tac (HOLCF_ss addsimps [inst_cprod_pcpo2]) 1)]);
   47.81 +val csnd_strict  = prove_goal Cprod3.thy "csnd`UU = UU" (fn _ => [
   47.82 +			(simp_tac (HOLCF_ss addsimps [inst_cprod_pcpo2]) 1)]);
   47.83 +
   47.84 +in
   47.85 +
   47.86 +
   47.87 +fun theorems thy (((dname,_),cons) : eq, eqs :eq list) =
   47.88 +let
   47.89 +
   47.90 +val dummy = writeln ("Proving isomorphism properties of domain "^dname^"...");
   47.91 +val pg = pg' thy;
   47.92 +
   47.93 +(* ----- getting the axioms and definitions --------------------------------------- *)
   47.94 +
   47.95 +local val ga = get_axiom thy in
   47.96 +val ax_abs_iso    = ga (dname^"_abs_iso"   );
   47.97 +val ax_rep_iso    = ga (dname^"_rep_iso"   );
   47.98 +val ax_when_def   = ga (dname^"_when_def"  );
   47.99 +val axs_con_def   = map (fn (con,_) => ga (extern_name con ^"_def")) cons;
  47.100 +val axs_dis_def   = map (fn (con,_) => ga (   dis_name con ^"_def")) cons;
  47.101 +val axs_sel_def   = flat(map (fn (_,args) => 
  47.102 +		    map (fn     arg => ga (sel_of arg      ^"_def")) args) cons);
  47.103 +val ax_copy_def   = ga (dname^"_copy_def"  );
  47.104 +end; (* local *)
  47.105 +
  47.106 +(* ----- theorems concerning the isomorphism -------------------------------------- *)
  47.107 +
  47.108 +val dc_abs  = %%(dname^"_abs");
  47.109 +val dc_rep  = %%(dname^"_rep");
  47.110 +val dc_copy = %%(dname^"_copy");
  47.111 +val x_name = "x";
  47.112 +
  47.113 +val (rep_strict, abs_strict) = let 
  47.114 +	       val r = ax_rep_iso RS (ax_abs_iso RS (allI  RSN(2,allI RS iso_strict)))
  47.115 +	       in (r RS conjunct1, r RS conjunct2) end;
  47.116 +val abs_defin' = pg [] ((dc_abs`%x_name === UU) ==> (%x_name === UU)) [
  47.117 +				res_inst_tac [("t",x_name)] (ax_abs_iso RS subst) 1,
  47.118 +				etac ssubst 1,
  47.119 +				rtac rep_strict 1];
  47.120 +val rep_defin' = pg [] ((dc_rep`%x_name === UU) ==> (%x_name === UU)) [
  47.121 +				res_inst_tac [("t",x_name)] (ax_rep_iso RS subst) 1,
  47.122 +				etac ssubst 1,
  47.123 +				rtac abs_strict 1];
  47.124 +val iso_rews = [ax_abs_iso,ax_rep_iso,abs_strict,rep_strict];
  47.125 +
  47.126 +local 
  47.127 +val iso_swap = pg [] (dc_rep`%"x" === %"y" ==> %"x" === dc_abs`%"y") [
  47.128 +				dres_inst_tac [("f",dname^"_abs")] cfun_arg_cong 1,
  47.129 +				etac (ax_rep_iso RS subst) 1];
  47.130 +fun exh foldr1 cn quant foldr2 var = let
  47.131 +  fun one_con (con,args) = let val vns = map vname args in
  47.132 +    foldr quant (vns, foldr2 ((%x_name === con_app2 con (var vns) vns)::
  47.133 +			      map (defined o (var vns)) (nonlazy args))) end
  47.134 +  in foldr1 ((cn(%x_name===UU))::map one_con cons) end;
  47.135 +in
  47.136 +val cases = let 
  47.137 +	    fun common_tac thm = rtac thm 1 THEN contr_tac 1;
  47.138 +	    fun unit_tac true = common_tac liftE1
  47.139 +	    |   unit_tac _    = all_tac;
  47.140 +	    fun prod_tac []          = common_tac oneE
  47.141 +	    |   prod_tac [arg]       = unit_tac (is_lazy arg)
  47.142 +	    |   prod_tac (arg::args) = 
  47.143 +				common_tac sprodE THEN
  47.144 +				kill_neq_tac 1 THEN
  47.145 +				unit_tac (is_lazy arg) THEN
  47.146 +				prod_tac args;
  47.147 +	    fun sum_one_tac p = SELECT_GOAL(EVERY[
  47.148 +				rtac p 1,
  47.149 +				rewrite_goals_tac axs_con_def,
  47.150 +				dtac iso_swap 1,
  47.151 +				simp_tac HOLCF_ss 1,
  47.152 +				UNTIL_SOLVED(fast_tac HOL_cs 1)]) 1;
  47.153 +	    fun sum_tac [(_,args)]       [p]        = 
  47.154 +				prod_tac args THEN sum_one_tac p
  47.155 +	    |   sum_tac ((_,args)::cons') (p::prems) = DETERM(
  47.156 +				common_tac ssumE THEN
  47.157 +				kill_neq_tac 1 THEN kill_neq_tac 2 THEN
  47.158 +				prod_tac args THEN sum_one_tac p) THEN
  47.159 +				sum_tac cons' prems
  47.160 +	    |   sum_tac _ _ = Imposs "theorems:sum_tac";
  47.161 +	  in pg'' thy [] (exh (fn l => foldr (op ===>) (l,mk_trp(%"P")))
  47.162 +			      (fn T => T ==> %"P") mk_All
  47.163 +			      (fn l => foldr (op ===>) (map mk_trp l,mk_trp(%"P")))
  47.164 +			      bound_arg)
  47.165 +			     (fn prems => [
  47.166 +				cut_facts_tac [excluded_middle] 1,
  47.167 +				etac disjE 1,
  47.168 +				rtac (hd prems) 2,
  47.169 +				etac rep_defin' 2,
  47.170 +				if is_one_con_one_arg (not o is_lazy) cons
  47.171 +				then rtac (hd (tl prems)) 1 THEN atac 2 THEN
  47.172 +				     rewrite_goals_tac axs_con_def THEN
  47.173 +				     simp_tac (HOLCF_ss addsimps [ax_rep_iso]) 1
  47.174 +				else sum_tac cons (tl prems)])end;
  47.175 +val exhaust = pg [] (mk_trp(exh (foldr' mk_disj) Id mk_ex (foldr' mk_conj) (K %))) [
  47.176 +				rtac cases 1,
  47.177 +				UNTIL_SOLVED(fast_tac HOL_cs 1)];
  47.178 +end;
  47.179 +
  47.180 +local 
  47.181 +val when_app = foldl (op `) (%%(dname^"_when"), map % (when_funs cons));
  47.182 +val when_appl = pg [ax_when_def] (mk_trp(when_app`%x_name===when_body cons 
  47.183 +		(fn (_,n) => %(nth_elem(n-1,when_funs cons)))`(dc_rep`%x_name))) [
  47.184 +				simp_tac HOLCF_ss 1];
  47.185 +in
  47.186 +val when_strict = pg [] ((if is_one_con_one_arg (K true) cons 
  47.187 +	then fn t => mk_trp(strict(%"f")) ===> t else Id)(mk_trp(strict when_app))) [
  47.188 +				simp_tac(HOLCF_ss addsimps [when_appl,rep_strict]) 1];
  47.189 +val when_apps = let fun one_when n (con,args) = pg axs_con_def
  47.190 +		(lift_defined % (nonlazy args, mk_trp(when_app`(con_app con args) ===
  47.191 +		 mk_cfapp(%(nth_elem(n,when_funs cons)),map %# args))))[
  47.192 +			asm_simp_tac (HOLCF_ss addsimps [when_appl,ax_abs_iso]) 1];
  47.193 +		in mapn one_when 0 cons end;
  47.194 +end;
  47.195 +val when_rews = when_strict::when_apps;
  47.196 +
  47.197 +(* ----- theorems concerning the constructors, discriminators and selectors ------- *)
  47.198 +
  47.199 +val dis_stricts = map (fn (con,_) => pg axs_dis_def (mk_trp(
  47.200 +			(if is_one_con_one_arg (K true) cons then mk_not else Id)
  47.201 +		         (strict(%%(dis_name con))))) [
  47.202 +		simp_tac (HOLCF_ss addsimps (if is_one_con_one_arg (K true) cons 
  47.203 +					then [ax_when_def] else when_rews)) 1]) cons;
  47.204 +val dis_apps = let fun one_dis c (con,args)= pg (axs_dis_def)
  47.205 +		   (lift_defined % (nonlazy args, (*(if is_one_con_one_arg is_lazy cons
  47.206 +			then curry (lift_defined %#) args else Id)
  47.207 +#################*)
  47.208 +			(mk_trp((%%(dis_name c))`(con_app con args) ===
  47.209 +			      %%(if con=c then "TT" else "FF"))))) [
  47.210 +				asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  47.211 +	in flat(map (fn (c,_) => map (one_dis c) cons) cons) end;
  47.212 +val dis_defins = map (fn (con,args) => pg [] (defined(%x_name)==> 
  47.213 +		      defined(%%(dis_name con)`%x_name)) [
  47.214 +				rtac cases 1,
  47.215 +				contr_tac 1,
  47.216 +				UNTIL_SOLVED (CHANGED(asm_simp_tac 
  47.217 +				              (HOLCF_ss addsimps dis_apps) 1))]) cons;
  47.218 +val dis_rews = dis_stricts @ dis_defins @ dis_apps;
  47.219 +
  47.220 +val con_stricts = flat(map (fn (con,args) => map (fn vn =>
  47.221 +			pg (axs_con_def) 
  47.222 +			   (mk_trp(con_app2 con (fn arg => if vname arg = vn 
  47.223 +					then UU else %# arg) args === UU))[
  47.224 +				asm_simp_tac (HOLCF_ss addsimps [abs_strict]) 1]
  47.225 +			) (nonlazy args)) cons);
  47.226 +val con_defins = map (fn (con,args) => pg []
  47.227 +			(lift_defined % (nonlazy args,
  47.228 +				mk_trp(defined(con_app con args)))) ([
  47.229 +				rtac swap3 1] @ (if is_one_con_one_arg (K true) cons 
  47.230 +				then [
  47.231 +				  if is_lazy (hd args) then rtac defined_up 2
  47.232 +						       else atac 2,
  47.233 +				  rtac abs_defin' 1,	
  47.234 +				  asm_full_simp_tac (HOLCF_ss addsimps axs_con_def) 1]
  47.235 +				else [
  47.236 +				  eres_inst_tac [("f",dis_name con)] cfun_arg_cong 1,
  47.237 +				  asm_simp_tac (HOLCF_ss addsimps dis_rews) 1])))cons;
  47.238 +val con_rews = con_stricts @ con_defins;
  47.239 +
  47.240 +val sel_stricts = let fun one_sel sel = pg axs_sel_def (mk_trp(strict(%%sel))) [
  47.241 +				simp_tac (HOLCF_ss addsimps when_rews) 1];
  47.242 +in flat(map (fn (_,args) => map (fn arg => one_sel (sel_of arg)) args) cons) end;
  47.243 +val sel_apps = let fun one_sel c n sel = map (fn (con,args) => 
  47.244 +		let val nlas = nonlazy args;
  47.245 +		    val vns  = map vname args;
  47.246 +		in pg axs_sel_def (lift_defined %
  47.247 +		   (filter (fn v => con=c andalso (v<>nth_elem(n,vns))) nlas,
  47.248 +   mk_trp((%%sel)`(con_app con args) === (if con=c then %(nth_elem(n,vns)) else UU))))
  47.249 +			    ( (if con=c then [] 
  47.250 +			       else map(case_UU_tac(when_rews@con_stricts)1) nlas)
  47.251 +			     @(if con=c andalso ((nth_elem(n,vns)) mem nlas)
  47.252 +					 then[case_UU_tac (when_rews @ con_stricts) 1 
  47.253 +							  (nth_elem(n,vns))] else [])
  47.254 +			     @ [asm_simp_tac(HOLCF_ss addsimps when_rews)1])end) cons;
  47.255 +in flat(map  (fn (c,args) => 
  47.256 +	flat(mapn (fn n => fn arg => one_sel c n (sel_of arg)) 0 args)) cons) end;
  47.257 +val sel_defins = if length cons = 1 then map (fn arg => pg [] (defined(%x_name) ==> 
  47.258 +			defined(%%(sel_of arg)`%x_name)) [
  47.259 +				rtac cases 1,
  47.260 +				contr_tac 1,
  47.261 +				UNTIL_SOLVED (CHANGED(asm_simp_tac 
  47.262 +				              (HOLCF_ss addsimps sel_apps) 1))]) 
  47.263 +		 (filter_out is_lazy (snd(hd cons))) else [];
  47.264 +val sel_rews = sel_stricts @ sel_defins @ sel_apps;
  47.265 +
  47.266 +val distincts_le = let
  47.267 +    fun dist (con1, args1) (con2, args2) = pg []
  47.268 +	      (lift_defined % ((nonlazy args1),
  47.269 +			     (mk_trp (con_app con1 args1 ~<< con_app con2 args2))))([
  47.270 +			rtac swap3 1,
  47.271 +			eres_inst_tac [("fo5",dis_name con1)] monofun_cfun_arg 1]
  47.272 +		      @ map (case_UU_tac (con_stricts @ dis_rews) 1) (nonlazy args2)
  47.273 +		      @[asm_simp_tac (HOLCF_ss addsimps dis_rews) 1]);
  47.274 +    fun distinct (con1,args1) (con2,args2) =
  47.275 +	let val arg1 = (con1, args1);
  47.276 +	    val arg2 = (con2, (map (fn (arg,vn) => upd_vname (K vn) arg)
  47.277 +			      (args2~~variantlist(map vname args2,map vname args1))));
  47.278 +	in [dist arg1 arg2, dist arg2 arg1] end;
  47.279 +    fun distincts []      = []
  47.280 +    |   distincts (c::cs) = (map (distinct c) cs) :: distincts cs;
  47.281 +in distincts cons end;
  47.282 +val dists_le = flat (flat distincts_le);
  47.283 +val dists_eq = let
  47.284 +    fun distinct (_,args1) ((_,args2),leqs) = let
  47.285 +	val (le1,le2) = (hd leqs, hd(tl leqs));
  47.286 +	val (eq1,eq2) = (le1 RS dist_eqI, le2 RS dist_eqI) in
  47.287 +	if nonlazy args1 = [] then [eq1, eq1 RS not_sym] else
  47.288 +	if nonlazy args2 = [] then [eq2, eq2 RS not_sym] else
  47.289 +					[eq1, eq2] end;
  47.290 +    fun distincts []      = []
  47.291 +    |   distincts ((c,leqs)::cs) = flat(map (distinct c) ((map fst cs)~~leqs)) @
  47.292 +				   distincts cs;
  47.293 +    in distincts (cons~~distincts_le) end;
  47.294 +
  47.295 +local 
  47.296 +  fun pgterm rel con args = let
  47.297 +		fun append s = upd_vname(fn v => v^s);
  47.298 +		val (largs,rargs) = (args, map (append "'") args);
  47.299 +		in pg [] (mk_trp (rel(con_app con largs,con_app con rargs)) ===>
  47.300 +		      lift_defined % ((nonlazy largs),lift_defined % ((nonlazy rargs),
  47.301 +			    mk_trp (foldr' mk_conj 
  47.302 +				(map rel (map %# largs ~~ map %# rargs)))))) end;
  47.303 +  val cons' = filter (fn (_,args) => args<>[]) cons;
  47.304 +in
  47.305 +val inverts = map (fn (con,args) => 
  47.306 +		pgterm (op <<) con args (flat(map (fn arg => [
  47.307 +				TRY(rtac conjI 1),
  47.308 +				dres_inst_tac [("fo5",sel_of arg)] monofun_cfun_arg 1,
  47.309 +				asm_full_simp_tac (HOLCF_ss addsimps sel_apps) 1]
  47.310 +			     			      ) args))) cons';
  47.311 +val injects = map (fn ((con,args),inv_thm) => 
  47.312 +			   pgterm (op ===) con args [
  47.313 +				etac (antisym_less_inverse RS conjE) 1,
  47.314 +				dtac inv_thm 1, REPEAT(atac 1),
  47.315 +				dtac inv_thm 1, REPEAT(atac 1),
  47.316 +				TRY(safe_tac HOL_cs),
  47.317 +				REPEAT(rtac antisym_less 1 ORELSE atac 1)] )
  47.318 +		  (cons'~~inverts);
  47.319 +end;
  47.320 +
  47.321 +(* ----- theorems concerning one induction step ----------------------------------- *)
  47.322 +
  47.323 +val copy_strict = pg [ax_copy_def] ((if is_one_con_one_arg (K true) cons then fn t =>
  47.324 +	 mk_trp(strict(cproj (%"f") eqs (rec_of (hd(snd(hd cons)))))) ===> t
  47.325 +	else Id) (mk_trp(strict(dc_copy`%"f")))) [
  47.326 +				asm_simp_tac(HOLCF_ss addsimps [abs_strict,rep_strict,
  47.327 +							cfst_strict,csnd_strict]) 1];
  47.328 +val copy_apps = map (fn (con,args) => pg (ax_copy_def::axs_con_def)
  47.329 +		    (lift_defined %# (filter is_nonlazy_rec args,
  47.330 +			mk_trp(dc_copy`%"f"`(con_app con args) ===
  47.331 +			   (con_app2 con (app_rec_arg (cproj (%"f") eqs)) args))))
  47.332 +				 (map (case_UU_tac [ax_abs_iso] 1 o vname)
  47.333 +				   (filter(fn a=>not(is_rec a orelse is_lazy a))args)@
  47.334 +				 [asm_simp_tac (HOLCF_ss addsimps [ax_abs_iso]) 1])
  47.335 +		)cons;
  47.336 +val copy_stricts = map(fn(con,args)=>pg[](mk_trp(dc_copy`UU`(con_app con args) ===UU))
  47.337 +	     (let val rews = cfst_strict::csnd_strict::copy_strict::copy_apps@con_rews
  47.338 +			 in map (case_UU_tac rews 1) (nonlazy args) @ [
  47.339 +			     asm_simp_tac (HOLCF_ss addsimps rews) 1] end))
  47.340 +		   (filter (fn (_,args)=>exists is_nonlazy_rec args) cons);
  47.341 +val copy_rews = copy_strict::copy_apps @ copy_stricts;
  47.342 +
  47.343 +in     (iso_rews, exhaust, cases, when_rews,
  47.344 +	con_rews, sel_rews, dis_rews, dists_eq, dists_le, inverts, injects,
  47.345 +	copy_rews)
  47.346 +end; (* let *)
  47.347 +
  47.348 +
  47.349 +fun comp_theorems thy (comp_dname, eqs: eq list, casess, con_rews, copy_rews) =
  47.350 +let
  47.351 +
  47.352 +val dummy = writeln ("Proving induction properties of domain "^comp_dname^"...");
  47.353 +val pg = pg' thy;
  47.354 +
  47.355 +val dnames = map (fst o fst) eqs;
  47.356 +val conss  = map  snd        eqs;
  47.357 +
  47.358 +(* ----- getting the composite axiom and definitions ------------------------------ *)
  47.359 +
  47.360 +local val ga = get_axiom thy in
  47.361 +val axs_reach      = map (fn dn => ga (dn ^  "_reach"   )) dnames;
  47.362 +val axs_take_def   = map (fn dn => ga (dn ^  "_take_def")) dnames;
  47.363 +val axs_finite_def = map (fn dn => ga (dn ^"_finite_def")) dnames;
  47.364 +val ax_copy2_def   = ga (comp_dname^ "_copy_def");
  47.365 +val ax_bisim_def   = ga (comp_dname^"_bisim_def");
  47.366 +end; (* local *)
  47.367 +
  47.368 +(* ----- theorems concerning finiteness and induction ----------------------------- *)
  47.369 +
  47.370 +fun dc_take dn = %%(dn^"_take");
  47.371 +val x_name = idx_name dnames "x"; 
  47.372 +val P_name = idx_name dnames "P";
  47.373 +
  47.374 +local
  47.375 +  val iterate_ss = simpset_of "Fix";	
  47.376 +  val iterate_Cprod_strict_ss = iterate_ss addsimps [cfst_strict, csnd_strict];
  47.377 +  val iterate_Cprod_ss = iterate_ss addsimps [cfst2,csnd2,csplit2];
  47.378 +  val copy_con_rews  = copy_rews @ con_rews;
  47.379 +  val copy_take_defs = (if length dnames=1 then [] else [ax_copy2_def]) @axs_take_def;
  47.380 +  val take_stricts = pg copy_take_defs (mk_trp(foldr' mk_conj (map (fn ((dn,args),_)=>
  47.381 +		  (dc_take dn $ %"n")`UU === mk_constrain(Type(dn,args),UU)) eqs)))([
  47.382 +				nat_ind_tac "n" 1,
  47.383 +				simp_tac iterate_ss 1,
  47.384 +				simp_tac iterate_Cprod_strict_ss 1,
  47.385 +				asm_simp_tac iterate_Cprod_ss 1,
  47.386 +				TRY(safe_tac HOL_cs)] @
  47.387 +			map(K(asm_simp_tac (HOL_ss addsimps copy_rews)1))dnames);
  47.388 +  val take_stricts' = rewrite_rule copy_take_defs take_stricts;
  47.389 +  val take_0s = mapn (fn n => fn dn => pg axs_take_def(mk_trp((dc_take dn $ %%"0")
  47.390 +								`%x_name n === UU))[
  47.391 +				simp_tac iterate_Cprod_strict_ss 1]) 1 dnames;
  47.392 +  val take_apps = pg copy_take_defs (mk_trp(foldr' mk_conj 
  47.393 +	    (flat(map (fn ((dn,_),cons) => map (fn (con,args) => foldr mk_all 
  47.394 +		(map vname args,(dc_take dn $ (%%"Suc" $ %"n"))`(con_app con args) ===
  47.395 +  		 con_app2 con (app_rec_arg (fn n=>dc_take (nth_elem(n,dnames))$ %"n"))
  47.396 +			      args)) cons) eqs)))) ([
  47.397 +				nat_ind_tac "n" 1,
  47.398 +				simp_tac iterate_Cprod_strict_ss 1,
  47.399 +				simp_tac (HOLCF_ss addsimps copy_con_rews) 1,
  47.400 +				TRY(safe_tac HOL_cs)] @
  47.401 +			(flat(map (fn ((dn,_),cons) => map (fn (con,args) => EVERY (
  47.402 +				asm_full_simp_tac iterate_Cprod_ss 1::
  47.403 +				map (case_UU_tac (take_stricts'::copy_con_rews) 1)
  47.404 +				    (nonlazy args) @[
  47.405 +				asm_full_simp_tac (HOLCF_ss addsimps copy_rews) 1])
  47.406 +		 	) cons) eqs)));
  47.407 +in
  47.408 +val take_rews = atomize take_stricts @ take_0s @ atomize take_apps;
  47.409 +end; (* local *)
  47.410 +
  47.411 +val take_lemmas = mapn (fn n => fn(dn,ax_reach) => pg'' thy axs_take_def (mk_All("n",
  47.412 +		mk_trp(dc_take dn $ Bound 0 `%(x_name n) === 
  47.413 +		       dc_take dn $ Bound 0 `%(x_name n^"'")))
  47.414 +	   ===> mk_trp(%(x_name n) === %(x_name n^"'"))) (fn prems => [
  47.415 +				res_inst_tac[("t",x_name n    )](ax_reach RS subst) 1,
  47.416 +				res_inst_tac[("t",x_name n^"'")](ax_reach RS subst) 1,
  47.417 +				rtac (fix_def2 RS ssubst) 1,
  47.418 +				REPEAT(CHANGED(rtac (contlub_cfun_arg RS ssubst) 1
  47.419 +					       THEN chain_tac 1)),
  47.420 +				rtac (contlub_cfun_fun RS ssubst) 1,
  47.421 +				rtac (contlub_cfun_fun RS ssubst) 2,
  47.422 +				rtac lub_equal 3,
  47.423 +				chain_tac 1,
  47.424 +				rtac allI 1,
  47.425 +				resolve_tac prems 1])) 1 (dnames~~axs_reach);
  47.426 +
  47.427 +local
  47.428 +  fun one_con p (con,args) = foldr mk_All (map vname args,
  47.429 +	lift_defined (bound_arg (map vname args)) (nonlazy args,
  47.430 +	lift (fn arg => %(P_name (1+rec_of arg)) $ bound_arg args arg)
  47.431 +	     (filter is_rec args,mk_trp(%p $ con_app2 con (bound_arg args) args))));
  47.432 +  fun one_eq ((p,cons),concl) = (mk_trp(%p $ UU) ===> 
  47.433 +			   foldr (op ===>) (map (one_con p) cons,concl));
  47.434 +  fun ind_term concf = foldr one_eq (mapn (fn n => fn x => (P_name n, x)) 1 conss,
  47.435 +	mk_trp(foldr' mk_conj (mapn (fn n => concf (P_name n,x_name n)) 1 dnames)));
  47.436 +  val take_ss = HOL_ss addsimps take_rews;
  47.437 +  fun ind_tacs tacsf thms1 thms2 prems = TRY(safe_tac HOL_cs)::
  47.438 +				flat (mapn (fn n => fn (thm1,thm2) => 
  47.439 +				  tacsf (n,prems) (thm1,thm2) @ 
  47.440 +				  flat (map (fn cons =>
  47.441 +				    (resolve_tac prems 1 ::
  47.442 +				     flat (map (fn (_,args) => 
  47.443 +				       resolve_tac prems 1::
  47.444 +				       map (K(atac 1)) (nonlazy args) @
  47.445 +				       map (K(atac 1)) (filter is_rec args))
  47.446 +				     cons)))
  47.447 +				   conss))
  47.448 +				0 (thms1~~thms2));
  47.449 +  local 
  47.450 +    fun all_rec_to ns lazy_rec (n,cons) = forall (exists (fn arg => 
  47.451 +		  is_rec arg andalso not(rec_of arg mem ns) andalso
  47.452 +		  ((rec_of arg =  n andalso not(lazy_rec orelse is_lazy arg)) orelse 
  47.453 +		    rec_of arg <> n andalso all_rec_to (rec_of arg::ns) 
  47.454 +		      (lazy_rec orelse is_lazy arg) (n, (nth_elem(rec_of arg,conss))))
  47.455 +		  ) o snd) cons;
  47.456 +    fun warn (n,cons) = if all_rec_to [] false (n,cons) then (writeln 
  47.457 +			   ("WARNING: domain "^nth_elem(n,dnames)^" is empty!"); true)
  47.458 +			else false;
  47.459 +    fun lazy_rec_to ns lazy_rec (n,cons) = exists (exists (fn arg => 
  47.460 +		  is_rec arg andalso not(rec_of arg mem ns) andalso
  47.461 +		  ((rec_of arg =  n andalso (lazy_rec orelse is_lazy arg)) orelse 
  47.462 +		    rec_of arg <> n andalso lazy_rec_to (rec_of arg::ns)
  47.463 +		     (lazy_rec orelse is_lazy arg) (n, (nth_elem(rec_of arg,conss))))
  47.464 +		 ) o snd) cons;
  47.465 +  in val is_emptys = map warn (mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs);
  47.466 +     val is_finite = forall (not o lazy_rec_to [] false) 
  47.467 +			    (mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs)
  47.468 +  end;
  47.469 +in
  47.470 +val finite_ind = pg'' thy [] (ind_term (fn (P,x) => fn dn => 
  47.471 +			  mk_all(x,%P $ (dc_take dn $ %"n" `Bound 0)))) (fn prems=> [
  47.472 +				nat_ind_tac "n" 1,
  47.473 +				simp_tac (take_ss addsimps prems) 1,
  47.474 +				TRY(safe_tac HOL_cs)]
  47.475 +				@ flat(mapn (fn n => fn (cons,cases) => [
  47.476 +				 res_inst_tac [("x",x_name n)] cases 1,
  47.477 +				 asm_simp_tac (take_ss addsimps prems) 1]
  47.478 +				 @ flat(map (fn (con,args) => 
  47.479 +				  asm_simp_tac take_ss 1 ::
  47.480 +				  map (fn arg =>
  47.481 +				   case_UU_tac (prems@con_rews) 1 (
  47.482 +				   nth_elem(rec_of arg,dnames)^"_take n1`"^vname arg))
  47.483 +				  (filter is_nonlazy_rec args) @ [
  47.484 +				  resolve_tac prems 1] @
  47.485 +				  map (K (atac 1))      (nonlazy args) @
  47.486 +				  map (K (etac spec 1)) (filter is_rec args)) 
  47.487 +				 cons))
  47.488 +				1 (conss~~casess)));
  47.489 +
  47.490 +val (finites,ind) = if is_finite then
  47.491 +let 
  47.492 +  fun take_enough dn = mk_ex ("n",dc_take dn $ Bound 0 ` %"x" === %"x");
  47.493 +  val finite_lemmas1a = map (fn dn => pg [] (mk_trp(defined (%"x")) ===> 
  47.494 +	mk_trp(mk_disj(mk_all("n",dc_take dn $ Bound 0 ` %"x" === UU),
  47.495 +	take_enough dn)) ===> mk_trp(take_enough dn)) [
  47.496 +				etac disjE 1,
  47.497 +				etac notE 1,
  47.498 +				resolve_tac take_lemmas 1,
  47.499 +				asm_simp_tac take_ss 1,
  47.500 +				atac 1]) dnames;
  47.501 +  val finite_lemma1b = pg [] (mk_trp (mk_all("n",foldr' mk_conj (mapn 
  47.502 +	(fn n => fn ((dn,args),_) => mk_constrainall(x_name n,Type(dn,args),
  47.503 +	 mk_disj(dc_take dn $ Bound 1 ` Bound 0 === UU,
  47.504 +		 dc_take dn $ Bound 1 ` Bound 0 === Bound 0))) 1 eqs)))) ([
  47.505 +				rtac allI 1,
  47.506 +				nat_ind_tac "n" 1,
  47.507 +				simp_tac take_ss 1,
  47.508 +				TRY(safe_tac(empty_cs addSEs[conjE] addSIs[conjI]))] @
  47.509 +				flat(mapn (fn n => fn (cons,cases) => [
  47.510 +				  simp_tac take_ss 1,
  47.511 +				  rtac allI 1,
  47.512 +				  res_inst_tac [("x",x_name n)] cases 1,
  47.513 +				  asm_simp_tac take_ss 1] @ 
  47.514 +				  flat(map (fn (con,args) => 
  47.515 +				    asm_simp_tac take_ss 1 ::
  47.516 +				    flat(map (fn arg => [
  47.517 +				      eres_inst_tac [("x",vname arg)] all_dupE 1,
  47.518 +				      etac disjE 1,
  47.519 +				      asm_simp_tac (HOL_ss addsimps con_rews) 1,
  47.520 +				      asm_simp_tac take_ss 1])
  47.521 +				    (filter is_nonlazy_rec args)))
  47.522 +				  cons))
  47.523 +				1 (conss~~casess))) handle ERROR => raise ERROR;
  47.524 +  val all_finite=map (fn(dn,l1b)=>pg axs_finite_def (mk_trp(%%(dn^"_finite") $ %"x"))[
  47.525 +				case_UU_tac take_rews 1 "x",
  47.526 +				eresolve_tac finite_lemmas1a 1,
  47.527 +				step_tac HOL_cs 1,
  47.528 +				step_tac HOL_cs 1,
  47.529 +				cut_facts_tac [l1b] 1,
  47.530 +				fast_tac HOL_cs 1]) (dnames~~atomize finite_lemma1b);
  47.531 +in
  47.532 +(all_finite,
  47.533 + pg'' thy [] (ind_term (fn (P,x) => fn dn => %P $ %x))
  47.534 +			       (ind_tacs (fn _ => fn (all_fin,finite_ind) => [
  47.535 +				rtac (rewrite_rule axs_finite_def all_fin RS exE) 1,
  47.536 +				etac subst 1,
  47.537 +				rtac finite_ind 1]) all_finite (atomize finite_ind))
  47.538 +) end (* let *) else
  47.539 +(mapn (fn n => fn dn => read_instantiate_sg (sign_of thy) 
  47.540 +	  	    [("P",dn^"_finite "^x_name n)] excluded_middle) 1 dnames,
  47.541 + pg'' thy [] (foldr (op ===>) (mapn (fn n =>K(mk_trp(%%"adm" $ %(P_name n))))1
  47.542 +				       dnames,ind_term (fn(P,x)=>fn dn=> %P $ %x)))
  47.543 +			       (ind_tacs (fn (n,prems) => fn (ax_reach,finite_ind) =>[
  47.544 +				rtac (ax_reach RS subst) 1,
  47.545 +				res_inst_tac [("x",x_name n)] spec 1,
  47.546 +				rtac wfix_ind 1,
  47.547 +				rtac adm_impl_admw 1,
  47.548 +				resolve_tac adm_thms 1,
  47.549 +				rtac adm_subst 1,
  47.550 +				cont_tacR 1,
  47.551 +				resolve_tac prems 1,
  47.552 +				strip_tac 1,
  47.553 +			        rtac(rewrite_rule axs_take_def finite_ind) 1])
  47.554 +				 axs_reach (atomize finite_ind))
  47.555 +)
  47.556 +end; (* local *)
  47.557 +
  47.558 +local
  47.559 +  val xs = mapn (fn n => K (x_name n)) 1 dnames;
  47.560 +  fun bnd_arg n i = Bound(2*(length dnames - n)-i-1);
  47.561 +  val take_ss = HOL_ss addsimps take_rews;
  47.562 +  val sproj   = bin_branchr (fn s => "fst("^s^")") (fn s => "snd("^s^")");
  47.563 +  val coind_lemma = pg [ax_bisim_def] (mk_trp(mk_imp(%%(comp_dname^"_bisim") $ %"R",
  47.564 +		foldr (fn (x,t)=> mk_all(x,mk_all(x^"'",t))) (xs,
  47.565 +		  foldr mk_imp (mapn (fn n => K(proj (%"R") dnames n $ 
  47.566 +				      bnd_arg n 0 $ bnd_arg n 1)) 0 dnames,
  47.567 +		    foldr' mk_conj (mapn (fn n => fn dn => 
  47.568 +				(dc_take dn $ %"n" `bnd_arg n 0 === 
  47.569 +				(dc_take dn $ %"n" `bnd_arg n 1))) 0 dnames)))))) ([
  47.570 +				rtac impI 1,
  47.571 +				nat_ind_tac "n" 1,
  47.572 +				simp_tac take_ss 1,
  47.573 +				safe_tac HOL_cs] @
  47.574 +				flat(mapn (fn n => fn x => [
  47.575 +				  etac allE 1, etac allE 1, 
  47.576 +				  eres_inst_tac [("P1",sproj "R" dnames n^
  47.577 +						  " "^x^" "^x^"'")](mp RS disjE) 1,
  47.578 +				  TRY(safe_tac HOL_cs),
  47.579 +				  REPEAT(CHANGED(asm_simp_tac take_ss 1))]) 
  47.580 +				0 xs));
  47.581 +in
  47.582 +val coind = pg [] (mk_trp(%%(comp_dname^"_bisim") $ %"R") ===>
  47.583 +		foldr (op ===>) (mapn (fn n => fn x => 
  47.584 +			mk_trp(proj (%"R") dnames n $ %x $ %(x^"'"))) 0 xs,
  47.585 +			mk_trp(foldr' mk_conj (map (fn x => %x === %(x^"'")) xs)))) ([
  47.586 +				TRY(safe_tac HOL_cs)] @
  47.587 +				flat(map (fn take_lemma => [
  47.588 +				  rtac take_lemma 1,
  47.589 +				  cut_facts_tac [coind_lemma] 1,
  47.590 +				  fast_tac HOL_cs 1])
  47.591 +				take_lemmas));
  47.592 +end; (* local *)
  47.593 +
  47.594 +
  47.595 +in (take_rews, take_lemmas, finites, finite_ind, ind, coind)
  47.596 +
  47.597 +end; (* let *)
  47.598 +end; (* local *)
  47.599 +end; (* struct *)
    48.1 --- a/src/HOLCF/ex/Coind.ML	Fri Oct 06 16:17:08 1995 +0100
    48.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    48.3 @@ -1,138 +0,0 @@
    48.4 -(*  Title: 	HOLCF/coind.ML
    48.5 -    ID:         $Id$
    48.6 -    Author: 	Franz Regensburger
    48.7 -    Copyright   1993 Technische Universitaet Muenchen
    48.8 -*)
    48.9 -
   48.10 -open Coind;
   48.11 -
   48.12 -(* ------------------------------------------------------------------------- *)
   48.13 -(* expand fixed point properties                                             *)
   48.14 -(* ------------------------------------------------------------------------- *)
   48.15 -
   48.16 -
   48.17 -val nats_def2 = fix_prover2 Coind.thy nats_def 
   48.18 -	"nats = scons`dzero`(smap`dsucc`nats)";
   48.19 -
   48.20 -val from_def2 = fix_prover2 Coind.thy from_def 
   48.21 -	"from = (LAM n.scons`n`(from`(dsucc`n)))";
   48.22 -
   48.23 -
   48.24 -
   48.25 -(* ------------------------------------------------------------------------- *)
   48.26 -(* recursive  properties                                                     *)
   48.27 -(* ------------------------------------------------------------------------- *)
   48.28 -
   48.29 -
   48.30 -val from = prove_goal Coind.thy "from`n = scons`n`(from`(dsucc`n))"
   48.31 - (fn prems =>
   48.32 -	[
   48.33 -	(rtac trans 1),
   48.34 -	(rtac (from_def2 RS ssubst) 1),
   48.35 -	(Simp_tac 1),
   48.36 -	(rtac refl 1)
   48.37 -	]);
   48.38 -
   48.39 -
   48.40 -val from1 = prove_goal Coind.thy "from`UU = UU"
   48.41 - (fn prems =>
   48.42 -	[
   48.43 -	(rtac trans 1),
   48.44 -	(rtac (from RS ssubst) 1),
   48.45 -	(resolve_tac  stream_constrdef 1),
   48.46 -	(rtac refl 1)
   48.47 -	]);
   48.48 -
   48.49 -val coind_rews = 
   48.50 -	[iterator1, iterator2, iterator3, smap1, smap2,from1];
   48.51 -
   48.52 -
   48.53 -(* ------------------------------------------------------------------------- *)
   48.54 -(* the example                                                               *)
   48.55 -(* prove:        nats = from`dzero                                           *)
   48.56 -(* ------------------------------------------------------------------------- *)
   48.57 -
   48.58 -
   48.59 -val coind_lemma1 = prove_goal Coind.thy "iterator`n`(smap`dsucc)`nats =\
   48.60 -\		 scons`n`(iterator`(dsucc`n)`(smap`dsucc)`nats)"
   48.61 - (fn prems =>
   48.62 -	[
   48.63 -	(res_inst_tac [("s","n")] dnat_ind 1),
   48.64 -	(simp_tac (!simpset addsimps (coind_rews @ stream_rews)) 1),
   48.65 -	(simp_tac (!simpset addsimps (coind_rews @ stream_rews)) 1),
   48.66 -	(rtac trans 1),
   48.67 -	(rtac nats_def2 1),
   48.68 -	(simp_tac (!simpset addsimps (coind_rews @ dnat_rews)) 1),
   48.69 -	(rtac trans 1),
   48.70 -	(etac iterator3 1),
   48.71 -	(rtac trans 1),
   48.72 -	(Asm_simp_tac 1),
   48.73 -	(rtac trans 1),
   48.74 -	(etac smap2 1),
   48.75 -	(rtac cfun_arg_cong 1),
   48.76 -	(asm_simp_tac (!simpset addsimps ([iterator3 RS sym] @ dnat_rews)) 1)
   48.77 -	]);
   48.78 -
   48.79 -
   48.80 -val nats_eq_from = prove_goal Coind.thy "nats = from`dzero"
   48.81 - (fn prems =>
   48.82 -	[
   48.83 -	(res_inst_tac [("R",
   48.84 -"% p q.? n. p = iterator`n`(smap`dsucc)`nats & q = from`n")] stream_coind 1),
   48.85 -	(res_inst_tac [("x","dzero")] exI 2),
   48.86 -	(asm_simp_tac (!simpset addsimps coind_rews) 2),
   48.87 -	(rewrite_goals_tac [stream_bisim_def]),
   48.88 -	(strip_tac 1),
   48.89 -	(etac exE 1),
   48.90 -	(res_inst_tac [("Q","n=UU")] classical2 1),
   48.91 -	(rtac disjI1 1),
   48.92 -	(asm_simp_tac (!simpset addsimps coind_rews) 1),
   48.93 -	(rtac disjI2 1),
   48.94 -	(etac conjE 1),
   48.95 -	(hyp_subst_tac 1),
   48.96 -	(res_inst_tac [("x","n")] exI 1),
   48.97 -	(res_inst_tac [("x","iterator`(dsucc`n)`(smap`dsucc)`nats")] exI 1),
   48.98 -	(res_inst_tac [("x","from`(dsucc`n)")] exI 1),
   48.99 -	(etac conjI 1),
  48.100 -	(rtac conjI 1),
  48.101 -	(rtac coind_lemma1 1),
  48.102 -	(rtac conjI 1),
  48.103 -	(rtac from 1),
  48.104 -	(res_inst_tac [("x","dsucc`n")] exI 1),
  48.105 -	(fast_tac HOL_cs 1)
  48.106 -	]);
  48.107 -
  48.108 -(* another proof using stream_coind_lemma2 *)
  48.109 -
  48.110 -val nats_eq_from = prove_goal Coind.thy "nats = from`dzero"
  48.111 - (fn prems =>
  48.112 -	[
  48.113 -	(res_inst_tac [("R","% p q.? n. p = \
  48.114 -\	iterator`n`(smap`dsucc)`nats & q = from`n")] stream_coind 1),
  48.115 -	(rtac stream_coind_lemma2 1),
  48.116 -	(strip_tac 1),
  48.117 -	(etac exE 1),
  48.118 -	(res_inst_tac [("Q","n=UU")] classical2 1),
  48.119 -	(asm_simp_tac (!simpset addsimps coind_rews) 1),
  48.120 -	(res_inst_tac [("x","UU::dnat")] exI 1),
  48.121 -	(simp_tac (!simpset addsimps coind_rews addsimps stream_rews) 1),
  48.122 -	(etac conjE 1),
  48.123 -	(hyp_subst_tac 1),
  48.124 -	(rtac conjI 1),
  48.125 -	(rtac (coind_lemma1 RS ssubst) 1),
  48.126 -	(rtac (from RS ssubst) 1),
  48.127 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  48.128 -	(res_inst_tac [("x","dsucc`n")] exI 1),
  48.129 -	(rtac conjI 1),
  48.130 -	(rtac trans 1),
  48.131 -	(rtac (coind_lemma1 RS ssubst) 1),
  48.132 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  48.133 -	(rtac refl 1),
  48.134 -	(rtac trans 1),
  48.135 -	(rtac (from RS ssubst) 1),
  48.136 -	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  48.137 -	(rtac refl 1),
  48.138 -	(res_inst_tac [("x","dzero")] exI 1),
  48.139 -	(asm_simp_tac (!simpset addsimps coind_rews) 1)
  48.140 -	]);
  48.141 -
    49.1 --- a/src/HOLCF/ex/Coind.thy	Fri Oct 06 16:17:08 1995 +0100
    49.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    49.3 @@ -1,33 +0,0 @@
    49.4 -(*  Title: 	HOLCF/coind.thy
    49.5 -    ID:         $Id$
    49.6 -    Author: 	Franz Regensburger
    49.7 -    Copyright   1993 Technische Universitaet Muenchen
    49.8 -
    49.9 -Example for co-induction on streams
   49.10 -*)
   49.11 -
   49.12 -Coind = Stream2 +
   49.13 -
   49.14 -
   49.15 -consts
   49.16 -
   49.17 -	nats		:: "dnat stream"
   49.18 -	from		:: "dnat -> dnat stream"
   49.19 -
   49.20 -defs
   49.21 -	nats_def	"nats == fix`(LAM h.scons`dzero`(smap`dsucc`h))"
   49.22 -
   49.23 -	from_def	"from == fix`(LAM h n.scons`n`(h`(dsucc`n)))"
   49.24 -
   49.25 -end
   49.26 -
   49.27 -(*
   49.28 -		smap`f`UU = UU
   49.29 -      x~=UU --> smap`f`(scons`x`xs) = scons`(f`x)`(smap`f`xs)
   49.30 -
   49.31 -		nats = scons`dzero`(smap`dsucc`nats)
   49.32 -
   49.33 -		from`n = scons`n`(from`(dsucc`n))
   49.34 -*)
   49.35 -
   49.36 -
    50.1 --- a/src/HOLCF/ex/Dagstuhl.ML	Fri Oct 06 16:17:08 1995 +0100
    50.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    50.3 @@ -1,75 +0,0 @@
    50.4 -(* $Id$ *)
    50.5 -
    50.6 -open Dagstuhl;
    50.7 -
    50.8 -val YS_def2  = fix_prover2 Dagstuhl.thy  YS_def  "YS = scons`y`YS";
    50.9 -val YYS_def2 = fix_prover2 Dagstuhl.thy YYS_def "YYS = scons`y`(scons`y`YYS)";
   50.10 -
   50.11 -
   50.12 -val prems = goal Dagstuhl.thy "YYS << scons`y`YYS";
   50.13 -by (rewrite_goals_tac [YYS_def]);
   50.14 -by (rtac fix_ind 1);
   50.15 -by (resolve_tac adm_thms 1);
   50.16 -by (cont_tacR 1);
   50.17 -by (rtac minimal 1);
   50.18 -by (rtac (beta_cfun RS ssubst) 1);
   50.19 -by (cont_tacR 1);
   50.20 -by (rtac monofun_cfun_arg 1);
   50.21 -by (rtac monofun_cfun_arg 1);
   50.22 -by (atac 1);
   50.23 -val lemma3 = result();
   50.24 -
   50.25 -val prems = goal Dagstuhl.thy "scons`y`YYS << YYS";
   50.26 -by (rtac (YYS_def2 RS ssubst) 1);
   50.27 -back();
   50.28 -by (rtac monofun_cfun_arg 1);
   50.29 -by (rtac lemma3 1);
   50.30 -val lemma4=result();
   50.31 -
   50.32 -(* val  lemma5 = lemma3 RS (lemma4 RS antisym_less) *)
   50.33 -
   50.34 -val prems = goal Dagstuhl.thy "scons`y`YYS = YYS";
   50.35 -by (rtac antisym_less 1);
   50.36 -by (rtac lemma4 1);
   50.37 -by (rtac lemma3 1);
   50.38 -val lemma5=result();
   50.39 -
   50.40 -val prems = goal Dagstuhl.thy "YS = YYS";
   50.41 -by (rtac stream_take_lemma 1);
   50.42 -by (nat_ind_tac "n" 1);
   50.43 -by (simp_tac (!simpset addsimps stream_rews) 1);
   50.44 -by (rtac (YS_def2 RS ssubst) 1);
   50.45 -by (rtac (YYS_def2 RS ssubst) 1);
   50.46 -by (asm_simp_tac (!simpset addsimps stream_rews) 1);
   50.47 -by (rtac (lemma5 RS sym RS subst) 1);
   50.48 -by (rtac refl 1);
   50.49 -val wir_moel=result();
   50.50 -
   50.51 -(* ------------------------------------------------------------------------ *)
   50.52 -(* Zweite L"osung: Bernhard M"oller                                         *)
   50.53 -(* statt Beweis von  wir_moel "uber take_lemma beidseitige Inclusion        *)
   50.54 -(* verwendet lemma5                                                         *)
   50.55 -(* ------------------------------------------------------------------------ *)
   50.56 -
   50.57 -val prems = goal Dagstuhl.thy "YYS << YS";
   50.58 -by (rewrite_goals_tac [YYS_def]);
   50.59 -by (rtac fix_least 1);
   50.60 -by (rtac (beta_cfun RS ssubst) 1);
   50.61 -by (cont_tacR 1);
   50.62 -by (simp_tac (!simpset addsimps [YS_def2 RS sym]) 1);
   50.63 -val lemma6=result();
   50.64 -
   50.65 -val prems = goal Dagstuhl.thy "YS << YYS";
   50.66 -by (rewrite_goals_tac [YS_def]);
   50.67 -by (rtac fix_ind 1);
   50.68 -by (resolve_tac adm_thms 1);
   50.69 -by (cont_tacR 1);
   50.70 -by (rtac minimal 1);
   50.71 -by (rtac (beta_cfun RS ssubst) 1);
   50.72 -by (cont_tacR 1);
   50.73 -by (rtac (lemma5 RS sym RS ssubst) 1);
   50.74 -by (etac monofun_cfun_arg 1);
   50.75 -val lemma7 = result();
   50.76 -
   50.77 -val  wir_moel = lemma6 RS (lemma7 RS antisym_less);
   50.78 -
    51.1 --- a/src/HOLCF/ex/Dagstuhl.thy	Fri Oct 06 16:17:08 1995 +0100
    51.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    51.3 @@ -1,17 +0,0 @@
    51.4 -(* $Id$ *)
    51.5 -
    51.6 -
    51.7 -Dagstuhl  =  Stream2 +
    51.8 -
    51.9 -consts
   51.10 -	y  :: "'a"
   51.11 -       YS  :: "'a stream"
   51.12 -       YYS :: "'a stream"
   51.13 -
   51.14 -defs
   51.15 -
   51.16 -YS_def    "YS  == fix`(LAM x. scons`y`x)"
   51.17 -YYS_def   "YYS == fix`(LAM z. scons`y`(scons`y`z))"
   51.18 -  
   51.19 -end
   51.20 -
    52.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    52.2 +++ b/src/HOLCF/ex/Fix2.ML	Fri Oct 06 17:25:24 1995 +0100
    52.3 @@ -0,0 +1,28 @@
    52.4 +(*  Title:	HOLCF/ex/Fix2.ML
    52.5 +    ID:         $Id$
    52.6 +    Author: 	Franz Regensburger
    52.7 +    Copyright	1995 Technische Universitaet Muenchen
    52.8 +*)
    52.9 +
   52.10 +open Fix2;
   52.11 +
   52.12 +val lemma1 = prove_goal Fix2.thy "fix = gix"
   52.13 + (fn prems =>
   52.14 +	[
   52.15 +	(rtac ext_cfun 1),
   52.16 +	(rtac antisym_less 1),
   52.17 +	(rtac fix_least 1),
   52.18 +	(rtac gix1_def 1),
   52.19 +	(rtac gix2_def 1),
   52.20 +	(rtac (fix_eq RS sym) 1)
   52.21 +	]);
   52.22 +
   52.23 +
   52.24 +val lemma2 = prove_goal Fix2.thy "gix`F=lub(range(%i. iterate i F UU))"
   52.25 + (fn prems =>
   52.26 +	[
   52.27 +	(rtac (lemma1 RS subst) 1),
   52.28 +	(rtac fix_def2 1)
   52.29 +	]);
   52.30 +
   52.31 +
    53.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    53.2 +++ b/src/HOLCF/ex/Fix2.thy	Fri Oct 06 17:25:24 1995 +0100
    53.3 @@ -0,0 +1,38 @@
    53.4 +(*  Title:	HOLCF/ex/Fix2.thy
    53.5 +    ID:         $Id$
    53.6 +    Author: 	Franz Regensburger
    53.7 +    Copyright	1995 Technische Universitaet Muenchen
    53.8 +
    53.9 + Show that fix is the unique least fixed-point operator. 
   53.10 + From axioms gix1_def,gix2_def it follows that fix = gix
   53.11 +
   53.12 +*)
   53.13 +
   53.14 +Fix2 = Fix + 
   53.15 +
   53.16 +consts
   53.17 +
   53.18 +     gix     :: "('a->'a)->'a"
   53.19 +
   53.20 +rules
   53.21 +
   53.22 +gix1_def "F`(gix`F) = gix`F"
   53.23 +gix2_def "F`y=y ==> gix`F << y"
   53.24 +
   53.25 +end
   53.26 +
   53.27 +
   53.28 +
   53.29 +
   53.30 +
   53.31 +
   53.32 +
   53.33 +
   53.34 +
   53.35 +
   53.36 +
   53.37 +
   53.38 +
   53.39 +
   53.40 +
   53.41 +
    54.1 --- a/src/HOLCF/ex/Hoare.ML	Fri Oct 06 16:17:08 1995 +0100
    54.2 +++ b/src/HOLCF/ex/Hoare.ML	Fri Oct 06 17:25:24 1995 +0100
    54.3 @@ -137,8 +137,6 @@
    54.4  
    54.5  (** --------- proves about iterations of p and q ---------- **)
    54.6  
    54.7 -val HOLCF_ss = simpset_of "HOLCF";
    54.8 -
    54.9  val hoare_lemma9 = prove_goal Hoare.thy 
   54.10  "(! m. m< Suc k --> b1`(iterate m g x)=TT) -->\
   54.11  \  p`(iterate k g x)=p`x"
    55.1 --- a/src/HOLCF/ex/Loop.ML	Fri Oct 06 16:17:08 1995 +0100
    55.2 +++ b/src/HOLCF/ex/Loop.ML	Fri Oct 06 17:25:24 1995 +0100
    55.3 @@ -1,4 +1,4 @@
    55.4 -(*  Title:	HOLCF/ex/loop.ML
    55.5 +(*  Title:	HOLCF/ex/Loop.ML
    55.6      ID:         $Id$
    55.7      Author: 	Franz Regensburger
    55.8      Copyright	1993 Technische Universitaet Muenchen
    55.9 @@ -39,8 +39,6 @@
   55.10  	(Simp_tac 1)
   55.11  	]);
   55.12  
   55.13 -val HOLCF_ss = simpset_of "HOLCF";
   55.14 -
   55.15  val while_unfold2 = prove_goal Loop.thy 
   55.16  	"!x.while`b`g`x = while`b`g`(iterate k (step`b`g) x)"
   55.17   (fn prems =>
    56.1 --- a/src/HOLCF/ex/Loop.thy	Fri Oct 06 16:17:08 1995 +0100
    56.2 +++ b/src/HOLCF/ex/Loop.thy	Fri Oct 06 17:25:24 1995 +0100
    56.3 @@ -1,4 +1,4 @@
    56.4 -(*  Title:	HOLCF/ex/loop.thy
    56.5 +(*  Title:	HOLCF/ex/Loop.thy
    56.6      ID:         $Id$
    56.7      Author: 	Franz Regensburger
    56.8      Copyright	1993 Technische Universitaet Muenchen
    57.1 --- a/src/HOLCF/ex/ROOT.ML	Fri Oct 06 16:17:08 1995 +0100
    57.2 +++ b/src/HOLCF/ex/ROOT.ML	Fri Oct 06 17:25:24 1995 +0100
    57.3 @@ -10,10 +10,9 @@
    57.4  
    57.5  writeln"Root file for HOLCF examples";
    57.6  proof_timing := true;
    57.7 -time_use_thy "ex/Coind";
    57.8  time_use_thy "ex/Hoare";
    57.9  time_use_thy "ex/Loop";
   57.10 -time_use_thy "ex/Dagstuhl";
   57.11 +time_use_thy "ex/Fix2";
   57.12  time_use "ex/loeckx.ML";
   57.13  
   57.14  maketest     "END: Root file for HOLCF examples";
    58.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    58.2 +++ b/src/HOLCF/explicit_domains/Coind.ML	Fri Oct 06 17:25:24 1995 +0100
    58.3 @@ -0,0 +1,138 @@
    58.4 +(*  Title: 	HOLCF/Coind.ML
    58.5 +    ID:         $Id$
    58.6 +    Author: 	Franz Regensburger
    58.7 +    Copyright   1993 Technische Universitaet Muenchen
    58.8 +*)
    58.9 +
   58.10 +open Coind;
   58.11 +
   58.12 +(* ------------------------------------------------------------------------- *)
   58.13 +(* expand fixed point properties                                             *)
   58.14 +(* ------------------------------------------------------------------------- *)
   58.15 +
   58.16 +
   58.17 +val nats_def2 = fix_prover2 Coind.thy nats_def 
   58.18 +	"nats = scons`dzero`(smap`dsucc`nats)";
   58.19 +
   58.20 +val from_def2 = fix_prover2 Coind.thy from_def 
   58.21 +	"from = (LAM n.scons`n`(from`(dsucc`n)))";
   58.22 +
   58.23 +
   58.24 +
   58.25 +(* ------------------------------------------------------------------------- *)
   58.26 +(* recursive  properties                                                     *)
   58.27 +(* ------------------------------------------------------------------------- *)
   58.28 +
   58.29 +
   58.30 +val from = prove_goal Coind.thy "from`n = scons`n`(from`(dsucc`n))"
   58.31 + (fn prems =>
   58.32 +	[
   58.33 +	(rtac trans 1),
   58.34 +	(rtac (from_def2 RS ssubst) 1),
   58.35 +	(Simp_tac 1),
   58.36 +	(rtac refl 1)
   58.37 +	]);
   58.38 +
   58.39 +
   58.40 +val from1 = prove_goal Coind.thy "from`UU = UU"
   58.41 + (fn prems =>
   58.42 +	[
   58.43 +	(rtac trans 1),
   58.44 +	(rtac (from RS ssubst) 1),
   58.45 +	(resolve_tac  stream_constrdef 1),
   58.46 +	(rtac refl 1)
   58.47 +	]);
   58.48 +
   58.49 +val coind_rews = 
   58.50 +	[iterator1, iterator2, iterator3, smap1, smap2,from1];
   58.51 +
   58.52 +
   58.53 +(* ------------------------------------------------------------------------- *)
   58.54 +(* the example                                                               *)
   58.55 +(* prove:        nats = from`dzero                                           *)
   58.56 +(* ------------------------------------------------------------------------- *)
   58.57 +
   58.58 +
   58.59 +val coind_lemma1 = prove_goal Coind.thy "iterator`n`(smap`dsucc)`nats =\
   58.60 +\		 scons`n`(iterator`(dsucc`n)`(smap`dsucc)`nats)"
   58.61 + (fn prems =>
   58.62 +	[
   58.63 +	(res_inst_tac [("s","n")] dnat_ind 1),
   58.64 +	(simp_tac (!simpset addsimps (coind_rews @ stream_rews)) 1),
   58.65 +	(simp_tac (!simpset addsimps (coind_rews @ stream_rews)) 1),
   58.66 +	(rtac trans 1),
   58.67 +	(rtac nats_def2 1),
   58.68 +	(simp_tac (!simpset addsimps (coind_rews @ dnat_rews)) 1),
   58.69 +	(rtac trans 1),
   58.70 +	(etac iterator3 1),
   58.71 +	(rtac trans 1),
   58.72 +	(Asm_simp_tac 1),
   58.73 +	(rtac trans 1),
   58.74 +	(etac smap2 1),
   58.75 +	(rtac cfun_arg_cong 1),
   58.76 +	(asm_simp_tac (!simpset addsimps ([iterator3 RS sym] @ dnat_rews)) 1)
   58.77 +	]);
   58.78 +
   58.79 +
   58.80 +val nats_eq_from = prove_goal Coind.thy "nats = from`dzero"
   58.81 + (fn prems =>
   58.82 +	[
   58.83 +	(res_inst_tac [("R",
   58.84 +"% p q.? n. p = iterator`n`(smap`dsucc)`nats & q = from`n")] stream_coind 1),
   58.85 +	(res_inst_tac [("x","dzero")] exI 2),
   58.86 +	(asm_simp_tac (!simpset addsimps coind_rews) 2),
   58.87 +	(rewrite_goals_tac [stream_bisim_def]),
   58.88 +	(strip_tac 1),
   58.89 +	(etac exE 1),
   58.90 +	(res_inst_tac [("Q","n=UU")] classical2 1),
   58.91 +	(rtac disjI1 1),
   58.92 +	(asm_simp_tac (!simpset addsimps coind_rews) 1),
   58.93 +	(rtac disjI2 1),
   58.94 +	(etac conjE 1),
   58.95 +	(hyp_subst_tac 1),
   58.96 +	(res_inst_tac [("x","n")] exI 1),
   58.97 +	(res_inst_tac [("x","iterator`(dsucc`n)`(smap`dsucc)`nats")] exI 1),
   58.98 +	(res_inst_tac [("x","from`(dsucc`n)")] exI 1),
   58.99 +	(etac conjI 1),
  58.100 +	(rtac conjI 1),
  58.101 +	(rtac coind_lemma1 1),
  58.102 +	(rtac conjI 1),
  58.103 +	(rtac from 1),
  58.104 +	(res_inst_tac [("x","dsucc`n")] exI 1),
  58.105 +	(fast_tac HOL_cs 1)
  58.106 +	]);
  58.107 +
  58.108 +(* another proof using stream_coind_lemma2 *)
  58.109 +
  58.110 +val nats_eq_from = prove_goal Coind.thy "nats = from`dzero"
  58.111 + (fn prems =>
  58.112 +	[
  58.113 +	(res_inst_tac [("R","% p q.? n. p = \
  58.114 +\	iterator`n`(smap`dsucc)`nats & q = from`n")] stream_coind 1),
  58.115 +	(rtac stream_coind_lemma2 1),
  58.116 +	(strip_tac 1),
  58.117 +	(etac exE 1),
  58.118 +	(res_inst_tac [("Q","n=UU")] classical2 1),
  58.119 +	(asm_simp_tac (!simpset addsimps coind_rews) 1),
  58.120 +	(res_inst_tac [("x","UU::dnat")] exI 1),
  58.121 +	(simp_tac (!simpset addsimps coind_rews addsimps stream_rews) 1),
  58.122 +	(etac conjE 1),
  58.123 +	(hyp_subst_tac 1),
  58.124 +	(rtac conjI 1),
  58.125 +	(rtac (coind_lemma1 RS ssubst) 1),
  58.126 +	(rtac (from RS ssubst) 1),
  58.127 +	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  58.128 +	(res_inst_tac [("x","dsucc`n")] exI 1),
  58.129 +	(rtac conjI 1),
  58.130 +	(rtac trans 1),
  58.131 +	(rtac (coind_lemma1 RS ssubst) 1),
  58.132 +	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  58.133 +	(rtac refl 1),
  58.134 +	(rtac trans 1),
  58.135 +	(rtac (from RS ssubst) 1),
  58.136 +	(asm_simp_tac (!simpset addsimps stream_rews) 1),
  58.137 +	(rtac refl 1),
  58.138 +	(res_inst_tac [("x","dzero")] exI 1),
  58.139 +	(asm_simp_tac (!simpset addsimps coind_rews) 1)
  58.140 +	]);
  58.141 +
    59.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    59.2 +++ b/src/HOLCF/explicit_domains/Coind.thy	Fri Oct 06 17:25:24 1995 +0100
    59.3 @@ -0,0 +1,33 @@
    59.4 +(*  Title: 	HOLCF/Coind.thy
    59.5 +    ID:         $Id$
    59.6 +    Author: 	Franz Regensburger
    59.7 +    Copyright   1993 Technische Universitaet Muenchen
    59.8 +
    59.9 +Example for co-induction on streams
   59.10 +*)
   59.11 +
   59.12 +Coind = Stream2 +
   59.13 +
   59.14 +
   59.15 +consts
   59.16 +
   59.17 +	nats		:: "dnat stream"
   59.18 +	from		:: "dnat -> dnat stream"
   59.19 +
   59.20 +defs
   59.21 +	nats_def	"nats == fix`(LAM h.scons`dzero`(smap`dsucc`h))"
   59.22 +
   59.23 +	from_def	"from == fix`(LAM h n.scons`n`(h`(dsucc`n)))"
   59.24 +
   59.25 +end
   59.26 +
   59.27 +(*
   59.28 +		smap`f`UU = UU
   59.29 +      x~=UU --> smap`f`(scons`x`xs) = scons`(f`x)`(smap`f`xs)
   59.30 +
   59.31 +		nats = scons`dzero`(smap`dsucc`nats)
   59.32 +
   59.33 +		from`n = scons`n`(from`(dsucc`n))
   59.34 +*)
   59.35 +
   59.36 +
    60.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    60.2 +++ b/src/HOLCF/explicit_domains/Dagstuhl.ML	Fri Oct 06 17:25:24 1995 +0100
    60.3 @@ -0,0 +1,75 @@
    60.4 +(* $Id$ *)
    60.5 +
    60.6 +open Dagstuhl;
    60.7 +
    60.8 +val YS_def2  = fix_prover2 Dagstuhl.thy  YS_def  "YS = scons`y`YS";
    60.9 +val YYS_def2 = fix_prover2 Dagstuhl.thy YYS_def "YYS = scons`y`(scons`y`YYS)";
   60.10 +
   60.11 +
   60.12 +val prems = goal Dagstuhl.thy "YYS << scons`y`YYS";
   60.13 +by (rewrite_goals_tac [YYS_def]);
   60.14 +by (rtac fix_ind 1);
   60.15 +by (resolve_tac adm_thms 1);
   60.16 +by (cont_tacR 1);
   60.17 +by (rtac minimal 1);
   60.18 +by (rtac (beta_cfun RS ssubst) 1);
   60.19 +by (cont_tacR 1);
   60.20 +by (rtac monofun_cfun_arg 1);
   60.21 +by (rtac monofun_cfun_arg 1);
   60.22 +by (atac 1);
   60.23 +val lemma3 = result();
   60.24 +
   60.25 +val prems = goal Dagstuhl.thy "scons`y`YYS << YYS";
   60.26 +by (rtac (YYS_def2 RS ssubst) 1);
   60.27 +back();
   60.28 +by (rtac monofun_cfun_arg 1);
   60.29 +by (rtac lemma3 1);
   60.30 +val lemma4=result();
   60.31 +
   60.32 +(* val  lemma5 = lemma3 RS (lemma4 RS antisym_less) *)
   60.33 +
   60.34 +val prems = goal Dagstuhl.thy "scons`y`YYS = YYS";
   60.35 +by (rtac antisym_less 1);
   60.36 +by (rtac lemma4 1);
   60.37 +by (rtac lemma3 1);
   60.38 +val lemma5=result();
   60.39 +
   60.40 +val prems = goal Dagstuhl.thy "YS = YYS";
   60.41 +by (rtac stream_take_lemma 1);
   60.42 +by (nat_ind_tac "n" 1);
   60.43 +by (simp_tac (!simpset addsimps stream_rews) 1);
   60.44 +by (rtac (YS_def2 RS ssubst) 1);
   60.45 +by (rtac (YYS_def2 RS ssubst) 1);
   60.46 +by (asm_simp_tac (!simpset addsimps stream_rews) 1);
   60.47 +by (rtac (lemma5 RS sym RS subst) 1);
   60.48 +by (rtac refl 1);
   60.49 +val wir_moel=result();
   60.50 +
   60.51 +(* ------------------------------------------------------------------------ *)
   60.52 +(* Zweite L"osung: Bernhard M"oller                                         *)
   60.53 +(* statt Beweis von  wir_moel "uber take_lemma beidseitige Inclusion        *)
   60.54 +(* verwendet lemma5                                                         *)
   60.55 +(* ------------------------------------------------------------------------ *)
   60.56 +
   60.57 +val prems = goal Dagstuhl.thy "YYS << YS";
   60.58 +by (rewrite_goals_tac [YYS_def]);
   60.59 +by (rtac fix_least 1);
   60.60 +by (rtac (beta_cfun RS ssubst) 1);
   60.61 +by (cont_tacR 1);
   60.62 +by (simp_tac (!simpset addsimps [YS_def2 RS sym]) 1);
   60.63 +val lemma6=result();
   60.64 +
   60.65 +val prems = goal Dagstuhl.thy "YS << YYS";
   60.66 +by (rewrite_goals_tac [YS_def]);
   60.67 +by (rtac fix_ind 1);
   60.68 +by (resolve_tac adm_thms 1);
   60.69 +by (cont_tacR 1);
   60.70 +by (rtac minimal 1);
   60.71 +by (rtac (beta_cfun RS ssubst) 1);
   60.72 +by (cont_tacR 1);
   60.73 +by (rtac (lemma5 RS sym RS ssubst) 1);
   60.74 +by (etac monofun_cfun_arg 1);
   60.75 +val lemma7 = result();
   60.76 +
   60.77 +val  wir_moel = lemma6 RS (lemma7 RS antisym_less);
   60.78 +
    61.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    61.2 +++ b/src/HOLCF/explicit_domains/Dagstuhl.thy	Fri Oct 06 17:25:24 1995 +0100
    61.3 @@ -0,0 +1,17 @@
    61.4 +(* $Id$ *)
    61.5 +
    61.6 +
    61.7 +Dagstuhl  =  Stream2 +
    61.8 +
    61.9 +consts
   61.10 +	y  :: "'a"
   61.11 +       YS  :: "'a stream"
   61.12 +       YYS :: "'a stream"
   61.13 +
   61.14 +defs
   61.15 +
   61.16 +YS_def    "YS  == fix`(LAM x. scons`y`x)"
   61.17 +YYS_def   "YYS == fix`(LAM z. scons`y`(scons`y`z))"
   61.18 +  
   61.19 +end
   61.20 +
    62.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    62.2 +++ b/src/HOLCF/explicit_domains/Dlist.ML	Fri Oct 06 17:25:24 1995 +0100
    62.3 @@ -0,0 +1,564 @@
    62.4 +(*  Title: 	HOLCF/Dlist.ML
    62.5 +    Author: 	Franz Regensburger
    62.6 +    ID:         $ $
    62.7 +    Copyright   1994 Technische Universitaet Muenchen
    62.8 +
    62.9 +Lemmas for dlist.thy
   62.10 +*)
   62.11 +
   62.12 +open Dlist;
   62.13 +
   62.14 +(* ------------------------------------------------------------------------*)
   62.15 +(* The isomorphisms dlist_rep_iso and dlist_abs_iso are strict             *)
   62.16 +(* ------------------------------------------------------------------------*)
   62.17 +
   62.18 +val dlist_iso_strict= dlist_rep_iso RS (dlist_abs_iso RS 
   62.19 +	(allI  RSN (2,allI RS iso_strict)));
   62.20 +
   62.21 +val dlist_rews = [dlist_iso_strict RS conjunct1,
   62.22 +		dlist_iso_strict RS conjunct2];
   62.23 +
   62.24 +(* ------------------------------------------------------------------------*)
   62.25 +(* Properties of dlist_copy                                                *)
   62.26 +(* ------------------------------------------------------------------------*)
   62.27 +
   62.28 +val temp = prove_goalw Dlist.thy  [dlist_copy_def] "dlist_copy`f`UU=UU"
   62.29 + (fn prems =>
   62.30 +	[
   62.31 +	(asm_simp_tac (!simpset addsimps 
   62.32 +		(dlist_rews @ [dlist_abs_iso,dlist_rep_iso])) 1)
   62.33 +	]);
   62.34 +
   62.35 +val dlist_copy = [temp];
   62.36 +
   62.37 +
   62.38 +val temp = prove_goalw Dlist.thy  [dlist_copy_def,dnil_def] 
   62.39 +    "dlist_copy`f`dnil=dnil"
   62.40 + (fn prems =>
   62.41 +	[
   62.42 +	(asm_simp_tac (!simpset addsimps 
   62.43 +		(dlist_rews @ [dlist_abs_iso,dlist_rep_iso])) 1)
   62.44 +	]);
   62.45 +
   62.46 +val dlist_copy = temp :: dlist_copy;
   62.47 +
   62.48 +
   62.49 +val temp = prove_goalw Dlist.thy  [dlist_copy_def,dcons_def] 
   62.50 +	"xl~=UU ==> dlist_copy`f`(dcons`x`xl)= dcons`x`(f`xl)"
   62.51 + (fn prems =>
   62.52 +	[
   62.53 +	(cut_facts_tac prems 1),
   62.54 +	(asm_simp_tac (!simpset addsimps 
   62.55 +		(dlist_rews @ [dlist_abs_iso,dlist_rep_iso])) 1),
   62.56 +	(res_inst_tac [("Q","x=UU")] classical2 1),
   62.57 +	(Asm_simp_tac  1),
   62.58 +	(asm_simp_tac (!simpset addsimps [defined_spair]) 1)
   62.59 +	]);
   62.60 +
   62.61 +val dlist_copy = temp :: dlist_copy;
   62.62 +
   62.63 +val dlist_rews =  dlist_copy @ dlist_rews; 
   62.64 +
   62.65 +(* ------------------------------------------------------------------------*)
   62.66 +(* Exhaustion and elimination for dlists                                   *)
   62.67 +(* ------------------------------------------------------------------------*)
   62.68 +
   62.69 +qed_goalw "Exh_dlist" Dlist.thy [dcons_def,dnil_def]
   62.70 +	"l = UU | l = dnil | (? x xl. x~=UU &xl~=UU & l = dcons`x`xl)"
   62.71 + (fn prems =>
   62.72 +	[
   62.73 +	(Simp_tac 1),
   62.74 +	(rtac (dlist_rep_iso RS subst) 1),
   62.75 +	(res_inst_tac [("p","dlist_rep`l")] ssumE 1),
   62.76 +	(rtac disjI1 1),
   62.77 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   62.78 +	(rtac disjI2 1),
   62.79 +	(rtac disjI1 1),
   62.80 +	(res_inst_tac [("p","x")] oneE 1),
   62.81 +	(contr_tac 1),
   62.82 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   62.83 +	(rtac disjI2 1),
   62.84 +	(rtac disjI2 1),
   62.85 +	(res_inst_tac [("p","y")] sprodE 1),
   62.86 +	(contr_tac 1),
   62.87 +	(rtac exI 1),
   62.88 +	(rtac exI 1),
   62.89 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
   62.90 +	(fast_tac HOL_cs 1)
   62.91 +	]);
   62.92 +
   62.93 +
   62.94 +qed_goal "dlistE" Dlist.thy 
   62.95 +"[| l=UU ==> Q; l=dnil ==> Q;!!x xl.[|l=dcons`x`xl;x~=UU;xl~=UU|]==>Q|]==>Q"
   62.96 + (fn prems =>
   62.97 +	[
   62.98 +	(rtac (Exh_dlist RS disjE) 1),
   62.99 +	(eresolve_tac prems 1),
  62.100 +	(etac disjE 1),
  62.101 +	(eresolve_tac prems 1),
  62.102 +	(etac exE 1),
  62.103 +	(etac exE 1),
  62.104 +	(resolve_tac prems 1),
  62.105 +	(fast_tac HOL_cs 1),
  62.106 +	(fast_tac HOL_cs 1),
  62.107 +	(fast_tac HOL_cs 1)
  62.108 +	]);
  62.109 +
  62.110 +(* ------------------------------------------------------------------------*)
  62.111 +(* Properties of dlist_when                                                *)
  62.112 +(* ------------------------------------------------------------------------*)
  62.113 +
  62.114 +val temp = prove_goalw  Dlist.thy  [dlist_when_def] "dlist_when`f1`f2`UU=UU"
  62.115 + (fn prems =>
  62.116 +	[
  62.117 +	(asm_simp_tac (!simpset addsimps [dlist_iso_strict]) 1)
  62.118 +	]);
  62.119 +
  62.120 +val dlist_when = [temp];
  62.121 +
  62.122 +val temp = prove_goalw  Dlist.thy [dlist_when_def,dnil_def]
  62.123 + "dlist_when`f1`f2`dnil= f1"
  62.124 + (fn prems =>
  62.125 +	[
  62.126 +	(asm_simp_tac (!simpset addsimps [dlist_abs_iso]) 1)
  62.127 +	]);
  62.128 +
  62.129 +val dlist_when = temp::dlist_when;
  62.130 +
  62.131 +val temp = prove_goalw  Dlist.thy [dlist_when_def,dcons_def]
  62.132 + "[|x~=UU;xl~=UU|] ==> dlist_when`f1`f2`(dcons`x`xl)= f2`x`xl"
  62.133 + (fn prems =>
  62.134 +	[
  62.135 +	(cut_facts_tac prems 1),
  62.136 +	(asm_simp_tac (!simpset addsimps [dlist_abs_iso,defined_spair]) 1)
  62.137 +	]);
  62.138 +
  62.139 +val dlist_when = temp::dlist_when;
  62.140 +
  62.141 +val dlist_rews = dlist_when @ dlist_rews;
  62.142 +
  62.143 +(* ------------------------------------------------------------------------*)
  62.144 +(* Rewrites for  discriminators and  selectors                             *)
  62.145 +(* ------------------------------------------------------------------------*)
  62.146 +
  62.147 +fun prover defs thm = prove_goalw Dlist.thy defs thm
  62.148 + (fn prems =>
  62.149 +	[
  62.150 +	(simp_tac (!simpset addsimps dlist_rews) 1)
  62.151 +	]);
  62.152 +
  62.153 +val dlist_discsel = [
  62.154 +	prover [is_dnil_def] "is_dnil`UU=UU",
  62.155 +	prover [is_dcons_def] "is_dcons`UU=UU",
  62.156 +	prover [dhd_def] "dhd`UU=UU",
  62.157 +	prover [dtl_def] "dtl`UU=UU"
  62.158 +	];
  62.159 +
  62.160 +fun prover defs thm = prove_goalw Dlist.thy defs thm
  62.161 + (fn prems =>
  62.162 +	[
  62.163 +	(cut_facts_tac prems 1),
  62.164 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
  62.165 +	]);
  62.166 +
  62.167 +val dlist_discsel = [
  62.168 +prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
  62.169 +  "is_dnil`dnil=TT",
  62.170 +prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
  62.171 +  "[|x~=UU;xl~=UU|] ==> is_dnil`(dcons`x`xl)=FF",
  62.172 +prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
  62.173 +  "is_dcons`dnil=FF",
  62.174 +prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
  62.175 +  "[|x~=UU;xl~=UU|] ==> is_dcons`(dcons`x`xl)=TT",
  62.176 +prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
  62.177 +  "dhd`dnil=UU",
  62.178 +prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
  62.179 +  "[|x~=UU;xl~=UU|] ==> dhd`(dcons`x`xl)=x",
  62.180 +prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
  62.181 +  "dtl`dnil=UU",
  62.182 +prover [is_dnil_def,is_dcons_def,dhd_def,dtl_def]
  62.183 +  "[|x~=UU;xl~=UU|] ==> dtl`(dcons`x`xl)=xl"] @ dlist_discsel;
  62.184 +
  62.185 +val dlist_rews = dlist_discsel @ dlist_rews;
  62.186 +
  62.187 +(* ------------------------------------------------------------------------*)
  62.188 +(* Definedness and strictness                                              *)
  62.189 +(* ------------------------------------------------------------------------*)
  62.190 +
  62.191 +fun prover contr thm = prove_goal Dlist.thy thm
  62.192 + (fn prems =>
  62.193 +	[
  62.194 +	(res_inst_tac [("P1",contr)] classical3 1),
  62.195 +	(simp_tac (!simpset addsimps dlist_rews) 1),
  62.196 +	(dtac sym 1),
  62.197 +	(Asm_simp_tac  1),
  62.198 +	(simp_tac (!simpset addsimps (prems @ dlist_rews)) 1)
  62.199 +	]);
  62.200 +
  62.201 +
  62.202 +val dlist_constrdef = [
  62.203 +prover "is_dnil`(UU::'a dlist) ~= UU" "dnil~=(UU::'a dlist)",
  62.204 +prover "is_dcons`(UU::'a dlist) ~= UU" 
  62.205 +	"[|x~=UU;xl~=UU|]==>dcons`(x::'a)`xl ~= UU"
  62.206 + ];
  62.207 +
  62.208 +
  62.209 +fun prover defs thm = prove_goalw Dlist.thy defs thm
  62.210 + (fn prems =>
  62.211 +	[
  62.212 +	(simp_tac (!simpset addsimps dlist_rews) 1)
  62.213 +	]);
  62.214 +
  62.215 +val dlist_constrdef = [
  62.216 +	prover [dcons_def] "dcons`UU`xl=UU",
  62.217 +	prover [dcons_def] "dcons`x`UU=UU"
  62.218 +	] @ dlist_constrdef;
  62.219 +
  62.220 +val dlist_rews = dlist_constrdef @ dlist_rews;
  62.221 +
  62.222 +
  62.223 +(* ------------------------------------------------------------------------*)
  62.224 +(* Distinctness wrt. << and =                                              *)
  62.225 +(* ------------------------------------------------------------------------*)
  62.226 +
  62.227 +val temp = prove_goal Dlist.thy  "~dnil << dcons`(x::'a)`xl"
  62.228 + (fn prems =>
  62.229 +	[
  62.230 +	(res_inst_tac [("P1","TT << FF")] classical3 1),
  62.231 +	(resolve_tac dist_less_tr 1),
  62.232 +	(dres_inst_tac [("fo5","is_dnil")] monofun_cfun_arg 1),
  62.233 +	(etac box_less 1),
  62.234 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.235 +	(res_inst_tac [("Q","(x::'a)=UU")] classical2 1),
  62.236 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.237 +	(res_inst_tac [("Q","(xl ::'a dlist)=UU")] classical2 1),
  62.238 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.239 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
  62.240 +	]);
  62.241 +
  62.242 +val dlist_dist_less = [temp];
  62.243 +
  62.244 +val temp = prove_goal Dlist.thy  "[|x~=UU;xl~=UU|]==>~ dcons`x`xl << dnil"
  62.245 + (fn prems =>
  62.246 +	[
  62.247 +	(cut_facts_tac prems 1),
  62.248 +	(res_inst_tac [("P1","TT << FF")] classical3 1),
  62.249 +	(resolve_tac dist_less_tr 1),
  62.250 +	(dres_inst_tac [("fo5","is_dcons")] monofun_cfun_arg 1),
  62.251 +	(etac box_less 1),
  62.252 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.253 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
  62.254 +	]);
  62.255 +
  62.256 +val dlist_dist_less = temp::dlist_dist_less;
  62.257 +
  62.258 +val temp = prove_goal Dlist.thy  "dnil ~= dcons`x`xl"
  62.259 + (fn prems =>
  62.260 +	[
  62.261 +	(res_inst_tac [("Q","x=UU")] classical2 1),
  62.262 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.263 +	(res_inst_tac [("Q","xl=UU")] classical2 1),
  62.264 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.265 +	(res_inst_tac [("P1","TT = FF")] classical3 1),
  62.266 +	(resolve_tac dist_eq_tr 1),
  62.267 +	(dres_inst_tac [("f","is_dnil")] cfun_arg_cong 1),
  62.268 +	(etac box_equals 1),
  62.269 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.270 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
  62.271 +	]);
  62.272 +
  62.273 +val dlist_dist_eq = [temp,temp RS not_sym];
  62.274 +
  62.275 +val dlist_rews = dlist_dist_less @ dlist_dist_eq @ dlist_rews;
  62.276 +
  62.277 +(* ------------------------------------------------------------------------*)
  62.278 +(* Invertibility                                                           *)
  62.279 +(* ------------------------------------------------------------------------*)
  62.280 +
  62.281 +val temp = prove_goal Dlist.thy "[|x1~=UU; y1~=UU;x2~=UU; y2~=UU;\
  62.282 +\ dcons`x1`x2 << dcons`y1`y2 |] ==> x1<< y1 & x2 << y2"
  62.283 + (fn prems =>
  62.284 +	[
  62.285 +	(cut_facts_tac prems 1),
  62.286 +	(rtac conjI 1),
  62.287 +	(dres_inst_tac [("fo5","dlist_when`UU`(LAM x l.x)")] monofun_cfun_arg 1),
  62.288 +	(etac box_less 1),
  62.289 +	(asm_simp_tac (!simpset addsimps dlist_when) 1),
  62.290 +	(asm_simp_tac (!simpset addsimps dlist_when) 1),
  62.291 +	(dres_inst_tac [("fo5","dlist_when`UU`(LAM x l.l)")] monofun_cfun_arg 1),
  62.292 +	(etac box_less 1),
  62.293 +	(asm_simp_tac (!simpset addsimps dlist_when) 1),
  62.294 +	(asm_simp_tac (!simpset addsimps dlist_when) 1)
  62.295 +	]);
  62.296 +
  62.297 +val dlist_invert =[temp];
  62.298 +
  62.299 +(* ------------------------------------------------------------------------*)
  62.300 +(* Injectivity                                                             *)
  62.301 +(* ------------------------------------------------------------------------*)
  62.302 +
  62.303 +val temp = prove_goal Dlist.thy "[|x1~=UU; y1~=UU;x2~=UU; y2~=UU;\
  62.304 +\ dcons`x1`x2 = dcons`y1`y2 |] ==> x1= y1 & x2 = y2"
  62.305 + (fn prems =>
  62.306 +	[
  62.307 +	(cut_facts_tac prems 1),
  62.308 +	(rtac conjI 1),
  62.309 +	(dres_inst_tac [("f","dlist_when`UU`(LAM x l.x)")] cfun_arg_cong 1),
  62.310 +	(etac box_equals 1),
  62.311 +	(asm_simp_tac (!simpset addsimps dlist_when) 1),
  62.312 +	(asm_simp_tac (!simpset addsimps dlist_when) 1),
  62.313 +	(dres_inst_tac [("f","dlist_when`UU`(LAM x l.l)")] cfun_arg_cong 1),
  62.314 +	(etac box_equals 1),
  62.315 +	(asm_simp_tac (!simpset addsimps dlist_when) 1),
  62.316 +	(asm_simp_tac (!simpset addsimps dlist_when) 1)
  62.317 +	]);
  62.318 +
  62.319 +val dlist_inject = [temp];
  62.320 + 
  62.321 +
  62.322 +(* ------------------------------------------------------------------------*)
  62.323 +(* definedness for  discriminators and  selectors                          *)
  62.324 +(* ------------------------------------------------------------------------*)
  62.325 +
  62.326 +fun prover thm = prove_goal Dlist.thy thm
  62.327 + (fn prems =>
  62.328 +	[
  62.329 +	(cut_facts_tac prems 1),
  62.330 +	(rtac dlistE 1),
  62.331 +	(contr_tac 1),
  62.332 +	(REPEAT (asm_simp_tac (!simpset addsimps dlist_discsel) 1))
  62.333 +	]);
  62.334 +
  62.335 +val dlist_discsel_def = 
  62.336 +	[
  62.337 +	prover "l~=UU ==> is_dnil`l~=UU", 
  62.338 +	prover "l~=UU ==> is_dcons`l~=UU" 
  62.339 +	];
  62.340 +
  62.341 +val dlist_rews = dlist_discsel_def @ dlist_rews;
  62.342 +
  62.343 +(* ------------------------------------------------------------------------*)
  62.344 +(* enhance the simplifier                                                  *)
  62.345 +(* ------------------------------------------------------------------------*)
  62.346 +
  62.347 +qed_goal "dhd2" Dlist.thy "xl~=UU ==> dhd`(dcons`x`xl)=x"
  62.348 + (fn prems =>
  62.349 +	[
  62.350 +	(cut_facts_tac prems 1),
  62.351 +	(res_inst_tac [("Q","x=UU")] classical2 1),
  62.352 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.353 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
  62.354 +	]);
  62.355 +
  62.356 +qed_goal "dtl2" Dlist.thy "x~=UU ==> dtl`(dcons`x`xl)=xl"
  62.357 + (fn prems =>
  62.358 +	[
  62.359 +	(cut_facts_tac prems 1),
  62.360 +	(res_inst_tac [("Q","xl=UU")] classical2 1),
  62.361 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.362 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
  62.363 +	]);
  62.364 +
  62.365 +val dlist_rews = dhd2 :: dtl2 :: dlist_rews;
  62.366 +
  62.367 +(* ------------------------------------------------------------------------*)
  62.368 +(* Properties dlist_take                                                   *)
  62.369 +(* ------------------------------------------------------------------------*)
  62.370 +
  62.371 +val temp = prove_goalw Dlist.thy [dlist_take_def] "dlist_take n`UU=UU"
  62.372 + (fn prems =>
  62.373 +	[
  62.374 +	(res_inst_tac [("n","n")] natE 1),
  62.375 +	(Asm_simp_tac 1),
  62.376 +	(Asm_simp_tac 1),
  62.377 +	(simp_tac (!simpset addsimps dlist_rews) 1)
  62.378 +	]);
  62.379 +
  62.380 +val dlist_take = [temp];
  62.381 +
  62.382 +val temp = prove_goalw Dlist.thy [dlist_take_def] "dlist_take 0`xs=UU"
  62.383 + (fn prems =>
  62.384 +	[
  62.385 +	(Asm_simp_tac 1)
  62.386 +	]);
  62.387 +
  62.388 +val dlist_take = temp::dlist_take;
  62.389 +
  62.390 +val temp = prove_goalw Dlist.thy [dlist_take_def]
  62.391 +	"dlist_take (Suc n)`dnil=dnil"
  62.392 + (fn prems =>
  62.393 +	[
  62.394 +	(Asm_simp_tac 1),
  62.395 +	(simp_tac (!simpset addsimps dlist_rews) 1)
  62.396 +	]);
  62.397 +
  62.398 +val dlist_take = temp::dlist_take;
  62.399 +
  62.400 +val temp = prove_goalw Dlist.thy [dlist_take_def]
  62.401 +  "dlist_take (Suc n)`(dcons`x`xl)= dcons`x`(dlist_take n`xl)"
  62.402 + (fn prems =>
  62.403 +	[
  62.404 +	(res_inst_tac [("Q","x=UU")] classical2 1),
  62.405 +	(Asm_simp_tac 1),
  62.406 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.407 +	(res_inst_tac [("Q","xl=UU")] classical2 1),
  62.408 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.409 +	(Asm_simp_tac 1),
  62.410 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.411 +	(res_inst_tac [("n","n")] natE 1),
  62.412 +	(Asm_simp_tac 1),
  62.413 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.414 +	(Asm_simp_tac 1),
  62.415 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.416 +	(Asm_simp_tac 1),
  62.417 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
  62.418 +	]);
  62.419 +
  62.420 +val dlist_take = temp::dlist_take;
  62.421 +
  62.422 +val dlist_rews = dlist_take @ dlist_rews;
  62.423 +
  62.424 +(* ------------------------------------------------------------------------*)
  62.425 +(* take lemma for dlists                                                  *)
  62.426 +(* ------------------------------------------------------------------------*)
  62.427 +
  62.428 +fun prover reach defs thm  = prove_goalw Dlist.thy defs thm
  62.429 + (fn prems =>
  62.430 +	[
  62.431 +	(res_inst_tac [("t","l1")] (reach RS subst) 1),
  62.432 +	(res_inst_tac [("t","l2")] (reach RS subst) 1),
  62.433 +	(rtac (fix_def2 RS ssubst) 1),
  62.434 +	(rtac (contlub_cfun_fun RS ssubst) 1),
  62.435 +	(rtac is_chain_iterate 1),
  62.436 +	(rtac (contlub_cfun_fun RS ssubst) 1),
  62.437 +	(rtac is_chain_iterate 1),
  62.438 +	(rtac lub_equal 1),
  62.439 +	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
  62.440 +	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
  62.441 +	(rtac allI 1),
  62.442 +	(resolve_tac prems 1)
  62.443 +	]);
  62.444 +
  62.445 +val dlist_take_lemma = prover dlist_reach  [dlist_take_def]
  62.446 +	"(!!n.dlist_take n`l1 = dlist_take n`l2) ==> l1=l2";
  62.447 +
  62.448 +
  62.449 +(* ------------------------------------------------------------------------*)
  62.450 +(* Co -induction for dlists                                               *)
  62.451 +(* ------------------------------------------------------------------------*)
  62.452 +
  62.453 +qed_goalw "dlist_coind_lemma" Dlist.thy [dlist_bisim_def] 
  62.454 +"dlist_bisim R ==> ! p q. R p q --> dlist_take n`p = dlist_take n`q"
  62.455 + (fn prems =>
  62.456 +	[
  62.457 +	(cut_facts_tac prems 1),
  62.458 +	(nat_ind_tac "n" 1),
  62.459 +	(simp_tac (!simpset addsimps dlist_rews) 1),
  62.460 +	(strip_tac 1),
  62.461 +	((etac allE 1) THEN (etac allE 1) THEN (etac (mp RS disjE) 1)),
  62.462 +	(atac 1),
  62.463 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.464 +	(etac disjE 1),
  62.465 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.466 +	(etac exE 1),
  62.467 +	(etac exE 1),
  62.468 +	(etac exE 1),
  62.469 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.470 +	(REPEAT (etac conjE 1)),
  62.471 +	(rtac cfun_arg_cong 1),
  62.472 +	(fast_tac HOL_cs 1)
  62.473 +	]);
  62.474 +
  62.475 +qed_goal "dlist_coind" Dlist.thy "[|dlist_bisim R ; R p q |] ==> p = q"
  62.476 + (fn prems =>
  62.477 +	[
  62.478 +	(rtac dlist_take_lemma 1),
  62.479 +	(rtac (dlist_coind_lemma RS spec RS spec RS mp) 1),
  62.480 +	(resolve_tac prems 1),
  62.481 +	(resolve_tac prems 1)
  62.482 +	]);
  62.483 +
  62.484 +(* ------------------------------------------------------------------------*)
  62.485 +(* structural induction                                                    *)
  62.486 +(* ------------------------------------------------------------------------*)
  62.487 +
  62.488 +qed_goal "dlist_finite_ind" Dlist.thy
  62.489 +"[|P(UU);P(dnil);\
  62.490 +\  !! x l1.[|x~=UU;l1~=UU;P(l1)|] ==> P(dcons`x`l1)\
  62.491 +\  |] ==> !l.P(dlist_take n`l)"
  62.492 + (fn prems =>
  62.493 +	[
  62.494 +	(nat_ind_tac "n" 1),
  62.495 +	(simp_tac (!simpset addsimps dlist_rews) 1),
  62.496 +	(resolve_tac prems 1),
  62.497 +	(rtac allI 1),
  62.498 +	(res_inst_tac [("l","l")] dlistE 1),
  62.499 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.500 +	(resolve_tac prems 1),
  62.501 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.502 +	(resolve_tac prems 1),
  62.503 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.504 +	(res_inst_tac [("Q","dlist_take n1`xl=UU")] classical2 1),
  62.505 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.506 +	(resolve_tac prems 1),
  62.507 +	(resolve_tac prems 1),
  62.508 +	(atac 1),
  62.509 +	(atac 1),
  62.510 +	(etac spec 1)
  62.511 +	]);
  62.512 +
  62.513 +qed_goal "dlist_all_finite_lemma1" Dlist.thy
  62.514 +"!l.dlist_take n`l=UU |dlist_take n`l=l"
  62.515 + (fn prems =>
  62.516 +	[
  62.517 +	(nat_ind_tac "n" 1),
  62.518 +	(simp_tac (!simpset addsimps dlist_rews) 1),
  62.519 +	(rtac allI 1),
  62.520 +	(res_inst_tac [("l","l")] dlistE 1),
  62.521 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.522 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.523 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.524 +	(eres_inst_tac [("x","xl")] allE 1),
  62.525 +	(etac disjE 1),
  62.526 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.527 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1)
  62.528 +	]);
  62.529 +
  62.530 +qed_goal "dlist_all_finite_lemma2" Dlist.thy "? n.dlist_take n`l=l"
  62.531 + (fn prems =>
  62.532 +	[
  62.533 +	(res_inst_tac [("Q","l=UU")] classical2 1),
  62.534 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.535 +	(subgoal_tac "(!n.dlist_take n`l=UU) |(? n.dlist_take n`l = l)" 1),
  62.536 +	(etac disjE 1),
  62.537 +	(eres_inst_tac [("P","l=UU")] notE 1),
  62.538 +	(rtac dlist_take_lemma 1),
  62.539 +	(asm_simp_tac (!simpset addsimps dlist_rews) 1),
  62.540 +	(atac 1),
  62.541 +	(subgoal_tac "!n.!l.dlist_take n`l=UU |dlist_take n`l=l" 1),
  62.542 +	(fast_tac HOL_cs 1),
  62.543 +	(rtac allI 1),
  62.544 +	(rtac dlist_all_finite_lemma1 1)
  62.545 +	]);
  62.546 +
  62.547 +qed_goalw "dlist_all_finite" Dlist.thy [dlist_finite_def] "dlist_finite(l)"
  62.548 + (fn prems =>
  62.549 +	[
  62.550 +	(rtac  dlist_all_finite_lemma2 1)
  62.551 +	]);
  62.552 +
  62.553 +qed_goal "dlist_ind" Dlist.thy
  62.554 +"[|P(UU);P(dnil);\
  62.555 +\  !! x l1.[|x~=UU;l1~=UU;P(l1)|] ==> P(dcons`x`l1)|] ==> P(l)"
  62.556 + (fn prems =>
  62.557 +	[
  62.558 +	(rtac (dlist_all_finite_lemma2 RS exE) 1),
  62.559 +	(etac subst 1),
  62.560 +	(rtac (dlist_finite_ind RS spec) 1),
  62.561 +	(REPEAT (resolve_tac prems 1)),
  62.562 +	(REPEAT (atac 1))
  62.563 +	]);
  62.564 +
  62.565 +
  62.566 +
  62.567 +
    63.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    63.2 +++ b/src/HOLCF/explicit_domains/Dlist.thy	Fri Oct 06 17:25:24 1995 +0100
    63.3 @@ -0,0 +1,126 @@
    63.4 +(*  Title: 	HOLCF/Dlist.thy
    63.5 +
    63.6 +    Author: 	Franz Regensburger
    63.7 +    ID:         $ $
    63.8 +    Copyright   1994 Technische Universitaet Muenchen
    63.9 +
   63.10 +Theory for finite lists  'a dlist = one ++ ('a ** 'a dlist)
   63.11 +
   63.12 +The type is axiomatized as the least solution of the domain equation above.
   63.13 +The functor term that specifies the domain equation is: 
   63.14 +
   63.15 +  FT = <++,K_{one},<**,K_{'a},I>>
   63.16 +
   63.17 +For details see chapter 5 of:
   63.18 +
   63.19 +[Franz Regensburger] HOLCF: Eine konservative Erweiterung von HOL um LCF,
   63.20 +                     Dissertation, Technische Universit"at M"unchen, 1994
   63.21 +
   63.22 +
   63.23 +*)
   63.24 +
   63.25 +Dlist = Stream2 +
   63.26 +
   63.27 +types dlist 1
   63.28 +
   63.29 +(* ----------------------------------------------------------------------- *)
   63.30 +(* arity axiom is validated by semantic reasoning                          *)
   63.31 +(* partial ordering is implicit in the isomorphism axioms and their cont.  *)
   63.32 +
   63.33 +arities dlist::(pcpo)pcpo
   63.34 +
   63.35 +consts
   63.36 +
   63.37 +(* ----------------------------------------------------------------------- *)
   63.38 +(* essential constants                                                     *)
   63.39 +
   63.40 +dlist_rep	:: "('a dlist) -> (one ++ 'a ** 'a dlist)"
   63.41 +dlist_abs	:: "(one ++ 'a ** 'a dlist) -> ('a dlist)"
   63.42 +
   63.43 +(* ----------------------------------------------------------------------- *)
   63.44 +(* abstract constants and auxiliary constants                              *)
   63.45 +
   63.46 +dlist_copy	:: "('a dlist -> 'a dlist) ->'a dlist -> 'a dlist"
   63.47 +
   63.48 +dnil            :: "'a dlist"
   63.49 +dcons		:: "'a -> 'a dlist -> 'a dlist"
   63.50 +dlist_when	:: " 'b -> ('a -> 'a dlist -> 'b) -> 'a dlist -> 'b"
   63.51 +is_dnil    	:: "'a dlist -> tr"
   63.52 +is_dcons	:: "'a dlist -> tr"
   63.53 +dhd		:: "'a dlist -> 'a"
   63.54 +dtl		:: "'a dlist -> 'a dlist"
   63.55 +dlist_take	:: "nat => 'a dlist -> 'a dlist"
   63.56 +dlist_finite	:: "'a dlist => bool"
   63.57 +dlist_bisim	:: "('a dlist => 'a dlist => bool) => bool"
   63.58 +
   63.59 +rules
   63.60 +
   63.61 +(* ----------------------------------------------------------------------- *)
   63.62 +(* axiomatization of recursive type 'a dlist                               *)
   63.63 +(* ----------------------------------------------------------------------- *)
   63.64 +(* ('a dlist,dlist_abs) is the initial F-algebra where                     *)
   63.65 +(* F is the locally continuous functor determined by functor term FT.      *)
   63.66 +(* domain equation: 'a dlist = one ++ ('a ** 'a dlist)                     *)
   63.67 +(* functor term:    FT = <++,K_{one},<**,K_{'a},I>>                        *)
   63.68 +(* ----------------------------------------------------------------------- *)
   63.69 +(* dlist_abs is an isomorphism with inverse dlist_rep                      *)
   63.70 +(* identity is the least endomorphism on 'a dlist                          *)
   63.71 +
   63.72 +dlist_abs_iso	"dlist_rep`(dlist_abs`x) = x"
   63.73 +dlist_rep_iso	"dlist_abs`(dlist_rep`x) = x"
   63.74 +dlist_copy_def	"dlist_copy == (LAM f. dlist_abs oo \
   63.75 +\ 		(sswhen`sinl`(sinr oo (ssplit`(LAM x y. (|x,f`y|) ))))\
   63.76 +\                                oo dlist_rep)"
   63.77 +dlist_reach	"(fix`dlist_copy)`x=x"
   63.78 +
   63.79 +
   63.80 +defs
   63.81 +(* ----------------------------------------------------------------------- *)
   63.82 +(* properties of additional constants                                      *)
   63.83 +(* ----------------------------------------------------------------------- *)
   63.84 +(* constructors                                                            *)
   63.85 +
   63.86 +dnil_def	"dnil  == dlist_abs`(sinl`one)"
   63.87 +dcons_def	"dcons == (LAM x l. dlist_abs`(sinr`(|x,l|) ))"
   63.88 +
   63.89 +(* ----------------------------------------------------------------------- *)
   63.90 +(* discriminator functional                                                *)
   63.91 +
   63.92 +dlist_when_def 
   63.93 +"dlist_when == (LAM f1 f2 l.\
   63.94 +\   sswhen`(LAM x.f1) `(ssplit`(LAM x l.f2`x`l)) `(dlist_rep`l))"
   63.95 +
   63.96 +(* ----------------------------------------------------------------------- *)
   63.97 +(* discriminators and selectors                                            *)
   63.98 +
   63.99 +is_dnil_def	"is_dnil  == dlist_when`TT`(LAM x l.FF)"
  63.100 +is_dcons_def	"is_dcons == dlist_when`FF`(LAM x l.TT)"
  63.101 +dhd_def		"dhd == dlist_when`UU`(LAM x l.x)"
  63.102 +dtl_def		"dtl == dlist_when`UU`(LAM x l.l)"
  63.103 +
  63.104 +(* ----------------------------------------------------------------------- *)
  63.105 +(* the taker for dlists                                                   *)
  63.106 +
  63.107 +dlist_take_def "dlist_take == (%n.iterate n dlist_copy UU)"
  63.108 +
  63.109 +(* ----------------------------------------------------------------------- *)
  63.110 +
  63.111 +dlist_finite_def	"dlist_finite == (%s.? n.dlist_take n`s=s)"
  63.112 +
  63.113 +(* ----------------------------------------------------------------------- *)
  63.114 +(* definition of bisimulation is determined by domain equation             *)
  63.115 +(* simplification and rewriting for abstract constants yields def below    *)
  63.116 +
  63.117 +dlist_bisim_def "dlist_bisim ==
  63.118 + ( %R.!l1 l2.
  63.119 + 	R l1 l2 -->
  63.120 +  ((l1=UU & l2=UU) |
  63.121 +   (l1=dnil & l2=dnil) |
  63.122 +   (? x l11 l21. x~=UU & l11~=UU & l21~=UU & 
  63.123 +               l1=dcons`x`l11 & l2 = dcons`x`l21 & R l11 l21)))"
  63.124 +
  63.125 +end
  63.126 +
  63.127 +
  63.128 +
  63.129 +
    64.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    64.2 +++ b/src/HOLCF/explicit_domains/Dnat.ML	Fri Oct 06 17:25:24 1995 +0100
    64.3 @@ -0,0 +1,534 @@
    64.4 +(*  Title: 	HOLCF/Dnat.ML
    64.5 +    ID:         $Id$
    64.6 +    Author: 	Franz Regensburger
    64.7 +    Copyright   1993 Technische Universitaet Muenchen
    64.8 +
    64.9 +Lemmas for dnat.thy 
   64.10 +*)
   64.11 +
   64.12 +open Dnat;
   64.13 +
   64.14 +(* ------------------------------------------------------------------------*)
   64.15 +(* The isomorphisms dnat_rep_iso and dnat_abs_iso are strict               *)
   64.16 +(* ------------------------------------------------------------------------*)
   64.17 +
   64.18 +val dnat_iso_strict = dnat_rep_iso RS (dnat_abs_iso RS 
   64.19 +	(allI  RSN (2,allI RS iso_strict)));
   64.20 +
   64.21 +val dnat_rews = [dnat_iso_strict RS conjunct1,
   64.22 +		dnat_iso_strict RS conjunct2];
   64.23 +
   64.24 +(* ------------------------------------------------------------------------*)
   64.25 +(* Properties of dnat_copy                                                 *)
   64.26 +(* ------------------------------------------------------------------------*)
   64.27 +
   64.28 +fun prover defs thm =  prove_goalw Dnat.thy defs thm
   64.29 + (fn prems =>
   64.30 +	[
   64.31 +	(cut_facts_tac prems 1),
   64.32 +	(asm_simp_tac (!simpset addsimps 
   64.33 +		(dnat_rews @ [dnat_abs_iso,dnat_rep_iso])) 1)
   64.34 +	]);
   64.35 +
   64.36 +val dnat_copy = 
   64.37 +	[
   64.38 +	prover [dnat_copy_def] "dnat_copy`f`UU=UU",
   64.39 +	prover [dnat_copy_def,dzero_def] "dnat_copy`f`dzero= dzero",
   64.40 +	prover [dnat_copy_def,dsucc_def] 
   64.41 +		"n~=UU ==> dnat_copy`f`(dsucc`n) = dsucc`(f`n)"
   64.42 +	];
   64.43 +
   64.44 +val dnat_rews =  dnat_copy @ dnat_rews; 
   64.45 +
   64.46 +(* ------------------------------------------------------------------------*)
   64.47 +(* Exhaustion and elimination for dnat                                     *)
   64.48 +(* ------------------------------------------------------------------------*)
   64.49 +
   64.50 +qed_goalw "Exh_dnat" Dnat.thy [dsucc_def,dzero_def]
   64.51 +	"n = UU | n = dzero | (? x . x~=UU & n = dsucc`x)"
   64.52 + (fn prems =>
   64.53 +	[
   64.54 +	(Simp_tac  1),
   64.55 +	(rtac (dnat_rep_iso RS subst) 1),
   64.56 +	(res_inst_tac [("p","dnat_rep`n")] ssumE 1),
   64.57 +	(rtac disjI1 1),
   64.58 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   64.59 +	(rtac (disjI1 RS disjI2) 1),
   64.60 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   64.61 +	(res_inst_tac [("p","x")] oneE 1),
   64.62 +	(contr_tac 1),
   64.63 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   64.64 +	(rtac (disjI2 RS disjI2) 1),
   64.65 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   64.66 +	(fast_tac HOL_cs 1)
   64.67 +	]);
   64.68 +
   64.69 +qed_goal "dnatE" Dnat.thy 
   64.70 + "[| n=UU ==> Q; n=dzero ==> Q; !!x.[|n=dsucc`x;x~=UU|]==>Q|]==>Q"
   64.71 + (fn prems =>
   64.72 +	[
   64.73 +	(rtac (Exh_dnat RS disjE) 1),
   64.74 +	(eresolve_tac prems 1),
   64.75 +	(etac disjE 1),
   64.76 +	(eresolve_tac prems 1),
   64.77 +	(REPEAT (etac exE 1)),
   64.78 +	(resolve_tac prems 1),
   64.79 +	(fast_tac HOL_cs 1),
   64.80 +	(fast_tac HOL_cs 1)
   64.81 +	]);
   64.82 +
   64.83 +(* ------------------------------------------------------------------------*)
   64.84 +(* Properties of dnat_when                                                 *)
   64.85 +(* ------------------------------------------------------------------------*)
   64.86 +
   64.87 +fun prover defs thm =  prove_goalw Dnat.thy defs thm
   64.88 + (fn prems =>
   64.89 +	[
   64.90 +	(cut_facts_tac prems 1),
   64.91 +	(asm_simp_tac (!simpset addsimps 
   64.92 +		(dnat_rews @ [dnat_abs_iso,dnat_rep_iso])) 1)
   64.93 +	]);
   64.94 +
   64.95 +
   64.96 +val dnat_when = [
   64.97 +	prover [dnat_when_def] "dnat_when`c`f`UU=UU",
   64.98 +	prover [dnat_when_def,dzero_def] "dnat_when`c`f`dzero=c",
   64.99 +	prover [dnat_when_def,dsucc_def] 
  64.100 +		"n~=UU ==> dnat_when`c`f`(dsucc`n)=f`n"
  64.101 +	];
  64.102 +
  64.103 +val dnat_rews = dnat_when @ dnat_rews;
  64.104 +
  64.105 +(* ------------------------------------------------------------------------*)
  64.106 +(* Rewrites for  discriminators and  selectors                             *)
  64.107 +(* ------------------------------------------------------------------------*)
  64.108 +
  64.109 +fun prover defs thm = prove_goalw Dnat.thy defs thm
  64.110 + (fn prems =>
  64.111 +	[
  64.112 +	(simp_tac (!simpset addsimps dnat_rews) 1)
  64.113 +	]);
  64.114 +
  64.115 +val dnat_discsel = [
  64.116 +	prover [is_dzero_def] "is_dzero`UU=UU",
  64.117 +	prover [is_dsucc_def] "is_dsucc`UU=UU",
  64.118 +	prover [dpred_def] "dpred`UU=UU"
  64.119 +	];
  64.120 +
  64.121 +
  64.122 +fun prover defs thm = prove_goalw Dnat.thy defs thm
  64.123 + (fn prems =>
  64.124 +	[
  64.125 +	(cut_facts_tac prems 1),
  64.126 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
  64.127 +	]);
  64.128 +
  64.129 +val dnat_discsel = [
  64.130 +	prover [is_dzero_def] "is_dzero`dzero=TT",
  64.131 +	prover [is_dzero_def] "n~=UU ==>is_dzero`(dsucc`n)=FF",
  64.132 +	prover [is_dsucc_def] "is_dsucc`dzero=FF",
  64.133 +	prover [is_dsucc_def] "n~=UU ==> is_dsucc`(dsucc`n)=TT",
  64.134 +	prover [dpred_def] "dpred`dzero=UU",
  64.135 +	prover [dpred_def] "n~=UU ==> dpred`(dsucc`n)=n"
  64.136 +	] @ dnat_discsel;
  64.137 +
  64.138 +val dnat_rews = dnat_discsel @ dnat_rews;
  64.139 +
  64.140 +(* ------------------------------------------------------------------------*)
  64.141 +(* Definedness and strictness                                              *)
  64.142 +(* ------------------------------------------------------------------------*)
  64.143 +
  64.144 +fun prover contr thm = prove_goal Dnat.thy thm
  64.145 + (fn prems =>
  64.146 +	[
  64.147 +	(res_inst_tac [("P1",contr)] classical3 1),
  64.148 +	(simp_tac (!simpset addsimps dnat_rews) 1),
  64.149 +	(dtac sym 1),
  64.150 +	(Asm_simp_tac  1),
  64.151 +	(simp_tac (!simpset addsimps (prems @ dnat_rews)) 1)
  64.152 +	]);
  64.153 +
  64.154 +val dnat_constrdef = [
  64.155 +	prover "is_dzero`UU ~= UU" "dzero~=UU",
  64.156 +	prover "is_dsucc`UU ~= UU" "n~=UU ==> dsucc`n~=UU"
  64.157 +	]; 
  64.158 +
  64.159 +
  64.160 +fun prover defs thm = prove_goalw Dnat.thy defs thm
  64.161 + (fn prems =>
  64.162 +	[
  64.163 +	(simp_tac (!simpset addsimps dnat_rews) 1)
  64.164 +	]);
  64.165 +
  64.166 +val dnat_constrdef = [
  64.167 +	prover [dsucc_def] "dsucc`UU=UU"
  64.168 +	] @ dnat_constrdef;
  64.169 +
  64.170 +val dnat_rews = dnat_constrdef @ dnat_rews;
  64.171 +
  64.172 +
  64.173 +(* ------------------------------------------------------------------------*)
  64.174 +(* Distinctness wrt. << and =                                              *)
  64.175 +(* ------------------------------------------------------------------------*)
  64.176 +
  64.177 +val temp = prove_goal Dnat.thy  "~dzero << dsucc`n"
  64.178 + (fn prems =>
  64.179 +	[
  64.180 +	(res_inst_tac [("P1","TT << FF")] classical3 1),
  64.181 +	(resolve_tac dist_less_tr 1),
  64.182 +	(dres_inst_tac [("fo5","is_dzero")] monofun_cfun_arg 1),
  64.183 +	(etac box_less 1),
  64.184 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.185 +	(res_inst_tac [("Q","n=UU")] classical2 1),
  64.186 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.187 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
  64.188 +	]);
  64.189 +
  64.190 +val dnat_dist_less = [temp];
  64.191 +
  64.192 +val temp = prove_goal Dnat.thy  "n~=UU ==> ~dsucc`n << dzero"
  64.193 + (fn prems =>
  64.194 +	[
  64.195 +	(cut_facts_tac prems 1),
  64.196 +	(res_inst_tac [("P1","TT << FF")] classical3 1),
  64.197 +	(resolve_tac dist_less_tr 1),
  64.198 +	(dres_inst_tac [("fo5","is_dsucc")] monofun_cfun_arg 1),
  64.199 +	(etac box_less 1),
  64.200 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.201 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
  64.202 +	]);
  64.203 +
  64.204 +val dnat_dist_less = temp::dnat_dist_less;
  64.205 +
  64.206 +val temp = prove_goal Dnat.thy   "dzero ~= dsucc`n"
  64.207 + (fn prems =>
  64.208 +	[
  64.209 +	(res_inst_tac [("Q","n=UU")] classical2 1),
  64.210 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.211 +	(res_inst_tac [("P1","TT = FF")] classical3 1),
  64.212 +	(resolve_tac dist_eq_tr 1),
  64.213 +	(dres_inst_tac [("f","is_dzero")] cfun_arg_cong 1),
  64.214 +	(etac box_equals 1),
  64.215 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.216 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
  64.217 +	]);
  64.218 +
  64.219 +val dnat_dist_eq = [temp, temp RS not_sym];
  64.220 +
  64.221 +val dnat_rews = dnat_dist_less @ dnat_dist_eq @ dnat_rews;
  64.222 +
  64.223 +(* ------------------------------------------------------------------------*)
  64.224 +(* Invertibility                                                           *)
  64.225 +(* ------------------------------------------------------------------------*)
  64.226 +
  64.227 +val dnat_invert = 
  64.228 +	[
  64.229 +prove_goal Dnat.thy 
  64.230 +"[|x1~=UU; y1~=UU; dsucc`x1 << dsucc`y1 |] ==> x1<< y1"
  64.231 + (fn prems =>
  64.232 +	[
  64.233 +	(cut_facts_tac prems 1),
  64.234 +	(dres_inst_tac [("fo5","dnat_when`c`(LAM x.x)")] monofun_cfun_arg 1),
  64.235 +	(etac box_less 1),
  64.236 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.237 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
  64.238 +	])
  64.239 +	];
  64.240 +
  64.241 +(* ------------------------------------------------------------------------*)
  64.242 +(* Injectivity                                                             *)
  64.243 +(* ------------------------------------------------------------------------*)
  64.244 +
  64.245 +val dnat_inject = 
  64.246 +	[
  64.247 +prove_goal Dnat.thy 
  64.248 +"[|x1~=UU; y1~=UU; dsucc`x1 = dsucc`y1 |] ==> x1= y1"
  64.249 + (fn prems =>
  64.250 +	[
  64.251 +	(cut_facts_tac prems 1),
  64.252 +	(dres_inst_tac [("f","dnat_when`c`(LAM x.x)")] cfun_arg_cong 1),
  64.253 +	(etac box_equals 1),
  64.254 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.255 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
  64.256 +	])
  64.257 +	];
  64.258 +
  64.259 +(* ------------------------------------------------------------------------*)
  64.260 +(* definedness for  discriminators and  selectors                          *)
  64.261 +(* ------------------------------------------------------------------------*)
  64.262 +
  64.263 +
  64.264 +fun prover thm = prove_goal Dnat.thy thm
  64.265 + (fn prems =>
  64.266 +	[
  64.267 +	(cut_facts_tac prems 1),
  64.268 +	(rtac dnatE 1),
  64.269 +	(contr_tac 1),
  64.270 +	(REPEAT (asm_simp_tac (!simpset addsimps dnat_rews) 1))
  64.271 +	]);
  64.272 +
  64.273 +val dnat_discsel_def = 
  64.274 +	[
  64.275 +	prover  "n~=UU ==> is_dzero`n ~= UU",
  64.276 +	prover  "n~=UU ==> is_dsucc`n ~= UU"
  64.277 +	];
  64.278 +
  64.279 +val dnat_rews = dnat_discsel_def @ dnat_rews;
  64.280 +
  64.281 + 
  64.282 +(* ------------------------------------------------------------------------*)
  64.283 +(* Properties dnat_take                                                    *)
  64.284 +(* ------------------------------------------------------------------------*)
  64.285 +val temp = prove_goalw Dnat.thy [dnat_take_def] "dnat_take n`UU = UU"
  64.286 + (fn prems =>
  64.287 +	[
  64.288 +	(res_inst_tac [("n","n")] natE 1),
  64.289 +	(Asm_simp_tac 1),
  64.290 +	(Asm_simp_tac 1),
  64.291 +	(simp_tac (!simpset addsimps dnat_rews) 1)
  64.292 +	]);
  64.293 +
  64.294 +val dnat_take = [temp];
  64.295 +
  64.296 +val temp = prove_goalw Dnat.thy [dnat_take_def] "dnat_take 0`xs = UU"
  64.297 + (fn prems =>
  64.298 +	[
  64.299 +	(Asm_simp_tac 1)
  64.300 +	]);
  64.301 +
  64.302 +val dnat_take = temp::dnat_take;
  64.303 +
  64.304 +val temp = prove_goalw Dnat.thy [dnat_take_def]
  64.305 +	"dnat_take (Suc n)`dzero=dzero"
  64.306 + (fn prems =>
  64.307 +	[
  64.308 +	(Asm_simp_tac 1),
  64.309 +	(simp_tac (!simpset addsimps dnat_rews) 1)
  64.310 +	]);
  64.311 +
  64.312 +val dnat_take = temp::dnat_take;
  64.313 +
  64.314 +val temp = prove_goalw Dnat.thy [dnat_take_def]
  64.315 +  "dnat_take (Suc n)`(dsucc`xs)=dsucc`(dnat_take n ` xs)"
  64.316 + (fn prems =>
  64.317 +	[
  64.318 +	(res_inst_tac [("Q","xs=UU")] classical2 1),
  64.319 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.320 +	(Asm_simp_tac 1),
  64.321 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.322 +	(res_inst_tac [("n","n")] natE 1),
  64.323 +	(Asm_simp_tac 1),
  64.324 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.325 +	(Asm_simp_tac 1),
  64.326 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.327 +	(Asm_simp_tac 1),
  64.328 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
  64.329 +	]);
  64.330 +
  64.331 +val dnat_take = temp::dnat_take;
  64.332 +
  64.333 +val dnat_rews = dnat_take @ dnat_rews;
  64.334 +
  64.335 +
  64.336 +(* ------------------------------------------------------------------------*)
  64.337 +(* take lemma for dnats                                                  *)
  64.338 +(* ------------------------------------------------------------------------*)
  64.339 +
  64.340 +fun prover reach defs thm  = prove_goalw Dnat.thy defs thm
  64.341 + (fn prems =>
  64.342 +	[
  64.343 +	(res_inst_tac [("t","s1")] (reach RS subst) 1),
  64.344 +	(res_inst_tac [("t","s2")] (reach RS subst) 1),
  64.345 +	(rtac (fix_def2 RS ssubst) 1),
  64.346 +	(rtac (contlub_cfun_fun RS ssubst) 1),
  64.347 +	(rtac is_chain_iterate 1),
  64.348 +	(rtac (contlub_cfun_fun RS ssubst) 1),
  64.349 +	(rtac is_chain_iterate 1),
  64.350 +	(rtac lub_equal 1),
  64.351 +	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
  64.352 +	(rtac (is_chain_iterate RS ch2ch_fappL) 1),
  64.353 +	(rtac allI 1),
  64.354 +	(resolve_tac prems 1)
  64.355 +	]);
  64.356 +
  64.357 +val dnat_take_lemma = prover dnat_reach  [dnat_take_def]
  64.358 +	"(!!n.dnat_take n`s1 = dnat_take n`s2) ==> s1=s2";
  64.359 +
  64.360 +
  64.361 +(* ------------------------------------------------------------------------*)
  64.362 +(* Co -induction for dnats                                                 *)
  64.363 +(* ------------------------------------------------------------------------*)
  64.364 +
  64.365 +qed_goalw "dnat_coind_lemma" Dnat.thy [dnat_bisim_def] 
  64.366 +"dnat_bisim R ==> ! p q. R p q --> dnat_take n`p = dnat_take n`q"
  64.367 + (fn prems =>
  64.368 +	[
  64.369 +	(cut_facts_tac prems 1),
  64.370 +	(nat_ind_tac "n" 1),
  64.371 +	(simp_tac (!simpset addsimps dnat_take) 1),
  64.372 +	(strip_tac 1),
  64.373 +	((etac allE 1) THEN (etac allE 1) THEN (etac (mp RS disjE) 1)),
  64.374 +	(atac 1),
  64.375 +	(asm_simp_tac (!simpset addsimps dnat_take) 1),
  64.376 +	(etac disjE 1),
  64.377 +	(asm_simp_tac (!simpset addsimps dnat_take) 1),
  64.378 +	(etac exE 1),
  64.379 +	(etac exE 1),
  64.380 +	(asm_simp_tac (!simpset addsimps dnat_take) 1),
  64.381 +	(REPEAT (etac conjE 1)),
  64.382 +	(rtac cfun_arg_cong 1),
  64.383 +	(fast_tac HOL_cs 1)
  64.384 +	]);
  64.385 +
  64.386 +qed_goal "dnat_coind" Dnat.thy "[|dnat_bisim R;R p q|] ==> p = q"
  64.387 + (fn prems =>
  64.388 +	[
  64.389 +	(rtac dnat_take_lemma 1),
  64.390 +	(rtac (dnat_coind_lemma RS spec RS spec RS mp) 1),
  64.391 +	(resolve_tac prems 1),
  64.392 +	(resolve_tac prems 1)
  64.393 +	]);
  64.394 +
  64.395 +
  64.396 +(* ------------------------------------------------------------------------*)
  64.397 +(* structural induction for admissible predicates                          *)
  64.398 +(* ------------------------------------------------------------------------*)
  64.399 +
  64.400 +(* not needed any longer
  64.401 +qed_goal "dnat_ind" Dnat.thy
  64.402 +"[| adm(P);\
  64.403 +\   P(UU);\
  64.404 +\   P(dzero);\
  64.405 +\   !! s1.[|s1~=UU ; P(s1)|] ==> P(dsucc`s1)|] ==> P(s)"
  64.406 + (fn prems =>
  64.407 +	[
  64.408 +	(rtac (dnat_reach RS subst) 1),
  64.409 +	(res_inst_tac [("x","s")] spec 1),
  64.410 +	(rtac fix_ind 1),
  64.411 +	(rtac adm_all2 1),
  64.412 +	(rtac adm_subst 1),
  64.413 +	(cont_tacR 1),
  64.414 +	(resolve_tac prems 1),
  64.415 +	(Simp_tac 1),
  64.416 +	(resolve_tac prems 1),
  64.417 +	(strip_tac 1),
  64.418 +	(res_inst_tac [("n","xa")] dnatE 1),
  64.419 +	(asm_simp_tac (!simpset addsimps dnat_copy) 1),
  64.420 +	(resolve_tac prems 1),
  64.421 +	(asm_simp_tac (!simpset addsimps dnat_copy) 1),
  64.422 +	(resolve_tac prems 1),
  64.423 +	(asm_simp_tac (!simpset addsimps dnat_copy) 1),
  64.424 +	(res_inst_tac [("Q","x`xb=UU")] classical2 1),
  64.425 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.426 +	(resolve_tac prems 1),
  64.427 +	(eresolve_tac prems 1),
  64.428 +	(etac spec 1)
  64.429 +	]);
  64.430 +*)
  64.431 +
  64.432 +qed_goal "dnat_finite_ind" Dnat.thy
  64.433 +"[|P(UU);P(dzero);\
  64.434 +\  !! s1.[|s1~=UU;P(s1)|] ==> P(dsucc`s1)\
  64.435 +\  |] ==> !s.P(dnat_take n`s)"
  64.436 + (fn prems =>
  64.437 +	[
  64.438 +	(nat_ind_tac "n" 1),
  64.439 +	(simp_tac (!simpset addsimps dnat_rews) 1),
  64.440 +	(resolve_tac prems 1),
  64.441 +	(rtac allI 1),
  64.442 +	(res_inst_tac [("n","s")] dnatE 1),
  64.443 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.444 +	(resolve_tac prems 1),
  64.445 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.446 +	(resolve_tac prems 1),
  64.447 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.448 +	(res_inst_tac [("Q","dnat_take n1`x=UU")] classical2 1),
  64.449 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.450 +	(resolve_tac prems 1),
  64.451 +	(resolve_tac prems 1),
  64.452 +	(atac 1),
  64.453 +	(etac spec 1)
  64.454 +	]);
  64.455 +
  64.456 +qed_goal "dnat_all_finite_lemma1" Dnat.thy
  64.457 +"!s.dnat_take n`s=UU |dnat_take n`s=s"
  64.458 + (fn prems =>
  64.459 +	[
  64.460 +	(nat_ind_tac "n" 1),
  64.461 +	(simp_tac (!simpset addsimps dnat_rews) 1),
  64.462 +	(rtac allI 1),
  64.463 +	(res_inst_tac [("n","s")] dnatE 1),
  64.464 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.465 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.466 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.467 +	(eres_inst_tac [("x","x")] allE 1),
  64.468 +	(etac disjE 1),
  64.469 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.470 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1)
  64.471 +	]);
  64.472 +
  64.473 +qed_goal "dnat_all_finite_lemma2" Dnat.thy "? n.dnat_take n`s=s"
  64.474 + (fn prems =>
  64.475 +	[
  64.476 +	(res_inst_tac [("Q","s=UU")] classical2 1),
  64.477 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.478 +	(subgoal_tac "(!n.dnat_take(n)`s=UU) |(? n.dnat_take(n)`s=s)" 1),
  64.479 +	(etac disjE 1),
  64.480 +	(eres_inst_tac [("P","s=UU")] notE 1),
  64.481 +	(rtac dnat_take_lemma 1),
  64.482 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.483 +	(atac 1),
  64.484 +	(subgoal_tac "!n.!s.dnat_take(n)`s=UU |dnat_take(n)`s=s" 1),
  64.485 +	(fast_tac HOL_cs 1),
  64.486 +	(rtac allI 1),
  64.487 +	(rtac dnat_all_finite_lemma1 1)
  64.488 +	]);
  64.489 +
  64.490 +
  64.491 +qed_goal "dnat_ind" Dnat.thy
  64.492 +"[|P(UU);P(dzero);\
  64.493 +\  !! s1.[|s1~=UU;P(s1)|] ==> P(dsucc`s1)\
  64.494 +\  |] ==> P(s)"
  64.495 + (fn prems =>
  64.496 +	[
  64.497 +	(rtac (dnat_all_finite_lemma2 RS exE) 1),
  64.498 +	(etac subst 1),
  64.499 +	(rtac (dnat_finite_ind RS spec) 1),
  64.500 +	(REPEAT (resolve_tac prems 1)),
  64.501 +	(REPEAT (atac 1))
  64.502 +	]);
  64.503 +
  64.504 +
  64.505 +qed_goalw "dnat_flat" Dnat.thy [flat_def] "flat(dzero)"
  64.506 + (fn prems =>
  64.507 +	[
  64.508 +	(rtac allI 1),
  64.509 +	(res_inst_tac [("s","x")] dnat_ind 1),
  64.510 +	(fast_tac HOL_cs 1),
  64.511 +	(rtac allI 1),
  64.512 +	(res_inst_tac [("n","y")] dnatE 1),
  64.513 +	(fast_tac (HOL_cs addSIs [UU_I]) 1),
  64.514 +	(Asm_simp_tac 1),
  64.515 +	(asm_simp_tac (!simpset addsimps dnat_dist_less) 1),
  64.516 +	(rtac allI 1),
  64.517 +	(res_inst_tac [("n","y")] dnatE 1),
  64.518 +	(fast_tac (HOL_cs addSIs [UU_I]) 1),
  64.519 +	(asm_simp_tac (!simpset addsimps dnat_dist_less) 1),
  64.520 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
  64.521 +	(strip_tac 1),
  64.522 +	(subgoal_tac "s1<<xa" 1),
  64.523 +	(etac allE 1),
  64.524 +	(dtac mp 1),
  64.525 +	(atac 1),
  64.526 +	(etac disjE 1),
  64.527 +	(contr_tac 1),
  64.528 +	(Asm_simp_tac 1),
  64.529 +	(resolve_tac  dnat_invert 1),
  64.530 +	(REPEAT (atac 1))
  64.531 +	]);
  64.532 +
  64.533 +
  64.534 +
  64.535 +
  64.536 +
  64.537 +
    65.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    65.2 +++ b/src/HOLCF/explicit_domains/Dnat.thy	Fri Oct 06 17:25:24 1995 +0100
    65.3 @@ -0,0 +1,110 @@
    65.4 +(*  Title: 	HOLCF/Dnat.thy
    65.5 +    ID:         $Id$
    65.6 +    Author: 	Franz Regensburger
    65.7 +    Copyright   1993 Technische Universitaet Muenchen
    65.8 +
    65.9 +Theory for the domain of natural numbers  dnat = one ++ dnat
   65.10 +
   65.11 +The type is axiomatized as the least solution of the domain equation above.
   65.12 +The functor term that specifies the domain equation is: 
   65.13 +
   65.14 +  FT = <++,K_{one},I>
   65.15 +
   65.16 +For details see chapter 5 of:
   65.17 +
   65.18 +[Franz Regensburger] HOLCF: Eine konservative Erweiterung von HOL um LCF,
   65.19 +                     Dissertation, Technische Universit"at M"unchen, 1994
   65.20 +
   65.21 +*)
   65.22 +
   65.23 +Dnat = HOLCF +
   65.24 +
   65.25 +types dnat 0
   65.26 +
   65.27 +(* ----------------------------------------------------------------------- *)
   65.28 +(* arrity axiom is valuated by semantical reasoning                        *)
   65.29 +
   65.30 +arities dnat::pcpo
   65.31 +
   65.32 +consts
   65.33 +
   65.34 +(* ----------------------------------------------------------------------- *)
   65.35 +(* essential constants                                                     *)
   65.36 +
   65.37 +dnat_rep	:: " dnat -> (one ++ dnat)"
   65.38 +dnat_abs	:: "(one ++ dnat) -> dnat"
   65.39 +
   65.40 +(* ----------------------------------------------------------------------- *)
   65.41 +(* abstract constants and auxiliary constants                              *)
   65.42 +
   65.43 +dnat_copy	:: "(dnat -> dnat) -> dnat -> dnat"
   65.44 +
   65.45 +dzero		:: "dnat"
   65.46 +dsucc		:: "dnat -> dnat"
   65.47 +dnat_when	:: "'b -> (dnat -> 'b) -> dnat -> 'b"
   65.48 +is_dzero	:: "dnat -> tr"
   65.49 +is_dsucc	:: "dnat -> tr"
   65.50 +dpred		:: "dnat -> dnat"
   65.51 +dnat_take	:: "nat => dnat -> dnat"
   65.52 +dnat_bisim	:: "(dnat => dnat => bool) => bool"
   65.53 +
   65.54 +rules
   65.55 +
   65.56 +(* ----------------------------------------------------------------------- *)
   65.57 +(* axiomatization of recursive type dnat                                   *)
   65.58 +(* ----------------------------------------------------------------------- *)
   65.59 +(* (dnat,dnat_abs) is the initial F-algebra where                          *)
   65.60 +(* F is the locally continuous functor determined by functor term FT.      *)
   65.61 +(* domain equation: dnat = one ++ dnat                                     *)
   65.62 +(* functor term:    FT = <++,K_{one},I>                                    *) 
   65.63 +(* ----------------------------------------------------------------------- *)
   65.64 +(* dnat_abs is an isomorphism with inverse dnat_rep                        *)
   65.65 +(* identity is the least endomorphism on dnat                              *)
   65.66 +
   65.67 +dnat_abs_iso	"dnat_rep`(dnat_abs`x) = x"
   65.68 +dnat_rep_iso	"dnat_abs`(dnat_rep`x) = x"
   65.69 +dnat_copy_def	"dnat_copy == (LAM f. dnat_abs oo 
   65.70 +		 (sswhen`sinl`(sinr oo f)) oo dnat_rep )"
   65.71 +dnat_reach	"(fix`dnat_copy)`x=x"
   65.72 +
   65.73 +
   65.74 +defs
   65.75 +(* ----------------------------------------------------------------------- *)
   65.76 +(* properties of additional constants                                      *)
   65.77 +(* ----------------------------------------------------------------------- *)
   65.78 +(* constructors                                                            *)
   65.79 +
   65.80 +dzero_def	"dzero == dnat_abs`(sinl`one)"
   65.81 +dsucc_def	"dsucc == (LAM n. dnat_abs`(sinr`n))"
   65.82 +
   65.83 +(* ----------------------------------------------------------------------- *)
   65.84 +(* discriminator functional                                                *)
   65.85 +
   65.86 +dnat_when_def	"dnat_when == (LAM f1 f2 n.sswhen`(LAM x.f1)`f2`(dnat_rep`n))"
   65.87 +
   65.88 +
   65.89 +(* ----------------------------------------------------------------------- *)
   65.90 +(* discriminators and selectors                                            *)
   65.91 +
   65.92 +is_dzero_def	"is_dzero == dnat_when`TT`(LAM x.FF)"
   65.93 +is_dsucc_def	"is_dsucc == dnat_when`FF`(LAM x.TT)"
   65.94 +dpred_def	"dpred == dnat_when`UU`(LAM x.x)"
   65.95 +
   65.96 +
   65.97 +(* ----------------------------------------------------------------------- *)
   65.98 +(* the taker for dnats                                                   *)
   65.99 +
  65.100 +dnat_take_def "dnat_take == (%n.iterate n dnat_copy UU)"
  65.101 +
  65.102 +(* ----------------------------------------------------------------------- *)
  65.103 +(* definition of bisimulation is determined by domain equation             *)
  65.104 +(* simplification and rewriting for abstract constants yields def below    *)
  65.105 +
  65.106 +dnat_bisim_def "dnat_bisim ==
  65.107 +(%R.!s1 s2.
  65.108 + 	R s1 s2 -->
  65.109 +  ((s1=UU & s2=UU) |(s1=dzero & s2=dzero) |
  65.110 +  (? s11 s21. s11~=UU & s21~=UU & s1=dsucc`s11 &
  65.111 +		 s2 = dsucc`s21 & R s11 s21)))"
  65.112 +
  65.113 +end
    66.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    66.2 +++ b/src/HOLCF/explicit_domains/Dnat2.ML	Fri Oct 06 17:25:24 1995 +0100
    66.3 @@ -0,0 +1,52 @@
    66.4 +(*  Title: 	HOLCF/Dnat2.ML
    66.5 +    ID:         $Id$
    66.6 +    Author: 	Franz Regensburger
    66.7 +    Copyright   1993 Technische Universitaet Muenchen
    66.8 +
    66.9 +Lemmas for theory Dnat2.thy
   66.10 +*)
   66.11 +
   66.12 +open Dnat2;
   66.13 +
   66.14 +
   66.15 +(* ------------------------------------------------------------------------- *)
   66.16 +(* expand fixed point properties                                             *)
   66.17 +(* ------------------------------------------------------------------------- *)
   66.18 +
   66.19 +val iterator_def2 = fix_prover2 Dnat2.thy iterator_def 
   66.20 +	"iterator = (LAM n f x. dnat_when`x`(LAM m.f`(iterator`m`f`x)) `n)";
   66.21 +
   66.22 +(* ------------------------------------------------------------------------- *)
   66.23 +(* recursive  properties                                                     *)
   66.24 +(* ------------------------------------------------------------------------- *)
   66.25 +
   66.26 +qed_goal "iterator1" Dnat2.thy "iterator`UU`f`x = UU"
   66.27 + (fn prems =>
   66.28 +	[
   66.29 +	(rtac (iterator_def2 RS ssubst) 1),
   66.30 +	(simp_tac (!simpset addsimps dnat_when) 1)
   66.31 +	]);
   66.32 +
   66.33 +qed_goal "iterator2" Dnat2.thy "iterator`dzero`f`x = x"
   66.34 + (fn prems =>
   66.35 +	[
   66.36 +	(rtac (iterator_def2 RS ssubst) 1),
   66.37 +	(simp_tac (!simpset addsimps dnat_when) 1)
   66.38 +	]);
   66.39 +
   66.40 +qed_goal "iterator3" Dnat2.thy 
   66.41 +"n~=UU ==> iterator`(dsucc`n)`f`x = f`(iterator`n`f`x)"
   66.42 + (fn prems =>
   66.43 +	[
   66.44 +	(cut_facts_tac prems 1),
   66.45 +	(rtac trans 1),
   66.46 +	(rtac (iterator_def2 RS ssubst) 1),
   66.47 +	(asm_simp_tac (!simpset addsimps dnat_rews) 1),
   66.48 +	(rtac refl 1)
   66.49 +	]);
   66.50 +
   66.51 +val dnat2_rews = 
   66.52 +	[iterator1, iterator2, iterator3];
   66.53 +
   66.54 +
   66.55 +
    67.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    67.2 +++ b/src/HOLCF/explicit_domains/Dnat2.thy	Fri Oct 06 17:25:24 1995 +0100
    67.3 @@ -0,0 +1,29 @@
    67.4 +(*  Title: 	HOLCF/Dnat2.thy
    67.5 +    ID:         $Id$
    67.6 +    Author: 	Franz Regensburger
    67.7 +    Copyright   1993 Technische Universitaet Muenchen
    67.8 +
    67.9 +Additional constants for dnat
   67.10 +
   67.11 +*)
   67.12 +
   67.13 +Dnat2 = Dnat +
   67.14 +
   67.15 +consts
   67.16 +
   67.17 +iterator	:: "dnat -> ('a -> 'a) -> 'a -> 'a"
   67.18 +
   67.19 +
   67.20 +defs
   67.21 +
   67.22 +iterator_def	"iterator == fix`(LAM h n f x.
   67.23 +			dnat_when `x `(LAM m.f`(h`m`f`x)) `n)"
   67.24 +end
   67.25 +
   67.26 +(*
   67.27 +
   67.28 +		iterator`UU`f`x = UU
   67.29 +		iterator`dzero`f`x = x
   67.30 +      n~=UU --> iterator`(dsucc`n)`f`x = f`(iterator`n`f`x)
   67.31 +*)
   67.32 +
    68.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    68.2 +++ b/src/HOLCF/explicit_domains/Focus_ex.ML	Fri Oct 06 17:25:24 1995 +0100
    68.3 @@ -0,0 +1,151 @@
    68.4 +(*
    68.5 +    ID:         $Id$
    68.6 +    Author: 	Franz Regensburger
    68.7 +    Copyright   1995 Technische Universitaet Muenchen
    68.8 +
    68.9 +*)
   68.10 +
   68.11 +open Focus_ex;
   68.12 +
   68.13 +(* first some logical trading *)
   68.14 +
   68.15 +val prems = goal Focus_ex.thy
   68.16 +"is_g(g) = \ 
   68.17 +\ (? f. is_f(f) & (!x.(? z. <g`x,z> = f`<x,z> & \
   68.18 +\	     (! w y. <y,w> = f`<x,w>  --> z << w))))";
   68.19 +by (simp_tac (!simpset addsimps [is_g,is_net_g]) 1);
   68.20 +by (fast_tac HOL_cs 1);
   68.21 +val lemma1 = result();
   68.22 +
   68.23 +val prems = goal Focus_ex.thy
   68.24 +"(? f. is_f(f) & (!x. (? z. <g`x,z> = f`<x,z> & \
   68.25 +\ 		     (! w y. <y,w> = f`<x,w>  --> z << w)))) \
   68.26 +\ = \ 
   68.27 +\ (? f. is_f(f) & (!x. ? z.\
   68.28 +\       g`x = cfst`(f`<x,z>) & \
   68.29 +\         z = csnd`(f`<x,z>) & \
   68.30 +\	(! w y.  <y,w> = f`<x,w> --> z << w)))";
   68.31 +by (rtac iffI 1);
   68.32 +by (etac exE 1);
   68.33 +by (res_inst_tac [("x","f")] exI 1);
   68.34 +by (REPEAT (etac conjE 1));
   68.35 +by (etac conjI 1);
   68.36 +by (strip_tac 1);
   68.37 +by (etac allE 1);
   68.38 +by (etac exE 1);
   68.39 +by (res_inst_tac [("x","z")] exI 1);
   68.40 +by (REPEAT (etac conjE 1));
   68.41 +by (rtac conjI 1);
   68.42 +by (rtac conjI 2);
   68.43 +by (atac 3);
   68.44 +by (dtac sym 1);
   68.45 +by (Asm_simp_tac 1);
   68.46 +by (dtac sym 1);
   68.47 +by (Asm_simp_tac 1);
   68.48 +by (etac exE 1);
   68.49 +by (res_inst_tac [("x","f")] exI 1);
   68.50 +by (REPEAT (etac conjE 1));
   68.51 +by (etac conjI 1);
   68.52 +by (strip_tac 1);
   68.53 +by (etac allE 1);
   68.54 +by (etac exE 1);
   68.55 +by (res_inst_tac [("x","z")] exI 1);
   68.56 +by (REPEAT (etac conjE 1));
   68.57 +by (rtac conjI 1);
   68.58 +by (atac 2);
   68.59 +by (rtac trans 1);
   68.60 +by (rtac (surjective_pairing_Cprod2) 2);
   68.61 +by (etac subst 1);
   68.62 +by (etac subst 1);
   68.63 +by (rtac refl 1);
   68.64 +val lemma2 = result();
   68.65 +
   68.66 +(* direction def_g(g) --> is_g(g) *)
   68.67 +
   68.68 +val prems = goal Focus_ex.thy "def_g(g) --> is_g(g)";
   68.69 +by (simp_tac (!simpset addsimps [def_g,lemma1, lemma2]) 1);
   68.70 +by (rtac impI 1);
   68.71 +by (etac exE 1);
   68.72 +by (res_inst_tac [("x","f")] exI 1);
   68.73 +by (REPEAT (etac conjE 1));
   68.74 +by (etac conjI 1);
   68.75 +by (strip_tac 1);
   68.76 +by (res_inst_tac [("x","fix`(LAM k.csnd`(f`<x,k>))")] exI 1);
   68.77 +by (rtac conjI 1);
   68.78 +by (Asm_simp_tac 1);
   68.79 +by (rtac conjI 1);
   68.80 +by (rtac trans 1);
   68.81 +by (rtac fix_eq 1);
   68.82 +by (Simp_tac 1);
   68.83 +by (strip_tac 1);
   68.84 +by (rtac fix_least 1);
   68.85 +by (dtac sym 1);
   68.86 +back();
   68.87 +by (Asm_simp_tac 1);
   68.88 +val lemma3 = result();
   68.89 +
   68.90 +(* direction is_g(g) --> def_g(g) *)
   68.91 +val prems = goal Focus_ex.thy "is_g(g) --> def_g(g)";
   68.92 +by (simp_tac (!simpset addsimps [lemma1,lemma2,def_g]) 1);
   68.93 +by (rtac impI 1);
   68.94 +by (etac exE 1);
   68.95 +by (res_inst_tac [("x","f")] exI 1);
   68.96 +by (REPEAT (etac conjE 1));
   68.97 +by (etac conjI 1);
   68.98 +by (rtac ext_cfun 1);
   68.99 +by (etac allE 1);
  68.100 +by (etac exE 1);
  68.101 +by (REPEAT (etac conjE 1));
  68.102 +by (subgoal_tac "fix`(LAM k. csnd`(f`<x, k>)) = z" 1);
  68.103 +by (Asm_simp_tac 1);
  68.104 +by (subgoal_tac "! w y. f`<x, w> = <y, w>  --> z << w" 1);
  68.105 +by (rtac sym 1);
  68.106 +by (rtac fix_eqI 1);
  68.107 +by (Asm_simp_tac 1);
  68.108 +by (etac sym 1);
  68.109 +by (rtac allI 1);
  68.110 +by (Simp_tac 1);
  68.111 +by (strip_tac 1);
  68.112 +by (subgoal_tac "f`<x, za> = <cfst`(f`<x,za>),za>" 1);
  68.113 +by (fast_tac HOL_cs 1);
  68.114 +by (rtac trans 1);
  68.115 +by (rtac (surjective_pairing_Cprod2 RS sym) 1);
  68.116 +by (etac cfun_arg_cong 1);
  68.117 +by (strip_tac 1);
  68.118 +by (REPEAT (etac allE 1));
  68.119 +by (etac mp 1);
  68.120 +by (etac sym 1);
  68.121 +val lemma4 = result();
  68.122 +
  68.123 +(* now we assemble the result *)
  68.124 +
  68.125 +val prems = goal Focus_ex.thy "def_g = is_g";
  68.126 +by (rtac ext 1);
  68.127 +by (rtac iffI 1);
  68.128 +by (etac (lemma3 RS mp) 1);
  68.129 +by (etac (lemma4 RS mp) 1);
  68.130 +val loopback_eq = result();
  68.131 +
  68.132 +val prems = goal Focus_ex.thy 
  68.133 +"(? f.\
  68.134 +\ is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))\
  68.135 +\ -->\
  68.136 +\ (? g. def_g(g::'b stream -> 'c stream ))";
  68.137 +by (simp_tac (!simpset addsimps [def_g]) 1);
  68.138 +by (strip_tac 1);
  68.139 +by (etac exE 1);
  68.140 +by (rtac exI 1);
  68.141 +by (rtac exI 1);
  68.142 +by (etac conjI 1);
  68.143 +by (rtac refl 1);
  68.144 +val L2 = result();
  68.145 +
  68.146 +val prems = goal Focus_ex.thy 
  68.147 +"(? f.\
  68.148 +\ is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))\
  68.149 +\ -->\
  68.150 +\ (? g. is_g(g::'b stream -> 'c stream ))";
  68.151 +by (rtac (loopback_eq RS subst) 1);
  68.152 +by (rtac L2 1);
  68.153 +val conservative_loopback = result();
  68.154 +
    69.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    69.2 +++ b/src/HOLCF/explicit_domains/Focus_ex.thy	Fri Oct 06 17:25:24 1995 +0100
    69.3 @@ -0,0 +1,143 @@
    69.4 +(*
    69.5 +    ID:         $Id$
    69.6 +    Author: 	Franz Regensburger
    69.7 +    Copyright   1995 Technische Universitaet Muenchen
    69.8 +
    69.9 +*)
   69.10 +
   69.11 +(* Specification of the following loop back device
   69.12 +
   69.13 +
   69.14 +          g 
   69.15 +           --------------------
   69.16 +          |      -------       |
   69.17 +       x  |     |       |      |  y
   69.18 +    ------|---->|       |------| ----->        
   69.19 +          |  z  |   f   | z    |
   69.20 +          |  -->|       |---   |
   69.21 +          | |   |       |   |  |
   69.22 +          | |    -------    |  |
   69.23 +          | |               |  |
   69.24 +          |  <--------------   |
   69.25 +          |                    | 
   69.26 +           --------------------
   69.27 +
   69.28 +
   69.29 +First step: Notation in Agent Network Description Language (ANDL)
   69.30 +-----------------------------------------------------------------
   69.31 +
   69.32 +agent f
   69.33 +	input  channel i1:'b i2: ('b,'c) tc
   69.34 +	output channel o1:'c o2: ('b,'c) tc
   69.35 +is
   69.36 +	Rf(i1,i2,o1,o2)  (left open in the example)
   69.37 +end f
   69.38 +
   69.39 +agent g
   69.40 +	input  channel x:'b 
   69.41 +	output channel y:'c 
   69.42 +is network
   69.43 +	<y,z> = f`<x,z>
   69.44 +end network
   69.45 +end g
   69.46 +
   69.47 +
   69.48 +Remark: the type of the feedback depends at most on the types of the input and
   69.49 +        output of g. (No type miracles inside g)
   69.50 +
   69.51 +Second step: Translation of ANDL specification to HOLCF Specification
   69.52 +---------------------------------------------------------------------
   69.53 +
   69.54 +Specification of agent f ist translated to predicate is_f
   69.55 +
   69.56 +is_f :: ('b stream * ('b,'c) tc stream -> 
   69.57 +		'c stream * ('b,'c) tc stream) => bool
   69.58 +
   69.59 +is_f f  = ! i1 i2 o1 o2. 
   69.60 +	f`<i1,i2> = <o1,o2> --> Rf(i1,i2,o1,o2)
   69.61 +
   69.62 +Specification of agent g is translated to predicate is_g which uses
   69.63 +predicate is_net_g
   69.64 +
   69.65 +is_net_g :: ('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
   69.66 +	    'b stream => 'c stream => bool
   69.67 +
   69.68 +is_net_g f x y = 
   69.69 +	? z. <y,z> = f`<x,z> &
   69.70 +	! oy hz. <oy,hz> = f`<x,hz> --> z << hz 
   69.71 +
   69.72 +
   69.73 +is_g :: ('b stream -> 'c stream) => bool
   69.74 +
   69.75 +is_g g  = ? f. is_f f  & (! x y. g`x = y --> is_net_g f x y
   69.76 +	  
   69.77 +Third step: (show conservativity)
   69.78 +-----------
   69.79 +
   69.80 +Suppose we have a model for the theory TH1 which contains the axiom
   69.81 +
   69.82 +	? f. is_f f 
   69.83 +
   69.84 +In this case there is also a model for the theory TH2 that enriches TH1 by
   69.85 +axiom
   69.86 +
   69.87 +	? g. is_g g 
   69.88 +
   69.89 +The result is proved by showing that there is a definitional extension
   69.90 +that extends TH1 by a definition of g.
   69.91 +
   69.92 +
   69.93 +We define:
   69.94 +
   69.95 +def_g g  = 
   69.96 +         (? f. is_f f  & 
   69.97 +	      g = (LAM x. cfst`(f`<x,fix`(LAM k.csnd`(f`<x,k>))>)) )
   69.98 +	
   69.99 +Now we prove:
  69.100 +
  69.101 +	(?f. is_f f ) --> (? g. is_g g) 
  69.102 +
  69.103 +using the theorems
  69.104 +
  69.105 +loopback_eq)	def_g = is_g			(real work) 
  69.106 +
  69.107 +L1)		(? f. is_f f ) --> (? g. def_g g)  (trivial)
  69.108 +
  69.109 +*)
  69.110 +
  69.111 +Focus_ex = Stream +
  69.112 +
  69.113 +types  tc 2
  69.114 +
  69.115 +arities tc:: (pcpo,pcpo)pcpo
  69.116 +
  69.117 +consts
  69.118 +
  69.119 +is_f     ::
  69.120 + "('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) => bool"
  69.121 +is_net_g :: "('b stream *('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
  69.122 +	    'b stream => 'c stream => bool"
  69.123 +is_g     :: "('b stream -> 'c stream) => bool"
  69.124 +def_g    :: "('b stream -> 'c stream) => bool"
  69.125 +Rf	 :: 
  69.126 +"('b stream * ('b,'c) tc stream * 'c stream * ('b,'c) tc stream) => bool"
  69.127 +
  69.128 +defs
  69.129 +
  69.130 +is_f		"is_f f == (! i1 i2 o1 o2.
  69.131 +			f`<i1,i2> = <o1,o2> --> Rf(i1,i2,o1,o2))"
  69.132 +
  69.133 +is_net_g	"is_net_g f x y == (? z. 
  69.134 +			<y,z> = f`<x,z> &
  69.135 +			(! oy hz. <oy,hz> = f`<x,hz> --> z << hz))" 
  69.136 +
  69.137 +is_g		"is_g g  == (? f.
  69.138 +			is_f f  & 
  69.139 +			(!x y. g`x = y --> is_net_g f x y))"
  69.140 +
  69.141 +
  69.142 +def_g		"def_g g == (? f.
  69.143 +			is_f f  & 
  69.144 +	      		g = (LAM x. cfst`(f`<x,fix`(LAM k.csnd`(f`<x,k>))>)))" 
  69.145 +
  69.146 +end
    70.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    70.2 +++ b/src/HOLCF/explicit_domains/README	Fri Oct 06 17:25:24 1995 +0100
    70.3 @@ -0,0 +1,22 @@
    70.4 +(*
    70.5 +    ID:         $Id$
    70.6 +    Author: 	Franz Regensburger
    70.7 +    Copyright   1995 Technische Universitaet Muenchen
    70.8 +
    70.9 +*)
   70.10 +
   70.11 +The files contained in this directory are examples for the
   70.12 +explicit construction of domains. The technique used is described
   70.13 +in the thesis
   70.14 +
   70.15 +	HOLCF: Eine konservative Erweiterung von HOL um LCF
   70.16 +
   70.17 +The thesis is available via the web using URL
   70.18 +
   70.19 +	http://www4.informatik.tu-muenchen.de/~regensbu/papers.html
   70.20 +
   70.21 +
   70.22 +The same construction is automatically performed if you use the
   70.23 +type definition package of David Oheimb. See subdirectory HOLCF/domains
   70.24 +for more details.
   70.25 +
    71.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    71.2 +++ b/src/HOLCF/explicit_domains/ROOT.ML	Fri Oct 06 17:25:24 1995 +0100
    71.3 @@ -0,0 +1,22 @@
    71.4 +(*
    71.5 +    ID:         $Id$
    71.6 +    Author: 	Franz Regensburger
    71.7 +    Copyright   1995 Technische Universitaet Muenchen
    71.8 +
    71.9 +*)
   71.10 +
   71.11 +HOLCF_build_completed;    (*Cause examples to fail if HOLCF did*)
   71.12 +
   71.13 +writeln"Root file for HOLCF examples: explicit domain axiomatisation";
   71.14 +proof_timing := true;
   71.15 +time_use_thy "explicit_domains/Dnat";
   71.16 +time_use_thy "explicit_domains/Dnat2";
   71.17 +time_use_thy "explicit_domains/Stream";
   71.18 +time_use_thy "explicit_domains/Stream2";
   71.19 +time_use_thy "explicit_domains/Dlist";
   71.20 +
   71.21 +time_use_thy "explicit_domains/Coind";
   71.22 +time_use_thy "explicit_domains/Dagstuhl";
   71.23 +time_use_thy "explicit_domains/Focus_ex";
   71.24 +
   71.25 +maketest "END: Root file for HOLCF examples: explicit domain axiomatization";
    72.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    72.2 +++ b/src/HOLCF/explicit_domains/Stream.ML	Fri Oct 06 17:25:24 1995 +0100
    72.3 @@ -0,0 +1,840 @@
    72.4 +(*  
    72.5 +    ID:         $Id$
    72.6 +    Author: 	Franz Regensburger
    72.7 +    Copyright   1993 Technische Universitaet Muenchen
    72.8 +
    72.9 +Lemmas for stream.thy
   72.10 +*)
   72.11 +
   72.12 +open Stream;
   72.13 +
   72.14 +(* ------------------------------------------------------------------------*)
   72.15 +(* The isomorphisms stream_rep_iso and stream_abs_iso are strict           *)
   72.16 +(* ------------------------------------------------------------------------*)
   72.17 +
   72.18 +val stream_iso_strict= stream_rep_iso RS (stream_abs_iso RS 
   72.19 +	(allI  RSN (2,allI RS iso_strict)));
   72.20 +
   72.21 +val stream_rews = [stream_iso_strict RS conjunct1,
   72.22 +		stream_iso_strict RS conjunct2];
   72.23 +
   72.24 +(* ------------------------------------------------------------------------*)
   72.25 +(* Properties of stream_copy                                               *)
   72.26 +(* ------------------------------------------------------------------------*)
   72.27 +
   72.28 +fun prover defs thm =  prove_goalw Stream.thy defs thm
   72.29 + (fn prems =>
   72.30 +	[
   72.31 +	(cut_facts_tac prems 1),
   72.32 +	(asm_simp_tac (!simpset addsimps 
   72.33 +		(stream_rews @ [stream_abs_iso,stream_rep_iso])) 1)
   72.34 +	]);
   72.35 +
   72.36 +val stream_copy = 
   72.37 +	[
   72.38 +	prover [stream_copy_def] "stream_copy`f`UU=UU",
   72.39 +	prover [stream_copy_def,scons_def] 
   72.40 +	"x~=UU ==> stream_copy`f`(scons`x`xs)= scons`x`(f`xs)"
   72.41 +	];
   72.42 +
   72.43 +val stream_rews =  stream_copy @ stream_rews; 
   72.44 +
   72.45 +(* ------------------------------------------------------------------------*)
   72.46 +(* Exhaustion and elimination for streams                                  *)
   72.47 +(* ------------------------------------------------------------------------*)
   72.48 +
   72.49 +qed_goalw "Exh_stream" Stream.thy [scons_def]
   72.50 +	"s = UU | (? x xs. x~=UU & s = scons`x`xs)"
   72.51 + (fn prems =>
   72.52 +	[
   72.53 +	(Simp_tac 1),
   72.54 +	(rtac (stream_rep_iso RS subst) 1),
   72.55 +	(res_inst_tac [("p","stream_rep`s")] sprodE 1),
   72.56 +	(asm_simp_tac (!simpset addsimps stream_rews) 1),
   72.57 +	(Asm_simp_tac  1),
   72.58 +	(res_inst_tac [("p","y")] liftE1 1),
   72.59 +	(contr_tac 1),
   72.60 +	(rtac disjI2 1),
   72.61 +	(rtac exI 1),
   72.62 +	(rtac exI 1),
   72.63 +	(etac conjI 1),
   72.64 +	(Asm_simp_tac  1)
   72.65 +	]);
   72.66 +
   72.67 +qed_goal "streamE" Stream.thy 
   72.68 +	"[| s=UU ==> Q; !!x xs.[|s=scons`x`xs;x~=UU|]==>Q|]==>Q"
   72.69 + (fn prems =>
   72.70 +	[
   72.71 +	(rtac (Exh_stream RS disjE) 1),
   72.72 +	(eresolve_tac prems 1),
   72.73 +	(etac exE 1),
   72.74 +	(etac exE 1),
   72.75 +	(resolve_tac prems 1),
   72.76 +	(fast_tac HOL_cs 1),
   72.77 +	(fast_tac HOL_cs 1)
   72.78 +	]);
   72.79 +
   72.80 +(* ------------------------------------------------------------------------*)
   72.81 +(* Properties of stream_when                                               *)
   72.82 +(* ------------------------------------------------------------------------*)
   72.83 +
   72.84 +fun prover defs thm =  prove_goalw Stream.thy defs thm
   72.85 + (fn prems =>
   72.86 +	[
   72.87 +	(cut_facts_tac prems 1),
   72.88 +	(asm_simp_tac (!simpset addsimps 
   72.89 +		(stream_rews @ [stream_abs_iso,stream_rep_iso])) 1)
   72.90 +	]);
   72.91 +
   72.92 +
   72.93 +val stream_when = [
   72.94 +	prover [stream_when_def] "stream_when`f`UU=UU",
   72.95 +	prover [stream_when_def,scons_def] 
   72.96 +		"x~=UU ==> stream_when`f`(scons`x`xs)= f`x`xs"
   72.97 +	];
   72.98 +
   72.99 +val stream_rews = stream_when @ stream_rews;
  72.100 +
  72.101 +(* ------------------------------------------------------------------------*)
  72.102 +(* Rewrites for  discriminators and  selectors                             *)
  72.103 +(* ------------------------------------------------------------------------*)
  72.104 +
  72.105 +fun prover defs thm = prove_goalw Stream.thy defs thm
  72.106 + (fn prems =>
  72.107 +	[
  72.108 +	(simp_tac (!simpset addsimps stream_rews) 1)
  72.109 +	]);
  72.110 +
  72.111 +val stream_discsel = [
  72.112 +	prover [is_scons_def] "is_scons`UU=UU",
  72.113 +	prover [shd_def] "shd`UU=UU",
  72.114 +	prover [stl_def] "stl`UU=UU"
  72.115 +	];
  72.116 +
  72.117 +fun prover defs thm = prove_goalw Stream.thy defs thm
  72.118 + (fn prems =>
  72.119 +	[
  72.120 +	(cut_facts_tac prems 1),
  72.121 +	(asm_simp_tac (!simpset addsimps stream_rews) 1)
  72.122 +	]);
  72.123 +
  72.124 +val stream_discsel = [
  72.125 +prover [is_scons_def,shd_def,stl_def] "x~=UU ==> is_scons`(scons`x`xs)=TT",
  72.126 +prover [is_scons_def,shd_def,stl_def] "x~=UU ==> shd`(scons`x`xs)=x",
  72.127 +prover [is_scons_def,shd_def,stl_def] "x~=UU ==> stl`(scons`x`xs)=xs"
  72.128 +	] @ stream_discsel;
  72.129 +
  72.130 +val stream_rews = stream_discsel @ stream_rews;
  72.131 +
  72.132 +(* ------------------------------------------------------------------------*)
  72.133 +(* Definedness and strictness                                              *)
  72.134 +(* ------------------------------------------------------------------------*)
  72.135 +
  72.136 +fun prover contr thm = prove_goal Stream.thy thm
  72.137 + (fn prems =>
  72.138 +	[
  72.139 +	(res_inst_tac [("P1",contr)] classical3 1),
  72.140 +	(simp_tac (!simpset addsimps stream_rews) 1),
  72.141 +	(dtac sym 1),
  72.142 +	(Asm_simp_tac 1),
  72.143 +	(simp_tac (!simpset addsimps (prems @ stream_rews)) 1)
  72.144 +	]);
  72.145 +
  72.146 +val stream_constrdef = [
  72.147 +	prover "is_scons`(UU::'a stream)~=UU" "x~=UU ==> scons`(x::'a)`xs~=UU"
  72.148 +	]; 
  72.149 +
  72.150 +fun prover defs thm = prove_goalw Stream.thy defs thm
  72.151 + (fn prems =>
  72.152 +	[
  72.153 +	(simp_tac (!simpset addsimps stream_rews) 1)
  72.154 +	]);
  72.155 +
  72.156 +val stream_constrdef = [
  72.157 +	prover [scons_def] "scons`UU`xs=UU"
  72.158 +	] @ stream_constrdef;
  72.159 +
  72.160 +val stream_rews = stream_constrdef @ stream_rews;
  72.161 +
  72.162 +
  72.163 +(* ------------------------------------------------------------------------*)
  72.164 +(* Distinctness wrt. << and =                                              *)
  72.165 +(* ------------------------------------------------------------------------*)
  72.166 +
  72.167 +
  72.168 +(* ------------------------------------------------------------------------*)
  72.169 +(* Invertibility                                                           *)
  72.170 +(* ------------------------------------------------------------------------*)
  72.171 +
  72.172 +val stream_invert =
  72.173 +	[
  72.174 +prove_goal Stream.thy "[|x1~=UU; y1~=UU;\
  72.175 +\ scons`x1`x2 << scons`y1`y2|] ==> x1<< y1 & x2 << y2"
  72.176 + (fn prems =>
  72.177 +	[
  72.178 +	(cut_facts_tac prems 1),
  72.179 +	(rtac conjI 1),
  72.180 +	(dres_inst_tac [("fo5","stream_when`(LAM x l.x)")] monofun_cfun_arg 1),
  72.181 +	(etac box_less 1),
  72.182 +	(asm_simp_tac (!simpset addsimps stream_when) 1),
  72.183 +	(asm_simp_tac (!simpset addsimps stream_when) 1),
  72.184 +	(dres_inst_tac [("fo5","stream_when`(LAM x l.l)")] monofun_cfun_arg 1),
  72.185 +	(etac box_less 1),
  72.186 +	(asm_simp_tac (!simpset addsimps stream_when) 1),
  72.187 +	(asm_simp_tac (!simpset addsimps stream_when) 1)
  72.188 +	])
  72.189 +	];
  72.190 +
  72.191 +(* ------------------------------------------------------------------------*)
  72.192 +(* Injectivity                                                             *)
  72.193 +(* ------------------------------------------------------------------------*)
  72.194 +
  72.195 +val stream_inject = 
  72.196 +	[
  72.197 +prove_goal Stream.thy "[|x1~=UU; y1~=UU;\
  72.198 +\ scons`x1`x2 = scons`y1`y2 |] ==> x1= y1 & x2 = y2"
  72.199 + (fn prems =>
  72.200 +	[
  72.201 +	(cut_facts_tac prems 1),
  72.202 +	(rtac conjI 1),
  72.203 +	(dres_inst_tac [("f","stream_when`(LAM x l.x)")] cfun_arg_cong 1),
  72.204 +	(etac box_equals 1),
  72.205 +	(asm_simp_tac (!simpset addsimps stream_when) 1),
  72.206 +	(asm_simp_tac (!simpset addsimps stream_when) 1),
  72.207 +	(dres_inst_tac [("f","stream_when`(LAM x l.l)")] cfun_arg_cong 1),
  72.208 +	(etac box_equals 1),
  72.209 +	(asm_simp_tac (!simpset addsimps stream_when) 1),
  72.210 +	(asm_simp_tac (!simpset addsimps stream_when) 1)
  72.211 +	])
  72.212 +	];
  72.213 +
  72.214 +(* ------------------------------------------------------------------------*)
  72.215 +(* definedness for  discriminators and  selectors                          *)
  72.216 +(* ------------------------------------------------------------------------*)
  72.217 +
  72.218 +fun prover thm = prove_goal Stream.thy thm
  72.219 + (fn prems =>
  72.220 +	[
  72.221 +	(cut_facts_tac prems 1),
  72.222 +	(rtac streamE 1),
  72.223 +	(contr_tac 1),
  72.224 +	(REPEAT (asm_simp_tac (!simpset addsimps stream_discsel) 1))
  72.225 +	]);
  72.226 +
  72.227 +val stream_discsel_def = 
  72.228 +	[
  72.229 +	prover "s~=UU ==> is_scons`s ~= UU", 
  72.230 +	prover "s~=UU ==> shd`s ~=UU" 
  72.231 +	];
  72.232 +
  72.233 +val stream_rews = stream_discsel_def @ stream_rews;
  72.234 +
  72.235 +