removed obsolete ML files;
authorwenzelm
Tue Jul 18 02:22:38 2006 +0200 (2006-07-18)
changeset 2014098acc6d0fab6
parent 20139 804927db5311
child 20141 cf8129ebcdd3
removed obsolete ML files;
src/CCL/CCL.ML
src/CCL/CCL.thy
src/CCL/Fix.ML
src/CCL/Fix.thy
src/CCL/Gfp.ML
src/CCL/Gfp.thy
src/CCL/Hered.ML
src/CCL/Hered.thy
src/CCL/IsaMakefile
src/CCL/Lfp.ML
src/CCL/Lfp.thy
src/CCL/ROOT.ML
src/CCL/Set.ML
src/CCL/Set.thy
src/CCL/Term.ML
src/CCL/Term.thy
src/CCL/Trancl.ML
src/CCL/Trancl.thy
src/CCL/Type.ML
src/CCL/Type.thy
src/CCL/Wfd.thy
src/CCL/coinduction.ML
src/CCL/equalities.ML
src/CCL/eval.ML
src/CCL/ex/Flag.ML
src/CCL/ex/Flag.thy
src/CCL/ex/List.ML
src/CCL/ex/List.thy
src/CCL/ex/Nat.ML
src/CCL/ex/Nat.thy
src/CCL/ex/Stream.ML
src/CCL/ex/Stream.thy
src/CCL/genrec.ML
src/CCL/mono.ML
src/CCL/subset.ML
src/CCL/typecheck.ML
src/CCL/wfd.ML
     1.1 --- a/src/CCL/CCL.ML	Mon Jul 17 18:42:38 2006 +0200
     1.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.3 @@ -1,328 +0,0 @@
     1.4 -(*  Title:      CCL/CCL.ML
     1.5 -    ID:         $Id$
     1.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
     1.7 -    Copyright   1993  University of Cambridge
     1.8 -*)
     1.9 -
    1.10 -val ccl_data_defs = [apply_def,fix_def];
    1.11 -
    1.12 -val CCL_ss = set_ss addsimps [po_refl];
    1.13 -
    1.14 -(*** Congruence Rules ***)
    1.15 -
    1.16 -(*similar to AP_THM in Gordon's HOL*)
    1.17 -qed_goal "fun_cong" (the_context ()) "(f::'a=>'b) = g ==> f(x)=g(x)"
    1.18 -  (fn [prem] => [rtac (prem RS subst) 1, rtac refl 1]);
    1.19 -
    1.20 -(*similar to AP_TERM in Gordon's HOL and FOL's subst_context*)
    1.21 -qed_goal "arg_cong" (the_context ()) "x=y ==> f(x)=f(y)"
    1.22 - (fn [prem] => [rtac (prem RS subst) 1, rtac refl 1]);
    1.23 -
    1.24 -Goal  "(ALL x. f(x) = g(x)) --> (%x. f(x)) = (%x. g(x))";
    1.25 -by (simp_tac (CCL_ss addsimps [eq_iff]) 1);
    1.26 -by (fast_tac (set_cs addIs [po_abstractn]) 1);
    1.27 -bind_thm("abstractn", standard (allI RS (result() RS mp)));
    1.28 -
    1.29 -fun type_of_terms (Const("Trueprop",_) $
    1.30 -                   (Const("op =",(Type ("fun", [t,_]))) $ _ $ _)) = t;
    1.31 -
    1.32 -fun abs_prems thm =
    1.33 -   let fun do_abs n thm (Type ("fun", [_,t])) = do_abs n (abstractn RSN (n,thm)) t
    1.34 -         | do_abs n thm _                     = thm
    1.35 -       fun do_prems n      [] thm = thm
    1.36 -         | do_prems n (x::xs) thm = do_prems (n+1) xs (do_abs n thm (type_of_terms x));
    1.37 -   in do_prems 1 (prems_of thm) thm
    1.38 -   end;
    1.39 -
    1.40 -val caseBs = [caseBtrue,caseBfalse,caseBpair,caseBlam,caseBbot];
    1.41 -
    1.42 -(*** Termination and Divergence ***)
    1.43 -
    1.44 -Goalw [Trm_def,Dvg_def] "Trm(t) <-> ~ t = bot";
    1.45 -by (rtac iff_refl 1);
    1.46 -qed "Trm_iff";
    1.47 -
    1.48 -Goalw [Trm_def,Dvg_def] "Dvg(t) <-> t = bot";
    1.49 -by (rtac iff_refl 1);
    1.50 -qed "Dvg_iff";
    1.51 -
    1.52 -(*** Constructors are injective ***)
    1.53 -
    1.54 -val prems = goal (the_context ())
    1.55 -    "[| x=a;  y=b;  x=y |] ==> a=b";
    1.56 -by  (REPEAT (SOMEGOAL (ares_tac (prems@[box_equals]))));
    1.57 -qed "eq_lemma";
    1.58 -
    1.59 -fun mk_inj_rl thy rews s =
    1.60 -      let fun mk_inj_lemmas r = ([arg_cong] RL [(r RS (r RS eq_lemma))]);
    1.61 -          val inj_lemmas = List.concat (map mk_inj_lemmas rews);
    1.62 -          val tac = REPEAT (ares_tac [iffI,allI,conjI] 1 ORELSE
    1.63 -                            eresolve_tac inj_lemmas 1 ORELSE
    1.64 -                            asm_simp_tac (CCL_ss addsimps rews) 1)
    1.65 -      in prove_goal thy s (fn _ => [tac])
    1.66 -      end;
    1.67 -
    1.68 -val ccl_injs = map (mk_inj_rl (the_context ()) caseBs)
    1.69 -               ["<a,b> = <a',b'> <-> (a=a' & b=b')",
    1.70 -                "(lam x. b(x) = lam x. b'(x)) <-> ((ALL z. b(z)=b'(z)))"];
    1.71 -
    1.72 -val pair_inject = ((hd ccl_injs) RS iffD1) RS conjE;
    1.73 -
    1.74 -(*** Constructors are distinct ***)
    1.75 -
    1.76 -local
    1.77 -  fun pairs_of f x [] = []
    1.78 -    | pairs_of f x (y::ys) = (f x y) :: (f y x) :: (pairs_of f x ys);
    1.79 -
    1.80 -  fun mk_combs ff [] = []
    1.81 -    | mk_combs ff (x::xs) = (pairs_of ff x xs) @ mk_combs ff xs;
    1.82 -
    1.83 -(* Doesn't handle binder types correctly *)
    1.84 -  fun saturate thy sy name =
    1.85 -       let fun arg_str 0 a s = s
    1.86 -         | arg_str 1 a s = "(" ^ a ^ "a" ^ s ^ ")"
    1.87 -         | arg_str n a s = arg_str (n-1) a ("," ^ a ^ (chr((ord "a")+n-1)) ^ s);
    1.88 -           val sg = sign_of thy;
    1.89 -           val T = case Sign.const_type sg (Sign.intern_const (sign_of thy) sy) of
    1.90 -                            NONE => error(sy^" not declared") | SOME(T) => T;
    1.91 -           val arity = length (fst (strip_type T));
    1.92 -       in sy ^ (arg_str arity name "") end;
    1.93 -
    1.94 -  fun mk_thm_str thy a b = "~ " ^ (saturate thy a "a") ^ " = " ^ (saturate thy b "b");
    1.95 -
    1.96 -  val lemma = prove_goal (the_context ()) "t=t' --> case(t,b,c,d,e) = case(t',b,c,d,e)"
    1.97 -                   (fn _ => [simp_tac CCL_ss 1]) RS mp;
    1.98 -  fun mk_lemma (ra,rb) = [lemma] RL [ra RS (rb RS eq_lemma)] RL
    1.99 -                           [distinctness RS notE,sym RS (distinctness RS notE)];
   1.100 -in
   1.101 -  fun mk_lemmas rls = List.concat (map mk_lemma (mk_combs pair rls));
   1.102 -  fun mk_dstnct_rls thy xs = mk_combs (mk_thm_str thy) xs;
   1.103 -end;
   1.104 -
   1.105 -
   1.106 -val caseB_lemmas = mk_lemmas caseBs;
   1.107 -
   1.108 -val ccl_dstncts =
   1.109 -        let fun mk_raw_dstnct_thm rls s =
   1.110 -                  prove_goal (the_context ()) s (fn _=> [rtac notI 1,eresolve_tac rls 1])
   1.111 -        in map (mk_raw_dstnct_thm caseB_lemmas)
   1.112 -                (mk_dstnct_rls (the_context ()) ["bot","true","false","pair","lambda"]) end;
   1.113 -
   1.114 -fun mk_dstnct_thms thy defs inj_rls xs =
   1.115 -          let fun mk_dstnct_thm rls s = prove_goalw thy defs s
   1.116 -                               (fn _ => [simp_tac (CCL_ss addsimps (rls@inj_rls)) 1])
   1.117 -          in map (mk_dstnct_thm ccl_dstncts) (mk_dstnct_rls thy xs) end;
   1.118 -
   1.119 -fun mkall_dstnct_thms thy defs i_rls xss = List.concat (map (mk_dstnct_thms thy defs i_rls) xss);
   1.120 -
   1.121 -(*** Rewriting and Proving ***)
   1.122 -
   1.123 -fun XH_to_I rl = rl RS iffD2;
   1.124 -fun XH_to_D rl = rl RS iffD1;
   1.125 -val XH_to_E = make_elim o XH_to_D;
   1.126 -val XH_to_Is = map XH_to_I;
   1.127 -val XH_to_Ds = map XH_to_D;
   1.128 -val XH_to_Es = map XH_to_E;
   1.129 -
   1.130 -val ccl_rews = caseBs @ ccl_injs @ ccl_dstncts;
   1.131 -val ccl_ss = CCL_ss addsimps ccl_rews;
   1.132 -
   1.133 -val ccl_cs = set_cs addSEs (pair_inject::(ccl_dstncts RL [notE]))
   1.134 -                    addSDs (XH_to_Ds ccl_injs);
   1.135 -
   1.136 -(****** Facts from gfp Definition of [= and = ******)
   1.137 -
   1.138 -val major::prems = goal (the_context ()) "[| A=B;  a:B <-> P |] ==> a:A <-> P";
   1.139 -by (resolve_tac (prems RL [major RS ssubst]) 1);
   1.140 -qed "XHlemma1";
   1.141 -
   1.142 -Goal "(P(t,t') <-> Q) --> (<t,t'> : {p. EX t t'. p=<t,t'> &  P(t,t')} <-> Q)";
   1.143 -by (fast_tac ccl_cs 1);
   1.144 -bind_thm("XHlemma2", result() RS mp);
   1.145 -
   1.146 -(*** Pre-Order ***)
   1.147 -
   1.148 -Goalw [POgen_def,SIM_def]  "mono(%X. POgen(X))";
   1.149 -by (rtac monoI 1);
   1.150 -by (safe_tac ccl_cs);
   1.151 -by (REPEAT_SOME (resolve_tac [exI,conjI,refl]));
   1.152 -by (ALLGOALS (simp_tac ccl_ss));
   1.153 -by (ALLGOALS (fast_tac set_cs));
   1.154 -qed "POgen_mono";
   1.155 -
   1.156 -Goalw [POgen_def,SIM_def]
   1.157 - "<t,t'> : POgen(R) <-> t= bot | (t=true & t'=true)  | (t=false & t'=false) | \
   1.158 -\          (EX a a' b b'. t=<a,b> &  t'=<a',b'>  & <a,a'> : R & <b,b'> : R) | \
   1.159 -\          (EX f f'. t=lam x. f(x) &  t'=lam x. f'(x) & (ALL x. <f(x),f'(x)> : R))";
   1.160 -by (rtac (iff_refl RS XHlemma2) 1);
   1.161 -qed "POgenXH";
   1.162 -
   1.163 -Goal
   1.164 -  "t [= t' <-> t=bot | (t=true & t'=true) | (t=false & t'=false) | \
   1.165 -\                (EX a a' b b'. t=<a,b> &  t'=<a',b'>  & a [= a' & b [= b') | \
   1.166 -\                (EX f f'. t=lam x. f(x) &  t'=lam x. f'(x) & (ALL x. f(x) [= f'(x)))";
   1.167 -by (simp_tac (ccl_ss addsimps [PO_iff] delsimps ex_simps) 1);
   1.168 -by (rtac (rewrite_rule [POgen_def,SIM_def]
   1.169 -                 (POgen_mono RS (PO_def RS def_gfp_Tarski) RS XHlemma1)) 1);
   1.170 -by (rtac (iff_refl RS XHlemma2) 1);
   1.171 -qed "poXH";
   1.172 -
   1.173 -Goal "bot [= b";
   1.174 -by (rtac (poXH RS iffD2) 1);
   1.175 -by (simp_tac ccl_ss 1);
   1.176 -qed "po_bot";
   1.177 -
   1.178 -Goal "a [= bot --> a=bot";
   1.179 -by (rtac impI 1);
   1.180 -by (dtac (poXH RS iffD1) 1);
   1.181 -by (etac rev_mp 1);
   1.182 -by (simp_tac ccl_ss 1);
   1.183 -bind_thm("bot_poleast", result() RS mp);
   1.184 -
   1.185 -Goal "<a,b> [= <a',b'> <->  a [= a' & b [= b'";
   1.186 -by (rtac (poXH RS iff_trans) 1);
   1.187 -by (simp_tac ccl_ss 1);
   1.188 -qed "po_pair";
   1.189 -
   1.190 -Goal "lam x. f(x) [= lam x. f'(x) <-> (ALL x. f(x) [= f'(x))";
   1.191 -by (rtac (poXH RS iff_trans) 1);
   1.192 -by (simp_tac ccl_ss 1);
   1.193 -by (REPEAT (ares_tac [iffI,allI] 1 ORELSE eresolve_tac [exE,conjE] 1));
   1.194 -by (asm_simp_tac ccl_ss 1);
   1.195 -by (fast_tac ccl_cs 1);
   1.196 -qed "po_lam";
   1.197 -
   1.198 -val ccl_porews = [po_bot,po_pair,po_lam];
   1.199 -
   1.200 -val [p1,p2,p3,p4,p5] = goal (the_context ())
   1.201 -    "[| t [= t';  a [= a';  b [= b';  !!x y. c(x,y) [= c'(x,y); \
   1.202 -\       !!u. d(u) [= d'(u) |] ==> case(t,a,b,c,d) [= case(t',a',b',c',d')";
   1.203 -by (rtac (p1 RS po_cong RS po_trans) 1);
   1.204 -by (rtac (p2 RS po_cong RS po_trans) 1);
   1.205 -by (rtac (p3 RS po_cong RS po_trans) 1);
   1.206 -by (rtac (p4 RS po_abstractn RS po_abstractn RS po_cong RS po_trans) 1);
   1.207 -by (res_inst_tac [("f1","%d. case(t',a',b',c',d)")]
   1.208 -               (p5 RS po_abstractn RS po_cong RS po_trans) 1);
   1.209 -by (rtac po_refl 1);
   1.210 -qed "case_pocong";
   1.211 -
   1.212 -val [p1,p2] = goalw (the_context ()) ccl_data_defs
   1.213 -    "[| f [= f';  a [= a' |] ==> f ` a [= f' ` a'";
   1.214 -by (REPEAT (ares_tac [po_refl,case_pocong,p1,p2 RS po_cong] 1));
   1.215 -qed "apply_pocong";
   1.216 -
   1.217 -
   1.218 -val prems = goal (the_context ()) "~ lam x. b(x) [= bot";
   1.219 -by (rtac notI 1);
   1.220 -by (dtac bot_poleast 1);
   1.221 -by (etac (distinctness RS notE) 1);
   1.222 -qed "npo_lam_bot";
   1.223 -
   1.224 -val eq1::eq2::prems = goal (the_context ())
   1.225 -    "[| x=a;  y=b;  x[=y |] ==> a[=b";
   1.226 -by (rtac (eq1 RS subst) 1);
   1.227 -by (rtac (eq2 RS subst) 1);
   1.228 -by (resolve_tac prems 1);
   1.229 -qed "po_lemma";
   1.230 -
   1.231 -Goal "~ <a,b> [= lam x. f(x)";
   1.232 -by (rtac notI 1);
   1.233 -by (rtac (npo_lam_bot RS notE) 1);
   1.234 -by (etac (case_pocong RS (caseBlam RS (caseBpair RS po_lemma))) 1);
   1.235 -by (REPEAT (resolve_tac [po_refl,npo_lam_bot] 1));
   1.236 -qed "npo_pair_lam";
   1.237 -
   1.238 -Goal "~ lam x. f(x) [= <a,b>";
   1.239 -by (rtac notI 1);
   1.240 -by (rtac (npo_lam_bot RS notE) 1);
   1.241 -by (etac (case_pocong RS (caseBpair RS (caseBlam RS po_lemma))) 1);
   1.242 -by (REPEAT (resolve_tac [po_refl,npo_lam_bot] 1));
   1.243 -qed "npo_lam_pair";
   1.244 -
   1.245 -fun mk_thm s = prove_goal (the_context ()) s (fn _ =>
   1.246 -                          [rtac notI 1,dtac case_pocong 1,etac rev_mp 5,
   1.247 -                           ALLGOALS (simp_tac ccl_ss),
   1.248 -                           REPEAT (resolve_tac [po_refl,npo_lam_bot] 1)]);
   1.249 -
   1.250 -val npo_rls = [npo_pair_lam,npo_lam_pair] @ map mk_thm
   1.251 -            ["~ true [= false",          "~ false [= true",
   1.252 -             "~ true [= <a,b>",          "~ <a,b> [= true",
   1.253 -             "~ true [= lam x. f(x)","~ lam x. f(x) [= true",
   1.254 -            "~ false [= <a,b>",          "~ <a,b> [= false",
   1.255 -            "~ false [= lam x. f(x)","~ lam x. f(x) [= false"];
   1.256 -
   1.257 -(* Coinduction for [= *)
   1.258 -
   1.259 -val prems = goal (the_context ()) "[|  <t,u> : R;  R <= POgen(R) |] ==> t [= u";
   1.260 -by (rtac (PO_def RS def_coinduct RS (PO_iff RS iffD2)) 1);
   1.261 -by (REPEAT (ares_tac prems 1));
   1.262 -qed "po_coinduct";
   1.263 -
   1.264 -fun po_coinduct_tac s i = res_inst_tac [("R",s)] po_coinduct i;
   1.265 -
   1.266 -(*************** EQUALITY *******************)
   1.267 -
   1.268 -Goalw [EQgen_def,SIM_def]  "mono(%X. EQgen(X))";
   1.269 -by (rtac monoI 1);
   1.270 -by (safe_tac set_cs);
   1.271 -by (REPEAT_SOME (resolve_tac [exI,conjI,refl]));
   1.272 -by (ALLGOALS (simp_tac ccl_ss));
   1.273 -by (ALLGOALS (fast_tac set_cs));
   1.274 -qed "EQgen_mono";
   1.275 -
   1.276 -Goalw [EQgen_def,SIM_def]
   1.277 -  "<t,t'> : EQgen(R) <-> (t=bot & t'=bot)  | (t=true & t'=true)  | \
   1.278 -\                                            (t=false & t'=false) | \
   1.279 -\                (EX a a' b b'. t=<a,b> &  t'=<a',b'>  & <a,a'> : R & <b,b'> : R) | \
   1.280 -\                (EX f f'. t=lam x. f(x) &  t'=lam x. f'(x) & (ALL x.<f(x),f'(x)> : R))";
   1.281 -by (rtac (iff_refl RS XHlemma2) 1);
   1.282 -qed "EQgenXH";
   1.283 -
   1.284 -Goal
   1.285 -  "t=t' <-> (t=bot & t'=bot)  | (t=true & t'=true)  | (t=false & t'=false) | \
   1.286 -\                    (EX a a' b b'. t=<a,b> &  t'=<a',b'>  & a=a' & b=b') | \
   1.287 -\                    (EX f f'. t=lam x. f(x) &  t'=lam x. f'(x) & (ALL x. f(x)=f'(x)))";
   1.288 -by (subgoal_tac
   1.289 -  "<t,t'> : EQ <-> (t=bot & t'=bot)  | (t=true & t'=true) | (t=false & t'=false) | \
   1.290 -\             (EX a a' b b'. t=<a,b> &  t'=<a',b'>  & <a,a'> : EQ & <b,b'> : EQ) | \
   1.291 -\             (EX f f'. t=lam x. f(x) &  t'=lam x. f'(x) & (ALL x. <f(x),f'(x)> : EQ))" 1);
   1.292 -by (etac rev_mp 1);
   1.293 -by (simp_tac (CCL_ss addsimps [EQ_iff RS iff_sym]) 1);
   1.294 -by (rtac (rewrite_rule [EQgen_def,SIM_def]
   1.295 -                 (EQgen_mono RS (EQ_def RS def_gfp_Tarski) RS XHlemma1)) 1);
   1.296 -by (rtac (iff_refl RS XHlemma2) 1);
   1.297 -qed "eqXH";
   1.298 -
   1.299 -val prems = goal (the_context ()) "[|  <t,u> : R;  R <= EQgen(R) |] ==> t = u";
   1.300 -by (rtac (EQ_def RS def_coinduct RS (EQ_iff RS iffD2)) 1);
   1.301 -by (REPEAT (ares_tac prems 1));
   1.302 -qed "eq_coinduct";
   1.303 -
   1.304 -val prems = goal (the_context ())
   1.305 -    "[|  <t,u> : R;  R <= EQgen(lfp(%x. EQgen(x) Un R Un EQ)) |] ==> t = u";
   1.306 -by (rtac (EQ_def RS def_coinduct3 RS (EQ_iff RS iffD2)) 1);
   1.307 -by (REPEAT (ares_tac (EQgen_mono::prems) 1));
   1.308 -qed "eq_coinduct3";
   1.309 -
   1.310 -fun eq_coinduct_tac s i = res_inst_tac [("R",s)] eq_coinduct i;
   1.311 -fun eq_coinduct3_tac s i = res_inst_tac [("R",s)] eq_coinduct3 i;
   1.312 -
   1.313 -(*** Untyped Case Analysis and Other Facts ***)
   1.314 -
   1.315 -Goalw [apply_def]  "(EX f. t=lam x. f(x)) --> t = lam x.(t ` x)";
   1.316 -by (safe_tac ccl_cs);
   1.317 -by (simp_tac ccl_ss 1);
   1.318 -bind_thm("cond_eta", result() RS mp);
   1.319 -
   1.320 -Goal "(t=bot) | (t=true) | (t=false) | (EX a b. t=<a,b>) | (EX f. t=lam x. f(x))";
   1.321 -by (cut_facts_tac [refl RS (eqXH RS iffD1)] 1);
   1.322 -by (fast_tac set_cs 1);
   1.323 -qed "exhaustion";
   1.324 -
   1.325 -val prems = goal (the_context ())
   1.326 -    "[| P(bot);  P(true);  P(false);  !!x y. P(<x,y>);  !!b. P(lam x. b(x)) |] ==> P(t)";
   1.327 -by (cut_facts_tac [exhaustion] 1);
   1.328 -by (REPEAT_SOME (ares_tac prems ORELSE' eresolve_tac [disjE,exE,ssubst]));
   1.329 -qed "term_case";
   1.330 -
   1.331 -fun term_case_tac a i = res_inst_tac [("t",a)] term_case i;
     2.1 --- a/src/CCL/CCL.thy	Mon Jul 17 18:42:38 2006 +0200
     2.2 +++ b/src/CCL/CCL.thy	Tue Jul 18 02:22:38 2006 +0200
     2.3 @@ -150,6 +150,344 @@
     2.4          - wfd induction / coinduction and fixed point induction available
     2.5  *}
     2.6  
     2.7 -ML {* use_legacy_bindings (the_context ()) *}
     2.8 +
     2.9 +lemmas ccl_data_defs = apply_def fix_def
    2.10 +  and [simp] = po_refl
    2.11 +
    2.12 +
    2.13 +subsection {* Congruence Rules *}
    2.14 +
    2.15 +(*similar to AP_THM in Gordon's HOL*)
    2.16 +lemma fun_cong: "(f::'a=>'b) = g ==> f(x)=g(x)"
    2.17 +  by simp
    2.18 +
    2.19 +(*similar to AP_TERM in Gordon's HOL and FOL's subst_context*)
    2.20 +lemma arg_cong: "x=y ==> f(x)=f(y)"
    2.21 +  by simp
    2.22 +
    2.23 +lemma abstractn: "(!!x. f(x) = g(x)) ==> f = g"
    2.24 +  apply (simp add: eq_iff)
    2.25 +  apply (blast intro: po_abstractn)
    2.26 +  done
    2.27 +
    2.28 +lemmas caseBs = caseBtrue caseBfalse caseBpair caseBlam caseBbot
    2.29 +
    2.30 +
    2.31 +subsection {* Termination and Divergence *}
    2.32 +
    2.33 +lemma Trm_iff: "Trm(t) <-> ~ t = bot"
    2.34 +  by (simp add: Trm_def Dvg_def)
    2.35 +
    2.36 +lemma Dvg_iff: "Dvg(t) <-> t = bot"
    2.37 +  by (simp add: Trm_def Dvg_def)
    2.38 +
    2.39 +
    2.40 +subsection {* Constructors are injective *}
    2.41 +
    2.42 +lemma eq_lemma: "[| x=a;  y=b;  x=y |] ==> a=b"
    2.43 +  by simp
    2.44 +
    2.45 +ML {*
    2.46 +  local
    2.47 +    val arg_cong = thm "arg_cong";
    2.48 +    val eq_lemma = thm "eq_lemma";
    2.49 +    val ss = simpset_of (the_context ());
    2.50 +  in
    2.51 +    fun mk_inj_rl thy rews s =
    2.52 +      let
    2.53 +        fun mk_inj_lemmas r = [arg_cong] RL [r RS (r RS eq_lemma)]
    2.54 +        val inj_lemmas = List.concat (map mk_inj_lemmas rews)
    2.55 +        val tac = REPEAT (ares_tac [iffI, allI, conjI] 1 ORELSE
    2.56 +          eresolve_tac inj_lemmas 1 ORELSE
    2.57 +          asm_simp_tac (Simplifier.theory_context thy ss addsimps rews) 1)
    2.58 +      in prove_goal thy s (fn _ => [tac]) end  
    2.59 +  end
    2.60 +*}
    2.61 +
    2.62 +ML {*
    2.63 +  bind_thms ("ccl_injs",
    2.64 +    map (mk_inj_rl (the_context ()) (thms "caseBs"))
    2.65 +      ["<a,b> = <a',b'> <-> (a=a' & b=b')",
    2.66 +       "(lam x. b(x) = lam x. b'(x)) <-> ((ALL z. b(z)=b'(z)))"])
    2.67 +*}
    2.68 +
    2.69 +
    2.70 +lemma pair_inject: "<a,b> = <a',b'> \<Longrightarrow> (a = a' \<Longrightarrow> b = b' \<Longrightarrow> R) \<Longrightarrow> R"
    2.71 +  by (simp add: ccl_injs)
    2.72 +
    2.73 +
    2.74 +subsection {* Constructors are distinct *}
    2.75 +
    2.76 +lemma lem: "t=t' ==> case(t,b,c,d,e) = case(t',b,c,d,e)"
    2.77 +  by simp
    2.78 +
    2.79 +ML {*
    2.80 +
    2.81 +local
    2.82 +  fun pairs_of f x [] = []
    2.83 +    | pairs_of f x (y::ys) = (f x y) :: (f y x) :: (pairs_of f x ys)
    2.84 +
    2.85 +  fun mk_combs ff [] = []
    2.86 +    | mk_combs ff (x::xs) = (pairs_of ff x xs) @ mk_combs ff xs
    2.87 +
    2.88 +  (* Doesn't handle binder types correctly *)
    2.89 +  fun saturate thy sy name =
    2.90 +       let fun arg_str 0 a s = s
    2.91 +         | arg_str 1 a s = "(" ^ a ^ "a" ^ s ^ ")"
    2.92 +         | arg_str n a s = arg_str (n-1) a ("," ^ a ^ (chr((ord "a")+n-1)) ^ s)
    2.93 +           val T = Sign.the_const_type thy (Sign.intern_const thy sy);
    2.94 +           val arity = length (fst (strip_type T))
    2.95 +       in sy ^ (arg_str arity name "") end
    2.96 +
    2.97 +  fun mk_thm_str thy a b = "~ " ^ (saturate thy a "a") ^ " = " ^ (saturate thy b "b")
    2.98 +
    2.99 +  val lemma = thm "lem";
   2.100 +  val eq_lemma = thm "eq_lemma";
   2.101 +  val distinctness = thm "distinctness";
   2.102 +  fun mk_lemma (ra,rb) = [lemma] RL [ra RS (rb RS eq_lemma)] RL
   2.103 +                           [distinctness RS notE,sym RS (distinctness RS notE)]
   2.104 +in
   2.105 +  fun mk_lemmas rls = List.concat (map mk_lemma (mk_combs pair rls))
   2.106 +  fun mk_dstnct_rls thy xs = mk_combs (mk_thm_str thy) xs
   2.107 +end
   2.108 +
   2.109 +*}
   2.110 +
   2.111 +ML {*
   2.112 +
   2.113 +val caseB_lemmas = mk_lemmas (thms "caseBs")
   2.114 +
   2.115 +val ccl_dstncts =
   2.116 +        let fun mk_raw_dstnct_thm rls s =
   2.117 +                  prove_goal (the_context ()) s (fn _=> [rtac notI 1,eresolve_tac rls 1])
   2.118 +        in map (mk_raw_dstnct_thm caseB_lemmas)
   2.119 +                (mk_dstnct_rls (the_context ()) ["bot","true","false","pair","lambda"]) end
   2.120 +
   2.121 +fun mk_dstnct_thms thy defs inj_rls xs =
   2.122 +          let fun mk_dstnct_thm rls s = prove_goalw thy defs s
   2.123 +                               (fn _ => [simp_tac (simpset_of thy addsimps (rls@inj_rls)) 1])
   2.124 +          in map (mk_dstnct_thm ccl_dstncts) (mk_dstnct_rls thy xs) end
   2.125 +
   2.126 +fun mkall_dstnct_thms thy defs i_rls xss = List.concat (map (mk_dstnct_thms thy defs i_rls) xss)
   2.127 +
   2.128 +(*** Rewriting and Proving ***)
   2.129 +
   2.130 +fun XH_to_I rl = rl RS iffD2
   2.131 +fun XH_to_D rl = rl RS iffD1
   2.132 +val XH_to_E = make_elim o XH_to_D
   2.133 +val XH_to_Is = map XH_to_I
   2.134 +val XH_to_Ds = map XH_to_D
   2.135 +val XH_to_Es = map XH_to_E;
   2.136 +
   2.137 +bind_thms ("ccl_rews", thms "caseBs" @ ccl_injs @ ccl_dstncts);
   2.138 +bind_thms ("ccl_dstnctsEs", ccl_dstncts RL [notE]);
   2.139 +bind_thms ("ccl_injDs", XH_to_Ds (thms "ccl_injs"));
   2.140 +*}
   2.141 +
   2.142 +lemmas [simp] = ccl_rews
   2.143 +  and [elim!] = pair_inject ccl_dstnctsEs
   2.144 +  and [dest!] = ccl_injDs
   2.145 +
   2.146 +
   2.147 +subsection {* Facts from gfp Definition of @{text "[="} and @{text "="} *}
   2.148 +
   2.149 +lemma XHlemma1: "[| A=B;  a:B <-> P |] ==> a:A <-> P"
   2.150 +  by simp
   2.151 +
   2.152 +lemma XHlemma2: "(P(t,t') <-> Q) ==> (<t,t'> : {p. EX t t'. p=<t,t'> &  P(t,t')} <-> Q)"
   2.153 +  by blast
   2.154 +
   2.155 +
   2.156 +subsection {* Pre-Order *}
   2.157 +
   2.158 +lemma POgen_mono: "mono(%X. POgen(X))"
   2.159 +  apply (unfold POgen_def SIM_def)
   2.160 +  apply (rule monoI)
   2.161 +  apply blast
   2.162 +  done
   2.163 +
   2.164 +lemma POgenXH: 
   2.165 +  "<t,t'> : POgen(R) <-> t= bot | (t=true & t'=true)  | (t=false & t'=false) |  
   2.166 +           (EX a a' b b'. t=<a,b> &  t'=<a',b'>  & <a,a'> : R & <b,b'> : R) |  
   2.167 +           (EX f f'. t=lam x. f(x) &  t'=lam x. f'(x) & (ALL x. <f(x),f'(x)> : R))"
   2.168 +  apply (unfold POgen_def SIM_def)
   2.169 +  apply (rule iff_refl [THEN XHlemma2])
   2.170 +  done
   2.171 +
   2.172 +lemma poXH: 
   2.173 +  "t [= t' <-> t=bot | (t=true & t'=true) | (t=false & t'=false) |  
   2.174 +                 (EX a a' b b'. t=<a,b> &  t'=<a',b'>  & a [= a' & b [= b') |  
   2.175 +                 (EX f f'. t=lam x. f(x) &  t'=lam x. f'(x) & (ALL x. f(x) [= f'(x)))"
   2.176 +  apply (simp add: PO_iff del: ex_simps)
   2.177 +  apply (rule POgen_mono
   2.178 +    [THEN PO_def [THEN def_gfp_Tarski], THEN XHlemma1, unfolded POgen_def SIM_def])
   2.179 +  apply (rule iff_refl [THEN XHlemma2])
   2.180 +  done
   2.181 +
   2.182 +lemma po_bot: "bot [= b"
   2.183 +  apply (rule poXH [THEN iffD2])
   2.184 +  apply simp
   2.185 +  done
   2.186 +
   2.187 +lemma bot_poleast: "a [= bot ==> a=bot"
   2.188 +  apply (drule poXH [THEN iffD1])
   2.189 +  apply simp
   2.190 +  done
   2.191 +
   2.192 +lemma po_pair: "<a,b> [= <a',b'> <->  a [= a' & b [= b'"
   2.193 +  apply (rule poXH [THEN iff_trans])
   2.194 +  apply simp
   2.195 +  done
   2.196 +
   2.197 +lemma po_lam: "lam x. f(x) [= lam x. f'(x) <-> (ALL x. f(x) [= f'(x))"
   2.198 +  apply (rule poXH [THEN iff_trans])
   2.199 +  apply fastsimp
   2.200 +  done
   2.201 +
   2.202 +lemmas ccl_porews = po_bot po_pair po_lam
   2.203 +
   2.204 +lemma case_pocong:
   2.205 +  assumes 1: "t [= t'"
   2.206 +    and 2: "a [= a'"
   2.207 +    and 3: "b [= b'"
   2.208 +    and 4: "!!x y. c(x,y) [= c'(x,y)"
   2.209 +    and 5: "!!u. d(u) [= d'(u)"
   2.210 +  shows "case(t,a,b,c,d) [= case(t',a',b',c',d')"
   2.211 +  apply (rule 1 [THEN po_cong, THEN po_trans])
   2.212 +  apply (rule 2 [THEN po_cong, THEN po_trans])
   2.213 +  apply (rule 3 [THEN po_cong, THEN po_trans])
   2.214 +  apply (rule 4 [THEN po_abstractn, THEN po_abstractn, THEN po_cong, THEN po_trans])
   2.215 +  apply (rule_tac f1 = "%d. case (t',a',b',c',d)" in
   2.216 +    5 [THEN po_abstractn, THEN po_cong, THEN po_trans])
   2.217 +  apply (rule po_refl)
   2.218 +  done
   2.219 +
   2.220 +lemma apply_pocong: "[| f [= f';  a [= a' |] ==> f ` a [= f' ` a'"
   2.221 +  unfolding ccl_data_defs
   2.222 +  apply (rule case_pocong, (rule po_refl | assumption)+)
   2.223 +  apply (erule po_cong)
   2.224 +  done
   2.225 +
   2.226 +lemma npo_lam_bot: "~ lam x. b(x) [= bot"
   2.227 +  apply (rule notI)
   2.228 +  apply (drule bot_poleast)
   2.229 +  apply (erule distinctness [THEN notE])
   2.230 +  done
   2.231 +
   2.232 +lemma po_lemma: "[| x=a;  y=b;  x[=y |] ==> a[=b"
   2.233 +  by simp
   2.234 +
   2.235 +lemma npo_pair_lam: "~ <a,b> [= lam x. f(x)"
   2.236 +  apply (rule notI)
   2.237 +  apply (rule npo_lam_bot [THEN notE])
   2.238 +  apply (erule case_pocong [THEN caseBlam [THEN caseBpair [THEN po_lemma]]])
   2.239 +  apply (rule po_refl npo_lam_bot)+
   2.240 +  done
   2.241 +
   2.242 +lemma npo_lam_pair: "~ lam x. f(x) [= <a,b>"
   2.243 +  apply (rule notI)
   2.244 +  apply (rule npo_lam_bot [THEN notE])
   2.245 +  apply (erule case_pocong [THEN caseBpair [THEN caseBlam [THEN po_lemma]]])
   2.246 +  apply (rule po_refl npo_lam_bot)+
   2.247 +  done
   2.248 +
   2.249 +ML {*
   2.250 +
   2.251 +local
   2.252 +  fun mk_thm s = prove_goal (the_context ()) s (fn _ =>
   2.253 +                          [rtac notI 1,dtac (thm "case_pocong") 1,etac rev_mp 5,
   2.254 +                           ALLGOALS (simp_tac (simpset ())),
   2.255 +                           REPEAT (resolve_tac [thm "po_refl", thm "npo_lam_bot"] 1)])
   2.256 +in
   2.257 +
   2.258 +val npo_rls = [thm "npo_pair_lam", thm "npo_lam_pair"] @ map mk_thm
   2.259 +            ["~ true [= false",          "~ false [= true",
   2.260 +             "~ true [= <a,b>",          "~ <a,b> [= true",
   2.261 +             "~ true [= lam x. f(x)","~ lam x. f(x) [= true",
   2.262 +            "~ false [= <a,b>",          "~ <a,b> [= false",
   2.263 +            "~ false [= lam x. f(x)","~ lam x. f(x) [= false"]
   2.264 +end;
   2.265 +
   2.266 +bind_thms ("npo_rls", npo_rls);
   2.267 +*}
   2.268 +
   2.269 +
   2.270 +subsection {* Coinduction for @{text "[="} *}
   2.271 +
   2.272 +lemma po_coinduct: "[|  <t,u> : R;  R <= POgen(R) |] ==> t [= u"
   2.273 +  apply (rule PO_def [THEN def_coinduct, THEN PO_iff [THEN iffD2]])
   2.274 +   apply assumption+
   2.275 +  done
   2.276 +
   2.277 +ML {*
   2.278 +  local val po_coinduct = thm "po_coinduct"
   2.279 +  in fun po_coinduct_tac s i = res_inst_tac [("R",s)] po_coinduct i end
   2.280 +*}
   2.281 +
   2.282 +
   2.283 +subsection {* Equality *}
   2.284 +
   2.285 +lemma EQgen_mono: "mono(%X. EQgen(X))"
   2.286 +  apply (unfold EQgen_def SIM_def)
   2.287 +  apply (rule monoI)
   2.288 +  apply blast
   2.289 +  done
   2.290 +
   2.291 +lemma EQgenXH: 
   2.292 +  "<t,t'> : EQgen(R) <-> (t=bot & t'=bot)  | (t=true & t'=true)  |  
   2.293 +                                             (t=false & t'=false) |  
   2.294 +                 (EX a a' b b'. t=<a,b> &  t'=<a',b'>  & <a,a'> : R & <b,b'> : R) |  
   2.295 +                 (EX f f'. t=lam x. f(x) &  t'=lam x. f'(x) & (ALL x.<f(x),f'(x)> : R))"
   2.296 +  apply (unfold EQgen_def SIM_def)
   2.297 +  apply (rule iff_refl [THEN XHlemma2])
   2.298 +  done
   2.299 +
   2.300 +lemma eqXH: 
   2.301 +  "t=t' <-> (t=bot & t'=bot)  | (t=true & t'=true)  | (t=false & t'=false) |  
   2.302 +                     (EX a a' b b'. t=<a,b> &  t'=<a',b'>  & a=a' & b=b') |  
   2.303 +                     (EX f f'. t=lam x. f(x) &  t'=lam x. f'(x) & (ALL x. f(x)=f'(x)))"
   2.304 +  apply (subgoal_tac "<t,t'> : EQ <-> (t=bot & t'=bot) | (t=true & t'=true) | (t=false & t'=false) | (EX a a' b b'. t=<a,b> & t'=<a',b'> & <a,a'> : EQ & <b,b'> : EQ) | (EX f f'. t=lam x. f (x) & t'=lam x. f' (x) & (ALL x. <f (x) ,f' (x) > : EQ))")
   2.305 +  apply (erule rev_mp)
   2.306 +  apply (simp add: EQ_iff [THEN iff_sym])
   2.307 +  apply (rule EQgen_mono [THEN EQ_def [THEN def_gfp_Tarski], THEN XHlemma1,
   2.308 +    unfolded EQgen_def SIM_def])
   2.309 +  apply (rule iff_refl [THEN XHlemma2])
   2.310 +  done
   2.311 +
   2.312 +lemma eq_coinduct: "[|  <t,u> : R;  R <= EQgen(R) |] ==> t = u"
   2.313 +  apply (rule EQ_def [THEN def_coinduct, THEN EQ_iff [THEN iffD2]])
   2.314 +   apply assumption+
   2.315 +  done
   2.316 +
   2.317 +lemma eq_coinduct3:
   2.318 +  "[|  <t,u> : R;  R <= EQgen(lfp(%x. EQgen(x) Un R Un EQ)) |] ==> t = u"
   2.319 +  apply (rule EQ_def [THEN def_coinduct3, THEN EQ_iff [THEN iffD2]])
   2.320 +  apply (rule EQgen_mono | assumption)+
   2.321 +  done
   2.322 +
   2.323 +ML {*
   2.324 +  local
   2.325 +    val eq_coinduct = thm "eq_coinduct"
   2.326 +    val eq_coinduct3 = thm "eq_coinduct3"
   2.327 +  in
   2.328 +    fun eq_coinduct_tac s i = res_inst_tac [("R",s)] eq_coinduct i
   2.329 +    fun eq_coinduct3_tac s i = res_inst_tac [("R",s)] eq_coinduct3 i
   2.330 +  end
   2.331 +*}
   2.332 +
   2.333 +
   2.334 +subsection {* Untyped Case Analysis and Other Facts *}
   2.335 +
   2.336 +lemma cond_eta: "(EX f. t=lam x. f(x)) ==> t = lam x.(t ` x)"
   2.337 +  by (auto simp: apply_def)
   2.338 +
   2.339 +lemma exhaustion: "(t=bot) | (t=true) | (t=false) | (EX a b. t=<a,b>) | (EX f. t=lam x. f(x))"
   2.340 +  apply (cut_tac refl [THEN eqXH [THEN iffD1]])
   2.341 +  apply blast
   2.342 +  done
   2.343 +
   2.344 +lemma term_case:
   2.345 +  "[| P(bot);  P(true);  P(false);  !!x y. P(<x,y>);  !!b. P(lam x. b(x)) |] ==> P(t)"
   2.346 +  using exhaustion [of t] by blast
   2.347  
   2.348  end
     3.1 --- a/src/CCL/Fix.ML	Mon Jul 17 18:42:38 2006 +0200
     3.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3 @@ -1,189 +0,0 @@
     3.4 -(*  Title:      CCL/Fix.ML
     3.5 -    ID:         $Id$
     3.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
     3.7 -    Copyright   1993  University of Cambridge
     3.8 -*)
     3.9 -
    3.10 -(*** Fixed Point Induction ***)
    3.11 -
    3.12 -val [base,step,incl] = goalw (the_context ()) [INCL_def]
    3.13 -    "[| P(bot);  !!x. P(x) ==> P(f(x));  INCL(P) |] ==> P(fix(f))";
    3.14 -by (rtac (incl RS spec RS mp) 1);
    3.15 -by (rtac (Nat_ind RS ballI) 1 THEN atac 1);
    3.16 -by (ALLGOALS (simp_tac term_ss));
    3.17 -by (REPEAT (ares_tac [base,step] 1));
    3.18 -qed "fix_ind";
    3.19 -
    3.20 -(*** Inclusive Predicates ***)
    3.21 -
    3.22 -val prems = goalw (the_context ()) [INCL_def]
    3.23 -     "INCL(P) <-> (ALL f. (ALL n:Nat. P(f ^ n ` bot)) --> P(fix(f)))";
    3.24 -by (rtac iff_refl 1);
    3.25 -qed "inclXH";
    3.26 -
    3.27 -val prems = goal (the_context ())
    3.28 -     "[| !!f. ALL n:Nat. P(f^n`bot) ==> P(fix(f)) |] ==> INCL(%x. P(x))";
    3.29 -by (fast_tac (term_cs addIs (prems @ [XH_to_I inclXH])) 1);
    3.30 -qed "inclI";
    3.31 -
    3.32 -val incl::prems = goal (the_context ())
    3.33 -     "[| INCL(P);  !!n. n:Nat ==> P(f^n`bot) |] ==> P(fix(f))";
    3.34 -by (fast_tac (term_cs addIs ([ballI RS (incl RS (XH_to_D inclXH) RS spec RS mp)]
    3.35 -                       @ prems)) 1);
    3.36 -qed "inclD";
    3.37 -
    3.38 -val incl::prems = goal (the_context ())
    3.39 -     "[| INCL(P);  (ALL n:Nat. P(f^n`bot))-->P(fix(f)) ==> R |] ==> R";
    3.40 -by (fast_tac (term_cs addIs ([incl RS inclD] @ prems)) 1);
    3.41 -qed "inclE";
    3.42 -
    3.43 -
    3.44 -(*** Lemmas for Inclusive Predicates ***)
    3.45 -
    3.46 -Goal "INCL(%x.~ a(x) [= t)";
    3.47 -by (rtac inclI 1);
    3.48 -by (dtac bspec 1);
    3.49 -by (rtac zeroT 1);
    3.50 -by (etac contrapos 1);
    3.51 -by (rtac po_trans 1);
    3.52 -by (assume_tac 2);
    3.53 -by (stac napplyBzero 1);
    3.54 -by (rtac po_cong 1 THEN rtac po_bot 1);
    3.55 -qed "npo_INCL";
    3.56 -
    3.57 -val prems = goal (the_context ()) "[| INCL(P);  INCL(Q) |] ==> INCL(%x. P(x) & Q(x))";
    3.58 -by (fast_tac (set_cs addSIs ([inclI] @ (prems RL [inclD]))) 1);;
    3.59 -qed "conj_INCL";
    3.60 -
    3.61 -val prems = goal (the_context ()) "[| !!a. INCL(P(a)) |] ==> INCL(%x. ALL a. P(a,x))";
    3.62 -by (fast_tac (set_cs addSIs ([inclI] @ (prems RL [inclD]))) 1);;
    3.63 -qed "all_INCL";
    3.64 -
    3.65 -val prems = goal (the_context ()) "[| !!a. a:A ==> INCL(P(a)) |] ==> INCL(%x. ALL a:A. P(a,x))";
    3.66 -by (fast_tac (set_cs addSIs ([inclI] @ (prems RL [inclD]))) 1);;
    3.67 -qed "ball_INCL";
    3.68 -
    3.69 -Goal "INCL(%x. a(x) = (b(x)::'a::prog))";
    3.70 -by (simp_tac (term_ss addsimps [eq_iff]) 1);
    3.71 -by (REPEAT (resolve_tac [conj_INCL,po_INCL] 1));
    3.72 -qed "eq_INCL";
    3.73 -
    3.74 -(*** Derivation of Reachability Condition ***)
    3.75 -
    3.76 -(* Fixed points of idgen *)
    3.77 -
    3.78 -Goal "idgen(fix(idgen)) = fix(idgen)";
    3.79 -by (rtac (fixB RS sym) 1);
    3.80 -qed "fix_idgenfp";
    3.81 -
    3.82 -Goalw [idgen_def] "idgen(lam x. x) = lam x. x";
    3.83 -by (simp_tac term_ss 1);
    3.84 -by (rtac (term_case RS allI) 1);
    3.85 -by (ALLGOALS (simp_tac term_ss));
    3.86 -qed "id_idgenfp";
    3.87 -
    3.88 -(* All fixed points are lam-expressions *)
    3.89 -
    3.90 -val [prem] = goal (the_context ()) "idgen(d) = d ==> d = lam x.?f(x)";
    3.91 -by (rtac (prem RS subst) 1);
    3.92 -by (rewtac idgen_def);
    3.93 -by (rtac refl 1);
    3.94 -qed "idgenfp_lam";
    3.95 -
    3.96 -(* Lemmas for rewriting fixed points of idgen *)
    3.97 -
    3.98 -val prems = goalw (the_context ()) [idgen_def]
    3.99 -    "[| a = b;  a ` t = u |] ==> b ` t = u";
   3.100 -by (simp_tac (term_ss addsimps (prems RL [sym])) 1);
   3.101 -qed "l_lemma";
   3.102 -
   3.103 -val idgen_lemmas =
   3.104 -    let fun mk_thm s = prove_goalw (the_context ()) [idgen_def] s
   3.105 -           (fn [prem] => [rtac (prem RS l_lemma) 1,simp_tac term_ss 1])
   3.106 -    in map mk_thm
   3.107 -          [    "idgen(d) = d ==> d ` bot = bot",
   3.108 -               "idgen(d) = d ==> d ` true = true",
   3.109 -               "idgen(d) = d ==> d ` false = false",
   3.110 -               "idgen(d) = d ==> d ` <a,b> = <d ` a,d ` b>",
   3.111 -               "idgen(d) = d ==> d ` (lam x. f(x)) = lam x. d ` f(x)"]
   3.112 -    end;
   3.113 -
   3.114 -(* Proof of Reachability law - show that fix and lam x.x both give LEAST fixed points
   3.115 -                               of idgen and hence are they same *)
   3.116 -
   3.117 -val [p1,p2,p3] = goal (the_context ())
   3.118 -    "[| ALL x. t ` x [= u ` x;  EX f. t=lam x. f(x);  EX f. u=lam x. f(x) |] ==> t [= u";
   3.119 -by (stac (p2 RS cond_eta) 1);
   3.120 -by (stac (p3 RS cond_eta) 1);
   3.121 -by (rtac (p1 RS (po_lam RS iffD2)) 1);
   3.122 -qed "po_eta";
   3.123 -
   3.124 -val [prem] = goalw (the_context ()) [idgen_def] "idgen(d) = d ==> d = lam x.?f(x)";
   3.125 -by (rtac (prem RS subst) 1);
   3.126 -by (rtac refl 1);
   3.127 -qed "po_eta_lemma";
   3.128 -
   3.129 -val [prem] = goal (the_context ())
   3.130 -    "idgen(d) = d ==> \
   3.131 -\      {p. EX a b. p=<a,b> & (EX t. a=fix(idgen) ` t & b = d ` t)} <=   \
   3.132 -\      POgen({p. EX a b. p=<a,b> & (EX t. a=fix(idgen) ` t  & b = d ` t)})";
   3.133 -by (REPEAT (step_tac term_cs 1));
   3.134 -by (term_case_tac "t" 1);
   3.135 -by (ALLGOALS (simp_tac (term_ss addsimps (POgenXH::([prem,fix_idgenfp] RL idgen_lemmas)))));
   3.136 -by (ALLGOALS (fast_tac set_cs));
   3.137 -qed "lemma1";
   3.138 -
   3.139 -val [prem] = goal (the_context ())
   3.140 -    "idgen(d) = d ==> fix(idgen) [= d";
   3.141 -by (rtac (allI RS po_eta) 1);
   3.142 -by (rtac (lemma1 RSN(2,po_coinduct)) 1);
   3.143 -by (ALLGOALS (fast_tac (term_cs addIs [prem,po_eta_lemma,fix_idgenfp])));
   3.144 -qed "fix_least_idgen";
   3.145 -
   3.146 -val [prem] = goal (the_context ())
   3.147 -    "idgen(d) = d ==> \
   3.148 -\      {p. EX a b. p=<a,b> & b = d ` a} <= POgen({p. EX a b. p=<a,b> & b = d ` a})";
   3.149 -by (REPEAT (step_tac term_cs 1));
   3.150 -by (term_case_tac "a" 1);
   3.151 -by (ALLGOALS (simp_tac (term_ss addsimps (POgenXH::([prem] RL idgen_lemmas)))));
   3.152 -by (ALLGOALS (fast_tac set_cs));
   3.153 -qed "lemma2";
   3.154 -
   3.155 -val [prem] = goal (the_context ())
   3.156 -    "idgen(d) = d ==> lam x. x [= d";
   3.157 -by (rtac (allI RS po_eta) 1);
   3.158 -by (rtac (lemma2 RSN(2,po_coinduct)) 1);
   3.159 -by (simp_tac term_ss 1);
   3.160 -by (ALLGOALS (fast_tac (term_cs addIs [prem,po_eta_lemma,fix_idgenfp])));
   3.161 -qed "id_least_idgen";
   3.162 -
   3.163 -Goal  "fix(idgen) = lam x. x";
   3.164 -by (fast_tac (term_cs addIs [eq_iff RS iffD2,
   3.165 -                             id_idgenfp RS fix_least_idgen,
   3.166 -                             fix_idgenfp RS id_least_idgen]) 1);
   3.167 -qed "reachability";
   3.168 -
   3.169 -(********)
   3.170 -
   3.171 -val [prem] = goal (the_context ()) "f = lam x. x ==> f`t = t";
   3.172 -by (rtac (prem RS sym RS subst) 1);
   3.173 -by (rtac applyB 1);
   3.174 -qed "id_apply";
   3.175 -
   3.176 -val prems = goal (the_context ())
   3.177 -     "[| P(bot);  P(true);  P(false);  \
   3.178 -\        !!x y.[| P(x);  P(y) |] ==> P(<x,y>);  \
   3.179 -\        !!u.(!!x. P(u(x))) ==> P(lam x. u(x));  INCL(P) |] ==> \
   3.180 -\     P(t)";
   3.181 -by (rtac (reachability RS id_apply RS subst) 1);
   3.182 -by (res_inst_tac [("x","t")] spec 1);
   3.183 -by (rtac fix_ind 1);
   3.184 -by (rewtac idgen_def);
   3.185 -by (REPEAT_SOME (ares_tac [allI]));
   3.186 -by (stac applyBbot 1);
   3.187 -by (resolve_tac prems 1);
   3.188 -by (rtac (applyB RS ssubst) 1);
   3.189 -by (res_inst_tac [("t","xa")] term_case 1);
   3.190 -by (ALLGOALS (simp_tac term_ss));
   3.191 -by (ALLGOALS (fast_tac (term_cs addIs ([all_INCL,INCL_subst] @ prems))));
   3.192 -qed "term_ind";
     4.1 --- a/src/CCL/Fix.thy	Mon Jul 17 18:42:38 2006 +0200
     4.2 +++ b/src/CCL/Fix.thy	Tue Jul 18 02:22:38 2006 +0200
     4.3 @@ -22,6 +22,181 @@
     4.4    po_INCL:    "INCL(%x. a(x) [= b(x))"
     4.5    INCL_subst: "INCL(P) ==> INCL(%x. P((g::i=>i)(x)))"
     4.6  
     4.7 -ML {* use_legacy_bindings (the_context ()) *}
     4.8 +
     4.9 +subsection {* Fixed Point Induction *}
    4.10 +
    4.11 +lemma fix_ind:
    4.12 +  assumes base: "P(bot)"
    4.13 +    and step: "!!x. P(x) ==> P(f(x))"
    4.14 +    and incl: "INCL(P)"
    4.15 +  shows "P(fix(f))"
    4.16 +  apply (rule incl [unfolded INCL_def, rule_format])
    4.17 +  apply (rule Nat_ind [THEN ballI], assumption)
    4.18 +   apply simp_all
    4.19 +   apply (rule base)
    4.20 +  apply (erule step)
    4.21 +  done
    4.22 +
    4.23 +
    4.24 +subsection {* Inclusive Predicates *}
    4.25 +
    4.26 +lemma inclXH: "INCL(P) <-> (ALL f. (ALL n:Nat. P(f ^ n ` bot)) --> P(fix(f)))"
    4.27 +  by (simp add: INCL_def)
    4.28 +
    4.29 +lemma inclI: "[| !!f. ALL n:Nat. P(f^n`bot) ==> P(fix(f)) |] ==> INCL(%x. P(x))"
    4.30 +  unfolding inclXH by blast
    4.31 +
    4.32 +lemma inclD: "[| INCL(P);  !!n. n:Nat ==> P(f^n`bot) |] ==> P(fix(f))"
    4.33 +  unfolding inclXH by blast
    4.34 +
    4.35 +lemma inclE: "[| INCL(P);  (ALL n:Nat. P(f^n`bot))-->P(fix(f)) ==> R |] ==> R"
    4.36 +  by (blast dest: inclD)
    4.37 +
    4.38 +
    4.39 +subsection {* Lemmas for Inclusive Predicates *}
    4.40 +
    4.41 +lemma npo_INCL: "INCL(%x.~ a(x) [= t)"
    4.42 +  apply (rule inclI)
    4.43 +  apply (drule bspec)
    4.44 +   apply (rule zeroT)
    4.45 +  apply (erule contrapos)
    4.46 +  apply (rule po_trans)
    4.47 +   prefer 2
    4.48 +   apply assumption
    4.49 +  apply (subst napplyBzero)
    4.50 +  apply (rule po_cong, rule po_bot)
    4.51 +  done
    4.52 +
    4.53 +lemma conj_INCL: "[| INCL(P);  INCL(Q) |] ==> INCL(%x. P(x) & Q(x))"
    4.54 +  by (blast intro!: inclI dest!: inclD)
    4.55 +
    4.56 +lemma all_INCL: "[| !!a. INCL(P(a)) |] ==> INCL(%x. ALL a. P(a,x))"
    4.57 +  by (blast intro!: inclI dest!: inclD)
    4.58 +
    4.59 +lemma ball_INCL: "[| !!a. a:A ==> INCL(P(a)) |] ==> INCL(%x. ALL a:A. P(a,x))"
    4.60 +  by (blast intro!: inclI dest!: inclD)
    4.61 +
    4.62 +lemma eq_INCL: "INCL(%x. a(x) = (b(x)::'a::prog))"
    4.63 +  apply (simp add: eq_iff)
    4.64 +  apply (rule conj_INCL po_INCL)+
    4.65 +  done
    4.66 +
    4.67 +
    4.68 +subsection {* Derivation of Reachability Condition *}
    4.69 +
    4.70 +(* Fixed points of idgen *)
    4.71 +
    4.72 +lemma fix_idgenfp: "idgen(fix(idgen)) = fix(idgen)"
    4.73 +  apply (rule fixB [symmetric])
    4.74 +  done
    4.75 +
    4.76 +lemma id_idgenfp: "idgen(lam x. x) = lam x. x"
    4.77 +  apply (simp add: idgen_def)
    4.78 +  apply (rule term_case [THEN allI])
    4.79 +      apply simp_all
    4.80 +  done
    4.81 +
    4.82 +(* All fixed points are lam-expressions *)
    4.83 +
    4.84 +lemma idgenfp_lam: "idgen(d) = d ==> d = lam x. ?f(x)"
    4.85 +  apply (unfold idgen_def)
    4.86 +  apply (erule ssubst)
    4.87 +  apply (rule refl)
    4.88 +  done
    4.89 +
    4.90 +(* Lemmas for rewriting fixed points of idgen *)
    4.91 +
    4.92 +lemma l_lemma: "[| a = b;  a ` t = u |] ==> b ` t = u"
    4.93 +  by (simp add: idgen_def)
    4.94 +
    4.95 +lemma idgen_lemmas:
    4.96 +  "idgen(d) = d ==> d ` bot = bot"
    4.97 +  "idgen(d) = d ==> d ` true = true"
    4.98 +  "idgen(d) = d ==> d ` false = false"
    4.99 +  "idgen(d) = d ==> d ` <a,b> = <d ` a,d ` b>"
   4.100 +  "idgen(d) = d ==> d ` (lam x. f(x)) = lam x. d ` f(x)"
   4.101 +  by (erule l_lemma, simp add: idgen_def)+
   4.102 +
   4.103 +
   4.104 +(* Proof of Reachability law - show that fix and lam x.x both give LEAST fixed points
   4.105 +  of idgen and hence are they same *)
   4.106 +
   4.107 +lemma po_eta:
   4.108 +  "[| ALL x. t ` x [= u ` x;  EX f. t=lam x. f(x);  EX f. u=lam x. f(x) |] ==> t [= u"
   4.109 +  apply (drule cond_eta)+
   4.110 +  apply (erule ssubst)
   4.111 +  apply (erule ssubst)
   4.112 +  apply (rule po_lam [THEN iffD2])
   4.113 +  apply simp
   4.114 +  done
   4.115 +
   4.116 +lemma po_eta_lemma: "idgen(d) = d ==> d = lam x. ?f(x)"
   4.117 +  apply (unfold idgen_def)
   4.118 +  apply (erule sym)
   4.119 +  done
   4.120 +
   4.121 +lemma lemma1:
   4.122 +  "idgen(d) = d ==>
   4.123 +    {p. EX a b. p=<a,b> & (EX t. a=fix(idgen) ` t & b = d ` t)} <=
   4.124 +      POgen({p. EX a b. p=<a,b> & (EX t. a=fix(idgen) ` t  & b = d ` t)})"
   4.125 +  apply clarify
   4.126 +  apply (rule_tac t = t in term_case)
   4.127 +      apply (simp_all add: POgenXH idgen_lemmas idgen_lemmas [OF fix_idgenfp])
   4.128 +   apply blast
   4.129 +  apply fast
   4.130 +  done
   4.131 +
   4.132 +lemma fix_least_idgen: "idgen(d) = d ==> fix(idgen) [= d"
   4.133 +  apply (rule allI [THEN po_eta])
   4.134 +    apply (rule lemma1 [THEN [2] po_coinduct])
   4.135 +     apply (blast intro: po_eta_lemma fix_idgenfp)+
   4.136 +  done
   4.137 +
   4.138 +lemma lemma2:
   4.139 +  "idgen(d) = d ==>
   4.140 +    {p. EX a b. p=<a,b> & b = d ` a} <= POgen({p. EX a b. p=<a,b> & b = d ` a})"
   4.141 +  apply clarify
   4.142 +  apply (rule_tac t = a in term_case)
   4.143 +      apply (simp_all add: POgenXH idgen_lemmas)
   4.144 +  apply fast
   4.145 +  done
   4.146 +
   4.147 +lemma id_least_idgen: "idgen(d) = d ==> lam x. x [= d"
   4.148 +  apply (rule allI [THEN po_eta])
   4.149 +    apply (rule lemma2 [THEN [2] po_coinduct])
   4.150 +     apply simp
   4.151 +    apply (fast intro: po_eta_lemma fix_idgenfp)+
   4.152 +  done
   4.153 +
   4.154 +lemma reachability: "fix(idgen) = lam x. x"
   4.155 +  apply (fast intro: eq_iff [THEN iffD2]
   4.156 +    id_idgenfp [THEN fix_least_idgen] fix_idgenfp [THEN id_least_idgen])
   4.157 +  done
   4.158 +
   4.159 +(********)
   4.160 +
   4.161 +lemma id_apply: "f = lam x. x ==> f`t = t"
   4.162 +  apply (erule ssubst)
   4.163 +  apply (rule applyB)
   4.164 +  done
   4.165 +
   4.166 +lemma term_ind:
   4.167 +  assumes "P(bot)" "P(true)" "P(false)"
   4.168 +    "!!x y.[| P(x);  P(y) |] ==> P(<x,y>)"
   4.169 +    "!!u.(!!x. P(u(x))) ==> P(lam x. u(x))"  "INCL(P)"
   4.170 +  shows "P(t)"
   4.171 +  apply (rule reachability [THEN id_apply, THEN subst])
   4.172 +  apply (rule_tac x = t in spec)
   4.173 +  apply (rule fix_ind)
   4.174 +    apply (unfold idgen_def)
   4.175 +    apply (rule allI)
   4.176 +    apply (subst applyBbot)
   4.177 +    apply assumption
   4.178 +   apply (rule allI)
   4.179 +   apply (rule applyB [THEN ssubst])
   4.180 +    apply (rule_tac t = "xa" in term_case)
   4.181 +       apply simp_all
   4.182 +       apply (fast intro: prems INCL_subst all_INCL)+
   4.183 +  done
   4.184  
   4.185  end
     5.1 --- a/src/CCL/Gfp.ML	Mon Jul 17 18:42:38 2006 +0200
     5.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3 @@ -1,125 +0,0 @@
     5.4 -(*  Title:      CCL/Gfp.ML
     5.5 -    ID:         $Id$
     5.6 -*)
     5.7 -
     5.8 -(*** Proof of Knaster-Tarski Theorem using gfp ***)
     5.9 -
    5.10 -(* gfp(f) is the least upper bound of {u. u <= f(u)} *)
    5.11 -
    5.12 -val prems = goalw (the_context ()) [gfp_def] "[| A <= f(A) |] ==> A <= gfp(f)";
    5.13 -by (rtac (CollectI RS Union_upper) 1);
    5.14 -by (resolve_tac prems 1);
    5.15 -qed "gfp_upperbound";
    5.16 -
    5.17 -val prems = goalw (the_context ()) [gfp_def]
    5.18 -    "[| !!u. u <= f(u) ==> u<=A |] ==> gfp(f) <= A";
    5.19 -by (REPEAT (ares_tac ([Union_least]@prems) 1));
    5.20 -by (etac CollectD 1);
    5.21 -qed "gfp_least";
    5.22 -
    5.23 -val [mono] = goal (the_context ()) "mono(f) ==> gfp(f) <= f(gfp(f))";
    5.24 -by (EVERY1 [rtac gfp_least, rtac subset_trans, atac,
    5.25 -            rtac (mono RS monoD), rtac gfp_upperbound, atac]);
    5.26 -qed "gfp_lemma2";
    5.27 -
    5.28 -val [mono] = goal (the_context ()) "mono(f) ==> f(gfp(f)) <= gfp(f)";
    5.29 -by (EVERY1 [rtac gfp_upperbound, rtac (mono RS monoD), 
    5.30 -            rtac gfp_lemma2, rtac mono]);
    5.31 -qed "gfp_lemma3";
    5.32 -
    5.33 -val [mono] = goal (the_context ()) "mono(f) ==> gfp(f) = f(gfp(f))";
    5.34 -by (REPEAT (resolve_tac [equalityI,gfp_lemma2,gfp_lemma3,mono] 1));
    5.35 -qed "gfp_Tarski";
    5.36 -
    5.37 -(*** Coinduction rules for greatest fixed points ***)
    5.38 -
    5.39 -(*weak version*)
    5.40 -val prems = goal (the_context ())
    5.41 -    "[| a: A;  A <= f(A) |] ==> a : gfp(f)";
    5.42 -by (rtac (gfp_upperbound RS subsetD) 1);
    5.43 -by (REPEAT (ares_tac prems 1));
    5.44 -qed "coinduct";
    5.45 -
    5.46 -val [prem,mono] = goal (the_context ())
    5.47 -    "[| A <= f(A) Un gfp(f);  mono(f) |] ==>  \
    5.48 -\    A Un gfp(f) <= f(A Un gfp(f))";
    5.49 -by (rtac subset_trans 1);
    5.50 -by (rtac (mono RS mono_Un) 2);
    5.51 -by (rtac (mono RS gfp_Tarski RS subst) 1);
    5.52 -by (rtac (prem RS Un_least) 1);
    5.53 -by (rtac Un_upper2 1);
    5.54 -qed "coinduct2_lemma";
    5.55 -
    5.56 -(*strong version, thanks to Martin Coen*)
    5.57 -val ainA::prems = goal (the_context ())
    5.58 -    "[| a: A;  A <= f(A) Un gfp(f);  mono(f) |] ==> a : gfp(f)";
    5.59 -by (rtac coinduct 1);
    5.60 -by (rtac (prems MRS coinduct2_lemma) 2);
    5.61 -by (resolve_tac [ainA RS UnI1] 1);
    5.62 -qed "coinduct2";
    5.63 -
    5.64 -(***  Even Stronger version of coinduct  [by Martin Coen]
    5.65 -         - instead of the condition  A <= f(A)
    5.66 -                           consider  A <= (f(A) Un f(f(A)) ...) Un gfp(A) ***)
    5.67 -
    5.68 -val [prem] = goal (the_context ()) "mono(f) ==> mono(%x. f(x) Un A Un B)";
    5.69 -by (REPEAT (ares_tac [subset_refl, monoI, Un_mono, prem RS monoD] 1));
    5.70 -qed "coinduct3_mono_lemma";
    5.71 -
    5.72 -val [prem,mono] = goal (the_context ())
    5.73 -    "[| A <= f(lfp(%x. f(x) Un A Un gfp(f)));  mono(f) |] ==> \
    5.74 -\    lfp(%x. f(x) Un A Un gfp(f)) <= f(lfp(%x. f(x) Un A Un gfp(f)))";
    5.75 -by (rtac subset_trans 1);
    5.76 -by (rtac (mono RS coinduct3_mono_lemma RS lfp_lemma3) 1);
    5.77 -by (rtac (Un_least RS Un_least) 1);
    5.78 -by (rtac subset_refl 1);
    5.79 -by (rtac prem 1);
    5.80 -by (rtac (mono RS gfp_Tarski RS equalityD1 RS subset_trans) 1);
    5.81 -by (rtac (mono RS monoD) 1);
    5.82 -by (stac (mono RS coinduct3_mono_lemma RS lfp_Tarski) 1);
    5.83 -by (rtac Un_upper2 1);
    5.84 -qed "coinduct3_lemma";
    5.85 -
    5.86 -val ainA::prems = goal (the_context ())
    5.87 -    "[| a:A;  A <= f(lfp(%x. f(x) Un A Un gfp(f))); mono(f) |] ==> a : gfp(f)";
    5.88 -by (rtac coinduct 1);
    5.89 -by (rtac (prems MRS coinduct3_lemma) 2);
    5.90 -by (resolve_tac (prems RL [coinduct3_mono_lemma RS lfp_Tarski RS ssubst]) 1);
    5.91 -by (rtac (ainA RS UnI2 RS UnI1) 1);
    5.92 -qed "coinduct3";
    5.93 -
    5.94 -
    5.95 -(** Definition forms of gfp_Tarski, to control unfolding **)
    5.96 -
    5.97 -val [rew,mono] = goal (the_context ()) "[| h==gfp(f);  mono(f) |] ==> h = f(h)";
    5.98 -by (rewtac rew);
    5.99 -by (rtac (mono RS gfp_Tarski) 1);
   5.100 -qed "def_gfp_Tarski";
   5.101 -
   5.102 -val rew::prems = goal (the_context ())
   5.103 -    "[| h==gfp(f);  a:A;  A <= f(A) |] ==> a: h";
   5.104 -by (rewtac rew);
   5.105 -by (REPEAT (ares_tac (prems @ [coinduct]) 1));
   5.106 -qed "def_coinduct";
   5.107 -
   5.108 -val rew::prems = goal (the_context ())
   5.109 -    "[| h==gfp(f);  a:A;  A <= f(A) Un h; mono(f) |] ==> a: h";
   5.110 -by (rewtac rew);
   5.111 -by (REPEAT (ares_tac (map (rewrite_rule [rew]) prems @ [coinduct2]) 1));
   5.112 -qed "def_coinduct2";
   5.113 -
   5.114 -val rew::prems = goal (the_context ())
   5.115 -    "[| h==gfp(f);  a:A;  A <= f(lfp(%x. f(x) Un A Un h)); mono(f) |] ==> a: h";
   5.116 -by (rewtac rew);
   5.117 -by (REPEAT (ares_tac (map (rewrite_rule [rew]) prems @ [coinduct3]) 1));
   5.118 -qed "def_coinduct3";
   5.119 -
   5.120 -(*Monotonicity of gfp!*)
   5.121 -val prems = goal (the_context ())
   5.122 -    "[| mono(f);  !!Z. f(Z)<=g(Z) |] ==> gfp(f) <= gfp(g)";
   5.123 -by (rtac gfp_upperbound 1);
   5.124 -by (rtac subset_trans 1);
   5.125 -by (rtac gfp_lemma2 1);
   5.126 -by (resolve_tac prems 1);
   5.127 -by (resolve_tac prems 1);
   5.128 -qed "gfp_mono";
     6.1 --- a/src/CCL/Gfp.thy	Mon Jul 17 18:42:38 2006 +0200
     6.2 +++ b/src/CCL/Gfp.thy	Tue Jul 18 02:22:38 2006 +0200
     6.3 @@ -10,10 +10,124 @@
     6.4  imports Lfp
     6.5  begin
     6.6  
     6.7 -constdefs
     6.8 +definition
     6.9    gfp :: "['a set=>'a set] => 'a set"    (*greatest fixed point*)
    6.10    "gfp(f) == Union({u. u <= f(u)})"
    6.11  
    6.12 -ML {* use_legacy_bindings (the_context ()) *}
    6.13 +(* gfp(f) is the least upper bound of {u. u <= f(u)} *)
    6.14 +
    6.15 +lemma gfp_upperbound: "[| A <= f(A) |] ==> A <= gfp(f)"
    6.16 +  unfolding gfp_def by blast
    6.17 +
    6.18 +lemma gfp_least: "[| !!u. u <= f(u) ==> u<=A |] ==> gfp(f) <= A"
    6.19 +  unfolding gfp_def by blast
    6.20 +
    6.21 +lemma gfp_lemma2: "mono(f) ==> gfp(f) <= f(gfp(f))"
    6.22 +  by (rule gfp_least, rule subset_trans, assumption, erule monoD,
    6.23 +    rule gfp_upperbound, assumption)
    6.24 +
    6.25 +lemma gfp_lemma3: "mono(f) ==> f(gfp(f)) <= gfp(f)"
    6.26 +  by (rule gfp_upperbound, frule monoD, rule gfp_lemma2, assumption+)
    6.27 +
    6.28 +lemma gfp_Tarski: "mono(f) ==> gfp(f) = f(gfp(f))"
    6.29 +  by (rule equalityI gfp_lemma2 gfp_lemma3 | assumption)+
    6.30 +
    6.31 +
    6.32 +(*** Coinduction rules for greatest fixed points ***)
    6.33 +
    6.34 +(*weak version*)
    6.35 +lemma coinduct: "[| a: A;  A <= f(A) |] ==> a : gfp(f)"
    6.36 +  by (blast dest: gfp_upperbound)
    6.37 +
    6.38 +lemma coinduct2_lemma:
    6.39 +  "[| A <= f(A) Un gfp(f);  mono(f) |] ==>   
    6.40 +    A Un gfp(f) <= f(A Un gfp(f))"
    6.41 +  apply (rule subset_trans)
    6.42 +   prefer 2
    6.43 +   apply (erule mono_Un)
    6.44 +  apply (rule subst, erule gfp_Tarski)
    6.45 +  apply (erule Un_least)
    6.46 +  apply (rule Un_upper2)
    6.47 +  done
    6.48 +
    6.49 +(*strong version, thanks to Martin Coen*)
    6.50 +lemma coinduct2:
    6.51 +  "[| a: A;  A <= f(A) Un gfp(f);  mono(f) |] ==> a : gfp(f)"
    6.52 +  apply (rule coinduct)
    6.53 +   prefer 2
    6.54 +   apply (erule coinduct2_lemma, assumption)
    6.55 +  apply blast
    6.56 +  done
    6.57 +
    6.58 +(***  Even Stronger version of coinduct  [by Martin Coen]
    6.59 +         - instead of the condition  A <= f(A)
    6.60 +                           consider  A <= (f(A) Un f(f(A)) ...) Un gfp(A) ***)
    6.61 +
    6.62 +lemma coinduct3_mono_lemma: "mono(f) ==> mono(%x. f(x) Un A Un B)"
    6.63 +  by (rule monoI) (blast dest: monoD)
    6.64 +
    6.65 +lemma coinduct3_lemma:
    6.66 +  assumes prem: "A <= f(lfp(%x. f(x) Un A Un gfp(f)))"
    6.67 +    and mono: "mono(f)"
    6.68 +  shows "lfp(%x. f(x) Un A Un gfp(f)) <= f(lfp(%x. f(x) Un A Un gfp(f)))"
    6.69 +  apply (rule subset_trans)
    6.70 +   apply (rule mono [THEN coinduct3_mono_lemma, THEN lfp_lemma3])
    6.71 +  apply (rule Un_least [THEN Un_least])
    6.72 +    apply (rule subset_refl)
    6.73 +   apply (rule prem)
    6.74 +  apply (rule mono [THEN gfp_Tarski, THEN equalityD1, THEN subset_trans])
    6.75 +  apply (rule mono [THEN monoD])
    6.76 +  apply (subst mono [THEN coinduct3_mono_lemma, THEN lfp_Tarski])
    6.77 +  apply (rule Un_upper2)
    6.78 +  done
    6.79 +
    6.80 +lemma coinduct3:
    6.81 +  assumes 1: "a:A"
    6.82 +    and 2: "A <= f(lfp(%x. f(x) Un A Un gfp(f)))"
    6.83 +    and 3: "mono(f)"
    6.84 +  shows "a : gfp(f)"
    6.85 +  apply (rule coinduct)
    6.86 +   prefer 2
    6.87 +   apply (rule coinduct3_lemma [OF 2 3])
    6.88 +  apply (subst lfp_Tarski [OF coinduct3_mono_lemma, OF 3])
    6.89 +  using 1 apply blast
    6.90 +  done
    6.91 +
    6.92 +
    6.93 +subsection {* Definition forms of @{text "gfp_Tarski"}, to control unfolding *}
    6.94 +
    6.95 +lemma def_gfp_Tarski: "[| h==gfp(f);  mono(f) |] ==> h = f(h)"
    6.96 +  apply unfold
    6.97 +  apply (erule gfp_Tarski)
    6.98 +  done
    6.99 +
   6.100 +lemma def_coinduct: "[| h==gfp(f);  a:A;  A <= f(A) |] ==> a: h"
   6.101 +  apply unfold
   6.102 +  apply (erule coinduct)
   6.103 +  apply assumption
   6.104 +  done
   6.105 +
   6.106 +lemma def_coinduct2: "[| h==gfp(f);  a:A;  A <= f(A) Un h; mono(f) |] ==> a: h"
   6.107 +  apply unfold
   6.108 +  apply (erule coinduct2)
   6.109 +   apply assumption
   6.110 +  apply assumption
   6.111 +  done
   6.112 +
   6.113 +lemma def_coinduct3: "[| h==gfp(f);  a:A;  A <= f(lfp(%x. f(x) Un A Un h)); mono(f) |] ==> a: h"
   6.114 +  apply unfold
   6.115 +  apply (erule coinduct3)
   6.116 +   apply assumption
   6.117 +  apply assumption
   6.118 +  done
   6.119 +
   6.120 +(*Monotonicity of gfp!*)
   6.121 +lemma gfp_mono: "[| mono(f);  !!Z. f(Z)<=g(Z) |] ==> gfp(f) <= gfp(g)"
   6.122 +  apply (rule gfp_upperbound)
   6.123 +  apply (rule subset_trans)
   6.124 +   apply (rule gfp_lemma2)
   6.125 +   apply assumption
   6.126 +  apply (erule meta_spec)
   6.127 +  done
   6.128  
   6.129  end
     7.1 --- a/src/CCL/Hered.ML	Mon Jul 17 18:42:38 2006 +0200
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,190 +0,0 @@
     7.4 -(*  Title:      CCL/Hered.ML
     7.5 -    ID:         $Id$
     7.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
     7.7 -    Copyright   1993  University of Cambridge
     7.8 -*)
     7.9 -
    7.10 -fun type_of_terms (Const("Trueprop",_) $ (Const("op =",(Type ("fun", [t,_])))$_$_)) = t;
    7.11 -
    7.12 -(*** Hereditary Termination ***)
    7.13 -
    7.14 -Goalw [HTTgen_def]  "mono(%X. HTTgen(X))";
    7.15 -by (rtac monoI 1);
    7.16 -by (fast_tac set_cs 1);
    7.17 -qed "HTTgen_mono";
    7.18 -
    7.19 -Goalw [HTTgen_def]
    7.20 -  "t : HTTgen(A) <-> t=true | t=false | (EX a b. t=<a,b> & a : A & b : A) | \
    7.21 -\                                       (EX f. t=lam x. f(x) & (ALL x. f(x) : A))";
    7.22 -by (fast_tac set_cs 1);
    7.23 -qed "HTTgenXH";
    7.24 -
    7.25 -Goal
    7.26 -  "t : HTT <-> t=true | t=false | (EX a b. t=<a,b> & a : HTT & b : HTT) | \
    7.27 -\                                  (EX f. t=lam x. f(x) & (ALL x. f(x) : HTT))";
    7.28 -by (rtac (rewrite_rule [HTTgen_def]
    7.29 -                 (HTTgen_mono RS (HTT_def RS def_gfp_Tarski) RS XHlemma1)) 1);
    7.30 -by (fast_tac set_cs 1);
    7.31 -qed "HTTXH";
    7.32 -
    7.33 -(*** Introduction Rules for HTT ***)
    7.34 -
    7.35 -Goal "~ bot : HTT";
    7.36 -by (fast_tac (term_cs addDs [XH_to_D HTTXH]) 1);
    7.37 -qed "HTT_bot";
    7.38 -
    7.39 -Goal "true : HTT";
    7.40 -by (fast_tac (term_cs addIs [XH_to_I HTTXH]) 1);
    7.41 -qed "HTT_true";
    7.42 -
    7.43 -Goal "false : HTT";
    7.44 -by (fast_tac (term_cs addIs [XH_to_I HTTXH]) 1);
    7.45 -qed "HTT_false";
    7.46 -
    7.47 -Goal "<a,b> : HTT <->  a : HTT  & b : HTT";
    7.48 -by (rtac (HTTXH RS iff_trans) 1);
    7.49 -by (fast_tac term_cs 1);
    7.50 -qed "HTT_pair";
    7.51 -
    7.52 -Goal "lam x. f(x) : HTT <-> (ALL x. f(x) : HTT)";
    7.53 -by (rtac (HTTXH RS iff_trans) 1);
    7.54 -by (simp_tac term_ss 1);
    7.55 -by (safe_tac term_cs);
    7.56 -by (asm_simp_tac term_ss 1);
    7.57 -by (fast_tac term_cs 1);
    7.58 -qed "HTT_lam";
    7.59 -
    7.60 -local
    7.61 -  val raw_HTTrews = [HTT_bot,HTT_true,HTT_false,HTT_pair,HTT_lam];
    7.62 -  fun mk_thm s = prove_goalw (the_context ()) data_defs s (fn _ =>
    7.63 -                  [simp_tac (term_ss addsimps raw_HTTrews) 1]);
    7.64 -in
    7.65 -  val HTT_rews = raw_HTTrews @
    7.66 -               map mk_thm ["one : HTT",
    7.67 -                           "inl(a) : HTT <-> a : HTT",
    7.68 -                           "inr(b) : HTT <-> b : HTT",
    7.69 -                           "zero : HTT",
    7.70 -                           "succ(n) : HTT <-> n : HTT",
    7.71 -                           "[] : HTT",
    7.72 -                           "x$xs : HTT <-> x : HTT & xs : HTT"];
    7.73 -end;
    7.74 -
    7.75 -val HTT_Is = HTT_rews @ (HTT_rews RL [iffD2]);
    7.76 -
    7.77 -(*** Coinduction for HTT ***)
    7.78 -
    7.79 -val prems = goal (the_context ()) "[|  t : R;  R <= HTTgen(R) |] ==> t : HTT";
    7.80 -by (rtac (HTT_def RS def_coinduct) 1);
    7.81 -by (REPEAT (ares_tac prems 1));
    7.82 -qed "HTT_coinduct";
    7.83 -
    7.84 -fun HTT_coinduct_tac s i = res_inst_tac [("R",s)] HTT_coinduct i;
    7.85 -
    7.86 -val prems = goal (the_context ())
    7.87 -    "[|  t : R;   R <= HTTgen(lfp(%x. HTTgen(x) Un R Un HTT)) |] ==> t : HTT";
    7.88 -by (rtac (HTTgen_mono RSN(3,HTT_def RS def_coinduct3)) 1);
    7.89 -by (REPEAT (ares_tac prems 1));
    7.90 -qed "HTT_coinduct3";
    7.91 -val HTT_coinduct3_raw = rewrite_rule [HTTgen_def] HTT_coinduct3;
    7.92 -
    7.93 -fun HTT_coinduct3_tac s i = res_inst_tac [("R",s)] HTT_coinduct3 i;
    7.94 -
    7.95 -val HTTgenIs = map (mk_genIs (the_context ()) data_defs HTTgenXH HTTgen_mono)
    7.96 -       ["true : HTTgen(R)",
    7.97 -        "false : HTTgen(R)",
    7.98 -        "[| a : R;  b : R |] ==> <a,b> : HTTgen(R)",
    7.99 -        "[| !!x. b(x) : R |] ==> lam x. b(x) : HTTgen(R)",
   7.100 -        "one : HTTgen(R)",
   7.101 -        "a : lfp(%x. HTTgen(x) Un R Un HTT) ==> \
   7.102 -\                         inl(a) : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   7.103 -        "b : lfp(%x. HTTgen(x) Un R Un HTT) ==> \
   7.104 -\                         inr(b) : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   7.105 -        "zero : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   7.106 -        "n : lfp(%x. HTTgen(x) Un R Un HTT) ==> \
   7.107 -\                         succ(n) : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   7.108 -        "[] : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   7.109 -        "[| h : lfp(%x. HTTgen(x) Un R Un HTT); t : lfp(%x. HTTgen(x) Un R Un HTT) |] ==>\
   7.110 -\                         h$t : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))"];
   7.111 -
   7.112 -(*** Formation Rules for Types ***)
   7.113 -
   7.114 -Goal "Unit <= HTT";
   7.115 -by (simp_tac (CCL_ss addsimps ([subsetXH,UnitXH] @ HTT_rews)) 1);
   7.116 -qed "UnitF";
   7.117 -
   7.118 -Goal "Bool <= HTT";
   7.119 -by (simp_tac (CCL_ss addsimps ([subsetXH,BoolXH] @ HTT_rews)) 1);
   7.120 -by (fast_tac (set_cs addIs HTT_Is @ (prems RL [subsetD])) 1);
   7.121 -qed "BoolF";
   7.122 -
   7.123 -val prems = goal (the_context ()) "[| A <= HTT;  B <= HTT |] ==> A + B  <= HTT";
   7.124 -by (simp_tac (CCL_ss addsimps ([subsetXH,PlusXH] @ HTT_rews)) 1);
   7.125 -by (fast_tac (set_cs addIs HTT_Is @ (prems RL [subsetD])) 1);
   7.126 -qed "PlusF";
   7.127 -
   7.128 -val prems = goal (the_context ())
   7.129 -     "[| A <= HTT;  !!x. x:A ==> B(x) <= HTT |] ==> SUM x:A. B(x) <= HTT";
   7.130 -by (simp_tac (CCL_ss addsimps ([subsetXH,SgXH] @ HTT_rews)) 1);
   7.131 -by (fast_tac (set_cs addIs HTT_Is @ (prems RL [subsetD])) 1);
   7.132 -qed "SigmaF";
   7.133 -
   7.134 -(*** Formation Rules for Recursive types - using coinduction these only need ***)
   7.135 -(***                                          exhaution rule for type-former ***)
   7.136 -
   7.137 -(*Proof by induction - needs induction rule for type*)
   7.138 -Goal "Nat <= HTT";
   7.139 -by (simp_tac (term_ss addsimps [subsetXH]) 1);
   7.140 -by (safe_tac set_cs);
   7.141 -by (etac Nat_ind 1);
   7.142 -by (ALLGOALS (fast_tac (set_cs addIs HTT_Is @ (prems RL [subsetD]))));
   7.143 -val NatF = result();
   7.144 -
   7.145 -Goal "Nat <= HTT";
   7.146 -by (safe_tac set_cs);
   7.147 -by (etac HTT_coinduct3 1);
   7.148 -by (fast_tac (set_cs addIs HTTgenIs
   7.149 -                 addSEs [HTTgen_mono RS ci3_RI] addEs [XH_to_E NatXH]) 1);
   7.150 -qed "NatF";
   7.151 -
   7.152 -val [prem] = goal (the_context ()) "A <= HTT ==> List(A) <= HTT";
   7.153 -by (safe_tac set_cs);
   7.154 -by (etac HTT_coinduct3 1);
   7.155 -by (fast_tac (set_cs addSIs HTTgenIs
   7.156 -                 addSEs [HTTgen_mono RS ci3_RI,prem RS subsetD RS (HTTgen_mono RS ci3_AI)]
   7.157 -                 addEs [XH_to_E ListXH]) 1);
   7.158 -qed "ListF";
   7.159 -
   7.160 -val [prem] = goal (the_context ()) "A <= HTT ==> Lists(A) <= HTT";
   7.161 -by (safe_tac set_cs);
   7.162 -by (etac HTT_coinduct3 1);
   7.163 -by (fast_tac (set_cs addSIs HTTgenIs
   7.164 -                 addSEs [HTTgen_mono RS ci3_RI,prem RS subsetD RS (HTTgen_mono RS ci3_AI)]
   7.165 -                 addEs [XH_to_E ListsXH]) 1);
   7.166 -qed "ListsF";
   7.167 -
   7.168 -val [prem] = goal (the_context ()) "A <= HTT ==> ILists(A) <= HTT";
   7.169 -by (safe_tac set_cs);
   7.170 -by (etac HTT_coinduct3 1);
   7.171 -by (fast_tac (set_cs addSIs HTTgenIs
   7.172 -                 addSEs [HTTgen_mono RS ci3_RI,prem RS subsetD RS (HTTgen_mono RS ci3_AI)]
   7.173 -                 addEs [XH_to_E IListsXH]) 1);
   7.174 -qed "IListsF";
   7.175 -
   7.176 -(*** A possible use for this predicate is proving equality from pre-order       ***)
   7.177 -(*** but it seems as easy (and more general) to do this directly by coinduction ***)
   7.178 -(*
   7.179 -val prems = goal (the_context ()) "[| t : HTT;  t [= u |] ==> u [= t";
   7.180 -by (po_coinduct_tac "{p. EX a b. p=<a,b> & b : HTT & b [= a}" 1);
   7.181 -by (fast_tac (ccl_cs addIs prems) 1);
   7.182 -by (safe_tac ccl_cs);
   7.183 -by (dtac (poXH RS iffD1) 1);
   7.184 -by (safe_tac (set_cs addSEs [HTT_bot RS notE]));
   7.185 -by (REPEAT_SOME (rtac (POgenXH RS iffD2) ORELSE' etac rev_mp));
   7.186 -by (ALLGOALS (simp_tac (term_ss addsimps HTT_rews)));
   7.187 -by (ALLGOALS (fast_tac ccl_cs));
   7.188 -qed "HTT_po_op";
   7.189 -
   7.190 -val prems = goal (the_context ()) "[| t : HTT;  t [= u |] ==> t = u";
   7.191 -by (REPEAT (ares_tac (prems @ [conjI RS (eq_iff RS iffD2),HTT_po_op]) 1));
   7.192 -qed "HTT_po_eq";
   7.193 -*)
     8.1 --- a/src/CCL/Hered.thy	Mon Jul 17 18:42:38 2006 +0200
     8.2 +++ b/src/CCL/Hered.thy	Tue Jul 18 02:22:38 2006 +0200
     8.3 @@ -8,7 +8,6 @@
     8.4  
     8.5  theory Hered
     8.6  imports Type
     8.7 -uses "coinduction.ML"
     8.8  begin
     8.9  
    8.10  text {*
    8.11 @@ -30,6 +29,166 @@
    8.12                                        (EX f.  t=lam x. f(x) & (ALL x. f(x) : R))}"
    8.13    HTT_def:       "HTT == gfp(HTTgen)"
    8.14  
    8.15 -ML {* use_legacy_bindings (the_context ()) *}
    8.16 +
    8.17 +subsection {* Hereditary Termination *}
    8.18 +
    8.19 +lemma HTTgen_mono: "mono(%X. HTTgen(X))"
    8.20 +  apply (unfold HTTgen_def)
    8.21 +  apply (rule monoI)
    8.22 +  apply blast
    8.23 +  done
    8.24 +
    8.25 +lemma HTTgenXH: 
    8.26 +  "t : HTTgen(A) <-> t=true | t=false | (EX a b. t=<a,b> & a : A & b : A) |  
    8.27 +                                        (EX f. t=lam x. f(x) & (ALL x. f(x) : A))"
    8.28 +  apply (unfold HTTgen_def)
    8.29 +  apply blast
    8.30 +  done
    8.31 +
    8.32 +lemma HTTXH: 
    8.33 +  "t : HTT <-> t=true | t=false | (EX a b. t=<a,b> & a : HTT & b : HTT) |  
    8.34 +                                   (EX f. t=lam x. f(x) & (ALL x. f(x) : HTT))"
    8.35 +  apply (rule HTTgen_mono [THEN HTT_def [THEN def_gfp_Tarski], THEN XHlemma1, unfolded HTTgen_def])
    8.36 +  apply blast
    8.37 +  done
    8.38 +
    8.39 +
    8.40 +subsection {* Introduction Rules for HTT *}
    8.41 +
    8.42 +lemma HTT_bot: "~ bot : HTT"
    8.43 +  by (blast dest: HTTXH [THEN iffD1])
    8.44 +
    8.45 +lemma HTT_true: "true : HTT"
    8.46 +  by (blast intro: HTTXH [THEN iffD2])
    8.47 +
    8.48 +lemma HTT_false: "false : HTT"
    8.49 +  by (blast intro: HTTXH [THEN iffD2])
    8.50 +
    8.51 +lemma HTT_pair: "<a,b> : HTT <->  a : HTT  & b : HTT"
    8.52 +  apply (rule HTTXH [THEN iff_trans])
    8.53 +  apply blast
    8.54 +  done
    8.55 +
    8.56 +lemma HTT_lam: "lam x. f(x) : HTT <-> (ALL x. f(x) : HTT)"
    8.57 +  apply (rule HTTXH [THEN iff_trans])
    8.58 +  apply auto
    8.59 +  done
    8.60 +
    8.61 +lemmas HTT_rews1 = HTT_bot HTT_true HTT_false HTT_pair HTT_lam
    8.62 +
    8.63 +lemma HTT_rews2:
    8.64 +  "one : HTT"
    8.65 +  "inl(a) : HTT <-> a : HTT"
    8.66 +  "inr(b) : HTT <-> b : HTT"
    8.67 +  "zero : HTT"
    8.68 +  "succ(n) : HTT <-> n : HTT"
    8.69 +  "[] : HTT"
    8.70 +  "x$xs : HTT <-> x : HTT & xs : HTT"
    8.71 +  by (simp_all add: data_defs HTT_rews1)
    8.72 +
    8.73 +lemmas HTT_rews = HTT_rews1 HTT_rews2
    8.74 +
    8.75 +
    8.76 +subsection {* Coinduction for HTT *}
    8.77 +
    8.78 +lemma HTT_coinduct: "[|  t : R;  R <= HTTgen(R) |] ==> t : HTT"
    8.79 +  apply (erule HTT_def [THEN def_coinduct])
    8.80 +  apply assumption
    8.81 +  done
    8.82 +
    8.83 +ML {*
    8.84 +  local val HTT_coinduct = thm "HTT_coinduct"
    8.85 +  in fun HTT_coinduct_tac s i = res_inst_tac [("R", s)] HTT_coinduct i end
    8.86 +*}
    8.87 +
    8.88 +lemma HTT_coinduct3:
    8.89 +  "[|  t : R;   R <= HTTgen(lfp(%x. HTTgen(x) Un R Un HTT)) |] ==> t : HTT"
    8.90 +  apply (erule HTTgen_mono [THEN [3] HTT_def [THEN def_coinduct3]])
    8.91 +  apply assumption
    8.92 +  done
    8.93 +
    8.94 +ML {*
    8.95 +local
    8.96 +  val HTT_coinduct3 = thm "HTT_coinduct3"
    8.97 +  val HTTgen_def = thm "HTTgen_def"
    8.98 +in
    8.99 +
   8.100 +val HTT_coinduct3_raw = rewrite_rule [HTTgen_def] HTT_coinduct3
   8.101 +
   8.102 +fun HTT_coinduct3_tac s i = res_inst_tac [("R",s)] HTT_coinduct3 i
   8.103 +
   8.104 +val HTTgenIs =
   8.105 +  map (mk_genIs (the_context ()) (thms "data_defs") (thm "HTTgenXH") (thm "HTTgen_mono"))
   8.106 +  ["true : HTTgen(R)",
   8.107 +   "false : HTTgen(R)",
   8.108 +   "[| a : R;  b : R |] ==> <a,b> : HTTgen(R)",
   8.109 +   "[| !!x. b(x) : R |] ==> lam x. b(x) : HTTgen(R)",
   8.110 +   "one : HTTgen(R)",
   8.111 +   "a : lfp(%x. HTTgen(x) Un R Un HTT) ==> inl(a) : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   8.112 +   "b : lfp(%x. HTTgen(x) Un R Un HTT) ==> inr(b) : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   8.113 +   "zero : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   8.114 +   "n : lfp(%x. HTTgen(x) Un R Un HTT) ==> succ(n) : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   8.115 +   "[] : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))",
   8.116 +   "[| h : lfp(%x. HTTgen(x) Un R Un HTT); t : lfp(%x. HTTgen(x) Un R Un HTT) |] ==> h$t : HTTgen(lfp(%x. HTTgen(x) Un R Un HTT))"]
   8.117  
   8.118  end
   8.119 +*}
   8.120 +
   8.121 +ML {* bind_thms ("HTTgenIs", HTTgenIs) *}
   8.122 +
   8.123 +
   8.124 +subsection {* Formation Rules for Types *}
   8.125 +
   8.126 +lemma UnitF: "Unit <= HTT"
   8.127 +  by (simp add: subsetXH UnitXH HTT_rews)
   8.128 +
   8.129 +lemma BoolF: "Bool <= HTT"
   8.130 +  by (fastsimp simp: subsetXH BoolXH iff: HTT_rews)
   8.131 +
   8.132 +lemma PlusF: "[| A <= HTT;  B <= HTT |] ==> A + B  <= HTT"
   8.133 +  by (fastsimp simp: subsetXH PlusXH iff: HTT_rews)
   8.134 +
   8.135 +lemma SigmaF: "[| A <= HTT;  !!x. x:A ==> B(x) <= HTT |] ==> SUM x:A. B(x) <= HTT"
   8.136 +  by (fastsimp simp: subsetXH SgXH HTT_rews)
   8.137 +
   8.138 +
   8.139 +(*** Formation Rules for Recursive types - using coinduction these only need ***)
   8.140 +(***                                          exhaution rule for type-former ***)
   8.141 +
   8.142 +(*Proof by induction - needs induction rule for type*)
   8.143 +lemma "Nat <= HTT"
   8.144 +  apply (simp add: subsetXH)
   8.145 +  apply clarify
   8.146 +  apply (erule Nat_ind)
   8.147 +   apply (fastsimp iff: HTT_rews)+
   8.148 +  done
   8.149 +
   8.150 +lemma NatF: "Nat <= HTT"
   8.151 +  apply clarify
   8.152 +  apply (erule HTT_coinduct3)
   8.153 +  apply (fast intro: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI] dest: NatXH [THEN iffD1])
   8.154 +  done
   8.155 +
   8.156 +lemma ListF: "A <= HTT ==> List(A) <= HTT"
   8.157 +  apply clarify
   8.158 +  apply (erule HTT_coinduct3)
   8.159 +  apply (fast intro!: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI]
   8.160 +    subsetD [THEN HTTgen_mono [THEN ci3_AI]]
   8.161 +    dest: ListXH [THEN iffD1])
   8.162 +  done
   8.163 +
   8.164 +lemma ListsF: "A <= HTT ==> Lists(A) <= HTT"
   8.165 +  apply clarify
   8.166 +  apply (erule HTT_coinduct3)
   8.167 +  apply (fast intro!: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI]
   8.168 +    subsetD [THEN HTTgen_mono [THEN ci3_AI]] dest: ListsXH [THEN iffD1])
   8.169 +  done
   8.170 +
   8.171 +lemma IListsF: "A <= HTT ==> ILists(A) <= HTT"
   8.172 +  apply clarify
   8.173 +  apply (erule HTT_coinduct3)
   8.174 +  apply (fast intro!: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI]
   8.175 +    subsetD [THEN HTTgen_mono [THEN ci3_AI]] dest: IListsXH [THEN iffD1])
   8.176 +  done
   8.177 +
   8.178 +end
     9.1 --- a/src/CCL/IsaMakefile	Mon Jul 17 18:42:38 2006 +0200
     9.2 +++ b/src/CCL/IsaMakefile	Tue Jul 18 02:22:38 2006 +0200
     9.3 @@ -28,11 +28,8 @@
     9.4  
     9.5  $(OUT)/FOL: FOL
     9.6  
     9.7 -$(OUT)/CCL: $(OUT)/FOL CCL.ML CCL.thy Fix.ML Fix.thy Gfp.ML Gfp.thy \
     9.8 -  Hered.ML Hered.thy Lfp.ML Lfp.thy ROOT.ML Set.ML Set.thy Term.ML \
     9.9 -  Term.thy Trancl.ML Trancl.thy Type.ML Type.thy wfd.ML Wfd.thy \
    9.10 -  coinduction.ML equalities.ML eval.ML genrec.ML mono.ML subset.ML \
    9.11 -  typecheck.ML
    9.12 +$(OUT)/CCL: $(OUT)/FOL CCL.thy Fix.thy Gfp.thy Hered.thy Lfp.thy ROOT.ML \
    9.13 +  Set.thy Term.thy Trancl.thy Type.thy Wfd.thy
    9.14  	@$(ISATOOL) usedir -b -r $(OUT)/FOL CCL
    9.15  
    9.16  
    9.17 @@ -40,8 +37,8 @@
    9.18  
    9.19  CCL-ex: CCL $(LOG)/CCL-ex.gz
    9.20  
    9.21 -$(LOG)/CCL-ex.gz: $(OUT)/CCL ex/Flag.ML ex/Flag.thy ex/List.ML \
    9.22 -  ex/List.thy ex/Nat.ML ex/Nat.thy ex/ROOT.ML ex/Stream.ML ex/Stream.thy
    9.23 +$(LOG)/CCL-ex.gz: $(OUT)/CCL ex/Flag.thy ex/List.thy ex/Nat.thy ex/ROOT.ML \
    9.24 +  ex/Stream.thy
    9.25  	@$(ISATOOL) usedir $(OUT)/CCL ex
    9.26  
    9.27  
    10.1 --- a/src/CCL/Lfp.ML	Mon Jul 17 18:42:38 2006 +0200
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,72 +0,0 @@
    10.4 -(*  Title:      CCL/Lfp.ML
    10.5 -    ID:         $Id$
    10.6 -*)
    10.7 -
    10.8 -(*** Proof of Knaster-Tarski Theorem ***)
    10.9 -
   10.10 -(* lfp(f) is the greatest lower bound of {u. f(u) <= u} *)
   10.11 -
   10.12 -val prems = goalw (the_context ()) [lfp_def] "[| f(A) <= A |] ==> lfp(f) <= A";
   10.13 -by (rtac (CollectI RS Inter_lower) 1);
   10.14 -by (resolve_tac prems 1);
   10.15 -qed "lfp_lowerbound";
   10.16 -
   10.17 -val prems = goalw (the_context ()) [lfp_def]
   10.18 -    "[| !!u. f(u) <= u ==> A<=u |] ==> A <= lfp(f)";
   10.19 -by (REPEAT (ares_tac ([Inter_greatest]@prems) 1));
   10.20 -by (etac CollectD 1);
   10.21 -qed "lfp_greatest";
   10.22 -
   10.23 -val [mono] = goal (the_context ()) "mono(f) ==> f(lfp(f)) <= lfp(f)";
   10.24 -by (EVERY1 [rtac lfp_greatest, rtac subset_trans,
   10.25 -            rtac (mono RS monoD), rtac lfp_lowerbound, atac, atac]);
   10.26 -qed "lfp_lemma2";
   10.27 -
   10.28 -val [mono] = goal (the_context ()) "mono(f) ==> lfp(f) <= f(lfp(f))";
   10.29 -by (EVERY1 [rtac lfp_lowerbound, rtac (mono RS monoD),
   10.30 -            rtac lfp_lemma2, rtac mono]);
   10.31 -qed "lfp_lemma3";
   10.32 -
   10.33 -val [mono] = goal (the_context ()) "mono(f) ==> lfp(f) = f(lfp(f))";
   10.34 -by (REPEAT (resolve_tac [equalityI,lfp_lemma2,lfp_lemma3,mono] 1));
   10.35 -qed "lfp_Tarski";
   10.36 -
   10.37 -
   10.38 -(*** General induction rule for least fixed points ***)
   10.39 -
   10.40 -val [lfp,mono,indhyp] = goal (the_context ())
   10.41 -    "[| a: lfp(f);  mono(f);                            \
   10.42 -\       !!x. [| x: f(lfp(f) Int {x. P(x)}) |] ==> P(x)   \
   10.43 -\    |] ==> P(a)";
   10.44 -by (res_inst_tac [("a","a")] (Int_lower2 RS subsetD RS CollectD) 1);
   10.45 -by (rtac (lfp RSN (2, lfp_lowerbound RS subsetD)) 1);
   10.46 -by (EVERY1 [rtac Int_greatest, rtac subset_trans,
   10.47 -            rtac (Int_lower1 RS (mono RS monoD)),
   10.48 -            rtac (mono RS lfp_lemma2),
   10.49 -            rtac (CollectI RS subsetI), rtac indhyp, atac]);
   10.50 -qed "induct";
   10.51 -
   10.52 -(** Definition forms of lfp_Tarski and induct, to control unfolding **)
   10.53 -
   10.54 -val [rew,mono] = goal (the_context ()) "[| h==lfp(f);  mono(f) |] ==> h = f(h)";
   10.55 -by (rewtac rew);
   10.56 -by (rtac (mono RS lfp_Tarski) 1);
   10.57 -qed "def_lfp_Tarski";
   10.58 -
   10.59 -val rew::prems = goal (the_context ())
   10.60 -    "[| A == lfp(f);  a:A;  mono(f);                    \
   10.61 -\       !!x. [| x: f(A Int {x. P(x)}) |] ==> P(x)        \
   10.62 -\    |] ==> P(a)";
   10.63 -by (EVERY1 [rtac induct,        (*backtracking to force correct induction*)
   10.64 -            REPEAT1 o (ares_tac (map (rewrite_rule [rew]) prems))]);
   10.65 -qed "def_induct";
   10.66 -
   10.67 -(*Monotonicity of lfp!*)
   10.68 -val prems = goal (the_context ())
   10.69 -    "[| mono(g);  !!Z. f(Z)<=g(Z) |] ==> lfp(f) <= lfp(g)";
   10.70 -by (rtac lfp_lowerbound 1);
   10.71 -by (rtac subset_trans 1);
   10.72 -by (resolve_tac prems 1);
   10.73 -by (rtac lfp_lemma2 1);
   10.74 -by (resolve_tac prems 1);
   10.75 -qed "lfp_mono";
    11.1 --- a/src/CCL/Lfp.thy	Mon Jul 17 18:42:38 2006 +0200
    11.2 +++ b/src/CCL/Lfp.thy	Tue Jul 18 02:22:38 2006 +0200
    11.3 @@ -8,13 +8,67 @@
    11.4  
    11.5  theory Lfp
    11.6  imports Set
    11.7 -uses "subset.ML" "equalities.ML" "mono.ML"
    11.8  begin
    11.9  
   11.10 -constdefs
   11.11 +definition
   11.12    lfp :: "['a set=>'a set] => 'a set"     (*least fixed point*)
   11.13    "lfp(f) == Inter({u. f(u) <= u})"
   11.14  
   11.15 -ML {* use_legacy_bindings (the_context ()) *}
   11.16 +(* lfp(f) is the greatest lower bound of {u. f(u) <= u} *)
   11.17 +
   11.18 +lemma lfp_lowerbound: "[| f(A) <= A |] ==> lfp(f) <= A"
   11.19 +  unfolding lfp_def by blast
   11.20 +
   11.21 +lemma lfp_greatest: "[| !!u. f(u) <= u ==> A<=u |] ==> A <= lfp(f)"
   11.22 +  unfolding lfp_def by blast
   11.23 +
   11.24 +lemma lfp_lemma2: "mono(f) ==> f(lfp(f)) <= lfp(f)"
   11.25 +  by (rule lfp_greatest, rule subset_trans, drule monoD, rule lfp_lowerbound, assumption+)
   11.26 +
   11.27 +lemma lfp_lemma3: "mono(f) ==> lfp(f) <= f(lfp(f))"
   11.28 +  by (rule lfp_lowerbound, frule monoD, drule lfp_lemma2, assumption+)
   11.29 +
   11.30 +lemma lfp_Tarski: "mono(f) ==> lfp(f) = f(lfp(f))"
   11.31 +  by (rule equalityI lfp_lemma2 lfp_lemma3 | assumption)+
   11.32 +
   11.33 +
   11.34 +(*** General induction rule for least fixed points ***)
   11.35 +
   11.36 +lemma induct:
   11.37 +  assumes lfp: "a: lfp(f)"
   11.38 +    and mono: "mono(f)"
   11.39 +    and indhyp: "!!x. [| x: f(lfp(f) Int {x. P(x)}) |] ==> P(x)"
   11.40 +  shows "P(a)"
   11.41 +  apply (rule_tac a = a in Int_lower2 [THEN subsetD, THEN CollectD])
   11.42 +  apply (rule lfp [THEN [2] lfp_lowerbound [THEN subsetD]])
   11.43 +  apply (rule Int_greatest, rule subset_trans, rule Int_lower1 [THEN mono [THEN monoD]],
   11.44 +    rule mono [THEN lfp_lemma2], rule CollectI [THEN subsetI], rule indhyp, assumption)
   11.45 +  done
   11.46 +
   11.47 +(** Definition forms of lfp_Tarski and induct, to control unfolding **)
   11.48 +
   11.49 +lemma def_lfp_Tarski: "[| h==lfp(f);  mono(f) |] ==> h = f(h)"
   11.50 +  apply unfold
   11.51 +  apply (drule lfp_Tarski)
   11.52 +  apply assumption
   11.53 +  done
   11.54 +
   11.55 +lemma def_induct:
   11.56 +  "[| A == lfp(f);  a:A;  mono(f);                     
   11.57 +    !!x. [| x: f(A Int {x. P(x)}) |] ==> P(x)         
   11.58 +  |] ==> P(a)"
   11.59 +  apply (rule induct [of concl: P a])
   11.60 +    apply simp
   11.61 +   apply assumption
   11.62 +  apply blast
   11.63 +  done
   11.64 +
   11.65 +(*Monotonicity of lfp!*)
   11.66 +lemma lfp_mono: "[| mono(g);  !!Z. f(Z)<=g(Z) |] ==> lfp(f) <= lfp(g)"
   11.67 +  apply (rule lfp_lowerbound)
   11.68 +  apply (rule subset_trans)
   11.69 +   apply (erule meta_spec)
   11.70 +  apply (erule lfp_lemma2)
   11.71 +  done
   11.72  
   11.73  end
    12.1 --- a/src/CCL/ROOT.ML	Mon Jul 17 18:42:38 2006 +0200
    12.2 +++ b/src/CCL/ROOT.ML	Tue Jul 18 02:22:38 2006 +0200
    12.3 @@ -14,7 +14,5 @@
    12.4  (* CCL - a computational logic for an untyped functional language *)
    12.5  (*                       with evaluation to weak head-normal form *)
    12.6  
    12.7 -use_thy "CCL";
    12.8 -use_thy "Hered";
    12.9  use_thy "Wfd";
   12.10  use_thy "Fix";
    13.1 --- a/src/CCL/Set.ML	Mon Jul 17 18:42:38 2006 +0200
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,330 +0,0 @@
    13.4 -(*  Title:      Set/Set.ML
    13.5 -    ID:         $Id$
    13.6 -*)
    13.7 -
    13.8 -val [prem] = goal (the_context ()) "[| P(a) |] ==> a : {x. P(x)}";
    13.9 -by (rtac (mem_Collect_iff RS iffD2) 1);
   13.10 -by (rtac prem 1);
   13.11 -qed "CollectI";
   13.12 -
   13.13 -val prems = goal (the_context ()) "[| a : {x. P(x)} |] ==> P(a)";
   13.14 -by (resolve_tac (prems RL [mem_Collect_iff  RS iffD1]) 1);
   13.15 -qed "CollectD";
   13.16 -
   13.17 -val CollectE = make_elim CollectD;
   13.18 -
   13.19 -val [prem] = goal (the_context ()) "[| !!x. x:A <-> x:B |] ==> A = B";
   13.20 -by (rtac (set_extension RS iffD2) 1);
   13.21 -by (rtac (prem RS allI) 1);
   13.22 -qed "set_ext";
   13.23 -
   13.24 -(*** Bounded quantifiers ***)
   13.25 -
   13.26 -val prems = goalw (the_context ()) [Ball_def]
   13.27 -    "[| !!x. x:A ==> P(x) |] ==> ALL x:A. P(x)";
   13.28 -by (REPEAT (ares_tac (prems @ [allI,impI]) 1));
   13.29 -qed "ballI";
   13.30 -
   13.31 -val [major,minor] = goalw (the_context ()) [Ball_def]
   13.32 -    "[| ALL x:A. P(x);  x:A |] ==> P(x)";
   13.33 -by (rtac (minor RS (major RS spec RS mp)) 1);
   13.34 -qed "bspec";
   13.35 -
   13.36 -val major::prems = goalw (the_context ()) [Ball_def]
   13.37 -    "[| ALL x:A. P(x);  P(x) ==> Q;  ~ x:A ==> Q |] ==> Q";
   13.38 -by (rtac (major RS spec RS impCE) 1);
   13.39 -by (REPEAT (eresolve_tac prems 1));
   13.40 -qed "ballE";
   13.41 -
   13.42 -(*Takes assumptions ALL x:A.P(x) and a:A; creates assumption P(a)*)
   13.43 -fun ball_tac i = etac ballE i THEN contr_tac (i+1);
   13.44 -
   13.45 -val prems = goalw (the_context ()) [Bex_def]
   13.46 -    "[| P(x);  x:A |] ==> EX x:A. P(x)";
   13.47 -by (REPEAT (ares_tac (prems @ [exI,conjI]) 1));
   13.48 -qed "bexI";
   13.49 -
   13.50 -qed_goal "bexCI" (the_context ())
   13.51 -   "[| EX x:A. ~P(x) ==> P(a);  a:A |] ==> EX x:A. P(x)"
   13.52 - (fn prems=>
   13.53 -  [ (rtac classical 1),
   13.54 -    (REPEAT (ares_tac (prems@[bexI,ballI,notI,notE]) 1))  ]);
   13.55 -
   13.56 -val major::prems = goalw (the_context ()) [Bex_def]
   13.57 -    "[| EX x:A. P(x);  !!x. [| x:A; P(x) |] ==> Q  |] ==> Q";
   13.58 -by (rtac (major RS exE) 1);
   13.59 -by (REPEAT (eresolve_tac (prems @ [asm_rl,conjE]) 1));
   13.60 -qed "bexE";
   13.61 -
   13.62 -(*Trival rewrite rule;   (! x:A.P)=P holds only if A is nonempty!*)
   13.63 -val prems = goal (the_context ())
   13.64 -    "(ALL x:A. True) <-> True";
   13.65 -by (REPEAT (ares_tac [TrueI,ballI,iffI] 1));
   13.66 -qed "ball_rew";
   13.67 -
   13.68 -(** Congruence rules **)
   13.69 -
   13.70 -val prems = goal (the_context ())
   13.71 -    "[| A=A';  !!x. x:A' ==> P(x) <-> P'(x) |] ==> \
   13.72 -\    (ALL x:A. P(x)) <-> (ALL x:A'. P'(x))";
   13.73 -by (resolve_tac (prems RL [ssubst,iffD2]) 1);
   13.74 -by (REPEAT (ares_tac [ballI,iffI] 1
   13.75 -     ORELSE eresolve_tac ([make_elim bspec, mp] @ (prems RL [iffE])) 1));
   13.76 -qed "ball_cong";
   13.77 -
   13.78 -val prems = goal (the_context ())
   13.79 -    "[| A=A';  !!x. x:A' ==> P(x) <-> P'(x) |] ==> \
   13.80 -\    (EX x:A. P(x)) <-> (EX x:A'. P'(x))";
   13.81 -by (resolve_tac (prems RL [ssubst,iffD2]) 1);
   13.82 -by (REPEAT (etac bexE 1
   13.83 -     ORELSE ares_tac ([bexI,iffI] @ (prems RL [iffD1,iffD2])) 1));
   13.84 -qed "bex_cong";
   13.85 -
   13.86 -(*** Rules for subsets ***)
   13.87 -
   13.88 -val prems = goalw (the_context ()) [subset_def] "(!!x. x:A ==> x:B) ==> A <= B";
   13.89 -by (REPEAT (ares_tac (prems @ [ballI]) 1));
   13.90 -qed "subsetI";
   13.91 -
   13.92 -(*Rule in Modus Ponens style*)
   13.93 -val major::prems = goalw (the_context ()) [subset_def] "[| A <= B;  c:A |] ==> c:B";
   13.94 -by (rtac (major RS bspec) 1);
   13.95 -by (resolve_tac prems 1);
   13.96 -qed "subsetD";
   13.97 -
   13.98 -(*Classical elimination rule*)
   13.99 -val major::prems = goalw (the_context ()) [subset_def]
  13.100 -    "[| A <= B;  ~(c:A) ==> P;  c:B ==> P |] ==> P";
  13.101 -by (rtac (major RS ballE) 1);
  13.102 -by (REPEAT (eresolve_tac prems 1));
  13.103 -qed "subsetCE";
  13.104 -
  13.105 -(*Takes assumptions A<=B; c:A and creates the assumption c:B *)
  13.106 -fun set_mp_tac i = etac subsetCE i  THEN  mp_tac i;
  13.107 -
  13.108 -qed_goal "subset_refl" (the_context ()) "A <= A"
  13.109 - (fn _=> [ (REPEAT (ares_tac [subsetI] 1)) ]);
  13.110 -
  13.111 -Goal "[| A<=B;  B<=C |] ==> A<=C";
  13.112 -by (rtac subsetI 1);
  13.113 -by (REPEAT (eresolve_tac [asm_rl, subsetD] 1));
  13.114 -qed "subset_trans";
  13.115 -
  13.116 -
  13.117 -(*** Rules for equality ***)
  13.118 -
  13.119 -(*Anti-symmetry of the subset relation*)
  13.120 -val prems = goal (the_context ()) "[| A <= B;  B <= A |] ==> A = B";
  13.121 -by (rtac (iffI RS set_ext) 1);
  13.122 -by (REPEAT (ares_tac (prems RL [subsetD]) 1));
  13.123 -qed "subset_antisym";
  13.124 -val equalityI = subset_antisym;
  13.125 -
  13.126 -(* Equality rules from ZF set theory -- are they appropriate here? *)
  13.127 -val prems = goal (the_context ()) "A = B ==> A<=B";
  13.128 -by (resolve_tac (prems RL [subst]) 1);
  13.129 -by (rtac subset_refl 1);
  13.130 -qed "equalityD1";
  13.131 -
  13.132 -val prems = goal (the_context ()) "A = B ==> B<=A";
  13.133 -by (resolve_tac (prems RL [subst]) 1);
  13.134 -by (rtac subset_refl 1);
  13.135 -qed "equalityD2";
  13.136 -
  13.137 -val prems = goal (the_context ())
  13.138 -    "[| A = B;  [| A<=B; B<=A |] ==> P |]  ==>  P";
  13.139 -by (resolve_tac prems 1);
  13.140 -by (REPEAT (resolve_tac (prems RL [equalityD1,equalityD2]) 1));
  13.141 -qed "equalityE";
  13.142 -
  13.143 -val major::prems = goal (the_context ())
  13.144 -    "[| A = B;  [| c:A; c:B |] ==> P;  [| ~ c:A; ~ c:B |] ==> P |]  ==>  P";
  13.145 -by (rtac (major RS equalityE) 1);
  13.146 -by (REPEAT (contr_tac 1 ORELSE eresolve_tac ([asm_rl,subsetCE]@prems) 1));
  13.147 -qed "equalityCE";
  13.148 -
  13.149 -Goal "{x. x:A} = A";
  13.150 -by (REPEAT (ares_tac [equalityI,subsetI,CollectI] 1  ORELSE etac CollectD 1));
  13.151 -qed "trivial_set";
  13.152 -
  13.153 -(*** Rules for binary union -- Un ***)
  13.154 -
  13.155 -val prems = goalw (the_context ()) [Un_def] "c:A ==> c : A Un B";
  13.156 -by (REPEAT (resolve_tac (prems @ [CollectI,disjI1]) 1));
  13.157 -qed "UnI1";
  13.158 -
  13.159 -val prems = goalw (the_context ()) [Un_def] "c:B ==> c : A Un B";
  13.160 -by (REPEAT (resolve_tac (prems @ [CollectI,disjI2]) 1));
  13.161 -qed "UnI2";
  13.162 -
  13.163 -(*Classical introduction rule: no commitment to A vs B*)
  13.164 -qed_goal "UnCI" (the_context ()) "(~c:B ==> c:A) ==> c : A Un B"
  13.165 - (fn prems=>
  13.166 -  [ (rtac classical 1),
  13.167 -    (REPEAT (ares_tac (prems@[UnI1,notI]) 1)),
  13.168 -    (REPEAT (ares_tac (prems@[UnI2,notE]) 1)) ]);
  13.169 -
  13.170 -val major::prems = goalw (the_context ()) [Un_def]
  13.171 -    "[| c : A Un B;  c:A ==> P;  c:B ==> P |] ==> P";
  13.172 -by (rtac (major RS CollectD RS disjE) 1);
  13.173 -by (REPEAT (eresolve_tac prems 1));
  13.174 -qed "UnE";
  13.175 -
  13.176 -
  13.177 -(*** Rules for small intersection -- Int ***)
  13.178 -
  13.179 -val prems = goalw (the_context ()) [Int_def]
  13.180 -    "[| c:A;  c:B |] ==> c : A Int B";
  13.181 -by (REPEAT (resolve_tac (prems @ [CollectI,conjI]) 1));
  13.182 -qed "IntI";
  13.183 -
  13.184 -val [major] = goalw (the_context ()) [Int_def] "c : A Int B ==> c:A";
  13.185 -by (rtac (major RS CollectD RS conjunct1) 1);
  13.186 -qed "IntD1";
  13.187 -
  13.188 -val [major] = goalw (the_context ()) [Int_def] "c : A Int B ==> c:B";
  13.189 -by (rtac (major RS CollectD RS conjunct2) 1);
  13.190 -qed "IntD2";
  13.191 -
  13.192 -val [major,minor] = goal (the_context ())
  13.193 -    "[| c : A Int B;  [| c:A; c:B |] ==> P |] ==> P";
  13.194 -by (rtac minor 1);
  13.195 -by (rtac (major RS IntD1) 1);
  13.196 -by (rtac (major RS IntD2) 1);
  13.197 -qed "IntE";
  13.198 -
  13.199 -
  13.200 -(*** Rules for set complement -- Compl ***)
  13.201 -
  13.202 -val prems = goalw (the_context ()) [Compl_def]
  13.203 -    "[| c:A ==> False |] ==> c : Compl(A)";
  13.204 -by (REPEAT (ares_tac (prems @ [CollectI,notI]) 1));
  13.205 -qed "ComplI";
  13.206 -
  13.207 -(*This form, with negated conclusion, works well with the Classical prover.
  13.208 -  Negated assumptions behave like formulae on the right side of the notional
  13.209 -  turnstile...*)
  13.210 -val major::prems = goalw (the_context ()) [Compl_def]
  13.211 -    "[| c : Compl(A) |] ==> ~c:A";
  13.212 -by (rtac (major RS CollectD) 1);
  13.213 -qed "ComplD";
  13.214 -
  13.215 -val ComplE = make_elim ComplD;
  13.216 -
  13.217 -
  13.218 -(*** Empty sets ***)
  13.219 -
  13.220 -Goalw [empty_def] "{x. False} = {}";
  13.221 -by (rtac refl 1);
  13.222 -qed "empty_eq";
  13.223 -
  13.224 -val [prem] = goalw (the_context ()) [empty_def] "a : {} ==> P";
  13.225 -by (rtac (prem RS CollectD RS FalseE) 1);
  13.226 -qed "emptyD";
  13.227 -
  13.228 -val emptyE = make_elim emptyD;
  13.229 -
  13.230 -val [prem] = goal (the_context ()) "~ A={} ==> (EX x. x:A)";
  13.231 -by (rtac (prem RS Cla.swap) 1);
  13.232 -by (rtac equalityI 1);
  13.233 -by (ALLGOALS (fast_tac (FOL_cs addSIs [subsetI] addSEs [emptyD])));
  13.234 -qed "not_emptyD";
  13.235 -
  13.236 -(*** Singleton sets ***)
  13.237 -
  13.238 -Goalw [singleton_def] "a : {a}";
  13.239 -by (rtac CollectI 1);
  13.240 -by (rtac refl 1);
  13.241 -qed "singletonI";
  13.242 -
  13.243 -val [major] = goalw (the_context ()) [singleton_def] "b : {a} ==> b=a";
  13.244 -by (rtac (major RS CollectD) 1);
  13.245 -qed "singletonD";
  13.246 -
  13.247 -val singletonE = make_elim singletonD;
  13.248 -
  13.249 -(*** Unions of families ***)
  13.250 -
  13.251 -(*The order of the premises presupposes that A is rigid; b may be flexible*)
  13.252 -val prems = goalw (the_context ()) [UNION_def]
  13.253 -    "[| a:A;  b: B(a) |] ==> b: (UN x:A. B(x))";
  13.254 -by (REPEAT (resolve_tac (prems @ [bexI,CollectI]) 1));
  13.255 -qed "UN_I";
  13.256 -
  13.257 -val major::prems = goalw (the_context ()) [UNION_def]
  13.258 -    "[| b : (UN x:A. B(x));  !!x.[| x:A;  b: B(x) |] ==> R |] ==> R";
  13.259 -by (rtac (major RS CollectD RS bexE) 1);
  13.260 -by (REPEAT (ares_tac prems 1));
  13.261 -qed "UN_E";
  13.262 -
  13.263 -val prems = goal (the_context ())
  13.264 -    "[| A=B;  !!x. x:B ==> C(x) = D(x) |] ==> \
  13.265 -\    (UN x:A. C(x)) = (UN x:B. D(x))";
  13.266 -by (REPEAT (etac UN_E 1
  13.267 -     ORELSE ares_tac ([UN_I,equalityI,subsetI] @
  13.268 -                      (prems RL [equalityD1,equalityD2] RL [subsetD])) 1));
  13.269 -qed "UN_cong";
  13.270 -
  13.271 -(*** Intersections of families -- INTER x:A. B(x) is Inter(B)``A ) *)
  13.272 -
  13.273 -val prems = goalw (the_context ()) [INTER_def]
  13.274 -    "(!!x. x:A ==> b: B(x)) ==> b : (INT x:A. B(x))";
  13.275 -by (REPEAT (ares_tac ([CollectI,ballI] @ prems) 1));
  13.276 -qed "INT_I";
  13.277 -
  13.278 -val major::prems = goalw (the_context ()) [INTER_def]
  13.279 -    "[| b : (INT x:A. B(x));  a:A |] ==> b: B(a)";
  13.280 -by (rtac (major RS CollectD RS bspec) 1);
  13.281 -by (resolve_tac prems 1);
  13.282 -qed "INT_D";
  13.283 -
  13.284 -(*"Classical" elimination rule -- does not require proving X:C *)
  13.285 -val major::prems = goalw (the_context ()) [INTER_def]
  13.286 -    "[| b : (INT x:A. B(x));  b: B(a) ==> R;  ~ a:A ==> R |] ==> R";
  13.287 -by (rtac (major RS CollectD RS ballE) 1);
  13.288 -by (REPEAT (eresolve_tac prems 1));
  13.289 -qed "INT_E";
  13.290 -
  13.291 -val prems = goal (the_context ())
  13.292 -    "[| A=B;  !!x. x:B ==> C(x) = D(x) |] ==> \
  13.293 -\    (INT x:A. C(x)) = (INT x:B. D(x))";
  13.294 -by (REPEAT_FIRST (resolve_tac [INT_I,equalityI,subsetI]));
  13.295 -by (REPEAT (dtac INT_D 1
  13.296 -     ORELSE ares_tac (prems RL [equalityD1,equalityD2] RL [subsetD]) 1));
  13.297 -qed "INT_cong";
  13.298 -
  13.299 -(*** Rules for Unions ***)
  13.300 -
  13.301 -(*The order of the premises presupposes that C is rigid; A may be flexible*)
  13.302 -val prems = goalw (the_context ()) [Union_def]
  13.303 -    "[| X:C;  A:X |] ==> A : Union(C)";
  13.304 -by (REPEAT (resolve_tac (prems @ [UN_I]) 1));
  13.305 -qed "UnionI";
  13.306 -
  13.307 -val major::prems = goalw (the_context ()) [Union_def]
  13.308 -    "[| A : Union(C);  !!X.[| A:X;  X:C |] ==> R |] ==> R";
  13.309 -by (rtac (major RS UN_E) 1);
  13.310 -by (REPEAT (ares_tac prems 1));
  13.311 -qed "UnionE";
  13.312 -
  13.313 -(*** Rules for Inter ***)
  13.314 -
  13.315 -val prems = goalw (the_context ()) [Inter_def]
  13.316 -    "[| !!X. X:C ==> A:X |] ==> A : Inter(C)";
  13.317 -by (REPEAT (ares_tac ([INT_I] @ prems) 1));
  13.318 -qed "InterI";
  13.319 -
  13.320 -(*A "destruct" rule -- every X in C contains A as an element, but
  13.321 -  A:X can hold when X:C does not!  This rule is analogous to "spec". *)
  13.322 -val major::prems = goalw (the_context ()) [Inter_def]
  13.323 -    "[| A : Inter(C);  X:C |] ==> A:X";
  13.324 -by (rtac (major RS INT_D) 1);
  13.325 -by (resolve_tac prems 1);
  13.326 -qed "InterD";
  13.327 -
  13.328 -(*"Classical" elimination rule -- does not require proving X:C *)
  13.329 -val major::prems = goalw (the_context ()) [Inter_def]
  13.330 -    "[| A : Inter(C);  A:X ==> R;  ~ X:C ==> R |] ==> R";
  13.331 -by (rtac (major RS INT_E) 1);
  13.332 -by (REPEAT (eresolve_tac prems 1));
  13.333 -qed "InterE";
    14.1 --- a/src/CCL/Set.thy	Mon Jul 17 18:42:38 2006 +0200
    14.2 +++ b/src/CCL/Set.thy	Tue Jul 18 02:22:38 2006 +0200
    14.3 @@ -72,7 +72,439 @@
    14.4    Inter_def:     "Inter(S)    == (INT x:S. x)"
    14.5    Union_def:     "Union(S)    == (UN x:S. x)"
    14.6  
    14.7 -ML {* use_legacy_bindings (the_context ()) *}
    14.8 +
    14.9 +lemma CollectI: "[| P(a) |] ==> a : {x. P(x)}"
   14.10 +  apply (rule mem_Collect_iff [THEN iffD2])
   14.11 +  apply assumption
   14.12 +  done
   14.13 +
   14.14 +lemma CollectD: "[| a : {x. P(x)} |] ==> P(a)"
   14.15 +  apply (erule mem_Collect_iff [THEN iffD1])
   14.16 +  done
   14.17 +
   14.18 +lemmas CollectE = CollectD [elim_format]
   14.19 +
   14.20 +lemma set_ext: "[| !!x. x:A <-> x:B |] ==> A = B"
   14.21 +  apply (rule set_extension [THEN iffD2])
   14.22 +  apply simp
   14.23 +  done
   14.24 +
   14.25 +
   14.26 +subsection {* Bounded quantifiers *}
   14.27 +
   14.28 +lemma ballI: "[| !!x. x:A ==> P(x) |] ==> ALL x:A. P(x)"
   14.29 +  by (simp add: Ball_def)
   14.30 +
   14.31 +lemma bspec: "[| ALL x:A. P(x);  x:A |] ==> P(x)"
   14.32 +  by (simp add: Ball_def)
   14.33 +
   14.34 +lemma ballE: "[| ALL x:A. P(x);  P(x) ==> Q;  ~ x:A ==> Q |] ==> Q"
   14.35 +  unfolding Ball_def by blast
   14.36 +
   14.37 +lemma bexI: "[| P(x);  x:A |] ==> EX x:A. P(x)"
   14.38 +  unfolding Bex_def by blast
   14.39 +
   14.40 +lemma bexCI: "[| EX x:A. ~P(x) ==> P(a);  a:A |] ==> EX x:A. P(x)"
   14.41 +  unfolding Bex_def by blast
   14.42 +
   14.43 +lemma bexE: "[| EX x:A. P(x);  !!x. [| x:A; P(x) |] ==> Q  |] ==> Q"
   14.44 +  unfolding Bex_def by blast
   14.45 +
   14.46 +(*Trival rewrite rule;   (! x:A.P)=P holds only if A is nonempty!*)
   14.47 +lemma ball_rew: "(ALL x:A. True) <-> True"
   14.48 +  by (blast intro: ballI)
   14.49 +
   14.50 +
   14.51 +subsection {* Congruence rules *}
   14.52 +
   14.53 +lemma ball_cong:
   14.54 +  "[| A=A';  !!x. x:A' ==> P(x) <-> P'(x) |] ==>
   14.55 +    (ALL x:A. P(x)) <-> (ALL x:A'. P'(x))"
   14.56 +  by (blast intro: ballI elim: ballE)
   14.57 +
   14.58 +lemma bex_cong:
   14.59 +  "[| A=A';  !!x. x:A' ==> P(x) <-> P'(x) |] ==>
   14.60 +    (EX x:A. P(x)) <-> (EX x:A'. P'(x))"
   14.61 +  by (blast intro: bexI elim: bexE)
   14.62 +
   14.63 +
   14.64 +subsection {* Rules for subsets *}
   14.65 +
   14.66 +lemma subsetI: "(!!x. x:A ==> x:B) ==> A <= B"
   14.67 +  unfolding subset_def by (blast intro: ballI)
   14.68 +
   14.69 +(*Rule in Modus Ponens style*)
   14.70 +lemma subsetD: "[| A <= B;  c:A |] ==> c:B"
   14.71 +  unfolding subset_def by (blast elim: ballE)
   14.72 +
   14.73 +(*Classical elimination rule*)
   14.74 +lemma subsetCE: "[| A <= B;  ~(c:A) ==> P;  c:B ==> P |] ==> P"
   14.75 +  by (blast dest: subsetD)
   14.76 +
   14.77 +lemma subset_refl: "A <= A"
   14.78 +  by (blast intro: subsetI)
   14.79 +
   14.80 +lemma subset_trans: "[| A<=B;  B<=C |] ==> A<=C"
   14.81 +  by (blast intro: subsetI dest: subsetD)
   14.82 +
   14.83 +
   14.84 +subsection {* Rules for equality *}
   14.85 +
   14.86 +(*Anti-symmetry of the subset relation*)
   14.87 +lemma subset_antisym: "[| A <= B;  B <= A |] ==> A = B"
   14.88 +  by (blast intro: set_ext dest: subsetD)
   14.89 +
   14.90 +lemmas equalityI = subset_antisym
   14.91 +
   14.92 +(* Equality rules from ZF set theory -- are they appropriate here? *)
   14.93 +lemma equalityD1: "A = B ==> A<=B"
   14.94 +  and equalityD2: "A = B ==> B<=A"
   14.95 +  by (simp_all add: subset_refl)
   14.96 +
   14.97 +lemma equalityE: "[| A = B;  [| A<=B; B<=A |] ==> P |]  ==>  P"
   14.98 +  by (simp add: subset_refl)
   14.99 +
  14.100 +lemma equalityCE:
  14.101 +    "[| A = B;  [| c:A; c:B |] ==> P;  [| ~ c:A; ~ c:B |] ==> P |]  ==>  P"
  14.102 +  by (blast elim: equalityE subsetCE)
  14.103 +
  14.104 +lemma trivial_set: "{x. x:A} = A"
  14.105 +  by (blast intro: equalityI subsetI CollectI dest: CollectD)
  14.106 +
  14.107 +
  14.108 +subsection {* Rules for binary union *}
  14.109 +
  14.110 +lemma UnI1: "c:A ==> c : A Un B"
  14.111 +  and UnI2: "c:B ==> c : A Un B"
  14.112 +  unfolding Un_def by (blast intro: CollectI)+
  14.113 +
  14.114 +(*Classical introduction rule: no commitment to A vs B*)
  14.115 +lemma UnCI: "(~c:B ==> c:A) ==> c : A Un B"
  14.116 +  by (blast intro: UnI1 UnI2)
  14.117 +
  14.118 +lemma UnE: "[| c : A Un B;  c:A ==> P;  c:B ==> P |] ==> P"
  14.119 +  unfolding Un_def by (blast dest: CollectD)
  14.120 +
  14.121 +
  14.122 +subsection {* Rules for small intersection *}
  14.123 +
  14.124 +lemma IntI: "[| c:A;  c:B |] ==> c : A Int B"
  14.125 +  unfolding Int_def by (blast intro: CollectI)
  14.126 +
  14.127 +lemma IntD1: "c : A Int B ==> c:A"
  14.128 +  and IntD2: "c : A Int B ==> c:B"
  14.129 +  unfolding Int_def by (blast dest: CollectD)+
  14.130 +
  14.131 +lemma IntE: "[| c : A Int B;  [| c:A; c:B |] ==> P |] ==> P"
  14.132 +  by (blast dest: IntD1 IntD2)
  14.133 +
  14.134 +
  14.135 +subsection {* Rules for set complement *}
  14.136 +
  14.137 +lemma ComplI: "[| c:A ==> False |] ==> c : Compl(A)"
  14.138 +  unfolding Compl_def by (blast intro: CollectI)
  14.139 +
  14.140 +(*This form, with negated conclusion, works well with the Classical prover.
  14.141 +  Negated assumptions behave like formulae on the right side of the notional
  14.142 +  turnstile...*)
  14.143 +lemma ComplD: "[| c : Compl(A) |] ==> ~c:A"
  14.144 +  unfolding Compl_def by (blast dest: CollectD)
  14.145 +
  14.146 +lemmas ComplE = ComplD [elim_format]
  14.147 +
  14.148 +
  14.149 +subsection {* Empty sets *}
  14.150 +
  14.151 +lemma empty_eq: "{x. False} = {}"
  14.152 +  by (simp add: empty_def)
  14.153 +
  14.154 +lemma emptyD: "a : {} ==> P"
  14.155 +  unfolding empty_def by (blast dest: CollectD)
  14.156 +
  14.157 +lemmas emptyE = emptyD [elim_format]
  14.158 +
  14.159 +lemma not_emptyD:
  14.160 +  assumes "~ A={}"
  14.161 +  shows "EX x. x:A"
  14.162 +proof -
  14.163 +  have "\<not> (EX x. x:A) \<Longrightarrow> A = {}"
  14.164 +    by (rule equalityI) (blast intro!: subsetI elim!: emptyD)+
  14.165 +  with prems show ?thesis by blast
  14.166 +qed
  14.167 +
  14.168 +
  14.169 +subsection {* Singleton sets *}
  14.170 +
  14.171 +lemma singletonI: "a : {a}"
  14.172 +  unfolding singleton_def by (blast intro: CollectI)
  14.173 +
  14.174 +lemma singletonD: "b : {a} ==> b=a"
  14.175 +  unfolding singleton_def by (blast dest: CollectD)
  14.176 +
  14.177 +lemmas singletonE = singletonD [elim_format]
  14.178 +
  14.179 +
  14.180 +subsection {* Unions of families *}
  14.181 +
  14.182 +(*The order of the premises presupposes that A is rigid; b may be flexible*)
  14.183 +lemma UN_I: "[| a:A;  b: B(a) |] ==> b: (UN x:A. B(x))"
  14.184 +  unfolding UNION_def by (blast intro: bexI CollectI)
  14.185 +
  14.186 +lemma UN_E: "[| b : (UN x:A. B(x));  !!x.[| x:A;  b: B(x) |] ==> R |] ==> R"
  14.187 +  unfolding UNION_def by (blast dest: CollectD elim: bexE)
  14.188 +
  14.189 +lemma UN_cong:
  14.190 +  "[| A=B;  !!x. x:B ==> C(x) = D(x) |] ==>
  14.191 +    (UN x:A. C(x)) = (UN x:B. D(x))"
  14.192 +  by (simp add: UNION_def cong: bex_cong)
  14.193 +
  14.194 +
  14.195 +subsection {* Intersections of families *}
  14.196 +
  14.197 +lemma INT_I: "(!!x. x:A ==> b: B(x)) ==> b : (INT x:A. B(x))"
  14.198 +  unfolding INTER_def by (blast intro: CollectI ballI)
  14.199 +
  14.200 +lemma INT_D: "[| b : (INT x:A. B(x));  a:A |] ==> b: B(a)"
  14.201 +  unfolding INTER_def by (blast dest: CollectD bspec)
  14.202 +
  14.203 +(*"Classical" elimination rule -- does not require proving X:C *)
  14.204 +lemma INT_E: "[| b : (INT x:A. B(x));  b: B(a) ==> R;  ~ a:A ==> R |] ==> R"
  14.205 +  unfolding INTER_def by (blast dest: CollectD bspec)
  14.206 +
  14.207 +lemma INT_cong:
  14.208 +  "[| A=B;  !!x. x:B ==> C(x) = D(x) |] ==>
  14.209 +    (INT x:A. C(x)) = (INT x:B. D(x))"
  14.210 +  by (simp add: INTER_def cong: ball_cong)
  14.211 +
  14.212 +
  14.213 +subsection {* Rules for Unions *}
  14.214 +
  14.215 +(*The order of the premises presupposes that C is rigid; A may be flexible*)
  14.216 +lemma UnionI: "[| X:C;  A:X |] ==> A : Union(C)"
  14.217 +  unfolding Union_def by (blast intro: UN_I)
  14.218 +
  14.219 +lemma UnionE: "[| A : Union(C);  !!X.[| A:X;  X:C |] ==> R |] ==> R"
  14.220 +  unfolding Union_def by (blast elim: UN_E)
  14.221 +
  14.222 +
  14.223 +subsection {* Rules for Inter *}
  14.224 +
  14.225 +lemma InterI: "[| !!X. X:C ==> A:X |] ==> A : Inter(C)"
  14.226 +  unfolding Inter_def by (blast intro: INT_I)
  14.227 +
  14.228 +(*A "destruct" rule -- every X in C contains A as an element, but
  14.229 +  A:X can hold when X:C does not!  This rule is analogous to "spec". *)
  14.230 +lemma InterD: "[| A : Inter(C);  X:C |] ==> A:X"
  14.231 +  unfolding Inter_def by (blast dest: INT_D)
  14.232 +
  14.233 +(*"Classical" elimination rule -- does not require proving X:C *)
  14.234 +lemma InterE: "[| A : Inter(C);  A:X ==> R;  ~ X:C ==> R |] ==> R"
  14.235 +  unfolding Inter_def by (blast elim: INT_E)
  14.236 +
  14.237 +
  14.238 +section {* Derived rules involving subsets; Union and Intersection as lattice operations *}
  14.239 +
  14.240 +subsection {* Big Union -- least upper bound of a set *}
  14.241 +
  14.242 +lemma Union_upper: "B:A ==> B <= Union(A)"
  14.243 +  by (blast intro: subsetI UnionI)
  14.244 +
  14.245 +lemma Union_least: "[| !!X. X:A ==> X<=C |] ==> Union(A) <= C"
  14.246 +  by (blast intro: subsetI dest: subsetD elim: UnionE)
  14.247 +
  14.248 +
  14.249 +subsection {* Big Intersection -- greatest lower bound of a set *}
  14.250 +
  14.251 +lemma Inter_lower: "B:A ==> Inter(A) <= B"
  14.252 +  by (blast intro: subsetI dest: InterD)
  14.253 +
  14.254 +lemma Inter_greatest: "[| !!X. X:A ==> C<=X |] ==> C <= Inter(A)"
  14.255 +  by (blast intro: subsetI InterI dest: subsetD)
  14.256 +
  14.257 +
  14.258 +subsection {* Finite Union -- the least upper bound of 2 sets *}
  14.259 +
  14.260 +lemma Un_upper1: "A <= A Un B"
  14.261 +  by (blast intro: subsetI UnI1)
  14.262 +
  14.263 +lemma Un_upper2: "B <= A Un B"
  14.264 +  by (blast intro: subsetI UnI2)
  14.265 +
  14.266 +lemma Un_least: "[| A<=C;  B<=C |] ==> A Un B <= C"
  14.267 +  by (blast intro: subsetI elim: UnE dest: subsetD)
  14.268 +
  14.269 +
  14.270 +subsection {* Finite Intersection -- the greatest lower bound of 2 sets *}
  14.271 +
  14.272 +lemma Int_lower1: "A Int B <= A"
  14.273 +  by (blast intro: subsetI elim: IntE)
  14.274 +
  14.275 +lemma Int_lower2: "A Int B <= B"
  14.276 +  by (blast intro: subsetI elim: IntE)
  14.277 +
  14.278 +lemma Int_greatest: "[| C<=A;  C<=B |] ==> C <= A Int B"
  14.279 +  by (blast intro: subsetI IntI dest: subsetD)
  14.280 +
  14.281 +
  14.282 +subsection {* Monotonicity *}
  14.283 +
  14.284 +lemma monoI: "[| !!A B. A <= B ==> f(A) <= f(B) |] ==> mono(f)"
  14.285 +  unfolding mono_def by blast
  14.286 +
  14.287 +lemma monoD: "[| mono(f);  A <= B |] ==> f(A) <= f(B)"
  14.288 +  unfolding mono_def by blast
  14.289 +
  14.290 +lemma mono_Un: "mono(f) ==> f(A) Un f(B) <= f(A Un B)"
  14.291 +  by (blast intro: Un_least dest: monoD intro: Un_upper1 Un_upper2)
  14.292 +
  14.293 +lemma mono_Int: "mono(f) ==> f(A Int B) <= f(A) Int f(B)"
  14.294 +  by (blast intro: Int_greatest dest: monoD intro: Int_lower1 Int_lower2)
  14.295 +
  14.296 +
  14.297 +subsection {* Automated reasoning setup *}
  14.298 +
  14.299 +lemmas [intro!] = ballI subsetI InterI INT_I CollectI ComplI IntI UnCI singletonI
  14.300 +  and [intro] = bexI UnionI UN_I
  14.301 +  and [elim!] = bexE UnionE UN_E CollectE ComplE IntE UnE emptyE singletonE
  14.302 +  and [elim] = ballE InterD InterE INT_D INT_E subsetD subsetCE
  14.303 +
  14.304 +lemma mem_rews:
  14.305 +  "(a : A Un B)   <->  (a:A | a:B)"
  14.306 +  "(a : A Int B)  <->  (a:A & a:B)"
  14.307 +  "(a : Compl(B)) <->  (~a:B)"
  14.308 +  "(a : {b})      <->  (a=b)"
  14.309 +  "(a : {})       <->   False"
  14.310 +  "(a : {x. P(x)}) <->  P(a)"
  14.311 +  by blast+
  14.312 +
  14.313 +lemmas [simp] = trivial_set empty_eq mem_rews
  14.314 +  and [cong] = ball_cong bex_cong INT_cong UN_cong
  14.315 +
  14.316 +
  14.317 +section {* Equalities involving union, intersection, inclusion, etc. *}
  14.318 +
  14.319 +subsection {* Binary Intersection *}
  14.320 +
  14.321 +lemma Int_absorb: "A Int A = A"
  14.322 +  by (blast intro: equalityI)
  14.323 +
  14.324 +lemma Int_commute: "A Int B  =  B Int A"
  14.325 +  by (blast intro: equalityI)
  14.326 +
  14.327 +lemma Int_assoc: "(A Int B) Int C  =  A Int (B Int C)"
  14.328 +  by (blast intro: equalityI)
  14.329 +
  14.330 +lemma Int_Un_distrib: "(A Un B) Int C  =  (A Int C) Un (B Int C)"
  14.331 +  by (blast intro: equalityI)
  14.332 +
  14.333 +lemma subset_Int_eq: "(A<=B) <-> (A Int B = A)"
  14.334 +  by (blast intro: equalityI elim: equalityE)
  14.335 +
  14.336 +
  14.337 +subsection {* Binary Union *}
  14.338 +
  14.339 +lemma Un_absorb: "A Un A = A"
  14.340 +  by (blast intro: equalityI)
  14.341 +
  14.342 +lemma Un_commute: "A Un B  =  B Un A"
  14.343 +  by (blast intro: equalityI)
  14.344 +
  14.345 +lemma Un_assoc: "(A Un B) Un C  =  A Un (B Un C)"
  14.346 +  by (blast intro: equalityI)
  14.347 +
  14.348 +lemma Un_Int_distrib: "(A Int B) Un C  =  (A Un C) Int (B Un C)"
  14.349 +  by (blast intro: equalityI)
  14.350 +
  14.351 +lemma Un_Int_crazy:
  14.352 +    "(A Int B) Un (B Int C) Un (C Int A) = (A Un B) Int (B Un C) Int (C Un A)"
  14.353 +  by (blast intro: equalityI)
  14.354 +
  14.355 +lemma subset_Un_eq: "(A<=B) <-> (A Un B = B)"
  14.356 +  by (blast intro: equalityI elim: equalityE)
  14.357 +
  14.358 +
  14.359 +subsection {* Simple properties of @{text "Compl"} -- complement of a set *}
  14.360 +
  14.361 +lemma Compl_disjoint: "A Int Compl(A) = {x. False}"
  14.362 +  by (blast intro: equalityI)
  14.363 +
  14.364 +lemma Compl_partition: "A Un Compl(A) = {x. True}"
  14.365 +  by (blast intro: equalityI)
  14.366 +
  14.367 +lemma double_complement: "Compl(Compl(A)) = A"
  14.368 +  by (blast intro: equalityI)
  14.369 +
  14.370 +lemma Compl_Un: "Compl(A Un B) = Compl(A) Int Compl(B)"
  14.371 +  by (blast intro: equalityI)
  14.372 +
  14.373 +lemma Compl_Int: "Compl(A Int B) = Compl(A) Un Compl(B)"
  14.374 +  by (blast intro: equalityI)
  14.375 +
  14.376 +lemma Compl_UN: "Compl(UN x:A. B(x)) = (INT x:A. Compl(B(x)))"
  14.377 +  by (blast intro: equalityI)
  14.378 +
  14.379 +lemma Compl_INT: "Compl(INT x:A. B(x)) = (UN x:A. Compl(B(x)))"
  14.380 +  by (blast intro: equalityI)
  14.381 +
  14.382 +(*Halmos, Naive Set Theory, page 16.*)
  14.383 +lemma Un_Int_assoc_eq: "((A Int B) Un C = A Int (B Un C)) <-> (C<=A)"
  14.384 +  by (blast intro: equalityI elim: equalityE)
  14.385 +
  14.386 +
  14.387 +subsection {* Big Union and Intersection *}
  14.388 +
  14.389 +lemma Union_Un_distrib: "Union(A Un B) = Union(A) Un Union(B)"
  14.390 +  by (blast intro: equalityI)
  14.391 +
  14.392 +lemma Union_disjoint:
  14.393 +    "(Union(C) Int A = {x. False}) <-> (ALL B:C. B Int A = {x. False})"
  14.394 +  by (blast intro: equalityI elim: equalityE)
  14.395 +
  14.396 +lemma Inter_Un_distrib: "Inter(A Un B) = Inter(A) Int Inter(B)"
  14.397 +  by (blast intro: equalityI)
  14.398 +
  14.399 +
  14.400 +subsection {* Unions and Intersections of Families *}
  14.401 +
  14.402 +lemma UN_eq: "(UN x:A. B(x)) = Union({Y. EX x:A. Y=B(x)})"
  14.403 +  by (blast intro: equalityI)
  14.404 +
  14.405 +(*Look: it has an EXISTENTIAL quantifier*)
  14.406 +lemma INT_eq: "(INT x:A. B(x)) = Inter({Y. EX x:A. Y=B(x)})"
  14.407 +  by (blast intro: equalityI)
  14.408 +
  14.409 +lemma Int_Union_image: "A Int Union(B) = (UN C:B. A Int C)"
  14.410 +  by (blast intro: equalityI)
  14.411 +
  14.412 +lemma Un_Inter_image: "A Un Inter(B) = (INT C:B. A Un C)"
  14.413 +  by (blast intro: equalityI)
  14.414 +
  14.415 +
  14.416 +section {* Monotonicity of various operations *}
  14.417 +
  14.418 +lemma Union_mono: "A<=B ==> Union(A) <= Union(B)"
  14.419 +  by blast
  14.420 +
  14.421 +lemma Inter_anti_mono: "[| B<=A |] ==> Inter(A) <= Inter(B)"
  14.422 +  by blast
  14.423 +
  14.424 +lemma UN_mono:
  14.425 +  "[| A<=B;  !!x. x:A ==> f(x)<=g(x) |] ==>  
  14.426 +    (UN x:A. f(x)) <= (UN x:B. g(x))"
  14.427 +  by blast
  14.428 +
  14.429 +lemma INT_anti_mono:
  14.430 +  "[| B<=A;  !!x. x:A ==> f(x)<=g(x) |] ==>  
  14.431 +    (INT x:A. f(x)) <= (INT x:A. g(x))"
  14.432 +  by blast
  14.433 +
  14.434 +lemma Un_mono: "[| A<=C;  B<=D |] ==> A Un B <= C Un D"
  14.435 +  by blast
  14.436 +
  14.437 +lemma Int_mono: "[| A<=C;  B<=D |] ==> A Int B <= C Int D"
  14.438 +  by blast
  14.439 +
  14.440 +lemma Compl_anti_mono: "[| A<=B |] ==> Compl(B) <= Compl(A)"
  14.441 +  by blast
  14.442  
  14.443  end
  14.444 -
    15.1 --- a/src/CCL/Term.ML	Mon Jul 17 18:42:38 2006 +0200
    15.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.3 @@ -1,144 +0,0 @@
    15.4 -(*  Title:      CCL/Term.ML
    15.5 -    ID:         $Id$
    15.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    15.7 -    Copyright   1993  University of Cambridge
    15.8 -*)
    15.9 -
   15.10 -val simp_can_defs = [one_def,inl_def,inr_def];
   15.11 -val simp_ncan_defs = [if_def,when_def,split_def,fst_def,snd_def,thd_def];
   15.12 -val simp_defs = simp_can_defs @ simp_ncan_defs;
   15.13 -
   15.14 -val ind_can_defs = [zero_def,succ_def,nil_def,cons_def];
   15.15 -val ind_ncan_defs = [ncase_def,nrec_def,lcase_def,lrec_def];
   15.16 -val ind_defs = ind_can_defs @ ind_ncan_defs;
   15.17 -
   15.18 -val data_defs = simp_defs @ ind_defs @ [napply_def];
   15.19 -val genrec_defs = [letrec_def,letrec2_def,letrec3_def];
   15.20 -
   15.21 -(*** Beta Rules, including strictness ***)
   15.22 -
   15.23 -Goalw [let_def] "~ t=bot--> let x be t in f(x) = f(t)";
   15.24 -by (res_inst_tac [("t","t")] term_case 1);
   15.25 -by (ALLGOALS(simp_tac(CCL_ss addsimps [caseBtrue,caseBfalse,caseBpair,caseBlam])));
   15.26 -bind_thm("letB", result() RS mp);
   15.27 -
   15.28 -Goalw [let_def] "let x be bot in f(x) = bot";
   15.29 -by (rtac caseBbot 1);
   15.30 -qed "letBabot";
   15.31 -
   15.32 -Goalw [let_def] "let x be t in bot = bot";
   15.33 -by (resolve_tac ([caseBbot] RL [term_case]) 1);
   15.34 -by (ALLGOALS(simp_tac(CCL_ss addsimps [caseBtrue,caseBfalse,caseBpair,caseBlam])));
   15.35 -qed "letBbbot";
   15.36 -
   15.37 -Goalw [apply_def] "(lam x. b(x)) ` a = b(a)";
   15.38 -by (ALLGOALS(simp_tac(CCL_ss addsimps [caseBtrue,caseBfalse,caseBpair,caseBlam])));
   15.39 -qed "applyB";
   15.40 -
   15.41 -Goalw [apply_def] "bot ` a = bot";
   15.42 -by (rtac caseBbot 1);
   15.43 -qed "applyBbot";
   15.44 -
   15.45 -Goalw [fix_def] "fix(f) = f(fix(f))";
   15.46 -by (resolve_tac [applyB RS ssubst] 1 THEN rtac refl 1);
   15.47 -qed "fixB";
   15.48 -
   15.49 -Goalw [letrec_def]
   15.50 -      "letrec g x be h(x,g) in g(a) = h(a,%y. letrec g x be h(x,g) in g(y))";
   15.51 -by (resolve_tac [fixB RS ssubst] 1 THEN
   15.52 -    resolve_tac [applyB RS ssubst] 1 THEN rtac refl 1);
   15.53 -qed "letrecB";
   15.54 -
   15.55 -val rawBs = caseBs @ [applyB,applyBbot];
   15.56 -
   15.57 -fun raw_mk_beta_rl defs s = prove_goalw (the_context ()) defs s
   15.58 -           (fn _ => [stac letrecB 1,
   15.59 -                     simp_tac (CCL_ss addsimps rawBs) 1]);
   15.60 -fun mk_beta_rl s = raw_mk_beta_rl data_defs s;
   15.61 -
   15.62 -fun raw_mk_beta_rl defs s = prove_goalw (the_context ()) defs s
   15.63 -           (fn _ => [simp_tac (CCL_ss addsimps rawBs
   15.64 -                               setloop (stac letrecB)) 1]);
   15.65 -fun mk_beta_rl s = raw_mk_beta_rl data_defs s;
   15.66 -
   15.67 -val ifBtrue    = mk_beta_rl "if true then t else u = t";
   15.68 -val ifBfalse   = mk_beta_rl "if false then t else u = u";
   15.69 -val ifBbot     = mk_beta_rl "if bot then t else u = bot";
   15.70 -
   15.71 -val whenBinl   = mk_beta_rl "when(inl(a),t,u) = t(a)";
   15.72 -val whenBinr   = mk_beta_rl "when(inr(a),t,u) = u(a)";
   15.73 -val whenBbot   = mk_beta_rl "when(bot,t,u) = bot";
   15.74 -
   15.75 -val splitB     = mk_beta_rl "split(<a,b>,h) = h(a,b)";
   15.76 -val splitBbot  = mk_beta_rl "split(bot,h) = bot";
   15.77 -val fstB       = mk_beta_rl "fst(<a,b>) = a";
   15.78 -val fstBbot    = mk_beta_rl "fst(bot) = bot";
   15.79 -val sndB       = mk_beta_rl "snd(<a,b>) = b";
   15.80 -val sndBbot    = mk_beta_rl "snd(bot) = bot";
   15.81 -val thdB       = mk_beta_rl "thd(<a,<b,c>>) = c";
   15.82 -val thdBbot    = mk_beta_rl "thd(bot) = bot";
   15.83 -
   15.84 -val ncaseBzero = mk_beta_rl "ncase(zero,t,u) = t";
   15.85 -val ncaseBsucc = mk_beta_rl "ncase(succ(n),t,u) = u(n)";
   15.86 -val ncaseBbot  = mk_beta_rl "ncase(bot,t,u) = bot";
   15.87 -val nrecBzero  = mk_beta_rl "nrec(zero,t,u) = t";
   15.88 -val nrecBsucc  = mk_beta_rl "nrec(succ(n),t,u) = u(n,nrec(n,t,u))";
   15.89 -val nrecBbot   = mk_beta_rl "nrec(bot,t,u) = bot";
   15.90 -
   15.91 -val lcaseBnil  = mk_beta_rl "lcase([],t,u) = t";
   15.92 -val lcaseBcons = mk_beta_rl "lcase(x$xs,t,u) = u(x,xs)";
   15.93 -val lcaseBbot  = mk_beta_rl "lcase(bot,t,u) = bot";
   15.94 -val lrecBnil   = mk_beta_rl "lrec([],t,u) = t";
   15.95 -val lrecBcons  = mk_beta_rl "lrec(x$xs,t,u) = u(x,xs,lrec(xs,t,u))";
   15.96 -val lrecBbot   = mk_beta_rl "lrec(bot,t,u) = bot";
   15.97 -
   15.98 -val letrec2B = raw_mk_beta_rl (data_defs @ [letrec2_def])
   15.99 -       "letrec g x y be h(x,y,g) in g(p,q) = \
  15.100 -\                     h(p,q,%u v. letrec g x y be h(x,y,g) in g(u,v))";
  15.101 -val letrec3B = raw_mk_beta_rl (data_defs @ [letrec3_def])
  15.102 -       "letrec g x y z be h(x,y,z,g) in g(p,q,r) = \
  15.103 -\                     h(p,q,r,%u v w. letrec g x y z be h(x,y,z,g) in g(u,v,w))";
  15.104 -
  15.105 -val napplyBzero   = mk_beta_rl "f^zero`a = a";
  15.106 -val napplyBsucc   = mk_beta_rl "f^succ(n)`a = f(f^n`a)";
  15.107 -
  15.108 -val termBs = [letB,applyB,applyBbot,splitB,splitBbot,
  15.109 -              fstB,fstBbot,sndB,sndBbot,thdB,thdBbot,
  15.110 -              ifBtrue,ifBfalse,ifBbot,whenBinl,whenBinr,whenBbot,
  15.111 -              ncaseBzero,ncaseBsucc,ncaseBbot,nrecBzero,nrecBsucc,nrecBbot,
  15.112 -              lcaseBnil,lcaseBcons,lcaseBbot,lrecBnil,lrecBcons,lrecBbot,
  15.113 -              napplyBzero,napplyBsucc];
  15.114 -
  15.115 -(*** Constructors are injective ***)
  15.116 -
  15.117 -val term_injs = map (mk_inj_rl (the_context ())
  15.118 -                     [applyB,splitB,whenBinl,whenBinr,ncaseBsucc,lcaseBcons])
  15.119 -               ["(inl(a) = inl(a')) <-> (a=a')",
  15.120 -                "(inr(a) = inr(a')) <-> (a=a')",
  15.121 -                "(succ(a) = succ(a')) <-> (a=a')",
  15.122 -                "(a$b = a'$b') <-> (a=a' & b=b')"];
  15.123 -
  15.124 -(*** Constructors are distinct ***)
  15.125 -
  15.126 -val term_dstncts = mkall_dstnct_thms (the_context ()) data_defs (ccl_injs @ term_injs)
  15.127 -                    [["bot","inl","inr"],["bot","zero","succ"],["bot","nil","op $"]];
  15.128 -
  15.129 -(*** Rules for pre-order [= ***)
  15.130 -
  15.131 -local
  15.132 -  fun mk_thm s = prove_goalw (the_context ()) data_defs s (fn _ =>
  15.133 -                  [simp_tac (ccl_ss addsimps (ccl_porews)) 1]);
  15.134 -in
  15.135 -  val term_porews = map mk_thm ["inl(a) [= inl(a') <-> a [= a'",
  15.136 -                                "inr(b) [= inr(b') <-> b [= b'",
  15.137 -                                "succ(n) [= succ(n') <-> n [= n'",
  15.138 -                                "x$xs [= x'$xs' <-> x [= x'  & xs [= xs'"];
  15.139 -end;
  15.140 -
  15.141 -(*** Rewriting and Proving ***)
  15.142 -
  15.143 -val term_rews = termBs @ term_injs @ term_dstncts @ ccl_porews @ term_porews;
  15.144 -val term_ss = ccl_ss addsimps term_rews;
  15.145 -
  15.146 -val term_cs = ccl_cs addSEs (term_dstncts RL [notE])
  15.147 -                     addSDs (XH_to_Ds term_injs);
    16.1 --- a/src/CCL/Term.thy	Mon Jul 17 18:42:38 2006 +0200
    16.2 +++ b/src/CCL/Term.thy	Tue Jul 18 02:22:38 2006 +0200
    16.3 @@ -143,6 +143,183 @@
    16.4  
    16.5    napply_def: "f ^n` a == nrec(n,a,%x g. f(g))"
    16.6  
    16.7 -ML {* use_legacy_bindings (the_context ()) *}
    16.8 +
    16.9 +lemmas simp_can_defs = one_def inl_def inr_def
   16.10 +  and simp_ncan_defs = if_def when_def split_def fst_def snd_def thd_def
   16.11 +lemmas simp_defs = simp_can_defs simp_ncan_defs
   16.12 +
   16.13 +lemmas ind_can_defs = zero_def succ_def nil_def cons_def
   16.14 +  and ind_ncan_defs = ncase_def nrec_def lcase_def lrec_def
   16.15 +lemmas ind_defs = ind_can_defs ind_ncan_defs
   16.16 +
   16.17 +lemmas data_defs = simp_defs ind_defs napply_def
   16.18 +  and genrec_defs = letrec_def letrec2_def letrec3_def
   16.19 +
   16.20 +
   16.21 +subsection {* Beta Rules, including strictness *}
   16.22 +
   16.23 +lemma letB: "~ t=bot ==> let x be t in f(x) = f(t)"
   16.24 +  apply (unfold let_def)
   16.25 +  apply (erule rev_mp)
   16.26 +  apply (rule_tac t = "t" in term_case)
   16.27 +      apply (simp_all add: caseBtrue caseBfalse caseBpair caseBlam)
   16.28 +  done
   16.29 +
   16.30 +lemma letBabot: "let x be bot in f(x) = bot"
   16.31 +  apply (unfold let_def)
   16.32 +  apply (rule caseBbot)
   16.33 +  done
   16.34 +
   16.35 +lemma letBbbot: "let x be t in bot = bot"
   16.36 +  apply (unfold let_def)
   16.37 +  apply (rule_tac t = t in term_case)
   16.38 +      apply (rule caseBbot)
   16.39 +     apply (simp_all add: caseBtrue caseBfalse caseBpair caseBlam)
   16.40 +  done
   16.41 +
   16.42 +lemma applyB: "(lam x. b(x)) ` a = b(a)"
   16.43 +  apply (unfold apply_def)
   16.44 +  apply (simp add: caseBtrue caseBfalse caseBpair caseBlam)
   16.45 +  done
   16.46 +
   16.47 +lemma applyBbot: "bot ` a = bot"
   16.48 +  apply (unfold apply_def)
   16.49 +  apply (rule caseBbot)
   16.50 +  done
   16.51 +
   16.52 +lemma fixB: "fix(f) = f(fix(f))"
   16.53 +  apply (unfold fix_def)
   16.54 +  apply (rule applyB [THEN ssubst], rule refl)
   16.55 +  done
   16.56 +
   16.57 +lemma letrecB:
   16.58 +    "letrec g x be h(x,g) in g(a) = h(a,%y. letrec g x be h(x,g) in g(y))"
   16.59 +  apply (unfold letrec_def)
   16.60 +  apply (rule fixB [THEN ssubst], rule applyB [THEN ssubst], rule refl)
   16.61 +  done
   16.62 +
   16.63 +lemmas rawBs = caseBs applyB applyBbot
   16.64 +
   16.65 +ML {*
   16.66 +local
   16.67 +  val letrecB = thm "letrecB"
   16.68 +  val rawBs = thms "rawBs"
   16.69 +  val data_defs = thms "data_defs"
   16.70 +in
   16.71 +
   16.72 +fun raw_mk_beta_rl defs s = prove_goalw (the_context ()) defs s
   16.73 +           (fn _ => [stac letrecB 1,
   16.74 +                     simp_tac (simpset () addsimps rawBs) 1]);
   16.75 +fun mk_beta_rl s = raw_mk_beta_rl data_defs s;
   16.76 +
   16.77 +fun raw_mk_beta_rl defs s = prove_goalw (the_context ()) defs s
   16.78 +           (fn _ => [simp_tac (simpset () addsimps rawBs
   16.79 +                               setloop (stac letrecB)) 1]);
   16.80 +fun mk_beta_rl s = raw_mk_beta_rl data_defs s;
   16.81  
   16.82  end
   16.83 +*}
   16.84 +
   16.85 +ML {*
   16.86 +bind_thm ("ifBtrue", mk_beta_rl "if true then t else u = t");
   16.87 +bind_thm ("ifBfalse", mk_beta_rl "if false then t else u = u");
   16.88 +bind_thm ("ifBbot", mk_beta_rl "if bot then t else u = bot");
   16.89 +
   16.90 +bind_thm ("whenBinl", mk_beta_rl "when(inl(a),t,u) = t(a)");
   16.91 +bind_thm ("whenBinr", mk_beta_rl "when(inr(a),t,u) = u(a)");
   16.92 +bind_thm ("whenBbot", mk_beta_rl "when(bot,t,u) = bot");
   16.93 +
   16.94 +bind_thm ("splitB", mk_beta_rl "split(<a,b>,h) = h(a,b)");
   16.95 +bind_thm ("splitBbot", mk_beta_rl "split(bot,h) = bot");
   16.96 +bind_thm ("fstB", mk_beta_rl "fst(<a,b>) = a");
   16.97 +bind_thm ("fstBbot", mk_beta_rl "fst(bot) = bot");
   16.98 +bind_thm ("sndB", mk_beta_rl "snd(<a,b>) = b");
   16.99 +bind_thm ("sndBbot", mk_beta_rl "snd(bot) = bot");
  16.100 +bind_thm ("thdB", mk_beta_rl "thd(<a,<b,c>>) = c");
  16.101 +bind_thm ("thdBbot", mk_beta_rl "thd(bot) = bot");
  16.102 +
  16.103 +bind_thm ("ncaseBzero", mk_beta_rl "ncase(zero,t,u) = t");
  16.104 +bind_thm ("ncaseBsucc", mk_beta_rl "ncase(succ(n),t,u) = u(n)");
  16.105 +bind_thm ("ncaseBbot", mk_beta_rl "ncase(bot,t,u) = bot");
  16.106 +bind_thm ("nrecBzero", mk_beta_rl "nrec(zero,t,u) = t");
  16.107 +bind_thm ("nrecBsucc", mk_beta_rl "nrec(succ(n),t,u) = u(n,nrec(n,t,u))");
  16.108 +bind_thm ("nrecBbot", mk_beta_rl "nrec(bot,t,u) = bot");
  16.109 +
  16.110 +bind_thm ("lcaseBnil", mk_beta_rl "lcase([],t,u) = t");
  16.111 +bind_thm ("lcaseBcons", mk_beta_rl "lcase(x$xs,t,u) = u(x,xs)");
  16.112 +bind_thm ("lcaseBbot", mk_beta_rl "lcase(bot,t,u) = bot");
  16.113 +bind_thm ("lrecBnil", mk_beta_rl "lrec([],t,u) = t");
  16.114 +bind_thm ("lrecBcons", mk_beta_rl "lrec(x$xs,t,u) = u(x,xs,lrec(xs,t,u))");
  16.115 +bind_thm ("lrecBbot", mk_beta_rl "lrec(bot,t,u) = bot");
  16.116 +
  16.117 +bind_thm ("letrec2B", raw_mk_beta_rl (thms "data_defs" @ [thm "letrec2_def"])
  16.118 +  "letrec g x y be h(x,y,g) in g(p,q) = h(p,q,%u v. letrec g x y be h(x,y,g) in g(u,v))");
  16.119 +
  16.120 +bind_thm ("letrec3B", raw_mk_beta_rl (thms "data_defs" @ [thm "letrec3_def"])
  16.121 +  "letrec g x y z be h(x,y,z,g) in g(p,q,r) = h(p,q,r,%u v w. letrec g x y z be h(x,y,z,g) in g(u,v,w))");
  16.122 +
  16.123 +bind_thm ("napplyBzero", mk_beta_rl "f^zero`a = a");
  16.124 +bind_thm ("napplyBsucc", mk_beta_rl "f^succ(n)`a = f(f^n`a)");
  16.125 +
  16.126 +bind_thms ("termBs", [thm "letB", thm "applyB", thm "applyBbot", splitB,splitBbot,
  16.127 +  fstB,fstBbot,sndB,sndBbot,thdB,thdBbot,
  16.128 +  ifBtrue,ifBfalse,ifBbot,whenBinl,whenBinr,whenBbot,
  16.129 +  ncaseBzero,ncaseBsucc,ncaseBbot,nrecBzero,nrecBsucc,nrecBbot,
  16.130 +  lcaseBnil,lcaseBcons,lcaseBbot,lrecBnil,lrecBcons,lrecBbot,
  16.131 +  napplyBzero,napplyBsucc]);
  16.132 +*}
  16.133 +
  16.134 +
  16.135 +subsection {* Constructors are injective *}
  16.136 +
  16.137 +ML {*
  16.138 +
  16.139 +bind_thms ("term_injs", map (mk_inj_rl (the_context ())
  16.140 +  [thm "applyB", thm "splitB", thm "whenBinl", thm "whenBinr", thm "ncaseBsucc", thm "lcaseBcons"])
  16.141 +    ["(inl(a) = inl(a')) <-> (a=a')",
  16.142 +     "(inr(a) = inr(a')) <-> (a=a')",
  16.143 +     "(succ(a) = succ(a')) <-> (a=a')",
  16.144 +     "(a$b = a'$b') <-> (a=a' & b=b')"])
  16.145 +*}
  16.146 +
  16.147 +
  16.148 +subsection {* Constructors are distinct *}
  16.149 +
  16.150 +ML {*
  16.151 +bind_thms ("term_dstncts",
  16.152 +  mkall_dstnct_thms (the_context ()) (thms "data_defs") (thms "ccl_injs" @ thms "term_injs")
  16.153 +    [["bot","inl","inr"], ["bot","zero","succ"], ["bot","nil","op $"]]);
  16.154 +*}
  16.155 +
  16.156 +
  16.157 +subsection {* Rules for pre-order @{text "[="} *}
  16.158 +
  16.159 +ML {*
  16.160 +
  16.161 +local
  16.162 +  fun mk_thm s = prove_goalw (the_context ()) (thms "data_defs") s (fn _ =>
  16.163 +    [simp_tac (simpset () addsimps (thms "ccl_porews")) 1])
  16.164 +in
  16.165 +  val term_porews = map mk_thm ["inl(a) [= inl(a') <-> a [= a'",
  16.166 +                                "inr(b) [= inr(b') <-> b [= b'",
  16.167 +                                "succ(n) [= succ(n') <-> n [= n'",
  16.168 +                                "x$xs [= x'$xs' <-> x [= x'  & xs [= xs'"]
  16.169 +end;
  16.170 +
  16.171 +bind_thms ("term_porews", term_porews);
  16.172 +*}
  16.173 +
  16.174 +
  16.175 +subsection {* Rewriting and Proving *}
  16.176 +
  16.177 +lemmas term_rews = termBs term_injs term_dstncts ccl_porews term_porews
  16.178 +
  16.179 +ML {*
  16.180 +  bind_thms ("term_injDs", XH_to_Ds term_injs);
  16.181 +*}
  16.182 +
  16.183 +lemmas [simp] = term_rews
  16.184 +  and [elim!] = term_dstncts [THEN notE]
  16.185 +  and [dest!] = term_injDs
  16.186 +
  16.187 +end
    17.1 --- a/src/CCL/Trancl.ML	Mon Jul 17 18:42:38 2006 +0200
    17.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.3 @@ -1,205 +0,0 @@
    17.4 -(*  Title:      CCL/Trancl.ML
    17.5 -    ID:         $Id$
    17.6 -*)
    17.7 -
    17.8 -(** Natural deduction for trans(r) **)
    17.9 -
   17.10 -val prems = goalw (the_context ()) [trans_def]
   17.11 -    "(!! x y z. [| <x,y>:r;  <y,z>:r |] ==> <x,z>:r) ==> trans(r)";
   17.12 -by (REPEAT (ares_tac (prems@[allI,impI]) 1));
   17.13 -qed "transI";
   17.14 -
   17.15 -val major::prems = goalw (the_context ()) [trans_def]
   17.16 -    "[| trans(r);  <a,b>:r;  <b,c>:r |] ==> <a,c>:r";
   17.17 -by (cut_facts_tac [major] 1);
   17.18 -by (fast_tac (FOL_cs addIs prems) 1);
   17.19 -qed "transD";
   17.20 -
   17.21 -(** Identity relation **)
   17.22 -
   17.23 -Goalw [id_def] "<a,a> : id";
   17.24 -by (rtac CollectI 1);
   17.25 -by (rtac exI 1);
   17.26 -by (rtac refl 1);
   17.27 -qed "idI";
   17.28 -
   17.29 -val major::prems = goalw (the_context ()) [id_def]
   17.30 -    "[| p: id;  !!x.[| p = <x,x> |] ==> P  \
   17.31 -\    |] ==>  P";
   17.32 -by (rtac (major RS CollectE) 1);
   17.33 -by (etac exE 1);
   17.34 -by (eresolve_tac prems 1);
   17.35 -qed "idE";
   17.36 -
   17.37 -(** Composition of two relations **)
   17.38 -
   17.39 -val prems = goalw (the_context ()) [comp_def]
   17.40 -    "[| <a,b>:s; <b,c>:r |] ==> <a,c> : r O s";
   17.41 -by (fast_tac (set_cs addIs prems) 1);
   17.42 -qed "compI";
   17.43 -
   17.44 -(*proof requires higher-level assumptions or a delaying of hyp_subst_tac*)
   17.45 -val prems = goalw (the_context ()) [comp_def]
   17.46 -    "[| xz : r O s;  \
   17.47 -\       !!x y z. [| xz = <x,z>;  <x,y>:s;  <y,z>:r |] ==> P \
   17.48 -\    |] ==> P";
   17.49 -by (cut_facts_tac prems 1);
   17.50 -by (REPEAT (eresolve_tac [CollectE, exE, conjE] 1 ORELSE ares_tac prems 1));
   17.51 -qed "compE";
   17.52 -
   17.53 -val prems = goal (the_context ())
   17.54 -    "[| <a,c> : r O s;  \
   17.55 -\       !!y. [| <a,y>:s;  <y,c>:r |] ==> P \
   17.56 -\    |] ==> P";
   17.57 -by (rtac compE 1);
   17.58 -by (REPEAT (ares_tac prems 1 ORELSE eresolve_tac [pair_inject,ssubst] 1));
   17.59 -qed "compEpair";
   17.60 -
   17.61 -val comp_cs = set_cs addIs [compI,idI]
   17.62 -                       addEs [compE,idE]
   17.63 -                       addSEs [pair_inject];
   17.64 -
   17.65 -val prems = goal (the_context ())
   17.66 -    "[| r'<=r; s'<=s |] ==> (r' O s') <= (r O s)";
   17.67 -by (cut_facts_tac prems 1);
   17.68 -by (fast_tac comp_cs 1);
   17.69 -qed "comp_mono";
   17.70 -
   17.71 -(** The relation rtrancl **)
   17.72 -
   17.73 -Goal "mono(%s. id Un (r O s))";
   17.74 -by (rtac monoI 1);
   17.75 -by (REPEAT (ares_tac [monoI, subset_refl, comp_mono, Un_mono] 1));
   17.76 -qed "rtrancl_fun_mono";
   17.77 -
   17.78 -val rtrancl_unfold = rtrancl_fun_mono RS (rtrancl_def RS def_lfp_Tarski);
   17.79 -
   17.80 -(*Reflexivity of rtrancl*)
   17.81 -Goal "<a,a> : r^*";
   17.82 -by (stac rtrancl_unfold 1);
   17.83 -by (fast_tac comp_cs 1);
   17.84 -qed "rtrancl_refl";
   17.85 -
   17.86 -(*Closure under composition with r*)
   17.87 -val prems = goal (the_context ())
   17.88 -    "[| <a,b> : r^*;  <b,c> : r |] ==> <a,c> : r^*";
   17.89 -by (stac rtrancl_unfold 1);
   17.90 -by (fast_tac (comp_cs addIs prems) 1);
   17.91 -qed "rtrancl_into_rtrancl";
   17.92 -
   17.93 -(*rtrancl of r contains r*)
   17.94 -val [prem] = goal (the_context ()) "[| <a,b> : r |] ==> <a,b> : r^*";
   17.95 -by (rtac (rtrancl_refl RS rtrancl_into_rtrancl) 1);
   17.96 -by (rtac prem 1);
   17.97 -qed "r_into_rtrancl";
   17.98 -
   17.99 -
  17.100 -(** standard induction rule **)
  17.101 -
  17.102 -val major::prems = goal (the_context ())
  17.103 -  "[| <a,b> : r^*; \
  17.104 -\     !!x. P(<x,x>); \
  17.105 -\     !!x y z.[| P(<x,y>); <x,y>: r^*; <y,z>: r |]  ==>  P(<x,z>) |] \
  17.106 -\  ==>  P(<a,b>)";
  17.107 -by (rtac (major RS (rtrancl_def RS def_induct)) 1);
  17.108 -by (rtac rtrancl_fun_mono 1);
  17.109 -by (fast_tac (comp_cs addIs prems) 1);
  17.110 -qed "rtrancl_full_induct";
  17.111 -
  17.112 -(*nice induction rule*)
  17.113 -val major::prems = goal (the_context ())
  17.114 -    "[| <a,b> : r^*;    \
  17.115 -\       P(a); \
  17.116 -\       !!y z.[| <a,y> : r^*;  <y,z> : r;  P(y) |] ==> P(z) |]  \
  17.117 -\     ==> P(b)";
  17.118 -(*by induction on this formula*)
  17.119 -by (subgoal_tac "ALL y. <a,b> = <a,y> --> P(y)" 1);
  17.120 -(*now solve first subgoal: this formula is sufficient*)
  17.121 -by (fast_tac FOL_cs 1);
  17.122 -(*now do the induction*)
  17.123 -by (resolve_tac [major RS rtrancl_full_induct] 1);
  17.124 -by (fast_tac (comp_cs addIs prems) 1);
  17.125 -by (fast_tac (comp_cs addIs prems) 1);
  17.126 -qed "rtrancl_induct";
  17.127 -
  17.128 -(*transitivity of transitive closure!! -- by induction.*)
  17.129 -Goal "trans(r^*)";
  17.130 -by (rtac transI 1);
  17.131 -by (res_inst_tac [("b","z")] rtrancl_induct 1);
  17.132 -by (DEPTH_SOLVE (eresolve_tac [asm_rl, rtrancl_into_rtrancl] 1));
  17.133 -qed "trans_rtrancl";
  17.134 -
  17.135 -(*elimination of rtrancl -- by induction on a special formula*)
  17.136 -val major::prems = goal (the_context ())
  17.137 -    "[| <a,b> : r^*;  (a = b) ==> P; \
  17.138 -\       !!y.[| <a,y> : r^*; <y,b> : r |] ==> P |] \
  17.139 -\    ==> P";
  17.140 -by (subgoal_tac "a = b  | (EX y. <a,y> : r^* & <y,b> : r)" 1);
  17.141 -by (rtac (major RS rtrancl_induct) 2);
  17.142 -by (fast_tac (set_cs addIs prems) 2);
  17.143 -by (fast_tac (set_cs addIs prems) 2);
  17.144 -by (REPEAT (eresolve_tac ([asm_rl,exE,disjE,conjE]@prems) 1));
  17.145 -qed "rtranclE";
  17.146 -
  17.147 -
  17.148 -(**** The relation trancl ****)
  17.149 -
  17.150 -(** Conversions between trancl and rtrancl **)
  17.151 -
  17.152 -val [major] = goalw (the_context ()) [trancl_def]
  17.153 -    "[| <a,b> : r^+ |] ==> <a,b> : r^*";
  17.154 -by (resolve_tac [major RS compEpair] 1);
  17.155 -by (REPEAT (ares_tac [rtrancl_into_rtrancl] 1));
  17.156 -qed "trancl_into_rtrancl";
  17.157 -
  17.158 -(*r^+ contains r*)
  17.159 -val [prem] = goalw (the_context ()) [trancl_def]
  17.160 -   "[| <a,b> : r |] ==> <a,b> : r^+";
  17.161 -by (REPEAT (ares_tac [prem,compI,rtrancl_refl] 1));
  17.162 -qed "r_into_trancl";
  17.163 -
  17.164 -(*intro rule by definition: from rtrancl and r*)
  17.165 -val prems = goalw (the_context ()) [trancl_def]
  17.166 -    "[| <a,b> : r^*;  <b,c> : r |]   ==>  <a,c> : r^+";
  17.167 -by (REPEAT (resolve_tac ([compI]@prems) 1));
  17.168 -qed "rtrancl_into_trancl1";
  17.169 -
  17.170 -(*intro rule from r and rtrancl*)
  17.171 -val prems = goal (the_context ())
  17.172 -    "[| <a,b> : r;  <b,c> : r^* |]   ==>  <a,c> : r^+";
  17.173 -by (resolve_tac (prems RL [rtranclE]) 1);
  17.174 -by (etac subst 1);
  17.175 -by (resolve_tac (prems RL [r_into_trancl]) 1);
  17.176 -by (rtac (trans_rtrancl RS transD RS rtrancl_into_trancl1) 1);
  17.177 -by (REPEAT (ares_tac (prems@[r_into_rtrancl]) 1));
  17.178 -qed "rtrancl_into_trancl2";
  17.179 -
  17.180 -(*elimination of r^+ -- NOT an induction rule*)
  17.181 -val major::prems = goal (the_context ())
  17.182 -    "[| <a,b> : r^+;  \
  17.183 -\       <a,b> : r ==> P; \
  17.184 -\       !!y.[| <a,y> : r^+;  <y,b> : r |] ==> P  \
  17.185 -\    |] ==> P";
  17.186 -by (subgoal_tac "<a,b> : r | (EX y. <a,y> : r^+  &  <y,b> : r)" 1);
  17.187 -by (REPEAT (eresolve_tac ([asm_rl,disjE,exE,conjE]@prems) 1));
  17.188 -by (rtac (rewrite_rule [trancl_def] major RS compEpair) 1);
  17.189 -by (etac rtranclE 1);
  17.190 -by (fast_tac comp_cs 1);
  17.191 -by (fast_tac (comp_cs addSIs [rtrancl_into_trancl1]) 1);
  17.192 -qed "tranclE";
  17.193 -
  17.194 -(*Transitivity of r^+.
  17.195 -  Proved by unfolding since it uses transitivity of rtrancl. *)
  17.196 -Goalw [trancl_def] "trans(r^+)";
  17.197 -by (rtac transI 1);
  17.198 -by (REPEAT (etac compEpair 1));
  17.199 -by (rtac (rtrancl_into_rtrancl RS (trans_rtrancl RS transD RS compI)) 1);
  17.200 -by (REPEAT (assume_tac 1));
  17.201 -qed "trans_trancl";
  17.202 -
  17.203 -val prems = goal (the_context ())
  17.204 -    "[| <a,b> : r;  <b,c> : r^+ |]   ==>  <a,c> : r^+";
  17.205 -by (rtac (r_into_trancl RS (trans_trancl RS transD)) 1);
  17.206 -by (resolve_tac prems 1);
  17.207 -by (resolve_tac prems 1);
  17.208 -qed "trancl_into_trancl2";
    18.1 --- a/src/CCL/Trancl.thy	Mon Jul 17 18:42:38 2006 +0200
    18.2 +++ b/src/CCL/Trancl.thy	Tue Jul 18 02:22:38 2006 +0200
    18.3 @@ -26,6 +26,197 @@
    18.4    rtrancl_def:     "r^* == lfp(%s. id Un (r O s))"
    18.5    trancl_def:      "r^+ == r O rtrancl(r)"
    18.6  
    18.7 -ML {* use_legacy_bindings (the_context ()) *}
    18.8 +
    18.9 +subsection {* Natural deduction for @{text "trans(r)"} *}
   18.10 +
   18.11 +lemma transI:
   18.12 +  "(!! x y z. [| <x,y>:r;  <y,z>:r |] ==> <x,z>:r) ==> trans(r)"
   18.13 +  unfolding trans_def by blast
   18.14 +
   18.15 +lemma transD: "[| trans(r);  <a,b>:r;  <b,c>:r |] ==> <a,c>:r"
   18.16 +  unfolding trans_def by blast
   18.17 +
   18.18 +
   18.19 +subsection {* Identity relation *}
   18.20 +
   18.21 +lemma idI: "<a,a> : id"
   18.22 +  apply (unfold id_def)
   18.23 +  apply (rule CollectI)
   18.24 +  apply (rule exI)
   18.25 +  apply (rule refl)
   18.26 +  done
   18.27 +
   18.28 +lemma idE:
   18.29 +    "[| p: id;  !!x.[| p = <x,x> |] ==> P |] ==>  P"
   18.30 +  apply (unfold id_def)
   18.31 +  apply (erule CollectE)
   18.32 +  apply blast
   18.33 +  done
   18.34 +
   18.35 +
   18.36 +subsection {* Composition of two relations *}
   18.37 +
   18.38 +lemma compI: "[| <a,b>:s; <b,c>:r |] ==> <a,c> : r O s"
   18.39 +  unfolding comp_def by blast
   18.40 +
   18.41 +(*proof requires higher-level assumptions or a delaying of hyp_subst_tac*)
   18.42 +lemma compE:
   18.43 +    "[| xz : r O s;
   18.44 +        !!x y z. [| xz = <x,z>;  <x,y>:s;  <y,z>:r |] ==> P
   18.45 +     |] ==> P"
   18.46 +  unfolding comp_def by blast
   18.47 +
   18.48 +lemma compEpair:
   18.49 +  "[| <a,c> : r O s;
   18.50 +      !!y. [| <a,y>:s;  <y,c>:r |] ==> P
   18.51 +   |] ==> P"
   18.52 +  apply (erule compE)
   18.53 +  apply (simp add: pair_inject)
   18.54 +  done
   18.55 +
   18.56 +lemmas [intro] = compI idI
   18.57 +  and [elim] = compE idE
   18.58 +  and [elim!] = pair_inject
   18.59 +
   18.60 +lemma comp_mono: "[| r'<=r; s'<=s |] ==> (r' O s') <= (r O s)"
   18.61 +  by blast
   18.62 +
   18.63 +
   18.64 +subsection {* The relation rtrancl *}
   18.65 +
   18.66 +lemma rtrancl_fun_mono: "mono(%s. id Un (r O s))"
   18.67 +  apply (rule monoI)
   18.68 +  apply (rule monoI subset_refl comp_mono Un_mono)+
   18.69 +  apply assumption
   18.70 +  done
   18.71 +
   18.72 +lemma rtrancl_unfold: "r^* = id Un (r O r^*)"
   18.73 +  by (rule rtrancl_fun_mono [THEN rtrancl_def [THEN def_lfp_Tarski]])
   18.74 +
   18.75 +(*Reflexivity of rtrancl*)
   18.76 +lemma rtrancl_refl: "<a,a> : r^*"
   18.77 +  apply (subst rtrancl_unfold)
   18.78 +  apply blast
   18.79 +  done
   18.80 +
   18.81 +(*Closure under composition with r*)
   18.82 +lemma rtrancl_into_rtrancl: "[| <a,b> : r^*;  <b,c> : r |] ==> <a,c> : r^*"
   18.83 +  apply (subst rtrancl_unfold)
   18.84 +  apply blast
   18.85 +  done
   18.86 +
   18.87 +(*rtrancl of r contains r*)
   18.88 +lemma r_into_rtrancl: "[| <a,b> : r |] ==> <a,b> : r^*"
   18.89 +  apply (rule rtrancl_refl [THEN rtrancl_into_rtrancl])
   18.90 +  apply assumption
   18.91 +  done
   18.92 +
   18.93 +
   18.94 +subsection {* standard induction rule *}
   18.95 +
   18.96 +lemma rtrancl_full_induct:
   18.97 +  "[| <a,b> : r^*;
   18.98 +      !!x. P(<x,x>);
   18.99 +      !!x y z.[| P(<x,y>); <x,y>: r^*; <y,z>: r |]  ==>  P(<x,z>) |]
  18.100 +   ==>  P(<a,b>)"
  18.101 +  apply (erule def_induct [OF rtrancl_def])
  18.102 +   apply (rule rtrancl_fun_mono)
  18.103 +  apply blast
  18.104 +  done
  18.105 +
  18.106 +(*nice induction rule*)
  18.107 +lemma rtrancl_induct:
  18.108 +  "[| <a,b> : r^*;
  18.109 +      P(a);
  18.110 +      !!y z.[| <a,y> : r^*;  <y,z> : r;  P(y) |] ==> P(z) |]
  18.111 +    ==> P(b)"
  18.112 +(*by induction on this formula*)
  18.113 +  apply (subgoal_tac "ALL y. <a,b> = <a,y> --> P(y)")
  18.114 +(*now solve first subgoal: this formula is sufficient*)
  18.115 +  apply blast
  18.116 +(*now do the induction*)
  18.117 +  apply (erule rtrancl_full_induct)
  18.118 +   apply blast
  18.119 +  apply blast
  18.120 +  done
  18.121 +
  18.122 +(*transitivity of transitive closure!! -- by induction.*)
  18.123 +lemma trans_rtrancl: "trans(r^*)"
  18.124 +  apply (rule transI)
  18.125 +  apply (rule_tac b = z in rtrancl_induct)
  18.126 +    apply (fast elim: rtrancl_into_rtrancl)+
  18.127 +  done
  18.128 +
  18.129 +(*elimination of rtrancl -- by induction on a special formula*)
  18.130 +lemma rtranclE:
  18.131 +  "[| <a,b> : r^*;  (a = b) ==> P;
  18.132 +      !!y.[| <a,y> : r^*; <y,b> : r |] ==> P |]
  18.133 +   ==> P"
  18.134 +  apply (subgoal_tac "a = b | (EX y. <a,y> : r^* & <y,b> : r)")
  18.135 +   prefer 2
  18.136 +   apply (erule rtrancl_induct)
  18.137 +    apply blast
  18.138 +   apply blast
  18.139 +  apply blast
  18.140 +  done
  18.141 +
  18.142 +
  18.143 +subsection {* The relation trancl *}
  18.144 +
  18.145 +subsubsection {* Conversions between trancl and rtrancl *}
  18.146 +
  18.147 +lemma trancl_into_rtrancl: "[| <a,b> : r^+ |] ==> <a,b> : r^*"
  18.148 +  apply (unfold trancl_def)
  18.149 +  apply (erule compEpair)
  18.150 +  apply (erule rtrancl_into_rtrancl)
  18.151 +  apply assumption
  18.152 +  done
  18.153 +
  18.154 +(*r^+ contains r*)
  18.155 +lemma r_into_trancl: "[| <a,b> : r |] ==> <a,b> : r^+"
  18.156 +  unfolding trancl_def by (blast intro: rtrancl_refl)
  18.157 +
  18.158 +(*intro rule by definition: from rtrancl and r*)
  18.159 +lemma rtrancl_into_trancl1: "[| <a,b> : r^*;  <b,c> : r |]   ==>  <a,c> : r^+"
  18.160 +  unfolding trancl_def by blast
  18.161 +
  18.162 +(*intro rule from r and rtrancl*)
  18.163 +lemma rtrancl_into_trancl2: "[| <a,b> : r;  <b,c> : r^* |]   ==>  <a,c> : r^+"
  18.164 +  apply (erule rtranclE)
  18.165 +   apply (erule subst)
  18.166 +   apply (erule r_into_trancl)
  18.167 +  apply (rule trans_rtrancl [THEN transD, THEN rtrancl_into_trancl1])
  18.168 +    apply (assumption | rule r_into_rtrancl)+
  18.169 +  done
  18.170 +
  18.171 +(*elimination of r^+ -- NOT an induction rule*)
  18.172 +lemma tranclE:
  18.173 +  "[| <a,b> : r^+;
  18.174 +      <a,b> : r ==> P;
  18.175 +      !!y.[| <a,y> : r^+;  <y,b> : r |] ==> P
  18.176 +   |] ==> P"
  18.177 +  apply (subgoal_tac "<a,b> : r | (EX y. <a,y> : r^+ & <y,b> : r)")
  18.178 +   apply blast
  18.179 +  apply (unfold trancl_def)
  18.180 +  apply (erule compEpair)
  18.181 +  apply (erule rtranclE)
  18.182 +   apply blast
  18.183 +  apply (blast intro!: rtrancl_into_trancl1)
  18.184 +  done
  18.185 +
  18.186 +(*Transitivity of r^+.
  18.187 +  Proved by unfolding since it uses transitivity of rtrancl. *)
  18.188 +lemma trans_trancl: "trans(r^+)"
  18.189 +  apply (unfold trancl_def)
  18.190 +  apply (rule transI)
  18.191 +  apply (erule compEpair)+
  18.192 +  apply (erule rtrancl_into_rtrancl [THEN trans_rtrancl [THEN transD, THEN compI]])
  18.193 +    apply assumption+
  18.194 +  done
  18.195 +
  18.196 +lemma trancl_into_trancl2: "[| <a,b> : r;  <b,c> : r^+ |]   ==>  <a,c> : r^+"
  18.197 +  apply (rule r_into_trancl [THEN trans_trancl [THEN transD]])
  18.198 +   apply assumption+
  18.199 +  done
  18.200  
  18.201  end
    19.1 --- a/src/CCL/Type.ML	Mon Jul 17 18:42:38 2006 +0200
    19.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.3 @@ -1,304 +0,0 @@
    19.4 -(*  Title:      CCL/Type.ML
    19.5 -    ID:         $Id$
    19.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    19.7 -    Copyright   1992  University of Cambridge
    19.8 -*)
    19.9 -
   19.10 -val simp_type_defs = [Subtype_def,Unit_def,Bool_def,Plus_def,Sigma_def,Pi_def,
   19.11 -                      Lift_def,Tall_def,Tex_def];
   19.12 -val ind_type_defs = [Nat_def,List_def];
   19.13 -
   19.14 -val simp_data_defs = [one_def,inl_def,inr_def];
   19.15 -val ind_data_defs = [zero_def,succ_def,nil_def,cons_def];
   19.16 -
   19.17 -goal (the_context ()) "A <= B <-> (ALL x. x:A --> x:B)";
   19.18 -by (fast_tac set_cs 1);
   19.19 -qed "subsetXH";
   19.20 -
   19.21 -(*** Exhaustion Rules ***)
   19.22 -
   19.23 -fun mk_XH_tac thy defs rls s = prove_goalw thy defs s (fn _ => [cfast_tac rls 1]);
   19.24 -val XH_tac = mk_XH_tac (the_context ()) simp_type_defs [];
   19.25 -
   19.26 -val EmptyXH = XH_tac "a : {} <-> False";
   19.27 -val SubtypeXH = XH_tac "a : {x:A. P(x)} <-> (a:A & P(a))";
   19.28 -val UnitXH = XH_tac "a : Unit          <-> a=one";
   19.29 -val BoolXH = XH_tac "a : Bool          <-> a=true | a=false";
   19.30 -val PlusXH = XH_tac "a : A+B           <-> (EX x:A. a=inl(x)) | (EX x:B. a=inr(x))";
   19.31 -val PiXH   = XH_tac "a : PROD x:A. B(x) <-> (EX b. a=lam x. b(x) & (ALL x:A. b(x):B(x)))";
   19.32 -val SgXH   = XH_tac "a : SUM x:A. B(x)  <-> (EX x:A. EX y:B(x).a=<x,y>)";
   19.33 -
   19.34 -val XHs = [EmptyXH,SubtypeXH,UnitXH,BoolXH,PlusXH,PiXH,SgXH];
   19.35 -
   19.36 -val LiftXH = XH_tac "a : [A] <-> (a=bot | a:A)";
   19.37 -val TallXH = XH_tac "a : TALL X. B(X) <-> (ALL X. a:B(X))";
   19.38 -val TexXH  = XH_tac "a : TEX X. B(X) <-> (EX X. a:B(X))";
   19.39 -
   19.40 -val case_rls = XH_to_Es XHs;
   19.41 -
   19.42 -(*** Canonical Type Rules ***)
   19.43 -
   19.44 -fun mk_canT_tac thy xhs s = prove_goal thy s
   19.45 -                 (fn prems => [fast_tac (set_cs addIs (prems @ (xhs RL [iffD2]))) 1]);
   19.46 -val canT_tac = mk_canT_tac (the_context ()) XHs;
   19.47 -
   19.48 -val oneT   = canT_tac "one : Unit";
   19.49 -val trueT  = canT_tac "true : Bool";
   19.50 -val falseT = canT_tac "false : Bool";
   19.51 -val lamT   = canT_tac "[| !!x. x:A ==> b(x):B(x) |] ==> lam x. b(x) : Pi(A,B)";
   19.52 -val pairT  = canT_tac "[| a:A; b:B(a) |] ==> <a,b>:Sigma(A,B)";
   19.53 -val inlT   = canT_tac "a:A ==> inl(a) : A+B";
   19.54 -val inrT   = canT_tac "b:B ==> inr(b) : A+B";
   19.55 -
   19.56 -val canTs = [oneT,trueT,falseT,pairT,lamT,inlT,inrT];
   19.57 -
   19.58 -(*** Non-Canonical Type Rules ***)
   19.59 -
   19.60 -local
   19.61 -val lemma = prove_goal (the_context ()) "[| a:B(u);  u=v |] ==> a : B(v)"
   19.62 -                   (fn prems => [cfast_tac prems 1]);
   19.63 -in
   19.64 -fun mk_ncanT_tac thy defs top_crls crls s = prove_goalw thy defs s
   19.65 -  (fn major::prems => [(resolve_tac ([major] RL top_crls) 1),
   19.66 -                       (REPEAT_SOME (eresolve_tac (crls @ [exE,bexE,conjE,disjE]))),
   19.67 -                       (ALLGOALS (asm_simp_tac term_ss)),
   19.68 -                       (ALLGOALS (ares_tac (prems RL [lemma]) ORELSE'
   19.69 -                                  etac bspec )),
   19.70 -                       (safe_tac (ccl_cs addSIs prems))]);
   19.71 -end;
   19.72 -
   19.73 -val ncanT_tac = mk_ncanT_tac (the_context ()) [] case_rls case_rls;
   19.74 -
   19.75 -val ifT = ncanT_tac
   19.76 -     "[| b:Bool; b=true ==> t:A(true); b=false ==> u:A(false) |] ==> \
   19.77 -\     if b then t else u : A(b)";
   19.78 -
   19.79 -val applyT = ncanT_tac
   19.80 -    "[| f : Pi(A,B);  a:A |] ==> f ` a : B(a)";
   19.81 -
   19.82 -val splitT = ncanT_tac
   19.83 -    "[| p:Sigma(A,B); !!x y. [| x:A;  y:B(x); p=<x,y>  |] ==> c(x,y):C(<x,y>) |] ==>  \
   19.84 -\     split(p,c):C(p)";
   19.85 -
   19.86 -val whenT = ncanT_tac
   19.87 -     "[| p:A+B; !!x.[| x:A;  p=inl(x) |] ==> a(x):C(inl(x)); \
   19.88 -\               !!y.[| y:B;  p=inr(y) |] ==> b(y):C(inr(y)) |] ==> \
   19.89 -\     when(p,a,b) : C(p)";
   19.90 -
   19.91 -val ncanTs = [ifT,applyT,splitT,whenT];
   19.92 -
   19.93 -(*** Subtypes ***)
   19.94 -
   19.95 -val SubtypeD1 = standard ((SubtypeXH RS iffD1) RS conjunct1);
   19.96 -val SubtypeD2 = standard ((SubtypeXH RS iffD1) RS conjunct2);
   19.97 -
   19.98 -val prems = goal (the_context ())
   19.99 -     "[| a:A;  P(a) |] ==> a : {x:A. P(x)}";
  19.100 -by (REPEAT (resolve_tac (prems@[SubtypeXH RS iffD2,conjI]) 1));
  19.101 -qed "SubtypeI";
  19.102 -
  19.103 -val prems = goal (the_context ())
  19.104 -     "[| a : {x:A. P(x)};  [| a:A;  P(a) |] ==> Q |] ==> Q";
  19.105 -by (REPEAT (resolve_tac (prems@[SubtypeD1,SubtypeD2]) 1));
  19.106 -qed "SubtypeE";
  19.107 -
  19.108 -(*** Monotonicity ***)
  19.109 -
  19.110 -Goal "mono (%X. X)";
  19.111 -by (REPEAT (ares_tac [monoI] 1));
  19.112 -qed "idM";
  19.113 -
  19.114 -Goal "mono(%X. A)";
  19.115 -by (REPEAT (ares_tac [monoI,subset_refl] 1));
  19.116 -qed "constM";
  19.117 -
  19.118 -val major::prems = goal (the_context ())
  19.119 -    "mono(%X. A(X)) ==> mono(%X.[A(X)])";
  19.120 -by (rtac (subsetI RS monoI) 1);
  19.121 -by (dtac (LiftXH RS iffD1) 1);
  19.122 -by (etac disjE 1);
  19.123 -by (etac (disjI1 RS (LiftXH RS iffD2)) 1);
  19.124 -by (rtac (disjI2 RS (LiftXH RS iffD2)) 1);
  19.125 -by (etac (major RS monoD RS subsetD) 1);
  19.126 -by (assume_tac 1);
  19.127 -qed "LiftM";
  19.128 -
  19.129 -val prems = goal (the_context ())
  19.130 -    "[| mono(%X. A(X)); !!x X. x:A(X) ==> mono(%X. B(X,x)) |] ==> \
  19.131 -\    mono(%X. Sigma(A(X),B(X)))";
  19.132 -by (REPEAT (ares_tac ([subsetI RS monoI] @ canTs) 1 ORELSE
  19.133 -            eresolve_tac ([bspec,exE,conjE,disjE,bexE] @ case_rls) 1 ORELSE
  19.134 -            (resolve_tac (prems RL [monoD RS subsetD]) 1 THEN assume_tac 1) ORELSE
  19.135 -            hyp_subst_tac 1));
  19.136 -qed "SgM";
  19.137 -
  19.138 -val prems = goal (the_context ())
  19.139 -    "[| !!x. x:A ==> mono(%X. B(X,x)) |] ==> mono(%X. Pi(A,B(X)))";
  19.140 -by (REPEAT (ares_tac ([subsetI RS monoI] @ canTs) 1 ORELSE
  19.141 -            eresolve_tac ([bspec,exE,conjE,disjE,bexE] @ case_rls) 1 ORELSE
  19.142 -            (resolve_tac (prems RL [monoD RS subsetD]) 1 THEN assume_tac 1) ORELSE
  19.143 -            hyp_subst_tac 1));
  19.144 -qed "PiM";
  19.145 -
  19.146 -val prems = goal (the_context ())
  19.147 -     "[| mono(%X. A(X));  mono(%X. B(X)) |] ==> mono(%X. A(X)+B(X))";
  19.148 -by (REPEAT (ares_tac ([subsetI RS monoI] @ canTs) 1 ORELSE
  19.149 -            eresolve_tac ([bspec,exE,conjE,disjE,bexE] @ case_rls) 1 ORELSE
  19.150 -            (resolve_tac (prems RL [monoD RS subsetD]) 1 THEN assume_tac 1) ORELSE
  19.151 -            hyp_subst_tac 1));
  19.152 -qed "PlusM";
  19.153 -
  19.154 -(**************** RECURSIVE TYPES ******************)
  19.155 -
  19.156 -(*** Conversion Rules for Fixed Points via monotonicity and Tarski ***)
  19.157 -
  19.158 -Goal "mono(%X. Unit+X)";
  19.159 -by (REPEAT (ares_tac [PlusM,constM,idM] 1));
  19.160 -qed "NatM";
  19.161 -bind_thm("def_NatB", result() RS (Nat_def RS def_lfp_Tarski));
  19.162 -
  19.163 -Goal "mono(%X.(Unit+Sigma(A,%y. X)))";
  19.164 -by (REPEAT (ares_tac [PlusM,SgM,constM,idM] 1));
  19.165 -qed "ListM";
  19.166 -bind_thm("def_ListB", result() RS (List_def RS def_lfp_Tarski));
  19.167 -bind_thm("def_ListsB", result() RS (Lists_def RS def_gfp_Tarski));
  19.168 -
  19.169 -Goal "mono(%X.({} + Sigma(A,%y. X)))";
  19.170 -by (REPEAT (ares_tac [PlusM,SgM,constM,idM] 1));
  19.171 -qed "IListsM";
  19.172 -bind_thm("def_IListsB", result() RS (ILists_def RS def_gfp_Tarski));
  19.173 -
  19.174 -val ind_type_eqs = [def_NatB,def_ListB,def_ListsB,def_IListsB];
  19.175 -
  19.176 -(*** Exhaustion Rules ***)
  19.177 -
  19.178 -fun mk_iXH_tac teqs ddefs rls s = prove_goalw (the_context ()) ddefs s
  19.179 -           (fn _ => [resolve_tac (teqs RL [XHlemma1]) 1,
  19.180 -                     fast_tac (set_cs addSIs canTs addSEs case_rls) 1]);
  19.181 -
  19.182 -val iXH_tac = mk_iXH_tac ind_type_eqs ind_data_defs [];
  19.183 -
  19.184 -val NatXH  = iXH_tac "a : Nat <-> (a=zero | (EX x:Nat. a=succ(x)))";
  19.185 -val ListXH = iXH_tac "a : List(A) <-> (a=[] | (EX x:A. EX xs:List(A).a=x$xs))";
  19.186 -val ListsXH = iXH_tac "a : Lists(A) <-> (a=[] | (EX x:A. EX xs:Lists(A).a=x$xs))";
  19.187 -val IListsXH = iXH_tac "a : ILists(A) <-> (EX x:A. EX xs:ILists(A).a=x$xs)";
  19.188 -
  19.189 -val iXHs = [NatXH,ListXH];
  19.190 -val icase_rls = XH_to_Es iXHs;
  19.191 -
  19.192 -(*** Type Rules ***)
  19.193 -
  19.194 -val icanT_tac = mk_canT_tac (the_context ()) iXHs;
  19.195 -val incanT_tac = mk_ncanT_tac (the_context ()) [] icase_rls case_rls;
  19.196 -
  19.197 -val zeroT = icanT_tac "zero : Nat";
  19.198 -val succT = icanT_tac "n:Nat ==> succ(n) : Nat";
  19.199 -val nilT  = icanT_tac "[] : List(A)";
  19.200 -val consT = icanT_tac "[| h:A;  t:List(A) |] ==> h$t : List(A)";
  19.201 -
  19.202 -val icanTs = [zeroT,succT,nilT,consT];
  19.203 -
  19.204 -val ncaseT = incanT_tac
  19.205 -     "[| n:Nat; n=zero ==> b:C(zero); \
  19.206 -\        !!x.[| x:Nat;  n=succ(x) |] ==> c(x):C(succ(x)) |] ==>  \
  19.207 -\     ncase(n,b,c) : C(n)";
  19.208 -
  19.209 -val lcaseT = incanT_tac
  19.210 -     "[| l:List(A); l=[] ==> b:C([]); \
  19.211 -\        !!h t.[| h:A;  t:List(A); l=h$t |] ==> c(h,t):C(h$t) |] ==> \
  19.212 -\     lcase(l,b,c) : C(l)";
  19.213 -
  19.214 -val incanTs = [ncaseT,lcaseT];
  19.215 -
  19.216 -(*** Induction Rules ***)
  19.217 -
  19.218 -val ind_Ms = [NatM,ListM];
  19.219 -
  19.220 -fun mk_ind_tac ddefs tdefs Ms canTs case_rls s = prove_goalw (the_context ()) ddefs s
  19.221 -     (fn major::prems => [resolve_tac (Ms RL ([major] RL (tdefs RL [def_induct]))) 1,
  19.222 -                          fast_tac (set_cs addSIs (prems @ canTs) addSEs case_rls) 1]);
  19.223 -
  19.224 -val ind_tac = mk_ind_tac ind_data_defs ind_type_defs ind_Ms canTs case_rls;
  19.225 -
  19.226 -val Nat_ind = ind_tac
  19.227 -     "[| n:Nat; P(zero); !!x.[| x:Nat; P(x) |] ==> P(succ(x)) |] ==>  \
  19.228 -\     P(n)";
  19.229 -
  19.230 -val List_ind = ind_tac
  19.231 -     "[| l:List(A); P([]); \
  19.232 -\        !!x xs.[| x:A;  xs:List(A); P(xs) |] ==> P(x$xs) |] ==> \
  19.233 -\     P(l)";
  19.234 -
  19.235 -val inds = [Nat_ind,List_ind];
  19.236 -
  19.237 -(*** Primitive Recursive Rules ***)
  19.238 -
  19.239 -fun mk_prec_tac inds s = prove_goal (the_context ()) s
  19.240 -     (fn major::prems => [resolve_tac ([major] RL inds) 1,
  19.241 -                          ALLGOALS (simp_tac term_ss THEN'
  19.242 -                                    fast_tac (set_cs addSIs prems))]);
  19.243 -val prec_tac = mk_prec_tac inds;
  19.244 -
  19.245 -val nrecT = prec_tac
  19.246 -     "[| n:Nat; b:C(zero); \
  19.247 -\        !!x g.[| x:Nat; g:C(x) |] ==> c(x,g):C(succ(x)) |] ==>  \
  19.248 -\     nrec(n,b,c) : C(n)";
  19.249 -
  19.250 -val lrecT = prec_tac
  19.251 -     "[| l:List(A); b:C([]); \
  19.252 -\        !!x xs g.[| x:A;  xs:List(A); g:C(xs) |] ==> c(x,xs,g):C(x$xs) |] ==>  \
  19.253 -\     lrec(l,b,c) : C(l)";
  19.254 -
  19.255 -val precTs = [nrecT,lrecT];
  19.256 -
  19.257 -
  19.258 -(*** Theorem proving ***)
  19.259 -
  19.260 -val [major,minor] = goal (the_context ())
  19.261 -    "[| <a,b> : Sigma(A,B);  [| a:A;  b:B(a) |] ==> P   \
  19.262 -\    |] ==> P";
  19.263 -by (rtac (major RS (XH_to_E SgXH)) 1);
  19.264 -by (rtac minor 1);
  19.265 -by (ALLGOALS (fast_tac term_cs));
  19.266 -qed "SgE2";
  19.267 -
  19.268 -(* General theorem proving ignores non-canonical term-formers,             *)
  19.269 -(*         - intro rules are type rules for canonical terms                *)
  19.270 -(*         - elim rules are case rules (no non-canonical terms appear)     *)
  19.271 -
  19.272 -val type_cs = term_cs addSIs (SubtypeI::(canTs @ icanTs))
  19.273 -                      addSEs (SubtypeE::(XH_to_Es XHs));
  19.274 -
  19.275 -
  19.276 -(*** Infinite Data Types ***)
  19.277 -
  19.278 -val [mono] = goal (the_context ()) "mono(f) ==> lfp(f) <= gfp(f)";
  19.279 -by (rtac (lfp_lowerbound RS subset_trans) 1);
  19.280 -by (rtac (mono RS gfp_lemma3) 1);
  19.281 -by (rtac subset_refl 1);
  19.282 -qed "lfp_subset_gfp";
  19.283 -
  19.284 -val prems = goal (the_context ())
  19.285 -    "[| a:A;  !!x X.[| x:A;  ALL y:A. t(y):X |] ==> t(x) : B(X) |] ==> \
  19.286 -\    t(a) : gfp(B)";
  19.287 -by (rtac coinduct 1);
  19.288 -by (res_inst_tac [("P","%x. EX y:A. x=t(y)")] CollectI 1);
  19.289 -by (ALLGOALS (fast_tac (ccl_cs addSIs prems)));
  19.290 -qed "gfpI";
  19.291 -
  19.292 -val rew::prem::prems = goal (the_context ())
  19.293 -    "[| C==gfp(B);  a:A;  !!x X.[| x:A;  ALL y:A. t(y):X |] ==> t(x) : B(X) |] ==> \
  19.294 -\    t(a) : C";
  19.295 -by (rewtac rew);
  19.296 -by (REPEAT (ares_tac ((prem RS gfpI)::prems) 1));
  19.297 -qed "def_gfpI";
  19.298 -
  19.299 -(* EG *)
  19.300 -
  19.301 -val prems = goal (the_context ())
  19.302 -    "letrec g x be zero$g(x) in g(bot) : Lists(Nat)";
  19.303 -by (rtac (refl RS (XH_to_I UnitXH) RS (Lists_def RS def_gfpI)) 1);
  19.304 -by (stac letrecB 1);
  19.305 -by (rewtac cons_def);
  19.306 -by (fast_tac type_cs 1);
  19.307 -result();
    20.1 --- a/src/CCL/Type.thy	Mon Jul 17 18:42:38 2006 +0200
    20.2 +++ b/src/CCL/Type.thy	Tue Jul 18 02:22:38 2006 +0200
    20.3 @@ -69,6 +69,419 @@
    20.4  
    20.5    SPLIT_def:   "SPLIT(p,B) == Union({A. EX x y. p=<x,y> & A=B(x,y)})"
    20.6  
    20.7 -ML {* use_legacy_bindings (the_context ()) *}
    20.8 +
    20.9 +lemmas simp_type_defs =
   20.10 +    Subtype_def Unit_def Bool_def Plus_def Sigma_def Pi_def Lift_def Tall_def Tex_def
   20.11 +  and ind_type_defs = Nat_def List_def
   20.12 +  and simp_data_defs = one_def inl_def inr_def
   20.13 +  and ind_data_defs = zero_def succ_def nil_def cons_def
   20.14 +
   20.15 +lemma subsetXH: "A <= B <-> (ALL x. x:A --> x:B)"
   20.16 +  by blast
   20.17 +
   20.18 +
   20.19 +subsection {* Exhaustion Rules *}
   20.20 +
   20.21 +lemma EmptyXH: "!!a. a : {} <-> False"
   20.22 +  and SubtypeXH: "!!a A P. a : {x:A. P(x)} <-> (a:A & P(a))"
   20.23 +  and UnitXH: "!!a. a : Unit          <-> a=one"
   20.24 +  and BoolXH: "!!a. a : Bool          <-> a=true | a=false"
   20.25 +  and PlusXH: "!!a A B. a : A+B           <-> (EX x:A. a=inl(x)) | (EX x:B. a=inr(x))"
   20.26 +  and PiXH: "!!a A B. a : PROD x:A. B(x) <-> (EX b. a=lam x. b(x) & (ALL x:A. b(x):B(x)))"
   20.27 +  and SgXH: "!!a A B. a : SUM x:A. B(x)  <-> (EX x:A. EX y:B(x).a=<x,y>)"
   20.28 +  unfolding simp_type_defs by blast+
   20.29 +
   20.30 +lemmas XHs = EmptyXH SubtypeXH UnitXH BoolXH PlusXH PiXH SgXH
   20.31 +
   20.32 +lemma LiftXH: "a : [A] <-> (a=bot | a:A)"
   20.33 +  and TallXH: "a : TALL X. B(X) <-> (ALL X. a:B(X))"
   20.34 +  and TexXH: "a : TEX X. B(X) <-> (EX X. a:B(X))"
   20.35 +  unfolding simp_type_defs by blast+
   20.36 +
   20.37 +ML {*
   20.38 +bind_thms ("case_rls", XH_to_Es (thms "XHs"));
   20.39 +*}
   20.40 +
   20.41 +
   20.42 +subsection {* Canonical Type Rules *}
   20.43 +
   20.44 +lemma oneT: "one : Unit"
   20.45 +  and trueT: "true : Bool"
   20.46 +  and falseT: "false : Bool"
   20.47 +  and lamT: "!!b B. [| !!x. x:A ==> b(x):B(x) |] ==> lam x. b(x) : Pi(A,B)"
   20.48 +  and pairT: "!!b B. [| a:A; b:B(a) |] ==> <a,b>:Sigma(A,B)"
   20.49 +  and inlT: "a:A ==> inl(a) : A+B"
   20.50 +  and inrT: "b:B ==> inr(b) : A+B"
   20.51 +  by (blast intro: XHs [THEN iffD2])+
   20.52 +
   20.53 +lemmas canTs = oneT trueT falseT pairT lamT inlT inrT
   20.54 +
   20.55 +
   20.56 +subsection {* Non-Canonical Type Rules *}
   20.57 +
   20.58 +lemma lem: "[| a:B(u);  u=v |] ==> a : B(v)"
   20.59 +  by blast
   20.60 +
   20.61 +
   20.62 +ML {*
   20.63 +local
   20.64 +  val lemma = thm "lem"
   20.65 +  val bspec = thm "bspec"
   20.66 +  val bexE = thm "bexE"
   20.67 +in
   20.68 +
   20.69 +  fun mk_ncanT_tac thy defs top_crls crls s = prove_goalw thy defs s
   20.70 +    (fn major::prems => [(resolve_tac ([major] RL top_crls) 1),
   20.71 +                         (REPEAT_SOME (eresolve_tac (crls @ [exE,bexE,conjE,disjE]))),
   20.72 +                         (ALLGOALS (asm_simp_tac (simpset ()))),
   20.73 +                         (ALLGOALS (ares_tac (prems RL [lemma]) ORELSE'
   20.74 +                                    etac bspec )),
   20.75 +                         (safe_tac (claset () addSIs prems))])
   20.76 +
   20.77 +  val ncanT_tac = mk_ncanT_tac (the_context ()) [] case_rls case_rls
   20.78 +end
   20.79 +*}
   20.80 +
   20.81 +ML {*
   20.82 +
   20.83 +bind_thm ("ifT", ncanT_tac
   20.84 +  "[| b:Bool; b=true ==> t:A(true); b=false ==> u:A(false) |] ==> if b then t else u : A(b)");
   20.85 +
   20.86 +bind_thm ("applyT", ncanT_tac "[| f : Pi(A,B);  a:A |] ==> f ` a : B(a)");
   20.87 +
   20.88 +bind_thm ("splitT", ncanT_tac
   20.89 +  "[| p:Sigma(A,B); !!x y. [| x:A;  y:B(x); p=<x,y> |] ==> c(x,y):C(<x,y>) |] ==> split(p,c):C(p)");
   20.90 +
   20.91 +bind_thm ("whenT", ncanT_tac
   20.92 +  "[| p:A+B; !!x.[| x:A;  p=inl(x) |] ==> a(x):C(inl(x)); !!y.[| y:B;  p=inr(y) |] ==> b(y):C(inr(y)) |] ==> when(p,a,b) : C(p)");
   20.93 +*}
   20.94 +
   20.95 +lemmas ncanTs = ifT applyT splitT whenT
   20.96 +
   20.97 +
   20.98 +subsection {* Subtypes *}
   20.99 +
  20.100 +lemma SubtypeD1: "a : Subtype(A, P) ==> a : A"
  20.101 +  and SubtypeD2: "a : Subtype(A, P) ==> P(a)"
  20.102 +  by (simp_all add: SubtypeXH)
  20.103 +
  20.104 +lemma SubtypeI: "[| a:A;  P(a) |] ==> a : {x:A. P(x)}"
  20.105 +  by (simp add: SubtypeXH)
  20.106 +
  20.107 +lemma SubtypeE: "[| a : {x:A. P(x)};  [| a:A;  P(a) |] ==> Q |] ==> Q"
  20.108 +  by (simp add: SubtypeXH)
  20.109 +
  20.110 +
  20.111 +subsection {* Monotonicity *}
  20.112 +
  20.113 +lemma idM: "mono (%X. X)"
  20.114 +  apply (rule monoI)
  20.115 +  apply assumption
  20.116 +  done
  20.117 +
  20.118 +lemma constM: "mono(%X. A)"
  20.119 +  apply (rule monoI)
  20.120 +  apply (rule subset_refl)
  20.121 +  done
  20.122 +
  20.123 +lemma "mono(%X. A(X)) ==> mono(%X.[A(X)])"
  20.124 +  apply (rule subsetI [THEN monoI])
  20.125 +  apply (drule LiftXH [THEN iffD1])
  20.126 +  apply (erule disjE)
  20.127 +   apply (erule disjI1 [THEN LiftXH [THEN iffD2]])
  20.128 +  apply (rule disjI2 [THEN LiftXH [THEN iffD2]])
  20.129 +  apply (drule (1) monoD)
  20.130 +  apply blast
  20.131 +  done
  20.132 +
  20.133 +lemma SgM:
  20.134 +  "[| mono(%X. A(X)); !!x X. x:A(X) ==> mono(%X. B(X,x)) |] ==>
  20.135 +    mono(%X. Sigma(A(X),B(X)))"
  20.136 +  by (blast intro!: subsetI [THEN monoI] canTs elim!: case_rls
  20.137 +    dest!: monoD [THEN subsetD])
  20.138 +
  20.139 +lemma PiM:
  20.140 +  "[| !!x. x:A ==> mono(%X. B(X,x)) |] ==> mono(%X. Pi(A,B(X)))"
  20.141 +  by (blast intro!: subsetI [THEN monoI] canTs elim!: case_rls
  20.142 +    dest!: monoD [THEN subsetD])
  20.143 +
  20.144 +lemma PlusM:
  20.145 +    "[| mono(%X. A(X));  mono(%X. B(X)) |] ==> mono(%X. A(X)+B(X))"
  20.146 +  by (blast intro!: subsetI [THEN monoI] canTs elim!: case_rls
  20.147 +    dest!: monoD [THEN subsetD])
  20.148 +
  20.149 +
  20.150 +subsection {* Recursive types *}
  20.151 +
  20.152 +subsubsection {* Conversion Rules for Fixed Points via monotonicity and Tarski *}
  20.153 +
  20.154 +lemma NatM: "mono(%X. Unit+X)";
  20.155 +  apply (rule PlusM constM idM)+
  20.156 +  done
  20.157 +
  20.158 +lemma def_NatB: "Nat = Unit + Nat"
  20.159 +  apply (rule def_lfp_Tarski [OF Nat_def])
  20.160 +  apply (rule NatM)
  20.161 +  done
  20.162 +
  20.163 +lemma ListM: "mono(%X.(Unit+Sigma(A,%y. X)))"
  20.164 +  apply (rule PlusM SgM constM idM)+
  20.165 +  done
  20.166 +
  20.167 +lemma def_ListB: "List(A) = Unit + A * List(A)"
  20.168 +  apply (rule def_lfp_Tarski [OF List_def])
  20.169 +  apply (rule ListM)
  20.170 +  done
  20.171 +
  20.172 +lemma def_ListsB: "Lists(A) = Unit + A * Lists(A)"
  20.173 +  apply (rule def_gfp_Tarski [OF Lists_def])
  20.174 +  apply (rule ListM)
  20.175 +  done
  20.176 +
  20.177 +lemma IListsM: "mono(%X.({} + Sigma(A,%y. X)))"
  20.178 +  apply (rule PlusM SgM constM idM)+
  20.179 +  done
  20.180 +
  20.181 +lemma def_IListsB: "ILists(A) = {} + A * ILists(A)"
  20.182 +  apply (rule def_gfp_Tarski [OF ILists_def])
  20.183 +  apply (rule IListsM)
  20.184 +  done
  20.185 +
  20.186 +lemmas ind_type_eqs = def_NatB def_ListB def_ListsB def_IListsB
  20.187 +
  20.188 +
  20.189 +subsection {* Exhaustion Rules *}
  20.190 +
  20.191 +lemma NatXH: "a : Nat <-> (a=zero | (EX x:Nat. a=succ(x)))"
  20.192 +  and ListXH: "a : List(A) <-> (a=[] | (EX x:A. EX xs:List(A).a=x$xs))"
  20.193 +  and ListsXH: "a : Lists(A) <-> (a=[] | (EX x:A. EX xs:Lists(A).a=x$xs))"
  20.194 +  and IListsXH: "a : ILists(A) <-> (EX x:A. EX xs:ILists(A).a=x$xs)"
  20.195 +  unfolding ind_data_defs
  20.196 +  by (rule ind_type_eqs [THEN XHlemma1], blast intro!: canTs elim!: case_rls)+
  20.197 +
  20.198 +lemmas iXHs = NatXH ListXH
  20.199 +
  20.200 +ML {* bind_thms ("icase_rls", XH_to_Es (thms "iXHs")) *}
  20.201 +
  20.202 +
  20.203 +subsection {* Type Rules *}
  20.204 +
  20.205 +lemma zeroT: "zero : Nat"
  20.206 +  and succT: "n:Nat ==> succ(n) : Nat"
  20.207 +  and nilT: "[] : List(A)"
  20.208 +  and consT: "[| h:A;  t:List(A) |] ==> h$t : List(A)"
  20.209 +  by (blast intro: iXHs [THEN iffD2])+
  20.210 +
  20.211 +lemmas icanTs = zeroT succT nilT consT
  20.212 +
  20.213 +ML {*
  20.214 +val incanT_tac = mk_ncanT_tac (the_context ()) [] (thms "icase_rls") (thms "case_rls");
  20.215 +
  20.216 +bind_thm ("ncaseT", incanT_tac
  20.217 +  "[| n:Nat; n=zero ==> b:C(zero); !!x.[| x:Nat;  n=succ(x) |] ==> c(x):C(succ(x)) |] ==> ncase(n,b,c) : C(n)");
  20.218 +
  20.219 +bind_thm ("lcaseT", incanT_tac
  20.220 +     "[| l:List(A); l=[] ==> b:C([]); !!h t.[| h:A;  t:List(A); l=h$t |] ==> c(h,t):C(h$t) |] ==> lcase(l,b,c) : C(l)");
  20.221 +*}
  20.222 +
  20.223 +lemmas incanTs = ncaseT lcaseT
  20.224 +
  20.225 +
  20.226 +subsection {* Induction Rules *}
  20.227 +
  20.228 +lemmas ind_Ms = NatM ListM
  20.229 +
  20.230 +lemma Nat_ind: "[| n:Nat; P(zero); !!x.[| x:Nat; P(x) |] ==> P(succ(x)) |] ==> P(n)"
  20.231 +  apply (unfold ind_data_defs)
  20.232 +  apply (erule def_induct [OF Nat_def _ NatM])
  20.233 +  apply (blast intro: canTs elim!: case_rls)
  20.234 +  done
  20.235 +
  20.236 +lemma List_ind:
  20.237 +  "[| l:List(A); P([]); !!x xs.[| x:A;  xs:List(A); P(xs) |] ==> P(x$xs) |] ==> P(l)"
  20.238 +  apply (unfold ind_data_defs)
  20.239 +  apply (erule def_induct [OF List_def _ ListM])
  20.240 +  apply (blast intro: canTs elim!: case_rls)
  20.241 +  done
  20.242 +
  20.243 +lemmas inds = Nat_ind List_ind
  20.244 +
  20.245 +
  20.246 +subsection {* Primitive Recursive Rules *}
  20.247 +
  20.248 +lemma nrecT:
  20.249 +  "[| n:Nat; b:C(zero);
  20.250 +      !!x g.[| x:Nat; g:C(x) |] ==> c(x,g):C(succ(x)) |] ==>
  20.251 +      nrec(n,b,c) : C(n)"
  20.252 +  by (erule Nat_ind) auto
  20.253 +
  20.254 +lemma lrecT:
  20.255 +  "[| l:List(A); b:C([]);
  20.256 +      !!x xs g.[| x:A;  xs:List(A); g:C(xs) |] ==> c(x,xs,g):C(x$xs) |] ==>
  20.257 +      lrec(l,b,c) : C(l)"
  20.258 +  by (erule List_ind) auto
  20.259 +
  20.260 +lemmas precTs = nrecT lrecT
  20.261 +
  20.262 +
  20.263 +subsection {* Theorem proving *}
  20.264 +
  20.265 +lemma SgE2:
  20.266 +  "[| <a,b> : Sigma(A,B);  [| a:A;  b:B(a) |] ==> P |] ==> P"
  20.267 +  unfolding SgXH by blast
  20.268 +
  20.269 +(* General theorem proving ignores non-canonical term-formers,             *)
  20.270 +(*         - intro rules are type rules for canonical terms                *)
  20.271 +(*         - elim rules are case rules (no non-canonical terms appear)     *)
  20.272 +
  20.273 +ML {* bind_thms ("XHEs", XH_to_Es (thms "XHs")) *}
  20.274 +
  20.275 +lemmas [intro!] = SubtypeI canTs icanTs
  20.276 +  and [elim!] = SubtypeE XHEs
  20.277 +
  20.278 +
  20.279 +subsection {* Infinite Data Types *}
  20.280 +
  20.281 +lemma lfp_subset_gfp: "mono(f) ==> lfp(f) <= gfp(f)"
  20.282 +  apply (rule lfp_lowerbound [THEN subset_trans])
  20.283 +   apply (erule gfp_lemma3)
  20.284 +  apply (rule subset_refl)
  20.285 +  done
  20.286 +
  20.287 +lemma gfpI:
  20.288 +  assumes "a:A"
  20.289 +    and "!!x X.[| x:A;  ALL y:A. t(y):X |] ==> t(x) : B(X)"
  20.290 +  shows "t(a) : gfp(B)"
  20.291 +  apply (rule coinduct)
  20.292 +   apply (rule_tac P = "%x. EX y:A. x=t (y)" in CollectI)
  20.293 +   apply (blast intro!: prems)+
  20.294 +  done
  20.295 +
  20.296 +lemma def_gfpI:
  20.297 +  "[| C==gfp(B);  a:A;  !!x X.[| x:A;  ALL y:A. t(y):X |] ==> t(x) : B(X) |] ==>
  20.298 +    t(a) : C"
  20.299 +  apply unfold
  20.300 +  apply (erule gfpI)
  20.301 +  apply blast
  20.302 +  done
  20.303 +
  20.304 +(* EG *)
  20.305 +lemma "letrec g x be zero$g(x) in g(bot) : Lists(Nat)"
  20.306 +  apply (rule refl [THEN UnitXH [THEN iffD2], THEN Lists_def [THEN def_gfpI]])
  20.307 +  apply (subst letrecB)
  20.308 +  apply (unfold cons_def)
  20.309 +  apply blast
  20.310 +  done
  20.311 +
  20.312 +
  20.313 +subsection {* Lemmas and tactics for using the rule @{text
  20.314 +  "coinduct3"} on @{text "[="} and @{text "="} *}
  20.315 +
  20.316 +lemma lfpI: "[| mono(f);  a : f(lfp(f)) |] ==> a : lfp(f)"
  20.317 +  apply (erule lfp_Tarski [THEN ssubst])
  20.318 +  apply assumption
  20.319 +  done
  20.320 +
  20.321 +lemma ssubst_single: "[| a=a';  a' : A |] ==> a : A"
  20.322 +  by simp
  20.323 +
  20.324 +lemma ssubst_pair: "[| a=a';  b=b';  <a',b'> : A |] ==> <a,b> : A"
  20.325 +  by simp
  20.326 +
  20.327 +
  20.328 +(***)
  20.329 +
  20.330 +ML {*
  20.331 +
  20.332 +local
  20.333 +  val lfpI = thm "lfpI"
  20.334 +  val coinduct3_mono_lemma = thm "coinduct3_mono_lemma"
  20.335 +  fun mk_thm s = prove_goal (the_context ()) s (fn mono::prems =>
  20.336 +       [fast_tac (claset () addIs ((mono RS coinduct3_mono_lemma RS lfpI)::prems)) 1])
  20.337 +in
  20.338 +val ci3_RI    = mk_thm "[|  mono(Agen);  a : R |] ==> a : lfp(%x. Agen(x) Un R Un A)"
  20.339 +val ci3_AgenI = mk_thm "[|  mono(Agen);  a : Agen(lfp(%x. Agen(x) Un R Un A)) |] ==> a : lfp(%x. Agen(x) Un R Un A)"
  20.340 +val ci3_AI    = mk_thm "[|  mono(Agen);  a : A |] ==> a : lfp(%x. Agen(x) Un R Un A)"
  20.341 +
  20.342 +fun mk_genIs thy defs genXH gen_mono s = prove_goalw thy defs s
  20.343 +      (fn prems => [rtac (genXH RS iffD2) 1,
  20.344 +                    simp_tac (simpset ()) 1,
  20.345 +                    TRY (fast_tac (claset () addIs
  20.346 +                            ([genXH RS iffD2,gen_mono RS coinduct3_mono_lemma RS lfpI]
  20.347 +                             @ prems)) 1)])
  20.348 +end;
  20.349 +
  20.350 +bind_thm ("ci3_RI", ci3_RI);
  20.351 +bind_thm ("ci3_AgenI", ci3_AgenI);
  20.352 +bind_thm ("ci3_AI", ci3_AI);
  20.353 +*}
  20.354 +
  20.355 +
  20.356 +subsection {* POgen *}
  20.357 +
  20.358 +lemma PO_refl: "<a,a> : PO"
  20.359 +  apply (rule po_refl [THEN PO_iff [THEN iffD1]])
  20.360 +  done
  20.361 +
  20.362 +ML {*
  20.363 +
  20.364 +val POgenIs = map (mk_genIs (the_context ()) (thms "data_defs") (thm "POgenXH") (thm "POgen_mono"))
  20.365 +  ["<true,true> : POgen(R)",
  20.366 +   "<false,false> : POgen(R)",
  20.367 +   "[| <a,a'> : R;  <b,b'> : R |] ==> <<a,b>,<a',b'>> : POgen(R)",
  20.368 +   "[|!!x. <b(x),b'(x)> : R |] ==><lam x. b(x),lam x. b'(x)> : POgen(R)",
  20.369 +   "<one,one> : POgen(R)",
  20.370 +   "<a,a'> : lfp(%x. POgen(x) Un R Un PO) ==> <inl(a),inl(a')> : POgen(lfp(%x. POgen(x) Un R Un PO))",
  20.371 +   "<b,b'> : lfp(%x. POgen(x) Un R Un PO) ==> <inr(b),inr(b')> : POgen(lfp(%x. POgen(x) Un R Un PO))",
  20.372 +   "<zero,zero> : POgen(lfp(%x. POgen(x) Un R Un PO))",
  20.373 +   "<n,n'> : lfp(%x. POgen(x) Un R Un PO) ==> <succ(n),succ(n')> : POgen(lfp(%x. POgen(x) Un R Un PO))",
  20.374 +   "<[],[]> : POgen(lfp(%x. POgen(x) Un R Un PO))",
  20.375 +   "[| <h,h'> : lfp(%x. POgen(x) Un R Un PO);  <t,t'> : lfp(%x. POgen(x) Un R Un PO) |] ==> <h$t,h'$t'> : POgen(lfp(%x. POgen(x) Un R Un PO))"];
  20.376 +
  20.377 +fun POgen_tac (rla,rlb) i =
  20.378 +  SELECT_GOAL (CLASET safe_tac) i THEN
  20.379 +  rtac (rlb RS (rla RS (thm "ssubst_pair"))) i THEN
  20.380 +  (REPEAT (resolve_tac (POgenIs @ [thm "PO_refl" RS (thm "POgen_mono" RS ci3_AI)] @
  20.381 +    (POgenIs RL [thm "POgen_mono" RS ci3_AgenI]) @ [thm "POgen_mono" RS ci3_RI]) i));
  20.382 +
  20.383 +*}
  20.384 +
  20.385 +
  20.386 +subsection {* EQgen *}
  20.387 +
  20.388 +lemma EQ_refl: "<a,a> : EQ"
  20.389 +  apply (rule refl [THEN EQ_iff [THEN iffD1]])
  20.390 +  done
  20.391 +
  20.392 +ML {*
  20.393 +
  20.394 +val EQgenIs = map (mk_genIs (the_context ()) (thms "data_defs") (thm "EQgenXH") (thm "EQgen_mono"))
  20.395 +  ["<true,true> : EQgen(R)",
  20.396 +   "<false,false> : EQgen(R)",
  20.397 +   "[| <a,a'> : R;  <b,b'> : R |] ==> <<a,b>,<a',b'>> : EQgen(R)",
  20.398 +   "[|!!x. <b(x),b'(x)> : R |] ==> <lam x. b(x),lam x. b'(x)> : EQgen(R)",
  20.399 +   "<one,one> : EQgen(R)",
  20.400 +   "<a,a'> : lfp(%x. EQgen(x) Un R Un EQ) ==> <inl(a),inl(a')> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
  20.401 +   "<b,b'> : lfp(%x. EQgen(x) Un R Un EQ) ==> <inr(b),inr(b')> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
  20.402 +   "<zero,zero> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
  20.403 +   "<n,n'> : lfp(%x. EQgen(x) Un R Un EQ) ==> <succ(n),succ(n')> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
  20.404 +   "<[],[]> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
  20.405 +   "[| <h,h'> : lfp(%x. EQgen(x) Un R Un EQ); <t,t'> : lfp(%x. EQgen(x) Un R Un EQ) |] ==> <h$t,h'$t'> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))"];
  20.406 +
  20.407 +fun EQgen_raw_tac i =
  20.408 +  (REPEAT (resolve_tac (EQgenIs @ [thm "EQ_refl" RS (thm "EQgen_mono" RS ci3_AI)] @
  20.409 +    (EQgenIs RL [thm "EQgen_mono" RS ci3_AgenI]) @ [thm "EQgen_mono" RS ci3_RI]) i))
  20.410 +
  20.411 +(* Goals of the form R <= EQgen(R) - rewrite elements <a,b> : EQgen(R) using rews and *)
  20.412 +(* then reduce this to a goal <a',b'> : R (hopefully?)                                *)
  20.413 +(*      rews are rewrite rules that would cause looping in the simpifier              *)
  20.414 +
  20.415 +fun EQgen_tac simp_set rews i =
  20.416 + SELECT_GOAL
  20.417 +   (TRY (CLASET safe_tac) THEN
  20.418 +    resolve_tac ((rews@[refl]) RL ((rews@[refl]) RL [thm "ssubst_pair"])) i THEN
  20.419 +    ALLGOALS (simp_tac simp_set) THEN
  20.420 +    ALLGOALS EQgen_raw_tac) i
  20.421 +*}
  20.422  
  20.423  end
    21.1 --- a/src/CCL/Wfd.thy	Mon Jul 17 18:42:38 2006 +0200
    21.2 +++ b/src/CCL/Wfd.thy	Tue Jul 18 02:22:38 2006 +0200
    21.3 @@ -8,7 +8,6 @@
    21.4  
    21.5  theory Wfd
    21.6  imports Trancl Type Hered
    21.7 -uses ("wfd.ML") ("genrec.ML") ("typecheck.ML") ("eval.ML")
    21.8  begin
    21.9  
   21.10  consts
   21.11 @@ -35,11 +34,599 @@
   21.12    NatPR_def:      "NatPR == {p. EX x:Nat. p=<x,succ(x)>}"
   21.13    ListPR_def:     "ListPR(A) == {p. EX h:A. EX t:List(A). p=<t,h$t>}"
   21.14  
   21.15 -ML {* use_legacy_bindings (the_context ()) *}
   21.16 +
   21.17 +lemma wfd_induct:
   21.18 +  assumes 1: "Wfd(R)"
   21.19 +    and 2: "!!x.[| ALL y. <y,x>: R --> P(y) |] ==> P(x)"
   21.20 +  shows "P(a)"
   21.21 +  apply (rule 1 [unfolded Wfd_def, rule_format, THEN CollectD])
   21.22 +  using 2 apply blast
   21.23 +  done
   21.24 +
   21.25 +lemma wfd_strengthen_lemma:
   21.26 +  assumes 1: "!!x y.<x,y> : R ==> Q(x)"
   21.27 +    and 2: "ALL x. (ALL y. <y,x> : R --> y : P) --> x : P"
   21.28 +    and 3: "!!x. Q(x) ==> x:P"
   21.29 +  shows "a:P"
   21.30 +  apply (rule 2 [rule_format])
   21.31 +  using 1 3
   21.32 +  apply blast
   21.33 +  done
   21.34 +
   21.35 +ML {*
   21.36 +  local val wfd_strengthen_lemma = thm "wfd_strengthen_lemma" in
   21.37 +  fun wfd_strengthen_tac s i =
   21.38 +    res_inst_tac [("Q",s)] wfd_strengthen_lemma i THEN assume_tac (i+1)
   21.39 +  end
   21.40 +*}
   21.41 +
   21.42 +lemma wf_anti_sym: "[| Wfd(r);  <a,x>:r;  <x,a>:r |] ==> P"
   21.43 +  apply (subgoal_tac "ALL x. <a,x>:r --> <x,a>:r --> P")
   21.44 +   apply blast
   21.45 +  apply (erule wfd_induct)
   21.46 +  apply blast
   21.47 +  done
   21.48 +
   21.49 +lemma wf_anti_refl: "[| Wfd(r);  <a,a>: r |] ==> P"
   21.50 +  apply (rule wf_anti_sym)
   21.51 +  apply assumption+
   21.52 +  done
   21.53 +
   21.54 +
   21.55 +subsection {* Irreflexive transitive closure *}
   21.56 +
   21.57 +lemma trancl_wf:
   21.58 +  assumes 1: "Wfd(R)"
   21.59 +  shows "Wfd(R^+)"
   21.60 +  apply (unfold Wfd_def)
   21.61 +  apply (rule allI ballI impI)+
   21.62 +(*must retain the universal formula for later use!*)
   21.63 +  apply (rule allE, assumption)
   21.64 +  apply (erule mp)
   21.65 +  apply (rule 1 [THEN wfd_induct])
   21.66 +  apply (rule impI [THEN allI])
   21.67 +  apply (erule tranclE)
   21.68 +   apply blast
   21.69 +  apply (erule spec [THEN mp, THEN spec, THEN mp])
   21.70 +   apply assumption+
   21.71 +  done
   21.72 +
   21.73 +
   21.74 +subsection {* Lexicographic Ordering *}
   21.75 +
   21.76 +lemma lexXH:
   21.77 +  "p : ra**rb <-> (EX a a' b b'. p = <<a,b>,<a',b'>> & (<a,a'> : ra | a=a' & <b,b'> : rb))"
   21.78 +  unfolding lex_def by blast
   21.79 +
   21.80 +lemma lexI1: "<a,a'> : ra ==> <<a,b>,<a',b'>> : ra**rb"
   21.81 +  by (blast intro!: lexXH [THEN iffD2])
   21.82 +
   21.83 +lemma lexI2: "<b,b'> : rb ==> <<a,b>,<a,b'>> : ra**rb"
   21.84 +  by (blast intro!: lexXH [THEN iffD2])
   21.85 +
   21.86 +lemma lexE:
   21.87 +  assumes 1: "p : ra**rb"
   21.88 +    and 2: "!!a a' b b'.[| <a,a'> : ra; p=<<a,b>,<a',b'>> |] ==> R"
   21.89 +    and 3: "!!a b b'.[| <b,b'> : rb;  p = <<a,b>,<a,b'>> |] ==> R"
   21.90 +  shows R
   21.91 +  apply (rule 1 [THEN lexXH [THEN iffD1], THEN exE])
   21.92 +  using 2 3
   21.93 +  apply blast
   21.94 +  done
   21.95 +
   21.96 +lemma lex_pair: "[| p : r**s;  !!a a' b b'. p = <<a,b>,<a',b'>> ==> P |] ==>P"
   21.97 +  apply (erule lexE)
   21.98 +   apply blast+
   21.99 +  done
  21.100 +
  21.101 +lemma lex_wf:
  21.102 +  assumes 1: "Wfd(R)"
  21.103 +    and 2: "Wfd(S)"
  21.104 +  shows "Wfd(R**S)"
  21.105 +  apply (unfold Wfd_def)
  21.106 +  apply safe
  21.107 +  apply (tactic {* wfd_strengthen_tac "%x. EX a b. x=<a,b>" 1 *})
  21.108 +   apply (blast elim!: lex_pair)
  21.109 +  apply (subgoal_tac "ALL a b.<a,b>:P")
  21.110 +   apply blast
  21.111 +  apply (rule 1 [THEN wfd_induct, THEN allI])
  21.112 +  apply (rule 2 [THEN wfd_induct, THEN allI]) back
  21.113 +  apply (fast elim!: lexE)
  21.114 +  done
  21.115 +
  21.116 +
  21.117 +subsection {* Mapping *}
  21.118 +
  21.119 +lemma wmapXH: "p : wmap(f,r) <-> (EX x y. p=<x,y>  &  <f(x),f(y)> : r)"
  21.120 +  unfolding wmap_def by blast
  21.121 +
  21.122 +lemma wmapI: "<f(a),f(b)> : r ==> <a,b> : wmap(f,r)"
  21.123 +  by (blast intro!: wmapXH [THEN iffD2])
  21.124 +
  21.125 +lemma wmapE: "[| p : wmap(f,r);  !!a b.[| <f(a),f(b)> : r;  p=<a,b> |] ==> R |] ==> R"
  21.126 +  by (blast dest!: wmapXH [THEN iffD1])
  21.127 +
  21.128 +lemma wmap_wf:
  21.129 +  assumes 1: "Wfd(r)"
  21.130 +  shows "Wfd(wmap(f,r))"
  21.131 +  apply (unfold Wfd_def)
  21.132 +  apply clarify
  21.133 +  apply (subgoal_tac "ALL b. ALL a. f (a) =b-->a:P")
  21.134 +   apply blast
  21.135 +  apply (rule 1 [THEN wfd_induct, THEN allI])
  21.136 +  apply clarify
  21.137 +  apply (erule spec [THEN mp])
  21.138 +  apply (safe elim!: wmapE)
  21.139 +  apply (erule spec [THEN mp, THEN spec, THEN mp])
  21.140 +   apply assumption
  21.141 +   apply (rule refl)
  21.142 +  done
  21.143 +
  21.144 +
  21.145 +subsection {* Projections *}
  21.146 +
  21.147 +lemma wfstI: "<xa,ya> : r ==> <<xa,xb>,<ya,yb>> : wmap(fst,r)"
  21.148 +  apply (rule wmapI)
  21.149 +  apply simp
  21.150 +  done
  21.151 +
  21.152 +lemma wsndI: "<xb,yb> : r ==> <<xa,xb>,<ya,yb>> : wmap(snd,r)"
  21.153 +  apply (rule wmapI)
  21.154 +  apply simp
  21.155 +  done
  21.156 +
  21.157 +lemma wthdI: "<xc,yc> : r ==> <<xa,<xb,xc>>,<ya,<yb,yc>>> : wmap(thd,r)"
  21.158 +  apply (rule wmapI)
  21.159 +  apply simp
  21.160 +  done
  21.161 +
  21.162 +
  21.163 +subsection {* Ground well-founded relations *}
  21.164 +
  21.165 +lemma wfI: "[| Wfd(r);  a : r |] ==> a : wf(r)"
  21.166 +  unfolding wf_def by blast
  21.167 +
  21.168 +lemma Empty_wf: "Wfd({})"
  21.169 +  unfolding Wfd_def by (blast elim: EmptyXH [THEN iffD1, THEN FalseE])
  21.170 +
  21.171 +lemma wf_wf: "Wfd(wf(R))"
  21.172 +  unfolding wf_def
  21.173 +  apply (rule_tac Q = "Wfd(R)" in excluded_middle [THEN disjE])
  21.174 +   apply simp_all
  21.175 +  apply (rule Empty_wf)
  21.176 +  done
  21.177 +
  21.178 +lemma NatPRXH: "p : NatPR <-> (EX x:Nat. p=<x,succ(x)>)"
  21.179 +  unfolding NatPR_def by blast
  21.180 +
  21.181 +lemma ListPRXH: "p : ListPR(A) <-> (EX h:A. EX t:List(A).p=<t,h$t>)"
  21.182 +  unfolding ListPR_def by blast
  21.183 +
  21.184 +lemma NatPRI: "x : Nat ==> <x,succ(x)> : NatPR"
  21.185 +  by (auto simp: NatPRXH)
  21.186 +
  21.187 +lemma ListPRI: "[| t : List(A); h : A |] ==> <t,h $ t> : ListPR(A)"
  21.188 +  by (auto simp: ListPRXH)
  21.189 +
  21.190 +lemma NatPR_wf: "Wfd(NatPR)"
  21.191 +  apply (unfold Wfd_def)
  21.192 +  apply clarify
  21.193 +  apply (tactic {* wfd_strengthen_tac "%x. x:Nat" 1 *})
  21.194 +   apply (fastsimp iff: NatPRXH)
  21.195 +  apply (erule Nat_ind)
  21.196 +   apply (fastsimp iff: NatPRXH)+
  21.197 +  done
  21.198 +
  21.199 +lemma ListPR_wf: "Wfd(ListPR(A))"
  21.200 +  apply (unfold Wfd_def)
  21.201 +  apply clarify
  21.202 +  apply (tactic {* wfd_strengthen_tac "%x. x:List (A)" 1 *})
  21.203 +   apply (fastsimp iff: ListPRXH)
  21.204 +  apply (erule List_ind)
  21.205 +   apply (fastsimp iff: ListPRXH)+
  21.206 +  done
  21.207 +
  21.208 +
  21.209 +subsection {* General Recursive Functions *}
  21.210 +
  21.211 +lemma letrecT:
  21.212 +  assumes 1: "a : A"
  21.213 +    and 2: "!!p g.[| p:A; ALL x:{x: A. <x,p>:wf(R)}. g(x) : D(x) |] ==> h(p,g) : D(p)"
  21.214 +  shows "letrec g x be h(x,g) in g(a) : D(a)"
  21.215 +  apply (rule 1 [THEN rev_mp])
  21.216 +  apply (rule wf_wf [THEN wfd_induct])
  21.217 +  apply (subst letrecB)
  21.218 +  apply (rule impI)
  21.219 +  apply (erule 2)
  21.220 +  apply blast
  21.221 +  done
  21.222 +
  21.223 +lemma SPLITB: "SPLIT(<a,b>,B) = B(a,b)"
  21.224 +  unfolding SPLIT_def
  21.225 +  apply (rule set_ext)
  21.226 +  apply blast
  21.227 +  done
  21.228  
  21.229 -use "wfd.ML"
  21.230 -use "genrec.ML"
  21.231 -use "typecheck.ML"
  21.232 -use "eval.ML"
  21.233 +lemma letrec2T:
  21.234 +  assumes "a : A"
  21.235 +    and "b : B"
  21.236 +    and "!!p q g.[| p:A; q:B;
  21.237 +              ALL x:A. ALL y:{y: B. <<x,y>,<p,q>>:wf(R)}. g(x,y) : D(x,y) |] ==> 
  21.238 +                h(p,q,g) : D(p,q)"
  21.239 +  shows "letrec g x y be h(x,y,g) in g(a,b) : D(a,b)"
  21.240 +  apply (unfold letrec2_def)
  21.241 +  apply (rule SPLITB [THEN subst])
  21.242 +  apply (assumption | rule letrecT pairT splitT prems)+
  21.243 +  apply (subst SPLITB)
  21.244 +  apply (assumption | rule ballI SubtypeI prems)+
  21.245 +  apply (rule SPLITB [THEN subst])
  21.246 +  apply (assumption | rule letrecT SubtypeI pairT splitT prems |
  21.247 +    erule bspec SubtypeE sym [THEN subst])+
  21.248 +  done
  21.249 +
  21.250 +lemma lem: "SPLIT(<a,<b,c>>,%x xs. SPLIT(xs,%y z. B(x,y,z))) = B(a,b,c)"
  21.251 +  by (simp add: SPLITB)
  21.252 +
  21.253 +lemma letrec3T:
  21.254 +  assumes "a : A"
  21.255 +    and "b : B"
  21.256 +    and "c : C"
  21.257 +    and "!!p q r g.[| p:A; q:B; r:C;
  21.258 +       ALL x:A. ALL y:B. ALL z:{z:C. <<x,<y,z>>,<p,<q,r>>> : wf(R)}.  
  21.259 +                                                        g(x,y,z) : D(x,y,z) |] ==> 
  21.260 +                h(p,q,r,g) : D(p,q,r)"
  21.261 +  shows "letrec g x y z be h(x,y,z,g) in g(a,b,c) : D(a,b,c)"
  21.262 +  apply (unfold letrec3_def)
  21.263 +  apply (rule lem [THEN subst])
  21.264 +  apply (assumption | rule letrecT pairT splitT prems)+
  21.265 +  apply (simp add: SPLITB)
  21.266 +  apply (assumption | rule ballI SubtypeI prems)+
  21.267 +  apply (rule lem [THEN subst])
  21.268 +  apply (assumption | rule letrecT SubtypeI pairT splitT prems |
  21.269 +    erule bspec SubtypeE sym [THEN subst])+
  21.270 +  done
  21.271 +
  21.272 +lemmas letrecTs = letrecT letrec2T letrec3T
  21.273 +
  21.274 +
  21.275 +subsection {* Type Checking for Recursive Calls *}
  21.276 +
  21.277 +lemma rcallT:
  21.278 +  "[| ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x);  
  21.279 +      g(a) : D(a) ==> g(a) : E;  a:A;  <a,p>:wf(R) |] ==>  
  21.280 +  g(a) : E"
  21.281 +  by blast
  21.282 +
  21.283 +lemma rcall2T:
  21.284 +  "[| ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y);  
  21.285 +      g(a,b) : D(a,b) ==> g(a,b) : E;  a:A;  b:B;  <<a,b>,<p,q>>:wf(R) |] ==>  
  21.286 +  g(a,b) : E"
  21.287 +  by blast
  21.288 +
  21.289 +lemma rcall3T:
  21.290 +  "[| ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}. g(x,y,z):D(x,y,z);  
  21.291 +      g(a,b,c) : D(a,b,c) ==> g(a,b,c) : E;   
  21.292 +      a:A;  b:B;  c:C;  <<a,<b,c>>,<p,<q,r>>> : wf(R) |] ==>  
  21.293 +  g(a,b,c) : E"
  21.294 +  by blast
  21.295 +
  21.296 +lemmas rcallTs = rcallT rcall2T rcall3T
  21.297 +
  21.298 +
  21.299 +subsection {* Instantiating an induction hypothesis with an equality assumption *}
  21.300 +
  21.301 +lemma hyprcallT:
  21.302 +  assumes 1: "g(a) = b"
  21.303 +    and 2: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x)"
  21.304 +    and 3: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) ==> b=g(a) ==> g(a) : D(a) ==> P"
  21.305 +    and 4: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) ==> a:A"
  21.306 +    and 5: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) ==> <a,p>:wf(R)"
  21.307 +  shows P
  21.308 +  apply (rule 3 [OF 2, OF 1 [symmetric]])
  21.309 +  apply (rule rcallT [OF 2])
  21.310 +    apply assumption
  21.311 +   apply (rule 4 [OF 2])
  21.312 +  apply (rule 5 [OF 2])
  21.313 +  done
  21.314 +
  21.315 +lemma hyprcall2T:
  21.316 +  assumes 1: "g(a,b) = c"
  21.317 +    and 2: "ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y)"
  21.318 +    and 3: "[| c=g(a,b);  g(a,b) : D(a,b) |] ==> P"
  21.319 +    and 4: "a:A"
  21.320 +    and 5: "b:B"
  21.321 +    and 6: "<<a,b>,<p,q>>:wf(R)"
  21.322 +  shows P
  21.323 +  apply (rule 3)
  21.324 +    apply (rule 1 [symmetric])
  21.325 +  apply (rule rcall2T)
  21.326 +      apply assumption+
  21.327 +  done
  21.328 +
  21.329 +lemma hyprcall3T:
  21.330 +  assumes 1: "g(a,b,c) = d"
  21.331 +    and 2: "ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}.g(x,y,z):D(x,y,z)"
  21.332 +    and 3: "[| d=g(a,b,c);  g(a,b,c) : D(a,b,c) |] ==> P"
  21.333 +    and 4: "a:A"
  21.334 +    and 5: "b:B"
  21.335 +    and 6: "c:C"
  21.336 +    and 7: "<<a,<b,c>>,<p,<q,r>>> : wf(R)"
  21.337 +  shows P
  21.338 +  apply (rule 3)
  21.339 +   apply (rule 1 [symmetric])
  21.340 +  apply (rule rcall3T)
  21.341 +  apply assumption+
  21.342 +  done
  21.343 +
  21.344 +lemmas hyprcallTs = hyprcallT hyprcall2T hyprcall3T
  21.345 +
  21.346 +
  21.347 +subsection {* Rules to Remove Induction Hypotheses after Type Checking *}
  21.348 +
  21.349 +lemma rmIH1: "[| ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x); P |] ==> P" .
  21.350 +
  21.351 +lemma rmIH2: "[| ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y); P |] ==> P" .
  21.352 +  
  21.353 +lemma rmIH3:
  21.354 + "[| ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}.g(x,y,z):D(x,y,z);  
  21.355 +     P |] ==>  
  21.356 +     P" .
  21.357 +
  21.358 +lemmas rmIHs = rmIH1 rmIH2 rmIH3
  21.359 +
  21.360 +
  21.361 +subsection {* Lemmas for constructors and subtypes *}
  21.362 +
  21.363 +(* 0-ary constructors do not need additional rules as they are handled *)
  21.364 +(*                                      correctly by applying SubtypeI *)
  21.365 +
  21.366 +lemma Subtype_canTs:
  21.367 +  "!!a b A B P. a : {x:A. b:{y:B(a).P(<x,y>)}} ==> <a,b> : {x:Sigma(A,B).P(x)}"
  21.368 +  "!!a A B P. a : {x:A. P(inl(x))} ==> inl(a) : {x:A+B. P(x)}"
  21.369 +  "!!b A B P. b : {x:B. P(inr(x))} ==> inr(b) : {x:A+B. P(x)}"
  21.370 +  "!!a P. a : {x:Nat. P(succ(x))} ==> succ(a) : {x:Nat. P(x)}"
  21.371 +  "!!h t A P. h : {x:A. t : {y:List(A).P(x$y)}} ==> h$t : {x:List(A).P(x)}"
  21.372 +  by (assumption | rule SubtypeI canTs icanTs | erule SubtypeE)+
  21.373 +
  21.374 +lemma letT: "[| f(t):B;  ~t=bot  |] ==> let x be t in f(x) : B"
  21.375 +  apply (erule letB [THEN ssubst])
  21.376 +  apply assumption
  21.377 +  done
  21.378 +
  21.379 +lemma applyT2: "[| a:A;  f : Pi(A,B)  |] ==> f ` a  : B(a)"
  21.380 +  apply (erule applyT)
  21.381 +  apply assumption
  21.382 +  done
  21.383 +
  21.384 +lemma rcall_lemma1: "[| a:A;  a:A ==> P(a) |] ==> a : {x:A. P(x)}"
  21.385 +  by blast
  21.386 +
  21.387 +lemma rcall_lemma2: "[| a:{x:A. Q(x)};  [| a:A; Q(a) |] ==> P(a) |] ==> a : {x:A. P(x)}"
  21.388 +  by blast
  21.389 +
  21.390 +lemmas rcall_lemmas = asm_rl rcall_lemma1 SubtypeD1 rcall_lemma2
  21.391 +
  21.392 +
  21.393 +subsection {* Typechecking *}
  21.394 +
  21.395 +ML {*
  21.396 +
  21.397 +local
  21.398 +
  21.399 +val type_rls =
  21.400 +  thms "canTs" @ thms "icanTs" @ thms "applyT2" @ thms "ncanTs" @ thms "incanTs" @
  21.401 +  thms "precTs" @ thms "letrecTs" @ thms "letT" @ thms "Subtype_canTs";
  21.402 +
  21.403 +val rcallT = thm "rcallT";
  21.404 +val rcall2T = thm "rcall2T";
  21.405 +val rcall3T = thm "rcall3T";
  21.406 +val rcallTs = thms "rcallTs";
  21.407 +val rcall_lemmas = thms "rcall_lemmas";
  21.408 +val SubtypeE = thm "SubtypeE";
  21.409 +val SubtypeI = thm "SubtypeI";
  21.410 +val rmIHs = thms "rmIHs";
  21.411 +val hyprcallTs = thms "hyprcallTs";
  21.412 +
  21.413 +fun bvars (Const("all",_) $ Abs(s,_,t)) l = bvars t (s::l)
  21.414 +  | bvars _ l = l
  21.415 +
  21.416 +fun get_bno l n (Const("all",_) $ Abs(s,_,t)) = get_bno (s::l) n t
  21.417 +  | get_bno l n (Const("Trueprop",_) $ t) = get_bno l n t
  21.418 +  | get_bno l n (Const("Ball",_) $ _ $ Abs(s,_,t)) = get_bno (s::l) (n+1) t
  21.419 +  | get_bno l n (Const("op :",_) $ t $ _) = get_bno l n t
  21.420 +  | get_bno l n (t $ s) = get_bno l n t
  21.421 +  | get_bno l n (Bound m) = (m-length(l),n)
  21.422 +
  21.423 +(* Not a great way of identifying induction hypothesis! *)
  21.424 +fun could_IH x = could_unify(x,hd (prems_of rcallT)) orelse
  21.425 +                 could_unify(x,hd (prems_of rcall2T)) orelse
  21.426 +                 could_unify(x,hd (prems_of rcall3T))
  21.427 +
  21.428 +fun IHinst tac rls = SUBGOAL (fn (Bi,i) =>
  21.429 +  let val bvs = bvars Bi []
  21.430 +      val ihs = List.filter could_IH (Logic.strip_assums_hyp Bi)
  21.431 +      val rnames = map (fn x=>
  21.432 +                    let val (a,b) = get_bno [] 0 x
  21.433 +                    in (List.nth(bvs,a),b) end) ihs
  21.434 +      fun try_IHs [] = no_tac
  21.435 +        | try_IHs ((x,y)::xs) = tac [("g",x)] (List.nth(rls,y-1)) i ORELSE (try_IHs xs)
  21.436 +  in try_IHs rnames end)
  21.437 +
  21.438 +fun is_rigid_prog t =
  21.439 +     case (Logic.strip_assums_concl t) of
  21.440 +        (Const("Trueprop",_) $ (Const("op :",_) $ a $ _)) => (term_vars a = [])
  21.441 +       | _ => false
  21.442 +in
  21.443 +
  21.444 +fun rcall_tac i = let fun tac ps rl i = res_inst_tac ps rl i THEN atac i
  21.445 +                       in IHinst tac rcallTs i end THEN
  21.446 +                  eresolve_tac rcall_lemmas i
  21.447 +
  21.448 +fun raw_step_tac prems i = ares_tac (prems@type_rls) i ORELSE
  21.449 +                           rcall_tac i ORELSE
  21.450 +                           ematch_tac [SubtypeE] i ORELSE
  21.451 +                           match_tac [SubtypeI] i
  21.452 +
  21.453 +fun tc_step_tac prems = SUBGOAL (fn (Bi,i) =>
  21.454 +          if is_rigid_prog Bi then raw_step_tac prems i else no_tac)
  21.455 +
  21.456 +fun typechk_tac rls i = SELECT_GOAL (REPEAT_FIRST (tc_step_tac rls)) i
  21.457 +
  21.458 +val tac = typechk_tac [] 1
  21.459 +
  21.460 +(*** Clean up Correctness Condictions ***)
  21.461 +
  21.462 +val clean_ccs_tac = REPEAT_FIRST (eresolve_tac ([SubtypeE]@rmIHs) ORELSE'
  21.463 +                                 hyp_subst_tac)
  21.464 +
  21.465 +val clean_ccs_tac =
  21.466 +       let fun tac ps rl i = eres_inst_tac ps rl i THEN atac i
  21.467 +       in TRY (REPEAT_FIRST (IHinst tac hyprcallTs ORELSE'
  21.468 +                       eresolve_tac ([asm_rl,SubtypeE]@rmIHs) ORELSE'
  21.469 +                       hyp_subst_tac)) end
  21.470 +
  21.471 +fun gen_ccs_tac rls i = SELECT_GOAL (REPEAT_FIRST (tc_step_tac rls) THEN
  21.472 +                                     clean_ccs_tac) i
  21.473  
  21.474  end
  21.475 +*}
  21.476 +
  21.477 +
  21.478 +subsection {* Evaluation *}
  21.479 +
  21.480 +ML {*
  21.481 +
  21.482 +local
  21.483 +
  21.484 +structure Data = GenericDataFun
  21.485 +(
  21.486 +  val name = "CCL/eval";
  21.487 +  type T = thm list;
  21.488 +  val empty = [];
  21.489 +  val extend = I;
  21.490 +  fun merge _ (rules1, rules2) = gen_union Drule.eq_thm_prop (rules1, rules2);
  21.491 +  fun print _ _ = ();
  21.492 +);
  21.493 +
  21.494 +in
  21.495 +
  21.496 +val eval_add = Thm.declaration_attribute (Data.map o Drule.add_rule);
  21.497 +val eval_del = Thm.declaration_attribute (Data.map o Drule.del_rule);
  21.498 +
  21.499 +fun eval_tac ctxt ths =
  21.500 +  METAHYPS (fn prems =>
  21.501 +    DEPTH_SOLVE_1 (resolve_tac (ths @ prems @ Data.get (Context.Proof ctxt)) 1)) 1;
  21.502 +
  21.503 +val eval_setup =
  21.504 +  Data.init #>
  21.505 +  Attrib.add_attributes
  21.506 +    [("eval", Attrib.add_del_args eval_add eval_del, "declaration of evaluation rule")] #>
  21.507 +  Method.add_methods [("eval", Method.thms_ctxt_args (fn ths => fn ctxt =>
  21.508 +    Method.SIMPLE_METHOD (CHANGED (eval_tac ctxt ths))), "evaluation")];
  21.509 +
  21.510 +end;
  21.511 +
  21.512 +*}
  21.513 +
  21.514 +setup eval_setup
  21.515 +
  21.516 +lemmas eval_rls [eval] = trueV falseV pairV lamV caseVtrue caseVfalse caseVpair caseVlam
  21.517 +
  21.518 +lemma applyV [eval]:
  21.519 +  assumes "f ---> lam x. b(x)"
  21.520 +    and "b(a) ---> c"
  21.521 +  shows "f ` a ---> c"
  21.522 +  unfolding apply_def by (eval prems)
  21.523 +
  21.524 +lemma letV:
  21.525 +  assumes 1: "t ---> a"
  21.526 +    and 2: "f(a) ---> c"
  21.527 +  shows "let x be t in f(x) ---> c"
  21.528 +  apply (unfold let_def)
  21.529 +  apply (rule 1 [THEN canonical])
  21.530 +  apply (tactic {*
  21.531 +    REPEAT (DEPTH_SOLVE_1 (resolve_tac (thms "prems" @ thms "eval_rls") 1 ORELSE
  21.532 +                           etac (thm "substitute") 1)) *})
  21.533 +  done
  21.534 +
  21.535 +lemma fixV: "f(fix(f)) ---> c ==> fix(f) ---> c"
  21.536 +  apply (unfold fix_def)
  21.537 +  apply (rule applyV)
  21.538 +   apply (rule lamV)
  21.539 +  apply assumption
  21.540 +  done
  21.541 +
  21.542 +lemma letrecV:
  21.543 +  "h(t,%y. letrec g x be h(x,g) in g(y)) ---> c ==>  
  21.544 +                 letrec g x be h(x,g) in g(t) ---> c"
  21.545 +  apply (unfold letrec_def)
  21.546 +  apply (assumption | rule fixV applyV  lamV)+
  21.547 +  done
  21.548 +
  21.549 +lemmas [eval] = letV letrecV fixV
  21.550 +
  21.551 +lemma V_rls [eval]:
  21.552 +  "true ---> true"
  21.553 +  "false ---> false"
  21.554 +  "!!b c t u. [| b--->true;  t--->c |] ==> if b then t else u ---> c"
  21.555 +  "!!b c t u. [| b--->false;  u--->c |] ==> if b then t else u ---> c"
  21.556 +  "!!a b. <a,b> ---> <a,b>"
  21.557 +  "!!a b c t h. [| t ---> <a,b>;  h(a,b) ---> c |] ==> split(t,h) ---> c"
  21.558 +  "zero ---> zero"
  21.559 +  "!!n. succ(n) ---> succ(n)"
  21.560 +  "!!c n t u. [| n ---> zero; t ---> c |] ==> ncase(n,t,u) ---> c"
  21.561 +  "!!c n t u x. [| n ---> succ(x); u(x) ---> c |] ==> ncase(n,t,u) ---> c"
  21.562 +  "!!c n t u. [| n ---> zero; t ---> c |] ==> nrec(n,t,u) ---> c"
  21.563 +  "!!c n t u x. [| n--->succ(x); u(x,nrec(x,t,u))--->c |] ==> nrec(n,t,u)--->c"
  21.564 +  "[] ---> []"
  21.565 +  "!!h t. h$t ---> h$t"
  21.566 +  "!!c l t u. [| l ---> []; t ---> c |] ==> lcase(l,t,u) ---> c"
  21.567 +  "!!c l t u x xs. [| l ---> x$xs; u(x,xs) ---> c |] ==> lcase(l,t,u) ---> c"
  21.568 +  "!!c l t u. [| l ---> []; t ---> c |] ==> lrec(l,t,u) ---> c"
  21.569 +  "!!c l t u x xs. [| l--->x$xs; u(x,xs,lrec(xs,t,u))--->c |] ==> lrec(l,t,u)--->c"
  21.570 +  unfolding data_defs by eval+
  21.571 +
  21.572 +
  21.573 +subsection {* Factorial *}
  21.574 +
  21.575 +lemma
  21.576 +  "letrec f n be ncase(n,succ(zero),%x. nrec(n,zero,%y g. nrec(f(x),g,%z h. succ(h))))  
  21.577 +   in f(succ(succ(zero))) ---> ?a"
  21.578 +  by eval
  21.579 +
  21.580 +lemma
  21.581 +  "letrec f n be ncase(n,succ(zero),%x. nrec(n,zero,%y g. nrec(f(x),g,%z h. succ(h))))  
  21.582 +   in f(succ(succ(succ(zero)))) ---> ?a"
  21.583 +  by eval
  21.584 +
  21.585 +subsection {* Less Than Or Equal *}
  21.586 +
  21.587 +lemma
  21.588 +  "letrec f p be split(p,%m n. ncase(m,true,%x. ncase(n,false,%y. f(<x,y>))))
  21.589 +   in f(<succ(zero), succ(zero)>) ---> ?a"
  21.590 +  by eval
  21.591 +
  21.592 +lemma
  21.593 +  "letrec f p be split(p,%m n. ncase(m,true,%x. ncase(n,false,%y. f(<x,y>))))
  21.594 +   in f(<succ(zero), succ(succ(succ(succ(zero))))>) ---> ?a"
  21.595 +  by eval
  21.596 +
  21.597 +lemma
  21.598 +  "letrec f p be split(p,%m n. ncase(m,true,%x. ncase(n,false,%y. f(<x,y>))))
  21.599 +   in f(<succ(succ(succ(succ(succ(zero))))), succ(succ(succ(succ(zero))))>) ---> ?a"
  21.600 +  by eval
  21.601 +
  21.602 +
  21.603 +subsection {* Reverse *}
  21.604 +
  21.605 +lemma
  21.606 +  "letrec id l be lcase(l,[],%x xs. x$id(xs))  
  21.607 +   in id(zero$succ(zero)$[]) ---> ?a"
  21.608 +  by eval
  21.609 +
  21.610 +lemma
  21.611 +  "letrec rev l be lcase(l,[],%x xs. lrec(rev(xs),x$[],%y ys g. y$g))  
  21.612 +   in rev(zero$succ(zero)$(succ((lam x. x)`succ(zero)))$([])) ---> ?a"
  21.613 +  by eval
  21.614 +
  21.615 +end
    22.1 --- a/src/CCL/coinduction.ML	Mon Jul 17 18:42:38 2006 +0200
    22.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.3 @@ -1,108 +0,0 @@
    22.4 -(*  Title:      CCL/Coinduction.ML
    22.5 -    ID:         $Id$
    22.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    22.7 -    Copyright   1993  University of Cambridge
    22.8 -
    22.9 -Lemmas and tactics for using the rule coinduct3 on [= and =.
   22.10 -*)
   22.11 -
   22.12 -val [mono,prem] = goal (the_context ()) "[| mono(f);  a : f(lfp(f)) |] ==> a : lfp(f)";
   22.13 -by (stac (mono RS lfp_Tarski) 1);
   22.14 -by (rtac prem 1);
   22.15 -qed "lfpI";
   22.16 -
   22.17 -val prems = goal (the_context ()) "[| a=a';  a' : A |] ==> a : A";
   22.18 -by (simp_tac (term_ss addsimps prems) 1);
   22.19 -qed "ssubst_single";
   22.20 -
   22.21 -val prems = goal (the_context ()) "[| a=a';  b=b';  <a',b'> : A |] ==> <a,b> : A";
   22.22 -by (simp_tac (term_ss addsimps prems) 1);
   22.23 -qed "ssubst_pair";
   22.24 -
   22.25 -(***)
   22.26 -
   22.27 -local
   22.28 -fun mk_thm s = prove_goal (the_context ()) s (fn mono::prems =>
   22.29 -       [fast_tac (term_cs addIs ((mono RS coinduct3_mono_lemma RS lfpI)::prems)) 1]);
   22.30 -in
   22.31 -val ci3_RI    = mk_thm "[|  mono(Agen);  a : R |] ==> a : lfp(%x. Agen(x) Un R Un A)";
   22.32 -val ci3_AgenI = mk_thm "[|  mono(Agen);  a : Agen(lfp(%x. Agen(x) Un R Un A)) |] ==> \
   22.33 -\                       a : lfp(%x. Agen(x) Un R Un A)";
   22.34 -val ci3_AI    = mk_thm "[|  mono(Agen);  a : A |] ==> a : lfp(%x. Agen(x) Un R Un A)";
   22.35 -end;
   22.36 -
   22.37 -fun mk_genIs thy defs genXH gen_mono s = prove_goalw thy defs s
   22.38 -      (fn prems => [rtac (genXH RS iffD2) 1,
   22.39 -                    (simp_tac term_ss 1),
   22.40 -                    TRY (fast_tac (term_cs addIs
   22.41 -                            ([genXH RS iffD2,gen_mono RS coinduct3_mono_lemma RS lfpI]
   22.42 -                             @ prems)) 1)]);
   22.43 -
   22.44 -(** POgen **)
   22.45 -
   22.46 -goal (the_context ()) "<a,a> : PO";
   22.47 -by (rtac (po_refl RS (XH_to_D PO_iff)) 1);
   22.48 -qed "PO_refl";
   22.49 -
   22.50 -val POgenIs = map (mk_genIs (the_context ()) data_defs POgenXH POgen_mono)
   22.51 -      ["<true,true> : POgen(R)",
   22.52 -       "<false,false> : POgen(R)",
   22.53 -       "[| <a,a'> : R;  <b,b'> : R |] ==> <<a,b>,<a',b'>> : POgen(R)",
   22.54 -       "[|!!x. <b(x),b'(x)> : R |] ==><lam x. b(x),lam x. b'(x)> : POgen(R)",
   22.55 -       "<one,one> : POgen(R)",
   22.56 -       "<a,a'> : lfp(%x. POgen(x) Un R Un PO) ==> \
   22.57 -\                         <inl(a),inl(a')> : POgen(lfp(%x. POgen(x) Un R Un PO))",
   22.58 -       "<b,b'> : lfp(%x. POgen(x) Un R Un PO) ==> \
   22.59 -\                         <inr(b),inr(b')> : POgen(lfp(%x. POgen(x) Un R Un PO))",
   22.60 -       "<zero,zero> : POgen(lfp(%x. POgen(x) Un R Un PO))",
   22.61 -       "<n,n'> : lfp(%x. POgen(x) Un R Un PO) ==> \
   22.62 -\                         <succ(n),succ(n')> : POgen(lfp(%x. POgen(x) Un R Un PO))",
   22.63 -       "<[],[]> : POgen(lfp(%x. POgen(x) Un R Un PO))",
   22.64 -       "[| <h,h'> : lfp(%x. POgen(x) Un R Un PO); \
   22.65 -\          <t,t'> : lfp(%x. POgen(x) Un R Un PO) |] ==> \
   22.66 -\       <h$t,h'$t'> : POgen(lfp(%x. POgen(x) Un R Un PO))"];
   22.67 -
   22.68 -fun POgen_tac (rla,rlb) i =
   22.69 -       SELECT_GOAL (safe_tac ccl_cs) i THEN
   22.70 -       rtac (rlb RS (rla RS ssubst_pair)) i THEN
   22.71 -       (REPEAT (resolve_tac (POgenIs @ [PO_refl RS (POgen_mono RS ci3_AI)] @
   22.72 -                   (POgenIs RL [POgen_mono RS ci3_AgenI]) @ [POgen_mono RS ci3_RI]) i));
   22.73 -
   22.74 -(** EQgen **)
   22.75 -
   22.76 -goal (the_context ()) "<a,a> : EQ";
   22.77 -by (rtac (refl RS (EQ_iff RS iffD1)) 1);
   22.78 -qed "EQ_refl";
   22.79 -
   22.80 -val EQgenIs = map (mk_genIs (the_context ()) data_defs EQgenXH EQgen_mono)
   22.81 -["<true,true> : EQgen(R)",
   22.82 - "<false,false> : EQgen(R)",
   22.83 - "[| <a,a'> : R;  <b,b'> : R |] ==> <<a,b>,<a',b'>> : EQgen(R)",
   22.84 - "[|!!x. <b(x),b'(x)> : R |] ==> <lam x. b(x),lam x. b'(x)> : EQgen(R)",
   22.85 - "<one,one> : EQgen(R)",
   22.86 - "<a,a'> : lfp(%x. EQgen(x) Un R Un EQ) ==> \
   22.87 -\                   <inl(a),inl(a')> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
   22.88 - "<b,b'> : lfp(%x. EQgen(x) Un R Un EQ) ==> \
   22.89 -\                   <inr(b),inr(b')> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
   22.90 - "<zero,zero> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
   22.91 - "<n,n'> : lfp(%x. EQgen(x) Un R Un EQ) ==> \
   22.92 -\                   <succ(n),succ(n')> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
   22.93 - "<[],[]> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
   22.94 - "[| <h,h'> : lfp(%x. EQgen(x) Un R Un EQ); \
   22.95 -\          <t,t'> : lfp(%x. EQgen(x) Un R Un EQ) |] ==> \
   22.96 -\       <h$t,h'$t'> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))"];
   22.97 -
   22.98 -fun EQgen_raw_tac i =
   22.99 -       (REPEAT (resolve_tac (EQgenIs @ [EQ_refl RS (EQgen_mono RS ci3_AI)] @
  22.100 -                   (EQgenIs RL [EQgen_mono RS ci3_AgenI]) @ [EQgen_mono RS ci3_RI]) i));
  22.101 -
  22.102 -(* Goals of the form R <= EQgen(R) - rewrite elements <a,b> : EQgen(R) using rews and *)
  22.103 -(* then reduce this to a goal <a',b'> : R (hopefully?)                                *)
  22.104 -(*      rews are rewrite rules that would cause looping in the simpifier              *)
  22.105 -
  22.106 -fun EQgen_tac simp_set rews i =
  22.107 - SELECT_GOAL
  22.108 -   (TRY (safe_tac ccl_cs) THEN
  22.109 -    resolve_tac ((rews@[refl]) RL ((rews@[refl]) RL [ssubst_pair])) i THEN
  22.110 -    ALLGOALS (simp_tac simp_set) THEN
  22.111 -    ALLGOALS EQgen_raw_tac) i;
    23.1 --- a/src/CCL/equalities.ML	Mon Jul 17 18:42:38 2006 +0200
    23.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.3 @@ -1,127 +0,0 @@
    23.4 -(*  Title:      CCL/equalities.ML
    23.5 -    ID:         $Id$
    23.6 -
    23.7 -Equalities involving union, intersection, inclusion, etc.
    23.8 -*)
    23.9 -
   23.10 -val eq_cs = set_cs addSIs [equalityI];
   23.11 -
   23.12 -(** Binary Intersection **)
   23.13 -
   23.14 -goal (the_context ()) "A Int A = A";
   23.15 -by (fast_tac eq_cs 1);
   23.16 -qed "Int_absorb";
   23.17 -
   23.18 -goal (the_context ()) "A Int B  =  B Int A";
   23.19 -by (fast_tac eq_cs 1);
   23.20 -qed "Int_commute";
   23.21 -
   23.22 -goal (the_context ()) "(A Int B) Int C  =  A Int (B Int C)";
   23.23 -by (fast_tac eq_cs 1);
   23.24 -qed "Int_assoc";
   23.25 -
   23.26 -goal (the_context ()) "(A Un B) Int C  =  (A Int C) Un (B Int C)";
   23.27 -by (fast_tac eq_cs 1);
   23.28 -qed "Int_Un_distrib";
   23.29 -
   23.30 -goal (the_context ()) "(A<=B) <-> (A Int B = A)";
   23.31 -by (fast_tac (eq_cs addSEs [equalityE]) 1);
   23.32 -qed "subset_Int_eq";
   23.33 -
   23.34 -(** Binary Union **)
   23.35 -
   23.36 -goal (the_context ()) "A Un A = A";
   23.37 -by (fast_tac eq_cs 1);
   23.38 -qed "Un_absorb";
   23.39 -
   23.40 -goal (the_context ()) "A Un B  =  B Un A";
   23.41 -by (fast_tac eq_cs 1);
   23.42 -qed "Un_commute";
   23.43 -
   23.44 -goal (the_context ()) "(A Un B) Un C  =  A Un (B Un C)";
   23.45 -by (fast_tac eq_cs 1);
   23.46 -qed "Un_assoc";
   23.47 -
   23.48 -goal (the_context ()) "(A Int B) Un C  =  (A Un C) Int (B Un C)";
   23.49 -by (fast_tac eq_cs 1);
   23.50 -qed "Un_Int_distrib";
   23.51 -
   23.52 -goal (the_context ())
   23.53 - "(A Int B) Un (B Int C) Un (C Int A) = (A Un B) Int (B Un C) Int (C Un A)";
   23.54 -by (fast_tac eq_cs 1);
   23.55 -qed "Un_Int_crazy";
   23.56 -
   23.57 -goal (the_context ()) "(A<=B) <-> (A Un B = B)";
   23.58 -by (fast_tac (eq_cs addSEs [equalityE]) 1);
   23.59 -qed "subset_Un_eq";
   23.60 -
   23.61 -(** Simple properties of Compl -- complement of a set **)
   23.62 -
   23.63 -goal (the_context ()) "A Int Compl(A) = {x. False}";
   23.64 -by (fast_tac eq_cs 1);
   23.65 -qed "Compl_disjoint";
   23.66 -
   23.67 -goal (the_context ()) "A Un Compl(A) = {x. True}";
   23.68 -by (fast_tac eq_cs 1);
   23.69 -qed "Compl_partition";
   23.70 -
   23.71 -goal (the_context ()) "Compl(Compl(A)) = A";
   23.72 -by (fast_tac eq_cs 1);
   23.73 -qed "double_complement";
   23.74 -
   23.75 -goal (the_context ()) "Compl(A Un B) = Compl(A) Int Compl(B)";
   23.76 -by (fast_tac eq_cs 1);
   23.77 -qed "Compl_Un";
   23.78 -
   23.79 -goal (the_context ()) "Compl(A Int B) = Compl(A) Un Compl(B)";
   23.80 -by (fast_tac eq_cs 1);
   23.81 -qed "Compl_Int";
   23.82 -
   23.83 -goal (the_context ()) "Compl(UN x:A. B(x)) = (INT x:A. Compl(B(x)))";
   23.84 -by (fast_tac eq_cs 1);
   23.85 -qed "Compl_UN";
   23.86 -
   23.87 -goal (the_context ()) "Compl(INT x:A. B(x)) = (UN x:A. Compl(B(x)))";
   23.88 -by (fast_tac eq_cs 1);
   23.89 -qed "Compl_INT";
   23.90 -
   23.91 -(*Halmos, Naive Set Theory, page 16.*)
   23.92 -
   23.93 -goal (the_context ()) "((A Int B) Un C = A Int (B Un C)) <-> (C<=A)";
   23.94 -by (fast_tac (eq_cs addSEs [equalityE]) 1);
   23.95 -qed "Un_Int_assoc_eq";
   23.96 -
   23.97 -
   23.98 -(** Big Union and Intersection **)
   23.99 -
  23.100 -goal (the_context ()) "Union(A Un B) = Union(A) Un Union(B)";
  23.101 -by (fast_tac eq_cs 1);
  23.102 -qed "Union_Un_distrib";
  23.103 -
  23.104 -val prems = goal (the_context ())
  23.105 -   "(Union(C) Int A = {x. False}) <-> (ALL B:C. B Int A = {x. False})";
  23.106 -by (fast_tac (eq_cs addSEs [equalityE]) 1);
  23.107 -qed "Union_disjoint";
  23.108 -
  23.109 -goal (the_context ()) "Inter(A Un B) = Inter(A) Int Inter(B)";
  23.110 -by (best_tac eq_cs 1);
  23.111 -qed "Inter_Un_distrib";
  23.112 -
  23.113 -(** Unions and Intersections of Families **)
  23.114 -
  23.115 -goal (the_context ()) "(UN x:A. B(x)) = Union({Y. EX x:A. Y=B(x)})";
  23.116 -by (fast_tac eq_cs 1);
  23.117 -qed "UN_eq";
  23.118 -
  23.119 -(*Look: it has an EXISTENTIAL quantifier*)
  23.120 -goal (the_context ()) "(INT x:A. B(x)) = Inter({Y. EX x:A. Y=B(x)})";
  23.121 -by (fast_tac eq_cs 1);
  23.122 -qed "INT_eq";
  23.123 -
  23.124 -goal (the_context ()) "A Int Union(B) = (UN C:B. A Int C)";
  23.125 -by (fast_tac eq_cs 1);
  23.126 -qed "Int_Union_image";
  23.127 -
  23.128 -goal (the_context ()) "A Un Inter(B) = (INT C:B. A Un C)";
  23.129 -by (fast_tac eq_cs 1);
  23.130 -qed "Un_Inter_image";
    24.1 --- a/src/CCL/eval.ML	Mon Jul 17 18:42:38 2006 +0200
    24.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.3 @@ -1,100 +0,0 @@
    24.4 -(*  Title:      92/CCL/eval
    24.5 -    ID:         $Id$
    24.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    24.7 -    Copyright   1992  University of Cambridge
    24.8 -*)
    24.9 -
   24.10 -(*** Evaluation ***)
   24.11 -
   24.12 -val EVal_rls = ref [trueV,falseV,pairV,lamV,caseVtrue,caseVfalse,caseVpair,caseVlam];
   24.13 -val eval_tac = DEPTH_SOLVE_1 (resolve_tac (!EVal_rls) 1);
   24.14 -fun ceval_tac rls = DEPTH_SOLVE_1 (resolve_tac (!EVal_rls@rls) 1);
   24.15 -
   24.16 -val prems = goalw (the_context ()) [apply_def]
   24.17 -   "[| f ---> lam x. b(x);  b(a) ---> c |] ==> f ` a ---> c";
   24.18 -by (ceval_tac prems);
   24.19 -qed "applyV";
   24.20 -
   24.21 -EVal_rls := !EVal_rls @ [applyV];
   24.22 -
   24.23 -val major::prems = goalw (the_context ()) [let_def]
   24.24 -   "[| t ---> a;  f(a) ---> c |] ==> let x be t in f(x) ---> c";
   24.25 -by (rtac (major RS canonical) 1);
   24.26 -by (REPEAT (DEPTH_SOLVE_1 (resolve_tac ([major]@prems@(!EVal_rls)) 1 ORELSE
   24.27 -                           etac substitute 1)));
   24.28 -qed "letV";
   24.29 -
   24.30 -val prems = goalw (the_context ()) [fix_def]
   24.31 -   "f(fix(f)) ---> c ==> fix(f) ---> c";
   24.32 -by (rtac applyV 1);
   24.33 -by (rtac lamV 1);
   24.34 -by (resolve_tac prems 1);
   24.35 -qed "fixV";
   24.36 -
   24.37 -val prems = goalw (the_context ()) [letrec_def]
   24.38 -    "h(t,%y. letrec g x be h(x,g) in g(y)) ---> c ==> \
   24.39 -\                  letrec g x be h(x,g) in g(t) ---> c";
   24.40 -by (REPEAT (resolve_tac (prems @ [fixV,applyV,lamV]) 1));
   24.41 -qed "letrecV";
   24.42 -
   24.43 -EVal_rls := !EVal_rls @ [letV,letrecV,fixV];
   24.44 -
   24.45 -fun mk_V_rl s = prove_goalw (the_context ()) data_defs s (fn prems => [ceval_tac prems]);
   24.46 -
   24.47 -val V_rls = map mk_V_rl
   24.48 -             ["true ---> true",
   24.49 -              "false ---> false",
   24.50 -              "[| b--->true;  t--->c |] ==> if b then t else u ---> c",
   24.51 -              "[| b--->false;  u--->c |] ==> if b then t else u ---> c",
   24.52 -              "<a,b> ---> <a,b>",
   24.53 -              "[| t ---> <a,b>;  h(a,b) ---> c |] ==> split(t,h) ---> c",
   24.54 -              "zero ---> zero",
   24.55 -              "succ(n) ---> succ(n)",
   24.56 -              "[| n ---> zero; t ---> c |] ==> ncase(n,t,u) ---> c",
   24.57 -              "[| n ---> succ(x); u(x) ---> c |] ==> ncase(n,t,u) ---> c",
   24.58 -              "[| n ---> zero; t ---> c |] ==> nrec(n,t,u) ---> c",
   24.59 -              "[| n--->succ(x); u(x,nrec(x,t,u))--->c |] ==> nrec(n,t,u)--->c",
   24.60 -              "[] ---> []",
   24.61 -              "h$t ---> h$t",
   24.62 -              "[| l ---> []; t ---> c |] ==> lcase(l,t,u) ---> c",
   24.63 -              "[| l ---> x$xs; u(x,xs) ---> c |] ==> lcase(l,t,u) ---> c",
   24.64 -              "[| l ---> []; t ---> c |] ==> lrec(l,t,u) ---> c",
   24.65 -              "[| l--->x$xs; u(x,xs,lrec(xs,t,u))--->c |] ==> lrec(l,t,u)--->c"];
   24.66 -
   24.67 -EVal_rls := !EVal_rls @ V_rls;
   24.68 -
   24.69 -(* Factorial *)
   24.70 -
   24.71 -val prems = goal (the_context ())
   24.72 -    "letrec f n be ncase(n,succ(zero),%x. nrec(n,zero,%y g. nrec(f(x),g,%z h. succ(h)))) \
   24.73 -\              in f(succ(succ(zero))) ---> ?a";
   24.74 -by (ceval_tac []);
   24.75 -
   24.76 -val prems = goal (the_context ())
   24.77 -    "letrec f n be ncase(n,succ(zero),%x. nrec(n,zero,%y g. nrec(f(x),g,%z h. succ(h)))) \
   24.78 -\              in f(succ(succ(succ(zero)))) ---> ?a";
   24.79 -by (ceval_tac []);
   24.80 -
   24.81 -(* Less Than Or Equal *)
   24.82 -
   24.83 -fun isle x y = prove_goal (the_context ())
   24.84 -    ("letrec f p be split(p,%m n. ncase(m,true,%x. ncase(n,false,%y. f(<x,y>)))) \
   24.85 -\              in f(<"^x^","^y^">) ---> ?a")
   24.86 -    (fn prems => [ceval_tac []]);
   24.87 -
   24.88 -isle "succ(zero)" "succ(zero)";
   24.89 -isle "succ(zero)" "succ(succ(succ(succ(zero))))";
   24.90 -isle "succ(succ(succ(succ(succ(zero)))))" "succ(succ(succ(succ(zero))))";
   24.91 -
   24.92 -
   24.93 -(* Reverse *)
   24.94 -
   24.95 -val prems = goal (the_context ())
   24.96 -    "letrec id l be lcase(l,[],%x xs. x$id(xs)) \
   24.97 -\              in id(zero$succ(zero)$[]) ---> ?a";
   24.98 -by (ceval_tac []);
   24.99 -
  24.100 -val prems = goal (the_context ())
  24.101 -    "letrec rev l be lcase(l,[],%x xs. lrec(rev(xs),x$[],%y ys g. y$g)) \
  24.102 -\              in rev(zero$succ(zero)$(succ((lam x. x)`succ(zero)))$([])) ---> ?a";
  24.103 -by (ceval_tac []);
    25.1 --- a/src/CCL/ex/Flag.ML	Mon Jul 17 18:42:38 2006 +0200
    25.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.3 @@ -1,42 +0,0 @@
    25.4 -(*  Title:      CCL/ex/Flag.ML
    25.5 -    ID:         $Id$
    25.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    25.7 -    Copyright   1993  University of Cambridge
    25.8 -*)
    25.9 -
   25.10 -(******)
   25.11 -
   25.12 -val flag_defs = [Colour_def,red_def,white_def,blue_def,ccase_def];
   25.13 -
   25.14 -(******)
   25.15 -
   25.16 -val ColourXH = mk_XH_tac (the_context ()) (simp_type_defs @flag_defs) [] 
   25.17 -          "a : Colour <-> (a=red | a=white | a=blue)";
   25.18 -
   25.19 -val Colour_case = XH_to_E ColourXH;
   25.20 -
   25.21 -val redT = mk_canT_tac (the_context ()) [ColourXH] "red : Colour";
   25.22 -val whiteT = mk_canT_tac (the_context ()) [ColourXH] "white : Colour";
   25.23 -val blueT = mk_canT_tac (the_context ()) [ColourXH] "blue : Colour";
   25.24 -
   25.25 -
   25.26 -val ccaseT = mk_ncanT_tac (the_context ()) flag_defs case_rls case_rls
   25.27 -     "[| c:Colour; \
   25.28 -\        c=red ==> r : C(red); c=white ==> w : C(white); c=blue ==> b : C(blue) |] ==> \
   25.29 -\     ccase(c,r,w,b) : C(c)";
   25.30 -
   25.31 -(***)
   25.32 -
   25.33 -val prems = goalw (the_context ()) [flag_def]
   25.34 -    "flag : List(Colour)->List(Colour)*List(Colour)*List(Colour)";
   25.35 -by (typechk_tac [redT,whiteT,blueT,ccaseT] 1);
   25.36 -by clean_ccs_tac;
   25.37 -by (etac (ListPRI RS (ListPR_wf RS wfI)) 1);
   25.38 -by (assume_tac 1);
   25.39 -result();
   25.40 -
   25.41 -
   25.42 -val prems = goalw (the_context ()) [flag_def]
   25.43 -    "flag : PROD l:List(Colour).{x:List(Colour)*List(Colour)*List(Colour).FLAG(x,l)}";
   25.44 -by (gen_ccs_tac [redT,whiteT,blueT,ccaseT] 1);
   25.45 -by (REPEAT_SOME (ares_tac [ListPRI RS (ListPR_wf RS wfI)]));
    26.1 --- a/src/CCL/ex/Flag.thy	Mon Jul 17 18:42:38 2006 +0200
    26.2 +++ b/src/CCL/ex/Flag.thy	Tue Jul 18 02:22:38 2006 +0200
    26.3 @@ -44,6 +44,35 @@
    26.4                                  (c mem lb = true --> c=blue)) &
    26.5                    Perm(l,lr @ lw @ lb)"
    26.6  
    26.7 -ML {* use_legacy_bindings (the_context ()) *}
    26.8 +
    26.9 +lemmas flag_defs = Colour_def red_def white_def blue_def ccase_def
   26.10 +
   26.11 +lemma ColourXH: "a : Colour <-> (a=red | a=white | a=blue)"
   26.12 +  unfolding simp_type_defs flag_defs by blast
   26.13 +
   26.14 +lemma redT: "red : Colour"
   26.15 +  and whiteT: "white : Colour"
   26.16 +  and blueT: "blue : Colour"
   26.17 +  unfolding ColourXH by blast+
   26.18 +
   26.19 +ML {*
   26.20 +bind_thm ("ccaseT", mk_ncanT_tac (the_context ())
   26.21 +  (thms "flag_defs") (thms "case_rls") (thms "case_rls")
   26.22 +  "[| c:Colour; c=red ==> r : C(red); c=white ==> w : C(white); c=blue ==> b : C(blue) |] ==> ccase(c,r,w,b) : C(c)");
   26.23 +*}
   26.24 +
   26.25 +
   26.26 +lemma "flag : List(Colour)->List(Colour)*List(Colour)*List(Colour)"
   26.27 +  apply (unfold flag_def)
   26.28 +  apply (tactic {* typechk_tac [thm "redT", thm "whiteT", thm "blueT", thm "ccaseT"] 1 *})
   26.29 +  apply (tactic clean_ccs_tac)
   26.30 +  apply (erule ListPRI [THEN ListPR_wf [THEN wfI]])
   26.31 +  apply assumption
   26.32 +  done
   26.33 +
   26.34 +lemma "flag : PROD l:List(Colour).{x:List(Colour)*List(Colour)*List(Colour).FLAG(x,l)}"
   26.35 +  apply (unfold flag_def)
   26.36 +  apply (tactic {* gen_ccs_tac [thm "redT", thm "whiteT", thm "blueT", thm "ccaseT"] 1 *})
   26.37 +  oops
   26.38  
   26.39  end
    27.1 --- a/src/CCL/ex/List.ML	Mon Jul 17 18:42:38 2006 +0200
    27.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.3 @@ -1,101 +0,0 @@
    27.4 -(*  Title:      CCL/ex/List.ML
    27.5 -    ID:         $Id$
    27.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    27.7 -    Copyright   1993  University of Cambridge
    27.8 -*)
    27.9 -
   27.10 -val list_defs = [map_def,comp_def,append_def,filter_def,flat_def,
   27.11 -                 insert_def,isort_def,partition_def,qsort_def];
   27.12 -
   27.13 -(****)
   27.14 -
   27.15 -val listBs = map (fn s=>prove_goalw (the_context ()) list_defs s (fn _ => [simp_tac term_ss 1]))
   27.16 -     ["(f o g) = (%a. f(g(a)))",
   27.17 -      "(f o g)(a) = f(g(a))",
   27.18 -      "map(f,[]) = []",
   27.19 -      "map(f,x$xs) = f(x)$map(f,xs)",
   27.20 -      "[] @ m = m",
   27.21 -      "x$xs @ m = x$(xs @ m)",
   27.22 -      "filter(f,[]) = []",
   27.23 -      "filter(f,x$xs) = if f`x then x$filter(f,xs) else filter(f,xs)",
   27.24 -      "flat([]) = []",
   27.25 -      "flat(x$xs) = x @ flat(xs)",
   27.26 -      "insert(f,a,[]) = a$[]",
   27.27 -      "insert(f,a,x$xs) = if f`a`x then a$x$xs else x$insert(f,a,xs)"];
   27.28 -
   27.29 -val list_ss = nat_ss addsimps listBs;
   27.30 -
   27.31 -(****)
   27.32 -
   27.33 -val [prem] = goal (the_context ()) "n:Nat ==> map(f) ^ n ` [] = []";
   27.34 -by (rtac (prem RS Nat_ind) 1);
   27.35 -by (ALLGOALS (asm_simp_tac list_ss));
   27.36 -qed "nmapBnil";
   27.37 -
   27.38 -val [prem] = goal (the_context ()) "n:Nat ==> map(f)^n`(x$xs) = (f^n`x)$(map(f)^n`xs)";
   27.39 -by (rtac (prem RS Nat_ind) 1);
   27.40 -by (ALLGOALS (asm_simp_tac list_ss));
   27.41 -qed "nmapBcons";
   27.42 -
   27.43 -(***)
   27.44 -
   27.45 -val prems = goalw (the_context ()) [map_def]
   27.46 -  "[| !!x. x:A==>f(x):B;  l : List(A) |] ==> map(f,l) : List(B)";
   27.47 -by (typechk_tac prems 1);
   27.48 -qed "mapT";
   27.49 -
   27.50 -val prems = goalw (the_context ()) [append_def]
   27.51 -  "[| l : List(A);  m : List(A) |] ==> l @ m : List(A)";
   27.52 -by (typechk_tac prems 1);
   27.53 -qed "appendT";
   27.54 -
   27.55 -val prems = goal (the_context ())
   27.56 -  "[| l : {l:List(A). m : {m:List(A).P(l @ m)}} |] ==> l @ m : {x:List(A). P(x)}";
   27.57 -by (cut_facts_tac prems 1);
   27.58 -by (fast_tac (set_cs addSIs [SubtypeI,appendT] addSEs [SubtypeE]) 1);
   27.59 -qed "appendTS";
   27.60 -
   27.61 -val prems = goalw (the_context ()) [filter_def]
   27.62 -  "[| f:A->Bool;   l : List(A) |] ==> filter(f,l) : List(A)";
   27.63 -by (typechk_tac prems 1);
   27.64 -qed "filterT";
   27.65 -
   27.66 -val prems = goalw (the_context ()) [flat_def]
   27.67 -  "l : List(List(A)) ==> flat(l) : List(A)";
   27.68 -by (typechk_tac (appendT::prems) 1);
   27.69 -qed "flatT";
   27.70 -
   27.71 -val prems = goalw (the_context ()) [insert_def]
   27.72 -  "[|  f : A->A->Bool; a:A; l : List(A) |] ==> insert(f,a,l) : List(A)";
   27.73 -by (typechk_tac prems 1);
   27.74 -qed "insertT";
   27.75 -
   27.76 -val prems = goal (the_context ())
   27.77 -  "[| f : {f:A->A->Bool. a : {a:A. l : {l:List(A).P(insert(f,a,l))}}} |] ==> \
   27.78 -\  insert(f,a,l)  : {x:List(A). P(x)}";
   27.79 -by (cut_facts_tac prems 1);
   27.80 -by (fast_tac (set_cs addSIs [SubtypeI,insertT] addSEs [SubtypeE]) 1);
   27.81 -qed "insertTS";
   27.82 -
   27.83 -val prems = goalw (the_context ()) [partition_def]
   27.84 -  "[| f:A->Bool;  l : List(A) |] ==> partition(f,l) : List(A)*List(A)";
   27.85 -by (typechk_tac prems 1);
   27.86 -by clean_ccs_tac;
   27.87 -by (rtac (ListPRI RS wfstI RS (ListPR_wf RS wmap_wf RS wfI)) 2);
   27.88 -by (rtac (ListPRI RS wfstI RS (ListPR_wf RS wmap_wf RS wfI)) 1);
   27.89 -by (REPEAT (atac 1));
   27.90 -qed "partitionT";
   27.91 -
   27.92 -(*** Correctness Conditions for Insertion Sort ***)
   27.93 -
   27.94 -
   27.95 -val prems = goalw (the_context ()) [isort_def]
   27.96 -    "f:A->A->Bool ==> isort(f) : PROD l:List(A).{x: List(A). Ord(f,x) & Perm(x,l)}";
   27.97 -by (gen_ccs_tac  ([insertTS,insertT]@prems) 1);
   27.98 -
   27.99 -
  27.100 -(*** Correctness Conditions for Quick Sort ***)
  27.101 -
  27.102 -val prems = goalw (the_context ()) [qsort_def]
  27.103 -    "f:A->A->Bool ==> qsort(f) : PROD l:List(A).{x: List(A). Ord(f,x) & Perm(x,l)}";
  27.104 -by (gen_ccs_tac  ([partitionT,appendTS,appendT]@prems) 1);
    28.1 --- a/src/CCL/ex/List.thy	Mon Jul 17 18:42:38 2006 +0200
    28.2 +++ b/src/CCL/ex/List.thy	Tue Jul 18 02:22:38 2006 +0200
    28.3 @@ -43,6 +43,80 @@
    28.4                                     in split(p,%x y. qsortx(x) @ h$qsortx(y)))
    28.5                            in qsortx(l)"
    28.6  
    28.7 -ML {* use_legacy_bindings (the_context ()) *}
    28.8 +
    28.9 +lemmas list_defs = map_def comp_def append_def filter_def flat_def
   28.10 +  insert_def isort_def partition_def qsort_def
   28.11 +
   28.12 +lemma listBs [simp]:
   28.13 +  "!!f g. (f o g) = (%a. f(g(a)))"
   28.14 +  "!!a f g. (f o g)(a) = f(g(a))"
   28.15 +  "!!f. map(f,[]) = []"
   28.16 +  "!!f x xs. map(f,x$xs) = f(x)$map(f,xs)"
   28.17 +  "!!m. [] @ m = m"
   28.18 +  "!!x xs m. x$xs @ m = x$(xs @ m)"
   28.19 +  "!!f. filter(f,[]) = []"
   28.20 +  "!!f x xs. filter(f,x$xs) = if f`x then x$filter(f,xs) else filter(f,xs)"
   28.21 +  "flat([]) = []"
   28.22 +  "!!x xs. flat(x$xs) = x @ flat(xs)"
   28.23 +  "!!a f. insert(f,a,[]) = a$[]"
   28.24 +  "!!a f xs. insert(f,a,x$xs) = if f`a`x then a$x$xs else x$insert(f,a,xs)"
   28.25 +  by (simp_all add: list_defs)
   28.26 +
   28.27 +lemma nmapBnil: "n:Nat ==> map(f) ^ n ` [] = []"
   28.28 +  apply (erule Nat_ind)
   28.29 +   apply simp_all
   28.30 +  done
   28.31 +
   28.32 +lemma nmapBcons: "n:Nat ==> map(f)^n`(x$xs) = (f^n`x)$(map(f)^n`xs)"
   28.33 +  apply (erule Nat_ind)
   28.34 +   apply simp_all
   28.35 +  done
   28.36 +
   28.37 +
   28.38 +lemma mapT: "[| !!x. x:A==>f(x):B;  l : List(A) |] ==> map(f,l) : List(B)"
   28.39 +  apply (unfold map_def)
   28.40 +  apply (tactic "typechk_tac [] 1")
   28.41 +  apply blast
   28.42 +  done
   28.43 +
   28.44 +lemma appendT: "[| l : List(A);  m : List(A) |] ==> l @ m : List(A)"
   28.45 +  apply (unfold append_def)
   28.46 +  apply (tactic "typechk_tac [] 1")
   28.47 +  done
   28.48 +
   28.49 +lemma appendTS:
   28.50 +  "[| l : {l:List(A). m : {m:List(A).P(l @ m)}} |] ==> l @ m : {x:List(A). P(x)}"
   28.51 +  by (blast intro!: SubtypeI appendT elim!: SubtypeE)
   28.52 +
   28.53 +lemma filterT: "[| f:A->Bool;   l : List(A) |] ==> filter(f,l) : List(A)"
   28.54 +  apply (unfold filter_def)
   28.55 +  apply (tactic "typechk_tac [] 1")
   28.56 +  done
   28.57 +
   28.58 +lemma flatT: "l : List(List(A)) ==> flat(l) : List(A)"
   28.59 +  apply (unfold flat_def)
   28.60 +  apply (tactic {* typechk_tac [thm "appendT"] 1 *})
   28.61 +  done
   28.62 +
   28.63 +lemma insertT: "[|  f : A->A->Bool; a:A; l : List(A) |] ==> insert(f,a,l) : List(A)"
   28.64 +  apply (unfold insert_def)
   28.65 +  apply (tactic "typechk_tac [] 1")
   28.66 +  done
   28.67 +
   28.68 +lemma insertTS:
   28.69 +  "[| f : {f:A->A->Bool. a : {a:A. l : {l:List(A).P(insert(f,a,l))}}} |] ==>  
   28.70 +   insert(f,a,l)  : {x:List(A). P(x)}"
   28.71 +  by (blast intro!: SubtypeI insertT elim!: SubtypeE)
   28.72 +
   28.73 +lemma partitionT:
   28.74 +  "[| f:A->Bool;  l : List(A) |] ==> partition(f,l) : List(A)*List(A)"
   28.75 +  apply (unfold partition_def)
   28.76 +  apply (tactic "typechk_tac [] 1")
   28.77 +  apply (tactic clean_ccs_tac)
   28.78 +  apply (rule ListPRI [THEN wfstI, THEN ListPR_wf [THEN wmap_wf, THEN wfI]])
   28.79 +    apply assumption+
   28.80 +  apply (rule ListPRI [THEN wfstI, THEN ListPR_wf [THEN wmap_wf, THEN wfI]])
   28.81 +   apply assumption+
   28.82 +  done
   28.83  
   28.84  end
    29.1 --- a/src/CCL/ex/Nat.ML	Mon Jul 17 18:42:38 2006 +0200
    29.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    29.3 @@ -1,68 +0,0 @@
    29.4 -(*  Title:      CCL/ex/Nat.ML
    29.5 -    ID:         $Id$
    29.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    29.7 -    Copyright   1993  University of Cambridge
    29.8 -*)
    29.9 -
   29.10 -val nat_defs = [not_def,add_def,mult_def,sub_def,le_def,lt_def,ack_def,napply_def];
   29.11 -
   29.12 -val natBs = map (fn s=>prove_goalw (the_context ()) nat_defs s (fn _ => [simp_tac term_ss 1]))
   29.13 -     ["not(true) = false",
   29.14 -      "not(false) = true",
   29.15 -      "zero #+ n = n",
   29.16 -      "succ(n) #+ m = succ(n #+ m)",
   29.17 -      "zero #* n = zero",
   29.18 -      "succ(n) #* m = m #+ (n #* m)",
   29.19 -      "f^zero`a = a",
   29.20 -      "f^succ(n)`a = f(f^n`a)"];
   29.21 -
   29.22 -val nat_ss = term_ss addsimps natBs;
   29.23 -
   29.24 -(*** Lemma for napply ***)
   29.25 -
   29.26 -val [prem] = goal (the_context ()) "n:Nat ==> f^n`f(a) = f^succ(n)`a";
   29.27 -by (rtac (prem RS Nat_ind) 1);
   29.28 -by (ALLGOALS (asm_simp_tac nat_ss));
   29.29 -qed "napply_f";
   29.30 -
   29.31 -(****)
   29.32 -
   29.33 -val prems = goalw (the_context ()) [add_def] "[| a:Nat;  b:Nat |] ==> a #+ b : Nat";
   29.34 -by (typechk_tac prems 1);
   29.35 -qed "addT";
   29.36 -
   29.37 -val prems = goalw (the_context ()) [mult_def] "[| a:Nat;  b:Nat |] ==> a #* b : Nat";
   29.38 -by (typechk_tac (addT::prems) 1);
   29.39 -qed "multT";
   29.40 -
   29.41 -(* Defined to return zero if a<b *)
   29.42 -val prems = goalw (the_context ()) [sub_def] "[| a:Nat;  b:Nat |] ==> a #- b : Nat";
   29.43 -by (typechk_tac (prems) 1);
   29.44 -by clean_ccs_tac;
   29.45 -by (etac (NatPRI RS wfstI RS (NatPR_wf RS wmap_wf RS wfI)) 1);
   29.46 -qed "subT";
   29.47 -
   29.48 -val prems = goalw (the_context ()) [le_def] "[| a:Nat;  b:Nat |] ==> a #<= b : Bool";
   29.49 -by (typechk_tac (prems) 1);
   29.50 -by clean_ccs_tac;
   29.51 -by (etac (NatPRI RS wfstI RS (NatPR_wf RS wmap_wf RS wfI)) 1);
   29.52 -qed "leT";
   29.53 -
   29.54 -val prems = goalw (the_context ()) [not_def,lt_def] "[| a:Nat;  b:Nat |] ==> a #< b : Bool";
   29.55 -by (typechk_tac (prems@[leT]) 1);
   29.56 -qed "ltT";
   29.57 -
   29.58 -(* Correctness conditions for subtractive division **)
   29.59 -
   29.60 -val prems = goalw (the_context ()) [div_def]
   29.61 -    "[| a:Nat;  b:{x:Nat.~x=zero} |] ==> a ## b : {x:Nat. DIV(a,b,x)}";
   29.62 -by (gen_ccs_tac (prems@[ltT,subT]) 1);
   29.63 -
   29.64 -(* Termination Conditions for Ackermann's Function *)
   29.65 -
   29.66 -val prems = goalw (the_context ()) [ack_def]
   29.67 -    "[| a:Nat;  b:Nat |] ==> ackermann(a,b) : Nat";
   29.68 -by (gen_ccs_tac prems 1);
   29.69 -val relI = NatPR_wf RS (NatPR_wf RS lex_wf RS wfI);
   29.70 -by (REPEAT (eresolve_tac [NatPRI RS (lexI1 RS relI),NatPRI RS (lexI2 RS relI)] 1));
   29.71 -result();
    30.1 --- a/src/CCL/ex/Nat.thy	Mon Jul 17 18:42:38 2006 +0200
    30.2 +++ b/src/CCL/ex/Nat.thy	Tue Jul 18 02:22:38 2006 +0200
    30.3 @@ -40,7 +40,65 @@
    30.4                            ncase(m,ack(x,succ(zero)),%y. ack(x,ack(succ(x),y))))
    30.5                      in ack(a,b)"
    30.6  
    30.7 -ML {* use_legacy_bindings (the_context ()) *}
    30.8 +lemmas nat_defs = not_def add_def mult_def sub_def le_def lt_def ack_def napply_def
    30.9 +
   30.10 +lemma natBs [simp]:
   30.11 +  "not(true) = false"
   30.12 +  "not(false) = true"
   30.13 +  "zero #+ n = n"
   30.14 +  "succ(n) #+ m = succ(n #+ m)"
   30.15 +  "zero #* n = zero"
   30.16 +  "succ(n) #* m = m #+ (n #* m)"
   30.17 +  "f^zero`a = a"
   30.18 +  "f^succ(n)`a = f(f^n`a)"
   30.19 +  by (simp_all add: nat_defs)
   30.20 +
   30.21 +
   30.22 +lemma napply_f: "n:Nat ==> f^n`f(a) = f^succ(n)`a"
   30.23 +  apply (erule Nat_ind)
   30.24 +   apply simp_all
   30.25 +  done
   30.26 +
   30.27 +lemma addT: "[| a:Nat;  b:Nat |] ==> a #+ b : Nat"
   30.28 +  apply (unfold add_def)
   30.29 +  apply (tactic {* typechk_tac [] 1 *})
   30.30 +  done
   30.31 +
   30.32 +lemma multT: "[| a:Nat;  b:Nat |] ==> a #* b : Nat"
   30.33 +  apply (unfold add_def mult_def)
   30.34 +  apply (tactic {* typechk_tac [] 1 *})
   30.35 +  done
   30.36 +
   30.37 +(* Defined to return zero if a<b *)
   30.38 +lemma subT: "[| a:Nat;  b:Nat |] ==> a #- b : Nat"
   30.39 +  apply (unfold sub_def)
   30.40 +  apply (tactic {* typechk_tac [] 1 *})
   30.41 +  apply (tactic clean_ccs_tac)
   30.42 +  apply (erule NatPRI [THEN wfstI, THEN NatPR_wf [THEN wmap_wf, THEN wfI]])
   30.43 +  done
   30.44 +
   30.45 +lemma leT: "[| a:Nat;  b:Nat |] ==> a #<= b : Bool"
   30.46 +  apply (unfold le_def)
   30.47 +  apply (tactic {* typechk_tac [] 1 *})
   30.48 +  apply (tactic clean_ccs_tac)
   30.49 +  apply (erule NatPRI [THEN wfstI, THEN NatPR_wf [THEN wmap_wf, THEN wfI]])
   30.50 +  done
   30.51 +
   30.52 +lemma ltT: "[| a:Nat;  b:Nat |] ==> a #< b : Bool"
   30.53 +  apply (unfold not_def lt_def)
   30.54 +  apply (tactic {* typechk_tac [thm "leT"] 1 *})
   30.55 +  done
   30.56 +
   30.57 +
   30.58 +subsection {* Termination Conditions for Ackermann's Function *}
   30.59 +
   30.60 +lemmas relI = NatPR_wf [THEN NatPR_wf [THEN lex_wf, THEN wfI]]
   30.61 +
   30.62 +lemma "[| a:Nat;  b:Nat |] ==> ackermann(a,b) : Nat"
   30.63 +  apply (unfold ack_def)
   30.64 +  apply (tactic "gen_ccs_tac [] 1")
   30.65 +  apply (erule NatPRI [THEN lexI1 [THEN relI]] NatPRI [THEN lexI2 [THEN relI]])+
   30.66 +  done
   30.67  
   30.68  end
   30.69  
    31.1 --- a/src/CCL/ex/Stream.ML	Mon Jul 17 18:42:38 2006 +0200
    31.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.3 @@ -1,110 +0,0 @@
    31.4 -(*  Title:      CCL/ex/Stream.ML
    31.5 -    ID:         $Id$
    31.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    31.7 -    Copyright   1993  University of Cambridge
    31.8 -
    31.9 -Proving properties about infinite lists using coinduction:
   31.10 -    Lists(A)  is the set of all finite and infinite lists of elements of A.
   31.11 -    ILists(A) is the set of infinite lists of elements of A.
   31.12 -*)
   31.13 -
   31.14 -(*** Map of composition is composition of maps ***)
   31.15 -
   31.16 -val prems = goal (the_context ()) "l:Lists(A) ==> map(f o g,l) = map(f,map(g,l))";
   31.17 -by (eq_coinduct3_tac
   31.18 -       "{p. EX x y. p=<x,y> & (EX l:Lists(A).x=map(f o g,l) & y=map(f,map(g,l)))}"  1);
   31.19 -by (fast_tac (ccl_cs addSIs prems) 1);
   31.20 -by (safe_tac type_cs);
   31.21 -by (etac (XH_to_E ListsXH) 1);
   31.22 -by (EQgen_tac list_ss [] 1);
   31.23 -by (simp_tac list_ss 1);
   31.24 -by (fast_tac ccl_cs 1);
   31.25 -qed "map_comp";
   31.26 -
   31.27 -(*** Mapping the identity function leaves a list unchanged ***)
   31.28 -
   31.29 -val prems = goal (the_context ()) "l:Lists(A) ==> map(%x. x,l) = l";
   31.30 -by (eq_coinduct3_tac
   31.31 -       "{p. EX x y. p=<x,y> & (EX l:Lists(A).x=map(%x. x,l) & y=l)}"  1);
   31.32 -by (fast_tac (ccl_cs addSIs prems) 1);
   31.33 -by (safe_tac type_cs);
   31.34 -by (etac (XH_to_E ListsXH) 1);
   31.35 -by (EQgen_tac list_ss [] 1);
   31.36 -by (fast_tac ccl_cs 1);
   31.37 -qed "map_id";
   31.38 -
   31.39 -(*** Mapping distributes over append ***)
   31.40 -
   31.41 -val prems = goal (the_context ())
   31.42 -        "[| l:Lists(A); m:Lists(A) |] ==> map(f,l@m) = map(f,l) @ map(f,m)";
   31.43 -by (eq_coinduct3_tac "{p. EX x y. p=<x,y> & (EX l:Lists(A).EX m:Lists(A). \
   31.44 -\                                           x=map(f,l@m) & y=map(f,l) @ map(f,m))}"  1);
   31.45 -by (fast_tac (ccl_cs addSIs prems) 1);
   31.46 -by (safe_tac type_cs);
   31.47 -by (etac (XH_to_E ListsXH) 1);
   31.48 -by (EQgen_tac list_ss [] 1);
   31.49 -by (etac (XH_to_E ListsXH) 1);
   31.50 -by (EQgen_tac list_ss [] 1);
   31.51 -by (fast_tac ccl_cs 1);
   31.52 -qed "map_append";
   31.53 -
   31.54 -(*** Append is associative ***)
   31.55 -
   31.56 -val prems = goal (the_context ())
   31.57 -        "[| k:Lists(A); l:Lists(A); m:Lists(A) |] ==> k @ l @ m = (k @ l) @ m";
   31.58 -by (eq_coinduct3_tac
   31.59 -    "{p. EX x y. p=<x,y> & (EX k:Lists(A).EX l:Lists(A).EX m:Lists(A). \
   31.60 -\                          x=k @ l @ m & y=(k @ l) @ m)}"  1);
   31.61 -by (fast_tac (ccl_cs addSIs prems) 1);
   31.62 -by (safe_tac type_cs);
   31.63 -by (etac (XH_to_E ListsXH) 1);
   31.64 -by (EQgen_tac list_ss [] 1);
   31.65 -by (fast_tac ccl_cs 2);
   31.66 -by (DEPTH_SOLVE (etac (XH_to_E ListsXH) 1 THEN EQgen_tac list_ss [] 1));
   31.67 -qed "append_assoc";
   31.68 -
   31.69 -(*** Appending anything to an infinite list doesn't alter it ****)
   31.70 -
   31.71 -val prems = goal (the_context ()) "l:ILists(A) ==> l @ m = l";
   31.72 -by (eq_coinduct3_tac
   31.73 -    "{p. EX x y. p=<x,y> & (EX l:ILists(A).EX m. x=l@m & y=l)}" 1);
   31.74 -by (fast_tac (ccl_cs addSIs prems) 1);
   31.75 -by (safe_tac set_cs);
   31.76 -by (etac (XH_to_E IListsXH) 1);
   31.77 -by (EQgen_tac list_ss [] 1);
   31.78 -by (fast_tac ccl_cs 1);
   31.79 -qed "ilist_append";
   31.80 -
   31.81 -(*** The equivalance of two versions of an iteration function       ***)
   31.82 -(*                                                                    *)
   31.83 -(*        fun iter1(f,a) = a$iter1(f,f(a))                            *)
   31.84 -(*        fun iter2(f,a) = a$map(f,iter2(f,a))                        *)
   31.85 -
   31.86 -Goalw [iter1_def] "iter1(f,a) = a$iter1(f,f(a))";
   31.87 -by (rtac (letrecB RS trans) 1);
   31.88 -by (simp_tac term_ss 1);
   31.89 -qed "iter1B";
   31.90 -
   31.91 -Goalw [iter2_def] "iter2(f,a) = a $ map(f,iter2(f,a))";
   31.92 -by (rtac (letrecB RS trans) 1);
   31.93 -by (rtac refl 1);
   31.94 -qed "iter2B";
   31.95 -
   31.96 -val [prem] =goal (the_context ())
   31.97 -   "n:Nat ==> \
   31.98 -\   map(f) ^ n ` iter2(f,a) = (f ^ n ` a) $ (map(f) ^ n ` map(f,iter2(f,a)))";
   31.99 -by (res_inst_tac [("P", "%x. ?lhs(x) = ?rhs")] (iter2B RS ssubst) 1);
  31.100 -by (simp_tac (list_ss addsimps [prem RS nmapBcons]) 1);
  31.101 -qed "iter2Blemma";
  31.102 -
  31.103 -Goal "iter1(f,a) = iter2(f,a)";
  31.104 -by (eq_coinduct3_tac
  31.105 -    "{p. EX x y. p=<x,y> & (EX n:Nat. x=iter1(f,f^n`a) & y=map(f)^n`iter2(f,a))}"
  31.106 -    1);
  31.107 -by (fast_tac (type_cs addSIs [napplyBzero RS sym,
  31.108 -                              napplyBzero RS sym RS arg_cong]) 1);
  31.109 -by (EQgen_tac list_ss [iter1B,iter2Blemma] 1);
  31.110 -by (stac napply_f 1 THEN atac 1);
  31.111 -by (res_inst_tac [("f1","f")] (napplyBsucc RS subst) 1);
  31.112 -by (fast_tac type_cs 1);
  31.113 -qed "iter1_iter2_eq";
    32.1 --- a/src/CCL/ex/Stream.thy	Mon Jul 17 18:42:38 2006 +0200
    32.2 +++ b/src/CCL/ex/Stream.thy	Tue Jul 18 02:22:38 2006 +0200
    32.3 @@ -19,6 +19,127 @@
    32.4    iter1_def:   "iter1(f,a) == letrec iter x be x$iter(f(x)) in iter(a)"
    32.5    iter2_def:   "iter2(f,a) == letrec iter x be x$map(f,iter(x)) in iter(a)"
    32.6  
    32.7 -ML {* use_legacy_bindings (the_context ()) *}
    32.8 +
    32.9 +(*
   32.10 +Proving properties about infinite lists using coinduction:
   32.11 +    Lists(A)  is the set of all finite and infinite lists of elements of A.
   32.12 +    ILists(A) is the set of infinite lists of elements of A.
   32.13 +*)
   32.14 +
   32.15 +
   32.16 +subsection {* Map of composition is composition of maps *}
   32.17 +
   32.18 +lemma map_comp:
   32.19 +  assumes 1: "l:Lists(A)"
   32.20 +  shows "map(f o g,l) = map(f,map(g,l))"
   32.21 +  apply (tactic {* eq_coinduct3_tac
   32.22 +    "{p. EX x y. p=<x,y> & (EX l:Lists (A) .x=map (f o g,l) & y=map (f,map (g,l)))}" 1 *})
   32.23 +   apply (blast intro: 1)
   32.24 +  apply safe
   32.25 +  apply (drule ListsXH [THEN iffD1])
   32.26 +  apply (tactic "EQgen_tac (simpset ()) [] 1")
   32.27 +   apply fastsimp
   32.28 +  done
   32.29 +
   32.30 +(*** Mapping the identity function leaves a list unchanged ***)
   32.31 +
   32.32 +lemma map_id:
   32.33 +  assumes 1: "l:Lists(A)"
   32.34 +  shows "map(%x. x,l) = l"
   32.35 +  apply (tactic {* eq_coinduct3_tac
   32.36 +    "{p. EX x y. p=<x,y> & (EX l:Lists (A) .x=map (%x. x,l) & y=l) }" 1 *})
   32.37 +  apply (blast intro: 1)
   32.38 +  apply safe
   32.39 +  apply (drule ListsXH [THEN iffD1])
   32.40 +  apply (tactic "EQgen_tac (simpset ()) [] 1")
   32.41 +  apply blast
   32.42 +  done
   32.43 +
   32.44 +
   32.45 +subsection {* Mapping distributes over append *}
   32.46 +
   32.47 +lemma map_append:
   32.48 +  assumes "l:Lists(A)"
   32.49 +    and "m:Lists(A)"
   32.50 +  shows "map(f,l@m) = map(f,l) @ map(f,m)"
   32.51 +  apply (tactic {* eq_coinduct3_tac
   32.52 +    "{p. EX x y. p=<x,y> & (EX l:Lists (A). EX m:Lists (A). x=map (f,l@m) & y=map (f,l) @ map (f,m))}" 1 *})
   32.53 +  apply (blast intro: prems)
   32.54 +  apply safe
   32.55 +  apply (drule ListsXH [THEN iffD1])
   32.56 +  apply (tactic "EQgen_tac (simpset ()) [] 1")
   32.57 +  apply (drule ListsXH [THEN iffD1])
   32.58 +  apply (tactic "EQgen_tac (simpset ()) [] 1")
   32.59 +  apply blast
   32.60 +  done
   32.61 +
   32.62 +
   32.63 +subsection {* Append is associative *}
   32.64 +
   32.65 +lemma append_assoc:
   32.66 +  assumes "k:Lists(A)"
   32.67 +    and "l:Lists(A)"
   32.68 +    and "m:Lists(A)"
   32.69 +  shows "k @ l @ m = (k @ l) @ m"
   32.70 +  apply (tactic {* eq_coinduct3_tac
   32.71 +    "{p. EX x y. p=<x,y> & (EX k:Lists (A). EX l:Lists (A). EX m:Lists (A). x=k @ l @ m & y= (k @ l) @ m) }" 1*})
   32.72 +  apply (blast intro: prems)
   32.73 +  apply safe
   32.74 +  apply (drule ListsXH [THEN iffD1])
   32.75 +  apply (tactic "EQgen_tac (simpset ()) [] 1")
   32.76 +   prefer 2
   32.77 +   apply blast
   32.78 +  apply (tactic {* DEPTH_SOLVE (etac (XH_to_E (thm "ListsXH")) 1
   32.79 +    THEN EQgen_tac (simpset ()) [] 1) *})
   32.80 +  done
   32.81 +
   32.82 +
   32.83 +subsection {* Appending anything to an infinite list doesn't alter it *}
   32.84 +
   32.85 +lemma ilist_append:
   32.86 +  assumes "l:ILists(A)"
   32.87 +  shows "l @ m = l"
   32.88 +  apply (tactic {* eq_coinduct3_tac
   32.89 +    "{p. EX x y. p=<x,y> & (EX l:ILists (A) .EX m. x=l@m & y=l)}" 1 *})
   32.90 +  apply (blast intro: prems)
   32.91 +  apply safe
   32.92 +  apply (drule IListsXH [THEN iffD1])
   32.93 +  apply (tactic "EQgen_tac (simpset ()) [] 1")
   32.94 +  apply blast
   32.95 +  done
   32.96 +
   32.97 +(*** The equivalance of two versions of an iteration function       ***)
   32.98 +(*                                                                    *)
   32.99 +(*        fun iter1(f,a) = a$iter1(f,f(a))                            *)
  32.100 +(*        fun iter2(f,a) = a$map(f,iter2(f,a))                        *)
  32.101 +
  32.102 +lemma iter1B: "iter1(f,a) = a$iter1(f,f(a))"
  32.103 +  apply (unfold iter1_def)
  32.104 +  apply (rule letrecB [THEN trans])
  32.105 +  apply simp
  32.106 +  done
  32.107 +
  32.108 +lemma iter2B: "iter2(f,a) = a $ map(f,iter2(f,a))"
  32.109 +  apply (unfold iter2_def)
  32.110 +  apply (rule letrecB [THEN trans])
  32.111 +  apply (rule refl)
  32.112 +  done
  32.113 +
  32.114 +lemma iter2Blemma:
  32.115 +  "n:Nat ==>  
  32.116 +    map(f) ^ n ` iter2(f,a) = (f ^ n ` a) $ (map(f) ^ n ` map(f,iter2(f,a)))"
  32.117 +  apply (rule_tac P = "%x. ?lhs (x) = ?rhs" in iter2B [THEN ssubst])
  32.118 +  apply (simp add: nmapBcons)
  32.119 +  done
  32.120 +
  32.121 +lemma iter1_iter2_eq: "iter1(f,a) = iter2(f,a)"
  32.122 +  apply (tactic {* eq_coinduct3_tac
  32.123 +    "{p. EX x y. p=<x,y> & (EX n:Nat. x=iter1 (f,f^n`a) & y=map (f) ^n`iter2 (f,a))}" 1*})
  32.124 +  apply (fast intro!: napplyBzero [symmetric] napplyBzero [symmetric, THEN arg_cong])
  32.125 +  apply (tactic {* EQgen_tac (simpset ()) [thm "iter1B", thm "iter2Blemma"] 1 *})
  32.126 +  apply (subst napply_f, assumption)
  32.127 +  apply (rule_tac f1 = f in napplyBsucc [THEN subst])
  32.128 +  apply blast
  32.129 +  done
  32.130  
  32.131  end
    33.1 --- a/src/CCL/genrec.ML	Mon Jul 17 18:42:38 2006 +0200
    33.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    33.3 @@ -1,165 +0,0 @@
    33.4 -(*  Title:      CCL/genrec.ML
    33.5 -    ID:         $Id$
    33.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    33.7 -    Copyright   1993  University of Cambridge
    33.8 -
    33.9 -*)
   33.10 -
   33.11 -(*** General Recursive Functions ***)
   33.12 -
   33.13 -val major::prems = goal (the_context ())
   33.14 -    "[| a : A;  \
   33.15 -\       !!p g.[| p:A; ALL x:{x: A. <x,p>:wf(R)}. g(x) : D(x) |] ==>\
   33.16 -\               h(p,g) : D(p) |] ==> \
   33.17 -\    letrec g x be h(x,g) in g(a) : D(a)";
   33.18 -by (rtac (major RS rev_mp) 1);
   33.19 -by (rtac (wf_wf RS wfd_induct) 1);
   33.20 -by (stac letrecB 1);
   33.21 -by (rtac impI 1);
   33.22 -by (eresolve_tac prems 1);
   33.23 -by (rtac ballI 1);
   33.24 -by (etac (spec RS mp RS mp) 1);
   33.25 -by (REPEAT (eresolve_tac [SubtypeD1,SubtypeD2] 1));
   33.26 -qed "letrecT";
   33.27 -
   33.28 -goalw (the_context ()) [SPLIT_def] "SPLIT(<a,b>,B) = B(a,b)";
   33.29 -by (rtac set_ext 1);
   33.30 -by (fast_tac ccl_cs 1);
   33.31 -qed "SPLITB";
   33.32 -
   33.33 -val prems = goalw (the_context ()) [letrec2_def]
   33.34 -    "[| a : A;  b : B;  \
   33.35 -\     !!p q g.[| p:A; q:B; \
   33.36 -\             ALL x:A. ALL y:{y: B. <<x,y>,<p,q>>:wf(R)}. g(x,y) : D(x,y) |] ==>\
   33.37 -\               h(p,q,g) : D(p,q) |] ==> \
   33.38 -\    letrec g x y be h(x,y,g) in g(a,b) : D(a,b)";
   33.39 -by (rtac (SPLITB RS subst) 1);
   33.40 -by (REPEAT (ares_tac ([letrecT,pairT,splitT]@prems) 1));
   33.41 -by (stac SPLITB 1);
   33.42 -by (REPEAT (ares_tac ([ballI,SubtypeI]@prems) 1));
   33.43 -by (rtac (SPLITB RS subst) 1);
   33.44 -by (REPEAT (ares_tac ([letrecT,SubtypeI,pairT,splitT]@prems) 1 ORELSE
   33.45 -            eresolve_tac [bspec,SubtypeE,sym RS subst] 1));
   33.46 -qed "letrec2T";
   33.47 -
   33.48 -goal (the_context ()) "SPLIT(<a,<b,c>>,%x xs. SPLIT(xs,%y z. B(x,y,z))) = B(a,b,c)";
   33.49 -by (simp_tac (ccl_ss addsimps [SPLITB]) 1);
   33.50 -qed "lemma";
   33.51 -
   33.52 -val prems = goalw (the_context ()) [letrec3_def]
   33.53 -    "[| a : A;  b : B;  c : C;  \
   33.54 -\    !!p q r g.[| p:A; q:B; r:C; \
   33.55 -\      ALL x:A. ALL y:B. ALL z:{z:C. <<x,<y,z>>,<p,<q,r>>> : wf(R)}. \
   33.56 -\                                                       g(x,y,z) : D(x,y,z) |] ==>\
   33.57 -\               h(p,q,r,g) : D(p,q,r) |] ==> \
   33.58 -\    letrec g x y z be h(x,y,z,g) in g(a,b,c) : D(a,b,c)";
   33.59 -by (rtac (lemma RS subst) 1);
   33.60 -by (REPEAT (ares_tac ([letrecT,pairT,splitT]@prems) 1));
   33.61 -by (simp_tac (ccl_ss addsimps [SPLITB]) 1);
   33.62 -by (REPEAT (ares_tac ([ballI,SubtypeI]@prems) 1));
   33.63 -by (rtac (lemma RS subst) 1);
   33.64 -by (REPEAT (ares_tac ([letrecT,SubtypeI,pairT,splitT]@prems) 1 ORELSE
   33.65 -            eresolve_tac [bspec,SubtypeE,sym RS subst] 1));
   33.66 -qed "letrec3T";
   33.67 -
   33.68 -val letrecTs = [letrecT,letrec2T,letrec3T];
   33.69 -
   33.70 -
   33.71 -(*** Type Checking for Recursive Calls ***)
   33.72 -
   33.73 -val major::prems = goal (the_context ())
   33.74 -    "[| ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x); \
   33.75 -\       g(a) : D(a) ==> g(a) : E;  a:A;  <a,p>:wf(R) |] ==> \
   33.76 -\   g(a) : E";
   33.77 -by (REPEAT (ares_tac ([SubtypeI,major RS bspec,major]@prems) 1));
   33.78 -qed "rcallT";
   33.79 -
   33.80 -val major::prems = goal (the_context ())
   33.81 -    "[| ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y); \
   33.82 -\       g(a,b) : D(a,b) ==> g(a,b) : E;  a:A;  b:B;  <<a,b>,<p,q>>:wf(R) |] ==> \
   33.83 -\   g(a,b) : E";
   33.84 -by (REPEAT (ares_tac ([SubtypeI,major RS bspec RS bspec,major]@prems) 1));
   33.85 -qed "rcall2T";
   33.86 -
   33.87 -val major::prems = goal (the_context ())
   33.88 -    "[| ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}. g(x,y,z):D(x,y,z); \
   33.89 -\       g(a,b,c) : D(a,b,c) ==> g(a,b,c) : E;  \
   33.90 -\       a:A;  b:B;  c:C;  <<a,<b,c>>,<p,<q,r>>> : wf(R) |] ==> \
   33.91 -\   g(a,b,c) : E";
   33.92 -by (REPEAT (ares_tac ([SubtypeI,major RS bspec RS bspec RS bspec,major]@prems) 1));
   33.93 -qed "rcall3T";
   33.94 -
   33.95 -val rcallTs = [rcallT,rcall2T,rcall3T];
   33.96 -
   33.97 -(*** Instantiating an induction hypothesis with an equality assumption ***)
   33.98 -
   33.99 -val prems = goal (the_context ())
  33.100 -    "[| g(a) = b; ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x);  \
  33.101 -\       [| ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x);  b=g(a);  g(a) : D(a) |] ==> P; \
  33.102 -\       ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) ==> a:A;  \
  33.103 -\       ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) ==> <a,p>:wf(R) |] ==> \
  33.104 -\   P";
  33.105 -by (resolve_tac (prems RL prems) 1);
  33.106 -by (resolve_tac (prems RL [sym]) 1);
  33.107 -by (rtac rcallT 1);
  33.108 -by (REPEAT (ares_tac prems 1));
  33.109 -val hyprcallT = result();
  33.110 -
  33.111 -val prems = goal (the_context ())
  33.112 -    "[| g(a) = b; ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x);\
  33.113 -\       [| b=g(a);  g(a) : D(a) |] ==> P; a:A;  <a,p>:wf(R) |] ==> \
  33.114 -\   P";
  33.115 -by (resolve_tac (prems) 1);
  33.116 -by (resolve_tac (prems RL [sym]) 1);
  33.117 -by (rtac rcallT 1);
  33.118 -by (REPEAT (ares_tac prems 1));
  33.119 -qed "hyprcallT";
  33.120 -
  33.121 -val prems = goal (the_context ())
  33.122 -    "[| g(a,b) = c; ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y); \
  33.123 -\       [| c=g(a,b);  g(a,b) : D(a,b) |] ==> P; \
  33.124 -\       a:A;  b:B;  <<a,b>,<p,q>>:wf(R) |] ==> \
  33.125 -\   P";
  33.126 -by (resolve_tac (prems) 1);
  33.127 -by (resolve_tac (prems RL [sym]) 1);
  33.128 -by (rtac rcall2T 1);
  33.129 -by (REPEAT (ares_tac prems 1));
  33.130 -qed "hyprcall2T";
  33.131 -
  33.132 -val prems = goal (the_context ())
  33.133 -  "[| g(a,b,c) = d; \
  33.134 -\     ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}.g(x,y,z):D(x,y,z); \
  33.135 -\   [| d=g(a,b,c);  g(a,b,c) : D(a,b,c) |] ==> P; \
  33.136 -\   a:A;  b:B;  c:C;  <<a,<b,c>>,<p,<q,r>>> : wf(R) |] ==> \
  33.137 -\   P";
  33.138 -by (resolve_tac (prems) 1);
  33.139 -by (resolve_tac (prems RL [sym]) 1);
  33.140 -by (rtac rcall3T 1);
  33.141 -by (REPEAT (ares_tac prems 1));
  33.142 -qed "hyprcall3T";
  33.143 -
  33.144 -val hyprcallTs = [hyprcallT,hyprcall2T,hyprcall3T];
  33.145 -
  33.146 -(*** Rules to Remove Induction Hypotheses after Type Checking ***)
  33.147 -
  33.148 -val prems = goal (the_context ())
  33.149 -    "[| ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x); P |] ==> \
  33.150 -\    P";
  33.151 -by (REPEAT (ares_tac prems 1));
  33.152 -qed "rmIH1";
  33.153 -
  33.154 -val prems = goal (the_context ())
  33.155 -    "[| ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y); P |] ==> \
  33.156 -\    P";
  33.157 -by (REPEAT (ares_tac prems 1));
  33.158 -qed "rmIH2";
  33.159 -
  33.160 -val prems = goal (the_context ())
  33.161 - "[| ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}.g(x,y,z):D(x,y,z); \
  33.162 -\    P |] ==> \
  33.163 -\    P";
  33.164 -by (REPEAT (ares_tac prems 1));
  33.165 -qed "rmIH3";
  33.166 -
  33.167 -val rmIHs = [rmIH1,rmIH2,rmIH3];
  33.168 -
    34.1 --- a/src/CCL/mono.ML	Mon Jul 17 18:42:38 2006 +0200
    34.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    34.3 @@ -1,39 +0,0 @@
    34.4 -(*  Title:      CCL/mono.ML
    34.5 -    ID:         $Id$
    34.6 -
    34.7 -Monotonicity of various operations.
    34.8 -*)
    34.9 -
   34.10 -val prems = goal (the_context ()) "A<=B ==> Union(A) <= Union(B)";
   34.11 -by (cfast_tac prems 1);
   34.12 -qed "Union_mono";
   34.13 -
   34.14 -val prems = goal (the_context ()) "[| B<=A |] ==> Inter(A) <= Inter(B)";
   34.15 -by (cfast_tac prems 1);
   34.16 -qed "Inter_anti_mono";
   34.17 -
   34.18 -val prems = goal (the_context ())
   34.19 -    "[| A<=B;  !!x. x:A ==> f(x)<=g(x) |] ==> \
   34.20 -\    (UN x:A. f(x)) <= (UN x:B. g(x))";
   34.21 -by (REPEAT (eresolve_tac [UN_E,ssubst] 1
   34.22 -     ORELSE ares_tac ((prems RL [subsetD]) @ [subsetI,UN_I]) 1));
   34.23 -qed "UN_mono";
   34.24 -
   34.25 -val prems = goal (the_context ())
   34.26 -    "[| B<=A;  !!x. x:A ==> f(x)<=g(x) |] ==> \
   34.27 -\    (INT x:A. f(x)) <= (INT x:A. g(x))";
   34.28 -by (REPEAT (ares_tac ((prems RL [subsetD]) @ [subsetI,INT_I]) 1
   34.29 -     ORELSE etac INT_D 1));
   34.30 -qed "INT_anti_mono";
   34.31 -
   34.32 -val prems = goal (the_context ()) "[| A<=C;  B<=D |] ==> A Un B <= C Un D";
   34.33 -by (cfast_tac prems 1);
   34.34 -qed "Un_mono";
   34.35 -
   34.36 -val prems = goal (the_context ()) "[| A<=C;  B<=D |] ==> A Int B <= C Int D";
   34.37 -by (cfast_tac prems 1);
   34.38 -qed "Int_mono";
   34.39 -
   34.40 -val prems = goal (the_context ()) "[| A<=B |] ==> Compl(B) <= Compl(A)";
   34.41 -by (cfast_tac prems 1);
   34.42 -qed "Compl_anti_mono";
    35.1 --- a/src/CCL/subset.ML	Mon Jul 17 18:42:38 2006 +0200
    35.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    35.3 @@ -1,118 +0,0 @@
    35.4 -(*  Title:      CCL/subsetI
    35.5 -    ID:         $Id$
    35.6 -
    35.7 -Derived rules involving subsets.
    35.8 -Union and Intersection as lattice operations.
    35.9 -*)
   35.10 -
   35.11 -(*** Big Union -- least upper bound of a set  ***)
   35.12 -
   35.13 -val prems = goal (the_context ())
   35.14 -    "B:A ==> B <= Union(A)";
   35.15 -by (REPEAT (ares_tac (prems@[subsetI,UnionI]) 1));
   35.16 -qed "Union_upper";
   35.17 -
   35.18 -val prems = goal (the_context ())
   35.19 -    "[| !!X. X:A ==> X<=C |] ==> Union(A) <= C";
   35.20 -by (REPEAT (ares_tac [subsetI] 1
   35.21 -     ORELSE eresolve_tac ([UnionE] @ (prems RL [subsetD])) 1));
   35.22 -qed "Union_least";
   35.23 -
   35.24 -
   35.25 -(*** Big Intersection -- greatest lower bound of a set ***)
   35.26 -
   35.27 -val prems = goal (the_context ())
   35.28 -    "B:A ==> Inter(A) <= B";
   35.29 -by (REPEAT (resolve_tac (prems@[subsetI]) 1
   35.30 -     ORELSE etac InterD 1));
   35.31 -qed "Inter_lower";
   35.32 -
   35.33 -val prems = goal (the_context ())
   35.34 -    "[| !!X. X:A ==> C<=X |] ==> C <= Inter(A)";
   35.35 -by (REPEAT (ares_tac [subsetI,InterI] 1
   35.36 -     ORELSE eresolve_tac (prems RL [subsetD]) 1));
   35.37 -qed "Inter_greatest";
   35.38 -
   35.39 -(*** Finite Union -- the least upper bound of 2 sets ***)
   35.40 -
   35.41 -goal (the_context ()) "A <= A Un B";
   35.42 -by (REPEAT (ares_tac [subsetI,UnI1] 1));
   35.43 -qed "Un_upper1";
   35.44 -
   35.45 -goal (the_context ()) "B <= A Un B";
   35.46 -by (REPEAT (ares_tac [subsetI,UnI2] 1));
   35.47 -qed "Un_upper2";
   35.48 -
   35.49 -val prems = goal (the_context ()) "[| A<=C;  B<=C |] ==> A Un B <= C";
   35.50 -by (cut_facts_tac prems 1);
   35.51 -by (DEPTH_SOLVE (ares_tac [subsetI] 1 
   35.52 -          ORELSE eresolve_tac [UnE,subsetD] 1));
   35.53 -qed "Un_least";
   35.54 -
   35.55 -(*** Finite Intersection -- the greatest lower bound of 2 sets *)
   35.56 -
   35.57 -goal (the_context ()) "A Int B <= A";
   35.58 -by (REPEAT (ares_tac [subsetI] 1 ORELSE etac IntE 1));
   35.59 -qed "Int_lower1";
   35.60 -
   35.61 -goal (the_context ()) "A Int B <= B";
   35.62 -by (REPEAT (ares_tac [subsetI] 1 ORELSE etac IntE 1));
   35.63 -qed "Int_lower2";
   35.64 -
   35.65 -val prems = goal (the_context ()) "[| C<=A;  C<=B |] ==> C <= A Int B";
   35.66 -by (cut_facts_tac prems 1);
   35.67 -by (REPEAT (ares_tac [subsetI,IntI] 1
   35.68 -     ORELSE etac subsetD 1));
   35.69 -qed "Int_greatest";
   35.70 -
   35.71 -(*** Monotonicity ***)
   35.72 -
   35.73 -val [prem] = goalw (the_context ()) [mono_def]
   35.74 -    "[| !!A B. A <= B ==> f(A) <= f(B) |] ==> mono(f)";
   35.75 -by (REPEAT (ares_tac [allI, impI, prem] 1));
   35.76 -qed "monoI";
   35.77 -
   35.78 -val [major,minor] = goalw (the_context ()) [mono_def]
   35.79 -    "[| mono(f);  A <= B |] ==> f(A) <= f(B)";
   35.80 -by (rtac (major RS spec RS spec RS mp) 1);
   35.81 -by (rtac minor 1);
   35.82 -qed "monoD";
   35.83 -
   35.84 -val [prem] = goal (the_context ()) "mono(f) ==> f(A) Un f(B) <= f(A Un B)";
   35.85 -by (rtac Un_least 1);
   35.86 -by (rtac (Un_upper1 RS (prem RS monoD)) 1);
   35.87 -by (rtac (Un_upper2 RS (prem RS monoD)) 1);
   35.88 -qed "mono_Un";
   35.89 -
   35.90 -val [prem] = goal (the_context ()) "mono(f) ==> f(A Int B) <= f(A) Int f(B)";
   35.91 -by (rtac Int_greatest 1);
   35.92 -by (rtac (Int_lower1 RS (prem RS monoD)) 1);
   35.93 -by (rtac (Int_lower2 RS (prem RS monoD)) 1);
   35.94 -qed "mono_Int";
   35.95 -
   35.96 -(****)
   35.97 -
   35.98 -val set_cs = FOL_cs 
   35.99 -    addSIs [ballI, subsetI, InterI, INT_I, CollectI, 
  35.100 -            ComplI, IntI, UnCI, singletonI] 
  35.101 -    addIs  [bexI, UnionI, UN_I] 
  35.102 -    addSEs [bexE, UnionE, UN_E,
  35.103 -            CollectE, ComplE, IntE, UnE, emptyE, singletonE] 
  35.104 -    addEs  [ballE, InterD, InterE, INT_D, INT_E, subsetD, subsetCE];
  35.105 -
  35.106 -fun cfast_tac prems = cut_facts_tac prems THEN' fast_tac set_cs;
  35.107 -
  35.108 -fun prover s = prove_goal (the_context ()) s (fn _=>[fast_tac set_cs 1]);
  35.109 -
  35.110 -val mem_rews = [trivial_set,empty_eq] @ (map prover
  35.111 - [ "(a : A Un B)   <->  (a:A | a:B)",
  35.112 -   "(a : A Int B)  <->  (a:A & a:B)",
  35.113 -   "(a : Compl(B)) <->  (~a:B)",
  35.114 -   "(a : {b})      <->  (a=b)",
  35.115 -   "(a : {})       <->   False",
  35.116 -   "(a : {x. P(x)}) <->  P(a)" ]);
  35.117 -
  35.118 -val set_congs = [ball_cong, bex_cong, INT_cong, UN_cong];
  35.119 -
  35.120 -val set_ss = FOL_ss addcongs set_congs
  35.121 -                    addsimps mem_rews;
    36.1 --- a/src/CCL/typecheck.ML	Mon Jul 17 18:42:38 2006 +0200
    36.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    36.3 @@ -1,134 +0,0 @@
    36.4 -(*  Title:      CCL/typecheck.ML
    36.5 -    ID:         $Id$
    36.6 -    Author:     Martin Coen, Cambridge University Computer Laboratory
    36.7 -    Copyright   1993  University of Cambridge
    36.8 -*)
    36.9 -
   36.10 -(*** Lemmas for constructors and subtypes ***)
   36.11 -
   36.12 -(* 0-ary constructors do not need additional rules as they are handled *)
   36.13 -(*                                      correctly by applying SubtypeI *)
   36.14 -(*
   36.15 -val Subtype_canTs =
   36.16 -       let fun tac prems = cut_facts_tac prems 1 THEN
   36.17 -                REPEAT (ares_tac (SubtypeI::canTs@icanTs) 1 ORELSE
   36.18 -                        etac SubtypeE 1)
   36.19 -           fun solve s = prove_goal (the_context ()) s (fn prems => [tac prems])
   36.20 -       in map solve
   36.21 -           ["P(one) ==> one : {x:Unit.P(x)}",
   36.22 -            "P(true) ==> true : {x:Bool.P(x)}",
   36.23 -            "P(false) ==> false : {x:Bool.P(x)}",
   36.24 -            "a : {x:A. b:{y:B(a).P(<x,y>)}} ==> <a,b> : {x:Sigma(A,B).P(x)}",
   36.25 -            "a : {x:A.P(inl(x))} ==> inl(a) : {x:A+B.P(x)}",
   36.26 -            "b : {x:B.P(inr(x))} ==> inr(b) : {x:A+B.P(x)}",
   36.27 -            "P(zero) ==> zero : {x:Nat.P(x)}",
   36.28 -            "a : {x:Nat.P(succ(x))} ==> succ(a) : {x:Nat.P(x)}",
   36.29 -            "P([]) ==> [] : {x:List(A).P(x)}",
   36.30 -            "h : {x:A. t : {y:List(A).P(x$y)}} ==> h$t : {x:List(A).P(x)}"
   36.31 -        ] end;
   36.32 -*)
   36.33 -val Subtype_canTs =
   36.34 -       let fun tac prems = cut_facts_tac prems 1 THEN
   36.35 -                REPEAT (ares_tac (SubtypeI::canTs@icanTs) 1 ORELSE
   36.36 -                        etac SubtypeE 1)
   36.37 -           fun solve s = prove_goal (the_context ()) s (fn prems => [tac prems])
   36.38 -       in map solve
   36.39 -           ["a : {x:A. b:{y:B(a).P(<x,y>)}} ==> <a,b> : {x:Sigma(A,B).P(x)}",
   36.40 -            "a : {x:A. P(inl(x))} ==> inl(a) : {x:A+B. P(x)}",
   36.41 -            "b : {x:B. P(inr(x))} ==> inr(b) : {x:A+B. P(x)}",
   36.42 -            "a : {x:Nat. P(succ(x))} ==> succ(a) : {x:Nat. P(x)}",
   36.43 -            "h : {x:A. t : {y:List(A).P(x$y)}} ==> h$t : {x:List(A).P(x)}"
   36.44 -        ] end;
   36.45 -
   36.46 -val prems = goal (the_context ())
   36.47 -     "[| f(t):B;  ~t=bot  |] ==> let x be t in f(x) : B";
   36.48 -by (cut_facts_tac prems 1);
   36.49 -by (etac (letB RS ssubst) 1);
   36.50 -by (assume_tac 1);
   36.51 -qed "letT";
   36.52 -
   36.53 -val prems = goal (the_context ())
   36.54 -     "[| a:A;  f : Pi(A,B)  |] ==> f ` a  : B(a)";
   36.55 -by (REPEAT (ares_tac (applyT::prems) 1));
   36.56 -qed "applyT2";
   36.57 -
   36.58 -val prems = goal (the_context ())
   36.59 -    "[| a:A;  a:A ==> P(a) |] ==> a : {x:A. P(x)}";
   36.60 -by (fast_tac (type_cs addSIs prems) 1);
   36.61 -qed "rcall_lemma1";
   36.62 -
   36.63 -val prems = goal (the_context ())
   36.64 -    "[| a:{x:A. Q(x)};  [| a:A; Q(a) |] ==> P(a) |] ==> a : {x:A. P(x)}";
   36.65 -by (cut_facts_tac prems 1);
   36.66 -by (fast_tac (type_cs addSIs prems) 1);
   36.67 -qed "rcall_lemma2";
   36.68 -
   36.69 -val rcall_lemmas = [asm_rl,rcall_lemma1,SubtypeD1,rcall_lemma2];
   36.70 -
   36.71 -(***********************************TYPECHECKING*************************************)
   36.72 -
   36.73 -fun bvars (Const("all",_) $ Abs(s,_,t)) l = bvars t (s::l)
   36.74 -  | bvars _ l = l;
   36.75 -
   36.76 -fun get_bno l n (Const("all",_) $ Abs(s,_,t)) = get_bno (s::l) n t
   36.77 -  | get_bno l n (Const("Trueprop",_) $ t) = get_bno l n t
   36.78 -  | get_bno l n (Const("Ball",_) $ _ $ Abs(s,_,t)) = get_bno (s::l) (n+1) t
   36.79 -  | get_bno l n (Const("op :",_) $ t $ _) = get_bno l n t
   36.80 -  | get_bno l n (t $ s) = get_bno l n t
   36.81 -  | get_bno l n (Bound m) = (m-length(l),n);
   36.82 -
   36.83 -(* Not a great way of identifying induction hypothesis! *)
   36.84 -fun could_IH x = could_unify(x,hd (prems_of rcallT)) orelse
   36.85 -                 could_unify(x,hd (prems_of rcall2T)) orelse
   36.86 -                 could_unify(x,hd (prems_of rcall3T));
   36.87 -
   36.88 -fun IHinst tac rls = SUBGOAL (fn (Bi,i) =>
   36.89 -  let val bvs = bvars Bi [];
   36.90 -      val ihs = List.filter could_IH (Logic.strip_assums_hyp Bi);
   36.91 -      val rnames = map (fn x=>
   36.92 -                    let val (a,b) = get_bno [] 0 x
   36.93 -                    in (List.nth(bvs,a),b) end) ihs;
   36.94 -      fun try_IHs [] = no_tac
   36.95 -        | try_IHs ((x,y)::xs) = tac [("g",x)] (List.nth(rls,y-1)) i ORELSE (try_IHs xs);
   36.96 -  in try_IHs rnames end);
   36.97 -
   36.98 -(*****)
   36.99 -
  36.100 -val type_rls = canTs@icanTs@(applyT2::ncanTs)@incanTs@
  36.101 -               precTs@letrecTs@[letT]@Subtype_canTs;
  36.102 -
  36.103 -fun is_rigid_prog t =
  36.104 -     case (Logic.strip_assums_concl t) of
  36.105 -        (Const("Trueprop",_) $ (Const("op :",_) $ a $ _)) => (term_vars a = [])
  36.106 -       | _ => false;
  36.107 -
  36.108 -fun rcall_tac i = let fun tac ps rl i = res_inst_tac ps rl i THEN atac i;
  36.109 -                       in IHinst tac rcallTs i end THEN
  36.110 -                  eresolve_tac rcall_lemmas i;
  36.111 -
  36.112 -fun raw_step_tac prems i = ares_tac (prems@type_rls) i ORELSE
  36.113 -                           rcall_tac i ORELSE
  36.114 -                           ematch_tac [SubtypeE] i ORELSE
  36.115 -                           match_tac [SubtypeI] i;
  36.116 -
  36.117 -fun tc_step_tac prems = SUBGOAL (fn (Bi,i) =>
  36.118 -          if is_rigid_prog Bi then raw_step_tac prems i else no_tac);
  36.119 -
  36.120 -fun typechk_tac rls i = SELECT_GOAL (REPEAT_FIRST (tc_step_tac rls)) i;
  36.121 -
  36.122 -val tac = typechk_tac [] 1;
  36.123 -
  36.124 -
  36.125 -(*** Clean up Correctness Condictions ***)
  36.126 -
  36.127 -val clean_ccs_tac = REPEAT_FIRST (eresolve_tac ([SubtypeE]@rmIHs) ORELSE'
  36.128 -                                 hyp_subst_tac);
  36.129 -
  36.130 -val clean_ccs_tac =
  36.131 -       let fun tac ps rl i = eres_inst_tac ps rl i THEN atac i;
  36.132 -       in TRY (REPEAT_FIRST (IHinst tac hyprcallTs ORELSE'
  36.133 -                       eresolve_tac ([asm_rl,SubtypeE]@rmIHs) ORELSE'
  36.134 -                       hyp_subst_tac)) end;
  36.135 -
  36.136 -fun gen_ccs_tac rls i = SELECT_GOAL (REPEAT_FIRST (tc_step_tac rls) THEN
  36.137 -                                     clean_ccs_tac) i;
    37.1 --- a/src/CCL/wfd.ML	Mon Jul 17 18:42:38 2006 +0200
    37.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    37.3 @@ -1,193 +0,0 @@
    37.4 -(*  Title:      CCL/Wfd.ML
    37.5 -    ID:         $Id$
    37.6 -*)
    37.7 -
    37.8 -(***********)
    37.9 -
   37.10 -val [major,prem] = goalw (the_context ()) [Wfd_def]
   37.11 -    "[| Wfd(R);       \
   37.12 -\       !!x.[| ALL y. <y,x>: R --> P(y) |] ==> P(x) |]  ==>  \
   37.13 -\    P(a)";
   37.14 -by (rtac (major RS spec RS mp RS spec RS CollectD) 1);
   37.15 -by (fast_tac (set_cs addSIs [prem RS CollectI]) 1);
   37.16 -qed "wfd_induct";
   37.17 -
   37.18 -val [p1,p2,p3] = goal (the_context ())
   37.19 -    "[| !!x y.<x,y> : R ==> Q(x); \
   37.20 -\       ALL x. (ALL y. <y,x> : R --> y : P) --> x : P; \
   37.21 -\       !!x. Q(x) ==> x:P |] ==> a:P";
   37.22 -by (rtac (p2 RS  spec  RS mp) 1);
   37.23 -by (fast_tac (set_cs addSIs [p1 RS p3]) 1);
   37.24 -qed "wfd_strengthen_lemma";
   37.25 -
   37.26 -fun wfd_strengthen_tac s i = res_inst_tac [("Q",s)] wfd_strengthen_lemma i THEN
   37.27 -                             assume_tac (i+1);
   37.28 -
   37.29 -val wfd::prems = goal (the_context ()) "[| Wfd(r);  <a,x>:r;  <x,a>:r |] ==> P";
   37.30 -by (subgoal_tac "ALL x. <a,x>:r --> <x,a>:r --> P" 1);
   37.31 -by (fast_tac (FOL_cs addIs prems) 1);
   37.32 -by (rtac (wfd RS  wfd_induct) 1);
   37.33 -by (ALLGOALS (fast_tac (ccl_cs addSIs prems)));
   37.34 -qed "wf_anti_sym";
   37.35 -
   37.36 -val prems = goal (the_context ()) "[| Wfd(r);  <a,a>: r |] ==> P";
   37.37 -by (rtac wf_anti_sym 1);
   37.38 -by (REPEAT (resolve_tac prems 1));
   37.39 -qed "wf_anti_refl";
   37.40 -
   37.41 -(*** Irreflexive transitive closure ***)
   37.42 -
   37.43 -val [prem] = goal (the_context ()) "Wfd(R) ==> Wfd(R^+)";
   37.44 -by (rewtac Wfd_def);
   37.45 -by (REPEAT (ares_tac [allI,ballI,impI] 1));
   37.46 -(*must retain the universal formula for later use!*)
   37.47 -by (rtac allE 1 THEN assume_tac 1);
   37.48 -by (etac mp 1);
   37.49 -by (rtac (prem RS wfd_induct) 1);
   37.50 -by (rtac (impI RS allI) 1);
   37.51 -by (etac tranclE 1);
   37.52 -by (fast_tac ccl_cs 1);
   37.53 -by (etac (spec RS mp RS spec RS mp) 1);
   37.54 -by (REPEAT (atac 1));
   37.55 -qed "trancl_wf";
   37.56 -
   37.57 -(*** Lexicographic Ordering ***)
   37.58 -
   37.59 -Goalw [lex_def]
   37.60 - "p : ra**rb <-> (EX a a' b b'. p = <<a,b>,<a',b'>> & (<a,a'> : ra | a=a' & <b,b'> : rb))";
   37.61 -by (fast_tac ccl_cs 1);
   37.62 -qed "lexXH";
   37.63 -
   37.64 -val prems = goal (the_context ())
   37.65 - "<a,a'> : ra ==> <<a,b>,<a',b'>> : ra**rb";
   37.66 -by (fast_tac (ccl_cs addSIs (prems @ [lexXH RS iffD2])) 1);
   37.67 -qed "lexI1";
   37.68 -
   37.69 -val prems = goal (the_context ())
   37.70 - "<b,b'> : rb ==> <<a,b>,<a,b'>> : ra**rb";
   37.71 -by (fast_tac (ccl_cs addSIs (prems @ [lexXH RS iffD2])) 1);
   37.72 -qed "lexI2";
   37.73 -
   37.74 -val major::prems = goal (the_context ())
   37.75 - "[| p : ra**rb;  \
   37.76 -\    !!a a' b b'.[| <a,a'> : ra; p=<<a,b>,<a',b'>> |] ==> R;  \
   37.77 -\    !!a b b'.[| <b,b'> : rb;  p = <<a,b>,<a,b'>> |] ==> R  |] ==> \
   37.78 -\ R";
   37.79 -by (rtac (major RS (lexXH RS iffD1) RS exE) 1);
   37.80 -by (REPEAT_SOME (eresolve_tac ([exE,conjE,disjE]@prems)));
   37.81 -by (ALLGOALS (fast_tac ccl_cs));
   37.82 -qed "lexE";
   37.83 -
   37.84 -val [major,minor] = goal (the_context ())
   37.85 - "[| p : r**s;  !!a a' b b'. p = <<a,b>,<a',b'>> ==> P |] ==>P";
   37.86 -by (rtac (major RS lexE) 1);
   37.87 -by (ALLGOALS (fast_tac (set_cs addSEs [minor])));
   37.88 -qed "lex_pair";
   37.89 -
   37.90 -val [wfa,wfb] = goal (the_context ())
   37.91 - "[| Wfd(R); Wfd(S) |] ==> Wfd(R**S)";
   37.92 -by (rewtac Wfd_def);
   37.93 -by (safe_tac ccl_cs);
   37.94 -by (wfd_strengthen_tac "%x. EX a b. x=<a,b>" 1);
   37.95 -by (fast_tac (term_cs addSEs [lex_pair]) 1);
   37.96 -by (subgoal_tac "ALL a b.<a,b>:P" 1);
   37.97 -by (fast_tac ccl_cs 1);
   37.98 -by (rtac (wfa RS wfd_induct RS allI) 1);
   37.99 -by (rtac (wfb RS wfd_induct RS allI) 1);back();
  37.100 -by (fast_tac (type_cs addSEs [lexE]) 1);
  37.101 -qed "lex_wf";
  37.102 -
  37.103 -(*** Mapping ***)
  37.104 -
  37.105 -Goalw [wmap_def]
  37.106 - "p : wmap(f,r) <-> (EX x y. p=<x,y>  &  <f(x),f(y)> : r)";
  37.107 -by (fast_tac ccl_cs 1);
  37.108 -qed "wmapXH";
  37.109 -
  37.110 -val prems = goal (the_context ())
  37.111 - "<f(a),f(b)> : r ==> <a,b> : wmap(f,r)";
  37.112 -by (fast_tac (ccl_cs addSIs (prems @ [wmapXH RS iffD2])) 1);
  37.113 -qed "wmapI";
  37.114 -
  37.115 -val major::prems = goal (the_context ())
  37.116 - "[| p : wmap(f,r);  !!a b.[| <f(a),f(b)> : r;  p=<a,b> |] ==> R |] ==> R";
  37.117 -by (rtac (major RS (wmapXH RS iffD1) RS exE) 1);
  37.118 -by (REPEAT_SOME (eresolve_tac ([exE,conjE,disjE]@prems)));
  37.119 -by (ALLGOALS (fast_tac ccl_cs));
  37.120 -qed "wmapE";
  37.121 -
  37.122 -val [wf] = goal (the_context ())
  37.123 - "Wfd(r) ==> Wfd(wmap(f,r))";
  37.124 -by (rewtac Wfd_def);
  37.125 -by (safe_tac ccl_cs);
  37.126 -by (subgoal_tac "ALL b. ALL a. f(a)=b-->a:P" 1);
  37.127 -by (fast_tac ccl_cs 1);
  37.128 -by (rtac (wf RS wfd_induct RS allI) 1);
  37.129 -by (safe_tac ccl_cs);
  37.130 -by (etac (spec RS mp) 1);
  37.131 -by (safe_tac (ccl_cs addSEs [wmapE]));
  37.132 -by (etac (spec RS mp RS spec RS mp) 1);
  37.133 -by (assume_tac 1);
  37.134 -by (rtac refl 1);
  37.135 -qed "wmap_wf";
  37.136 -
  37.137 -(* Projections *)
  37.138 -
  37.139 -val prems = goal (the_context ()) "<xa,ya> : r ==> <<xa,xb>,<ya,yb>> : wmap(fst,r)";
  37.140 -by (rtac wmapI 1);
  37.141 -by (simp_tac (term_ss addsimps prems) 1);
  37.142 -qed "wfstI";
  37.143 -
  37.144 -val prems = goal (the_context ()) "<xb,yb> : r ==> <<xa,xb>,<ya,yb>> : wmap(snd,r)";
  37.145 -by (rtac wmapI 1);
  37.146 -by (simp_tac (term_ss addsimps prems) 1);
  37.147 -qed "wsndI";
  37.148 -
  37.149 -val prems = goal (the_context ()) "<xc,yc> : r ==> <<xa,<xb,xc>>,<ya,<yb,yc>>> : wmap(thd,r)";
  37.150 -by (rtac wmapI 1);
  37.151 -by (simp_tac (term_ss addsimps prems) 1);
  37.152 -qed "wthdI";
  37.153 -
  37.154 -(*** Ground well-founded relations ***)
  37.155 -
  37.156 -val prems = goalw (the_context ()) [wf_def]
  37.157 -    "[| Wfd(r);  a : r |] ==> a : wf(r)";
  37.158 -by (fast_tac (set_cs addSIs prems) 1);
  37.159 -qed "wfI";
  37.160 -
  37.161 -val prems = goalw (the_context ()) [Wfd_def] "Wfd({})";
  37.162 -by (fast_tac (set_cs addEs [EmptyXH RS iffD1 RS FalseE]) 1);
  37.163 -qed "Empty_wf";
  37.164 -
  37.165 -val prems = goalw (the_context ()) [wf_def] "Wfd(wf(R))";
  37.166 -by (res_inst_tac [("Q","Wfd(R)")] (excluded_middle RS disjE) 1);
  37.167 -by (ALLGOALS (asm_simp_tac CCL_ss));
  37.168 -by (rtac Empty_wf 1);
  37.169 -qed "wf_wf";
  37.170 -
  37.171 -Goalw [NatPR_def]  "p : NatPR <-> (EX x:Nat. p=<x,succ(x)>)";
  37.172 -by (fast_tac set_cs 1);
  37.173 -qed "NatPRXH";
  37.174 -
  37.175 -Goalw [ListPR_def]  "p : ListPR(A) <-> (EX h:A. EX t:List(A).p=<t,h$t>)";
  37.176 -by (fast_tac set_cs 1);
  37.177 -qed "ListPRXH";
  37.178 -
  37.179 -val NatPRI = refl RS (bexI RS (NatPRXH RS iffD2));
  37.180 -val ListPRI = refl RS (bexI RS (bexI RS (ListPRXH RS iffD2)));
  37.181 -
  37.182 -Goalw [Wfd_def]  "Wfd(NatPR)";
  37.183 -by (safe_tac set_cs);
  37.184 -by (wfd_strengthen_tac "%x. x:Nat" 1);
  37.185 -by (fast_tac (type_cs addSEs [XH_to_E NatPRXH]) 1);
  37.186 -by (etac Nat_ind 1);
  37.187 -by (ALLGOALS (fast_tac (type_cs addEs [XH_to_E NatPRXH])));
  37.188 -qed "NatPR_wf";
  37.189 -
  37.190 -Goalw [Wfd_def]  "Wfd(ListPR(A))";
  37.191 -by (safe_tac set_cs);
  37.192 -by (wfd_strengthen_tac "%x. x:List(A)" 1);
  37.193 -by (fast_tac (type_cs addSEs [XH_to_E ListPRXH]) 1);
  37.194 -by (etac List_ind 1);
  37.195 -by (ALLGOALS (fast_tac (type_cs addEs [XH_to_E ListPRXH])));
  37.196 -qed "ListPR_wf";