new version of HOL with curried function application
authorclasohm
Fri Mar 03 12:02:25 1995 +0100 (1995-03-03)
changeset 923ff1574a81019
parent 922 196ca0973a6d
child 924 806721cfbf46
new version of HOL with curried function application
src/HOL/Arith.ML
src/HOL/Arith.thy
src/HOL/Finite.ML
src/HOL/Finite.thy
src/HOL/Fun.ML
src/HOL/Fun.thy
src/HOL/Gfp.ML
src/HOL/Gfp.thy
src/HOL/HOL.ML
src/HOL/HOL.thy
src/HOL/Inductive.ML
src/HOL/Inductive.thy
src/HOL/Lfp.ML
src/HOL/Lfp.thy
src/HOL/List.ML
src/HOL/List.thy
src/HOL/Makefile
src/HOL/Nat.ML
src/HOL/Nat.thy
src/HOL/Ord.ML
src/HOL/Ord.thy
src/HOL/Prod.ML
src/HOL/Prod.thy
src/HOL/README
src/HOL/ROOT.ML
src/HOL/Set.ML
src/HOL/Set.thy
src/HOL/Sexp.ML
src/HOL/Sexp.thy
src/HOL/Sum.ML
src/HOL/Sum.thy
src/HOL/Trancl.ML
src/HOL/Trancl.thy
src/HOL/Univ.ML
src/HOL/Univ.thy
src/HOL/WF.ML
src/HOL/WF.thy
src/HOL/add_ind_def.ML
src/HOL/datatype.ML
src/HOL/equalities.ML
src/HOL/equalities.thy
src/HOL/hologic.ML
src/HOL/ind_syntax.ML
src/HOL/indrule.ML
src/HOL/intr_elim.ML
src/HOL/mono.ML
src/HOL/mono.thy
src/HOL/simpdata.ML
src/HOL/subset.ML
src/HOL/subset.thy
src/HOL/subtype.ML
src/HOL/thy_syntax.ML
src/HOL/typedef.ML
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Arith.ML	Fri Mar 03 12:02:25 1995 +0100
     1.3 @@ -0,0 +1,373 @@
     1.4 +(*  Title: 	HOL/Arith.ML
     1.5 +    ID:         $Id$
     1.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
     1.7 +    Copyright   1993  University of Cambridge
     1.8 +
     1.9 +Proofs about elementary arithmetic: addition, multiplication, etc.
    1.10 +Tests definitions and simplifier.
    1.11 +*)
    1.12 +
    1.13 +open Arith;
    1.14 +
    1.15 +(*** Basic rewrite rules for the arithmetic operators ***)
    1.16 +
    1.17 +val [pred_0, pred_Suc] = nat_recs pred_def;
    1.18 +val [add_0,add_Suc] = nat_recs add_def; 
    1.19 +val [mult_0,mult_Suc] = nat_recs mult_def; 
    1.20 +
    1.21 +(** Difference **)
    1.22 +
    1.23 +val diff_0 = diff_def RS def_nat_rec_0;
    1.24 +
    1.25 +qed_goalw "diff_0_eq_0" Arith.thy [diff_def, pred_def]
    1.26 +    "0 - n = 0"
    1.27 + (fn _ => [nat_ind_tac "n" 1,  ALLGOALS(asm_simp_tac nat_ss)]);
    1.28 +
    1.29 +(*Must simplify BEFORE the induction!!  (Else we get a critical pair)
    1.30 +  Suc(m) - Suc(n)   rewrites to   pred(Suc(m) - n)  *)
    1.31 +qed_goalw "diff_Suc_Suc" Arith.thy [diff_def, pred_def]
    1.32 +    "Suc(m) - Suc(n) = m - n"
    1.33 + (fn _ =>
    1.34 +  [simp_tac nat_ss 1, nat_ind_tac "n" 1, ALLGOALS(asm_simp_tac nat_ss)]);
    1.35 +
    1.36 +(*** Simplification over add, mult, diff ***)
    1.37 +
    1.38 +val arith_simps =
    1.39 + [pred_0, pred_Suc, add_0, add_Suc, mult_0, mult_Suc,
    1.40 +  diff_0, diff_0_eq_0, diff_Suc_Suc];
    1.41 +
    1.42 +val arith_ss = nat_ss addsimps arith_simps;
    1.43 +
    1.44 +(**** Inductive properties of the operators ****)
    1.45 +
    1.46 +(*** Addition ***)
    1.47 +
    1.48 +qed_goal "add_0_right" Arith.thy "m + 0 = m"
    1.49 + (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
    1.50 +
    1.51 +qed_goal "add_Suc_right" Arith.thy "m + Suc(n) = Suc(m+n)"
    1.52 + (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
    1.53 +
    1.54 +val arith_ss = arith_ss addsimps [add_0_right,add_Suc_right];
    1.55 +
    1.56 +(*Associative law for addition*)
    1.57 +qed_goal "add_assoc" Arith.thy "(m + n) + k = m + ((n + k)::nat)"
    1.58 + (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
    1.59 +
    1.60 +(*Commutative law for addition*)  
    1.61 +qed_goal "add_commute" Arith.thy "m + n = n + (m::nat)"
    1.62 + (fn _ =>  [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
    1.63 +
    1.64 +qed_goal "add_left_commute" Arith.thy "x+(y+z)=y+((x+z)::nat)"
    1.65 + (fn _ => [rtac (add_commute RS trans) 1, rtac (add_assoc RS trans) 1,
    1.66 +           rtac (add_commute RS arg_cong) 1]);
    1.67 +
    1.68 +(*Addition is an AC-operator*)
    1.69 +val add_ac = [add_assoc, add_commute, add_left_commute];
    1.70 +
    1.71 +goal Arith.thy "!!k::nat. (k + m = k + n) = (m=n)";
    1.72 +by (nat_ind_tac "k" 1);
    1.73 +by (simp_tac arith_ss 1);
    1.74 +by (asm_simp_tac arith_ss 1);
    1.75 +qed "add_left_cancel";
    1.76 +
    1.77 +goal Arith.thy "!!k::nat. (m + k = n + k) = (m=n)";
    1.78 +by (nat_ind_tac "k" 1);
    1.79 +by (simp_tac arith_ss 1);
    1.80 +by (asm_simp_tac arith_ss 1);
    1.81 +qed "add_right_cancel";
    1.82 +
    1.83 +goal Arith.thy "!!k::nat. (k + m <= k + n) = (m<=n)";
    1.84 +by (nat_ind_tac "k" 1);
    1.85 +by (simp_tac arith_ss 1);
    1.86 +by (asm_simp_tac (arith_ss addsimps [Suc_le_mono]) 1);
    1.87 +qed "add_left_cancel_le";
    1.88 +
    1.89 +goal Arith.thy "!!k::nat. (k + m < k + n) = (m<n)";
    1.90 +by (nat_ind_tac "k" 1);
    1.91 +by (simp_tac arith_ss 1);
    1.92 +by (asm_simp_tac arith_ss 1);
    1.93 +qed "add_left_cancel_less";
    1.94 +
    1.95 +(*** Multiplication ***)
    1.96 +
    1.97 +(*right annihilation in product*)
    1.98 +qed_goal "mult_0_right" Arith.thy "m * 0 = 0"
    1.99 + (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
   1.100 +
   1.101 +(*right Sucessor law for multiplication*)
   1.102 +qed_goal "mult_Suc_right" Arith.thy  "m * Suc(n) = m + (m * n)"
   1.103 + (fn _ => [nat_ind_tac "m" 1,
   1.104 +           ALLGOALS(asm_simp_tac (arith_ss addsimps add_ac))]);
   1.105 +
   1.106 +val arith_ss = arith_ss addsimps [mult_0_right,mult_Suc_right];
   1.107 +
   1.108 +(*Commutative law for multiplication*)
   1.109 +qed_goal "mult_commute" Arith.thy "m * n = n * (m::nat)"
   1.110 + (fn _ => [nat_ind_tac "m" 1, ALLGOALS (asm_simp_tac arith_ss)]);
   1.111 +
   1.112 +(*addition distributes over multiplication*)
   1.113 +qed_goal "add_mult_distrib" Arith.thy "(m + n)*k = (m*k) + ((n*k)::nat)"
   1.114 + (fn _ => [nat_ind_tac "m" 1,
   1.115 +           ALLGOALS(asm_simp_tac (arith_ss addsimps add_ac))]);
   1.116 +
   1.117 +qed_goal "add_mult_distrib2" Arith.thy "k*(m + n) = (k*m) + ((k*n)::nat)"
   1.118 + (fn _ => [nat_ind_tac "m" 1,
   1.119 +           ALLGOALS(asm_simp_tac (arith_ss addsimps add_ac))]);
   1.120 +
   1.121 +val arith_ss = arith_ss addsimps [add_mult_distrib,add_mult_distrib2];
   1.122 +
   1.123 +(*Associative law for multiplication*)
   1.124 +qed_goal "mult_assoc" Arith.thy "(m * n) * k = m * ((n * k)::nat)"
   1.125 +  (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
   1.126 +
   1.127 +qed_goal "mult_left_commute" Arith.thy "x*(y*z) = y*((x*z)::nat)"
   1.128 + (fn _ => [rtac trans 1, rtac mult_commute 1, rtac trans 1,
   1.129 +           rtac mult_assoc 1, rtac (mult_commute RS arg_cong) 1]);
   1.130 +
   1.131 +val mult_ac = [mult_assoc,mult_commute,mult_left_commute];
   1.132 +
   1.133 +(*** Difference ***)
   1.134 +
   1.135 +qed_goal "diff_self_eq_0" Arith.thy "m - m = 0"
   1.136 + (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
   1.137 +
   1.138 +(*Addition is the inverse of subtraction: if n<=m then n+(m-n) = m. *)
   1.139 +val [prem] = goal Arith.thy "[| ~ m<n |] ==> n+(m-n) = (m::nat)";
   1.140 +by (rtac (prem RS rev_mp) 1);
   1.141 +by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
   1.142 +by (ALLGOALS(asm_simp_tac arith_ss));
   1.143 +qed "add_diff_inverse";
   1.144 +
   1.145 +
   1.146 +(*** Remainder ***)
   1.147 +
   1.148 +goal Arith.thy "m - n < Suc(m)";
   1.149 +by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
   1.150 +by (etac less_SucE 3);
   1.151 +by (ALLGOALS(asm_simp_tac arith_ss));
   1.152 +qed "diff_less_Suc";
   1.153 +
   1.154 +goal Arith.thy "!!m::nat. m - n <= m";
   1.155 +by (res_inst_tac [("m","m"), ("n","n")] diff_induct 1);
   1.156 +by (ALLGOALS (asm_simp_tac arith_ss));
   1.157 +by (etac le_trans 1);
   1.158 +by (simp_tac (HOL_ss addsimps [le_eq_less_or_eq, lessI]) 1);
   1.159 +qed "diff_le_self";
   1.160 +
   1.161 +goal Arith.thy "!!n::nat. (n+m) - n = m";
   1.162 +by (nat_ind_tac "n" 1);
   1.163 +by (ALLGOALS (asm_simp_tac arith_ss));
   1.164 +qed "diff_add_inverse";
   1.165 +
   1.166 +goal Arith.thy "!!n::nat. n - (n+m) = 0";
   1.167 +by (nat_ind_tac "n" 1);
   1.168 +by (ALLGOALS (asm_simp_tac arith_ss));
   1.169 +qed "diff_add_0";
   1.170 +
   1.171 +(*In ordinary notation: if 0<n and n<=m then m-n < m *)
   1.172 +goal Arith.thy "!!m. [| 0<n; ~ m<n |] ==> m - n < m";
   1.173 +by (subgoal_tac "0<n --> ~ m<n --> m - n < m" 1);
   1.174 +by (fast_tac HOL_cs 1);
   1.175 +by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
   1.176 +by (ALLGOALS(asm_simp_tac(arith_ss addsimps [diff_less_Suc])));
   1.177 +qed "div_termination";
   1.178 +
   1.179 +val wf_less_trans = wf_pred_nat RS wf_trancl RSN (2, def_wfrec RS trans);
   1.180 +
   1.181 +goalw Nat.thy [less_def] "<m,n> : pred_nat^+ = (m<n)";
   1.182 +by (rtac refl 1);
   1.183 +qed "less_eq";
   1.184 +
   1.185 +goal Arith.thy "!!m. m<n ==> m mod n = m";
   1.186 +by (rtac (mod_def RS wf_less_trans) 1);
   1.187 +by(asm_simp_tac HOL_ss 1);
   1.188 +qed "mod_less";
   1.189 +
   1.190 +goal Arith.thy "!!m. [| 0<n;  ~m<n |] ==> m mod n = (m-n) mod n";
   1.191 +by (rtac (mod_def RS wf_less_trans) 1);
   1.192 +by(asm_simp_tac (nat_ss addsimps [div_termination, cut_apply, less_eq]) 1);
   1.193 +qed "mod_geq";
   1.194 +
   1.195 +
   1.196 +(*** Quotient ***)
   1.197 +
   1.198 +goal Arith.thy "!!m. m<n ==> m div n = 0";
   1.199 +by (rtac (div_def RS wf_less_trans) 1);
   1.200 +by(asm_simp_tac nat_ss 1);
   1.201 +qed "div_less";
   1.202 +
   1.203 +goal Arith.thy "!!M. [| 0<n;  ~m<n |] ==> m div n = Suc((m-n) div n)";
   1.204 +by (rtac (div_def RS wf_less_trans) 1);
   1.205 +by(asm_simp_tac (nat_ss addsimps [div_termination, cut_apply, less_eq]) 1);
   1.206 +qed "div_geq";
   1.207 +
   1.208 +(*Main Result about quotient and remainder.*)
   1.209 +goal Arith.thy "!!m. 0<n ==> (m div n)*n + m mod n = m";
   1.210 +by (res_inst_tac [("n","m")] less_induct 1);
   1.211 +by (rename_tac "k" 1);    (*Variable name used in line below*)
   1.212 +by (case_tac "k<n" 1);
   1.213 +by (ALLGOALS (asm_simp_tac(arith_ss addsimps (add_ac @
   1.214 +                       [mod_less, mod_geq, div_less, div_geq,
   1.215 +	                add_diff_inverse, div_termination]))));
   1.216 +qed "mod_div_equality";
   1.217 +
   1.218 +
   1.219 +(*** More results about difference ***)
   1.220 +
   1.221 +val [prem] = goal Arith.thy "m < Suc(n) ==> m-n = 0";
   1.222 +by (rtac (prem RS rev_mp) 1);
   1.223 +by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
   1.224 +by (ALLGOALS (asm_simp_tac arith_ss));
   1.225 +qed "less_imp_diff_is_0";
   1.226 +
   1.227 +val prems = goal Arith.thy "m-n = 0  -->  n-m = 0  -->  m=n";
   1.228 +by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
   1.229 +by (REPEAT(simp_tac arith_ss 1 THEN TRY(atac 1)));
   1.230 +qed "diffs0_imp_equal_lemma";
   1.231 +
   1.232 +(*  [| m-n = 0;  n-m = 0 |] ==> m=n  *)
   1.233 +bind_thm ("diffs0_imp_equal", (diffs0_imp_equal_lemma RS mp RS mp));
   1.234 +
   1.235 +val [prem] = goal Arith.thy "m<n ==> 0<n-m";
   1.236 +by (rtac (prem RS rev_mp) 1);
   1.237 +by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
   1.238 +by (ALLGOALS(asm_simp_tac arith_ss));
   1.239 +qed "less_imp_diff_positive";
   1.240 +
   1.241 +val [prem] = goal Arith.thy "n < Suc(m) ==> Suc(m)-n = Suc(m-n)";
   1.242 +by (rtac (prem RS rev_mp) 1);
   1.243 +by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
   1.244 +by (ALLGOALS(asm_simp_tac arith_ss));
   1.245 +qed "Suc_diff_n";
   1.246 +
   1.247 +goal Arith.thy "Suc(m)-n = if (m<n) 0 (Suc m-n)";
   1.248 +by(simp_tac (nat_ss addsimps [less_imp_diff_is_0, not_less_eq, Suc_diff_n]
   1.249 +                    setloop (split_tac [expand_if])) 1);
   1.250 +qed "if_Suc_diff_n";
   1.251 +
   1.252 +goal Arith.thy "P(k) --> (!n. P(Suc(n))--> P(n)) --> P(k-i)";
   1.253 +by (res_inst_tac [("m","k"),("n","i")] diff_induct 1);
   1.254 +by (ALLGOALS (strip_tac THEN' simp_tac arith_ss THEN' TRY o fast_tac HOL_cs));
   1.255 +qed "zero_induct_lemma";
   1.256 +
   1.257 +val prems = goal Arith.thy "[| P(k);  !!n. P(Suc(n)) ==> P(n) |] ==> P(0)";
   1.258 +by (rtac (diff_self_eq_0 RS subst) 1);
   1.259 +by (rtac (zero_induct_lemma RS mp RS mp) 1);
   1.260 +by (REPEAT (ares_tac ([impI,allI]@prems) 1));
   1.261 +qed "zero_induct";
   1.262 +
   1.263 +(*13 July 1992: loaded in 105.7s*)
   1.264 +
   1.265 +(**** Additional theorems about "less than" ****)
   1.266 +
   1.267 +goal Arith.thy "!!m. m<n --> (? k. n=Suc(m+k))";
   1.268 +by (nat_ind_tac "n" 1);
   1.269 +by (ALLGOALS(simp_tac arith_ss));
   1.270 +by (REPEAT_FIRST (ares_tac [conjI, impI]));
   1.271 +by (res_inst_tac [("x","0")] exI 2);
   1.272 +by (simp_tac arith_ss 2);
   1.273 +by (safe_tac HOL_cs);
   1.274 +by (res_inst_tac [("x","Suc(k)")] exI 1);
   1.275 +by (simp_tac arith_ss 1);
   1.276 +val less_eq_Suc_add_lemma = result();
   1.277 +
   1.278 +(*"m<n ==> ? k. n = Suc(m+k)"*)
   1.279 +bind_thm ("less_eq_Suc_add", less_eq_Suc_add_lemma RS mp);
   1.280 +
   1.281 +
   1.282 +goal Arith.thy "n <= ((m + n)::nat)";
   1.283 +by (nat_ind_tac "m" 1);
   1.284 +by (ALLGOALS(simp_tac arith_ss));
   1.285 +by (etac le_trans 1);
   1.286 +by (rtac (lessI RS less_imp_le) 1);
   1.287 +qed "le_add2";
   1.288 +
   1.289 +goal Arith.thy "n <= ((n + m)::nat)";
   1.290 +by (simp_tac (arith_ss addsimps add_ac) 1);
   1.291 +by (rtac le_add2 1);
   1.292 +qed "le_add1";
   1.293 +
   1.294 +bind_thm ("less_add_Suc1", (lessI RS (le_add1 RS le_less_trans)));
   1.295 +bind_thm ("less_add_Suc2", (lessI RS (le_add2 RS le_less_trans)));
   1.296 +
   1.297 +(*"i <= j ==> i <= j+m"*)
   1.298 +bind_thm ("trans_le_add1", le_add1 RSN (2,le_trans));
   1.299 +
   1.300 +(*"i <= j ==> i <= m+j"*)
   1.301 +bind_thm ("trans_le_add2", le_add2 RSN (2,le_trans));
   1.302 +
   1.303 +(*"i < j ==> i < j+m"*)
   1.304 +bind_thm ("trans_less_add1", le_add1 RSN (2,less_le_trans));
   1.305 +
   1.306 +(*"i < j ==> i < m+j"*)
   1.307 +bind_thm ("trans_less_add2", le_add2 RSN (2,less_le_trans));
   1.308 +
   1.309 +goal Arith.thy "!!k::nat. m <= n ==> m <= n+k";
   1.310 +by (eresolve_tac [le_trans] 1);
   1.311 +by (resolve_tac [le_add1] 1);
   1.312 +qed "le_imp_add_le";
   1.313 +
   1.314 +goal Arith.thy "!!k::nat. m < n ==> m < n+k";
   1.315 +by (eresolve_tac [less_le_trans] 1);
   1.316 +by (resolve_tac [le_add1] 1);
   1.317 +qed "less_imp_add_less";
   1.318 +
   1.319 +goal Arith.thy "m+k<=n --> m<=(n::nat)";
   1.320 +by (nat_ind_tac "k" 1);
   1.321 +by (ALLGOALS (asm_simp_tac arith_ss));
   1.322 +by (fast_tac (HOL_cs addDs [Suc_leD]) 1);
   1.323 +val add_leD1_lemma = result();
   1.324 +bind_thm ("add_leD1", add_leD1_lemma RS mp);;
   1.325 +
   1.326 +goal Arith.thy "!!k l::nat. [| k<l; m+l = k+n |] ==> m<n";
   1.327 +by (safe_tac (HOL_cs addSDs [less_eq_Suc_add]));
   1.328 +by (asm_full_simp_tac
   1.329 +    (HOL_ss addsimps ([add_Suc_right RS sym, add_left_cancel] @add_ac)) 1);
   1.330 +by (eresolve_tac [subst] 1);
   1.331 +by (simp_tac (arith_ss addsimps [less_add_Suc1]) 1);
   1.332 +qed "less_add_eq_less";
   1.333 +
   1.334 +
   1.335 +(** Monotonicity of addition (from ZF/Arith) **)
   1.336 +
   1.337 +(** Monotonicity results **)
   1.338 +
   1.339 +(*strict, in 1st argument*)
   1.340 +goal Arith.thy "!!i j k::nat. i < j ==> i + k < j + k";
   1.341 +by (nat_ind_tac "k" 1);
   1.342 +by (ALLGOALS (asm_simp_tac arith_ss));
   1.343 +qed "add_less_mono1";
   1.344 +
   1.345 +(*strict, in both arguments*)
   1.346 +goal Arith.thy "!!i j k::nat. [|i < j; k < l|] ==> i + k < j + l";
   1.347 +by (rtac (add_less_mono1 RS less_trans) 1);
   1.348 +by (REPEAT (etac asm_rl 1));
   1.349 +by (nat_ind_tac "j" 1);
   1.350 +by (ALLGOALS(asm_simp_tac arith_ss));
   1.351 +qed "add_less_mono";
   1.352 +
   1.353 +(*A [clumsy] way of lifting < monotonicity to <= monotonicity *)
   1.354 +val [lt_mono,le] = goal Arith.thy
   1.355 +     "[| !!i j::nat. i<j ==> f(i) < f(j);	\
   1.356 +\        i <= j					\
   1.357 +\     |] ==> f(i) <= (f(j)::nat)";
   1.358 +by (cut_facts_tac [le] 1);
   1.359 +by (asm_full_simp_tac (HOL_ss addsimps [le_eq_less_or_eq]) 1);
   1.360 +by (fast_tac (HOL_cs addSIs [lt_mono]) 1);
   1.361 +qed "less_mono_imp_le_mono";
   1.362 +
   1.363 +(*non-strict, in 1st argument*)
   1.364 +goal Arith.thy "!!i j k::nat. i<=j ==> i + k <= j + k";
   1.365 +by (res_inst_tac [("f", "%j.j+k")] less_mono_imp_le_mono 1);
   1.366 +by (eresolve_tac [add_less_mono1] 1);
   1.367 +by (assume_tac 1);
   1.368 +qed "add_le_mono1";
   1.369 +
   1.370 +(*non-strict, in both arguments*)
   1.371 +goal Arith.thy "!!k l::nat. [|i<=j;  k<=l |] ==> i + k <= j + l";
   1.372 +by (etac (add_le_mono1 RS le_trans) 1);
   1.373 +by (simp_tac (HOL_ss addsimps [add_commute]) 1);
   1.374 +(*j moves to the end because it is free while k, l are bound*)
   1.375 +by (eresolve_tac [add_le_mono1] 1);
   1.376 +qed "add_le_mono";
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/Arith.thy	Fri Mar 03 12:02:25 1995 +0100
     2.3 @@ -0,0 +1,31 @@
     2.4 +(*  Title:      HOL/Arith.thy
     2.5 +    ID:         $Id$
     2.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     2.7 +    Copyright   1993  University of Cambridge
     2.8 +
     2.9 +Arithmetic operators and their definitions
    2.10 +*)
    2.11 +
    2.12 +Arith = Nat +
    2.13 +
    2.14 +instance
    2.15 +  nat :: {plus, minus, times}
    2.16 +
    2.17 +consts
    2.18 +  pred      :: "nat => nat"
    2.19 +  div, mod  :: "[nat, nat] => nat"  (infixl 70)
    2.20 +
    2.21 +defs
    2.22 +  pred_def  "pred(m) == nat_rec m 0 (%n r.n)"
    2.23 +  add_def   "m+n == nat_rec m n (%u v. Suc(v))"
    2.24 +  diff_def  "m-n == nat_rec n m (%u v. pred(v))"
    2.25 +  mult_def  "m*n == nat_rec m 0 (%u v. n + v)"
    2.26 +  mod_def   "m mod n == wfrec (trancl pred_nat) m (%j f.(if (j<n) j (f (j-n))))"
    2.27 +  div_def   "m div n == wfrec (trancl pred_nat) m (%j f.(if (j<n) 0 (Suc (f (j-n)))))"
    2.28 +end
    2.29 +
    2.30 +(*"Difference" is subtraction of natural numbers.
    2.31 +  There are no negative numbers; we have
    2.32 +     m - n = 0  iff  m<=n   and     m - n = Suc(k) iff m>n.
    2.33 +  Also, nat_rec(m, 0, %z w.z) is pred(m).   *)
    2.34 +
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/Finite.ML	Fri Mar 03 12:02:25 1995 +0100
     3.3 @@ -0,0 +1,84 @@
     3.4 +(*  Title: 	HOL/Finite.thy
     3.5 +    ID:         $Id$
     3.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
     3.7 +    Copyright   1994  University of Cambridge
     3.8 +
     3.9 +Finite powerset operator
    3.10 +*)
    3.11 +
    3.12 +open Finite;
    3.13 +
    3.14 +goalw Finite.thy Fin.defs "!!A B. A<=B ==> Fin(A) <= Fin(B)";
    3.15 +br lfp_mono 1;
    3.16 +by (REPEAT (ares_tac basic_monos 1));
    3.17 +qed "Fin_mono";
    3.18 +
    3.19 +goalw Finite.thy Fin.defs "Fin(A) <= Pow(A)";
    3.20 +by (fast_tac (set_cs addSIs [lfp_lowerbound]) 1);
    3.21 +qed "Fin_subset_Pow";
    3.22 +
    3.23 +(* A : Fin(B) ==> A <= B *)
    3.24 +val FinD = Fin_subset_Pow RS subsetD RS PowD;
    3.25 +
    3.26 +(*Discharging ~ x:y entails extra work*)
    3.27 +val major::prems = goal Finite.thy 
    3.28 +    "[| F:Fin(A);  P({}); \
    3.29 +\	!!F x. [| x:A;  F:Fin(A);  x~:F;  P(F) |] ==> P(insert x F) \
    3.30 +\    |] ==> P(F)";
    3.31 +by (rtac (major RS Fin.induct) 1);
    3.32 +by (excluded_middle_tac "a:b" 2);
    3.33 +by (etac (insert_absorb RS ssubst) 3 THEN assume_tac 3);   (*backtracking!*)
    3.34 +by (REPEAT (ares_tac prems 1));
    3.35 +qed "Fin_induct";
    3.36 +
    3.37 +(** Simplification for Fin **)
    3.38 +
    3.39 +val Fin_ss = set_ss addsimps Fin.intrs;
    3.40 +
    3.41 +(*The union of two finite sets is finite*)
    3.42 +val major::prems = goal Finite.thy
    3.43 +    "[| F: Fin(A);  G: Fin(A) |] ==> F Un G : Fin(A)";
    3.44 +by (rtac (major RS Fin_induct) 1);
    3.45 +by (ALLGOALS (asm_simp_tac (Fin_ss addsimps (prems@[Un_insert_left]))));
    3.46 +qed "Fin_UnI";
    3.47 +
    3.48 +(*Every subset of a finite set is finite*)
    3.49 +val [subs,fin] = goal Finite.thy "[| A<=B;  B: Fin(M) |] ==> A: Fin(M)";
    3.50 +by (EVERY1 [subgoal_tac "ALL C. C<=B --> C: Fin(M)",
    3.51 +	    rtac mp, etac spec,
    3.52 +	    rtac subs]);
    3.53 +by (rtac (fin RS Fin_induct) 1);
    3.54 +by (simp_tac (Fin_ss addsimps [subset_Un_eq]) 1);
    3.55 +by (safe_tac (set_cs addSDs [subset_insert_iff RS iffD1]));
    3.56 +by (eres_inst_tac [("t","C")] (insert_Diff RS subst) 2);
    3.57 +by (ALLGOALS (asm_simp_tac Fin_ss));
    3.58 +qed "Fin_subset";
    3.59 +
    3.60 +(*The image of a finite set is finite*)
    3.61 +val major::_ = goal Finite.thy
    3.62 +    "F: Fin(A) ==> h``F : Fin(h``A)";
    3.63 +by (rtac (major RS Fin_induct) 1);
    3.64 +by (simp_tac Fin_ss 1);
    3.65 +by (asm_simp_tac (set_ss addsimps [image_eqI RS Fin.insertI, image_insert]) 1);
    3.66 +qed "Fin_imageI";
    3.67 +
    3.68 +val major::prems = goal Finite.thy 
    3.69 +    "[| c: Fin(A);  b: Fin(A);  				\
    3.70 +\       P(b);       						\
    3.71 +\       !!(x::'a) y. [| x:A; y: Fin(A);  x:y;  P(y) |] ==> P(y-{x}) \
    3.72 +\    |] ==> c<=b --> P(b-c)";
    3.73 +by (rtac (major RS Fin_induct) 1);
    3.74 +by (rtac (Diff_insert RS ssubst) 2);
    3.75 +by (ALLGOALS (asm_simp_tac
    3.76 +                (Fin_ss addsimps (prems@[Diff_subset RS Fin_subset]))));
    3.77 +qed "Fin_empty_induct_lemma";
    3.78 +
    3.79 +val prems = goal Finite.thy 
    3.80 +    "[| b: Fin(A);  						\
    3.81 +\       P(b);        						\
    3.82 +\       !!x y. [| x:A; y: Fin(A);  x:y;  P(y) |] ==> P(y-{x}) \
    3.83 +\    |] ==> P({})";
    3.84 +by (rtac (Diff_cancel RS subst) 1);
    3.85 +by (rtac (Fin_empty_induct_lemma RS mp) 1);
    3.86 +by (REPEAT (ares_tac (subset_refl::prems) 1));
    3.87 +qed "Fin_empty_induct";
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/HOL/Finite.thy	Fri Mar 03 12:02:25 1995 +0100
     4.3 @@ -0,0 +1,17 @@
     4.4 +(*  Title: 	HOL/Finite.thy
     4.5 +    ID:         $Id$
     4.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
     4.7 +    Copyright   1994  University of Cambridge
     4.8 +
     4.9 +Finite powerset operator
    4.10 +*)
    4.11 +
    4.12 +Finite = Lfp +
    4.13 +consts Fin :: "'a set => 'a set set"
    4.14 +
    4.15 +inductive "Fin(A)"
    4.16 +  intrs
    4.17 +    emptyI  "{} : Fin(A)"
    4.18 +    insertI "[| a: A;  b: Fin(A) |] ==> insert a b : Fin(A)"
    4.19 +
    4.20 +end
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Fun.ML	Fri Mar 03 12:02:25 1995 +0100
     5.3 @@ -0,0 +1,200 @@
     5.4 +(*  Title: 	HOL/Fun
     5.5 +    ID:         $Id$
     5.6 +    Author: 	Tobias Nipkow, Cambridge University Computer Laboratory
     5.7 +    Copyright   1993  University of Cambridge
     5.8 +
     5.9 +Lemmas about functions.
    5.10 +*)
    5.11 +
    5.12 +goal Fun.thy "(f = g) = (!x. f(x)=g(x))";
    5.13 +by (rtac iffI 1);
    5.14 +by(asm_simp_tac HOL_ss 1);
    5.15 +by(rtac ext 1 THEN asm_simp_tac HOL_ss 1);
    5.16 +qed "expand_fun_eq";
    5.17 +
    5.18 +val prems = goal Fun.thy
    5.19 +    "[| f(x)=u;  !!x. P(x) ==> g(f(x)) = x;  P(x) |] ==> x=g(u)";
    5.20 +by (rtac (arg_cong RS box_equals) 1);
    5.21 +by (REPEAT (resolve_tac (prems@[refl]) 1));
    5.22 +qed "apply_inverse";
    5.23 +
    5.24 +
    5.25 +(*** Range of a function ***)
    5.26 +
    5.27 +(*Frequently b does not have the syntactic form of f(x).*)
    5.28 +val [prem] = goalw Fun.thy [range_def] "b=f(x) ==> b : range(f)";
    5.29 +by (EVERY1 [rtac CollectI, rtac exI, rtac prem]);
    5.30 +qed "range_eqI";
    5.31 +
    5.32 +val rangeI = refl RS range_eqI;
    5.33 +
    5.34 +val [major,minor] = goalw Fun.thy [range_def]
    5.35 +    "[| b : range(%x.f(x));  !!x. b=f(x) ==> P |] ==> P"; 
    5.36 +by (rtac (major RS CollectD RS exE) 1);
    5.37 +by (etac minor 1);
    5.38 +qed "rangeE";
    5.39 +
    5.40 +(*** Image of a set under a function ***)
    5.41 +
    5.42 +val prems = goalw Fun.thy [image_def] "[| b=f(x);  x:A |] ==> b : f``A";
    5.43 +by (REPEAT (resolve_tac (prems @ [CollectI,bexI,prem]) 1));
    5.44 +qed "image_eqI";
    5.45 +
    5.46 +val imageI = refl RS image_eqI;
    5.47 +
    5.48 +(*The eta-expansion gives variable-name preservation.*)
    5.49 +val major::prems = goalw Fun.thy [image_def]
    5.50 +    "[| b : (%x.f(x))``A;  !!x.[| b=f(x);  x:A |] ==> P |] ==> P"; 
    5.51 +by (rtac (major RS CollectD RS bexE) 1);
    5.52 +by (REPEAT (ares_tac prems 1));
    5.53 +qed "imageE";
    5.54 +
    5.55 +goalw Fun.thy [o_def] "(f o g)``r = f``(g``r)";
    5.56 +by (rtac set_ext 1);
    5.57 +by (fast_tac (HOL_cs addIs [imageI] addSEs [imageE]) 1);
    5.58 +qed "image_compose";
    5.59 +
    5.60 +goal Fun.thy "f``(A Un B) = f``A Un f``B";
    5.61 +by (rtac set_ext 1);
    5.62 +by (fast_tac (HOL_cs addIs [imageI,UnCI] addSEs [imageE,UnE]) 1);
    5.63 +qed "image_Un";
    5.64 +
    5.65 +(*** inj(f): f is a one-to-one function ***)
    5.66 +
    5.67 +val prems = goalw Fun.thy [inj_def]
    5.68 +    "[| !! x y. f(x) = f(y) ==> x=y |] ==> inj(f)";
    5.69 +by (fast_tac (HOL_cs addIs prems) 1);
    5.70 +qed "injI";
    5.71 +
    5.72 +val [major] = goal Fun.thy "(!!x. g(f(x)) = x) ==> inj(f)";
    5.73 +by (rtac injI 1);
    5.74 +by (etac (arg_cong RS box_equals) 1);
    5.75 +by (rtac major 1);
    5.76 +by (rtac major 1);
    5.77 +qed "inj_inverseI";
    5.78 +
    5.79 +val [major,minor] = goalw Fun.thy [inj_def]
    5.80 +    "[| inj(f); f(x) = f(y) |] ==> x=y";
    5.81 +by (rtac (major RS spec RS spec RS mp) 1);
    5.82 +by (rtac minor 1);
    5.83 +qed "injD";
    5.84 +
    5.85 +(*Useful with the simplifier*)
    5.86 +val [major] = goal Fun.thy "inj(f) ==> (f(x) = f(y)) = (x=y)";
    5.87 +by (rtac iffI 1);
    5.88 +by (etac (major RS injD) 1);
    5.89 +by (etac arg_cong 1);
    5.90 +qed "inj_eq";
    5.91 +
    5.92 +val [major] = goal Fun.thy "inj(f) ==> (@x.f(x)=f(y)) = y";
    5.93 +by (rtac (major RS injD) 1);
    5.94 +by (rtac selectI 1);
    5.95 +by (rtac refl 1);
    5.96 +qed "inj_select";
    5.97 +
    5.98 +(*A one-to-one function has an inverse (given using select).*)
    5.99 +val [major] = goalw Fun.thy [Inv_def] "inj(f) ==> Inv f (f x) = x";
   5.100 +by (EVERY1 [rtac (major RS inj_select)]);
   5.101 +qed "Inv_f_f";
   5.102 +
   5.103 +(* Useful??? *)
   5.104 +val [oneone,minor] = goal Fun.thy
   5.105 +    "[| inj(f); !!y. y: range(f) ==> P(Inv f y) |] ==> P(x)";
   5.106 +by (res_inst_tac [("t", "x")] (oneone RS (Inv_f_f RS subst)) 1);
   5.107 +by (rtac (rangeI RS minor) 1);
   5.108 +qed "inj_transfer";
   5.109 +
   5.110 +
   5.111 +(*** inj_onto f A: f is one-to-one over A ***)
   5.112 +
   5.113 +val prems = goalw Fun.thy [inj_onto_def]
   5.114 +    "(!! x y. [| f(x) = f(y);  x:A;  y:A |] ==> x=y) ==> inj_onto f A";
   5.115 +by (fast_tac (HOL_cs addIs prems addSIs [ballI]) 1);
   5.116 +qed "inj_ontoI";
   5.117 +
   5.118 +val [major] = goal Fun.thy 
   5.119 +    "(!!x. x:A ==> g(f(x)) = x) ==> inj_onto f A";
   5.120 +by (rtac inj_ontoI 1);
   5.121 +by (etac (apply_inverse RS trans) 1);
   5.122 +by (REPEAT (eresolve_tac [asm_rl,major] 1));
   5.123 +qed "inj_onto_inverseI";
   5.124 +
   5.125 +val major::prems = goalw Fun.thy [inj_onto_def]
   5.126 +    "[| inj_onto f A;  f(x)=f(y);  x:A;  y:A |] ==> x=y";
   5.127 +by (rtac (major RS bspec RS bspec RS mp) 1);
   5.128 +by (REPEAT (resolve_tac prems 1));
   5.129 +qed "inj_ontoD";
   5.130 +
   5.131 +goal Fun.thy "!!x y.[| inj_onto f A;  x:A;  y:A |] ==> (f(x)=f(y)) = (x=y)";
   5.132 +by (fast_tac (HOL_cs addSEs [inj_ontoD]) 1);
   5.133 +qed "inj_onto_iff";
   5.134 +
   5.135 +val major::prems = goal Fun.thy
   5.136 +    "[| inj_onto f A;  ~x=y;  x:A;  y:A |] ==> ~ f(x)=f(y)";
   5.137 +by (rtac contrapos 1);
   5.138 +by (etac (major RS inj_ontoD) 2);
   5.139 +by (REPEAT (resolve_tac prems 1));
   5.140 +qed "inj_onto_contraD";
   5.141 +
   5.142 +
   5.143 +(*** Lemmas about inj ***)
   5.144 +
   5.145 +val prems = goalw Fun.thy [o_def]
   5.146 +    "[| inj(f);  inj_onto g (range f) |] ==> inj(g o f)";
   5.147 +by (cut_facts_tac prems 1);
   5.148 +by (fast_tac (HOL_cs addIs [injI,rangeI]
   5.149 +                     addEs [injD,inj_ontoD]) 1);
   5.150 +qed "comp_inj";
   5.151 +
   5.152 +val [prem] = goal Fun.thy "inj(f) ==> inj_onto f A";
   5.153 +by (fast_tac (HOL_cs addIs [prem RS injD, inj_ontoI]) 1);
   5.154 +qed "inj_imp";
   5.155 +
   5.156 +val [prem] = goalw Fun.thy [Inv_def] "y : range(f) ==> f(Inv f y) = y";
   5.157 +by (EVERY1 [rtac (prem RS rangeE), rtac selectI, etac sym]);
   5.158 +qed "f_Inv_f";
   5.159 +
   5.160 +val prems = goal Fun.thy
   5.161 +    "[| Inv f x=Inv f y; x: range(f);  y: range(f) |] ==> x=y";
   5.162 +by (rtac (arg_cong RS box_equals) 1);
   5.163 +by (REPEAT (resolve_tac (prems @ [f_Inv_f]) 1));
   5.164 +qed "Inv_injective";
   5.165 +
   5.166 +val prems = goal Fun.thy
   5.167 +    "[| inj(f);  A<=range(f) |] ==> inj_onto (Inv f) A";
   5.168 +by (cut_facts_tac prems 1);
   5.169 +by (fast_tac (HOL_cs addIs [inj_ontoI] 
   5.170 +		     addEs [Inv_injective,injD,subsetD]) 1);
   5.171 +qed "inj_onto_Inv";
   5.172 +
   5.173 +
   5.174 +(*** Set reasoning tools ***)
   5.175 +
   5.176 +val set_cs = HOL_cs 
   5.177 +    addSIs [ballI, PowI, subsetI, InterI, INT_I, INT1_I, CollectI, 
   5.178 +	    ComplI, IntI, DiffI, UnCI, insertCI] 
   5.179 +    addIs  [bexI, UnionI, UN_I, UN1_I, imageI, rangeI] 
   5.180 +    addSEs [bexE, make_elim PowD, UnionE, UN_E, UN1_E, DiffE,
   5.181 +	    CollectE, ComplE, IntE, UnE, insertE, imageE, rangeE, emptyE] 
   5.182 +    addEs  [ballE, InterD, InterE, INT_D, INT_E, make_elim INT1_D,
   5.183 +	    subsetD, subsetCE];
   5.184 +
   5.185 +fun cfast_tac prems = cut_facts_tac prems THEN' fast_tac set_cs;
   5.186 +
   5.187 +
   5.188 +fun prover s = prove_goal Fun.thy s (fn _=>[fast_tac set_cs 1]);
   5.189 +
   5.190 +val mem_simps = map prover
   5.191 + [ "(a : A Un B)   =  (a:A | a:B)",
   5.192 +   "(a : A Int B)  =  (a:A & a:B)",
   5.193 +   "(a : Compl(B)) =  (~a:B)",
   5.194 +   "(a : A-B)      =  (a:A & ~a:B)",
   5.195 +   "(a : {b})      =  (a=b)",
   5.196 +   "(a : {x.P(x)}) =  P(a)" ];
   5.197 +
   5.198 +val mksimps_pairs = ("Ball",[bspec]) :: mksimps_pairs;
   5.199 +
   5.200 +val set_ss =
   5.201 +  HOL_ss addsimps mem_simps
   5.202 +         addcongs [ball_cong,bex_cong]
   5.203 +         setmksimps (mksimps mksimps_pairs);
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Fun.thy	Fri Mar 03 12:02:25 1995 +0100
     6.3 @@ -0,0 +1,9 @@
     6.4 +(*  Title: 	HOL/Fun.thy
     6.5 +    ID:         $Id$
     6.6 +    Author: 	Tobias Nipkow, Cambridge University Computer Laboratory
     6.7 +    Copyright   1994  University of Cambridge
     6.8 +
     6.9 +Lemmas about functions.
    6.10 +*)
    6.11 +
    6.12 +Fun = Set
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Gfp.ML	Fri Mar 03 12:02:25 1995 +0100
     7.3 @@ -0,0 +1,145 @@
     7.4 +(*  Title: 	HOL/gfp
     7.5 +    ID:         $Id$
     7.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
     7.7 +    Copyright   1993  University of Cambridge
     7.8 +
     7.9 +For gfp.thy.  The Knaster-Tarski Theorem for greatest fixed points.
    7.10 +*)
    7.11 +
    7.12 +open Gfp;
    7.13 +
    7.14 +(*** Proof of Knaster-Tarski Theorem using gfp ***)
    7.15 +
    7.16 +(* gfp(f) is the least upper bound of {u. u <= f(u)} *)
    7.17 +
    7.18 +val prems = goalw Gfp.thy [gfp_def] "[| X <= f(X) |] ==> X <= gfp(f)";
    7.19 +by (rtac (CollectI RS Union_upper) 1);
    7.20 +by (resolve_tac prems 1);
    7.21 +qed "gfp_upperbound";
    7.22 +
    7.23 +val prems = goalw Gfp.thy [gfp_def]
    7.24 +    "[| !!u. u <= f(u) ==> u<=X |] ==> gfp(f) <= X";
    7.25 +by (REPEAT (ares_tac ([Union_least]@prems) 1));
    7.26 +by (etac CollectD 1);
    7.27 +qed "gfp_least";
    7.28 +
    7.29 +val [mono] = goal Gfp.thy "mono(f) ==> gfp(f) <= f(gfp(f))";
    7.30 +by (EVERY1 [rtac gfp_least, rtac subset_trans, atac,
    7.31 +	    rtac (mono RS monoD), rtac gfp_upperbound, atac]);
    7.32 +qed "gfp_lemma2";
    7.33 +
    7.34 +val [mono] = goal Gfp.thy "mono(f) ==> f(gfp(f)) <= gfp(f)";
    7.35 +by (EVERY1 [rtac gfp_upperbound, rtac (mono RS monoD), 
    7.36 +	    rtac gfp_lemma2, rtac mono]);
    7.37 +qed "gfp_lemma3";
    7.38 +
    7.39 +val [mono] = goal Gfp.thy "mono(f) ==> gfp(f) = f(gfp(f))";
    7.40 +by (REPEAT (resolve_tac [equalityI,gfp_lemma2,gfp_lemma3,mono] 1));
    7.41 +qed "gfp_Tarski";
    7.42 +
    7.43 +(*** Coinduction rules for greatest fixed points ***)
    7.44 +
    7.45 +(*weak version*)
    7.46 +val prems = goal Gfp.thy
    7.47 +    "[| a: X;  X <= f(X) |] ==> a : gfp(f)";
    7.48 +by (rtac (gfp_upperbound RS subsetD) 1);
    7.49 +by (REPEAT (ares_tac prems 1));
    7.50 +qed "weak_coinduct";
    7.51 +
    7.52 +val [prem,mono] = goal Gfp.thy
    7.53 +    "[| X <= f(X Un gfp(f));  mono(f) |] ==>  \
    7.54 +\    X Un gfp(f) <= f(X Un gfp(f))";
    7.55 +by (rtac (prem RS Un_least) 1);
    7.56 +by (rtac (mono RS gfp_lemma2 RS subset_trans) 1);
    7.57 +by (rtac (Un_upper2 RS subset_trans) 1);
    7.58 +by (rtac (mono RS mono_Un) 1);
    7.59 +qed "coinduct_lemma";
    7.60 +
    7.61 +(*strong version, thanks to Coen & Frost*)
    7.62 +goal Gfp.thy
    7.63 +    "!!X. [| mono(f);  a: X;  X <= f(X Un gfp(f)) |] ==> a : gfp(f)";
    7.64 +by (rtac (coinduct_lemma RSN (2, weak_coinduct)) 1);
    7.65 +by (REPEAT (ares_tac [UnI1, Un_least] 1));
    7.66 +qed "coinduct";
    7.67 +
    7.68 +val [mono,prem] = goal Gfp.thy
    7.69 +    "[| mono(f);  a: gfp(f) |] ==> a: f(X Un gfp(f))";
    7.70 +br (mono RS mono_Un RS subsetD) 1;
    7.71 +br (mono RS gfp_lemma2 RS subsetD RS UnI2) 1;
    7.72 +by (rtac prem 1);
    7.73 +qed "gfp_fun_UnI2";
    7.74 +
    7.75 +(***  Even Stronger version of coinduct  [by Martin Coen]
    7.76 +         - instead of the condition  X <= f(X)
    7.77 +                           consider  X <= (f(X) Un f(f(X)) ...) Un gfp(X) ***)
    7.78 +
    7.79 +val [prem] = goal Gfp.thy "mono(f) ==> mono(%x.f(x) Un X Un B)";
    7.80 +by (REPEAT (ares_tac [subset_refl, monoI, Un_mono, prem RS monoD] 1));
    7.81 +qed "coinduct3_mono_lemma";
    7.82 +
    7.83 +val [prem,mono] = goal Gfp.thy
    7.84 +    "[| X <= f(lfp(%x.f(x) Un X Un gfp(f)));  mono(f) |] ==> \
    7.85 +\    lfp(%x.f(x) Un X Un gfp(f)) <= f(lfp(%x.f(x) Un X Un gfp(f)))";
    7.86 +by (rtac subset_trans 1);
    7.87 +by (rtac (mono RS coinduct3_mono_lemma RS lfp_lemma3) 1);
    7.88 +by (rtac (Un_least RS Un_least) 1);
    7.89 +by (rtac subset_refl 1);
    7.90 +by (rtac prem 1);
    7.91 +by (rtac (mono RS gfp_Tarski RS equalityD1 RS subset_trans) 1);
    7.92 +by (rtac (mono RS monoD) 1);
    7.93 +by (rtac (mono RS coinduct3_mono_lemma RS lfp_Tarski RS ssubst) 1);
    7.94 +by (rtac Un_upper2 1);
    7.95 +qed "coinduct3_lemma";
    7.96 +
    7.97 +val prems = goal Gfp.thy
    7.98 +    "[| mono(f);  a:X;  X <= f(lfp(%x.f(x) Un X Un gfp(f))) |] ==> a : gfp(f)";
    7.99 +by (rtac (coinduct3_lemma RSN (2,weak_coinduct)) 1);
   7.100 +by (resolve_tac (prems RL [coinduct3_mono_lemma RS lfp_Tarski RS ssubst]) 1);
   7.101 +by (rtac (UnI2 RS UnI1) 1);
   7.102 +by (REPEAT (resolve_tac prems 1));
   7.103 +qed "coinduct3";
   7.104 +
   7.105 +
   7.106 +(** Definition forms of gfp_Tarski and coinduct, to control unfolding **)
   7.107 +
   7.108 +val [rew,mono] = goal Gfp.thy "[| A==gfp(f);  mono(f) |] ==> A = f(A)";
   7.109 +by (rewtac rew);
   7.110 +by (rtac (mono RS gfp_Tarski) 1);
   7.111 +qed "def_gfp_Tarski";
   7.112 +
   7.113 +val rew::prems = goal Gfp.thy
   7.114 +    "[| A==gfp(f);  mono(f);  a:X;  X <= f(X Un A) |] ==> a: A";
   7.115 +by (rewtac rew);
   7.116 +by (REPEAT (ares_tac (map (rewrite_rule [rew]) prems @ [coinduct]) 1));
   7.117 +qed "def_coinduct";
   7.118 +
   7.119 +(*The version used in the induction/coinduction package*)
   7.120 +val prems = goal Gfp.thy
   7.121 +    "[| A == gfp(%w. Collect(P(w)));  mono(%w. Collect(P(w)));  \
   7.122 +\       a: X;  !!z. z: X ==> P (X Un A) z |] ==> \
   7.123 +\    a : A";
   7.124 +by (rtac def_coinduct 1);
   7.125 +by (REPEAT (ares_tac (prems @ [subsetI,CollectI]) 1));
   7.126 +qed "def_Collect_coinduct";
   7.127 +
   7.128 +val rew::prems = goal Gfp.thy
   7.129 +    "[| A==gfp(f); mono(f);  a:X;  X <= f(lfp(%x.f(x) Un X Un A)) |] ==> a: A";
   7.130 +by (rewtac rew);
   7.131 +by (REPEAT (ares_tac (map (rewrite_rule [rew]) prems @ [coinduct3]) 1));
   7.132 +qed "def_coinduct3";
   7.133 +
   7.134 +(*Monotonicity of gfp!*)
   7.135 +val prems = goal Gfp.thy
   7.136 +    "[| mono(f);  !!Z. f(Z)<=g(Z) |] ==> gfp(f) <= gfp(g)";
   7.137 +by (rtac gfp_upperbound 1);
   7.138 +by (rtac subset_trans 1);
   7.139 +by (rtac gfp_lemma2 1);
   7.140 +by (resolve_tac prems 1);
   7.141 +by (resolve_tac prems 1);
   7.142 +val gfp_mono = result();
   7.143 +
   7.144 +(*Monotonicity of gfp!*)
   7.145 +val [prem] = goal Gfp.thy "[| !!Z. f(Z)<=g(Z) |] ==> gfp(f) <= gfp(g)";
   7.146 +br (gfp_upperbound RS gfp_least) 1;
   7.147 +be (prem RSN (2,subset_trans)) 1;
   7.148 +qed "gfp_mono";
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Gfp.thy	Fri Mar 03 12:02:25 1995 +0100
     8.3 @@ -0,0 +1,14 @@
     8.4 +(*  Title: 	HOL/gfp.thy
     8.5 +    ID:         $Id$
     8.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
     8.7 +    Copyright   1994  University of Cambridge
     8.8 +
     8.9 +Greatest fixed points (requires Lfp too!)
    8.10 +*)
    8.11 +
    8.12 +Gfp = Lfp +
    8.13 +consts gfp :: "['a set=>'a set] => 'a set"
    8.14 +defs
    8.15 + (*greatest fixed point*)
    8.16 + gfp_def "gfp(f) == Union({u. u <= f(u)})"
    8.17 +end
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/HOL.ML	Fri Mar 03 12:02:25 1995 +0100
     9.3 @@ -0,0 +1,266 @@
     9.4 +(*  Title: 	HOL/hol.ML
     9.5 +    ID:         $Id$
     9.6 +    Author: 	Tobias Nipkow
     9.7 +    Copyright   1991  University of Cambridge
     9.8 +
     9.9 +For hol.thy
    9.10 +Derived rules from Appendix of Mike Gordons HOL Report, Cambridge TR 68 
    9.11 +*)
    9.12 +
    9.13 +open HOL;
    9.14 +
    9.15 +
    9.16 +(** Equality **)
    9.17 +
    9.18 +qed_goal "sym" HOL.thy "s=t ==> t=s"
    9.19 + (fn prems => [cut_facts_tac prems 1, etac subst 1, rtac refl 1]);
    9.20 +
    9.21 +(*calling "standard" reduces maxidx to 0*)
    9.22 +bind_thm ("ssubst", (sym RS subst));
    9.23 +
    9.24 +qed_goal "trans" HOL.thy "[| r=s; s=t |] ==> r=t"
    9.25 + (fn prems =>
    9.26 +	[rtac subst 1, resolve_tac prems 1, resolve_tac prems 1]);
    9.27 +
    9.28 +(*Useful with eresolve_tac for proving equalties from known equalities.
    9.29 +	a = b
    9.30 +	|   |
    9.31 +	c = d	*)
    9.32 +qed_goal "box_equals" HOL.thy
    9.33 +    "[| a=b;  a=c;  b=d |] ==> c=d"  
    9.34 + (fn prems=>
    9.35 +  [ (rtac trans 1),
    9.36 +    (rtac trans 1),
    9.37 +    (rtac sym 1),
    9.38 +    (REPEAT (resolve_tac prems 1)) ]);
    9.39 +
    9.40 +(** Congruence rules for meta-application **)
    9.41 +
    9.42 +(*similar to AP_THM in Gordon's HOL*)
    9.43 +qed_goal "fun_cong" HOL.thy "(f::'a=>'b) = g ==> f(x)=g(x)"
    9.44 +  (fn [prem] => [rtac (prem RS subst) 1, rtac refl 1]);
    9.45 +
    9.46 +(*similar to AP_TERM in Gordon's HOL and FOL's subst_context*)
    9.47 +qed_goal "arg_cong" HOL.thy "x=y ==> f(x)=f(y)"
    9.48 + (fn [prem] => [rtac (prem RS subst) 1, rtac refl 1]);
    9.49 +
    9.50 +qed_goal "cong" HOL.thy
    9.51 +   "[| f = g; (x::'a) = y |] ==> f(x) = g(y)"
    9.52 + (fn [prem1,prem2] =>
    9.53 +   [rtac (prem1 RS subst) 1, rtac (prem2 RS subst) 1, rtac refl 1]);
    9.54 +
    9.55 +(** Equality of booleans -- iff **)
    9.56 +
    9.57 +qed_goal "iffI" HOL.thy
    9.58 +   "[| P ==> Q;  Q ==> P |] ==> P=Q"
    9.59 + (fn prems=> [ (REPEAT (ares_tac (prems@[impI, iff RS mp RS mp]) 1)) ]);
    9.60 +
    9.61 +qed_goal "iffD2" HOL.thy "[| P=Q; Q |] ==> P"
    9.62 + (fn prems =>
    9.63 +	[rtac ssubst 1, resolve_tac prems 1, resolve_tac prems 1]);
    9.64 +
    9.65 +val iffD1 = sym RS iffD2;
    9.66 +
    9.67 +qed_goal "iffE" HOL.thy
    9.68 +    "[| P=Q; [| P --> Q; Q --> P |] ==> R |] ==> R"
    9.69 + (fn [p1,p2] => [REPEAT(ares_tac([p1 RS iffD2, p1 RS iffD1, p2, impI])1)]);
    9.70 +
    9.71 +(** True **)
    9.72 +
    9.73 +qed_goalw "TrueI" HOL.thy [True_def] "True"
    9.74 +  (fn _ => [rtac refl 1]);
    9.75 +
    9.76 +qed_goal "eqTrueI " HOL.thy "P ==> P=True" 
    9.77 + (fn prems => [REPEAT(resolve_tac ([iffI,TrueI]@prems) 1)]);
    9.78 +
    9.79 +qed_goal "eqTrueE" HOL.thy "P=True ==> P" 
    9.80 + (fn prems => [REPEAT(resolve_tac (prems@[TrueI,iffD2]) 1)]);
    9.81 +
    9.82 +(** Universal quantifier **)
    9.83 +
    9.84 +qed_goalw "allI" HOL.thy [All_def] "(!!x::'a. P(x)) ==> !x. P(x)"
    9.85 + (fn prems => [resolve_tac (prems RL [eqTrueI RS ext]) 1]);
    9.86 +
    9.87 +qed_goalw "spec" HOL.thy [All_def] "! x::'a.P(x) ==> P(x)"
    9.88 + (fn prems => [rtac eqTrueE 1, resolve_tac (prems RL [fun_cong]) 1]);
    9.89 +
    9.90 +qed_goal "allE" HOL.thy "[| !x.P(x);  P(x) ==> R |] ==> R"
    9.91 + (fn major::prems=>
    9.92 +  [ (REPEAT (resolve_tac (prems @ [major RS spec]) 1)) ]);
    9.93 +
    9.94 +qed_goal "all_dupE" HOL.thy 
    9.95 +    "[| ! x.P(x);  [| P(x); ! x.P(x) |] ==> R |] ==> R"
    9.96 + (fn prems =>
    9.97 +  [ (REPEAT (resolve_tac (prems @ (prems RL [spec])) 1)) ]);
    9.98 +
    9.99 +
   9.100 +(** False ** Depends upon spec; it is impossible to do propositional logic
   9.101 +             before quantifiers! **)
   9.102 +
   9.103 +qed_goalw "FalseE" HOL.thy [False_def] "False ==> P"
   9.104 + (fn [major] => [rtac (major RS spec) 1]);
   9.105 +
   9.106 +qed_goal "False_neq_True" HOL.thy "False=True ==> P"
   9.107 + (fn [prem] => [rtac (prem RS eqTrueE RS FalseE) 1]);
   9.108 +
   9.109 +
   9.110 +(** Negation **)
   9.111 +
   9.112 +qed_goalw "notI" HOL.thy [not_def] "(P ==> False) ==> ~P"
   9.113 + (fn prems=> [rtac impI 1, eresolve_tac prems 1]);
   9.114 +
   9.115 +qed_goalw "notE" HOL.thy [not_def] "[| ~P;  P |] ==> R"
   9.116 + (fn prems => [rtac (prems MRS mp RS FalseE) 1]);
   9.117 +
   9.118 +(** Implication **)
   9.119 +
   9.120 +qed_goal "impE" HOL.thy "[| P-->Q;  P;  Q ==> R |] ==> R"
   9.121 + (fn prems=> [ (REPEAT (resolve_tac (prems@[mp]) 1)) ]);
   9.122 +
   9.123 +(* Reduces Q to P-->Q, allowing substitution in P. *)
   9.124 +qed_goal "rev_mp" HOL.thy "[| P;  P --> Q |] ==> Q"
   9.125 + (fn prems=>  [ (REPEAT (resolve_tac (prems@[mp]) 1)) ]);
   9.126 +
   9.127 +qed_goal "contrapos" HOL.thy "[| ~Q;  P==>Q |] ==> ~P"
   9.128 + (fn [major,minor]=> 
   9.129 +  [ (rtac (major RS notE RS notI) 1), 
   9.130 +    (etac minor 1) ]);
   9.131 +
   9.132 +(* ~(?t = ?s) ==> ~(?s = ?t) *)
   9.133 +val [not_sym] = compose(sym,2,contrapos);
   9.134 +
   9.135 +
   9.136 +(** Existential quantifier **)
   9.137 +
   9.138 +qed_goalw "exI" HOL.thy [Ex_def] "P(x) ==> ? x::'a.P(x)"
   9.139 + (fn prems => [rtac selectI 1, resolve_tac prems 1]);
   9.140 +
   9.141 +qed_goalw "exE" HOL.thy [Ex_def]
   9.142 +  "[| ? x::'a.P(x); !!x. P(x) ==> Q |] ==> Q"
   9.143 +  (fn prems => [REPEAT(resolve_tac prems 1)]);
   9.144 +
   9.145 +
   9.146 +(** Conjunction **)
   9.147 +
   9.148 +qed_goalw "conjI" HOL.thy [and_def] "[| P; Q |] ==> P&Q"
   9.149 + (fn prems =>
   9.150 +  [REPEAT (resolve_tac (prems@[allI,impI]) 1 ORELSE etac (mp RS mp) 1)]);
   9.151 +
   9.152 +qed_goalw "conjunct1" HOL.thy [and_def] "[| P & Q |] ==> P"
   9.153 + (fn prems =>
   9.154 +   [resolve_tac (prems RL [spec] RL [mp]) 1, REPEAT(ares_tac [impI] 1)]);
   9.155 +
   9.156 +qed_goalw "conjunct2" HOL.thy [and_def] "[| P & Q |] ==> Q"
   9.157 + (fn prems =>
   9.158 +   [resolve_tac (prems RL [spec] RL [mp]) 1, REPEAT(ares_tac [impI] 1)]);
   9.159 +
   9.160 +qed_goal "conjE" HOL.thy "[| P&Q;  [| P; Q |] ==> R |] ==> R"
   9.161 + (fn prems =>
   9.162 +	 [cut_facts_tac prems 1, resolve_tac prems 1,
   9.163 +	  etac conjunct1 1, etac conjunct2 1]);
   9.164 +
   9.165 +(** Disjunction *)
   9.166 +
   9.167 +qed_goalw "disjI1" HOL.thy [or_def] "P ==> P|Q"
   9.168 + (fn [prem] => [REPEAT(ares_tac [allI,impI, prem RSN (2,mp)] 1)]);
   9.169 +
   9.170 +qed_goalw "disjI2" HOL.thy [or_def] "Q ==> P|Q"
   9.171 + (fn [prem] => [REPEAT(ares_tac [allI,impI, prem RSN (2,mp)] 1)]);
   9.172 +
   9.173 +qed_goalw "disjE" HOL.thy [or_def] "[| P | Q; P ==> R; Q ==> R |] ==> R"
   9.174 + (fn [a1,a2,a3] =>
   9.175 +	[rtac (mp RS mp) 1, rtac spec 1, rtac a1 1,
   9.176 +	 rtac (a2 RS impI) 1, assume_tac 1, rtac (a3 RS impI) 1, assume_tac 1]);
   9.177 +
   9.178 +(** CCONTR -- classical logic **)
   9.179 +
   9.180 +qed_goalw "classical" HOL.thy [not_def]  "(~P ==> P) ==> P"
   9.181 + (fn [prem] =>
   9.182 +   [rtac (True_or_False RS (disjE RS eqTrueE)) 1,  assume_tac 1,
   9.183 +    rtac (impI RS prem RS eqTrueI) 1,
   9.184 +    etac subst 1,  assume_tac 1]);
   9.185 +
   9.186 +val ccontr = FalseE RS classical;
   9.187 +
   9.188 +(*Double negation law*)
   9.189 +qed_goal "notnotD" HOL.thy "~~P ==> P"
   9.190 + (fn [major]=>
   9.191 +  [ (rtac classical 1), (eresolve_tac [major RS notE] 1) ]);
   9.192 +
   9.193 +
   9.194 +(** Unique existence **)
   9.195 +
   9.196 +qed_goalw "ex1I" HOL.thy [Ex1_def]
   9.197 +    "[| P(a);  !!x. P(x) ==> x=a |] ==> ?! x. P(x)"
   9.198 + (fn prems =>
   9.199 +  [REPEAT (ares_tac (prems@[exI,conjI,allI,impI]) 1)]);
   9.200 +
   9.201 +qed_goalw "ex1E" HOL.thy [Ex1_def]
   9.202 +    "[| ?! x.P(x);  !!x. [| P(x);  ! y. P(y) --> y=x |] ==> R |] ==> R"
   9.203 + (fn major::prems =>
   9.204 +  [rtac (major RS exE) 1, REPEAT (etac conjE 1 ORELSE ares_tac prems 1)]);
   9.205 +
   9.206 +
   9.207 +(** Select: Hilbert's Epsilon-operator **)
   9.208 +
   9.209 +(*Easier to apply than selectI: conclusion has only one occurrence of P*)
   9.210 +qed_goal "selectI2" HOL.thy
   9.211 +    "[| P(a);  !!x. P(x) ==> Q(x) |] ==> Q(@x.P(x))"
   9.212 + (fn prems => [ resolve_tac prems 1, 
   9.213 +	        rtac selectI 1, 
   9.214 +		resolve_tac prems 1 ]);
   9.215 +
   9.216 +qed_goal "select_equality" HOL.thy
   9.217 +    "[| P(a);  !!x. P(x) ==> x=a |] ==> (@x.P(x)) = a"
   9.218 + (fn prems => [ rtac selectI2 1, 
   9.219 +		REPEAT (ares_tac prems 1) ]);
   9.220 +
   9.221 +
   9.222 +(** Classical intro rules for disjunction and existential quantifiers *)
   9.223 +
   9.224 +qed_goal "disjCI" HOL.thy "(~Q ==> P) ==> P|Q"
   9.225 + (fn prems=>
   9.226 +  [ (rtac classical 1),
   9.227 +    (REPEAT (ares_tac (prems@[disjI1,notI]) 1)),
   9.228 +    (REPEAT (ares_tac (prems@[disjI2,notE]) 1)) ]);
   9.229 +
   9.230 +qed_goal "excluded_middle" HOL.thy "~P | P"
   9.231 + (fn _ => [ (REPEAT (ares_tac [disjCI] 1)) ]);
   9.232 +
   9.233 +(*For disjunctive case analysis*)
   9.234 +fun excluded_middle_tac sP =
   9.235 +    res_inst_tac [("Q",sP)] (excluded_middle RS disjE);
   9.236 +
   9.237 +(*Classical implies (-->) elimination. *)
   9.238 +qed_goal "impCE" HOL.thy "[| P-->Q; ~P ==> R; Q ==> R |] ==> R" 
   9.239 + (fn major::prems=>
   9.240 +  [ rtac (excluded_middle RS disjE) 1,
   9.241 +    REPEAT (DEPTH_SOLVE_1 (ares_tac (prems @ [major RS mp]) 1))]);
   9.242 +
   9.243 +(*Classical <-> elimination. *)
   9.244 +qed_goal "iffCE" HOL.thy
   9.245 +    "[| P=Q;  [| P; Q |] ==> R;  [| ~P; ~Q |] ==> R |] ==> R"
   9.246 + (fn major::prems =>
   9.247 +  [ (rtac (major RS iffE) 1),
   9.248 +    (REPEAT (DEPTH_SOLVE_1 
   9.249 +	(eresolve_tac ([asm_rl,impCE,notE]@prems) 1))) ]);
   9.250 +
   9.251 +qed_goal "exCI" HOL.thy "(! x. ~P(x) ==> P(a)) ==> ? x.P(x)"
   9.252 + (fn prems=>
   9.253 +  [ (rtac ccontr 1),
   9.254 +    (REPEAT (ares_tac (prems@[exI,allI,notI,notE]) 1))  ]);
   9.255 +
   9.256 +
   9.257 +(* case distinction *)
   9.258 +
   9.259 +qed_goal "case_split_thm" HOL.thy "[| P ==> Q; ~P ==> Q |] ==> Q"
   9.260 +  (fn [p1,p2] => [cut_facts_tac [excluded_middle] 1, etac disjE 1,
   9.261 +                  etac p2 1, etac p1 1]);
   9.262 +
   9.263 +fun case_tac a = res_inst_tac [("P",a)] case_split_thm;
   9.264 +
   9.265 +(** Standard abbreviations **)
   9.266 +
   9.267 +fun stac th = rtac(th RS ssubst);
   9.268 +fun sstac ths = EVERY' (map stac ths);
   9.269 +fun strip_tac i = REPEAT(resolve_tac [impI,allI] i); 
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/HOL.thy	Fri Mar 03 12:02:25 1995 +0100
    10.3 @@ -0,0 +1,165 @@
    10.4 +(*  Title:      HOL/HOL.thy
    10.5 +    ID:         $Id$
    10.6 +    Author:     Tobias Nipkow
    10.7 +    Copyright   1993  University of Cambridge
    10.8 +
    10.9 +Higher-Order Logic
   10.10 +*)
   10.11 +
   10.12 +HOL = CPure +
   10.13 +
   10.14 +classes
   10.15 +  term < logic
   10.16 +
   10.17 +axclass
   10.18 +  plus < term
   10.19 +
   10.20 +axclass
   10.21 +  minus < term
   10.22 +
   10.23 +axclass
   10.24 +  times < term
   10.25 +
   10.26 +default
   10.27 +  term
   10.28 +
   10.29 +types
   10.30 +  bool
   10.31 +
   10.32 +arities
   10.33 +  fun :: (term, term) term
   10.34 +  bool :: term
   10.35 +
   10.36 +
   10.37 +consts
   10.38 +
   10.39 +  (* Constants *)
   10.40 +
   10.41 +  Trueprop      :: "bool => prop"                     ("(_)" 5)
   10.42 +  not           :: "bool => bool"                     ("~ _" [40] 40)
   10.43 +  True, False   :: "bool"
   10.44 +  if            :: "[bool, 'a, 'a] => 'a"
   10.45 +  Inv           :: "('a => 'b) => ('b => 'a)"
   10.46 +
   10.47 +  (* Binders *)
   10.48 +
   10.49 +  Eps           :: "('a => bool) => 'a"               (binder "@" 10)
   10.50 +  All           :: "('a => bool) => bool"             (binder "! " 10)
   10.51 +  Ex            :: "('a => bool) => bool"             (binder "? " 10)
   10.52 +  Ex1           :: "('a => bool) => bool"             (binder "?! " 10)
   10.53 +  Let           :: "['a, 'a => 'b] => 'b"
   10.54 +
   10.55 +  (* Infixes *)
   10.56 +
   10.57 +  o             :: "['b => 'c, 'a => 'b, 'a] => 'c"   (infixr 50)
   10.58 +  "="           :: "['a, 'a] => bool"                 (infixl 50)
   10.59 +(*"~="          :: "['a, 'a] => bool"                 (infixl 50)*)
   10.60 +  "&"           :: "[bool, bool] => bool"             (infixr 35)
   10.61 +  "|"           :: "[bool, bool] => bool"             (infixr 30)
   10.62 +  "-->"         :: "[bool, bool] => bool"             (infixr 25)
   10.63 +
   10.64 +  (* Overloaded Constants *)
   10.65 +
   10.66 +  "+"           :: "['a::plus, 'a] => 'a"             (infixl 65)
   10.67 +  "-"           :: "['a::minus, 'a] => 'a"            (infixl 65)
   10.68 +  "*"           :: "['a::times, 'a] => 'a"            (infixl 70)
   10.69 +
   10.70 +
   10.71 +types
   10.72 +  letbinds  letbind
   10.73 +  case_syn  cases_syn
   10.74 +
   10.75 +syntax
   10.76 +
   10.77 +  "~="          :: "['a, 'a] => bool"                 (infixl 50)
   10.78 +
   10.79 +  (* Alternative Quantifiers *)
   10.80 +
   10.81 +  "*All"        :: "[idts, bool] => bool"             ("(3ALL _./ _)" 10)
   10.82 +  "*Ex"         :: "[idts, bool] => bool"             ("(3EX _./ _)" 10)
   10.83 +  "*Ex1"        :: "[idts, bool] => bool"             ("(3EX! _./ _)" 10)
   10.84 +
   10.85 +  (* Let expressions *)
   10.86 +
   10.87 +  "_bind"       :: "[idt, 'a] => letbind"             ("(2_ =/ _)" 10)
   10.88 +  ""            :: "letbind => letbinds"              ("_")
   10.89 +  "_binds"      :: "[letbind, letbinds] => letbinds"  ("_;/ _")
   10.90 +  "_Let"        :: "[letbinds, 'a] => 'a"             ("(let (_)/ in (_))" 10)
   10.91 +
   10.92 +  (* Case expressions *)
   10.93 +
   10.94 +  "@case"       :: "['a, cases_syn] => 'b"            ("(case _ of/ _)" 10)
   10.95 +  "@case1"      :: "['a, 'b] => case_syn"             ("(2_ =>/ _)" 10)
   10.96 +  ""            :: "case_syn => cases_syn"            ("_")
   10.97 +  "@case2"      :: "[case_syn, cases_syn] => cases_syn"   ("_/ | _")
   10.98 +
   10.99 +translations
  10.100 +  "x ~= y"      == "~ (x = y)"
  10.101 +  "ALL xs. P"   => "! xs. P"
  10.102 +  "EX xs. P"    => "? xs. P"
  10.103 +  "EX! xs. P"   => "?! xs. P"
  10.104 +  "_Let (_binds b bs) e"  == "_Let b (_Let bs e)"
  10.105 +  "let x = a in e"          == "Let a (%x. e)"
  10.106 +
  10.107 +
  10.108 +rules
  10.109 +
  10.110 +  eq_reflection "(x=y) ==> (x==y)"
  10.111 +
  10.112 +  (* Basic Rules *)
  10.113 +
  10.114 +  refl          "t = (t::'a)"
  10.115 +  subst         "[| s = t; P(s) |] ==> P(t::'a)"
  10.116 +  ext           "(!!x::'a. (f(x)::'b) = g(x)) ==> (%x.f(x)) = (%x.g(x))"
  10.117 +  selectI       "P(x::'a) ==> P(@x.P(x))"
  10.118 +
  10.119 +  impI          "(P ==> Q) ==> P-->Q"
  10.120 +  mp            "[| P-->Q;  P |] ==> Q"
  10.121 +
  10.122 +defs
  10.123 +
  10.124 +  True_def      "True      == ((%x::bool.x)=(%x.x))"
  10.125 +  All_def       "All(P)    == (P = (%x.True))"
  10.126 +  Ex_def        "Ex(P)     == P(@x.P(x))"
  10.127 +  False_def     "False     == (!P.P)"
  10.128 +  not_def       "~ P       == P-->False"
  10.129 +  and_def       "P & Q     == !R. (P-->Q-->R) --> R"
  10.130 +  or_def        "P | Q     == !R. (P-->R) --> (Q-->R) --> R"
  10.131 +  Ex1_def       "Ex1(P)    == ? x. P(x) & (! y. P(y) --> y=x)"
  10.132 +
  10.133 +rules
  10.134 +  (* Axioms *)
  10.135 +
  10.136 +  iff           "(P-->Q) --> (Q-->P) --> (P=Q)"
  10.137 +  True_or_False "(P=True) | (P=False)"
  10.138 +
  10.139 +defs
  10.140 +  (* Misc Definitions *)
  10.141 +
  10.142 +  Let_def       "Let s f == f(s)"
  10.143 +  Inv_def       "Inv(f::'a=>'b)  == (% y. @x. f(x)=y)"
  10.144 +  o_def         "(f::'b=>'c) o g == (%(x::'a). f(g(x)))"
  10.145 +  if_def        "if P x y == @z::'a. (P=True --> z=x) & (P=False --> z=y)"
  10.146 +
  10.147 +end
  10.148 +
  10.149 +
  10.150 +ML
  10.151 +
  10.152 +(** Choice between the HOL and Isabelle style of quantifiers **)
  10.153 +
  10.154 +val HOL_quantifiers = ref true;
  10.155 +
  10.156 +fun alt_ast_tr' (name, alt_name) =
  10.157 +  let
  10.158 +    fun ast_tr' (*name*) args =
  10.159 +      if ! HOL_quantifiers then raise Match
  10.160 +      else Syntax.mk_appl (Syntax.Constant alt_name) args;
  10.161 +  in
  10.162 +    (name, ast_tr')
  10.163 +  end;
  10.164 +
  10.165 +
  10.166 +val print_ast_translation =
  10.167 +  map alt_ast_tr' [("! ", "*All"), ("? ", "*Ex"), ("?! ", "*Ex1")];
  10.168 +
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/Inductive.ML	Fri Mar 03 12:02:25 1995 +0100
    11.3 @@ -0,0 +1,94 @@
    11.4 +(*  Title: 	HOL/inductive.ML
    11.5 +    ID:         $Id$
    11.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    11.7 +    Copyright   1993  University of Cambridge
    11.8 +
    11.9 +(Co)Inductive Definitions for HOL
   11.10 +
   11.11 +Inductive definitions use least fixedpoints with standard products and sums
   11.12 +Coinductive definitions use greatest fixedpoints with Quine products and sums
   11.13 +
   11.14 +Sums are used only for mutual recursion;
   11.15 +Products are used only to derive "streamlined" induction rules for relations
   11.16 +*)
   11.17 +
   11.18 +local open Ind_Syntax
   11.19 +in
   11.20 +
   11.21 +fun gen_fp_oper a (X,T,t) = 
   11.22 +    let val setT = mk_setT T
   11.23 +    in Const(a, (setT-->setT)-->setT) $ absfree(X, setT, t)  end;
   11.24 +
   11.25 +structure Lfp_items =
   11.26 +  struct
   11.27 +  val oper	= gen_fp_oper "lfp"
   11.28 +  val Tarski	= def_lfp_Tarski
   11.29 +  val induct	= def_induct
   11.30 +  end;
   11.31 +
   11.32 +structure Gfp_items =
   11.33 +  struct
   11.34 +  val oper	= gen_fp_oper "gfp"
   11.35 +  val Tarski	= def_gfp_Tarski
   11.36 +  val induct	= def_Collect_coinduct
   11.37 +  end;
   11.38 +
   11.39 +end;
   11.40 +
   11.41 +
   11.42 +functor Ind_section_Fun (Inductive: sig include INDUCTIVE_ARG INDUCTIVE_I end) 
   11.43 +  : sig include INTR_ELIM INDRULE end =
   11.44 +struct
   11.45 +structure Intr_elim = Intr_elim_Fun(structure Inductive=Inductive and 
   11.46 +				    Fp=Lfp_items);
   11.47 +
   11.48 +structure Indrule = Indrule_Fun
   11.49 +    (structure Inductive=Inductive and Intr_elim=Intr_elim);
   11.50 +
   11.51 +open Intr_elim Indrule
   11.52 +end;
   11.53 +
   11.54 +
   11.55 +structure Ind = Add_inductive_def_Fun (Lfp_items);
   11.56 +
   11.57 +
   11.58 +signature INDUCTIVE_STRING =
   11.59 +  sig
   11.60 +  val thy_name   : string 		(*name of the new theory*)
   11.61 +  val srec_tms   : string list		(*recursion terms*)
   11.62 +  val sintrs     : string list		(*desired introduction rules*)
   11.63 +  end;
   11.64 +
   11.65 +
   11.66 +(*For upwards compatibility: can be called directly from ML*)
   11.67 +functor Inductive_Fun
   11.68 + (Inductive: sig include INDUCTIVE_STRING INDUCTIVE_ARG end)
   11.69 +   : sig include INTR_ELIM INDRULE end =
   11.70 +Ind_section_Fun
   11.71 +   (open Inductive Ind_Syntax
   11.72 +    val sign = sign_of thy;
   11.73 +    val rec_tms = map (readtm sign termTVar) srec_tms
   11.74 +    and intr_tms = map (readtm sign propT) sintrs;
   11.75 +    val thy = thy |> Ind.add_fp_def_i(rec_tms, intr_tms) 
   11.76 +                  |> add_thyname thy_name);
   11.77 +
   11.78 +
   11.79 +
   11.80 +signature COINDRULE =
   11.81 +  sig
   11.82 +  val coinduct : thm
   11.83 +  end;
   11.84 +
   11.85 +
   11.86 +functor CoInd_section_Fun
   11.87 + (Inductive: sig include INDUCTIVE_ARG INDUCTIVE_I end) 
   11.88 +    : sig include INTR_ELIM COINDRULE end =
   11.89 +struct
   11.90 +structure Intr_elim = Intr_elim_Fun(structure Inductive=Inductive and Fp=Gfp_items);
   11.91 +
   11.92 +open Intr_elim 
   11.93 +val coinduct = raw_induct
   11.94 +end;
   11.95 +
   11.96 +
   11.97 +structure CoInd = Add_inductive_def_Fun(Gfp_items);
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Inductive.thy	Fri Mar 03 12:02:25 1995 +0100
    12.3 @@ -0,0 +1,1 @@
    12.4 +Inductive = Gfp + Prod
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOL/Lfp.ML	Fri Mar 03 12:02:25 1995 +0100
    13.3 @@ -0,0 +1,74 @@
    13.4 +(*  Title: 	HOL/lfp.ML
    13.5 +    ID:         $Id$
    13.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    13.7 +    Copyright   1992  University of Cambridge
    13.8 +
    13.9 +For lfp.thy.  The Knaster-Tarski Theorem
   13.10 +*)
   13.11 +
   13.12 +open Lfp;
   13.13 +
   13.14 +(*** Proof of Knaster-Tarski Theorem ***)
   13.15 +
   13.16 +(* lfp(f) is the greatest lower bound of {u. f(u) <= u} *)
   13.17 +
   13.18 +val prems = goalw Lfp.thy [lfp_def] "[| f(A) <= A |] ==> lfp(f) <= A";
   13.19 +by (rtac (CollectI RS Inter_lower) 1);
   13.20 +by (resolve_tac prems 1);
   13.21 +qed "lfp_lowerbound";
   13.22 +
   13.23 +val prems = goalw Lfp.thy [lfp_def]
   13.24 +    "[| !!u. f(u) <= u ==> A<=u |] ==> A <= lfp(f)";
   13.25 +by (REPEAT (ares_tac ([Inter_greatest]@prems) 1));
   13.26 +by (etac CollectD 1);
   13.27 +qed "lfp_greatest";
   13.28 +
   13.29 +val [mono] = goal Lfp.thy "mono(f) ==> f(lfp(f)) <= lfp(f)";
   13.30 +by (EVERY1 [rtac lfp_greatest, rtac subset_trans,
   13.31 +	    rtac (mono RS monoD), rtac lfp_lowerbound, atac, atac]);
   13.32 +qed "lfp_lemma2";
   13.33 +
   13.34 +val [mono] = goal Lfp.thy "mono(f) ==> lfp(f) <= f(lfp(f))";
   13.35 +by (EVERY1 [rtac lfp_lowerbound, rtac (mono RS monoD), 
   13.36 +	    rtac lfp_lemma2, rtac mono]);
   13.37 +qed "lfp_lemma3";
   13.38 +
   13.39 +val [mono] = goal Lfp.thy "mono(f) ==> lfp(f) = f(lfp(f))";
   13.40 +by (REPEAT (resolve_tac [equalityI,lfp_lemma2,lfp_lemma3,mono] 1));
   13.41 +qed "lfp_Tarski";
   13.42 +
   13.43 +
   13.44 +(*** General induction rule for least fixed points ***)
   13.45 +
   13.46 +val [lfp,mono,indhyp] = goal Lfp.thy
   13.47 +    "[| a: lfp(f);  mono(f);  				\
   13.48 +\       !!x. [| x: f(lfp(f) Int {x.P(x)}) |] ==> P(x) 	\
   13.49 +\    |] ==> P(a)";
   13.50 +by (res_inst_tac [("a","a")] (Int_lower2 RS subsetD RS CollectD) 1);
   13.51 +by (rtac (lfp RSN (2, lfp_lowerbound RS subsetD)) 1);
   13.52 +by (EVERY1 [rtac Int_greatest, rtac subset_trans, 
   13.53 +	    rtac (Int_lower1 RS (mono RS monoD)),
   13.54 +	    rtac (mono RS lfp_lemma2),
   13.55 +	    rtac (CollectI RS subsetI), rtac indhyp, atac]);
   13.56 +qed "induct";
   13.57 +
   13.58 +(** Definition forms of lfp_Tarski and induct, to control unfolding **)
   13.59 +
   13.60 +val [rew,mono] = goal Lfp.thy "[| h==lfp(f);  mono(f) |] ==> h = f(h)";
   13.61 +by (rewtac rew);
   13.62 +by (rtac (mono RS lfp_Tarski) 1);
   13.63 +qed "def_lfp_Tarski";
   13.64 +
   13.65 +val rew::prems = goal Lfp.thy
   13.66 +    "[| A == lfp(f);  mono(f);   a:A;  			\
   13.67 +\       !!x. [| x: f(A Int {x.P(x)}) |] ==> P(x) 	\
   13.68 +\    |] ==> P(a)";
   13.69 +by (EVERY1 [rtac induct,	(*backtracking to force correct induction*)
   13.70 +	    REPEAT1 o (ares_tac (map (rewrite_rule [rew]) prems))]);
   13.71 +qed "def_induct";
   13.72 +
   13.73 +(*Monotonicity of lfp!*)
   13.74 +val [prem] = goal Lfp.thy "[| !!Z. f(Z)<=g(Z) |] ==> lfp(f) <= lfp(g)";
   13.75 +br (lfp_lowerbound RS lfp_greatest) 1;
   13.76 +be (prem RS subset_trans) 1;
   13.77 +qed "lfp_mono";
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/Lfp.thy	Fri Mar 03 12:02:25 1995 +0100
    14.3 @@ -0,0 +1,14 @@
    14.4 +(*  Title: 	HOL/lfp.thy
    14.5 +    ID:         $Id$
    14.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    14.7 +    Copyright   1992  University of Cambridge
    14.8 +
    14.9 +The Knaster-Tarski Theorem
   14.10 +*)
   14.11 +
   14.12 +Lfp = mono + 
   14.13 +consts lfp :: "['a set=>'a set] => 'a set"
   14.14 +defs
   14.15 + (*least fixed point*)
   14.16 + lfp_def "lfp(f) == Inter({u. f(u) <= u})"
   14.17 +end
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/List.ML	Fri Mar 03 12:02:25 1995 +0100
    15.3 @@ -0,0 +1,148 @@
    15.4 +(*  Title: 	HOL/List
    15.5 +    ID:         $Id$
    15.6 +    Author: 	Tobias Nipkow
    15.7 +    Copyright   1994 TU Muenchen
    15.8 +
    15.9 +List lemmas
   15.10 +*)
   15.11 +
   15.12 +open List;
   15.13 +
   15.14 +val [Nil_not_Cons,Cons_not_Nil] = list.distinct;
   15.15 +
   15.16 +bind_thm("Cons_neq_Nil", Cons_not_Nil RS notE);
   15.17 +bind_thm("Nil_neq_Cons", sym RS Cons_neq_Nil);
   15.18 +
   15.19 +bind_thm("Cons_inject", (hd list.inject) RS iffD1 RS conjE);
   15.20 +
   15.21 +val list_ss = HOL_ss addsimps list.simps;
   15.22 +
   15.23 +goal List.thy "!x. xs ~= x#xs";
   15.24 +by (list.induct_tac "xs" 1);
   15.25 +by (ALLGOALS (asm_simp_tac list_ss));
   15.26 +qed "not_Cons_self";
   15.27 +
   15.28 +goal List.thy "(xs ~= []) = (? y ys. xs = y#ys)";
   15.29 +by (list.induct_tac "xs" 1);
   15.30 +by(simp_tac list_ss 1);
   15.31 +by(asm_simp_tac list_ss 1);
   15.32 +by(REPEAT(resolve_tac [exI,refl,conjI] 1));
   15.33 +qed "neq_Nil_conv";
   15.34 +
   15.35 +val list_ss = arith_ss addsimps list.simps @
   15.36 +  [null_Nil, null_Cons, hd_Cons, tl_Cons, ttl_Nil, ttl_Cons,
   15.37 +   mem_Nil, mem_Cons,
   15.38 +   append_Nil, append_Cons,
   15.39 +   map_Nil, map_Cons,
   15.40 +   flat_Nil, flat_Cons,
   15.41 +   list_all_Nil, list_all_Cons,
   15.42 +   filter_Nil, filter_Cons];
   15.43 +
   15.44 +
   15.45 +(** @ - append **)
   15.46 +
   15.47 +goal List.thy "(xs@ys)@zs = xs@(ys@zs)";
   15.48 +by (list.induct_tac "xs" 1);
   15.49 +by(ALLGOALS(asm_simp_tac list_ss));
   15.50 +qed "append_assoc";
   15.51 +
   15.52 +goal List.thy "xs @ [] = xs";
   15.53 +by (list.induct_tac "xs" 1);
   15.54 +by(ALLGOALS(asm_simp_tac list_ss));
   15.55 +qed "append_Nil2";
   15.56 +
   15.57 +goal List.thy "(xs@ys = []) = (xs=[] & ys=[])";
   15.58 +by (list.induct_tac "xs" 1);
   15.59 +by(ALLGOALS(asm_simp_tac list_ss));
   15.60 +qed "append_is_Nil";
   15.61 +
   15.62 +goal List.thy "(xs @ ys = xs @ zs) = (ys=zs)";
   15.63 +by (list.induct_tac "xs" 1);
   15.64 +by(ALLGOALS(asm_simp_tac list_ss));
   15.65 +qed "same_append_eq";
   15.66 +
   15.67 +
   15.68 +(** mem **)
   15.69 +
   15.70 +goal List.thy "x mem (xs@ys) = (x mem xs | x mem ys)";
   15.71 +by (list.induct_tac "xs" 1);
   15.72 +by(ALLGOALS(asm_simp_tac (list_ss setloop (split_tac [expand_if]))));
   15.73 +qed "mem_append";
   15.74 +
   15.75 +goal List.thy "x mem [x:xs.P(x)] = (x mem xs & P(x))";
   15.76 +by (list.induct_tac "xs" 1);
   15.77 +by(ALLGOALS(asm_simp_tac (list_ss setloop (split_tac [expand_if]))));
   15.78 +qed "mem_filter";
   15.79 +
   15.80 +(** list_all **)
   15.81 +
   15.82 +goal List.thy "(Alls x:xs.True) = True";
   15.83 +by (list.induct_tac "xs" 1);
   15.84 +by(ALLGOALS(asm_simp_tac list_ss));
   15.85 +qed "list_all_True";
   15.86 +
   15.87 +goal List.thy "list_all p (xs@ys) = (list_all p xs & list_all p ys)";
   15.88 +by (list.induct_tac "xs" 1);
   15.89 +by(ALLGOALS(asm_simp_tac list_ss));
   15.90 +qed "list_all_conj";
   15.91 +
   15.92 +goal List.thy "(Alls x:xs.P(x)) = (!x. x mem xs --> P(x))";
   15.93 +by (list.induct_tac "xs" 1);
   15.94 +by(ALLGOALS(asm_simp_tac (list_ss setloop (split_tac [expand_if]))));
   15.95 +by(fast_tac HOL_cs 1);
   15.96 +qed "list_all_mem_conv";
   15.97 +
   15.98 +
   15.99 +(** list_case **)
  15.100 +
  15.101 +goal List.thy
  15.102 + "P(list_case a f xs) = ((xs=[] --> P(a)) & \
  15.103 +\                         (!y ys. xs=y#ys --> P(f y ys)))";
  15.104 +by (list.induct_tac "xs" 1);
  15.105 +by(ALLGOALS(asm_simp_tac list_ss));
  15.106 +by(fast_tac HOL_cs 1);
  15.107 +qed "expand_list_case";
  15.108 +
  15.109 +goal List.thy  "(xs=[] --> P([])) & (!y ys. xs=y#ys --> P(y#ys)) --> P(xs)";
  15.110 +by(list.induct_tac "xs" 1);
  15.111 +by(fast_tac HOL_cs 1);
  15.112 +by(fast_tac HOL_cs 1);
  15.113 +bind_thm("list_eq_cases",
  15.114 +  impI RSN (2,allI RSN (2,allI RSN (2,impI RS (conjI RS (result() RS mp))))));
  15.115 +
  15.116 +(** flat **)
  15.117 +
  15.118 +goal List.thy  "flat(xs@ys) = flat(xs)@flat(ys)";
  15.119 +by (list.induct_tac "xs" 1);
  15.120 +by(ALLGOALS(asm_simp_tac (list_ss addsimps [append_assoc])));
  15.121 +qed"flat_append";
  15.122 +
  15.123 +(** nth **)
  15.124 +
  15.125 +val [nth_0,nth_Suc] = nat_recs nth_def; 
  15.126 +store_thm("nth_0",nth_0);
  15.127 +store_thm("nth_Suc",nth_Suc);
  15.128 +
  15.129 +(** Additional mapping lemmas **)
  15.130 +
  15.131 +goal List.thy "map (%x.x) xs = xs";
  15.132 +by (list.induct_tac "xs" 1);
  15.133 +by (ALLGOALS (asm_simp_tac list_ss));
  15.134 +qed "map_ident";
  15.135 +
  15.136 +goal List.thy "map f (xs@ys) = map f xs @ map f ys";
  15.137 +by (list.induct_tac "xs" 1);
  15.138 +by (ALLGOALS (asm_simp_tac list_ss));
  15.139 +qed "map_append";
  15.140 +
  15.141 +goalw List.thy [o_def] "map (f o g) xs = map f (map g xs)";
  15.142 +by (list.induct_tac "xs" 1);
  15.143 +by (ALLGOALS (asm_simp_tac list_ss));
  15.144 +qed "map_compose";
  15.145 +
  15.146 +val list_ss = list_ss addsimps
  15.147 +  [not_Cons_self, append_assoc, append_Nil2, append_is_Nil, same_append_eq,
  15.148 +   mem_append, mem_filter,
  15.149 +   map_ident, map_append, map_compose,
  15.150 +   flat_append, list_all_True, list_all_conj, nth_0, nth_Suc];
  15.151 +
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/List.thy	Fri Mar 03 12:02:25 1995 +0100
    16.3 @@ -0,0 +1,83 @@
    16.4 +(*  Title:      HOL/List.thy
    16.5 +    ID:         $Id$
    16.6 +    Author:     Tobias Nipkow
    16.7 +    Copyright   1994 TU Muenchen
    16.8 +
    16.9 +Definition of type 'a list as a datatype. This allows primrec to work.
   16.10 +
   16.11 +*)
   16.12 +
   16.13 +List = Arith +
   16.14 +
   16.15 +datatype 'a list = "[]" ("[]") | "#"('a,'a list) (infixr 65)
   16.16 +
   16.17 +consts
   16.18 +
   16.19 +  null      :: "'a list => bool"
   16.20 +  hd        :: "'a list => 'a"
   16.21 +  tl,ttl    :: "'a list => 'a list"
   16.22 +  mem       :: "['a, 'a list] => bool"			(infixl 55)
   16.23 +  list_all  :: "('a => bool) => ('a list => bool)"
   16.24 +  map       :: "('a=>'b) => ('a list => 'b list)"
   16.25 +  "@"	    :: "['a list, 'a list] => 'a list"		(infixr 65)
   16.26 +  filter    :: "['a => bool, 'a list] => 'a list"
   16.27 +  foldl     :: "[['b,'a] => 'b, 'b, 'a list] => 'b"
   16.28 +  length    :: "'a list => nat"
   16.29 +  flat      :: "'a list list => 'a list"
   16.30 +  nth       :: "[nat, 'a list] => 'a"
   16.31 +
   16.32 +syntax
   16.33 +  (* list Enumeration *)
   16.34 +  "@list"   :: "args => 'a list"                        ("[(_)]")
   16.35 +
   16.36 +  (* Special syntax for list_all and filter *)
   16.37 +  "@Alls"	:: "[idt, 'a list, bool] => bool"	("(2Alls _:_./ _)" 10)
   16.38 +  "@filter"	:: "[idt, 'a list, bool] => 'a list"	("(1[_:_ ./ _])")
   16.39 +
   16.40 +translations
   16.41 +  "[x, xs]"     == "x#[xs]"
   16.42 +  "[x]"         == "x#[]"
   16.43 +
   16.44 +  "[x:xs . P]"	== "filter (%x.P) xs"
   16.45 +  "Alls x:xs.P"	== "list_all (%x.P) xs"
   16.46 +
   16.47 +primrec null list
   16.48 +  null_Nil "null([]) = True"
   16.49 +  null_Cons "null(x#xs) = False"
   16.50 +primrec hd list
   16.51 +  hd_Nil  "hd([]) = (@x.False)"
   16.52 +  hd_Cons "hd(x#xs) = x"
   16.53 +primrec tl list
   16.54 +  tl_Nil  "tl([]) = (@x.False)"
   16.55 +  tl_Cons "tl(x#xs) = xs"
   16.56 +primrec ttl list
   16.57 +  (* a "total" version of tl: *)
   16.58 +  ttl_Nil  "ttl([]) = []"
   16.59 +  ttl_Cons "ttl(x#xs) = xs"
   16.60 +primrec "op mem" list
   16.61 +  mem_Nil  "x mem [] = False"
   16.62 +  mem_Cons "x mem (y#ys) = if (y=x) True (x mem ys)"
   16.63 +primrec list_all list
   16.64 +  list_all_Nil  "list_all P [] = True"
   16.65 +  list_all_Cons "list_all P (x#xs) = (P(x) & list_all P xs)"
   16.66 +primrec map list
   16.67 +  map_Nil  "map f [] = []"
   16.68 +  map_Cons "map f (x#xs) = f(x)#map f xs"
   16.69 +primrec "op @" list
   16.70 +  append_Nil  "[] @ ys = ys"
   16.71 +  append_Cons "(x#xs)@ys = x#(xs@ys)"
   16.72 +primrec filter list
   16.73 +  filter_Nil  "filter P [] = []"
   16.74 +  filter_Cons "filter P (x#xs) = if (P x) (x#filter P xs) (filter P xs)"
   16.75 +primrec foldl list
   16.76 +  foldl_Nil  "foldl f a [] = a"
   16.77 +  foldl_Cons "foldl f a (x#xs) = foldl f (f a x) xs"
   16.78 +primrec length list
   16.79 +  length_Nil  "length([]) = 0"
   16.80 +  length_Cons "length(x#xs) = Suc(length(xs))"
   16.81 +primrec flat list
   16.82 +  flat_Nil  "flat([]) = []"
   16.83 +  flat_Cons "flat(x#xs) = x @ flat(xs)"
   16.84 +defs
   16.85 +  nth_def "nth(n) == nat_rec n hd (%m r xs. r(tl(xs)))"
   16.86 +end
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/Makefile	Fri Mar 03 12:02:25 1995 +0100
    17.3 @@ -0,0 +1,114 @@
    17.4 +#########################################################################
    17.5 +#									#
    17.6 +# 			Makefile for Isabelle (CHOL)			#
    17.7 +#									#
    17.8 +#########################################################################
    17.9 +
   17.10 +#To make the system, cd to this directory and type  
   17.11 +#	make -f Makefile 
   17.12 +#To make the system and test it on standard examples, type  
   17.13 +#	make -f Makefile test
   17.14 +
   17.15 +#Environment variable ISABELLECOMP specifies the compiler.
   17.16 +#Environment variable ISABELLEBIN specifies the destination directory.
   17.17 +#For Poly/ML, ISABELLEBIN must begin with a /
   17.18 +
   17.19 +#Makes pure Isabelle (Pure) if this file is ABSENT -- but not 
   17.20 +#if it is out of date, since this Makefile does not know its dependencies!
   17.21 +
   17.22 +BIN = $(ISABELLEBIN)
   17.23 +COMP = $(ISABELLECOMP)
   17.24 +THYS = HOL.thy Ord.thy Set.thy Fun.thy subset.thy \
   17.25 +       equalities.thy Prod.thy Trancl.thy Sum.thy WF.thy \
   17.26 +       mono.thy Lfp.thy Gfp.thy Nat.thy Inductive.thy \
   17.27 +       Finite.thy Arith.thy Sexp.thy Univ.thy List.thy 
   17.28 +
   17.29 +FILES = ROOT.ML add_ind_def.ML datatype.ML hologic.ML\
   17.30 +	ind_syntax.ML indrule.ML intr_elim.ML simpdata.ML\
   17.31 +	subtype.ML thy_syntax.ML ../Pure/section_utils.ML\
   17.32 +	../Provers/classical.ML ../Provers/simplifier.ML \
   17.33 +	../Provers/splitter.ML ../Provers/ind.ML $(THYS) $(THYS:.thy=.ML)
   17.34 +
   17.35 +$(BIN)/CHOL:   $(BIN)/Pure  $(FILES) 
   17.36 +	if [ -d $${ISABELLEBIN:?}/Pure ];\
   17.37 +           	then echo Bad value for ISABELLEBIN: \
   17.38 +                	$(BIN) is the Isabelle source directory; \
   17.39 +                	exit 1; \
   17.40 +           	fi;\
   17.41 +	case "$(COMP)" in \
   17.42 +	poly*)	echo 'make_database"$(BIN)/CHOL"; quit();'  \
   17.43 +			| $(COMP) $(BIN)/Pure;\
   17.44 +		echo 'open PolyML; use"ROOT";' | $(COMP) $(BIN)/CHOL ;;\
   17.45 +	sml*)	echo 'use"ROOT.ML"; xML"$(BIN)/CHOL" banner;' | $(BIN)/Pure ;;\
   17.46 +	*)	echo Bad value for ISABELLECOMP: \
   17.47 +                	$(COMP) is not poly or sml; exit 1;;\
   17.48 +	esac
   17.49 +
   17.50 +$(BIN)/Pure:
   17.51 +	cd ../Pure;  $(MAKE)
   17.52 +
   17.53 +#### Testing of CHOL
   17.54 +
   17.55 +#A macro referring to the object-logic (depends on ML compiler)
   17.56 +LOGIC:sh=case $ISABELLECOMP in \
   17.57 +	poly*)	echo "$ISABELLECOMP $ISABELLEBIN/CHOL" ;;\
   17.58 +	sml*)	echo "$ISABELLEBIN/CHOL" ;;\
   17.59 +	*)	echo "echo Bad value for ISABELLECOMP: \
   17.60 +                	$ISABELLEBIN is not poly or sml; exit 1" ;;\
   17.61 +	esac
   17.62 +
   17.63 +##IMP-semantics example
   17.64 +IMP_THYS = IMP/Com.thy IMP/Denotation.thy IMP/Equiv.thy IMP/Properties.thy
   17.65 +IMP_FILES = IMP/ROOT.ML $(IMP_THYS) $(IMP_THYS:.thy=.ML)
   17.66 +
   17.67 +IMP:    $(BIN)/CHOL  $(IMP_FILES)
   17.68 +	echo 'use"IMP/ROOT.ML";quit();' | $(LOGIC)
   17.69 +
   17.70 +##The integers in CHOL
   17.71 +INTEG_THYS = Integ/Relation.thy Integ/Equiv.thy Integ/Integ.thy 
   17.72 +
   17.73 +INTEG_FILES = Integ/ROOT.ML $(INTEG_THYS) $(INTEG_THYS:.thy=.ML)
   17.74 +
   17.75 +Integ:  $(BIN)/CHOL  $(INTEG_FILES)
   17.76 +	echo 'use"Integ/ROOT.ML";quit();' | $(LOGIC)
   17.77 +
   17.78 +##I/O Automata
   17.79 +IOA_THYS = IOA/example/Action.thy IOA/example/Channels.thy\
   17.80 +	   IOA/example/Correctness.thy IOA/example/Impl.thy \
   17.81 +	   IOA/example/Lemmas.thy IOA/example/Multiset.thy \
   17.82 +	   IOA/example/Receiver.thy IOA/example/Sender.thy \
   17.83 +	   IOA/meta_theory/Asig.thy IOA/meta_theory/IOA.thy \
   17.84 +	   IOA/meta_theory/Option.thy IOA/meta_theory/Solve.thy
   17.85 +
   17.86 +IOA_FILES = IOA/ROOT.ML IOA/example/Packet.thy IOA/example/Spec.thy\
   17.87 +	    $(IOA_THYS) $(IOA_THYS:.thy=.ML)
   17.88 +
   17.89 +IOA:    $(BIN)/CHOL  $(IOA_FILES)
   17.90 +	echo 'use"IOA/ROOT.ML";quit();' | $(LOGIC)
   17.91 +
   17.92 +##Properties of substitutions
   17.93 +SUBST_THYS = Subst/AList.thy Subst/Setplus.thy\
   17.94 +	     Subst/Subst.thy Subst/Unifier.thy\
   17.95 +	     Subst/UTerm.thy Subst/UTLemmas.thy
   17.96 +
   17.97 +SUBST_FILES = Subst/ROOT.ML $(SUBST_THYS) $(SUBST_THYS:.thy=.ML)
   17.98 +
   17.99 +Subst:  $(BIN)/CHOL  $(SUBST_FILES)
  17.100 +	echo 'use"Subst/ROOT.ML";quit();' | $(LOGIC)
  17.101 +
  17.102 +##Miscellaneous examples
  17.103 +EX_THYS = ex/LexProd.thy ex/MT.thy ex/Acc.thy \
  17.104 +	  ex/PropLog.thy ex/Puzzle.thy ex/Qsort.thy ex/LList.thy \
  17.105 +	  ex/Rec.thy ex/Simult.thy ex/Term.thy ex/String.thy 
  17.106 +
  17.107 +EX_FILES = ex/ROOT.ML ex/cla.ML ex/meson.ML ex/mesontest.ML ex/rel.ML \
  17.108 +           ex/set.ML $(EX_THYS) $(EX_THYS:.thy=.ML)
  17.109 +
  17.110 +ex:     $(BIN)/CHOL  $(EX_FILES)
  17.111 +	echo 'use"ex/ROOT.ML";quit();' | $(LOGIC)
  17.112 +
  17.113 +#Full test.
  17.114 +test:   $(BIN)/CHOL IMP Integ IOA Subst ex
  17.115 +	echo 'Test examples ran successfully' > test
  17.116 +
  17.117 +.PRECIOUS:  $(BIN)/Pure $(BIN)/CHOL 
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/Nat.ML	Fri Mar 03 12:02:25 1995 +0100
    18.3 @@ -0,0 +1,436 @@
    18.4 +(*  Title: 	HOL/nat
    18.5 +    ID:         $Id$
    18.6 +    Author: 	Tobias Nipkow, Cambridge University Computer Laboratory
    18.7 +    Copyright   1991  University of Cambridge
    18.8 +
    18.9 +For nat.thy.  Type nat is defined as a set (Nat) over the type ind.
   18.10 +*)
   18.11 +
   18.12 +open Nat;
   18.13 +
   18.14 +goal Nat.thy "mono(%X. {Zero_Rep} Un (Suc_Rep``X))";
   18.15 +by (REPEAT (ares_tac [monoI, subset_refl, image_mono, Un_mono] 1));
   18.16 +qed "Nat_fun_mono";
   18.17 +
   18.18 +val Nat_unfold = Nat_fun_mono RS (Nat_def RS def_lfp_Tarski);
   18.19 +
   18.20 +(* Zero is a natural number -- this also justifies the type definition*)
   18.21 +goal Nat.thy "Zero_Rep: Nat";
   18.22 +by (rtac (Nat_unfold RS ssubst) 1);
   18.23 +by (rtac (singletonI RS UnI1) 1);
   18.24 +qed "Zero_RepI";
   18.25 +
   18.26 +val prems = goal Nat.thy "i: Nat ==> Suc_Rep(i) : Nat";
   18.27 +by (rtac (Nat_unfold RS ssubst) 1);
   18.28 +by (rtac (imageI RS UnI2) 1);
   18.29 +by (resolve_tac prems 1);
   18.30 +qed "Suc_RepI";
   18.31 +
   18.32 +(*** Induction ***)
   18.33 +
   18.34 +val major::prems = goal Nat.thy
   18.35 +    "[| i: Nat;  P(Zero_Rep);   \
   18.36 +\       !!j. [| j: Nat; P(j) |] ==> P(Suc_Rep(j)) |]  ==> P(i)";
   18.37 +by (rtac ([Nat_def, Nat_fun_mono, major] MRS def_induct) 1);
   18.38 +by (fast_tac (set_cs addIs prems) 1);
   18.39 +qed "Nat_induct";
   18.40 +
   18.41 +val prems = goalw Nat.thy [Zero_def,Suc_def]
   18.42 +    "[| P(0);   \
   18.43 +\       !!k. P(k) ==> P(Suc(k)) |]  ==> P(n)";
   18.44 +by (rtac (Rep_Nat_inverse RS subst) 1);   (*types force good instantiation*)
   18.45 +by (rtac (Rep_Nat RS Nat_induct) 1);
   18.46 +by (REPEAT (ares_tac prems 1
   18.47 +     ORELSE eresolve_tac [Abs_Nat_inverse RS subst] 1));
   18.48 +qed "nat_induct";
   18.49 +
   18.50 +(*Perform induction on n. *)
   18.51 +fun nat_ind_tac a i = 
   18.52 +    EVERY [res_inst_tac [("n",a)] nat_induct i,
   18.53 +	   rename_last_tac a ["1"] (i+1)];
   18.54 +
   18.55 +(*A special form of induction for reasoning about m<n and m-n*)
   18.56 +val prems = goal Nat.thy
   18.57 +    "[| !!x. P x 0;  \
   18.58 +\       !!y. P 0 (Suc y);  \
   18.59 +\       !!x y. [| P x y |] ==> P (Suc x) (Suc y)  \
   18.60 +\    |] ==> P m n";
   18.61 +by (res_inst_tac [("x","m")] spec 1);
   18.62 +by (nat_ind_tac "n" 1);
   18.63 +by (rtac allI 2);
   18.64 +by (nat_ind_tac "x" 2);
   18.65 +by (REPEAT (ares_tac (prems@[allI]) 1 ORELSE etac spec 1));
   18.66 +qed "diff_induct";
   18.67 +
   18.68 +(*Case analysis on the natural numbers*)
   18.69 +val prems = goal Nat.thy 
   18.70 +    "[| n=0 ==> P;  !!x. n = Suc(x) ==> P |] ==> P";
   18.71 +by (subgoal_tac "n=0 | (EX x. n = Suc(x))" 1);
   18.72 +by (fast_tac (HOL_cs addSEs prems) 1);
   18.73 +by (nat_ind_tac "n" 1);
   18.74 +by (rtac (refl RS disjI1) 1);
   18.75 +by (fast_tac HOL_cs 1);
   18.76 +qed "natE";
   18.77 +
   18.78 +(*** Isomorphisms: Abs_Nat and Rep_Nat ***)
   18.79 +
   18.80 +(*We can't take these properties as axioms, or take Abs_Nat==Inv(Rep_Nat),
   18.81 +  since we assume the isomorphism equations will one day be given by Isabelle*)
   18.82 +
   18.83 +goal Nat.thy "inj(Rep_Nat)";
   18.84 +by (rtac inj_inverseI 1);
   18.85 +by (rtac Rep_Nat_inverse 1);
   18.86 +qed "inj_Rep_Nat";
   18.87 +
   18.88 +goal Nat.thy "inj_onto Abs_Nat Nat";
   18.89 +by (rtac inj_onto_inverseI 1);
   18.90 +by (etac Abs_Nat_inverse 1);
   18.91 +qed "inj_onto_Abs_Nat";
   18.92 +
   18.93 +(*** Distinctness of constructors ***)
   18.94 +
   18.95 +goalw Nat.thy [Zero_def,Suc_def] "Suc(m) ~= 0";
   18.96 +by (rtac (inj_onto_Abs_Nat RS inj_onto_contraD) 1);
   18.97 +by (rtac Suc_Rep_not_Zero_Rep 1);
   18.98 +by (REPEAT (resolve_tac [Rep_Nat, Suc_RepI, Zero_RepI] 1));
   18.99 +qed "Suc_not_Zero";
  18.100 +
  18.101 +bind_thm ("Zero_not_Suc", (Suc_not_Zero RS not_sym));
  18.102 +
  18.103 +bind_thm ("Suc_neq_Zero", (Suc_not_Zero RS notE));
  18.104 +val Zero_neq_Suc = sym RS Suc_neq_Zero;
  18.105 +
  18.106 +(** Injectiveness of Suc **)
  18.107 +
  18.108 +goalw Nat.thy [Suc_def] "inj(Suc)";
  18.109 +by (rtac injI 1);
  18.110 +by (dtac (inj_onto_Abs_Nat RS inj_ontoD) 1);
  18.111 +by (REPEAT (resolve_tac [Rep_Nat, Suc_RepI] 1));
  18.112 +by (dtac (inj_Suc_Rep RS injD) 1);
  18.113 +by (etac (inj_Rep_Nat RS injD) 1);
  18.114 +qed "inj_Suc";
  18.115 +
  18.116 +val Suc_inject = inj_Suc RS injD;;
  18.117 +
  18.118 +goal Nat.thy "(Suc(m)=Suc(n)) = (m=n)";
  18.119 +by (EVERY1 [rtac iffI, etac Suc_inject, etac arg_cong]); 
  18.120 +qed "Suc_Suc_eq";
  18.121 +
  18.122 +goal Nat.thy "n ~= Suc(n)";
  18.123 +by (nat_ind_tac "n" 1);
  18.124 +by (ALLGOALS(asm_simp_tac (HOL_ss addsimps [Zero_not_Suc,Suc_Suc_eq])));
  18.125 +qed "n_not_Suc_n";
  18.126 +
  18.127 +val Suc_n_not_n = n_not_Suc_n RS not_sym;
  18.128 +
  18.129 +(*** nat_case -- the selection operator for nat ***)
  18.130 +
  18.131 +goalw Nat.thy [nat_case_def] "nat_case a f 0 = a";
  18.132 +by (fast_tac (set_cs addIs [select_equality] addEs [Zero_neq_Suc]) 1);
  18.133 +qed "nat_case_0";
  18.134 +
  18.135 +goalw Nat.thy [nat_case_def] "nat_case a f (Suc k) = f(k)";
  18.136 +by (fast_tac (set_cs addIs [select_equality] 
  18.137 +	               addEs [make_elim Suc_inject, Suc_neq_Zero]) 1);
  18.138 +qed "nat_case_Suc";
  18.139 +
  18.140 +(** Introduction rules for 'pred_nat' **)
  18.141 +
  18.142 +goalw Nat.thy [pred_nat_def] "<n, Suc(n)> : pred_nat";
  18.143 +by (fast_tac set_cs 1);
  18.144 +qed "pred_natI";
  18.145 +
  18.146 +val major::prems = goalw Nat.thy [pred_nat_def]
  18.147 +    "[| p : pred_nat;  !!x n. [| p = <n, Suc(n)> |] ==> R \
  18.148 +\    |] ==> R";
  18.149 +by (rtac (major RS CollectE) 1);
  18.150 +by (REPEAT (eresolve_tac ([asm_rl,exE]@prems) 1));
  18.151 +qed "pred_natE";
  18.152 +
  18.153 +goalw Nat.thy [wf_def] "wf(pred_nat)";
  18.154 +by (strip_tac 1);
  18.155 +by (nat_ind_tac "x" 1);
  18.156 +by (fast_tac (HOL_cs addSEs [mp, pred_natE, Pair_inject, 
  18.157 +			     make_elim Suc_inject]) 2);
  18.158 +by (fast_tac (HOL_cs addSEs [mp, pred_natE, Pair_inject, Zero_neq_Suc]) 1);
  18.159 +qed "wf_pred_nat";
  18.160 +
  18.161 +
  18.162 +(*** nat_rec -- by wf recursion on pred_nat ***)
  18.163 +
  18.164 +bind_thm ("nat_rec_unfold", (wf_pred_nat RS (nat_rec_def RS def_wfrec)));
  18.165 +
  18.166 +(** conversion rules **)
  18.167 +
  18.168 +goal Nat.thy "nat_rec 0 c h = c";
  18.169 +by (rtac (nat_rec_unfold RS trans) 1);
  18.170 +by (simp_tac (HOL_ss addsimps [nat_case_0]) 1);
  18.171 +qed "nat_rec_0";
  18.172 +
  18.173 +goal Nat.thy "nat_rec (Suc n) c h = h n (nat_rec n c h)";
  18.174 +by (rtac (nat_rec_unfold RS trans) 1);
  18.175 +by (simp_tac (HOL_ss addsimps [nat_case_Suc, pred_natI, cut_apply]) 1);
  18.176 +qed "nat_rec_Suc";
  18.177 +
  18.178 +(*These 2 rules ease the use of primitive recursion.  NOTE USE OF == *)
  18.179 +val [rew] = goal Nat.thy
  18.180 +    "[| !!n. f(n) == nat_rec n c h |] ==> f(0) = c";
  18.181 +by (rewtac rew);
  18.182 +by (rtac nat_rec_0 1);
  18.183 +qed "def_nat_rec_0";
  18.184 +
  18.185 +val [rew] = goal Nat.thy
  18.186 +    "[| !!n. f(n) == nat_rec n c h |] ==> f(Suc(n)) = h n (f n)";
  18.187 +by (rewtac rew);
  18.188 +by (rtac nat_rec_Suc 1);
  18.189 +qed "def_nat_rec_Suc";
  18.190 +
  18.191 +fun nat_recs def =
  18.192 +      [standard (def RS def_nat_rec_0),
  18.193 +       standard (def RS def_nat_rec_Suc)];
  18.194 +
  18.195 +
  18.196 +(*** Basic properties of "less than" ***)
  18.197 +
  18.198 +(** Introduction properties **)
  18.199 +
  18.200 +val prems = goalw Nat.thy [less_def] "[| i<j;  j<k |] ==> i<(k::nat)";
  18.201 +by (rtac (trans_trancl RS transD) 1);
  18.202 +by (resolve_tac prems 1);
  18.203 +by (resolve_tac prems 1);
  18.204 +qed "less_trans";
  18.205 +
  18.206 +goalw Nat.thy [less_def] "n < Suc(n)";
  18.207 +by (rtac (pred_natI RS r_into_trancl) 1);
  18.208 +qed "lessI";
  18.209 +
  18.210 +(* i<j ==> i<Suc(j) *)
  18.211 +val less_SucI = lessI RSN (2, less_trans);
  18.212 +
  18.213 +goal Nat.thy "0 < Suc(n)";
  18.214 +by (nat_ind_tac "n" 1);
  18.215 +by (rtac lessI 1);
  18.216 +by (etac less_trans 1);
  18.217 +by (rtac lessI 1);
  18.218 +qed "zero_less_Suc";
  18.219 +
  18.220 +(** Elimination properties **)
  18.221 +
  18.222 +val prems = goalw Nat.thy [less_def] "n<m ==> ~ m<(n::nat)";
  18.223 +by(fast_tac (HOL_cs addIs ([wf_pred_nat, wf_trancl RS wf_asym]@prems))1);
  18.224 +qed "less_not_sym";
  18.225 +
  18.226 +(* [| n<m; m<n |] ==> R *)
  18.227 +bind_thm ("less_asym", (less_not_sym RS notE));
  18.228 +
  18.229 +goalw Nat.thy [less_def] "~ n<(n::nat)";
  18.230 +by (rtac notI 1);
  18.231 +by (etac (wf_pred_nat RS wf_trancl RS wf_anti_refl) 1);
  18.232 +qed "less_not_refl";
  18.233 +
  18.234 +(* n<n ==> R *)
  18.235 +bind_thm ("less_anti_refl", (less_not_refl RS notE));
  18.236 +
  18.237 +goal Nat.thy "!!m. n<m ==> m ~= (n::nat)";
  18.238 +by(fast_tac (HOL_cs addEs [less_anti_refl]) 1);
  18.239 +qed "less_not_refl2";
  18.240 +
  18.241 +
  18.242 +val major::prems = goalw Nat.thy [less_def]
  18.243 +    "[| i<k;  k=Suc(i) ==> P;  !!j. [| i<j;  k=Suc(j) |] ==> P \
  18.244 +\    |] ==> P";
  18.245 +by (rtac (major RS tranclE) 1);
  18.246 +by (fast_tac (HOL_cs addSEs (prems@[pred_natE, Pair_inject])) 1);
  18.247 +by (fast_tac (HOL_cs addSEs (prems@[pred_natE, Pair_inject])) 1);
  18.248 +qed "lessE";
  18.249 +
  18.250 +goal Nat.thy "~ n<0";
  18.251 +by (rtac notI 1);
  18.252 +by (etac lessE 1);
  18.253 +by (etac Zero_neq_Suc 1);
  18.254 +by (etac Zero_neq_Suc 1);
  18.255 +qed "not_less0";
  18.256 +
  18.257 +(* n<0 ==> R *)
  18.258 +bind_thm ("less_zeroE", (not_less0 RS notE));
  18.259 +
  18.260 +val [major,less,eq] = goal Nat.thy
  18.261 +    "[| m < Suc(n);  m<n ==> P;  m=n ==> P |] ==> P";
  18.262 +by (rtac (major RS lessE) 1);
  18.263 +by (rtac eq 1);
  18.264 +by (fast_tac (HOL_cs addSDs [Suc_inject]) 1);
  18.265 +by (rtac less 1);
  18.266 +by (fast_tac (HOL_cs addSDs [Suc_inject]) 1);
  18.267 +qed "less_SucE";
  18.268 +
  18.269 +goal Nat.thy "(m < Suc(n)) = (m < n | m = n)";
  18.270 +by (fast_tac (HOL_cs addSIs [lessI]
  18.271 +		     addEs  [less_trans, less_SucE]) 1);
  18.272 +qed "less_Suc_eq";
  18.273 +
  18.274 +
  18.275 +(** Inductive (?) properties **)
  18.276 +
  18.277 +val [prem] = goal Nat.thy "Suc(m) < n ==> m<n";
  18.278 +by (rtac (prem RS rev_mp) 1);
  18.279 +by (nat_ind_tac "n" 1);
  18.280 +by (rtac impI 1);
  18.281 +by (etac less_zeroE 1);
  18.282 +by (fast_tac (HOL_cs addSIs [lessI RS less_SucI]
  18.283 +	 	     addSDs [Suc_inject]
  18.284 +		     addEs  [less_trans, lessE]) 1);
  18.285 +qed "Suc_lessD";
  18.286 +
  18.287 +val [major,minor] = goal Nat.thy 
  18.288 +    "[| Suc(i)<k;  !!j. [| i<j;  k=Suc(j) |] ==> P \
  18.289 +\    |] ==> P";
  18.290 +by (rtac (major RS lessE) 1);
  18.291 +by (etac (lessI RS minor) 1);
  18.292 +by (etac (Suc_lessD RS minor) 1);
  18.293 +by (assume_tac 1);
  18.294 +qed "Suc_lessE";
  18.295 +
  18.296 +val [major] = goal Nat.thy "Suc(m) < Suc(n) ==> m<n";
  18.297 +by (rtac (major RS lessE) 1);
  18.298 +by (REPEAT (rtac lessI 1
  18.299 +     ORELSE eresolve_tac [make_elim Suc_inject, ssubst, Suc_lessD] 1));
  18.300 +qed "Suc_less_SucD";
  18.301 +
  18.302 +val prems = goal Nat.thy "m<n ==> Suc(m) < Suc(n)";
  18.303 +by (subgoal_tac "m<n --> Suc(m) < Suc(n)" 1);
  18.304 +by (fast_tac (HOL_cs addIs prems) 1);
  18.305 +by (nat_ind_tac "n" 1);
  18.306 +by (rtac impI 1);
  18.307 +by (etac less_zeroE 1);
  18.308 +by (fast_tac (HOL_cs addSIs [lessI]
  18.309 +	 	     addSDs [Suc_inject]
  18.310 +		     addEs  [less_trans, lessE]) 1);
  18.311 +qed "Suc_mono";
  18.312 +
  18.313 +goal Nat.thy "(Suc(m) < Suc(n)) = (m<n)";
  18.314 +by (EVERY1 [rtac iffI, etac Suc_less_SucD, etac Suc_mono]);
  18.315 +qed "Suc_less_eq";
  18.316 +
  18.317 +goal Nat.thy "~(Suc(n) < n)";
  18.318 +by(fast_tac (HOL_cs addEs [Suc_lessD RS less_anti_refl]) 1);
  18.319 +qed "not_Suc_n_less_n";
  18.320 +
  18.321 +(*"Less than" is a linear ordering*)
  18.322 +goal Nat.thy "m<n | m=n | n<(m::nat)";
  18.323 +by (nat_ind_tac "m" 1);
  18.324 +by (nat_ind_tac "n" 1);
  18.325 +by (rtac (refl RS disjI1 RS disjI2) 1);
  18.326 +by (rtac (zero_less_Suc RS disjI1) 1);
  18.327 +by (fast_tac (HOL_cs addIs [lessI, Suc_mono, less_SucI] addEs [lessE]) 1);
  18.328 +qed "less_linear";
  18.329 +
  18.330 +(*Can be used with less_Suc_eq to get n=m | n<m *)
  18.331 +goal Nat.thy "(~ m < n) = (n < Suc(m))";
  18.332 +by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
  18.333 +by(ALLGOALS(asm_simp_tac (HOL_ss addsimps
  18.334 +                          [not_less0,zero_less_Suc,Suc_less_eq])));
  18.335 +qed "not_less_eq";
  18.336 +
  18.337 +(*Complete induction, aka course-of-values induction*)
  18.338 +val prems = goalw Nat.thy [less_def]
  18.339 +    "[| !!n. [| ! m::nat. m<n --> P(m) |] ==> P(n) |]  ==>  P(n)";
  18.340 +by (wf_ind_tac "n" [wf_pred_nat RS wf_trancl] 1);
  18.341 +by (eresolve_tac prems 1);
  18.342 +qed "less_induct";
  18.343 +
  18.344 +
  18.345 +(*** Properties of <= ***)
  18.346 +
  18.347 +goalw Nat.thy [le_def] "0 <= n";
  18.348 +by (rtac not_less0 1);
  18.349 +qed "le0";
  18.350 +
  18.351 +val nat_simps = [not_less0, less_not_refl, zero_less_Suc, lessI, 
  18.352 +		 Suc_less_eq, less_Suc_eq, le0, not_Suc_n_less_n,
  18.353 +		 Suc_not_Zero, Zero_not_Suc, Suc_Suc_eq,
  18.354 +		 n_not_Suc_n, Suc_n_not_n,
  18.355 +		 nat_case_0, nat_case_Suc, nat_rec_0, nat_rec_Suc];
  18.356 +
  18.357 +val nat_ss0 = sum_ss  addsimps  nat_simps;
  18.358 +
  18.359 +(*Prevents simplification of f and g: much faster*)
  18.360 +qed_goal "nat_case_weak_cong" Nat.thy
  18.361 +  "m=n ==> nat_case a f m = nat_case a f n"
  18.362 +  (fn [prem] => [rtac (prem RS arg_cong) 1]);
  18.363 +
  18.364 +qed_goal "nat_rec_weak_cong" Nat.thy
  18.365 +  "m=n ==> nat_rec m a f = nat_rec n a f"
  18.366 +  (fn [prem] => [rtac (prem RS arg_cong) 1]);
  18.367 +
  18.368 +val prems = goalw Nat.thy [le_def] "~(n<m) ==> m<=(n::nat)";
  18.369 +by (resolve_tac prems 1);
  18.370 +qed "leI";
  18.371 +
  18.372 +val prems = goalw Nat.thy [le_def] "m<=n ==> ~(n<(m::nat))";
  18.373 +by (resolve_tac prems 1);
  18.374 +qed "leD";
  18.375 +
  18.376 +val leE = make_elim leD;
  18.377 +
  18.378 +goalw Nat.thy [le_def] "!!m. ~ m <= n ==> n<(m::nat)";
  18.379 +by (fast_tac HOL_cs 1);
  18.380 +qed "not_leE";
  18.381 +
  18.382 +goalw Nat.thy [le_def] "!!m. m < n ==> Suc(m) <= n";
  18.383 +by(simp_tac nat_ss0 1);
  18.384 +by (fast_tac (HOL_cs addEs [less_anti_refl,less_asym]) 1);
  18.385 +qed "lessD";
  18.386 +
  18.387 +goalw Nat.thy [le_def] "!!m. Suc(m) <= n ==> m <= n";
  18.388 +by(asm_full_simp_tac nat_ss0 1);
  18.389 +by(fast_tac HOL_cs 1);
  18.390 +qed "Suc_leD";
  18.391 +
  18.392 +goalw Nat.thy [le_def] "!!m. m < n ==> m <= (n::nat)";
  18.393 +by (fast_tac (HOL_cs addEs [less_asym]) 1);
  18.394 +qed "less_imp_le";
  18.395 +
  18.396 +goalw Nat.thy [le_def] "!!m. m <= n ==> m < n | m=(n::nat)";
  18.397 +by (cut_facts_tac [less_linear] 1);
  18.398 +by (fast_tac (HOL_cs addEs [less_anti_refl,less_asym]) 1);
  18.399 +qed "le_imp_less_or_eq";
  18.400 +
  18.401 +goalw Nat.thy [le_def] "!!m. m<n | m=n ==> m <=(n::nat)";
  18.402 +by (cut_facts_tac [less_linear] 1);
  18.403 +by (fast_tac (HOL_cs addEs [less_anti_refl,less_asym]) 1);
  18.404 +by (flexflex_tac);
  18.405 +qed "less_or_eq_imp_le";
  18.406 +
  18.407 +goal Nat.thy "(x <= (y::nat)) = (x < y | x=y)";
  18.408 +by (REPEAT(ares_tac [iffI,less_or_eq_imp_le,le_imp_less_or_eq] 1));
  18.409 +qed "le_eq_less_or_eq";
  18.410 +
  18.411 +goal Nat.thy "n <= (n::nat)";
  18.412 +by(simp_tac (HOL_ss addsimps [le_eq_less_or_eq]) 1);
  18.413 +qed "le_refl";
  18.414 +
  18.415 +val prems = goal Nat.thy "!!i. [| i <= j; j < k |] ==> i < (k::nat)";
  18.416 +by (dtac le_imp_less_or_eq 1);
  18.417 +by (fast_tac (HOL_cs addIs [less_trans]) 1);
  18.418 +qed "le_less_trans";
  18.419 +
  18.420 +goal Nat.thy "!!i. [| i < j; j <= k |] ==> i < (k::nat)";
  18.421 +by (dtac le_imp_less_or_eq 1);
  18.422 +by (fast_tac (HOL_cs addIs [less_trans]) 1);
  18.423 +qed "less_le_trans";
  18.424 +
  18.425 +goal Nat.thy "!!i. [| i <= j; j <= k |] ==> i <= (k::nat)";
  18.426 +by (EVERY1[dtac le_imp_less_or_eq, dtac le_imp_less_or_eq,
  18.427 +          rtac less_or_eq_imp_le, fast_tac (HOL_cs addIs [less_trans])]);
  18.428 +qed "le_trans";
  18.429 +
  18.430 +val prems = goal Nat.thy "!!m. [| m <= n; n <= m |] ==> m = (n::nat)";
  18.431 +by (EVERY1[dtac le_imp_less_or_eq, dtac le_imp_less_or_eq,
  18.432 +          fast_tac (HOL_cs addEs [less_anti_refl,less_asym])]);
  18.433 +qed "le_anti_sym";
  18.434 +
  18.435 +goal Nat.thy "(Suc(n) <= Suc(m)) = (n <= m)";
  18.436 +by (simp_tac (nat_ss0 addsimps [le_eq_less_or_eq]) 1);
  18.437 +qed "Suc_le_mono";
  18.438 +
  18.439 +val nat_ss = nat_ss0 addsimps [le_refl];
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/Nat.thy	Fri Mar 03 12:02:25 1995 +0100
    19.3 @@ -0,0 +1,70 @@
    19.4 +(*  Title:      HOL/Nat.thy
    19.5 +    ID:         $Id$
    19.6 +    Author:     Tobias Nipkow, Cambridge University Computer Laboratory
    19.7 +    Copyright   1991  University of Cambridge
    19.8 +
    19.9 +Definition of types ind and nat.
   19.10 +
   19.11 +Type nat is defined as a set Nat over type ind.
   19.12 +*)
   19.13 +
   19.14 +Nat = WF +
   19.15 +
   19.16 +(** type ind **)
   19.17 +
   19.18 +types
   19.19 +  ind
   19.20 +
   19.21 +arities
   19.22 +  ind :: term
   19.23 +
   19.24 +consts
   19.25 +  Zero_Rep      :: "ind"
   19.26 +  Suc_Rep       :: "ind => ind"
   19.27 +
   19.28 +rules
   19.29 +  (*the axiom of infinity in 2 parts*)
   19.30 +  inj_Suc_Rep           "inj(Suc_Rep)"
   19.31 +  Suc_Rep_not_Zero_Rep  "Suc_Rep(x) ~= Zero_Rep"
   19.32 +
   19.33 +
   19.34 +
   19.35 +(** type nat **)
   19.36 +
   19.37 +(* type definition *)
   19.38 +
   19.39 +subtype (Nat)
   19.40 +  nat = "lfp(%X. {Zero_Rep} Un (Suc_Rep``X))"   (lfp_def)
   19.41 +
   19.42 +instance
   19.43 +  nat :: ord
   19.44 +
   19.45 +
   19.46 +(* abstract constants and syntax *)
   19.47 +
   19.48 +consts
   19.49 +  "0"           :: "nat"                ("0")
   19.50 +  Suc           :: "nat => nat"
   19.51 +  nat_case      :: "['a, nat => 'a, nat] => 'a"
   19.52 +  pred_nat      :: "(nat * nat) set"
   19.53 +  nat_rec       :: "[nat, 'a, [nat, 'a] => 'a] => 'a"
   19.54 +
   19.55 +translations
   19.56 +  "case p of 0 => a | Suc(y) => b" == "nat_case a (%y.b) p"
   19.57 +
   19.58 +defs
   19.59 +  Zero_def      "0 == Abs_Nat(Zero_Rep)"
   19.60 +  Suc_def       "Suc == (%n. Abs_Nat(Suc_Rep(Rep_Nat(n))))"
   19.61 +
   19.62 +  (*nat operations and recursion*)
   19.63 +  nat_case_def  "nat_case a f n == @z.  (n=0 --> z=a)  \
   19.64 +\                                        & (!x. n=Suc(x) --> z=f(x))"
   19.65 +  pred_nat_def  "pred_nat == {p. ? n. p = <n, Suc(n)>}"
   19.66 +
   19.67 +  less_def "m<n == <m,n>:trancl(pred_nat)"
   19.68 +
   19.69 +  le_def   "m<=(n::nat) == ~(n<m)"
   19.70 +
   19.71 +  nat_rec_def   "nat_rec n c d == wfrec pred_nat n  \
   19.72 +\                        (nat_case (%g.c) (%m g.(d m (g m))))"
   19.73 +end
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/Ord.ML	Fri Mar 03 12:02:25 1995 +0100
    20.3 @@ -0,0 +1,21 @@
    20.4 +(*  Title: 	HOL/Ord.ML
    20.5 +    ID:         $Id$
    20.6 +    Author: 	Tobias Nipkow, Cambridge University Computer Laboratory
    20.7 +    Copyright   1993  University of Cambridge
    20.8 +
    20.9 +The type class for ordered types
   20.10 +*)
   20.11 +
   20.12 +open Ord;
   20.13 +
   20.14 +val [prem] = goalw Ord.thy [mono_def]
   20.15 +    "[| !!A B. A <= B ==> f(A) <= f(B) |] ==> mono(f)";
   20.16 +by (REPEAT (ares_tac [allI, impI, prem] 1));
   20.17 +qed "monoI";
   20.18 +
   20.19 +val [major,minor] = goalw Ord.thy [mono_def]
   20.20 +    "[| mono(f);  A <= B |] ==> f(A) <= f(B)";
   20.21 +by (rtac (major RS spec RS spec RS mp) 1);
   20.22 +by (rtac minor 1);
   20.23 +qed "monoD";
   20.24 +
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/HOL/Ord.thy	Fri Mar 03 12:02:25 1995 +0100
    21.3 @@ -0,0 +1,25 @@
    21.4 +(*  Title:      HOL/Ord.thy
    21.5 +    ID:         $Id$
    21.6 +    Author:     Tobias Nipkow, Cambridge University Computer Laboratory
    21.7 +    Copyright   1993  University of Cambridge
    21.8 +
    21.9 +The type class for ordered types    (* FIXME improve comment *)
   21.10 +*)
   21.11 +
   21.12 +Ord = HOL +
   21.13 +
   21.14 +axclass
   21.15 +  ord < term
   21.16 +
   21.17 +consts
   21.18 +  "<", "<="     :: "['a::ord, 'a] => bool"              (infixl 50)
   21.19 +  mono          :: "['a::ord => 'b::ord] => bool"       (*monotonicity*)
   21.20 +  min, max      :: "['a::ord, 'a] => 'a"
   21.21 +
   21.22 +defs
   21.23 +  mono_def      "mono(f) == (!A B. A <= B --> f(A) <= f(B))"
   21.24 +  min_def       "min a b == if (a <= b) a b"
   21.25 +  max_def       "max a b == if (a <= b) b a"
   21.26 +
   21.27 +end
   21.28 +
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/Prod.ML	Fri Mar 03 12:02:25 1995 +0100
    22.3 @@ -0,0 +1,237 @@
    22.4 +(*  Title: 	HOL/prod
    22.5 +    ID:         $Id$
    22.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    22.7 +    Copyright   1991  University of Cambridge
    22.8 +
    22.9 +For prod.thy.  Ordered Pairs, the Cartesian product type, the unit type
   22.10 +*)
   22.11 +
   22.12 +open Prod;
   22.13 +
   22.14 +(*This counts as a non-emptiness result for admitting 'a * 'b as a type*)
   22.15 +goalw Prod.thy [Prod_def] "Pair_Rep a b : Prod";
   22.16 +by (EVERY1 [rtac CollectI, rtac exI, rtac exI, rtac refl]);
   22.17 +qed "ProdI";
   22.18 +
   22.19 +val [major] = goalw Prod.thy [Pair_Rep_def]
   22.20 +    "Pair_Rep a b = Pair_Rep a' b' ==> a=a' & b=b'";
   22.21 +by (EVERY1 [rtac (major RS fun_cong RS fun_cong RS subst), 
   22.22 +	    rtac conjI, rtac refl, rtac refl]);
   22.23 +qed "Pair_Rep_inject";
   22.24 +
   22.25 +goal Prod.thy "inj_onto Abs_Prod Prod";
   22.26 +by (rtac inj_onto_inverseI 1);
   22.27 +by (etac Abs_Prod_inverse 1);
   22.28 +qed "inj_onto_Abs_Prod";
   22.29 +
   22.30 +val prems = goalw Prod.thy [Pair_def]
   22.31 +    "[| <a, b> = <a',b'>;  [| a=a';  b=b' |] ==> R |] ==> R";
   22.32 +by (rtac (inj_onto_Abs_Prod RS inj_ontoD RS Pair_Rep_inject RS conjE) 1);
   22.33 +by (REPEAT (ares_tac (prems@[ProdI]) 1));
   22.34 +qed "Pair_inject";
   22.35 +
   22.36 +goal Prod.thy "(<a,b> = <a',b'>) = (a=a' & b=b')";
   22.37 +by (fast_tac (set_cs addIs [Pair_inject]) 1);
   22.38 +qed "Pair_eq";
   22.39 +
   22.40 +goalw Prod.thy [fst_def] "fst(<a,b>) = a";
   22.41 +by (fast_tac (set_cs addIs [select_equality] addSEs [Pair_inject]) 1);
   22.42 +qed "fst_conv";
   22.43 +
   22.44 +goalw Prod.thy [snd_def] "snd(<a,b>) = b";
   22.45 +by (fast_tac (set_cs addIs [select_equality] addSEs [Pair_inject]) 1);
   22.46 +qed "snd_conv";
   22.47 +
   22.48 +goalw Prod.thy [Pair_def] "? x y. p = <x,y>";
   22.49 +by (rtac (rewrite_rule [Prod_def] Rep_Prod RS CollectE) 1);
   22.50 +by (EVERY1[etac exE, etac exE, rtac exI, rtac exI,
   22.51 +	   rtac (Rep_Prod_inverse RS sym RS trans),  etac arg_cong]);
   22.52 +qed "PairE_lemma";
   22.53 +
   22.54 +val [prem] = goal Prod.thy "[| !!x y. p = <x,y> ==> Q |] ==> Q";
   22.55 +by (rtac (PairE_lemma RS exE) 1);
   22.56 +by (REPEAT (eresolve_tac [prem,exE] 1));
   22.57 +qed "PairE";
   22.58 +
   22.59 +goalw Prod.thy [split_def] "split c <a,b> = c a b";
   22.60 +by (sstac [fst_conv, snd_conv] 1);
   22.61 +by (rtac refl 1);
   22.62 +qed "split";
   22.63 +
   22.64 +val prod_ss = set_ss addsimps [fst_conv, snd_conv, split, Pair_eq];
   22.65 +
   22.66 +goal Prod.thy "(s=t) = (fst(s)=fst(t) & snd(s)=snd(t))";
   22.67 +by (res_inst_tac[("p","s")] PairE 1);
   22.68 +by (res_inst_tac[("p","t")] PairE 1);
   22.69 +by (asm_simp_tac prod_ss 1);
   22.70 +qed "Pair_fst_snd_eq";
   22.71 +
   22.72 +(*Prevents simplification of c: much faster*)
   22.73 +qed_goal "split_weak_cong" Prod.thy
   22.74 +  "p=q ==> split c p = split c q"
   22.75 +  (fn [prem] => [rtac (prem RS arg_cong) 1]);
   22.76 +
   22.77 +(* Do not add as rewrite rule: invalidates some proofs in IMP *)
   22.78 +goal Prod.thy "p = <fst(p),snd(p)>";
   22.79 +by (res_inst_tac [("p","p")] PairE 1);
   22.80 +by (asm_simp_tac prod_ss 1);
   22.81 +qed "surjective_pairing";
   22.82 +
   22.83 +goal Prod.thy "p = split (%x y.<x,y>) p";
   22.84 +by (res_inst_tac [("p","p")] PairE 1);
   22.85 +by (asm_simp_tac prod_ss 1);
   22.86 +qed "surjective_pairing2";
   22.87 +
   22.88 +(*For use with split_tac and the simplifier*)
   22.89 +goal Prod.thy "R(split c p) = (! x y. p = <x,y> --> R(c x y))";
   22.90 +by (stac surjective_pairing 1);
   22.91 +by (stac split 1);
   22.92 +by (fast_tac (HOL_cs addSEs [Pair_inject]) 1);
   22.93 +qed "expand_split";
   22.94 +
   22.95 +(** split used as a logical connective or set former **)
   22.96 +
   22.97 +(*These rules are for use with fast_tac.
   22.98 +  Could instead call simp_tac/asm_full_simp_tac using split as rewrite.*)
   22.99 +
  22.100 +goal Prod.thy "!!a b c. c a b ==> split c <a,b>";
  22.101 +by (asm_simp_tac prod_ss 1);
  22.102 +qed "splitI";
  22.103 +
  22.104 +val prems = goalw Prod.thy [split_def]
  22.105 +    "[| split c p;  !!x y. [| p = <x,y>;  c x y |] ==> Q |] ==> Q";
  22.106 +by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
  22.107 +qed "splitE";
  22.108 +
  22.109 +goal Prod.thy "!!R a b. split R <a,b> ==> R a b";
  22.110 +by (etac (split RS iffD1) 1);
  22.111 +qed "splitD";
  22.112 +
  22.113 +goal Prod.thy "!!a b c. z: c a b ==> z: split c <a,b>";
  22.114 +by (asm_simp_tac prod_ss 1);
  22.115 +qed "mem_splitI";
  22.116 +
  22.117 +val prems = goalw Prod.thy [split_def]
  22.118 +    "[| z: split c p;  !!x y. [| p = <x,y>;  z: c x y |] ==> Q |] ==> Q";
  22.119 +by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
  22.120 +qed "mem_splitE";
  22.121 +
  22.122 +(*** prod_fun -- action of the product functor upon functions ***)
  22.123 +
  22.124 +goalw Prod.thy [prod_fun_def] "prod_fun f g <a,b> = <f(a),g(b)>";
  22.125 +by (rtac split 1);
  22.126 +qed "prod_fun";
  22.127 +
  22.128 +goal Prod.thy 
  22.129 +    "prod_fun (f1 o f2) (g1 o g2) = ((prod_fun f1 g1) o (prod_fun f2 g2))";
  22.130 +by (rtac ext 1);
  22.131 +by (res_inst_tac [("p","x")] PairE 1);
  22.132 +by (asm_simp_tac (prod_ss addsimps [prod_fun,o_def]) 1);
  22.133 +qed "prod_fun_compose";
  22.134 +
  22.135 +goal Prod.thy "prod_fun (%x.x) (%y.y) = (%z.z)";
  22.136 +by (rtac ext 1);
  22.137 +by (res_inst_tac [("p","z")] PairE 1);
  22.138 +by (asm_simp_tac (prod_ss addsimps [prod_fun]) 1);
  22.139 +qed "prod_fun_ident";
  22.140 +
  22.141 +val prems = goal Prod.thy "<a,b>:r ==> <f(a),g(b)> : (prod_fun f g)``r";
  22.142 +by (rtac image_eqI 1);
  22.143 +by (rtac (prod_fun RS sym) 1);
  22.144 +by (resolve_tac prems 1);
  22.145 +qed "prod_fun_imageI";
  22.146 +
  22.147 +val major::prems = goal Prod.thy
  22.148 +    "[| c: (prod_fun f g)``r;  !!x y. [| c=<f(x),g(y)>;  <x,y>:r |] ==> P  \
  22.149 +\    |] ==> P";
  22.150 +by (rtac (major RS imageE) 1);
  22.151 +by (res_inst_tac [("p","x")] PairE 1);
  22.152 +by (resolve_tac prems 1);
  22.153 +by (fast_tac HOL_cs 2);
  22.154 +by (fast_tac (HOL_cs addIs [prod_fun]) 1);
  22.155 +qed "prod_fun_imageE";
  22.156 +
  22.157 +(*** Disjoint union of a family of sets - Sigma ***)
  22.158 +
  22.159 +qed_goalw "SigmaI" Prod.thy [Sigma_def]
  22.160 +    "[| a:A;  b:B(a) |] ==> <a,b> : Sigma A B"
  22.161 + (fn prems=> [ (REPEAT (resolve_tac (prems@[singletonI,UN_I]) 1)) ]);
  22.162 +
  22.163 +(*The general elimination rule*)
  22.164 +qed_goalw "SigmaE" Prod.thy [Sigma_def]
  22.165 +    "[| c: Sigma A B;  \
  22.166 +\       !!x y.[| x:A;  y:B(x);  c=<x,y> |] ==> P \
  22.167 +\    |] ==> P"
  22.168 + (fn major::prems=>
  22.169 +  [ (cut_facts_tac [major] 1),
  22.170 +    (REPEAT (eresolve_tac [UN_E, singletonE] 1 ORELSE ares_tac prems 1)) ]);
  22.171 +
  22.172 +(** Elimination of <a,b>:A*B -- introduces no eigenvariables **)
  22.173 +qed_goal "SigmaD1" Prod.thy "<a,b> : Sigma A B ==> a : A"
  22.174 + (fn [major]=>
  22.175 +  [ (rtac (major RS SigmaE) 1),
  22.176 +    (REPEAT (eresolve_tac [asm_rl,Pair_inject,ssubst] 1)) ]);
  22.177 +
  22.178 +qed_goal "SigmaD2" Prod.thy "<a,b> : Sigma A B ==> b : B(a)"
  22.179 + (fn [major]=>
  22.180 +  [ (rtac (major RS SigmaE) 1),
  22.181 +    (REPEAT (eresolve_tac [asm_rl,Pair_inject,ssubst] 1)) ]);
  22.182 +
  22.183 +qed_goal "SigmaE2" Prod.thy
  22.184 +    "[| <a,b> : Sigma A B;    \
  22.185 +\       [| a:A;  b:B(a) |] ==> P   \
  22.186 +\    |] ==> P"
  22.187 + (fn [major,minor]=>
  22.188 +  [ (rtac minor 1),
  22.189 +    (rtac (major RS SigmaD1) 1),
  22.190 +    (rtac (major RS SigmaD2) 1) ]);
  22.191 +
  22.192 +(*** Domain of a relation ***)
  22.193 +
  22.194 +val prems = goalw Prod.thy [image_def] "<a,b> : r ==> a : fst``r";
  22.195 +by (rtac CollectI 1);
  22.196 +by (rtac bexI 1);
  22.197 +by (rtac (fst_conv RS sym) 1);
  22.198 +by (resolve_tac prems 1);
  22.199 +qed "fst_imageI";
  22.200 +
  22.201 +val major::prems = goal Prod.thy
  22.202 +    "[| a : fst``r;  !!y.[| <a,y> : r |] ==> P |] ==> P"; 
  22.203 +by (rtac (major RS imageE) 1);
  22.204 +by (resolve_tac prems 1);
  22.205 +by (etac ssubst 1);
  22.206 +by (rtac (surjective_pairing RS subst) 1);
  22.207 +by (assume_tac 1);
  22.208 +qed "fst_imageE";
  22.209 +
  22.210 +(*** Range of a relation ***)
  22.211 +
  22.212 +val prems = goalw Prod.thy [image_def] "<a,b> : r ==> b : snd``r";
  22.213 +by (rtac CollectI 1);
  22.214 +by (rtac bexI 1);
  22.215 +by (rtac (snd_conv RS sym) 1);
  22.216 +by (resolve_tac prems 1);
  22.217 +qed "snd_imageI";
  22.218 +
  22.219 +val major::prems = goal Prod.thy
  22.220 +    "[| a : snd``r;  !!y.[| <y,a> : r |] ==> P |] ==> P"; 
  22.221 +by (rtac (major RS imageE) 1);
  22.222 +by (resolve_tac prems 1);
  22.223 +by (etac ssubst 1);
  22.224 +by (rtac (surjective_pairing RS subst) 1);
  22.225 +by (assume_tac 1);
  22.226 +qed "snd_imageE";
  22.227 +
  22.228 +(** Exhaustion rule for unit -- a degenerate form of induction **)
  22.229 +
  22.230 +goalw Prod.thy [Unity_def]
  22.231 +    "u = Unity";
  22.232 +by (stac (rewrite_rule [Unit_def] Rep_Unit RS CollectD RS sym) 1);
  22.233 +by (rtac (Rep_Unit_inverse RS sym) 1);
  22.234 +qed "unit_eq";
  22.235 +
  22.236 +val prod_cs = set_cs addSIs [SigmaI, mem_splitI] 
  22.237 +                     addIs  [fst_imageI, snd_imageI, prod_fun_imageI]
  22.238 +                     addSEs [SigmaE2, SigmaE, mem_splitE, 
  22.239 +			     fst_imageE, snd_imageE, prod_fun_imageE,
  22.240 +			     Pair_inject];
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/Prod.thy	Fri Mar 03 12:02:25 1995 +0100
    23.3 @@ -0,0 +1,66 @@
    23.4 +(*  Title:      HOL/Prod.thy
    23.5 +    ID:         Prod.thy,v 1.5 1994/08/19 09:04:27 lcp Exp
    23.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    23.7 +    Copyright   1992  University of Cambridge
    23.8 +
    23.9 +Ordered Pairs and the Cartesian product type.
   23.10 +The unit type.
   23.11 +*)
   23.12 +
   23.13 +Prod = Fun +
   23.14 +
   23.15 +(** Products **)
   23.16 +
   23.17 +(* type definition *)
   23.18 +
   23.19 +consts
   23.20 +  Pair_Rep      :: "['a, 'b] => ['a, 'b] => bool"
   23.21 +
   23.22 +defs
   23.23 +  Pair_Rep_def  "Pair_Rep == (%a b. %x y. x=a & y=b)"
   23.24 +
   23.25 +subtype (Prod)
   23.26 +  ('a, 'b) "*"          (infixr 20)
   23.27 +    = "{f. ? a b. f = Pair_Rep (a::'a) (b::'b)}"
   23.28 +
   23.29 +
   23.30 +(* abstract constants and syntax *)
   23.31 +
   23.32 +consts
   23.33 +  fst           :: "'a * 'b => 'a"
   23.34 +  snd           :: "'a * 'b => 'b"
   23.35 +  split         :: "[['a, 'b] => 'c, 'a * 'b] => 'c"
   23.36 +  prod_fun      :: "['a => 'b, 'c => 'd, 'a * 'c] => 'b * 'd"
   23.37 +  Pair          :: "['a, 'b] => 'a * 'b"
   23.38 +  Sigma         :: "['a set, 'a => 'b set] => ('a * 'b) set"
   23.39 +
   23.40 +syntax
   23.41 +  "@Tuple"      :: "args => 'a * 'b"            ("(1<_>)")
   23.42 +
   23.43 +translations
   23.44 +  "<x, y, z>"   == "<x, <y, z>>"
   23.45 +  "<x, y>"      == "Pair x y"
   23.46 +  "<x>"         => "x"
   23.47 +
   23.48 +defs
   23.49 +  Pair_def      "Pair a b == Abs_Prod(Pair_Rep a b)"
   23.50 +  fst_def       "fst(p) == @a. ? b. p = <a, b>"
   23.51 +  snd_def       "snd(p) == @b. ? a. p = <a, b>"
   23.52 +  split_def     "split c p == c (fst p) (snd p)"
   23.53 +  prod_fun_def  "prod_fun f g == split(%x y.<f(x), g(y)>)"
   23.54 +  Sigma_def     "Sigma A B == UN x:A. UN y:B(x). {<x, y>}"
   23.55 +
   23.56 +
   23.57 +
   23.58 +(** Unit **)
   23.59 +
   23.60 +subtype (Unit)
   23.61 +  unit = "{p. p = True}"
   23.62 +
   23.63 +consts
   23.64 +  Unity         :: "unit"                       ("<>")
   23.65 +
   23.66 +defs
   23.67 +  Unity_def     "Unity == Abs_Unit(True)"
   23.68 +
   23.69 +end
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/README	Fri Mar 03 12:02:25 1995 +0100
    24.3 @@ -0,0 +1,23 @@
    24.4 +	   CHOL: Higher-Order Logic with curried functions
    24.5 +
    24.6 +This directory contains the Standard ML sources of the Isabelle system for
    24.7 +Higher-Order Logic with curried functions.  Important files include
    24.8 +
    24.9 +ROOT.ML -- loads all source files.  Enter an ML image containing Pure
   24.10 +Isabelle and type:    use "ROOT.ML";
   24.11 +
   24.12 +Makefile -- compiles the files under Poly/ML or SML of New Jersey
   24.13 +
   24.14 +ex -- subdirectory containing examples.  To execute them, enter an ML image
   24.15 +containing CHOL and type:    use "ex/ROOT.ML";
   24.16 +
   24.17 +Subst -- subdirectory defining a theory of substitution and unification.
   24.18 +
   24.19 +Useful references on Higher-Order Logic:
   24.20 +
   24.21 +	P. B. Andrews,
   24.22 +	An Introduction to Mathematical Logic and Type Theory
   24.23 +	(Academic Press, 1986).
   24.24 +
   24.25 +	J. Lambek and P. J. Scott,
   24.26 +	Introduction to Higher Order Categorical Logic (CUP, 1986)
    25.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.2 +++ b/src/HOL/ROOT.ML	Fri Mar 03 12:02:25 1995 +0100
    25.3 @@ -0,0 +1,87 @@
    25.4 +(*  Title:      CHOL/ROOT.ML
    25.5 +    ID:         $Id$
    25.6 +    Author:     Tobias Nipkow
    25.7 +    Copyright   1993  University of Cambridge
    25.8 +
    25.9 +Adds Classical Higher-order Logic to a database containing Pure Isabelle.
   25.10 +Should be executed in the subdirectory HOL.
   25.11 +*)
   25.12 +
   25.13 +val banner = "Higher-Order Logic with curried functions";
   25.14 +writeln banner;
   25.15 +
   25.16 +print_depth 1;
   25.17 +set eta_contract;
   25.18 +
   25.19 +(* Add user sections *)
   25.20 +use "../Pure/section_utils.ML";
   25.21 +use "thy_syntax.ML";
   25.22 +
   25.23 +use_thy "HOL";
   25.24 +use "../Provers/hypsubst.ML";
   25.25 +use "../Provers/classical.ML";
   25.26 +use "../Provers/simplifier.ML";
   25.27 +use "../Provers/splitter.ML";
   25.28 +
   25.29 +(** Applying HypsubstFun to generate hyp_subst_tac **)
   25.30 +
   25.31 +structure Hypsubst_Data =
   25.32 +  struct
   25.33 +  (*Take apart an equality judgement; otherwise raise Match!*)
   25.34 +  fun dest_eq (Const("Trueprop",_) $ (Const("op =",_)  $ t $ u)) = (t,u);
   25.35 +  val imp_intr = impI
   25.36 +  val rev_mp = rev_mp
   25.37 +  val subst = subst
   25.38 +  val sym = sym
   25.39 +  end;
   25.40 +
   25.41 +structure Hypsubst = HypsubstFun(Hypsubst_Data);
   25.42 +open Hypsubst;
   25.43 +
   25.44 +(*** Applying ClassicalFun to create a classical prover ***)
   25.45 +structure Classical_Data = 
   25.46 +  struct
   25.47 +  val sizef	= size_of_thm
   25.48 +  val mp	= mp
   25.49 +  val not_elim	= notE
   25.50 +  val classical	= classical
   25.51 +  val hyp_subst_tacs=[hyp_subst_tac]
   25.52 +  end;
   25.53 +
   25.54 +structure Classical = ClassicalFun(Classical_Data);
   25.55 +open Classical;
   25.56 +
   25.57 +(*Propositional rules*)
   25.58 +val prop_cs = empty_cs addSIs [refl,TrueI,conjI,disjCI,impI,notI,iffI]
   25.59 +                       addSEs [conjE,disjE,impCE,FalseE,iffE];
   25.60 +
   25.61 +(*Quantifier rules*)
   25.62 +val HOL_cs = prop_cs addSIs [allI] addIs [exI,ex1I]
   25.63 +                     addSEs [exE,ex1E] addEs [allE];
   25.64 +
   25.65 +use     "simpdata.ML";
   25.66 +use_thy "Ord";
   25.67 +use_thy "subset";
   25.68 +use_thy "equalities";
   25.69 +use     "hologic.ML";
   25.70 +use     "subtype.ML";
   25.71 +use_thy "Prod";
   25.72 +use_thy "Sum";
   25.73 +use_thy "Gfp";
   25.74 +use_thy "Nat";
   25.75 +
   25.76 +use "datatype.ML";
   25.77 +use "ind_syntax.ML";
   25.78 +use "add_ind_def.ML";
   25.79 +use "intr_elim.ML";
   25.80 +use "indrule.ML";
   25.81 +use_thy "Inductive";
   25.82 +
   25.83 +use_thy "Finite";
   25.84 +use_thy "Sexp";
   25.85 +use_thy "List";
   25.86 +
   25.87 +init_pps ();
   25.88 +print_depth 8;
   25.89 +
   25.90 +val CHOL_build_completed = ();   (*indicate successful build*)
    26.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.2 +++ b/src/HOL/Set.ML	Fri Mar 03 12:02:25 1995 +0100
    26.3 @@ -0,0 +1,447 @@
    26.4 +(*  Title: 	HOL/set
    26.5 +    ID:         $Id$
    26.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    26.7 +    Copyright   1991  University of Cambridge
    26.8 +
    26.9 +For set.thy.  Set theory for higher-order logic.  A set is simply a predicate.
   26.10 +*)
   26.11 +
   26.12 +open Set;
   26.13 +
   26.14 +val [prem] = goal Set.thy "[| P(a) |] ==> a : {x.P(x)}";
   26.15 +by (rtac (mem_Collect_eq RS ssubst) 1);
   26.16 +by (rtac prem 1);
   26.17 +qed "CollectI";
   26.18 +
   26.19 +val prems = goal Set.thy "[| a : {x.P(x)} |] ==> P(a)";
   26.20 +by (resolve_tac (prems RL [mem_Collect_eq  RS subst]) 1);
   26.21 +qed "CollectD";
   26.22 +
   26.23 +val [prem] = goal Set.thy "[| !!x. (x:A) = (x:B) |] ==> A = B";
   26.24 +by (rtac (prem RS ext RS arg_cong RS box_equals) 1);
   26.25 +by (rtac Collect_mem_eq 1);
   26.26 +by (rtac Collect_mem_eq 1);
   26.27 +qed "set_ext";
   26.28 +
   26.29 +val [prem] = goal Set.thy "[| !!x. P(x)=Q(x) |] ==> {x. P(x)} = {x. Q(x)}";
   26.30 +by (rtac (prem RS ext RS arg_cong) 1);
   26.31 +qed "Collect_cong";
   26.32 +
   26.33 +val CollectE = make_elim CollectD;
   26.34 +
   26.35 +(*** Bounded quantifiers ***)
   26.36 +
   26.37 +val prems = goalw Set.thy [Ball_def]
   26.38 +    "[| !!x. x:A ==> P(x) |] ==> ! x:A. P(x)";
   26.39 +by (REPEAT (ares_tac (prems @ [allI,impI]) 1));
   26.40 +qed "ballI";
   26.41 +
   26.42 +val [major,minor] = goalw Set.thy [Ball_def]
   26.43 +    "[| ! x:A. P(x);  x:A |] ==> P(x)";
   26.44 +by (rtac (minor RS (major RS spec RS mp)) 1);
   26.45 +qed "bspec";
   26.46 +
   26.47 +val major::prems = goalw Set.thy [Ball_def]
   26.48 +    "[| ! x:A. P(x);  P(x) ==> Q;  x~:A ==> Q |] ==> Q";
   26.49 +by (rtac (major RS spec RS impCE) 1);
   26.50 +by (REPEAT (eresolve_tac prems 1));
   26.51 +qed "ballE";
   26.52 +
   26.53 +(*Takes assumptions ! x:A.P(x) and a:A; creates assumption P(a)*)
   26.54 +fun ball_tac i = etac ballE i THEN contr_tac (i+1);
   26.55 +
   26.56 +val prems = goalw Set.thy [Bex_def]
   26.57 +    "[| P(x);  x:A |] ==> ? x:A. P(x)";
   26.58 +by (REPEAT (ares_tac (prems @ [exI,conjI]) 1));
   26.59 +qed "bexI";
   26.60 +
   26.61 +qed_goal "bexCI" Set.thy 
   26.62 +   "[| ! x:A. ~P(x) ==> P(a);  a:A |] ==> ? x:A.P(x)"
   26.63 + (fn prems=>
   26.64 +  [ (rtac classical 1),
   26.65 +    (REPEAT (ares_tac (prems@[bexI,ballI,notI,notE]) 1))  ]);
   26.66 +
   26.67 +val major::prems = goalw Set.thy [Bex_def]
   26.68 +    "[| ? x:A. P(x);  !!x. [| x:A; P(x) |] ==> Q  |] ==> Q";
   26.69 +by (rtac (major RS exE) 1);
   26.70 +by (REPEAT (eresolve_tac (prems @ [asm_rl,conjE]) 1));
   26.71 +qed "bexE";
   26.72 +
   26.73 +(*Trival rewrite rule;   (! x:A.P)=P holds only if A is nonempty!*)
   26.74 +val prems = goal Set.thy
   26.75 +    "(! x:A. True) = True";
   26.76 +by (REPEAT (ares_tac [TrueI,ballI,iffI] 1));
   26.77 +qed "ball_rew";
   26.78 +
   26.79 +(** Congruence rules **)
   26.80 +
   26.81 +val prems = goal Set.thy
   26.82 +    "[| A=B;  !!x. x:B ==> P(x) = Q(x) |] ==> \
   26.83 +\    (! x:A. P(x)) = (! x:B. Q(x))";
   26.84 +by (resolve_tac (prems RL [ssubst]) 1);
   26.85 +by (REPEAT (ares_tac [ballI,iffI] 1
   26.86 +     ORELSE eresolve_tac ([make_elim bspec, mp] @ (prems RL [iffE])) 1));
   26.87 +qed "ball_cong";
   26.88 +
   26.89 +val prems = goal Set.thy
   26.90 +    "[| A=B;  !!x. x:B ==> P(x) = Q(x) |] ==> \
   26.91 +\    (? x:A. P(x)) = (? x:B. Q(x))";
   26.92 +by (resolve_tac (prems RL [ssubst]) 1);
   26.93 +by (REPEAT (etac bexE 1
   26.94 +     ORELSE ares_tac ([bexI,iffI] @ (prems RL [iffD1,iffD2])) 1));
   26.95 +qed "bex_cong";
   26.96 +
   26.97 +(*** Subsets ***)
   26.98 +
   26.99 +val prems = goalw Set.thy [subset_def] "(!!x.x:A ==> x:B) ==> A <= B";
  26.100 +by (REPEAT (ares_tac (prems @ [ballI]) 1));
  26.101 +qed "subsetI";
  26.102 +
  26.103 +(*Rule in Modus Ponens style*)
  26.104 +val major::prems = goalw Set.thy [subset_def] "[| A <= B;  c:A |] ==> c:B";
  26.105 +by (rtac (major RS bspec) 1);
  26.106 +by (resolve_tac prems 1);
  26.107 +qed "subsetD";
  26.108 +
  26.109 +(*The same, with reversed premises for use with etac -- cf rev_mp*)
  26.110 +qed_goal "rev_subsetD" Set.thy "[| c:A;  A <= B |] ==> c:B"
  26.111 + (fn prems=>  [ (REPEAT (resolve_tac (prems@[subsetD]) 1)) ]);
  26.112 +
  26.113 +(*Classical elimination rule*)
  26.114 +val major::prems = goalw Set.thy [subset_def] 
  26.115 +    "[| A <= B;  c~:A ==> P;  c:B ==> P |] ==> P";
  26.116 +by (rtac (major RS ballE) 1);
  26.117 +by (REPEAT (eresolve_tac prems 1));
  26.118 +qed "subsetCE";
  26.119 +
  26.120 +(*Takes assumptions A<=B; c:A and creates the assumption c:B *)
  26.121 +fun set_mp_tac i = etac subsetCE i  THEN  mp_tac i;
  26.122 +
  26.123 +qed_goal "subset_refl" Set.thy "A <= (A::'a set)"
  26.124 + (fn _=> [ (REPEAT (ares_tac [subsetI] 1)) ]);
  26.125 +
  26.126 +val prems = goal Set.thy "[| A<=B;  B<=C |] ==> A<=(C::'a set)";
  26.127 +by (cut_facts_tac prems 1);
  26.128 +by (REPEAT (ares_tac [subsetI] 1 ORELSE set_mp_tac 1));
  26.129 +qed "subset_trans";
  26.130 +
  26.131 +
  26.132 +(*** Equality ***)
  26.133 +
  26.134 +(*Anti-symmetry of the subset relation*)
  26.135 +val prems = goal Set.thy "[| A <= B;  B <= A |] ==> A = (B::'a set)";
  26.136 +by (rtac (iffI RS set_ext) 1);
  26.137 +by (REPEAT (ares_tac (prems RL [subsetD]) 1));
  26.138 +qed "subset_antisym";
  26.139 +val equalityI = subset_antisym;
  26.140 +
  26.141 +(* Equality rules from ZF set theory -- are they appropriate here? *)
  26.142 +val prems = goal Set.thy "A = B ==> A<=(B::'a set)";
  26.143 +by (resolve_tac (prems RL [subst]) 1);
  26.144 +by (rtac subset_refl 1);
  26.145 +qed "equalityD1";
  26.146 +
  26.147 +val prems = goal Set.thy "A = B ==> B<=(A::'a set)";
  26.148 +by (resolve_tac (prems RL [subst]) 1);
  26.149 +by (rtac subset_refl 1);
  26.150 +qed "equalityD2";
  26.151 +
  26.152 +val prems = goal Set.thy
  26.153 +    "[| A = B;  [| A<=B; B<=(A::'a set) |] ==> P |]  ==>  P";
  26.154 +by (resolve_tac prems 1);
  26.155 +by (REPEAT (resolve_tac (prems RL [equalityD1,equalityD2]) 1));
  26.156 +qed "equalityE";
  26.157 +
  26.158 +val major::prems = goal Set.thy
  26.159 +    "[| A = B;  [| c:A; c:B |] ==> P;  [| c~:A; c~:B |] ==> P |]  ==>  P";
  26.160 +by (rtac (major RS equalityE) 1);
  26.161 +by (REPEAT (contr_tac 1 ORELSE eresolve_tac ([asm_rl,subsetCE]@prems) 1));
  26.162 +qed "equalityCE";
  26.163 +
  26.164 +(*Lemma for creating induction formulae -- for "pattern matching" on p
  26.165 +  To make the induction hypotheses usable, apply "spec" or "bspec" to
  26.166 +  put universal quantifiers over the free variables in p. *)
  26.167 +val prems = goal Set.thy 
  26.168 +    "[| p:A;  !!z. z:A ==> p=z --> R |] ==> R";
  26.169 +by (rtac mp 1);
  26.170 +by (REPEAT (resolve_tac (refl::prems) 1));
  26.171 +qed "setup_induction";
  26.172 +
  26.173 +
  26.174 +(*** Set complement -- Compl ***)
  26.175 +
  26.176 +val prems = goalw Set.thy [Compl_def]
  26.177 +    "[| c:A ==> False |] ==> c : Compl(A)";
  26.178 +by (REPEAT (ares_tac (prems @ [CollectI,notI]) 1));
  26.179 +qed "ComplI";
  26.180 +
  26.181 +(*This form, with negated conclusion, works well with the Classical prover.
  26.182 +  Negated assumptions behave like formulae on the right side of the notional
  26.183 +  turnstile...*)
  26.184 +val major::prems = goalw Set.thy [Compl_def]
  26.185 +    "[| c : Compl(A) |] ==> c~:A";
  26.186 +by (rtac (major RS CollectD) 1);
  26.187 +qed "ComplD";
  26.188 +
  26.189 +val ComplE = make_elim ComplD;
  26.190 +
  26.191 +
  26.192 +(*** Binary union -- Un ***)
  26.193 +
  26.194 +val prems = goalw Set.thy [Un_def] "c:A ==> c : A Un B";
  26.195 +by (REPEAT (resolve_tac (prems @ [CollectI,disjI1]) 1));
  26.196 +qed "UnI1";
  26.197 +
  26.198 +val prems = goalw Set.thy [Un_def] "c:B ==> c : A Un B";
  26.199 +by (REPEAT (resolve_tac (prems @ [CollectI,disjI2]) 1));
  26.200 +qed "UnI2";
  26.201 +
  26.202 +(*Classical introduction rule: no commitment to A vs B*)
  26.203 +qed_goal "UnCI" Set.thy "(c~:B ==> c:A) ==> c : A Un B"
  26.204 + (fn prems=>
  26.205 +  [ (rtac classical 1),
  26.206 +    (REPEAT (ares_tac (prems@[UnI1,notI]) 1)),
  26.207 +    (REPEAT (ares_tac (prems@[UnI2,notE]) 1)) ]);
  26.208 +
  26.209 +val major::prems = goalw Set.thy [Un_def]
  26.210 +    "[| c : A Un B;  c:A ==> P;  c:B ==> P |] ==> P";
  26.211 +by (rtac (major RS CollectD RS disjE) 1);
  26.212 +by (REPEAT (eresolve_tac prems 1));
  26.213 +qed "UnE";
  26.214 +
  26.215 +
  26.216 +(*** Binary intersection -- Int ***)
  26.217 +
  26.218 +val prems = goalw Set.thy [Int_def]
  26.219 +    "[| c:A;  c:B |] ==> c : A Int B";
  26.220 +by (REPEAT (resolve_tac (prems @ [CollectI,conjI]) 1));
  26.221 +qed "IntI";
  26.222 +
  26.223 +val [major] = goalw Set.thy [Int_def] "c : A Int B ==> c:A";
  26.224 +by (rtac (major RS CollectD RS conjunct1) 1);
  26.225 +qed "IntD1";
  26.226 +
  26.227 +val [major] = goalw Set.thy [Int_def] "c : A Int B ==> c:B";
  26.228 +by (rtac (major RS CollectD RS conjunct2) 1);
  26.229 +qed "IntD2";
  26.230 +
  26.231 +val [major,minor] = goal Set.thy
  26.232 +    "[| c : A Int B;  [| c:A; c:B |] ==> P |] ==> P";
  26.233 +by (rtac minor 1);
  26.234 +by (rtac (major RS IntD1) 1);
  26.235 +by (rtac (major RS IntD2) 1);
  26.236 +qed "IntE";
  26.237 +
  26.238 +
  26.239 +(*** Set difference ***)
  26.240 +
  26.241 +qed_goalw "DiffI" Set.thy [set_diff_def]
  26.242 +    "[| c : A;  c ~: B |] ==> c : A - B"
  26.243 + (fn prems=> [ (REPEAT (resolve_tac (prems @ [CollectI,conjI]) 1)) ]);
  26.244 +
  26.245 +qed_goalw "DiffD1" Set.thy [set_diff_def]
  26.246 +    "c : A - B ==> c : A"
  26.247 + (fn [major]=> [ (rtac (major RS CollectD RS conjunct1) 1) ]);
  26.248 +
  26.249 +qed_goalw "DiffD2" Set.thy [set_diff_def]
  26.250 +    "[| c : A - B;  c : B |] ==> P"
  26.251 + (fn [major,minor]=>
  26.252 +     [rtac (minor RS (major RS CollectD RS conjunct2 RS notE)) 1]);
  26.253 +
  26.254 +qed_goal "DiffE" Set.thy
  26.255 +    "[| c : A - B;  [| c:A; c~:B |] ==> P |] ==> P"
  26.256 + (fn prems=>
  26.257 +  [ (resolve_tac prems 1),
  26.258 +    (REPEAT (ares_tac (prems RL [DiffD1, DiffD2 RS notI]) 1)) ]);
  26.259 +
  26.260 +qed_goal "Diff_iff" Set.thy "(c : A-B) = (c:A & c~:B)"
  26.261 + (fn _ => [ (fast_tac (HOL_cs addSIs [DiffI] addSEs [DiffE]) 1) ]);
  26.262 +
  26.263 +
  26.264 +(*** The empty set -- {} ***)
  26.265 +
  26.266 +qed_goalw "emptyE" Set.thy [empty_def] "a:{} ==> P"
  26.267 + (fn [prem] => [rtac (prem RS CollectD RS FalseE) 1]);
  26.268 +
  26.269 +qed_goal "empty_subsetI" Set.thy "{} <= A"
  26.270 + (fn _ => [ (REPEAT (ares_tac [equalityI,subsetI,emptyE] 1)) ]);
  26.271 +
  26.272 +qed_goal "equals0I" Set.thy "[| !!y. y:A ==> False |] ==> A={}"
  26.273 + (fn prems=>
  26.274 +  [ (REPEAT (ares_tac (prems@[empty_subsetI,subsetI,equalityI]) 1 
  26.275 +      ORELSE eresolve_tac (prems RL [FalseE]) 1)) ]);
  26.276 +
  26.277 +qed_goal "equals0D" Set.thy "[| A={};  a:A |] ==> P"
  26.278 + (fn [major,minor]=>
  26.279 +  [ (rtac (minor RS (major RS equalityD1 RS subsetD RS emptyE)) 1) ]);
  26.280 +
  26.281 +
  26.282 +(*** Augmenting a set -- insert ***)
  26.283 +
  26.284 +qed_goalw "insertI1" Set.thy [insert_def] "a : insert a B"
  26.285 + (fn _ => [rtac (CollectI RS UnI1) 1, rtac refl 1]);
  26.286 +
  26.287 +qed_goalw "insertI2" Set.thy [insert_def] "a : B ==> a : insert b B"
  26.288 + (fn [prem]=> [ (rtac (prem RS UnI2) 1) ]);
  26.289 +
  26.290 +qed_goalw "insertE" Set.thy [insert_def]
  26.291 +    "[| a : insert b A;  a=b ==> P;  a:A ==> P |] ==> P"
  26.292 + (fn major::prems=>
  26.293 +  [ (rtac (major RS UnE) 1),
  26.294 +    (REPEAT (eresolve_tac (prems @ [CollectE]) 1)) ]);
  26.295 +
  26.296 +qed_goal "insert_iff" Set.thy "a : insert b A = (a=b | a:A)"
  26.297 + (fn _ => [fast_tac (HOL_cs addIs [insertI1,insertI2] addSEs [insertE]) 1]);
  26.298 +
  26.299 +(*Classical introduction rule*)
  26.300 +qed_goal "insertCI" Set.thy "(a~:B ==> a=b) ==> a: insert b B"
  26.301 + (fn [prem]=>
  26.302 +  [ (rtac (disjCI RS (insert_iff RS iffD2)) 1),
  26.303 +    (etac prem 1) ]);
  26.304 +
  26.305 +(*** Singletons, using insert ***)
  26.306 +
  26.307 +qed_goal "singletonI" Set.thy "a : {a}"
  26.308 + (fn _=> [ (rtac insertI1 1) ]);
  26.309 +
  26.310 +qed_goal "singletonE" Set.thy "[| a: {b};  a=b ==> P |] ==> P"
  26.311 + (fn major::prems=>
  26.312 +  [ (rtac (major RS insertE) 1),
  26.313 +    (REPEAT (eresolve_tac (prems @ [emptyE]) 1)) ]);
  26.314 +
  26.315 +goalw Set.thy [insert_def] "!!a. b : {a} ==> b=a";
  26.316 +by(fast_tac (HOL_cs addSEs [emptyE,CollectE,UnE]) 1);
  26.317 +qed "singletonD";
  26.318 +
  26.319 +val singletonE = make_elim singletonD;
  26.320 +
  26.321 +val [major] = goal Set.thy "{a}={b} ==> a=b";
  26.322 +by (rtac (major RS equalityD1 RS subsetD RS singletonD) 1);
  26.323 +by (rtac singletonI 1);
  26.324 +qed "singleton_inject";
  26.325 +
  26.326 +(*** Unions of families -- UNION x:A. B(x) is Union(B``A)  ***)
  26.327 +
  26.328 +(*The order of the premises presupposes that A is rigid; b may be flexible*)
  26.329 +val prems = goalw Set.thy [UNION_def]
  26.330 +    "[| a:A;  b: B(a) |] ==> b: (UN x:A. B(x))";
  26.331 +by (REPEAT (resolve_tac (prems @ [bexI,CollectI]) 1));
  26.332 +qed "UN_I";
  26.333 +
  26.334 +val major::prems = goalw Set.thy [UNION_def]
  26.335 +    "[| b : (UN x:A. B(x));  !!x.[| x:A;  b: B(x) |] ==> R |] ==> R";
  26.336 +by (rtac (major RS CollectD RS bexE) 1);
  26.337 +by (REPEAT (ares_tac prems 1));
  26.338 +qed "UN_E";
  26.339 +
  26.340 +val prems = goal Set.thy
  26.341 +    "[| A=B;  !!x. x:B ==> C(x) = D(x) |] ==> \
  26.342 +\    (UN x:A. C(x)) = (UN x:B. D(x))";
  26.343 +by (REPEAT (etac UN_E 1
  26.344 +     ORELSE ares_tac ([UN_I,equalityI,subsetI] @ 
  26.345 +		      (prems RL [equalityD1,equalityD2] RL [subsetD])) 1));
  26.346 +qed "UN_cong";
  26.347 +
  26.348 +
  26.349 +(*** Intersections of families -- INTER x:A. B(x) is Inter(B``A) *)
  26.350 +
  26.351 +val prems = goalw Set.thy [INTER_def]
  26.352 +    "(!!x. x:A ==> b: B(x)) ==> b : (INT x:A. B(x))";
  26.353 +by (REPEAT (ares_tac ([CollectI,ballI] @ prems) 1));
  26.354 +qed "INT_I";
  26.355 +
  26.356 +val major::prems = goalw Set.thy [INTER_def]
  26.357 +    "[| b : (INT x:A. B(x));  a:A |] ==> b: B(a)";
  26.358 +by (rtac (major RS CollectD RS bspec) 1);
  26.359 +by (resolve_tac prems 1);
  26.360 +qed "INT_D";
  26.361 +
  26.362 +(*"Classical" elimination -- by the Excluded Middle on a:A *)
  26.363 +val major::prems = goalw Set.thy [INTER_def]
  26.364 +    "[| b : (INT x:A. B(x));  b: B(a) ==> R;  a~:A ==> R |] ==> R";
  26.365 +by (rtac (major RS CollectD RS ballE) 1);
  26.366 +by (REPEAT (eresolve_tac prems 1));
  26.367 +qed "INT_E";
  26.368 +
  26.369 +val prems = goal Set.thy
  26.370 +    "[| A=B;  !!x. x:B ==> C(x) = D(x) |] ==> \
  26.371 +\    (INT x:A. C(x)) = (INT x:B. D(x))";
  26.372 +by (REPEAT_FIRST (resolve_tac [INT_I,equalityI,subsetI]));
  26.373 +by (REPEAT (dtac INT_D 1
  26.374 +     ORELSE ares_tac (prems RL [equalityD1,equalityD2] RL [subsetD]) 1));
  26.375 +qed "INT_cong";
  26.376 +
  26.377 +
  26.378 +(*** Unions over a type; UNION1(B) = Union(range(B)) ***)
  26.379 +
  26.380 +(*The order of the premises presupposes that A is rigid; b may be flexible*)
  26.381 +val prems = goalw Set.thy [UNION1_def]
  26.382 +    "b: B(x) ==> b: (UN x. B(x))";
  26.383 +by (REPEAT (resolve_tac (prems @ [TrueI, CollectI RS UN_I]) 1));
  26.384 +qed "UN1_I";
  26.385 +
  26.386 +val major::prems = goalw Set.thy [UNION1_def]
  26.387 +    "[| b : (UN x. B(x));  !!x. b: B(x) ==> R |] ==> R";
  26.388 +by (rtac (major RS UN_E) 1);
  26.389 +by (REPEAT (ares_tac prems 1));
  26.390 +qed "UN1_E";
  26.391 +
  26.392 +
  26.393 +(*** Intersections over a type; INTER1(B) = Inter(range(B)) *)
  26.394 +
  26.395 +val prems = goalw Set.thy [INTER1_def]
  26.396 +    "(!!x. b: B(x)) ==> b : (INT x. B(x))";
  26.397 +by (REPEAT (ares_tac (INT_I::prems) 1));
  26.398 +qed "INT1_I";
  26.399 +
  26.400 +val [major] = goalw Set.thy [INTER1_def]
  26.401 +    "b : (INT x. B(x)) ==> b: B(a)";
  26.402 +by (rtac (TrueI RS (CollectI RS (major RS INT_D))) 1);
  26.403 +qed "INT1_D";
  26.404 +
  26.405 +(*** Unions ***)
  26.406 +
  26.407 +(*The order of the premises presupposes that C is rigid; A may be flexible*)
  26.408 +val prems = goalw Set.thy [Union_def]
  26.409 +    "[| X:C;  A:X |] ==> A : Union(C)";
  26.410 +by (REPEAT (resolve_tac (prems @ [UN_I]) 1));
  26.411 +qed "UnionI";
  26.412 +
  26.413 +val major::prems = goalw Set.thy [Union_def]
  26.414 +    "[| A : Union(C);  !!X.[| A:X;  X:C |] ==> R |] ==> R";
  26.415 +by (rtac (major RS UN_E) 1);
  26.416 +by (REPEAT (ares_tac prems 1));
  26.417 +qed "UnionE";
  26.418 +
  26.419 +(*** Inter ***)
  26.420 +
  26.421 +val prems = goalw Set.thy [Inter_def]
  26.422 +    "[| !!X. X:C ==> A:X |] ==> A : Inter(C)";
  26.423 +by (REPEAT (ares_tac ([INT_I] @ prems) 1));
  26.424 +qed "InterI";
  26.425 +
  26.426 +(*A "destruct" rule -- every X in C contains A as an element, but
  26.427 +  A:X can hold when X:C does not!  This rule is analogous to "spec". *)
  26.428 +val major::prems = goalw Set.thy [Inter_def]
  26.429 +    "[| A : Inter(C);  X:C |] ==> A:X";
  26.430 +by (rtac (major RS INT_D) 1);
  26.431 +by (resolve_tac prems 1);
  26.432 +qed "InterD";
  26.433 +
  26.434 +(*"Classical" elimination rule -- does not require proving X:C *)
  26.435 +val major::prems = goalw Set.thy [Inter_def]
  26.436 +    "[| A : Inter(C);  A:X ==> R;  X~:C ==> R |] ==> R";
  26.437 +by (rtac (major RS INT_E) 1);
  26.438 +by (REPEAT (eresolve_tac prems 1));
  26.439 +qed "InterE";
  26.440 +
  26.441 +(*** Powerset ***)
  26.442 +
  26.443 +qed_goalw "PowI" Set.thy [Pow_def] "!!A B. A <= B ==> A : Pow(B)"
  26.444 + (fn _ => [ (etac CollectI 1) ]);
  26.445 +
  26.446 +qed_goalw "PowD" Set.thy [Pow_def] "!!A B. A : Pow(B)  ==>  A<=B"
  26.447 + (fn _=> [ (etac CollectD 1) ]);
  26.448 +
  26.449 +val Pow_bottom = empty_subsetI RS PowI;        (* {}: Pow(B) *)
  26.450 +val Pow_top = subset_refl RS PowI;             (* A : Pow(A) *)
    27.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.2 +++ b/src/HOL/Set.thy	Fri Mar 03 12:02:25 1995 +0100
    27.3 @@ -0,0 +1,145 @@
    27.4 +(*  Title:      HOL/Set.thy
    27.5 +    ID:         $Id$
    27.6 +    Author:     Tobias Nipkow
    27.7 +    Copyright   1993  University of Cambridge
    27.8 +*)
    27.9 +
   27.10 +Set = Ord +
   27.11 +
   27.12 +types
   27.13 +  'a set
   27.14 +
   27.15 +arities
   27.16 +  set :: (term) term
   27.17 +
   27.18 +instance
   27.19 +  set :: (term) {ord, minus}
   27.20 +
   27.21 +consts
   27.22 +  "{}"          :: "'a set"                           ("{}")
   27.23 +  insert        :: "['a, 'a set] => 'a set"
   27.24 +  Collect       :: "('a => bool) => 'a set"               (*comprehension*)
   27.25 +  Compl         :: "('a set) => 'a set"                   (*complement*)
   27.26 +  Int           :: "['a set, 'a set] => 'a set"       (infixl 70)
   27.27 +  Un            :: "['a set, 'a set] => 'a set"       (infixl 65)
   27.28 +  UNION, INTER  :: "['a set, 'a => 'b set] => 'b set"     (*general*)
   27.29 +  UNION1        :: "['a => 'b set] => 'b set"         (binder "UN " 10)
   27.30 +  INTER1        :: "['a => 'b set] => 'b set"         (binder "INT " 10)
   27.31 +  Union, Inter  :: "(('a set)set) => 'a set"              (*of a set*)
   27.32 +  Pow           :: "'a set => 'a set set"                 (*powerset*)
   27.33 +  range         :: "('a => 'b) => 'b set"                 (*of function*)
   27.34 +  Ball, Bex     :: "['a set, 'a => bool] => bool"         (*bounded quantifiers*)
   27.35 +  inj, surj     :: "('a => 'b) => bool"                   (*inj/surjective*)
   27.36 +  inj_onto      :: "['a => 'b, 'a set] => bool"
   27.37 +  "``"          :: "['a => 'b, 'a set] => ('b set)"   (infixl 90)
   27.38 +  ":"           :: "['a, 'a set] => bool"             (infixl 50) (*membership*)
   27.39 +
   27.40 +
   27.41 +syntax
   27.42 +
   27.43 +  "~:"          :: "['a, 'a set] => bool"             (infixl 50)
   27.44 +
   27.45 +  "@Finset"     :: "args => 'a set"                   ("{(_)}")
   27.46 +
   27.47 +  "@Coll"       :: "[idt, bool] => 'a set"            ("(1{_./ _})")
   27.48 +  "@SetCompr"   :: "['a, idts, bool] => 'a set"       ("(1{_ |/_./ _})")
   27.49 +
   27.50 +  (* Big Intersection / Union *)
   27.51 +
   27.52 +  "@INTER"      :: "[idt, 'a set, 'b set] => 'b set"  ("(3INT _:_./ _)" 10)
   27.53 +  "@UNION"      :: "[idt, 'a set, 'b set] => 'b set"  ("(3UN _:_./ _)" 10)
   27.54 +
   27.55 +  (* Bounded Quantifiers *)
   27.56 +
   27.57 +  "@Ball"       :: "[idt, 'a set, bool] => bool"      ("(3! _:_./ _)" 10)
   27.58 +  "@Bex"        :: "[idt, 'a set, bool] => bool"      ("(3? _:_./ _)" 10)
   27.59 +  "*Ball"       :: "[idt, 'a set, bool] => bool"      ("(3ALL _:_./ _)" 10)
   27.60 +  "*Bex"        :: "[idt, 'a set, bool] => bool"      ("(3EX _:_./ _)" 10)
   27.61 +
   27.62 +translations
   27.63 +  "x ~: y"      == "~ (x : y)"
   27.64 +  "{x, xs}"     == "insert x {xs}"
   27.65 +  "{x}"         == "insert x {}"
   27.66 +  "{x. P}"      == "Collect (%x. P)"
   27.67 +  "INT x:A. B"  == "INTER A (%x. B)"
   27.68 +  "UN x:A. B"   == "UNION A (%x. B)"
   27.69 +  "! x:A. P"    == "Ball A (%x. P)"
   27.70 +  "? x:A. P"    == "Bex A (%x. P)"
   27.71 +  "ALL x:A. P"  => "Ball A (%x. P)"
   27.72 +  "EX x:A. P"   => "Bex A (%x. P)"
   27.73 +
   27.74 +
   27.75 +rules
   27.76 +
   27.77 +  (* Isomorphisms between Predicates and Sets *)
   27.78 +
   27.79 +  mem_Collect_eq    "(a : {x.P(x)}) = P(a)"
   27.80 +  Collect_mem_eq    "{x.x:A} = A"
   27.81 +
   27.82 +
   27.83 +defs
   27.84 +  Ball_def      "Ball A P       == ! x. x:A --> P(x)"
   27.85 +  Bex_def       "Bex A P        == ? x. x:A & P(x)"
   27.86 +  subset_def    "A <= B         == ! x:A. x:B"
   27.87 +  Compl_def     "Compl(A)       == {x. ~x:A}"
   27.88 +  Un_def        "A Un B         == {x.x:A | x:B}"
   27.89 +  Int_def       "A Int B        == {x.x:A & x:B}"
   27.90 +  set_diff_def  "A - B          == {x. x:A & ~x:B}"
   27.91 +  INTER_def     "INTER A B      == {y. ! x:A. y: B(x)}"
   27.92 +  UNION_def     "UNION A B      == {y. ? x:A. y: B(x)}"
   27.93 +  INTER1_def    "INTER1(B)      == INTER {x.True} B"
   27.94 +  UNION1_def    "UNION1(B)      == UNION {x.True} B"
   27.95 +  Inter_def     "Inter(S)       == (INT x:S. x)"
   27.96 +  Union_def     "Union(S)       == (UN x:S. x)"
   27.97 +  Pow_def       "Pow(A)         == {B. B <= A}"
   27.98 +  empty_def     "{}             == {x. False}"
   27.99 +  insert_def    "insert a B     == {x.x=a} Un B"
  27.100 +  range_def     "range(f)       == {y. ? x. y=f(x)}"
  27.101 +  image_def     "f``A           == {y. ? x:A. y=f(x)}"
  27.102 +  inj_def       "inj(f)         == ! x y. f(x)=f(y) --> x=y"
  27.103 +  inj_onto_def  "inj_onto f A   == ! x:A. ! y:A. f(x)=f(y) --> x=y"
  27.104 +  surj_def      "surj(f)        == ! y. ? x. y=f(x)"
  27.105 +
  27.106 +end
  27.107 +
  27.108 +ML
  27.109 +
  27.110 +local
  27.111 +
  27.112 +(* Translates between { e | x1..xn. P} and {u. ? x1..xn. u=e & P}      *)
  27.113 +(* {y. ? x1..xn. y = e & P} is only translated if [0..n] subset bvs(e) *)
  27.114 +
  27.115 +val ex_tr = snd(mk_binder_tr("? ","Ex"));
  27.116 +
  27.117 +fun nvars(Const("_idts",_) $ _ $ idts) = nvars(idts)+1
  27.118 +  | nvars(_) = 1;
  27.119 +
  27.120 +fun setcompr_tr[e,idts,b] =
  27.121 +  let val eq = Syntax.const("op =") $ Bound(nvars(idts)) $ e
  27.122 +      val P = Syntax.const("op &") $ eq $ b
  27.123 +      val exP = ex_tr [idts,P]
  27.124 +  in Syntax.const("Collect") $ Abs("",dummyT,exP) end;
  27.125 +
  27.126 +val ex_tr' = snd(mk_binder_tr' ("Ex","DUMMY"));
  27.127 +
  27.128 +fun setcompr_tr'[Abs(_,_,P)] =
  27.129 +  let fun ok(Const("Ex",_)$Abs(_,_,P),n) = ok(P,n+1)
  27.130 +        | ok(Const("op &",_) $ (Const("op =",_) $ Bound(m) $ e) $ _, n) =
  27.131 +            if n>0 andalso m=n andalso
  27.132 +              ((0 upto (n-1)) subset add_loose_bnos(e,0,[]))
  27.133 +            then () else raise Match
  27.134 +
  27.135 +      fun tr'(_ $ abs) =
  27.136 +        let val _ $ idts $ (_ $ (_ $ _ $ e) $ Q) = ex_tr'[abs]
  27.137 +        in Syntax.const("@SetCompr") $ e $ idts $ Q end
  27.138 +  in ok(P,0); tr'(P) end;
  27.139 +
  27.140 +in
  27.141 +
  27.142 +val parse_translation = [("@SetCompr", setcompr_tr)];
  27.143 +val print_translation = [("Collect", setcompr_tr')];
  27.144 +val print_ast_translation =
  27.145 +  map HOL.alt_ast_tr' [("@Ball", "*Ball"), ("@Bex", "*Bex")];
  27.146 +
  27.147 +end;
  27.148 +
    28.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.2 +++ b/src/HOL/Sexp.ML	Fri Mar 03 12:02:25 1995 +0100
    28.3 @@ -0,0 +1,135 @@
    28.4 +(*  Title: 	HOL/Sexp
    28.5 +    ID:         $Id$
    28.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    28.7 +    Copyright   1994  University of Cambridge
    28.8 +
    28.9 +S-expressions, general binary trees for defining recursive data structures
   28.10 +*)
   28.11 +
   28.12 +open Sexp;
   28.13 +
   28.14 +(** sexp_case **)
   28.15 +
   28.16 +val sexp_free_cs = 
   28.17 +    set_cs addSDs [Leaf_inject, Numb_inject, Scons_inject] 
   28.18 +	   addSEs [Leaf_neq_Scons, Leaf_neq_Numb,
   28.19 +		   Numb_neq_Scons, Numb_neq_Leaf,
   28.20 +		   Scons_neq_Leaf, Scons_neq_Numb];
   28.21 +
   28.22 +goalw Sexp.thy [sexp_case_def] "sexp_case c d e (Leaf a) = c(a)";
   28.23 +by (resolve_tac [select_equality] 1);
   28.24 +by (ALLGOALS (fast_tac sexp_free_cs));
   28.25 +qed "sexp_case_Leaf";
   28.26 +
   28.27 +goalw Sexp.thy [sexp_case_def] "sexp_case c d e (Numb k) = d(k)";
   28.28 +by (resolve_tac [select_equality] 1);
   28.29 +by (ALLGOALS (fast_tac sexp_free_cs));
   28.30 +qed "sexp_case_Numb";
   28.31 +
   28.32 +goalw Sexp.thy [sexp_case_def] "sexp_case c d e (M$N) = e M N";
   28.33 +by (resolve_tac [select_equality] 1);
   28.34 +by (ALLGOALS (fast_tac sexp_free_cs));
   28.35 +qed "sexp_case_Scons";
   28.36 +
   28.37 +
   28.38 +(** Introduction rules for sexp constructors **)
   28.39 +
   28.40 +val [prem] = goalw Sexp.thy [In0_def] 
   28.41 +    "M: sexp ==> In0(M) : sexp";
   28.42 +by (rtac (prem RS (sexp.NumbI RS sexp.SconsI)) 1);
   28.43 +qed "sexp_In0I";
   28.44 +
   28.45 +val [prem] = goalw Sexp.thy [In1_def] 
   28.46 +    "M: sexp ==> In1(M) : sexp";
   28.47 +by (rtac (prem RS (sexp.NumbI RS sexp.SconsI)) 1);
   28.48 +qed "sexp_In1I";
   28.49 +
   28.50 +val sexp_cs = set_cs addIs sexp.intrs@[SigmaI, uprodI];
   28.51 +
   28.52 +goal Sexp.thy "range(Leaf) <= sexp";
   28.53 +by (fast_tac sexp_cs 1);
   28.54 +qed "range_Leaf_subset_sexp";
   28.55 +
   28.56 +val [major] = goal Sexp.thy "M$N : sexp ==> M: sexp & N: sexp";
   28.57 +by (rtac (major RS setup_induction) 1);
   28.58 +by (etac sexp.induct 1);
   28.59 +by (ALLGOALS 
   28.60 +    (fast_tac (set_cs addSEs [Scons_neq_Leaf,Scons_neq_Numb,Scons_inject])));
   28.61 +qed "Scons_D";
   28.62 +
   28.63 +(** Introduction rules for 'pred_sexp' **)
   28.64 +
   28.65 +goalw Sexp.thy [pred_sexp_def] "pred_sexp <= Sigma sexp (%u.sexp)";
   28.66 +by (fast_tac sexp_cs 1);
   28.67 +qed "pred_sexp_subset_Sigma";
   28.68 +
   28.69 +(* <a,b> : pred_sexp^+ ==> a : sexp *)
   28.70 +val trancl_pred_sexpD1 = 
   28.71 +    pred_sexp_subset_Sigma RS trancl_subset_Sigma RS subsetD RS SigmaD1
   28.72 +and trancl_pred_sexpD2 = 
   28.73 +    pred_sexp_subset_Sigma RS trancl_subset_Sigma RS subsetD RS SigmaD2;
   28.74 +
   28.75 +val prems = goalw Sexp.thy [pred_sexp_def]
   28.76 +    "[| M: sexp;  N: sexp |] ==> <M, M$N> : pred_sexp";
   28.77 +by (fast_tac (set_cs addIs prems) 1);
   28.78 +qed "pred_sexpI1";
   28.79 +
   28.80 +val prems = goalw Sexp.thy [pred_sexp_def]
   28.81 +    "[| M: sexp;  N: sexp |] ==> <N, M$N> : pred_sexp";
   28.82 +by (fast_tac (set_cs addIs prems) 1);
   28.83 +qed "pred_sexpI2";
   28.84 +
   28.85 +(*Combinations involving transitivity and the rules above*)
   28.86 +val pred_sexp_t1 = pred_sexpI1 RS r_into_trancl
   28.87 +and pred_sexp_t2 = pred_sexpI2 RS r_into_trancl;
   28.88 +
   28.89 +val pred_sexp_trans1 = pred_sexp_t1 RSN (2, trans_trancl RS transD)
   28.90 +and pred_sexp_trans2 = pred_sexp_t2 RSN (2, trans_trancl RS transD);
   28.91 +
   28.92 +(*Proves goals of the form <M,N>:pred_sexp^+ provided M,N:sexp*)
   28.93 +val pred_sexp_simps =
   28.94 +            sexp.intrs @
   28.95 +	    [pred_sexp_t1, pred_sexp_t2,
   28.96 +	     pred_sexp_trans1, pred_sexp_trans2, cut_apply];
   28.97 +val pred_sexp_ss = HOL_ss addsimps pred_sexp_simps;
   28.98 +
   28.99 +val major::prems = goalw Sexp.thy [pred_sexp_def]
  28.100 +    "[| p : pred_sexp;  \
  28.101 +\       !!M N. [| p = <M, M$N>;  M: sexp;  N: sexp |] ==> R; \
  28.102 +\       !!M N. [| p = <N, M$N>;  M: sexp;  N: sexp |] ==> R  \
  28.103 +\    |] ==> R";
  28.104 +by (cut_facts_tac [major] 1);
  28.105 +by (REPEAT (eresolve_tac ([asm_rl,emptyE,insertE,UN_E]@prems) 1));
  28.106 +qed "pred_sexpE";
  28.107 +
  28.108 +goal Sexp.thy "wf(pred_sexp)";
  28.109 +by (rtac (pred_sexp_subset_Sigma RS wfI) 1);
  28.110 +by (etac sexp.induct 1);
  28.111 +by (fast_tac (HOL_cs addSEs [mp, pred_sexpE, Pair_inject, Scons_inject]) 3);
  28.112 +by (fast_tac (HOL_cs addSEs [mp, pred_sexpE, Pair_inject, Numb_neq_Scons]) 2);
  28.113 +by (fast_tac (HOL_cs addSEs [mp, pred_sexpE, Pair_inject, Leaf_neq_Scons]) 1);
  28.114 +qed "wf_pred_sexp";
  28.115 +
  28.116 +(*** sexp_rec -- by wf recursion on pred_sexp ***)
  28.117 +
  28.118 +(** conversion rules **)
  28.119 +
  28.120 +val sexp_rec_unfold = wf_pred_sexp RS (sexp_rec_def RS def_wfrec);
  28.121 +
  28.122 +
  28.123 +goal Sexp.thy "sexp_rec (Leaf a) c d h = c(a)";
  28.124 +by (stac sexp_rec_unfold 1);
  28.125 +by (rtac sexp_case_Leaf 1);
  28.126 +qed "sexp_rec_Leaf";
  28.127 +
  28.128 +goal Sexp.thy "sexp_rec (Numb k) c d h = d(k)";
  28.129 +by (stac sexp_rec_unfold 1);
  28.130 +by (rtac sexp_case_Numb 1);
  28.131 +qed "sexp_rec_Numb";
  28.132 +
  28.133 +goal Sexp.thy "!!M. [| M: sexp;  N: sexp |] ==> \
  28.134 +\    sexp_rec (M$N) c d h = h M N (sexp_rec M c d h) (sexp_rec N c d h)";
  28.135 +by (rtac (sexp_rec_unfold RS trans) 1);
  28.136 +by (asm_simp_tac(HOL_ss addsimps
  28.137 +               [sexp_case_Scons,pred_sexpI1,pred_sexpI2,cut_apply])1);
  28.138 +qed "sexp_rec_Scons";
    29.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    29.2 +++ b/src/HOL/Sexp.thy	Fri Mar 03 12:02:25 1995 +0100
    29.3 @@ -0,0 +1,40 @@
    29.4 +(*  Title: 	HOL/Sexp
    29.5 +    ID:         $Id$
    29.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    29.7 +    Copyright   1992  University of Cambridge
    29.8 +
    29.9 +S-expressions, general binary trees for defining recursive data structures
   29.10 +*)
   29.11 +
   29.12 +Sexp = Univ +
   29.13 +consts
   29.14 +  sexp      :: "'a item set"
   29.15 +
   29.16 +  sexp_case :: "['a=>'b, nat=>'b, ['a item, 'a item]=>'b, \
   29.17 +\                'a item] => 'b"
   29.18 +
   29.19 +  sexp_rec  :: "['a item, 'a=>'b, nat=>'b, 	\
   29.20 +\                ['a item, 'a item, 'b, 'b]=>'b] => 'b"
   29.21 +  
   29.22 +  pred_sexp :: "('a item * 'a item)set"
   29.23 +
   29.24 +inductive "sexp"
   29.25 +  intrs
   29.26 +    LeafI  "Leaf(a): sexp"
   29.27 +    NumbI  "Numb(a): sexp"
   29.28 +    SconsI "[| M: sexp;  N: sexp |] ==> M$N : sexp"
   29.29 +
   29.30 +defs
   29.31 +
   29.32 +  sexp_case_def	
   29.33 +   "sexp_case c d e M == @ z. (? x.   M=Leaf(x) & z=c(x))  \
   29.34 +\                           | (? k.   M=Numb(k) & z=d(k))  \
   29.35 +\                           | (? N1 N2. M = N1 $ N2  & z=e N1 N2)"
   29.36 +
   29.37 +  pred_sexp_def
   29.38 +     "pred_sexp == UN M: sexp. UN N: sexp. {<M, M$N>, <N, M$N>}"
   29.39 +
   29.40 +  sexp_rec_def
   29.41 +   "sexp_rec M c d e == wfrec pred_sexp M  \
   29.42 +\             (%M g. sexp_case c d (%N1 N2. e N1 N2 (g N1) (g N2)) M)"
   29.43 +end
    30.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    30.2 +++ b/src/HOL/Sum.ML	Fri Mar 03 12:02:25 1995 +0100
    30.3 @@ -0,0 +1,204 @@
    30.4 +(*  Title: 	HOL/Sum.ML
    30.5 +    ID:         $Id$
    30.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    30.7 +    Copyright   1991  University of Cambridge
    30.8 +
    30.9 +For Sum.thy.  The disjoint sum of two types
   30.10 +*)
   30.11 +
   30.12 +open Sum;
   30.13 +
   30.14 +(** Inl_Rep and Inr_Rep: Representations of the constructors **)
   30.15 +
   30.16 +(*This counts as a non-emptiness result for admitting 'a+'b as a type*)
   30.17 +goalw Sum.thy [Sum_def] "Inl_Rep(a) : Sum";
   30.18 +by (EVERY1 [rtac CollectI, rtac disjI1, rtac exI, rtac refl]);
   30.19 +qed "Inl_RepI";
   30.20 +
   30.21 +goalw Sum.thy [Sum_def] "Inr_Rep(b) : Sum";
   30.22 +by (EVERY1 [rtac CollectI, rtac disjI2, rtac exI, rtac refl]);
   30.23 +qed "Inr_RepI";
   30.24 +
   30.25 +goal Sum.thy "inj_onto Abs_Sum Sum";
   30.26 +by (rtac inj_onto_inverseI 1);
   30.27 +by (etac Abs_Sum_inverse 1);
   30.28 +qed "inj_onto_Abs_Sum";
   30.29 +
   30.30 +(** Distinctness of Inl and Inr **)
   30.31 +
   30.32 +goalw Sum.thy [Inl_Rep_def, Inr_Rep_def] "Inl_Rep(a) ~= Inr_Rep(b)";
   30.33 +by (EVERY1 [rtac notI,
   30.34 +	    etac (fun_cong RS fun_cong RS fun_cong RS iffE), 
   30.35 +	    rtac (notE RS ccontr),  etac (mp RS conjunct2), 
   30.36 +	    REPEAT o (ares_tac [refl,conjI]) ]);
   30.37 +qed "Inl_Rep_not_Inr_Rep";
   30.38 +
   30.39 +goalw Sum.thy [Inl_def,Inr_def] "Inl(a) ~= Inr(b)";
   30.40 +by (rtac (inj_onto_Abs_Sum RS inj_onto_contraD) 1);
   30.41 +by (rtac Inl_Rep_not_Inr_Rep 1);
   30.42 +by (rtac Inl_RepI 1);
   30.43 +by (rtac Inr_RepI 1);
   30.44 +qed "Inl_not_Inr";
   30.45 +
   30.46 +bind_thm ("Inl_neq_Inr", (Inl_not_Inr RS notE));
   30.47 +val Inr_neq_Inl = sym RS Inl_neq_Inr;
   30.48 +
   30.49 +goal Sum.thy "(Inl(a)=Inr(b)) = False";
   30.50 +by (simp_tac (HOL_ss addsimps [Inl_not_Inr]) 1);
   30.51 +qed "Inl_Inr_eq";
   30.52 +
   30.53 +goal Sum.thy "(Inr(b)=Inl(a))  =  False";
   30.54 +by (simp_tac (HOL_ss addsimps [Inl_not_Inr RS not_sym]) 1);
   30.55 +qed "Inr_Inl_eq";
   30.56 +
   30.57 +
   30.58 +(** Injectiveness of Inl and Inr **)
   30.59 +
   30.60 +val [major] = goalw Sum.thy [Inl_Rep_def] "Inl_Rep(a) = Inl_Rep(c) ==> a=c";
   30.61 +by (rtac (major RS fun_cong RS fun_cong RS fun_cong RS iffE) 1);
   30.62 +by (fast_tac HOL_cs 1);
   30.63 +qed "Inl_Rep_inject";
   30.64 +
   30.65 +val [major] = goalw Sum.thy [Inr_Rep_def] "Inr_Rep(b) = Inr_Rep(d) ==> b=d";
   30.66 +by (rtac (major RS fun_cong RS fun_cong RS fun_cong RS iffE) 1);
   30.67 +by (fast_tac HOL_cs 1);
   30.68 +qed "Inr_Rep_inject";
   30.69 +
   30.70 +goalw Sum.thy [Inl_def] "inj(Inl)";
   30.71 +by (rtac injI 1);
   30.72 +by (etac (inj_onto_Abs_Sum RS inj_ontoD RS Inl_Rep_inject) 1);
   30.73 +by (rtac Inl_RepI 1);
   30.74 +by (rtac Inl_RepI 1);
   30.75 +qed "inj_Inl";
   30.76 +val Inl_inject = inj_Inl RS injD;
   30.77 +
   30.78 +goalw Sum.thy [Inr_def] "inj(Inr)";
   30.79 +by (rtac injI 1);
   30.80 +by (etac (inj_onto_Abs_Sum RS inj_ontoD RS Inr_Rep_inject) 1);
   30.81 +by (rtac Inr_RepI 1);
   30.82 +by (rtac Inr_RepI 1);
   30.83 +qed "inj_Inr";
   30.84 +val Inr_inject = inj_Inr RS injD;
   30.85 +
   30.86 +goal Sum.thy "(Inl(x)=Inl(y)) = (x=y)";
   30.87 +by (fast_tac (HOL_cs addSEs [Inl_inject]) 1);
   30.88 +qed "Inl_eq";
   30.89 +
   30.90 +goal Sum.thy "(Inr(x)=Inr(y)) = (x=y)";
   30.91 +by (fast_tac (HOL_cs addSEs [Inr_inject]) 1);
   30.92 +qed "Inr_eq";
   30.93 +
   30.94 +(*** Rules for the disjoint sum of two SETS ***)
   30.95 +
   30.96 +(** Introduction rules for the injections **)
   30.97 +
   30.98 +goalw Sum.thy [sum_def] "!!a A B. a : A ==> Inl(a) : A plus B";
   30.99 +by (REPEAT (ares_tac [UnI1,imageI] 1));
  30.100 +qed "InlI";
  30.101 +
  30.102 +goalw Sum.thy [sum_def] "!!b A B. b : B ==> Inr(b) : A plus B";
  30.103 +by (REPEAT (ares_tac [UnI2,imageI] 1));
  30.104 +qed "InrI";
  30.105 +
  30.106 +(** Elimination rules **)
  30.107 +
  30.108 +val major::prems = goalw Sum.thy [sum_def]
  30.109 +    "[| u: A plus B;  \
  30.110 +\       !!x. [| x:A;  u=Inl(x) |] ==> P; \
  30.111 +\       !!y. [| y:B;  u=Inr(y) |] ==> P \
  30.112 +\    |] ==> P";
  30.113 +by (rtac (major RS UnE) 1);
  30.114 +by (REPEAT (rtac refl 1
  30.115 +     ORELSE eresolve_tac (prems@[imageE,ssubst]) 1));
  30.116 +qed "plusE";
  30.117 +
  30.118 +
  30.119 +val sum_cs = set_cs addSIs [InlI, InrI] 
  30.120 +                    addSEs [plusE, Inl_neq_Inr, Inr_neq_Inl]
  30.121 +                    addSDs [Inl_inject, Inr_inject];
  30.122 +
  30.123 +
  30.124 +(** sum_case -- the selection operator for sums **)
  30.125 +
  30.126 +goalw Sum.thy [sum_case_def] "sum_case f g (Inl x) = f(x)";
  30.127 +by (fast_tac (sum_cs addIs [select_equality]) 1);
  30.128 +qed "sum_case_Inl";
  30.129 +
  30.130 +goalw Sum.thy [sum_case_def] "sum_case f g (Inr x) = g(x)";
  30.131 +by (fast_tac (sum_cs addIs [select_equality]) 1);
  30.132 +qed "sum_case_Inr";
  30.133 +
  30.134 +(** Exhaustion rule for sums -- a degenerate form of induction **)
  30.135 +
  30.136 +val prems = goalw Sum.thy [Inl_def,Inr_def]
  30.137 +    "[| !!x::'a. s = Inl(x) ==> P;  !!y::'b. s = Inr(y) ==> P \
  30.138 +\    |] ==> P";
  30.139 +by (rtac (rewrite_rule [Sum_def] Rep_Sum RS CollectE) 1);
  30.140 +by (REPEAT (eresolve_tac [disjE,exE] 1
  30.141 +     ORELSE EVERY1 [resolve_tac prems, 
  30.142 +		    etac subst,
  30.143 +		    rtac (Rep_Sum_inverse RS sym)]));
  30.144 +qed "sumE";
  30.145 +
  30.146 +goal Sum.thy "sum_case (%x::'a. f(Inl x)) (%y::'b. f(Inr y)) s = f(s)";
  30.147 +by (EVERY1 [res_inst_tac [("s","s")] sumE, 
  30.148 +	    etac ssubst, rtac sum_case_Inl,
  30.149 +	    etac ssubst, rtac sum_case_Inr]);
  30.150 +qed "surjective_sum";
  30.151 +
  30.152 +goal Sum.thy "R(sum_case f g s) = \
  30.153 +\             ((! x. s = Inl(x) --> R(f(x))) & (! y. s = Inr(y) --> R(g(y))))";
  30.154 +by (rtac sumE 1);
  30.155 +by (etac ssubst 1);
  30.156 +by (stac sum_case_Inl 1);
  30.157 +by (fast_tac (set_cs addSEs [make_elim Inl_inject, Inl_neq_Inr]) 1);
  30.158 +by (etac ssubst 1);
  30.159 +by (stac sum_case_Inr 1);
  30.160 +by (fast_tac (set_cs addSEs [make_elim Inr_inject, Inr_neq_Inl]) 1);
  30.161 +qed "expand_sum_case";
  30.162 +
  30.163 +val sum_ss = prod_ss addsimps [Inl_eq, Inr_eq, Inl_Inr_eq, Inr_Inl_eq, 
  30.164 +			       sum_case_Inl, sum_case_Inr];
  30.165 +
  30.166 +(*Prevents simplification of f and g: much faster*)
  30.167 +qed_goal "sum_case_weak_cong" Sum.thy
  30.168 +  "s=t ==> sum_case f g s = sum_case f g t"
  30.169 +  (fn [prem] => [rtac (prem RS arg_cong) 1]);
  30.170 +
  30.171 +
  30.172 +
  30.173 +
  30.174 +(** Rules for the Part primitive **)
  30.175 +
  30.176 +goalw Sum.thy [Part_def]
  30.177 +    "!!a b A h. [| a : A;  a=h(b) |] ==> a : Part A h";
  30.178 +by (fast_tac set_cs 1);
  30.179 +qed "Part_eqI";
  30.180 +
  30.181 +val PartI = refl RSN (2,Part_eqI);
  30.182 +
  30.183 +val major::prems = goalw Sum.thy [Part_def]
  30.184 +    "[| a : Part A h;  !!z. [| a : A;  a=h(z) |] ==> P  \
  30.185 +\    |] ==> P";
  30.186 +by (rtac (major RS IntE) 1);
  30.187 +by (etac CollectE 1);
  30.188 +by (etac exE 1);
  30.189 +by (REPEAT (ares_tac prems 1));
  30.190 +qed "PartE";
  30.191 +
  30.192 +goalw Sum.thy [Part_def] "Part A h <= A";
  30.193 +by (rtac Int_lower1 1);
  30.194 +qed "Part_subset";
  30.195 +
  30.196 +goal Sum.thy "!!A B. A<=B ==> Part A h <= Part B h";
  30.197 +by (fast_tac (set_cs addSIs [PartI] addSEs [PartE]) 1);
  30.198 +qed "Part_mono";
  30.199 +
  30.200 +goalw Sum.thy [Part_def] "!!a. a : Part A h ==> a : A";
  30.201 +by (etac IntD1 1);
  30.202 +qed "PartD1";
  30.203 +
  30.204 +goal Sum.thy "Part A (%x.x) = A";
  30.205 +by (fast_tac (set_cs addIs [PartI,equalityI] addSEs [PartE]) 1);
  30.206 +qed "Part_id";
  30.207 +
    31.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.2 +++ b/src/HOL/Sum.thy	Fri Mar 03 12:02:25 1995 +0100
    31.3 @@ -0,0 +1,51 @@
    31.4 +(*  Title:      HOL/Sum.thy
    31.5 +    ID:         $Id$
    31.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    31.7 +    Copyright   1992  University of Cambridge
    31.8 +
    31.9 +The disjoint sum of two types.
   31.10 +*)
   31.11 +
   31.12 +Sum = Prod +
   31.13 +
   31.14 +(* type definition *)
   31.15 +
   31.16 +consts
   31.17 +  Inl_Rep       :: "['a, 'a, 'b, bool] => bool"
   31.18 +  Inr_Rep       :: "['b, 'a, 'b, bool] => bool"
   31.19 +
   31.20 +defs
   31.21 +  Inl_Rep_def   "Inl_Rep == (%a. %x y p. x=a & p)"
   31.22 +  Inr_Rep_def   "Inr_Rep == (%b. %x y p. y=b & ~p)"
   31.23 +
   31.24 +subtype (Sum)
   31.25 +  ('a, 'b) "+"          (infixr 10)
   31.26 +    = "{f. (? a. f = Inl_Rep(a::'a)) | (? b. f = Inr_Rep(b::'b))}"
   31.27 +
   31.28 +
   31.29 +(* abstract constants and syntax *)
   31.30 +
   31.31 +consts
   31.32 +  Inl           :: "'a => 'a + 'b"
   31.33 +  Inr           :: "'b => 'a + 'b"
   31.34 +  sum_case      :: "['a => 'c, 'b => 'c, 'a + 'b] => 'c"
   31.35 +
   31.36 +  (*disjoint sum for sets; the operator + is overloaded with wrong type!*)
   31.37 +  "plus"        :: "['a set, 'b set] => ('a + 'b) set"        (infixr 65)
   31.38 +  Part          :: "['a set, 'b => 'a] => 'a set"
   31.39 +
   31.40 +translations
   31.41 +  "case p of Inl(x) => a | Inr(y) => b" == "sum_case (%x.a) (%y.b) p"
   31.42 +
   31.43 +defs
   31.44 +  Inl_def       "Inl == (%a. Abs_Sum(Inl_Rep(a)))"
   31.45 +  Inr_def       "Inr == (%b. Abs_Sum(Inr_Rep(b)))"
   31.46 +  sum_case_def  "sum_case f g p == @z.  (!x. p=Inl(x) --> z=f(x))      \
   31.47 +\                                     & (!y. p=Inr(y) --> z=g(y))"
   31.48 +
   31.49 +  sum_def       "A plus B == (Inl``A) Un (Inr``B)"
   31.50 +
   31.51 +  (*for selecting out the components of a mutually recursive definition*)
   31.52 +  Part_def      "Part A h == A Int {x. ? z. x = h(z)}"
   31.53 +
   31.54 +end
    32.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    32.2 +++ b/src/HOL/Trancl.ML	Fri Mar 03 12:02:25 1995 +0100
    32.3 @@ -0,0 +1,237 @@
    32.4 +(*  Title: 	HOL/trancl
    32.5 +    ID:         $Id$
    32.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    32.7 +    Copyright   1992  University of Cambridge
    32.8 +
    32.9 +For trancl.thy.  Theorems about the transitive closure of a relation
   32.10 +*)
   32.11 +
   32.12 +open Trancl;
   32.13 +
   32.14 +(** Natural deduction for trans(r) **)
   32.15 +
   32.16 +val prems = goalw Trancl.thy [trans_def]
   32.17 +    "(!! x y z. [| <x,y>:r;  <y,z>:r |] ==> <x,z>:r) ==> trans(r)";
   32.18 +by (REPEAT (ares_tac (prems@[allI,impI]) 1));
   32.19 +qed "transI";
   32.20 +
   32.21 +val major::prems = goalw Trancl.thy [trans_def]
   32.22 +    "[| trans(r);  <a,b>:r;  <b,c>:r |] ==> <a,c>:r";
   32.23 +by (cut_facts_tac [major] 1);
   32.24 +by (fast_tac (HOL_cs addIs prems) 1);
   32.25 +qed "transD";
   32.26 +
   32.27 +(** Identity relation **)
   32.28 +
   32.29 +goalw Trancl.thy [id_def] "<a,a> : id";  
   32.30 +by (rtac CollectI 1);
   32.31 +by (rtac exI 1);
   32.32 +by (rtac refl 1);
   32.33 +qed "idI";
   32.34 +
   32.35 +val major::prems = goalw Trancl.thy [id_def]
   32.36 +    "[| p: id;  !!x.[| p = <x,x> |] ==> P  \
   32.37 +\    |] ==>  P";  
   32.38 +by (rtac (major RS CollectE) 1);
   32.39 +by (etac exE 1);
   32.40 +by (eresolve_tac prems 1);
   32.41 +qed "idE";
   32.42 +
   32.43 +goalw Trancl.thy [id_def] "<a,b>:id = (a=b)";
   32.44 +by(fast_tac prod_cs 1);
   32.45 +qed "pair_in_id_conv";
   32.46 +
   32.47 +(** Composition of two relations **)
   32.48 +
   32.49 +val prems = goalw Trancl.thy [comp_def]
   32.50 +    "[| <a,b>:s; <b,c>:r |] ==> <a,c> : r O s";
   32.51 +by (fast_tac (set_cs addIs prems) 1);
   32.52 +qed "compI";
   32.53 +
   32.54 +(*proof requires higher-level assumptions or a delaying of hyp_subst_tac*)
   32.55 +val prems = goalw Trancl.thy [comp_def]
   32.56 +    "[| xz : r O s;  \
   32.57 +\       !!x y z. [| xz = <x,z>;  <x,y>:s;  <y,z>:r |] ==> P \
   32.58 +\    |] ==> P";
   32.59 +by (cut_facts_tac prems 1);
   32.60 +by (REPEAT (eresolve_tac [CollectE, exE, conjE] 1 ORELSE ares_tac prems 1));
   32.61 +qed "compE";
   32.62 +
   32.63 +val prems = goal Trancl.thy
   32.64 +    "[| <a,c> : r O s;  \
   32.65 +\       !!y. [| <a,y>:s;  <y,c>:r |] ==> P \
   32.66 +\    |] ==> P";
   32.67 +by (rtac compE 1);
   32.68 +by (REPEAT (ares_tac prems 1 ORELSE eresolve_tac [Pair_inject,ssubst] 1));
   32.69 +qed "compEpair";
   32.70 +
   32.71 +val comp_cs = prod_cs addIs [compI, idI] addSEs [compE, idE];
   32.72 +
   32.73 +goal Trancl.thy "!!r s. [| r'<=r; s'<=s |] ==> (r' O s') <= (r O s)";
   32.74 +by (fast_tac comp_cs 1);
   32.75 +qed "comp_mono";
   32.76 +
   32.77 +goal Trancl.thy
   32.78 +    "!!r s. [| s <= Sigma A (%x.B);  r <= Sigma B (%x.C) |] ==> \
   32.79 +\           (r O s) <= Sigma A (%x.C)";
   32.80 +by (fast_tac comp_cs 1);
   32.81 +qed "comp_subset_Sigma";
   32.82 +
   32.83 +
   32.84 +(** The relation rtrancl **)
   32.85 +
   32.86 +goal Trancl.thy "mono(%s. id Un (r O s))";
   32.87 +by (rtac monoI 1);
   32.88 +by (REPEAT (ares_tac [monoI, subset_refl, comp_mono, Un_mono] 1));
   32.89 +qed "rtrancl_fun_mono";
   32.90 +
   32.91 +val rtrancl_unfold = rtrancl_fun_mono RS (rtrancl_def RS def_lfp_Tarski);
   32.92 +
   32.93 +(*Reflexivity of rtrancl*)
   32.94 +goal Trancl.thy "<a,a> : r^*";
   32.95 +by (stac rtrancl_unfold 1);
   32.96 +by (fast_tac comp_cs 1);
   32.97 +qed "rtrancl_refl";
   32.98 +
   32.99 +(*Closure under composition with r*)
  32.100 +val prems = goal Trancl.thy
  32.101 +    "[| <a,b> : r^*;  <b,c> : r |] ==> <a,c> : r^*";
  32.102 +by (stac rtrancl_unfold 1);
  32.103 +by (fast_tac (comp_cs addIs prems) 1);
  32.104 +qed "rtrancl_into_rtrancl";
  32.105 +
  32.106 +(*rtrancl of r contains r*)
  32.107 +val [prem] = goal Trancl.thy "[| <a,b> : r |] ==> <a,b> : r^*";
  32.108 +by (rtac (rtrancl_refl RS rtrancl_into_rtrancl) 1);
  32.109 +by (rtac prem 1);
  32.110 +qed "r_into_rtrancl";
  32.111 +
  32.112 +(*monotonicity of rtrancl*)
  32.113 +goalw Trancl.thy [rtrancl_def] "!!r s. r <= s ==> r^* <= s^*";
  32.114 +by(REPEAT(ares_tac [lfp_mono,Un_mono,comp_mono,subset_refl] 1));
  32.115 +qed "rtrancl_mono";
  32.116 +
  32.117 +(** standard induction rule **)
  32.118 +
  32.119 +val major::prems = goal Trancl.thy 
  32.120 +  "[| <a,b> : r^*; \
  32.121 +\     !!x. P(<x,x>); \
  32.122 +\     !!x y z.[| P(<x,y>); <x,y>: r^*; <y,z>: r |]  ==>  P(<x,z>) |] \
  32.123 +\  ==>  P(<a,b>)";
  32.124 +by (rtac ([rtrancl_def, rtrancl_fun_mono, major] MRS def_induct) 1);
  32.125 +by (fast_tac (comp_cs addIs prems) 1);
  32.126 +qed "rtrancl_full_induct";
  32.127 +
  32.128 +(*nice induction rule*)
  32.129 +val major::prems = goal Trancl.thy
  32.130 +    "[| <a::'a,b> : r^*;    \
  32.131 +\       P(a); \
  32.132 +\	!!y z.[| <a,y> : r^*;  <y,z> : r;  P(y) |] ==> P(z) |]  \
  32.133 +\     ==> P(b)";
  32.134 +(*by induction on this formula*)
  32.135 +by (subgoal_tac "! y. <a::'a,b> = <a,y> --> P(y)" 1);
  32.136 +(*now solve first subgoal: this formula is sufficient*)
  32.137 +by (fast_tac HOL_cs 1);
  32.138 +(*now do the induction*)
  32.139 +by (resolve_tac [major RS rtrancl_full_induct] 1);
  32.140 +by (fast_tac (comp_cs addIs prems) 1);
  32.141 +by (fast_tac (comp_cs addIs prems) 1);
  32.142 +qed "rtrancl_induct";
  32.143 +
  32.144 +(*transitivity of transitive closure!! -- by induction.*)
  32.145 +goal Trancl.thy "trans(r^*)";
  32.146 +by (rtac transI 1);
  32.147 +by (res_inst_tac [("b","z")] rtrancl_induct 1);
  32.148 +by (DEPTH_SOLVE (eresolve_tac [asm_rl, rtrancl_into_rtrancl] 1));
  32.149 +qed "trans_rtrancl";
  32.150 +
  32.151 +(*elimination of rtrancl -- by induction on a special formula*)
  32.152 +val major::prems = goal Trancl.thy
  32.153 +    "[| <a::'a,b> : r^*;  (a = b) ==> P; 	\
  32.154 +\	!!y.[| <a,y> : r^*; <y,b> : r |] ==> P 	\
  32.155 +\    |] ==> P";
  32.156 +by (subgoal_tac "(a::'a) = b  | (? y. <a,y> : r^* & <y,b> : r)" 1);
  32.157 +by (rtac (major RS rtrancl_induct) 2);
  32.158 +by (fast_tac (set_cs addIs prems) 2);
  32.159 +by (fast_tac (set_cs addIs prems) 2);
  32.160 +by (REPEAT (eresolve_tac ([asm_rl,exE,disjE,conjE]@prems) 1));
  32.161 +qed "rtranclE";
  32.162 +
  32.163 +
  32.164 +(**** The relation trancl ****)
  32.165 +
  32.166 +(** Conversions between trancl and rtrancl **)
  32.167 +
  32.168 +val [major] = goalw Trancl.thy [trancl_def]
  32.169 +    "<a,b> : r^+ ==> <a,b> : r^*";
  32.170 +by (resolve_tac [major RS compEpair] 1);
  32.171 +by (REPEAT (ares_tac [rtrancl_into_rtrancl] 1));
  32.172 +qed "trancl_into_rtrancl";
  32.173 +
  32.174 +(*r^+ contains r*)
  32.175 +val [prem] = goalw Trancl.thy [trancl_def]
  32.176 +   "[| <a,b> : r |] ==> <a,b> : r^+";
  32.177 +by (REPEAT (ares_tac [prem,compI,rtrancl_refl] 1));
  32.178 +qed "r_into_trancl";
  32.179 +
  32.180 +(*intro rule by definition: from rtrancl and r*)
  32.181 +val prems = goalw Trancl.thy [trancl_def]
  32.182 +    "[| <a,b> : r^*;  <b,c> : r |]   ==>  <a,c> : r^+";
  32.183 +by (REPEAT (resolve_tac ([compI]@prems) 1));
  32.184 +qed "rtrancl_into_trancl1";
  32.185 +
  32.186 +(*intro rule from r and rtrancl*)
  32.187 +val prems = goal Trancl.thy
  32.188 +    "[| <a,b> : r;  <b,c> : r^* |]   ==>  <a,c> : r^+";
  32.189 +by (resolve_tac (prems RL [rtranclE]) 1);
  32.190 +by (etac subst 1);
  32.191 +by (resolve_tac (prems RL [r_into_trancl]) 1);
  32.192 +by (rtac (trans_rtrancl RS transD RS rtrancl_into_trancl1) 1);
  32.193 +by (REPEAT (ares_tac (prems@[r_into_rtrancl]) 1));
  32.194 +qed "rtrancl_into_trancl2";
  32.195 +
  32.196 +(*elimination of r^+ -- NOT an induction rule*)
  32.197 +val major::prems = goal Trancl.thy
  32.198 +    "[| <a::'a,b> : r^+;  \
  32.199 +\       <a,b> : r ==> P; \
  32.200 +\	!!y.[| <a,y> : r^+;  <y,b> : r |] ==> P  \
  32.201 +\    |] ==> P";
  32.202 +by (subgoal_tac "<a::'a,b> : r | (? y. <a,y> : r^+  &  <y,b> : r)" 1);
  32.203 +by (REPEAT (eresolve_tac ([asm_rl,disjE,exE,conjE]@prems) 1));
  32.204 +by (rtac (rewrite_rule [trancl_def] major RS compEpair) 1);
  32.205 +by (etac rtranclE 1);
  32.206 +by (fast_tac comp_cs 1);
  32.207 +by (fast_tac (comp_cs addSIs [rtrancl_into_trancl1]) 1);
  32.208 +qed "tranclE";
  32.209 +
  32.210 +(*Transitivity of r^+.
  32.211 +  Proved by unfolding since it uses transitivity of rtrancl. *)
  32.212 +goalw Trancl.thy [trancl_def] "trans(r^+)";
  32.213 +by (rtac transI 1);
  32.214 +by (REPEAT (etac compEpair 1));
  32.215 +by (rtac (rtrancl_into_rtrancl RS (trans_rtrancl RS transD RS compI)) 1);
  32.216 +by (REPEAT (assume_tac 1));
  32.217 +qed "trans_trancl";
  32.218 +
  32.219 +val prems = goal Trancl.thy
  32.220 +    "[| <a,b> : r;  <b,c> : r^+ |]   ==>  <a,c> : r^+";
  32.221 +by (rtac (r_into_trancl RS (trans_trancl RS transD)) 1);
  32.222 +by (resolve_tac prems 1);
  32.223 +by (resolve_tac prems 1);
  32.224 +qed "trancl_into_trancl2";
  32.225 +
  32.226 +
  32.227 +val major::prems = goal Trancl.thy
  32.228 +    "[| <a,b> : r^*;  r <= Sigma A (%x.A) |] ==> a=b | a:A";
  32.229 +by (cut_facts_tac prems 1);
  32.230 +by (rtac (major RS rtrancl_induct) 1);
  32.231 +by (rtac (refl RS disjI1) 1);
  32.232 +by (fast_tac (comp_cs addSEs [SigmaE2]) 1);
  32.233 +qed "trancl_subset_Sigma_lemma";
  32.234 +
  32.235 +goalw Trancl.thy [trancl_def]
  32.236 +    "!!r. r <= Sigma A (%x.A) ==> trancl(r) <= Sigma A (%x.A)";
  32.237 +by (fast_tac (comp_cs addSDs [trancl_subset_Sigma_lemma]) 1);
  32.238 +qed "trancl_subset_Sigma";
  32.239 +
  32.240 +val prod_ss = prod_ss addsimps [pair_in_id_conv];
    33.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    33.2 +++ b/src/HOL/Trancl.thy	Fri Mar 03 12:02:25 1995 +0100
    33.3 @@ -0,0 +1,26 @@
    33.4 +(*  Title: 	HOL/trancl.thy
    33.5 +    ID:         $Id$
    33.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    33.7 +    Copyright   1992  University of Cambridge
    33.8 +
    33.9 +Transitive closure of a relation
   33.10 +
   33.11 +rtrancl is refl/transitive closure;  trancl is transitive closure
   33.12 +*)
   33.13 +
   33.14 +Trancl = Lfp + Prod + 
   33.15 +consts
   33.16 +    trans   :: "('a * 'a)set => bool" 	(*transitivity predicate*)
   33.17 +    id	    :: "('a * 'a)set"
   33.18 +    rtrancl :: "('a * 'a)set => ('a * 'a)set"	("(_^*)" [100] 100)
   33.19 +    trancl  :: "('a * 'a)set => ('a * 'a)set"	("(_^+)" [100] 100)  
   33.20 +    O	    :: "[('b * 'c)set, ('a * 'b)set] => ('a * 'c)set" (infixr 60)
   33.21 +defs   
   33.22 +trans_def	"trans(r) == (!x y z. <x,y>:r --> <y,z>:r --> <x,z>:r)"
   33.23 +comp_def	(*composition of relations*)
   33.24 +		"r O s == {xz. ? x y z. xz = <x,z> & <x,y>:s & <y,z>:r}"
   33.25 +id_def		(*the identity relation*)
   33.26 +		"id == {p. ? x. p = <x,x>}"
   33.27 +rtrancl_def	"r^* == lfp(%s. id Un (r O s))"
   33.28 +trancl_def	"r^+ == r O rtrancl(r)"
   33.29 +end
    34.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    34.2 +++ b/src/HOL/Univ.ML	Fri Mar 03 12:02:25 1995 +0100
    34.3 @@ -0,0 +1,615 @@
    34.4 +(*  Title: 	HOL/univ
    34.5 +    ID:         $Id$
    34.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    34.7 +    Copyright   1991  University of Cambridge
    34.8 +
    34.9 +For univ.thy
   34.10 +*)
   34.11 +
   34.12 +open Univ;
   34.13 +
   34.14 +(** LEAST -- the least number operator **)
   34.15 +
   34.16 +
   34.17 +val [prem1,prem2] = goalw Univ.thy [Least_def]
   34.18 +    "[| P(k);  !!x. x<k ==> ~P(x) |] ==> (LEAST x.P(x)) = k";
   34.19 +by (rtac select_equality 1);
   34.20 +by (fast_tac (HOL_cs addSIs [prem1,prem2]) 1);
   34.21 +by (cut_facts_tac [less_linear] 1);
   34.22 +by (fast_tac (HOL_cs addSIs [prem1] addSDs [prem2]) 1);
   34.23 +qed "Least_equality";
   34.24 +
   34.25 +val [prem] = goal Univ.thy "P(k) ==> P(LEAST x.P(x))";
   34.26 +by (rtac (prem RS rev_mp) 1);
   34.27 +by (res_inst_tac [("n","k")] less_induct 1);
   34.28 +by (rtac impI 1);
   34.29 +by (rtac classical 1);
   34.30 +by (res_inst_tac [("s","n")] (Least_equality RS ssubst) 1);
   34.31 +by (assume_tac 1);
   34.32 +by (assume_tac 2);
   34.33 +by (fast_tac HOL_cs 1);
   34.34 +qed "LeastI";
   34.35 +
   34.36 +(*Proof is almost identical to the one above!*)
   34.37 +val [prem] = goal Univ.thy "P(k) ==> (LEAST x.P(x)) <= k";
   34.38 +by (rtac (prem RS rev_mp) 1);
   34.39 +by (res_inst_tac [("n","k")] less_induct 1);
   34.40 +by (rtac impI 1);
   34.41 +by (rtac classical 1);
   34.42 +by (res_inst_tac [("s","n")] (Least_equality RS ssubst) 1);
   34.43 +by (assume_tac 1);
   34.44 +by (rtac le_refl 2);
   34.45 +by (fast_tac (HOL_cs addIs [less_imp_le,le_trans]) 1);
   34.46 +qed "Least_le";
   34.47 +
   34.48 +val [prem] = goal Univ.thy "k < (LEAST x.P(x)) ==> ~P(k)";
   34.49 +by (rtac notI 1);
   34.50 +by (etac (rewrite_rule [le_def] Least_le RS notE) 1);
   34.51 +by (rtac prem 1);
   34.52 +qed "not_less_Least";
   34.53 +
   34.54 +
   34.55 +(** apfst -- can be used in similar type definitions **)
   34.56 +
   34.57 +goalw Univ.thy [apfst_def] "apfst f <a,b> = <f(a),b>";
   34.58 +by (rtac split 1);
   34.59 +qed "apfst";
   34.60 +
   34.61 +val [major,minor] = goal Univ.thy
   34.62 +    "[| q = apfst f p;  !!x y. [| p = <x,y>;  q = <f(x),y> |] ==> R \
   34.63 +\    |] ==> R";
   34.64 +by (rtac PairE 1);
   34.65 +by (rtac minor 1);
   34.66 +by (assume_tac 1);
   34.67 +by (rtac (major RS trans) 1);
   34.68 +by (etac ssubst 1);
   34.69 +by (rtac apfst 1);
   34.70 +qed "apfstE";
   34.71 +
   34.72 +(** Push -- an injection, analogous to Cons on lists **)
   34.73 +
   34.74 +val [major] = goalw Univ.thy [Push_def] "Push i f =Push j g  ==> i=j";
   34.75 +by (rtac (major RS fun_cong RS box_equals RS Suc_inject) 1);
   34.76 +by (rtac nat_case_0 1);
   34.77 +by (rtac nat_case_0 1);
   34.78 +qed "Push_inject1";
   34.79 +
   34.80 +val [major] = goalw Univ.thy [Push_def] "Push i f =Push j g  ==> f=g";
   34.81 +by (rtac (major RS fun_cong RS ext RS box_equals) 1);
   34.82 +by (rtac (nat_case_Suc RS ext) 1);
   34.83 +by (rtac (nat_case_Suc RS ext) 1);
   34.84 +qed "Push_inject2";
   34.85 +
   34.86 +val [major,minor] = goal Univ.thy
   34.87 +    "[| Push i f =Push j g;  [| i=j;  f=g |] ==> P \
   34.88 +\    |] ==> P";
   34.89 +by (rtac ((major RS Push_inject2) RS ((major RS Push_inject1) RS minor)) 1);
   34.90 +qed "Push_inject";
   34.91 +
   34.92 +val [major] = goalw Univ.thy [Push_def] "Push k f =(%z.0) ==> P";
   34.93 +by (rtac (major RS fun_cong RS box_equals RS Suc_neq_Zero) 1);
   34.94 +by (rtac nat_case_0 1);
   34.95 +by (rtac refl 1);
   34.96 +qed "Push_neq_K0";
   34.97 +
   34.98 +(*** Isomorphisms ***)
   34.99 +
  34.100 +goal Univ.thy "inj(Rep_Node)";
  34.101 +by (rtac inj_inverseI 1);	(*cannot combine by RS: multiple unifiers*)
  34.102 +by (rtac Rep_Node_inverse 1);
  34.103 +qed "inj_Rep_Node";
  34.104 +
  34.105 +goal Univ.thy "inj_onto Abs_Node Node";
  34.106 +by (rtac inj_onto_inverseI 1);
  34.107 +by (etac Abs_Node_inverse 1);
  34.108 +qed "inj_onto_Abs_Node";
  34.109 +
  34.110 +val Abs_Node_inject = inj_onto_Abs_Node RS inj_ontoD;
  34.111 +
  34.112 +
  34.113 +(*** Introduction rules for Node ***)
  34.114 +
  34.115 +goalw Univ.thy [Node_def] "<%k. 0,a> : Node";
  34.116 +by (fast_tac set_cs 1);
  34.117 +qed "Node_K0_I";
  34.118 +
  34.119 +goalw Univ.thy [Node_def,Push_def]
  34.120 +    "!!p. p: Node ==> apfst (Push i) p : Node";
  34.121 +by (fast_tac (set_cs addSIs [apfst, nat_case_Suc RS trans]) 1);
  34.122 +qed "Node_Push_I";
  34.123 +
  34.124 +
  34.125 +(*** Distinctness of constructors ***)
  34.126 +
  34.127 +(** Scons vs Atom **)
  34.128 +
  34.129 +goalw Univ.thy [Atom_def,Scons_def,Push_Node_def] "(M$N) ~= Atom(a)";
  34.130 +by (rtac notI 1);
  34.131 +by (etac (equalityD2 RS subsetD RS UnE) 1);
  34.132 +by (rtac singletonI 1);
  34.133 +by (REPEAT (eresolve_tac [imageE, Abs_Node_inject RS apfstE, 
  34.134 +			  Pair_inject, sym RS Push_neq_K0] 1
  34.135 +     ORELSE resolve_tac [Node_K0_I, Rep_Node RS Node_Push_I] 1));
  34.136 +qed "Scons_not_Atom";
  34.137 +bind_thm ("Atom_not_Scons", (Scons_not_Atom RS not_sym));
  34.138 +
  34.139 +bind_thm ("Scons_neq_Atom", (Scons_not_Atom RS notE));
  34.140 +val Atom_neq_Scons = sym RS Scons_neq_Atom;
  34.141 +
  34.142 +(*** Injectiveness ***)
  34.143 +
  34.144 +(** Atomic nodes **)
  34.145 +
  34.146 +goalw Univ.thy [Atom_def] "inj(Atom)";
  34.147 +by (rtac injI 1);
  34.148 +by (etac (singleton_inject RS Abs_Node_inject RS Pair_inject) 1);
  34.149 +by (REPEAT (ares_tac [Node_K0_I] 1));
  34.150 +qed "inj_Atom";
  34.151 +val Atom_inject = inj_Atom RS injD;
  34.152 +
  34.153 +goalw Univ.thy [Leaf_def,o_def] "inj(Leaf)";
  34.154 +by (rtac injI 1);
  34.155 +by (etac (Atom_inject RS Inl_inject) 1);
  34.156 +qed "inj_Leaf";
  34.157 +
  34.158 +val Leaf_inject = inj_Leaf RS injD;
  34.159 +
  34.160 +goalw Univ.thy [Numb_def,o_def] "inj(Numb)";
  34.161 +by (rtac injI 1);
  34.162 +by (etac (Atom_inject RS Inr_inject) 1);
  34.163 +qed "inj_Numb";
  34.164 +
  34.165 +val Numb_inject = inj_Numb RS injD;
  34.166 +
  34.167 +(** Injectiveness of Push_Node **)
  34.168 +
  34.169 +val [major,minor] = goalw Univ.thy [Push_Node_def]
  34.170 +    "[| Push_Node i m =Push_Node j n;  [| i=j;  m=n |] ==> P \
  34.171 +\    |] ==> P";
  34.172 +by (rtac (major RS Abs_Node_inject RS apfstE) 1);
  34.173 +by (REPEAT (resolve_tac [Rep_Node RS Node_Push_I] 1));
  34.174 +by (etac (sym RS apfstE) 1);
  34.175 +by (rtac minor 1);
  34.176 +by (etac Pair_inject 1);
  34.177 +by (etac (Push_inject1 RS sym) 1);
  34.178 +by (rtac (inj_Rep_Node RS injD) 1);
  34.179 +by (etac trans 1);
  34.180 +by (safe_tac (HOL_cs addSEs [Pair_inject,Push_inject,sym]));
  34.181 +qed "Push_Node_inject";
  34.182 +
  34.183 +
  34.184 +(** Injectiveness of Scons **)
  34.185 +
  34.186 +val [major] = goalw Univ.thy [Scons_def] "M$N <= M'$N' ==> M<=M'";
  34.187 +by (cut_facts_tac [major] 1);
  34.188 +by (fast_tac (set_cs addSDs [Suc_inject]
  34.189 +		     addSEs [Push_Node_inject, Zero_neq_Suc]) 1);
  34.190 +qed "Scons_inject_lemma1";
  34.191 +
  34.192 +val [major] = goalw Univ.thy [Scons_def] "M$N <= M'$N' ==> N<=N'";
  34.193 +by (cut_facts_tac [major] 1);
  34.194 +by (fast_tac (set_cs addSDs [Suc_inject]
  34.195 +		     addSEs [Push_Node_inject, Suc_neq_Zero]) 1);
  34.196 +qed "Scons_inject_lemma2";
  34.197 +
  34.198 +val [major] = goal Univ.thy "M$N = M'$N' ==> M=M'";
  34.199 +by (rtac (major RS equalityE) 1);
  34.200 +by (REPEAT (ares_tac [equalityI, Scons_inject_lemma1] 1));
  34.201 +qed "Scons_inject1";
  34.202 +
  34.203 +val [major] = goal Univ.thy "M$N = M'$N' ==> N=N'";
  34.204 +by (rtac (major RS equalityE) 1);
  34.205 +by (REPEAT (ares_tac [equalityI, Scons_inject_lemma2] 1));
  34.206 +qed "Scons_inject2";
  34.207 +
  34.208 +val [major,minor] = goal Univ.thy
  34.209 +    "[| M$N = M'$N';  [| M=M';  N=N' |] ==> P \
  34.210 +\    |] ==> P";
  34.211 +by (rtac ((major RS Scons_inject2) RS ((major RS Scons_inject1) RS minor)) 1);
  34.212 +qed "Scons_inject";
  34.213 +
  34.214 +(*rewrite rules*)
  34.215 +goal Univ.thy "(Atom(a)=Atom(b)) = (a=b)";
  34.216 +by (fast_tac (HOL_cs addSEs [Atom_inject]) 1);
  34.217 +qed "Atom_Atom_eq";
  34.218 +
  34.219 +goal Univ.thy "(M$N = M'$N') = (M=M' & N=N')";
  34.220 +by (fast_tac (HOL_cs addSEs [Scons_inject]) 1);
  34.221 +qed "Scons_Scons_eq";
  34.222 +
  34.223 +(*** Distinctness involving Leaf and Numb ***)
  34.224 +
  34.225 +(** Scons vs Leaf **)
  34.226 +
  34.227 +goalw Univ.thy [Leaf_def,o_def] "(M$N) ~= Leaf(a)";
  34.228 +by (rtac Scons_not_Atom 1);
  34.229 +qed "Scons_not_Leaf";
  34.230 +bind_thm ("Leaf_not_Scons", (Scons_not_Leaf RS not_sym));
  34.231 +
  34.232 +bind_thm ("Scons_neq_Leaf", (Scons_not_Leaf RS notE));
  34.233 +val Leaf_neq_Scons = sym RS Scons_neq_Leaf;
  34.234 +
  34.235 +(** Scons vs Numb **)
  34.236 +
  34.237 +goalw Univ.thy [Numb_def,o_def] "(M$N) ~= Numb(k)";
  34.238 +by (rtac Scons_not_Atom 1);
  34.239 +qed "Scons_not_Numb";
  34.240 +bind_thm ("Numb_not_Scons", (Scons_not_Numb RS not_sym));
  34.241 +
  34.242 +bind_thm ("Scons_neq_Numb", (Scons_not_Numb RS notE));
  34.243 +val Numb_neq_Scons = sym RS Scons_neq_Numb;
  34.244 +
  34.245 +(** Leaf vs Numb **)
  34.246 +
  34.247 +goalw Univ.thy [Leaf_def,Numb_def] "Leaf(a) ~= Numb(k)";
  34.248 +by (simp_tac (HOL_ss addsimps [Atom_Atom_eq,Inl_not_Inr]) 1);
  34.249 +qed "Leaf_not_Numb";
  34.250 +bind_thm ("Numb_not_Leaf", (Leaf_not_Numb RS not_sym));
  34.251 +
  34.252 +bind_thm ("Leaf_neq_Numb", (Leaf_not_Numb RS notE));
  34.253 +val Numb_neq_Leaf = sym RS Leaf_neq_Numb;
  34.254 +
  34.255 +
  34.256 +(*** ndepth -- the depth of a node ***)
  34.257 +
  34.258 +val univ_simps = [apfst,Scons_not_Atom,Atom_not_Scons,Scons_Scons_eq];
  34.259 +val univ_ss = nat_ss addsimps univ_simps;
  34.260 +
  34.261 +
  34.262 +goalw Univ.thy [ndepth_def] "ndepth (Abs_Node(<%k.0, x>)) = 0";
  34.263 +by (sstac [Node_K0_I RS Abs_Node_inverse, split] 1);
  34.264 +by (rtac Least_equality 1);
  34.265 +by (rtac refl 1);
  34.266 +by (etac less_zeroE 1);
  34.267 +qed "ndepth_K0";
  34.268 +
  34.269 +goal Univ.thy "k < Suc(LEAST x. f(x)=0) --> nat_case (Suc i) f k ~= 0";
  34.270 +by (nat_ind_tac "k" 1);
  34.271 +by (ALLGOALS (simp_tac nat_ss));
  34.272 +by (rtac impI 1);
  34.273 +by (etac not_less_Least 1);
  34.274 +qed "ndepth_Push_lemma";
  34.275 +
  34.276 +goalw Univ.thy [ndepth_def,Push_Node_def]
  34.277 +    "ndepth (Push_Node i n) = Suc(ndepth(n))";
  34.278 +by (stac (Rep_Node RS Node_Push_I RS Abs_Node_inverse) 1);
  34.279 +by (cut_facts_tac [rewrite_rule [Node_def] Rep_Node] 1);
  34.280 +by (safe_tac set_cs);
  34.281 +be ssubst 1;  (*instantiates type variables!*)
  34.282 +by (simp_tac univ_ss 1);
  34.283 +by (rtac Least_equality 1);
  34.284 +by (rewtac Push_def);
  34.285 +by (rtac (nat_case_Suc RS trans) 1);
  34.286 +by (etac LeastI 1);
  34.287 +by (etac (ndepth_Push_lemma RS mp) 1);
  34.288 +qed "ndepth_Push_Node";
  34.289 +
  34.290 +
  34.291 +(*** ntrunc applied to the various node sets ***)
  34.292 +
  34.293 +goalw Univ.thy [ntrunc_def] "ntrunc 0 M = {}";
  34.294 +by (safe_tac (set_cs addSIs [equalityI] addSEs [less_zeroE]));
  34.295 +qed "ntrunc_0";
  34.296 +
  34.297 +goalw Univ.thy [Atom_def,ntrunc_def] "ntrunc (Suc k) (Atom a) = Atom(a)";
  34.298 +by (safe_tac (set_cs addSIs [equalityI]));
  34.299 +by (stac ndepth_K0 1);
  34.300 +by (rtac zero_less_Suc 1);
  34.301 +qed "ntrunc_Atom";
  34.302 +
  34.303 +goalw Univ.thy [Leaf_def,o_def] "ntrunc (Suc k) (Leaf a) = Leaf(a)";
  34.304 +by (rtac ntrunc_Atom 1);
  34.305 +qed "ntrunc_Leaf";
  34.306 +
  34.307 +goalw Univ.thy [Numb_def,o_def] "ntrunc (Suc k) (Numb i) = Numb(i)";
  34.308 +by (rtac ntrunc_Atom 1);
  34.309 +qed "ntrunc_Numb";
  34.310 +
  34.311 +goalw Univ.thy [Scons_def,ntrunc_def]
  34.312 +    "ntrunc (Suc k) (M$N) = ntrunc k M $ ntrunc k N";
  34.313 +by (safe_tac (set_cs addSIs [equalityI,imageI]));
  34.314 +by (REPEAT (stac ndepth_Push_Node 3 THEN etac Suc_mono 3));
  34.315 +by (REPEAT (rtac Suc_less_SucD 1 THEN 
  34.316 +	    rtac (ndepth_Push_Node RS subst) 1 THEN 
  34.317 +	    assume_tac 1));
  34.318 +qed "ntrunc_Scons";
  34.319 +
  34.320 +(** Injection nodes **)
  34.321 +
  34.322 +goalw Univ.thy [In0_def] "ntrunc (Suc 0) (In0 M) = {}";
  34.323 +by (simp_tac (univ_ss addsimps [ntrunc_Scons,ntrunc_0]) 1);
  34.324 +by (rewtac Scons_def);
  34.325 +by (safe_tac (set_cs addSIs [equalityI]));
  34.326 +qed "ntrunc_one_In0";
  34.327 +
  34.328 +goalw Univ.thy [In0_def]
  34.329 +    "ntrunc (Suc (Suc k)) (In0 M) = In0 (ntrunc (Suc k) M)";
  34.330 +by (simp_tac (univ_ss addsimps [ntrunc_Scons,ntrunc_Numb]) 1);
  34.331 +qed "ntrunc_In0";
  34.332 +
  34.333 +goalw Univ.thy [In1_def] "ntrunc (Suc 0) (In1 M) = {}";
  34.334 +by (simp_tac (univ_ss addsimps [ntrunc_Scons,ntrunc_0]) 1);
  34.335 +by (rewtac Scons_def);
  34.336 +by (safe_tac (set_cs addSIs [equalityI]));
  34.337 +qed "ntrunc_one_In1";
  34.338 +
  34.339 +goalw Univ.thy [In1_def]
  34.340 +    "ntrunc (Suc (Suc k)) (In1 M) = In1 (ntrunc (Suc k) M)";
  34.341 +by (simp_tac (univ_ss addsimps [ntrunc_Scons,ntrunc_Numb]) 1);
  34.342 +qed "ntrunc_In1";
  34.343 +
  34.344 +
  34.345 +(*** Cartesian Product ***)
  34.346 +
  34.347 +goalw Univ.thy [uprod_def] "!!M N. [| M:A;  N:B |] ==> (M$N) : A<*>B";
  34.348 +by (REPEAT (ares_tac [singletonI,UN_I] 1));
  34.349 +qed "uprodI";
  34.350 +
  34.351 +(*The general elimination rule*)
  34.352 +val major::prems = goalw Univ.thy [uprod_def]
  34.353 +    "[| c : A<*>B;  \
  34.354 +\       !!x y. [| x:A;  y:B;  c=x$y |] ==> P \
  34.355 +\    |] ==> P";
  34.356 +by (cut_facts_tac [major] 1);
  34.357 +by (REPEAT (eresolve_tac [asm_rl,singletonE,UN_E] 1
  34.358 +     ORELSE resolve_tac prems 1));
  34.359 +qed "uprodE";
  34.360 +
  34.361 +(*Elimination of a pair -- introduces no eigenvariables*)
  34.362 +val prems = goal Univ.thy
  34.363 +    "[| (M$N) : A<*>B;      [| M:A;  N:B |] ==> P   \
  34.364 +\    |] ==> P";
  34.365 +by (rtac uprodE 1);
  34.366 +by (REPEAT (ares_tac prems 1 ORELSE eresolve_tac [Scons_inject,ssubst] 1));
  34.367 +qed "uprodE2";
  34.368 +
  34.369 +
  34.370 +(*** Disjoint Sum ***)
  34.371 +
  34.372 +goalw Univ.thy [usum_def] "!!M. M:A ==> In0(M) : A<+>B";
  34.373 +by (fast_tac set_cs 1);
  34.374 +qed "usum_In0I";
  34.375 +
  34.376 +goalw Univ.thy [usum_def] "!!N. N:B ==> In1(N) : A<+>B";
  34.377 +by (fast_tac set_cs 1);
  34.378 +qed "usum_In1I";
  34.379 +
  34.380 +val major::prems = goalw Univ.thy [usum_def]
  34.381 +    "[| u : A<+>B;  \
  34.382 +\       !!x. [| x:A;  u=In0(x) |] ==> P; \
  34.383 +\       !!y. [| y:B;  u=In1(y) |] ==> P \
  34.384 +\    |] ==> P";
  34.385 +by (rtac (major RS UnE) 1);
  34.386 +by (REPEAT (rtac refl 1 
  34.387 +     ORELSE eresolve_tac (prems@[imageE,ssubst]) 1));
  34.388 +qed "usumE";
  34.389 +
  34.390 +
  34.391 +(** Injection **)
  34.392 +
  34.393 +goalw Univ.thy [In0_def,In1_def] "In0(M) ~= In1(N)";
  34.394 +by (rtac notI 1);
  34.395 +by (etac (Scons_inject1 RS Numb_inject RS Zero_neq_Suc) 1);
  34.396 +qed "In0_not_In1";
  34.397 +
  34.398 +bind_thm ("In1_not_In0", (In0_not_In1 RS not_sym));
  34.399 +bind_thm ("In0_neq_In1", (In0_not_In1 RS notE));
  34.400 +val In1_neq_In0 = sym RS In0_neq_In1;
  34.401 +
  34.402 +val [major] = goalw Univ.thy [In0_def] "In0(M) = In0(N) ==>  M=N";
  34.403 +by (rtac (major RS Scons_inject2) 1);
  34.404 +qed "In0_inject";
  34.405 +
  34.406 +val [major] = goalw Univ.thy [In1_def] "In1(M) = In1(N) ==>  M=N";
  34.407 +by (rtac (major RS Scons_inject2) 1);
  34.408 +qed "In1_inject";
  34.409 +
  34.410 +
  34.411 +(*** proving equality of sets and functions using ntrunc ***)
  34.412 +
  34.413 +goalw Univ.thy [ntrunc_def] "ntrunc k M <= M";
  34.414 +by (fast_tac set_cs 1);
  34.415 +qed "ntrunc_subsetI";
  34.416 +
  34.417 +val [major] = goalw Univ.thy [ntrunc_def]
  34.418 +    "(!!k. ntrunc k M <= N) ==> M<=N";
  34.419 +by (fast_tac (set_cs addIs [less_add_Suc1, less_add_Suc2, 
  34.420 +			    major RS subsetD]) 1);
  34.421 +qed "ntrunc_subsetD";
  34.422 +
  34.423 +(*A generalized form of the take-lemma*)
  34.424 +val [major] = goal Univ.thy "(!!k. ntrunc k M = ntrunc k N) ==> M=N";
  34.425 +by (rtac equalityI 1);
  34.426 +by (ALLGOALS (rtac ntrunc_subsetD));
  34.427 +by (ALLGOALS (rtac (ntrunc_subsetI RSN (2, subset_trans))));
  34.428 +by (rtac (major RS equalityD1) 1);
  34.429 +by (rtac (major RS equalityD2) 1);
  34.430 +qed "ntrunc_equality";
  34.431 +
  34.432 +val [major] = goalw Univ.thy [o_def]
  34.433 +    "[| !!k. (ntrunc(k) o h1) = (ntrunc(k) o h2) |] ==> h1=h2";
  34.434 +by (rtac (ntrunc_equality RS ext) 1);
  34.435 +by (rtac (major RS fun_cong) 1);
  34.436 +qed "ntrunc_o_equality";
  34.437 +
  34.438 +(*** Monotonicity ***)
  34.439 +
  34.440 +goalw Univ.thy [uprod_def] "!!A B. [| A<=A';  B<=B' |] ==> A<*>B <= A'<*>B'";
  34.441 +by (fast_tac set_cs 1);
  34.442 +qed "uprod_mono";
  34.443 +
  34.444 +goalw Univ.thy [usum_def] "!!A B. [| A<=A';  B<=B' |] ==> A<+>B <= A'<+>B'";
  34.445 +by (fast_tac set_cs 1);
  34.446 +qed "usum_mono";
  34.447 +
  34.448 +goalw Univ.thy [Scons_def] "!!M N. [| M<=M';  N<=N' |] ==> M$N <= M'$N'";
  34.449 +by (fast_tac set_cs 1);
  34.450 +qed "Scons_mono";
  34.451 +
  34.452 +goalw Univ.thy [In0_def] "!!M N. M<=N ==> In0(M) <= In0(N)";
  34.453 +by (REPEAT (ares_tac [subset_refl,Scons_mono] 1));
  34.454 +qed "In0_mono";
  34.455 +
  34.456 +goalw Univ.thy [In1_def] "!!M N. M<=N ==> In1(M) <= In1(N)";
  34.457 +by (REPEAT (ares_tac [subset_refl,Scons_mono] 1));
  34.458 +qed "In1_mono";
  34.459 +
  34.460 +
  34.461 +(*** Split and Case ***)
  34.462 +
  34.463 +goalw Univ.thy [Split_def] "Split c (M$N) = c M N";
  34.464 +by (fast_tac (set_cs addIs [select_equality] addEs [Scons_inject]) 1);
  34.465 +qed "Split";
  34.466 +
  34.467 +goalw Univ.thy [Case_def] "Case c d (In0 M) = c(M)";
  34.468 +by (fast_tac (set_cs addIs [select_equality] 
  34.469 +		     addEs [make_elim In0_inject, In0_neq_In1]) 1);
  34.470 +qed "Case_In0";
  34.471 +
  34.472 +goalw Univ.thy [Case_def] "Case c d (In1 N) = d(N)";
  34.473 +by (fast_tac (set_cs addIs [select_equality] 
  34.474 +		     addEs [make_elim In1_inject, In1_neq_In0]) 1);
  34.475 +qed "Case_In1";
  34.476 +
  34.477 +(**** UN x. B(x) rules ****)
  34.478 +
  34.479 +goalw Univ.thy [ntrunc_def] "ntrunc k (UN x.f(x)) = (UN x. ntrunc k (f x))";
  34.480 +by (fast_tac (set_cs addIs [equalityI]) 1);
  34.481 +qed "ntrunc_UN1";
  34.482 +
  34.483 +goalw Univ.thy [Scons_def] "(UN x.f(x)) $ M = (UN x. f(x) $ M)";
  34.484 +by (fast_tac (set_cs addIs [equalityI]) 1);
  34.485 +qed "Scons_UN1_x";
  34.486 +
  34.487 +goalw Univ.thy [Scons_def] "M $ (UN x.f(x)) = (UN x. M $ f(x))";
  34.488 +by (fast_tac (set_cs addIs [equalityI]) 1);
  34.489 +qed "Scons_UN1_y";
  34.490 +
  34.491 +goalw Univ.thy [In0_def] "In0(UN x.f(x)) = (UN x. In0(f(x)))";
  34.492 +br Scons_UN1_y 1;
  34.493 +qed "In0_UN1";
  34.494 +
  34.495 +goalw Univ.thy [In1_def] "In1(UN x.f(x)) = (UN x. In1(f(x)))";
  34.496 +br Scons_UN1_y 1;
  34.497 +qed "In1_UN1";
  34.498 +
  34.499 +
  34.500 +(*** Equality : the diagonal relation ***)
  34.501 +
  34.502 +goalw Univ.thy [diag_def] "!!a A. [| a=b;  a:A |] ==> <a,b> : diag(A)";
  34.503 +by (fast_tac set_cs 1);
  34.504 +qed "diag_eqI";
  34.505 +
  34.506 +val diagI = refl RS diag_eqI |> standard;
  34.507 +
  34.508 +(*The general elimination rule*)
  34.509 +val major::prems = goalw Univ.thy [diag_def]
  34.510 +    "[| c : diag(A);  \
  34.511 +\       !!x y. [| x:A;  c = <x,x> |] ==> P \
  34.512 +\    |] ==> P";
  34.513 +by (rtac (major RS UN_E) 1);
  34.514 +by (REPEAT (eresolve_tac [asm_rl,singletonE] 1 ORELSE resolve_tac prems 1));
  34.515 +qed "diagE";
  34.516 +
  34.517 +(*** Equality for Cartesian Product ***)
  34.518 +
  34.519 +goalw Univ.thy [dprod_def]
  34.520 +    "!!r s. [| <M,M'>:r;  <N,N'>:s |] ==> <M$N, M'$N'> : r<**>s";
  34.521 +by (fast_tac prod_cs 1);
  34.522 +qed "dprodI";
  34.523 +
  34.524 +(*The general elimination rule*)
  34.525 +val major::prems = goalw Univ.thy [dprod_def]
  34.526 +    "[| c : r<**>s;  \
  34.527 +\       !!x y x' y'. [| <x,x'> : r;  <y,y'> : s;  c = <x$y,x'$y'> |] ==> P \
  34.528 +\    |] ==> P";
  34.529 +by (cut_facts_tac [major] 1);
  34.530 +by (REPEAT_FIRST (eresolve_tac [asm_rl, UN_E, mem_splitE, singletonE]));
  34.531 +by (REPEAT (ares_tac prems 1 ORELSE hyp_subst_tac 1));
  34.532 +qed "dprodE";
  34.533 +
  34.534 +
  34.535 +(*** Equality for Disjoint Sum ***)
  34.536 +
  34.537 +goalw Univ.thy [dsum_def]  "!!r. <M,M'>:r ==> <In0(M), In0(M')> : r<++>s";
  34.538 +by (fast_tac prod_cs 1);
  34.539 +qed "dsum_In0I";
  34.540 +
  34.541 +goalw Univ.thy [dsum_def]  "!!r. <N,N'>:s ==> <In1(N), In1(N')> : r<++>s";
  34.542 +by (fast_tac prod_cs 1);
  34.543 +qed "dsum_In1I";
  34.544 +
  34.545 +val major::prems = goalw Univ.thy [dsum_def]
  34.546 +    "[| w : r<++>s;  \
  34.547 +\       !!x x'. [| <x,x'> : r;  w = <In0(x), In0(x')> |] ==> P; \
  34.548 +\       !!y y'. [| <y,y'> : s;  w = <In1(y), In1(y')> |] ==> P \
  34.549 +\    |] ==> P";
  34.550 +by (cut_facts_tac [major] 1);
  34.551 +by (REPEAT_FIRST (eresolve_tac [asm_rl, UN_E, UnE, mem_splitE, singletonE]));
  34.552 +by (DEPTH_SOLVE (ares_tac prems 1 ORELSE hyp_subst_tac 1));
  34.553 +qed "dsumE";
  34.554 +
  34.555 +
  34.556 +val univ_cs =
  34.557 +    prod_cs addSIs [diagI, uprodI, dprodI]
  34.558 +            addIs  [usum_In0I, usum_In1I, dsum_In0I, dsum_In1I]
  34.559 +            addSEs [diagE, uprodE, dprodE, usumE, dsumE];
  34.560 +
  34.561 +
  34.562 +(*** Monotonicity ***)
  34.563 +
  34.564 +goal Univ.thy "!!r s. [| r<=r';  s<=s' |] ==> r<**>s <= r'<**>s'";
  34.565 +by (fast_tac univ_cs 1);
  34.566 +qed "dprod_mono";
  34.567 +
  34.568 +goal Univ.thy "!!r s. [| r<=r';  s<=s' |] ==> r<++>s <= r'<++>s'";
  34.569 +by (fast_tac univ_cs 1);
  34.570 +qed "dsum_mono";
  34.571 +
  34.572 +
  34.573 +(*** Bounding theorems ***)
  34.574 +
  34.575 +goal Univ.thy "diag(A) <= Sigma A (%x.A)";
  34.576 +by (fast_tac univ_cs 1);
  34.577 +qed "diag_subset_Sigma";
  34.578 +
  34.579 +goal Univ.thy "(Sigma A (%x.B) <**> Sigma C (%x.D)) <= Sigma (A<*>C) (%z. B<*>D)";
  34.580 +by (fast_tac univ_cs 1);
  34.581 +qed "dprod_Sigma";
  34.582 +
  34.583 +val dprod_subset_Sigma = [dprod_mono, dprod_Sigma] MRS subset_trans |>standard;
  34.584 +
  34.585 +(*Dependent version*)
  34.586 +goal Univ.thy
  34.587 +    "(Sigma A B <**> Sigma C D) <= Sigma (A<*>C) (Split(%x y. B(x)<*>D(y)))";
  34.588 +by (safe_tac univ_cs);
  34.589 +by (stac Split 1);
  34.590 +by (fast_tac univ_cs 1);
  34.591 +qed "dprod_subset_Sigma2";
  34.592 +
  34.593 +goal Univ.thy "(Sigma A (%x.B) <++> Sigma C (%x.D)) <= Sigma (A<+>C) (%z. B<+>D)";
  34.594 +by (fast_tac univ_cs 1);
  34.595 +qed "dsum_Sigma";
  34.596 +
  34.597 +val dsum_subset_Sigma = [dsum_mono, dsum_Sigma] MRS subset_trans |> standard;
  34.598 +
  34.599 +
  34.600 +(*** Domain ***)
  34.601 +
  34.602 +goal Univ.thy "fst `` diag(A) = A";
  34.603 +by (fast_tac (prod_cs addIs [equalityI, diagI] addSEs [diagE]) 1);
  34.604 +qed "fst_image_diag";
  34.605 +
  34.606 +goal Univ.thy "fst `` (r<**>s) = (fst``r) <*> (fst``s)";
  34.607 +by (fast_tac (prod_cs addIs [equalityI, uprodI, dprodI]
  34.608 +                     addSEs [uprodE, dprodE]) 1);
  34.609 +qed "fst_image_dprod";
  34.610 +
  34.611 +goal Univ.thy "fst `` (r<++>s) = (fst``r) <+> (fst``s)";
  34.612 +by (fast_tac (prod_cs addIs [equalityI, usum_In0I, usum_In1I, 
  34.613 +			     dsum_In0I, dsum_In1I]
  34.614 +                     addSEs [usumE, dsumE]) 1);
  34.615 +qed "fst_image_dsum";
  34.616 +
  34.617 +val fst_image_simps = [fst_image_diag, fst_image_dprod, fst_image_dsum];
  34.618 +val fst_image_ss = univ_ss addsimps fst_image_simps;
    35.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    35.2 +++ b/src/HOL/Univ.thy	Fri Mar 03 12:02:25 1995 +0100
    35.3 @@ -0,0 +1,103 @@
    35.4 +(*  Title:      HOL/Univ.thy
    35.5 +    ID:         $Id$
    35.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    35.7 +    Copyright   1993  University of Cambridge
    35.8 +
    35.9 +Move LEAST to Nat.thy???  Could it be defined for all types 'a::ord?
   35.10 +
   35.11 +Declares the type 'a node, a subtype of (nat=>nat) * ('a+nat)
   35.12 +
   35.13 +Defines "Cartesian Product" and "Disjoint Sum" as set operations.
   35.14 +Could <*> be generalized to a general summation (Sigma)?
   35.15 +*)
   35.16 +
   35.17 +Univ = Arith + Sum +
   35.18 +
   35.19 +(** lists, trees will be sets of nodes **)
   35.20 +
   35.21 +subtype (Node)
   35.22 +  'a node = "{p. EX f x k. p = <f::nat=>nat, x::'a+nat> & f(k)=0}"
   35.23 +
   35.24 +types
   35.25 +  'a item = "'a node set"
   35.26 +
   35.27 +consts
   35.28 +  Least     :: "(nat=>bool) => nat"    (binder "LEAST " 10)
   35.29 +
   35.30 +  apfst     :: "['a=>'c, 'a*'b] => 'c*'b"
   35.31 +  Push      :: "[nat, nat=>nat] => (nat=>nat)"
   35.32 +
   35.33 +  Push_Node :: "[nat, 'a node] => 'a node"
   35.34 +  ndepth    :: "'a node => nat"
   35.35 +
   35.36 +  Atom      :: "('a+nat) => 'a item"
   35.37 +  Leaf      :: "'a => 'a item"
   35.38 +  Numb      :: "nat => 'a item"
   35.39 +  "$"       :: "['a item, 'a item]=> 'a item"   (infixr 60)
   35.40 +  In0,In1   :: "'a item => 'a item"
   35.41 +
   35.42 +  ntrunc    :: "[nat, 'a item] => 'a item"
   35.43 +
   35.44 +  "<*>"  :: "['a item set, 'a item set]=> 'a item set" (infixr 80)
   35.45 +  "<+>"  :: "['a item set, 'a item set]=> 'a item set" (infixr 70)
   35.46 +
   35.47 +  Split  :: "[['a item, 'a item]=>'b, 'a item] => 'b"
   35.48 +  Case   :: "[['a item]=>'b, ['a item]=>'b, 'a item] => 'b"
   35.49 +
   35.50 +  diag   :: "'a set => ('a * 'a)set"
   35.51 +  "<**>" :: "[('a item * 'a item)set, ('a item * 'a item)set] \
   35.52 +\           => ('a item * 'a item)set" (infixr 80)
   35.53 +  "<++>" :: "[('a item * 'a item)set, ('a item * 'a item)set] \
   35.54 +\           => ('a item * 'a item)set" (infixr 70)
   35.55 +
   35.56 +defs
   35.57 +
   35.58 +  (*least number operator*)
   35.59 +  Least_def      "Least(P) == @k. P(k) & (ALL j. j<k --> ~P(j))"
   35.60 +
   35.61 +  Push_Node_def  "Push_Node == (%n x. Abs_Node (apfst (Push n) (Rep_Node x)))"
   35.62 +
   35.63 +  (*crude "lists" of nats -- needed for the constructions*)
   35.64 +  apfst_def  "apfst == (%f. split(%x y. <f(x),y>))"
   35.65 +  Push_def   "Push == (%b h. nat_case (Suc b) h)"
   35.66 +
   35.67 +  (** operations on S-expressions -- sets of nodes **)
   35.68 +
   35.69 +  (*S-expression constructors*)
   35.70 +  Atom_def   "Atom == (%x. {Abs_Node(<%k.0, x>)})"
   35.71 +  Scons_def  "M$N == (Push_Node(0) `` M) Un (Push_Node(Suc(0)) `` N)"
   35.72 +
   35.73 +  (*Leaf nodes, with arbitrary or nat labels*)
   35.74 +  Leaf_def   "Leaf == Atom o Inl"
   35.75 +  Numb_def   "Numb == Atom o Inr"
   35.76 +
   35.77 +  (*Injections of the "disjoint sum"*)
   35.78 +  In0_def    "In0(M) == Numb(0) $ M"
   35.79 +  In1_def    "In1(M) == Numb(Suc(0)) $ M"
   35.80 +
   35.81 +  (*the set of nodes with depth less than k*)
   35.82 +  ndepth_def "ndepth(n) == split (%f x. LEAST k. f(k)=0) (Rep_Node n)"
   35.83 +  ntrunc_def "ntrunc k N == {n. n:N & ndepth(n)<k}"
   35.84 +
   35.85 +  (*products and sums for the "universe"*)
   35.86 +  uprod_def  "A<*>B == UN x:A. UN y:B. { (x$y) }"
   35.87 +  usum_def   "A<+>B == In0``A Un In1``B"
   35.88 +
   35.89 +  (*the corresponding eliminators*)
   35.90 +  Split_def  "Split c M == @u. ? x y. M = x$y & u = c x y"
   35.91 +
   35.92 +  Case_def   "Case c d M == @u.  (? x . M = In0(x) & u = c(x)) \
   35.93 +\                              | (? y . M = In1(y) & u = d(y))"
   35.94 +
   35.95 +
   35.96 +  (** diagonal sets and equality for the "universe" **)
   35.97 +
   35.98 +  diag_def   "diag(A) == UN x:A. {<x,x>}"
   35.99 +
  35.100 +  dprod_def  "r<**>s == UN u:r. split (%x x'. \
  35.101 +\                       UN v:s. split (%y y'. {<x$y,x'$y'>}) v) u"
  35.102 +
  35.103 +  dsum_def   "r<++>s == (UN u:r. split (%x x'. {<In0(x),In0(x')>}) u) Un \
  35.104 +\                       (UN v:s. split (%y y'. {<In1(y),In1(y')>}) v)"
  35.105 +
  35.106 +end
    36.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    36.2 +++ b/src/HOL/WF.ML	Fri Mar 03 12:02:25 1995 +0100
    36.3 @@ -0,0 +1,198 @@
    36.4 +(*  Title: 	HOL/wf.ML
    36.5 +    ID:         $Id$
    36.6 +    Author: 	Tobias Nipkow
    36.7 +    Copyright   1992  University of Cambridge
    36.8 +
    36.9 +For wf.thy.  Well-founded Recursion
   36.10 +*)
   36.11 +
   36.12 +open WF;
   36.13 +
   36.14 +val H_cong = read_instantiate [("f","H::[?'a, ?'a=>?'b]=>?'b")]
   36.15 +               (standard(refl RS cong RS cong));
   36.16 +val H_cong1 = refl RS H_cong;
   36.17 +
   36.18 +(*Restriction to domain A.  If r is well-founded over A then wf(r)*)
   36.19 +val [prem1,prem2] = goalw WF.thy [wf_def]
   36.20 + "[| r <= Sigma A (%u.A);  \
   36.21 +\    !!x P. [| ! x. (! y. <y,x> : r --> P(y)) --> P(x);  x:A |] ==> P(x) |]  \
   36.22 +\ ==>  wf(r)";
   36.23 +by (strip_tac 1);
   36.24 +by (rtac allE 1);
   36.25 +by (assume_tac 1);
   36.26 +by (best_tac (HOL_cs addSEs [prem1 RS subsetD RS SigmaE2] addIs [prem2]) 1);
   36.27 +qed "wfI";
   36.28 +
   36.29 +val major::prems = goalw WF.thy [wf_def]
   36.30 +    "[| wf(r);          \
   36.31 +\       !!x.[| ! y. <y,x>: r --> P(y) |] ==> P(x) \
   36.32 +\    |]  ==>  P(a)";
   36.33 +by (rtac (major RS spec RS mp RS spec) 1);
   36.34 +by (fast_tac (HOL_cs addEs prems) 1);
   36.35 +qed "wf_induct";
   36.36 +
   36.37 +(*Perform induction on i, then prove the wf(r) subgoal using prems. *)
   36.38 +fun wf_ind_tac a prems i = 
   36.39 +    EVERY [res_inst_tac [("a",a)] wf_induct i,
   36.40 +	   rename_last_tac a ["1"] (i+1),
   36.41 +	   ares_tac prems i];
   36.42 +
   36.43 +val prems = goal WF.thy "[| wf(r);  <a,x>:r;  <x,a>:r |] ==> P";
   36.44 +by (subgoal_tac "! x. <a,x>:r --> <x,a>:r --> P" 1);
   36.45 +by (fast_tac (HOL_cs addIs prems) 1);
   36.46 +by (wf_ind_tac "a" prems 1);
   36.47 +by (fast_tac set_cs 1);
   36.48 +qed "wf_asym";
   36.49 +
   36.50 +val prems = goal WF.thy "[| wf(r);  <a,a>: r |] ==> P";
   36.51 +by (rtac wf_asym 1);
   36.52 +by (REPEAT (resolve_tac prems 1));
   36.53 +qed "wf_anti_refl";
   36.54 +
   36.55 +(*transitive closure of a WF relation is WF!*)
   36.56 +val [prem] = goal WF.thy "wf(r) ==> wf(r^+)";
   36.57 +by (rewtac wf_def);
   36.58 +by (strip_tac 1);
   36.59 +(*must retain the universal formula for later use!*)
   36.60 +by (rtac allE 1 THEN assume_tac 1);
   36.61 +by (etac mp 1);
   36.62 +by (res_inst_tac [("a","x")] (prem RS wf_induct) 1);
   36.63 +by (rtac (impI RS allI) 1);
   36.64 +by (etac tranclE 1);
   36.65 +by (fast_tac HOL_cs 1);
   36.66 +by (fast_tac HOL_cs 1);
   36.67 +qed "wf_trancl";
   36.68 +
   36.69 +
   36.70 +(** cut **)
   36.71 +
   36.72 +(*This rewrite rule works upon formulae; thus it requires explicit use of
   36.73 +  H_cong to expose the equality*)
   36.74 +goalw WF.thy [cut_def]
   36.75 +    "(cut f r x = cut g r x) = (!y. <y,x>:r --> f(y)=g(y))";
   36.76 +by(simp_tac (HOL_ss addsimps [expand_fun_eq]
   36.77 +                    setloop (split_tac [expand_if])) 1);
   36.78 +qed "cut_cut_eq";
   36.79 +
   36.80 +goalw WF.thy [cut_def] "!!x. <x,a>:r ==> (cut f r a)(x) = f(x)";
   36.81 +by(asm_simp_tac HOL_ss 1);
   36.82 +qed "cut_apply";
   36.83 +
   36.84 +
   36.85 +(*** is_recfun ***)
   36.86 +
   36.87 +goalw WF.thy [is_recfun_def,cut_def]
   36.88 +    "!!f. [| is_recfun r a H f;  ~<b,a>:r |] ==> f(b) = (@z.True)";
   36.89 +by (etac ssubst 1);
   36.90 +by(asm_simp_tac HOL_ss 1);
   36.91 +qed "is_recfun_undef";
   36.92 +
   36.93 +(*eresolve_tac transD solves <a,b>:r using transitivity AT MOST ONCE
   36.94 +  mp amd allE  instantiate induction hypotheses*)
   36.95 +fun indhyp_tac hyps =
   36.96 +    ares_tac (TrueI::hyps) ORELSE' 
   36.97 +    (cut_facts_tac hyps THEN'
   36.98 +       DEPTH_SOLVE_1 o (ares_tac [TrueI] ORELSE'
   36.99 +		        eresolve_tac [transD, mp, allE]));
  36.100 +
  36.101 +(*** NOTE! some simplifications need a different finish_tac!! ***)
  36.102 +fun indhyp_tac hyps =
  36.103 +    resolve_tac (TrueI::refl::hyps) ORELSE' 
  36.104 +    (cut_facts_tac hyps THEN'
  36.105 +       DEPTH_SOLVE_1 o (ares_tac [TrueI] ORELSE'
  36.106 +		        eresolve_tac [transD, mp, allE]));
  36.107 +val wf_super_ss = HOL_ss setsolver indhyp_tac;
  36.108 +
  36.109 +val prems = goalw WF.thy [is_recfun_def,cut_def]
  36.110 +    "[| wf(r);  trans(r);  is_recfun r a H f;  is_recfun r b H g |] ==> \
  36.111 +    \ <x,a>:r --> <x,b>:r --> f(x)=g(x)";
  36.112 +by (cut_facts_tac prems 1);
  36.113 +by (etac wf_induct 1);
  36.114 +by (REPEAT (rtac impI 1 ORELSE etac ssubst 1));
  36.115 +by (asm_simp_tac (wf_super_ss addcongs [if_cong]) 1);
  36.116 +qed "is_recfun_equal_lemma";
  36.117 +bind_thm ("is_recfun_equal", (is_recfun_equal_lemma RS mp RS mp));
  36.118 +
  36.119 +
  36.120 +val prems as [wfr,transr,recfa,recgb,_] = goalw WF.thy [cut_def]
  36.121 +    "[| wf(r);  trans(r); \
  36.122 +\       is_recfun r a H f;  is_recfun r b H g;  <b,a>:r |] ==> \
  36.123 +\    cut f r b = g";
  36.124 +val gundef = recgb RS is_recfun_undef
  36.125 +and fisg   = recgb RS (recfa RS (transr RS (wfr RS is_recfun_equal)));
  36.126 +by (cut_facts_tac prems 1);
  36.127 +by (rtac ext 1);
  36.128 +by (asm_simp_tac (wf_super_ss addsimps [gundef,fisg]
  36.129 +                              setloop (split_tac [expand_if])) 1);
  36.130 +qed "is_recfun_cut";
  36.131 +
  36.132 +(*** Main Existence Lemma -- Basic Properties of the_recfun ***)
  36.133 +
  36.134 +val prems = goalw WF.thy [the_recfun_def]
  36.135 +    "is_recfun r a H f ==> is_recfun r a H (the_recfun r a H)";
  36.136 +by (res_inst_tac [("P", "is_recfun r a H")] selectI 1);
  36.137 +by (resolve_tac prems 1);
  36.138 +qed "is_the_recfun";
  36.139 +
  36.140 +val prems = goal WF.thy
  36.141 +    "[| wf(r);  trans(r) |] ==> is_recfun r a H (the_recfun r a H)";
  36.142 +by (cut_facts_tac prems 1);
  36.143 +by (wf_ind_tac "a" prems 1);
  36.144 +by (res_inst_tac [("f", "cut (%y. wftrec r y H) r a1")] is_the_recfun 1);
  36.145 +by (rewrite_goals_tac [is_recfun_def, wftrec_def]);
  36.146 +by (rtac (cut_cut_eq RS ssubst) 1);
  36.147 +(*Applying the substitution: must keep the quantified assumption!!*)
  36.148 +by (EVERY1 [strip_tac, rtac H_cong1, rtac allE, atac,
  36.149 +            etac (mp RS ssubst), atac]);
  36.150 +by (fold_tac [is_recfun_def]);
  36.151 +by (asm_simp_tac (wf_super_ss addsimps[cut_apply,is_recfun_cut,cut_cut_eq]) 1);
  36.152 +qed "unfold_the_recfun";
  36.153 +
  36.154 +
  36.155 +(*Beware incompleteness of unification!*)
  36.156 +val prems = goal WF.thy
  36.157 +    "[| wf(r);  trans(r);  <c,a>:r;  <c,b>:r |] \
  36.158 +\    ==> the_recfun r a H c = the_recfun r b H c";
  36.159 +by (DEPTH_SOLVE (ares_tac (prems@[is_recfun_equal,unfold_the_recfun]) 1));
  36.160 +qed "the_recfun_equal";
  36.161 +
  36.162 +val prems = goal WF.thy
  36.163 +    "[| wf(r); trans(r); <b,a>:r |] \
  36.164 +\    ==> cut (the_recfun r a H) r b = the_recfun r b H";
  36.165 +by (REPEAT (ares_tac (prems@[is_recfun_cut,unfold_the_recfun]) 1));
  36.166 +qed "the_recfun_cut";
  36.167 +
  36.168 +(*** Unfolding wftrec ***)
  36.169 +
  36.170 +goalw WF.thy [wftrec_def]
  36.171 +    "!!r. [| wf(r);  trans(r) |] ==> \
  36.172 +\    wftrec r a H = H a (cut (%x.wftrec r x H) r a)";
  36.173 +by (EVERY1 [stac (rewrite_rule [is_recfun_def] unfold_the_recfun),
  36.174 +	    REPEAT o atac, rtac H_cong1]);
  36.175 +by (asm_simp_tac (HOL_ss addsimps [cut_cut_eq,the_recfun_cut]) 1);
  36.176 +qed "wftrec";
  36.177 +
  36.178 +(*Unused but perhaps interesting*)
  36.179 +val prems = goal WF.thy
  36.180 +    "[| wf(r);  trans(r);  !!f x. H x (cut f r x) = H x f |] ==> \
  36.181 +\		wftrec r a H = H a (%x.wftrec r x H)";
  36.182 +by (rtac (wftrec RS trans) 1);
  36.183 +by (REPEAT (resolve_tac prems 1));
  36.184 +qed "wftrec2";
  36.185 +
  36.186 +(** Removal of the premise trans(r) **)
  36.187 +
  36.188 +goalw WF.thy [wfrec_def]
  36.189 +    "!!r. wf(r) ==> wfrec r a H = H a (cut (%x.wfrec r x H) r a)";
  36.190 +by (etac (wf_trancl RS wftrec RS ssubst) 1);
  36.191 +by (rtac trans_trancl 1);
  36.192 +by (rtac (refl RS H_cong) 1);    (*expose the equality of cuts*)
  36.193 +by (simp_tac (HOL_ss addsimps [cut_cut_eq, cut_apply, r_into_trancl]) 1);
  36.194 +qed "wfrec";
  36.195 +
  36.196 +(*This form avoids giant explosions in proofs.  NOTE USE OF == *)
  36.197 +val rew::prems = goal WF.thy
  36.198 +    "[| !!x. f(x)==wfrec r x H;  wf(r) |] ==> f(a) = H a (cut (%x.f(x)) r a)";
  36.199 +by (rewtac rew);
  36.200 +by (REPEAT (resolve_tac (prems@[wfrec]) 1));
  36.201 +qed "def_wfrec";
    37.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    37.2 +++ b/src/HOL/WF.thy	Fri Mar 03 12:02:25 1995 +0100
    37.3 @@ -0,0 +1,30 @@
    37.4 +(*  Title: 	HOL/wf.ML
    37.5 +    ID:         $Id$
    37.6 +    Author: 	Tobias Nipkow
    37.7 +    Copyright   1992  University of Cambridge
    37.8 +
    37.9 +Well-founded Recursion
   37.10 +*)
   37.11 +
   37.12 +WF = Trancl +
   37.13 +consts
   37.14 +   wf		:: "('a * 'a)set => bool"
   37.15 +   cut		:: "['a => 'b, ('a * 'a)set, 'a] => 'a => 'b"
   37.16 +   wftrec,wfrec	:: "[('a * 'a)set, 'a, ['a,'a=>'b]=>'b] => 'b"
   37.17 +   is_recfun	:: "[('a * 'a)set, 'a, ['a,'a=>'b]=>'b, 'a=>'b] => bool"
   37.18 +   the_recfun	:: "[('a * 'a)set, 'a, ['a,'a=>'b]=>'b] => 'a=>'b"
   37.19 +
   37.20 +defs
   37.21 +  wf_def  "wf(r) == (!P. (!x. (!y. <y,x>:r --> P(y)) --> P(x)) --> (!x.P(x)))"
   37.22 +  
   37.23 +  cut_def 	 "cut f r x == (%y. if (<y,x>:r) (f y) (@z.True))"
   37.24 +
   37.25 +  is_recfun_def  "is_recfun r a H f == (f = cut (%x.(H x (cut f r x))) r a)"
   37.26 +
   37.27 +  the_recfun_def "the_recfun r a H == (@f.is_recfun r a H f)"
   37.28 +
   37.29 +  wftrec_def     "wftrec r a H == H a (the_recfun r a H)"
   37.30 +
   37.31 +  (*version not requiring transitivity*)
   37.32 +  wfrec_def	"wfrec r a H == wftrec (trancl r) a (%x f.(H x (cut f r x)))"
   37.33 +end
    38.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    38.2 +++ b/src/HOL/add_ind_def.ML	Fri Mar 03 12:02:25 1995 +0100
    38.3 @@ -0,0 +1,244 @@
    38.4 +(*  Title: 	HOL/add_ind_def.ML
    38.5 +    ID:         $Id$
    38.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    38.7 +    Copyright   1994  University of Cambridge
    38.8 +
    38.9 +Fixedpoint definition module -- for Inductive/Coinductive Definitions
   38.10 +
   38.11 +Features:
   38.12 +* least or greatest fixedpoints
   38.13 +* user-specified product and sum constructions
   38.14 +* mutually recursive definitions
   38.15 +* definitions involving arbitrary monotone operators
   38.16 +* automatically proves introduction and elimination rules
   38.17 +
   38.18 +The recursive sets must *already* be declared as constants in parent theory!
   38.19 +
   38.20 +  Introduction rules have the form
   38.21 +  [| ti:M(Sj), ..., P(x), ... |] ==> t: Sk |]
   38.22 +  where M is some monotone operator (usually the identity)
   38.23 +  P(x) is any (non-conjunctive) side condition on the free variables
   38.24 +  ti, t are any terms
   38.25 +  Sj, Sk are two of the sets being defined in mutual recursion
   38.26 +
   38.27 +Sums are used only for mutual recursion;
   38.28 +Products are used only to derive "streamlined" induction rules for relations
   38.29 +
   38.30 +Nestings of disjoint sum types:
   38.31 +   (a+(b+c)) for 3,  ((a+b)+(c+d)) for 4,  ((a+b)+(c+(d+e))) for 5,
   38.32 +   ((a+(b+c))+(d+(e+f))) for 6
   38.33 +*)
   38.34 +
   38.35 +signature FP =		(** Description of a fixed point operator **)
   38.36 +  sig
   38.37 +  val oper	: string * typ * term -> term	(*fixed point operator*)
   38.38 +  val Tarski	: thm			(*Tarski's fixed point theorem*)
   38.39 +  val induct	: thm			(*induction/coinduction rule*)
   38.40 +  end;
   38.41 +
   38.42 +
   38.43 +signature ADD_INDUCTIVE_DEF =
   38.44 +  sig 
   38.45 +  val add_fp_def_i : term list * term list -> theory -> theory
   38.46 +  end;
   38.47 +
   38.48 +
   38.49 +
   38.50 +(*Declares functions to add fixedpoint/constructor defs to a theory*)
   38.51 +functor Add_inductive_def_Fun (Fp: FP) : ADD_INDUCTIVE_DEF =
   38.52 +struct
   38.53 +open Logic Ind_Syntax;
   38.54 +
   38.55 +(*internal version*)
   38.56 +fun add_fp_def_i (rec_tms, intr_tms) thy = 
   38.57 +  let
   38.58 +    val sign = sign_of thy;
   38.59 +
   38.60 +    (*recT and rec_params should agree for all mutually recursive components*)
   38.61 +    val rec_hds = map head_of rec_tms;
   38.62 +
   38.63 +    val _ = assert_all is_Const rec_hds
   38.64 +	    (fn t => "Recursive set not previously declared as constant: " ^ 
   38.65 +	             Sign.string_of_term sign t);
   38.66 +
   38.67 +    (*Now we know they are all Consts, so get their names, type and params*)
   38.68 +    val rec_names = map (#1 o dest_Const) rec_hds
   38.69 +    and (Const(_,recT),rec_params) = strip_comb (hd rec_tms);
   38.70 +
   38.71 +    val _ = assert_all Syntax.is_identifier rec_names
   38.72 +       (fn a => "Name of recursive set not an identifier: " ^ a);
   38.73 +
   38.74 +    local (*Checking the introduction rules*)
   38.75 +      val intr_sets = map (#2 o rule_concl_msg sign) intr_tms;
   38.76 +      fun intr_ok set =
   38.77 +	  case head_of set of Const(a,_) => a mem rec_names | _ => false;
   38.78 +    in
   38.79 +      val _ =  assert_all intr_ok intr_sets
   38.80 +	 (fn t => "Conclusion of rule does not name a recursive set: " ^ 
   38.81 +		  Sign.string_of_term sign t);
   38.82 +    end;
   38.83 +
   38.84 +    val _ = assert_all is_Free rec_params
   38.85 +	(fn t => "Param in recursion term not a free variable: " ^
   38.86 +		 Sign.string_of_term sign t);
   38.87 +
   38.88 +    (*** Construct the lfp definition ***)
   38.89 +    val mk_variant = variant (foldr add_term_names (intr_tms,[]));
   38.90 +
   38.91 +    val z = mk_variant"z" and X = mk_variant"X" and w = mk_variant"w";
   38.92 +
   38.93 +    (*Probably INCORRECT for mutual recursion!*)
   38.94 +    val domTs = summands(dest_setT (body_type recT));
   38.95 +    val dom_sumT = fold_bal mk_sum domTs;
   38.96 +    val dom_set   = mk_setT dom_sumT;
   38.97 +
   38.98 +    val freez   = Free(z, dom_sumT)
   38.99 +    and freeX   = Free(X, dom_set);
  38.100 +    (*type of w may be any of the domTs*)
  38.101 +
  38.102 +    fun dest_tprop (Const("Trueprop",_) $ P) = P
  38.103 +      | dest_tprop Q = error ("Ill-formed premise of introduction rule: " ^ 
  38.104 +			      Sign.string_of_term sign Q);
  38.105 +
  38.106 +    (*Makes a disjunct from an introduction rule*)
  38.107 +    fun lfp_part intr = (*quantify over rule's free vars except parameters*)
  38.108 +      let val prems = map dest_tprop (strip_imp_prems intr)
  38.109 +	  val _ = seq (fn rec_hd => seq (chk_prem rec_hd) prems) rec_hds
  38.110 +	  val exfrees = term_frees intr \\ rec_params
  38.111 +	  val zeq = eq_const dom_sumT $ freez $ (#1 (rule_concl intr))
  38.112 +      in foldr mk_exists (exfrees, fold_bal (app conj) (zeq::prems)) end;
  38.113 +
  38.114 +    (*The Part(A,h) terms -- compose injections to make h*)
  38.115 +    fun mk_Part (Bound 0, _) = freeX	(*no mutual rec, no Part needed*)
  38.116 +      | mk_Part (h, domT)    = 
  38.117 +	  let val goodh = mend_sum_types (h, dom_sumT)
  38.118 +              and Part_const = 
  38.119 +		  Const("Part", [dom_set, domT-->dom_sumT]---> dom_set)
  38.120 +          in  Part_const $ freeX $ Abs(w,domT,goodh)  end;
  38.121 +
  38.122 +    (*Access to balanced disjoint sums via injections*)
  38.123 +    val parts = map mk_Part
  38.124 +	        (accesses_bal (ap Inl, ap Inr, Bound 0) (length domTs) ~~
  38.125 +		 domTs);
  38.126 +
  38.127 +    (*replace each set by the corresponding Part(A,h)*)
  38.128 +    val part_intrs = map (subst_free (rec_tms ~~ parts) o lfp_part) intr_tms;
  38.129 +
  38.130 +    val lfp_rhs = Fp.oper(X, dom_sumT, 
  38.131 +			  mk_Collect(z, dom_sumT, 
  38.132 +				     fold_bal (app disj) part_intrs))
  38.133 +
  38.134 +    val _ = seq (fn rec_hd => deny (rec_hd occs lfp_rhs) 
  38.135 +			       "Illegal occurrence of recursion operator")
  38.136 +	     rec_hds;
  38.137 +
  38.138 +    (*** Make the new theory ***)
  38.139 +
  38.140 +    (*A key definition:
  38.141 +      If no mutual recursion then it equals the one recursive set.
  38.142 +      If mutual recursion then it differs from all the recursive sets. *)
  38.143 +    val big_rec_name = space_implode "_" rec_names;
  38.144 +
  38.145 +    (*Big_rec... is the union of the mutually recursive sets*)
  38.146 +    val big_rec_tm = list_comb(Const(big_rec_name,recT), rec_params);
  38.147 +
  38.148 +    (*The individual sets must already be declared*)
  38.149 +    val axpairs = map mk_defpair 
  38.150 +	  ((big_rec_tm, lfp_rhs) ::
  38.151 +	   (case parts of 
  38.152 +	       [_] => [] 			(*no mutual recursion*)
  38.153 +	     | _ => rec_tms ~~		(*define the sets as Parts*)
  38.154 +		    map (subst_atomic [(freeX, big_rec_tm)]) parts));
  38.155 +
  38.156 +    val _ = seq (writeln o Sign.string_of_term sign o #2) axpairs
  38.157 +  
  38.158 +  in  thy |> add_defs_i axpairs  end
  38.159 +
  38.160 +
  38.161 +(****************************************************************OMITTED
  38.162 +
  38.163 +(*Expects the recursive sets to have been defined already.
  38.164 +  con_ty_lists specifies the constructors in the form (name,prems,mixfix) *)
  38.165 +fun add_constructs_def (rec_names, con_ty_lists) thy = 
  38.166 +* let
  38.167 +*   val _ = writeln"  Defining the constructor functions...";
  38.168 +*   val case_name = "f";		(*name for case variables*)
  38.169 +
  38.170 +*   (** Define the constructors **)
  38.171 +
  38.172 +*   (*The empty tuple is 0*)
  38.173 +*   fun mk_tuple [] = Const("0",iT)
  38.174 +*     | mk_tuple args = foldr1 mk_Pair args;
  38.175 +
  38.176 +*   fun mk_inject n k u = access_bal(ap Inl, ap Inr, u) n k;
  38.177 +
  38.178 +*   val npart = length rec_names;	(*total # of mutually recursive parts*)
  38.179 +
  38.180 +*   (*Make constructor definition; kpart is # of this mutually recursive part*)
  38.181 +*   fun mk_con_defs (kpart, con_ty_list) = 
  38.182 +*     let val ncon = length con_ty_list	   (*number of constructors*)
  38.183 +	  fun mk_def (((id,T,syn), name, args, prems), kcon) =
  38.184 +		(*kcon is index of constructor*)
  38.185 +	      mk_defpair (list_comb (Const(name,T), args),
  38.186 +			  mk_inject npart kpart
  38.187 +			  (mk_inject ncon kcon (mk_tuple args)))
  38.188 +*     in  map mk_def (con_ty_list ~~ (1 upto ncon))  end;
  38.189 +
  38.190 +*   (** Define the case operator **)
  38.191 +
  38.192 +*   (*Combine split terms using case; yields the case operator for one part*)
  38.193 +*   fun call_case case_list = 
  38.194 +*     let fun call_f (free,args) = 
  38.195 +	      ap_split T free (map (#2 o dest_Free) args)
  38.196 +*     in  fold_bal (app sum_case) (map call_f case_list)  end;
  38.197 +
  38.198 +*   (** Generating function variables for the case definition
  38.199 +	Non-identifiers (e.g. infixes) get a name of the form f_op_nnn. **)
  38.200 +
  38.201 +*   (*Treatment of a single constructor*)
  38.202 +*   fun add_case (((id,T,syn), name, args, prems), (opno,cases)) =
  38.203 +	if Syntax.is_identifier id
  38.204 +	then (opno,   
  38.205 +	      (Free(case_name ^ "_" ^ id, T), args) :: cases)
  38.206 +	else (opno+1, 
  38.207 +	      (Free(case_name ^ "_op_" ^ string_of_int opno, T), args) :: 
  38.208 +	      cases)
  38.209 +
  38.210 +*   (*Treatment of a list of constructors, for one part*)
  38.211 +*   fun add_case_list (con_ty_list, (opno,case_lists)) =
  38.212 +	let val (opno',case_list) = foldr add_case (con_ty_list, (opno,[]))
  38.213 +	in (opno', case_list :: case_lists) end;
  38.214 +
  38.215 +*   (*Treatment of all parts*)
  38.216 +*   val (_, case_lists) = foldr add_case_list (con_ty_lists, (1,[]));
  38.217 +
  38.218 +*   val big_case_typ = flat (map (map (#2 o #1)) con_ty_lists) ---> (iT-->iT);
  38.219 +
  38.220 +*   val big_rec_name = space_implode "_" rec_names;
  38.221 +
  38.222 +*   val big_case_name = big_rec_name ^ "_case";
  38.223 +
  38.224 +*   (*The list of all the function variables*)
  38.225 +*   val big_case_args = flat (map (map #1) case_lists);
  38.226 +
  38.227 +*   val big_case_tm = 
  38.228 +	list_comb (Const(big_case_name, big_case_typ), big_case_args); 
  38.229 +
  38.230 +*   val big_case_def = mk_defpair  
  38.231 +	(big_case_tm, fold_bal (app sum_case) (map call_case case_lists)); 
  38.232 +
  38.233 +*   (** Build the new theory **)
  38.234 +
  38.235 +*   val const_decs =
  38.236 +	(big_case_name, big_case_typ, NoSyn) :: map #1 (flat con_ty_lists);
  38.237 +
  38.238 +*   val axpairs =
  38.239 +	big_case_def :: flat (map mk_con_defs ((1 upto npart) ~~ con_ty_lists))
  38.240 +
  38.241 +*   in  thy |> add_consts_i const_decs |> add_defs_i axpairs  end;
  38.242 +****************************************************************)
  38.243 +end;
  38.244 +
  38.245 +
  38.246 +
  38.247 +
    39.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    39.2 +++ b/src/HOL/datatype.ML	Fri Mar 03 12:02:25 1995 +0100
    39.3 @@ -0,0 +1,488 @@
    39.4 +(* Title:       HOL/datatype.ML
    39.5 +   ID:          $Id$
    39.6 +   Author:      Max Breitling, Carsten Clasohm, Tobias Nipkow, Norbert Voelker
    39.7 +   Copyright 1995 TU Muenchen
    39.8 +*)
    39.9 +
   39.10 +
   39.11 +(*used for constructor parameters*)
   39.12 +datatype dt_type = dtVar of string |
   39.13 +  dtTyp of dt_type list * string |
   39.14 +  dtRek of dt_type list * string;
   39.15 +
   39.16 +structure Datatype =
   39.17 +struct
   39.18 +local 
   39.19 +
   39.20 +val mysort = sort;
   39.21 +open ThyParse HOLogic;
   39.22 +exception Impossible;
   39.23 +exception RecError of string;
   39.24 +
   39.25 +val is_dtRek = (fn dtRek _ => true  |  _  => false);
   39.26 +fun opt_parens s = if s = "" then "" else enclose "(" ")" s; 
   39.27 +
   39.28 +(* ----------------------------------------------------------------------- *)
   39.29 +(* Derivation of the primrec combinator application from the equations     *)
   39.30 +
   39.31 +(* substitute fname(ls,xk,rs) by yk(ls,rs) in t for (xk,yk) in pairs  *) 
   39.32 +
   39.33 +fun subst_apps (_,_) [] t = t
   39.34 +  | subst_apps (fname,rpos) pairs t =
   39.35 +    let 
   39.36 +    fun subst (Abs(a,T,t)) = Abs(a,T,subst t)
   39.37 +      | subst (funct $ body) = 
   39.38 +	let val (f,b) = strip_comb (funct$body)
   39.39 +	in 
   39.40 +	  if is_Const f andalso fst(dest_Const f) = fname 
   39.41 +	    then 
   39.42 +	      let val (ls,rest) = (take(rpos,b), drop(rpos,b));
   39.43 +		val (xk,rs) = (hd rest,tl rest)
   39.44 +		  handle LIST _ => raise RecError "not enough arguments \
   39.45 +		   \ in recursive application on rhs"
   39.46 +              in 
   39.47 +		(case assoc (pairs,xk) of 
   39.48 +		   None => raise RecError 
   39.49 +		     ("illegal occurence of " ^ fname ^ " on rhs")
   39.50 +		 | Some(U) => list_comb(U,map subst (ls @ rs)))
   39.51 +	      end
   39.52 +	  else list_comb(f, map subst b)
   39.53 +	end
   39.54 +      | subst(t) = t
   39.55 +    in subst t end;
   39.56 +  
   39.57 +(* abstract rhs *)
   39.58 +
   39.59 +fun abst_rec (fname,rpos,tc,ls,cargs,rs,rhs) =       
   39.60 +  let val rargs = (map fst o 
   39.61 +		   (filter (fn (a,T) => is_dtRek T))) (cargs ~~ tc);
   39.62 +      val subs = map (fn (s,T) => (s,dummyT))
   39.63 +	           (rev(rename_wrt_term rhs rargs));
   39.64 +      val subst_rhs = subst_apps (fname,rpos)
   39.65 +	                (map Free rargs ~~ map Free subs) rhs;
   39.66 +  in 
   39.67 +      list_abs_free (cargs @ subs @ ls @ rs, subst_rhs) 
   39.68 +  end;
   39.69 +
   39.70 +(* parsing the prim rec equations *)
   39.71 +
   39.72 +fun dest_eq ( Const("Trueprop",_) $ (Const ("op =",_) $ lhs $ rhs))
   39.73 +                 = (lhs, rhs)
   39.74 +   | dest_eq _ = raise RecError "not a proper equation"; 
   39.75 +
   39.76 +fun dest_rec eq = 
   39.77 +  let val (lhs,rhs) = dest_eq eq; 
   39.78 +    val (name,args) = strip_comb lhs; 
   39.79 +    val (ls',rest)  = take_prefix is_Free args; 
   39.80 +    val (middle,rs') = take_suffix is_Free rest;
   39.81 +    val rpos = length ls';
   39.82 +    val (c,cargs') = strip_comb (hd middle)
   39.83 +      handle LIST "hd" => raise RecError "constructor missing";
   39.84 +    val (ls,cargs,rs) = (map dest_Free ls', map dest_Free cargs'
   39.85 +			 , map dest_Free rs')
   39.86 +      handle TERM ("dest_Free",_) => 
   39.87 +	  raise RecError "constructor has illegal argument in pattern";
   39.88 +  in 
   39.89 +    if length middle > 1 then 
   39.90 +      raise RecError "more than one non-variable in pattern"
   39.91 +    else if not(null(findrep (map fst (ls @ rs @ cargs)))) then 
   39.92 +      raise RecError "repeated variable name in pattern" 
   39.93 +	 else (fst(dest_Const name) handle TERM _ => 
   39.94 +	       raise RecError "function is not declared as constant in theory"
   39.95 +		 ,rpos,ls,fst( dest_Const c),cargs,rs,rhs)
   39.96 +  end; 
   39.97 +
   39.98 +(* check function specified for all constructors and sort function terms *)
   39.99 +
  39.100 +fun check_and_sort (n,its) = 
  39.101 +  if length its = n 
  39.102 +    then map snd (mysort (fn ((i : int,_),(j,_)) => i<j) its)
  39.103 +  else raise error "Primrec definition error:\n\
  39.104 +   \Please give an equation for every constructor";
  39.105 +
  39.106 +(* translate rec equations into function arguments suitable for rec comb *)
  39.107 +(* theory parameter needed for printing error messages                   *) 
  39.108 +
  39.109 +fun trans_recs _ _ [] = error("No primrec equations.")
  39.110 +  | trans_recs thy cs' (eq1::eqs) = 
  39.111 +    let val (name1,rpos1,ls1,_,_,_,_) = dest_rec eq1
  39.112 +      handle RecError s =>
  39.113 +	error("Primrec definition error: " ^ s ^ ":\n" 
  39.114 +	      ^ "   " ^ Sign.string_of_term (sign_of thy) eq1);
  39.115 +      val tcs = map (fn (_,c,T,_,_) => (c,T)) cs';  
  39.116 +      val cs = map fst tcs;
  39.117 +      fun trans_recs' _ [] = []
  39.118 +        | trans_recs' cis (eq::eqs) = 
  39.119 +	  let val (name,rpos,ls,c,cargs,rs,rhs) = dest_rec eq; 
  39.120 +	    val tc = assoc(tcs,c);
  39.121 +	    val i = (1 + find (c,cs))  handle LIST "find" => 0; 
  39.122 +	  in
  39.123 +	  if name <> name1 then 
  39.124 +	    raise RecError "function names inconsistent"
  39.125 +	  else if rpos <> rpos1 then 
  39.126 +	    raise RecError "position of rec. argument inconsistent"
  39.127 +	  else if i = 0 then 
  39.128 +	    raise RecError "illegal argument in pattern" 
  39.129 +	  else if i mem cis then
  39.130 +	    raise RecError "constructor already occured as pattern "
  39.131 +	       else (i,abst_rec (name,rpos,the tc,ls,cargs,rs,rhs))
  39.132 +		     :: trans_recs' (i::cis) eqs 
  39.133 +	  end
  39.134 +	  handle RecError s =>
  39.135 +	        error("Primrec definition error\n" ^ s ^ "\n" 
  39.136 +		      ^ "   " ^ Sign.string_of_term (sign_of thy) eq);
  39.137 +    in (  name1, ls1
  39.138 +	, check_and_sort (length cs, trans_recs' [] (eq1::eqs)))
  39.139 +    end ;
  39.140 +
  39.141 +in
  39.142 +  fun add_datatype (typevars, tname, cons_list') thy = 
  39.143 +    let
  39.144 +      fun typid(dtRek(_,id)) = id
  39.145 +        | typid(dtVar s) = implode (tl (explode s))
  39.146 +        | typid(dtTyp(_,id)) = id;
  39.147 +
  39.148 +      fun index_vnames(vn::vns,tab) =
  39.149 +            (case assoc(tab,vn) of
  39.150 +               None => if vn mem vns
  39.151 +                       then (vn^"1") :: index_vnames(vns,(vn,2)::tab)
  39.152 +                       else vn :: index_vnames(vns,tab)
  39.153 +             | Some(i) => (vn^(string_of_int i)) ::
  39.154 +                          index_vnames(vns,(vn,i+1)::tab))
  39.155 +        | index_vnames([],tab) = [];
  39.156 +
  39.157 +      fun mk_var_names types = index_vnames(map typid types,[]);
  39.158 +
  39.159 +      (*search for free type variables and convert recursive *)
  39.160 +      fun analyse_types (cons, types, syn) =
  39.161 +	let fun analyse(t as dtVar v) =
  39.162 +                  if t mem typevars then t
  39.163 +                  else error ("Free type variable " ^ v ^ " on rhs.")
  39.164 +	      | analyse(dtTyp(typl,s)) =
  39.165 +		  if tname <> s then dtTyp(analyses typl, s)
  39.166 +                  else if typevars = typl then dtRek(typl, s)
  39.167 +                       else error (s ^ " used in different ways")
  39.168 +	      | analyse(dtRek _) = raise Impossible
  39.169 +	    and analyses ts = map analyse ts;
  39.170 +	in (cons, Syntax.const_name cons syn, analyses types,
  39.171 +            mk_var_names types, syn)
  39.172 +        end;
  39.173 +
  39.174 +     (*test if all elements are recursive, i.e. if the type is empty*)
  39.175 +      
  39.176 +      fun non_empty (cs : ('a * 'b * dt_type list * 'c *'d) list) = 
  39.177 +	not(forall (exists is_dtRek o #3) cs) orelse
  39.178 +	error("Empty datatype not allowed!");
  39.179 +
  39.180 +      val cons_list = map analyse_types cons_list';
  39.181 +      val dummy = non_empty cons_list;
  39.182 +      val num_of_cons = length cons_list;
  39.183 +
  39.184 +     (* Auxiliary functions to construct argument and equation lists *)
  39.185 +
  39.186 +     (*generate 'var_n, ..., var_m'*)
  39.187 +      fun Args(var, delim, n, m) = 
  39.188 +	space_implode delim (map (fn n => var^string_of_int(n)) (n upto m));
  39.189 +
  39.190 +      fun C_exp name vns = name ^ opt_parens(space_implode ") (" vns);
  39.191 +
  39.192 +     (*Arg_eqs([x1,...,xn],[y1,...,yn]) = "x1 = y1 & ... & xn = yn" *)
  39.193 +      fun arg_eqs vns vns' =
  39.194 +        let fun mkeq(x,x') = x ^ "=" ^ x'
  39.195 +        in space_implode " & " (map mkeq (vns~~vns')) end;
  39.196 +
  39.197 +     (*Pretty printers for type lists;
  39.198 +       pp_typlist1: parentheses, pp_typlist2: brackets*)
  39.199 +      fun pp_typ (dtVar s) = s
  39.200 +        | pp_typ (dtTyp (typvars, id)) =
  39.201 +	  if null typvars then id else (pp_typlist1 typvars) ^ id
  39.202 +        | pp_typ (dtRek (typvars, id)) = (pp_typlist1 typvars) ^ id
  39.203 +      and
  39.204 +	pp_typlist' ts = commas (map pp_typ ts)
  39.205 +      and
  39.206 +	pp_typlist1 ts = if null ts then "" else parens (pp_typlist' ts);
  39.207 +
  39.208 +      fun pp_typlist2 ts = if null ts then "" else brackets (pp_typlist' ts);
  39.209 +
  39.210 +     (* Generate syntax translation for case rules *)
  39.211 +      fun calc_xrules c_nr y_nr ((_, name, _, vns, _) :: cs) = 
  39.212 +	let val arity = length vns;
  39.213 +	  val body  = "z" ^ string_of_int(c_nr);
  39.214 +	  val args1 = if arity=0 then ""
  39.215 +		      else parens (Args ("y", ") (", y_nr, y_nr+arity-1));
  39.216 +	  val args2 = if arity=0 then ""
  39.217 +		      else "% " ^ Args ("y", " ", y_nr, y_nr+arity-1) 
  39.218 +			^ ". ";
  39.219 +	  val (rest1,rest2) = 
  39.220 +	    if null cs then ("","")
  39.221 +	    else let val (h1, h2) = calc_xrules (c_nr+1) (y_nr+arity) cs
  39.222 +	    in (" | " ^ h1, " " ^ h2) end;
  39.223 +	in (name ^ args1 ^ " => " ^ body ^ rest1,
  39.224 +            "(" ^ args2 ^ body ^ rest2 ^ ")")
  39.225 +        end
  39.226 +        | calc_xrules _ _ [] = raise Impossible;
  39.227 +      
  39.228 +      val xrules =
  39.229 +	let val (first_part, scnd_part) = calc_xrules 1 1 cons_list
  39.230 +	in  [("logic", "case x of " ^ first_part) <->
  39.231 +	     ("logic", tname ^ "_case (" ^ scnd_part ^ ") x" )]
  39.232 +	end;
  39.233 +
  39.234 +     (*type declarations for constructors*)
  39.235 +      fun const_type (id, _, typlist, _, syn) =
  39.236 +	(id,  
  39.237 +	 (if null typlist then "" else pp_typlist2 typlist ^ " => ") ^
  39.238 +	    pp_typlist1 typevars ^ tname, syn);
  39.239 +
  39.240 +
  39.241 +      fun assumpt (dtRek _ :: ts, v :: vs ,found) =
  39.242 +	let val h = if found then ";P(" ^ v ^ ")" else "[| P(" ^ v ^ ")"
  39.243 +	in h ^ (assumpt (ts, vs, true)) end
  39.244 +        | assumpt (t :: ts, v :: vs, found) = assumpt (ts, vs, found)
  39.245 +      | assumpt ([], [], found) = if found then "|] ==>" else ""
  39.246 +        | assumpt _ = raise Impossible;
  39.247 +
  39.248 +      fun t_inducting ((_, name, types, vns, _) :: cs) =
  39.249 +	let
  39.250 +	  val h = if null types then " P(" ^ name ^ ")"
  39.251 +		  else " !!" ^ (space_implode " " vns) ^ "." ^
  39.252 +		    (assumpt (types, vns, false)) ^
  39.253 +                    "P(" ^ C_exp name vns ^ ")";
  39.254 +	  val rest = t_inducting cs;
  39.255 +	in if rest = "" then h else h ^ "; " ^ rest end
  39.256 +        | t_inducting [] = "";
  39.257 +
  39.258 +      fun t_induct cl typ_name =
  39.259 +        "[|" ^ t_inducting cl ^ "|] ==> P(" ^ typ_name ^ ")";
  39.260 +
  39.261 +      fun gen_typlist typevar f ((_, _, ts, _, _) :: cs) =
  39.262 +	let val h = if (length ts) > 0
  39.263 +		      then pp_typlist2(f ts) ^ "=>"
  39.264 +		    else ""
  39.265 +	in h ^ typevar ^  "," ^ (gen_typlist typevar f cs) end
  39.266 +        | gen_typlist _ _ [] = "";
  39.267 +
  39.268 +
  39.269 +(* -------------------------------------------------------------------- *)
  39.270 +(* The case constant and rules 	        				*)
  39.271 + 		
  39.272 +      val t_case = tname ^ "_case";
  39.273 +
  39.274 +      fun case_rule n (id, name, _, vns, _) =
  39.275 +	let val args =  opt_parens(space_implode ") (" vns)
  39.276 +	in (t_case ^ "_" ^ id,
  39.277 +	    t_case ^ "(" ^ Args("f", ") (", 1, num_of_cons)
  39.278 +	    ^ ") (" ^ name ^ args ^ ") = f"^string_of_int(n) ^ args)
  39.279 +	end
  39.280 +
  39.281 +      fun case_rules n (c :: cs) = case_rule n c :: case_rules(n+1) cs
  39.282 +        | case_rules _ [] = [];
  39.283 +
  39.284 +      val datatype_arity = length typevars;
  39.285 +
  39.286 +      val types = [(tname, datatype_arity, NoSyn)];
  39.287 +
  39.288 +      val arities = 
  39.289 +        let val term_list = replicate datatype_arity termS;
  39.290 +        in [(tname, term_list, termS)] 
  39.291 +	end;
  39.292 +
  39.293 +      val datatype_name = pp_typlist1 typevars ^ tname;
  39.294 +
  39.295 +      val new_tvar_name = variant (map (fn dtVar s => s) typevars) "'z";
  39.296 +
  39.297 +      val case_const =
  39.298 +	(t_case,
  39.299 +	 "[" ^ gen_typlist new_tvar_name I cons_list 
  39.300 +	 ^  pp_typlist1 typevars ^ tname ^ "] =>" ^ new_tvar_name,
  39.301 +	 NoSyn);
  39.302 +
  39.303 +      val rules_case = case_rules 1 cons_list;
  39.304 +
  39.305 +(* -------------------------------------------------------------------- *)
  39.306 +(* The prim-rec combinator						*) 
  39.307 +
  39.308 +      val t_rec = tname ^ "_rec"
  39.309 +
  39.310 +(* adding type variables for dtRek types to end of list of dt_types      *)   
  39.311 +
  39.312 +      fun add_reks ts = 
  39.313 +	ts @ map (fn _ => dtVar new_tvar_name) (filter is_dtRek ts); 
  39.314 +
  39.315 +(* positions of the dtRek types in a list of dt_types, starting from 1  *)
  39.316 +      fun rek_vars ts vns = map snd (filter (is_dtRek o fst) (ts ~~ vns))
  39.317 +
  39.318 +      fun rec_rule n (id,name,ts,vns,_) = 
  39.319 +	let val args = space_implode ") (" vns
  39.320 +	  val fargs = Args("f",") (",1,num_of_cons)
  39.321 +	  fun rarg vn = ") (" ^ t_rec ^ parens(fargs ^ ") (" ^ vn)
  39.322 +	  val rargs = implode (map rarg (rek_vars ts vns))
  39.323 +	in
  39.324 +	  ( t_rec ^ "_" ^ id
  39.325 +	   , t_rec ^ parens(fargs ^  ") (" ^ name ^ (opt_parens args)) ^ " = f"
  39.326 +	   ^ string_of_int(n) ^ opt_parens (args ^ rargs)) 
  39.327 +	end
  39.328 +
  39.329 +      fun rec_rules n (c::cs) = rec_rule n c :: rec_rules (n+1) cs 
  39.330 +	| rec_rules _ [] = [];
  39.331 +
  39.332 +      val rec_const =
  39.333 +	(t_rec,
  39.334 +	 "[" ^ (gen_typlist new_tvar_name add_reks cons_list) 
  39.335 +	 ^ (pp_typlist1 typevars) ^ tname ^ "] =>" ^ new_tvar_name,
  39.336 +	 NoSyn);
  39.337 +
  39.338 +      val rules_rec = rec_rules 1 cons_list
  39.339 +
  39.340 +(* -------------------------------------------------------------------- *)
  39.341 +      val consts = 
  39.342 +	map const_type cons_list
  39.343 +	@ (if num_of_cons < dtK then []
  39.344 +	   else [(tname ^ "_ord", datatype_name ^ "=>nat", NoSyn)])
  39.345 +	@ [case_const,rec_const];
  39.346 +
  39.347 +
  39.348 +      fun Ci_ing ((id, name, _, vns, _) :: cs) =
  39.349 +	   if null vns then Ci_ing cs
  39.350 +	   else let val vns' = variantlist(vns,vns)
  39.351 +                in ("inject_" ^ id,
  39.352 +		    "(" ^ (C_exp name vns) ^ "=" ^ (C_exp name vns')
  39.353 +		    ^ ") = (" ^ (arg_eqs vns vns') ^ ")") :: (Ci_ing cs)
  39.354 +                end
  39.355 +	| Ci_ing [] = [];
  39.356 +
  39.357 +      fun Ci_negOne (id1,name1,_,vns1,_) (id2,name2,_,vns2,_) =
  39.358 +            let val vns2' = variantlist(vns2,vns1)
  39.359 +                val ax = C_exp name1 vns1 ^ "~=" ^ C_exp name2 vns2'
  39.360 +	in (id1 ^ "_not_" ^ id2, ax) end;
  39.361 +
  39.362 +      fun Ci_neg1 [] = []
  39.363 +	| Ci_neg1 (c1::cs) = (map (Ci_negOne c1) cs) @ Ci_neg1 cs;
  39.364 +
  39.365 +      fun suc_expr n = 
  39.366 +	if n=0 then "0" else "Suc(" ^ suc_expr(n-1) ^ ")";
  39.367 +
  39.368 +      fun Ci_neg2() =
  39.369 +	let val ord_t = tname ^ "_ord";
  39.370 +	  val cis = cons_list ~~ (0 upto (num_of_cons - 1))
  39.371 +	  fun Ci_neg2equals ((id, name, _, vns, _), n) =
  39.372 +	    let val ax = ord_t ^ "(" ^ (C_exp name vns) ^ ") = " ^ (suc_expr n)
  39.373 +	    in (ord_t ^ "_" ^ id, ax) end
  39.374 +	in (ord_t ^ "_distinct", ord_t^"(x) ~= "^ord_t^"(y) ==> x ~= y") ::
  39.375 +	  (map Ci_neg2equals cis)
  39.376 +	end;
  39.377 +
  39.378 +      val rules_distinct = if num_of_cons < dtK then Ci_neg1 cons_list
  39.379 +			   else Ci_neg2();
  39.380 +
  39.381 +      val rules_inject = Ci_ing cons_list;
  39.382 +
  39.383 +      val rule_induct = (tname ^ "_induct", t_induct cons_list tname);
  39.384 +
  39.385 +      val rules = rule_induct ::
  39.386 +	(rules_inject @ rules_distinct @ rules_case @ rules_rec);
  39.387 +
  39.388 +      fun add_primrec eqns thy =
  39.389 +	let val rec_comb = Const(t_rec,dummyT)
  39.390 +	  val teqns = map (fn neq => snd(read_axm (sign_of thy) neq)) eqns
  39.391 +	  val (fname,ls,fns) = trans_recs thy cons_list teqns
  39.392 +	  val rhs = 
  39.393 +	    list_abs_free
  39.394 +	    (ls @ [(tname,dummyT)]
  39.395 +	     ,list_comb(rec_comb
  39.396 +			, fns @ map Bound (0 ::(length ls downto 1))));
  39.397 +          val sg = sign_of thy;
  39.398 +          val defpair =  mk_defpair (Const(fname,dummyT),rhs)
  39.399 +	  val defpairT as (_, _ $ Const(_,T) $ _ ) = inferT_axm sg defpair;
  39.400 +	  val varT = Type.varifyT T;
  39.401 +          val ftyp = the (Sign.const_type sg fname);
  39.402 +	in
  39.403 +	  if Type.typ_instance (#tsig(Sign.rep_sg sg), ftyp, varT)
  39.404 +	  then add_defs_i [defpairT] thy
  39.405 +	  else error("Primrec definition error: \ntype of " ^ fname 
  39.406 +		     ^ " is not instance of type deduced from equations")
  39.407 +	end;
  39.408 +
  39.409 +    in 
  39.410 +      (thy
  39.411 +      |> add_types types
  39.412 +      |> add_arities arities
  39.413 +      |> add_consts consts
  39.414 +      |> add_trrules xrules
  39.415 +      |> add_axioms rules,add_primrec)
  39.416 +    end
  39.417 +end
  39.418 +end
  39.419 +
  39.420 +(*
  39.421 +Informal description of functions used in datatype.ML for the Isabelle/HOL
  39.422 +implementation of prim. rec. function definitions. (N. Voelker, Feb. 1995) 
  39.423 +
  39.424 +* subst_apps (fname,rpos) pairs t:
  39.425 +   substitute the term 
  39.426 +       fname(ls,xk,rs) 
  39.427 +   by 
  39.428 +      yk(ls,rs) 
  39.429 +   in t for (xk,yk) in pairs, where rpos = length ls. 
  39.430 +   Applied with : 
  39.431 +     fname = function name 
  39.432 +     rpos = position of recursive argument 
  39.433 +     pairs = list of pairs (xk,yk), where 
  39.434 +          xk are the rec. arguments of the constructor in the pattern,
  39.435 +          yk is a variable with name derived from xk 
  39.436 +     t = rhs of equation 
  39.437 +
  39.438 +* abst_rec (fname,rpos,tc,ls,cargs,rs,rhs)
  39.439 +  - filter recursive arguments from constructor arguments cargs,
  39.440 +  - perform substitutions on rhs, 
  39.441 +  - derive list subs of new variable names yk for use in subst_apps, 
  39.442 +  - abstract rhs with respect to cargs, subs, ls and rs. 
  39.443 +
  39.444 +* dest_eq t 
  39.445 +  destruct a term denoting an equation into lhs and rhs. 
  39.446 +
  39.447 +* dest_req eq 
  39.448 +  destruct an equation of the form 
  39.449 +      name (vl1..vlrpos, Ci(vi1..vin), vr1..vrn) = rhs
  39.450 +  into 
  39.451 +  - function name  (name) 
  39.452 +  - position of the first non-variable parameter  (rpos)
  39.453 +  - the list of first rpos parameters (ls = [vl1..vlrpos]) 
  39.454 +  - the constructor (fst( dest_Const c) = Ci)
  39.455 +  - the arguments of the constructor (cargs = [vi1..vin])
  39.456 +  - the rest of the variables in the pattern (rs = [vr1..vrn])
  39.457 +  - the right hand side of the equation (rhs).  
  39.458 + 
  39.459 +* check_and_sort (n,its)
  39.460 +  check that  n = length its holds, and sort elements of its by 
  39.461 +  first component. 
  39.462 +
  39.463 +* trans_recs thy cs' (eq1::eqs)
  39.464 +  destruct eq1 into name1, rpos1, ls1, etc.. 
  39.465 +  get constructor list with and without type (tcs resp. cs) from cs',  
  39.466 +  for every equation:  
  39.467 +    destruct it into (name,rpos,ls,c,cargs,rs,rhs)
  39.468 +    get typed constructor tc from c and tcs 
  39.469 +    determine the index i of the constructor 
  39.470 +    check function name and position of rec. argument by comparison
  39.471 +    with first equation 
  39.472 +    check for repeated variable names in pattern
  39.473 +    derive function term f_i which is used as argument of the rec. combinator
  39.474 +    sort the terms f_i according to i and return them together
  39.475 +      with the function name and the parameter of the definition (ls). 
  39.476 +
  39.477 +* Application:
  39.478 +
  39.479 +  The rec. combinator is applied to the function terms resulting from
  39.480 +  trans_rec. This results in a function which takes the recursive arg. 
  39.481 +  as first parameter and then the arguments corresponding to ls. The
  39.482 +  order of parameters is corrected by setting the rhs equal to 
  39.483 +
  39.484 +  list_abs_free
  39.485 +	    (ls @ [(tname,dummyT)]
  39.486 +	     ,list_comb(rec_comb
  39.487 +			, fns @ map Bound (0 ::(length ls downto 1))));
  39.488 +
  39.489 +  Note the de-Bruijn indices counting the number of lambdas between the
  39.490 +  variable and its binding. 
  39.491 +*)
    40.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    40.2 +++ b/src/HOL/equalities.ML	Fri Mar 03 12:02:25 1995 +0100
    40.3 @@ -0,0 +1,333 @@
    40.4 +(*  Title: 	HOL/equalities
    40.5 +    ID:         $Id$
    40.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    40.7 +    Copyright   1994  University of Cambridge
    40.8 +
    40.9 +Equalities involving union, intersection, inclusion, etc.
   40.10 +*)
   40.11 +
   40.12 +writeln"File HOL/equalities";
   40.13 +
   40.14 +val eq_cs = set_cs addSIs [equalityI];
   40.15 +
   40.16 +(** The membership relation, : **)
   40.17 +
   40.18 +goal Set.thy "x ~: {}";
   40.19 +by(fast_tac set_cs 1);
   40.20 +qed "in_empty";
   40.21 +
   40.22 +goal Set.thy "x : insert y A = (x=y | x:A)";
   40.23 +by(fast_tac set_cs 1);
   40.24 +qed "in_insert";
   40.25 +
   40.26 +(** insert **)
   40.27 +
   40.28 +goal Set.thy "!!a. a:A ==> insert a A = A";
   40.29 +by (fast_tac eq_cs 1);
   40.30 +qed "insert_absorb";
   40.31 +
   40.32 +goal Set.thy "(insert x A <= B) = (x:B & A <= B)";
   40.33 +by (fast_tac set_cs 1);
   40.34 +qed "insert_subset";
   40.35 +
   40.36 +(** Image **)
   40.37 +
   40.38 +goal Set.thy "f``{} = {}";
   40.39 +by (fast_tac eq_cs 1);
   40.40 +qed "image_empty";
   40.41 +
   40.42 +goal Set.thy "f``insert a B = insert (f a) (f``B)";
   40.43 +by (fast_tac eq_cs 1);
   40.44 +qed "image_insert";
   40.45 +
   40.46 +(** Binary Intersection **)
   40.47 +
   40.48 +goal Set.thy "A Int A = A";
   40.49 +by (fast_tac eq_cs 1);
   40.50 +qed "Int_absorb";
   40.51 +
   40.52 +goal Set.thy "A Int B  =  B Int A";
   40.53 +by (fast_tac eq_cs 1);
   40.54 +qed "Int_commute";
   40.55 +
   40.56 +goal Set.thy "(A Int B) Int C  =  A Int (B Int C)";
   40.57 +by (fast_tac eq_cs 1);
   40.58 +qed "Int_assoc";
   40.59 +
   40.60 +goal Set.thy "{} Int B = {}";
   40.61 +by (fast_tac eq_cs 1);
   40.62 +qed "Int_empty_left";
   40.63 +
   40.64 +goal Set.thy "A Int {} = {}";
   40.65 +by (fast_tac eq_cs 1);
   40.66 +qed "Int_empty_right";
   40.67 +
   40.68 +goal Set.thy "A Int (B Un C)  =  (A Int B) Un (A Int C)";
   40.69 +by (fast_tac eq_cs 1);
   40.70 +qed "Int_Un_distrib";
   40.71 +
   40.72 +goal Set.thy "(A<=B) = (A Int B = A)";
   40.73 +by (fast_tac (eq_cs addSEs [equalityE]) 1);
   40.74 +qed "subset_Int_eq";
   40.75 +
   40.76 +(** Binary Union **)
   40.77 +
   40.78 +goal Set.thy "A Un A = A";
   40.79 +by (fast_tac eq_cs 1);
   40.80 +qed "Un_absorb";
   40.81 +
   40.82 +goal Set.thy "A Un B  =  B Un A";
   40.83 +by (fast_tac eq_cs 1);
   40.84 +qed "Un_commute";
   40.85 +
   40.86 +goal Set.thy "(A Un B) Un C  =  A Un (B Un C)";
   40.87 +by (fast_tac eq_cs 1);
   40.88 +qed "Un_assoc";
   40.89 +
   40.90 +goal Set.thy "{} Un B = B";
   40.91 +by(fast_tac eq_cs 1);
   40.92 +qed "Un_empty_left";
   40.93 +
   40.94 +goal Set.thy "A Un {} = A";
   40.95 +by(fast_tac eq_cs 1);
   40.96 +qed "Un_empty_right";
   40.97 +
   40.98 +goal Set.thy "insert a B Un C = insert a (B Un C)";
   40.99 +by(fast_tac eq_cs 1);
  40.100 +qed "Un_insert_left";
  40.101 +
  40.102 +goal Set.thy "(A Int B) Un C  =  (A Un C) Int (B Un C)";
  40.103 +by (fast_tac eq_cs 1);
  40.104 +qed "Un_Int_distrib";
  40.105 +
  40.106 +goal Set.thy
  40.107 + "(A Int B) Un (B Int C) Un (C Int A) = (A Un B) Int (B Un C) Int (C Un A)";
  40.108 +by (fast_tac eq_cs 1);
  40.109 +qed "Un_Int_crazy";
  40.110 +
  40.111 +goal Set.thy "(A<=B) = (A Un B = B)";
  40.112 +by (fast_tac (eq_cs addSEs [equalityE]) 1);
  40.113 +qed "subset_Un_eq";
  40.114 +
  40.115 +goal Set.thy "(A <= insert b C) = (A <= C | b:A & A-{b} <= C)";
  40.116 +by (fast_tac eq_cs 1);
  40.117 +qed "subset_insert_iff";
  40.118 +
  40.119 +goal Set.thy "(A Un B = {}) = (A = {} & B = {})";
  40.120 +by (fast_tac (eq_cs addEs [equalityCE]) 1);
  40.121 +qed "Un_empty";
  40.122 +
  40.123 +(** Simple properties of Compl -- complement of a set **)
  40.124 +
  40.125 +goal Set.thy "A Int Compl(A) = {}";
  40.126 +by (fast_tac eq_cs 1);
  40.127 +qed "Compl_disjoint";
  40.128 +
  40.129 +goal Set.thy "A Un Compl(A) = {x.True}";
  40.130 +by (fast_tac eq_cs 1);
  40.131 +qed "Compl_partition";
  40.132 +
  40.133 +goal Set.thy "Compl(Compl(A)) = A";
  40.134 +by (fast_tac eq_cs 1);
  40.135 +qed "double_complement";
  40.136 +
  40.137 +goal Set.thy "Compl(A Un B) = Compl(A) Int Compl(B)";
  40.138 +by (fast_tac eq_cs 1);
  40.139 +qed "Compl_Un";
  40.140 +
  40.141 +goal Set.thy "Compl(A Int B) = Compl(A) Un Compl(B)";
  40.142 +by (fast_tac eq_cs 1);
  40.143 +qed "Compl_Int";
  40.144 +
  40.145 +goal Set.thy "Compl(UN x:A. B(x)) = (INT x:A. Compl(B(x)))";
  40.146 +by (fast_tac eq_cs 1);
  40.147 +qed "Compl_UN";
  40.148 +
  40.149 +goal Set.thy "Compl(INT x:A. B(x)) = (UN x:A. Compl(B(x)))";
  40.150 +by (fast_tac eq_cs 1);
  40.151 +qed "Compl_INT";
  40.152 +
  40.153 +(*Halmos, Naive Set Theory, page 16.*)
  40.154 +
  40.155 +goal Set.thy "((A Int B) Un C = A Int (B Un C)) = (C<=A)";
  40.156 +by (fast_tac (eq_cs addSEs [equalityE]) 1);
  40.157 +qed "Un_Int_assoc_eq";
  40.158 +
  40.159 +
  40.160 +(** Big Union and Intersection **)
  40.161 +
  40.162 +goal Set.thy "Union({}) = {}";
  40.163 +by (fast_tac eq_cs 1);
  40.164 +qed "Union_empty";
  40.165 +
  40.166 +goal Set.thy "Union(insert a B) = a Un Union(B)";
  40.167 +by (fast_tac eq_cs 1);
  40.168 +qed "Union_insert";
  40.169 +
  40.170 +goal Set.thy "Union(A Un B) = Union(A) Un Union(B)";
  40.171 +by (fast_tac eq_cs 1);
  40.172 +qed "Union_Un_distrib";
  40.173 +
  40.174 +goal Set.thy "Union(A Int B) <= Union(A) Int Union(B)";
  40.175 +by (fast_tac set_cs 1);
  40.176 +qed "Union_Int_subset";
  40.177 +
  40.178 +val prems = goal Set.thy
  40.179 +   "(Union(C) Int A = {}) = (! B:C. B Int A = {})";
  40.180 +by (fast_tac (eq_cs addSEs [equalityE]) 1);
  40.181 +qed "Union_disjoint";
  40.182 +
  40.183 +goal Set.thy "Inter(A Un B) = Inter(A) Int Inter(B)";
  40.184 +by (best_tac eq_cs 1);
  40.185 +qed "Inter_Un_distrib";
  40.186 +
  40.187 +(** Unions and Intersections of Families **)
  40.188 +
  40.189 +(*Basic identities*)
  40.190 +
  40.191 +goal Set.thy "Union(range(f)) = (UN x.f(x))";
  40.192 +by (fast_tac eq_cs 1);
  40.193 +qed "Union_range_eq";
  40.194 +
  40.195 +goal Set.thy "Inter(range(f)) = (INT x.f(x))";
  40.196 +by (fast_tac eq_cs 1);
  40.197 +qed "Inter_range_eq";
  40.198 +
  40.199 +goal Set.thy "Union(B``A) = (UN x:A. B(x))";
  40.200 +by (fast_tac eq_cs 1);
  40.201 +qed "Union_image_eq";
  40.202 +
  40.203 +goal Set.thy "Inter(B``A) = (INT x:A. B(x))";
  40.204 +by (fast_tac eq_cs 1);
  40.205 +qed "Inter_image_eq";
  40.206 +
  40.207 +goal Set.thy "!!A. a: A ==> (UN y:A. c) = c";
  40.208 +by (fast_tac eq_cs 1);
  40.209 +qed "UN_constant";
  40.210 +
  40.211 +goal Set.thy "!!A. a: A ==> (INT y:A. c) = c";
  40.212 +by (fast_tac eq_cs 1);
  40.213 +qed "INT_constant";
  40.214 +
  40.215 +goal Set.thy "(UN x.B) = B";
  40.216 +by (fast_tac eq_cs 1);
  40.217 +qed "UN1_constant";
  40.218 +
  40.219 +goal Set.thy "(INT x.B) = B";
  40.220 +by (fast_tac eq_cs 1);
  40.221 +qed "INT1_constant";
  40.222 +
  40.223 +goal Set.thy "(UN x:A. B(x)) = Union({Y. ? x:A. Y=B(x)})";
  40.224 +by (fast_tac eq_cs 1);
  40.225 +qed "UN_eq";
  40.226 +
  40.227 +(*Look: it has an EXISTENTIAL quantifier*)
  40.228 +goal Set.thy "(INT x:A. B(x)) = Inter({Y. ? x:A. Y=B(x)})";
  40.229 +by (fast_tac eq_cs 1);
  40.230 +qed "INT_eq";
  40.231 +
  40.232 +(*Distributive laws...*)
  40.233 +
  40.234 +goal Set.thy "A Int Union(B) = (UN C:B. A Int C)";
  40.235 +by (fast_tac eq_cs 1);
  40.236 +qed "Int_Union";
  40.237 +
  40.238 +(* Devlin, Fundamentals of Contemporary Set Theory, page 12, exercise 5: 
  40.239 +   Union of a family of unions **)
  40.240 +goal Set.thy "(UN x:C. A(x) Un B(x)) = Union(A``C)  Un  Union(B``C)";
  40.241 +by (fast_tac eq_cs 1);
  40.242 +qed "Un_Union_image";
  40.243 +
  40.244 +(*Equivalent version*)
  40.245 +goal Set.thy "(UN i:I. A(i) Un B(i)) = (UN i:I. A(i))  Un  (UN i:I. B(i))";
  40.246 +by (fast_tac eq_cs 1);
  40.247 +qed "UN_Un_distrib";
  40.248 +
  40.249 +goal Set.thy "A Un Inter(B) = (INT C:B. A Un C)";
  40.250 +by (fast_tac eq_cs 1);
  40.251 +qed "Un_Inter";
  40.252 +
  40.253 +goal Set.thy "(INT x:C. A(x) Int B(x)) = Inter(A``C) Int Inter(B``C)";
  40.254 +by (best_tac eq_cs 1);
  40.255 +qed "Int_Inter_image";
  40.256 +
  40.257 +(*Equivalent version*)
  40.258 +goal Set.thy "(INT i:I. A(i) Int B(i)) = (INT i:I. A(i)) Int (INT i:I. B(i))";
  40.259 +by (fast_tac eq_cs 1);
  40.260 +qed "INT_Int_distrib";
  40.261 +
  40.262 +(*Halmos, Naive Set Theory, page 35.*)
  40.263 +goal Set.thy "B Int (UN i:I. A(i)) = (UN i:I. B Int A(i))";
  40.264 +by (fast_tac eq_cs 1);
  40.265 +qed "Int_UN_distrib";
  40.266 +
  40.267 +goal Set.thy "B Un (INT i:I. A(i)) = (INT i:I. B Un A(i))";
  40.268 +by (fast_tac eq_cs 1);
  40.269 +qed "Un_INT_distrib";
  40.270 +
  40.271 +goal Set.thy
  40.272 +    "(UN i:I. A(i)) Int (UN j:J. B(j)) = (UN i:I. UN j:J. A(i) Int B(j))";
  40.273 +by (fast_tac eq_cs 1);
  40.274 +qed "Int_UN_distrib2";
  40.275 +
  40.276 +goal Set.thy
  40.277 +    "(INT i:I. A(i)) Un (INT j:J. B(j)) = (INT i:I. INT j:J. A(i) Un B(j))";
  40.278 +by (fast_tac eq_cs 1);
  40.279 +qed "Un_INT_distrib2";
  40.280 +
  40.281 +(** Simple properties of Diff -- set difference **)
  40.282 +
  40.283 +goal Set.thy "A-A = {}";
  40.284 +by (fast_tac eq_cs 1);
  40.285 +qed "Diff_cancel";
  40.286 +
  40.287 +goal Set.thy "{}-A = {}";
  40.288 +by (fast_tac eq_cs 1);
  40.289 +qed "empty_Diff";
  40.290 +
  40.291 +goal Set.thy "A-{} = A";
  40.292 +by (fast_tac eq_cs 1);
  40.293 +qed "Diff_empty";
  40.294 +
  40.295 +(*NOT SUITABLE FOR REWRITING since {a} == insert a 0*)
  40.296 +goal Set.thy "A - insert a B = A - B - {a}";
  40.297 +by (fast_tac eq_cs 1);
  40.298 +qed "Diff_insert";
  40.299 +
  40.300 +(*NOT SUITABLE FOR REWRITING since {a} == insert a 0*)
  40.301 +goal Set.thy "A - insert a B = A - {a} - B";
  40.302 +by (fast_tac eq_cs 1);
  40.303 +qed "Diff_insert2";
  40.304 +
  40.305 +val prems = goal Set.thy "a:A ==> insert a (A-{a}) = A";
  40.306 +by (fast_tac (eq_cs addSIs prems) 1);
  40.307 +qed "insert_Diff";
  40.308 +
  40.309 +goal Set.thy "A Int (B-A) = {}";
  40.310 +by (fast_tac eq_cs 1);
  40.311 +qed "Diff_disjoint";
  40.312 +
  40.313 +goal Set.thy "!!A. A<=B ==> A Un (B-A) = B";
  40.314 +by (fast_tac eq_cs 1);
  40.315 +qed "Diff_partition";
  40.316 +
  40.317 +goal Set.thy "!!A. [| A<=B; B<= C |] ==> (B - (C - A)) = (A :: 'a set)";
  40.318 +by (fast_tac eq_cs 1);
  40.319 +qed "double_diff";
  40.320 +
  40.321 +goal Set.thy "A - (B Un C) = (A-B) Int (A-C)";
  40.322 +by (fast_tac eq_cs 1);
  40.323 +qed "Diff_Un";
  40.324 +
  40.325 +goal Set.thy "A - (B Int C) = (A-B) Un (A-C)";
  40.326 +by (fast_tac eq_cs 1);
  40.327 +qed "Diff_Int";
  40.328 +
  40.329 +val set_ss = set_ss addsimps
  40.330 +  [in_empty,in_insert,insert_subset,
  40.331 +   Int_absorb,Int_empty_left,Int_empty_right,
  40.332 +   Un_absorb,Un_empty_left,Un_empty_right,Un_empty,
  40.333 +   UN1_constant,image_empty,
  40.334 +   Compl_disjoint,double_complement,
  40.335 +   Union_empty,Union_insert,empty_subsetI,subset_refl,
  40.336 +   Diff_cancel,empty_Diff,Diff_empty,Diff_disjoint];
    41.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    41.2 +++ b/src/HOL/equalities.thy	Fri Mar 03 12:02:25 1995 +0100
    41.3 @@ -0,0 +1,9 @@
    41.4 +(*  Title: 	HOL/equalities
    41.5 +    ID:         $Id$
    41.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    41.7 +    Copyright   1994  University of Cambridge
    41.8 +
    41.9 +Equalities involving union, intersection, inclusion, etc.
   41.10 +*)
   41.11 +
   41.12 +equalities = subset
    42.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    42.2 +++ b/src/HOL/hologic.ML	Fri Mar 03 12:02:25 1995 +0100
    42.3 @@ -0,0 +1,86 @@
    42.4 +(*  Title:      HOL/hologic.ML
    42.5 +    ID:         $Id$
    42.6 +    Author:     Lawrence C Paulson and Markus Wenzel
    42.7 +
    42.8 +Abstract syntax operations for HOL.
    42.9 +*)
   42.10 +
   42.11 +signature HOLOGIC =
   42.12 +sig
   42.13 +  val termC: class
   42.14 +  val termS: sort
   42.15 +  val termTVar: typ
   42.16 +  val boolT: typ
   42.17 +  val mk_setT: typ -> typ
   42.18 +  val dest_setT: typ -> typ
   42.19 +  val mk_Trueprop: term -> term
   42.20 +  val dest_Trueprop: term -> term
   42.21 +  val conj: term
   42.22 +  val disj: term
   42.23 +  val imp: term
   42.24 +  val eq_const: typ -> term
   42.25 +  val all_const: typ -> term
   42.26 +  val exists_const: typ -> term
   42.27 +  val Collect_const: typ -> term
   42.28 +  val mk_eq: term * term -> term
   42.29 +  val mk_all: string * typ * term -> term
   42.30 +  val mk_exists: string * typ * term -> term
   42.31 +  val mk_Collect: string * typ * term -> term
   42.32 +  val mk_mem: term * term -> term
   42.33 +end;
   42.34 +
   42.35 +structure HOLogic: HOLOGIC =
   42.36 +struct
   42.37 +
   42.38 +(* classes *)
   42.39 +
   42.40 +val termC: class = "term";
   42.41 +val termS: sort = [termC];
   42.42 +
   42.43 +
   42.44 +(* types *)
   42.45 +
   42.46 +val termTVar = TVar (("'a", 0), termS);
   42.47 +
   42.48 +val boolT = Type ("bool", []);
   42.49 +
   42.50 +fun mk_setT T = Type ("set", [T]);
   42.51 +
   42.52 +fun dest_setT (Type ("set", [T])) = T
   42.53 +  | dest_setT T = raise_type "dest_setT: set type expected" [T] [];
   42.54 +
   42.55 +
   42.56 +(* terms *)
   42.57 +
   42.58 +val Trueprop = Const ("Trueprop", boolT --> propT);
   42.59 +
   42.60 +fun mk_Trueprop P = Trueprop $ P;
   42.61 +
   42.62 +fun dest_Trueprop (Const ("Trueprop", _) $ P) = P
   42.63 +  | dest_Trueprop t = raise_term "dest_Trueprop" [t];
   42.64 +
   42.65 +
   42.66 +val conj = Const ("op &", [boolT, boolT] ---> boolT)
   42.67 +and disj = Const ("op |", [boolT, boolT] ---> boolT)
   42.68 +and imp = Const ("op -->", [boolT, boolT] ---> boolT);
   42.69 +
   42.70 +fun eq_const T = Const ("op =", [T, T] ---> boolT);
   42.71 +fun mk_eq (t, u) = eq_const (fastype_of t) $ t $ u;
   42.72 +
   42.73 +fun all_const T = Const ("All", [T --> boolT] ---> boolT);
   42.74 +fun mk_all (x, T, P) = all_const T $ absfree (x, T, P);
   42.75 +
   42.76 +fun exists_const T = Const ("Ex", [T --> boolT] ---> boolT);
   42.77 +fun mk_exists (x, T, P) = exists_const T $ absfree (x, T, P);
   42.78 +
   42.79 +fun Collect_const T = Const ("Collect", [T --> boolT] ---> mk_setT T);
   42.80 +fun mk_Collect (a, T, t) = Collect_const T $ absfree (a, T, t);
   42.81 +
   42.82 +fun mk_mem (x, A) =
   42.83 +  let val setT = fastype_of A in
   42.84 +    Const ("op :", [dest_setT setT, setT] ---> boolT) $ x $ A
   42.85 +  end;
   42.86 +
   42.87 +
   42.88 +end;
   42.89 +
    43.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    43.2 +++ b/src/HOL/ind_syntax.ML	Fri Mar 03 12:02:25 1995 +0100
    43.3 @@ -0,0 +1,124 @@
    43.4 +(*  Title: 	HOL/ind_syntax.ML
    43.5 +    ID:         $Id$
    43.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    43.7 +    Copyright   1994  University of Cambridge
    43.8 +
    43.9 +Abstract Syntax functions for Inductive Definitions
   43.10 +See also hologic.ML and ../Pure/section-utils.ML
   43.11 +*)
   43.12 +
   43.13 +(*The structure protects these items from redeclaration (somewhat!).  The 
   43.14 +  datatype definitions in theory files refer to these items by name!
   43.15 +*)
   43.16 +structure Ind_Syntax =
   43.17 +struct
   43.18 +
   43.19 +(** Abstract syntax definitions for HOL **)
   43.20 +
   43.21 +open HOLogic;
   43.22 +
   43.23 +fun Int_const T = 
   43.24 +  let val sT = mk_setT T
   43.25 +  in  Const("op Int", [sT,sT]--->sT)  end;
   43.26 +
   43.27 +fun mk_exists (Free(x,T),P) = exists_const T $ (absfree (x,T,P));
   43.28 +
   43.29 +fun mk_all (Free(x,T),P) = all_const T $ (absfree (x,T,P));
   43.30 +
   43.31 +(*Creates All(%v.v:A --> P(v)) rather than Ball(A,P) *)
   43.32 +fun mk_all_imp (A,P) = 
   43.33 +  let val T = dest_setT (fastype_of A)
   43.34 +  in  all_const T $ Abs("v", T, imp $ (mk_mem (Bound 0, A)) $ (P $ Bound 0))
   43.35 +  end;
   43.36 +
   43.37 +(** Cartesian product type **)
   43.38 +
   43.39 +val unitT = Type("unit",[]);
   43.40 +
   43.41 +fun mk_prod (T1,T2) = Type("*", [T1,T2]);
   43.42 +
   43.43 +(*Maps the type T1*...*Tn to [T1,...,Tn], if nested to the right*)
   43.44 +fun factors (Type("*", [T1,T2])) = T1 :: factors T2
   43.45 +  | factors T                    = [T];
   43.46 +
   43.47 +(*Make a correctly typed ordered pair*)
   43.48 +fun mk_Pair (t1,t2) = 
   43.49 +  let val T1 = fastype_of t1
   43.50 +      and T2 = fastype_of t2
   43.51 +  in  Const("Pair", [T1, T2] ---> mk_prod(T1,T2)) $ t1 $ t2  end;
   43.52 +   
   43.53 +fun split_const(Ta,Tb,Tc) = 
   43.54 +    Const("split", [[Ta,Tb]--->Tc, mk_prod(Ta,Tb)] ---> Tc);
   43.55 +
   43.56 +(*Given u expecting arguments of types [T1,...,Tn], create term of 
   43.57 +  type T1*...*Tn => Tc using split.  Here * associates to the LEFT*)
   43.58 +fun ap_split_l Tc u [ ]   = Abs("null", unitT, u)
   43.59 +  | ap_split_l Tc u [_]   = u
   43.60 +  | ap_split_l Tc u (Ta::Tb::Ts) = ap_split_l Tc (split_const(Ta,Tb,Tc) $ u) 
   43.61 +                                              (mk_prod(Ta,Tb) :: Ts);
   43.62 +
   43.63 +(*Given u expecting arguments of types [T1,...,Tn], create term of 
   43.64 +  type T1*...*Tn => i using split.  Here * associates to the RIGHT*)
   43.65 +fun ap_split Tc u [ ]   = Abs("null", unitT, u)
   43.66 +  | ap_split Tc u [_]   = u
   43.67 +  | ap_split Tc u [Ta,Tb] = split_const(Ta,Tb,Tc) $ u
   43.68 +  | ap_split Tc u (Ta::Ts) = 
   43.69 +      split_const(Ta, foldr1 mk_prod Ts, Tc) $ 
   43.70 +      (Abs("v", Ta, ap_split Tc (u $ Bound(length Ts - 2)) Ts));
   43.71 +
   43.72 +(** Disjoint sum type **)
   43.73 +
   43.74 +fun mk_sum (T1,T2) = Type("+", [T1,T2]);
   43.75 +val Inl	= Const("Inl", dummyT)
   43.76 +and Inr	= Const("Inr", dummyT);		(*correct types added later!*)
   43.77 +(*val elim	= Const("case", [iT-->iT, iT-->iT, iT]--->iT)*)
   43.78 +
   43.79 +fun summands (Type("+", [T1,T2])) = summands T1 @ summands T2
   43.80 +  | summands T                    = [T];
   43.81 +
   43.82 +(*Given the destination type, fills in correct types of an Inl/Inr nest*)
   43.83 +fun mend_sum_types (h,T) =
   43.84 +    (case (h,T) of
   43.85 +	 (Const("Inl",_) $ h1, Type("+", [T1,T2])) =>
   43.86 +	     Const("Inl", T1 --> T) $ (mend_sum_types (h1, T1))
   43.87 +       | (Const("Inr",_) $ h2, Type("+", [T1,T2])) =>
   43.88 +	     Const("Inr", T2 --> T) $ (mend_sum_types (h2, T2))
   43.89 +       | _ => h);
   43.90 +
   43.91 +
   43.92 +
   43.93 +(*simple error-checking in the premises of an inductive definition*)
   43.94 +fun chk_prem rec_hd (Const("op &",_) $ _ $ _) =
   43.95 +	error"Premises may not be conjuctive"
   43.96 +  | chk_prem rec_hd (Const("op :",_) $ t $ X) = 
   43.97 +	deny (Logic.occs(rec_hd,t)) "Recursion term on left of member symbol"
   43.98 +  | chk_prem rec_hd t = 
   43.99 +	deny (Logic.occs(rec_hd,t)) "Recursion term in side formula";
  43.100 +
  43.101 +(*Return the conclusion of a rule, of the form t:X*)
  43.102 +fun rule_concl rl = 
  43.103 +    let val Const("Trueprop",_) $ (Const("op :",_) $ t $ X) = 
  43.104 +		Logic.strip_imp_concl rl
  43.105 +    in  (t,X)  end;
  43.106 +
  43.107 +(*As above, but return error message if bad*)
  43.108 +fun rule_concl_msg sign rl = rule_concl rl
  43.109 +    handle Bind => error ("Ill-formed conclusion of introduction rule: " ^ 
  43.110 +			  Sign.string_of_term sign rl);
  43.111 +
  43.112 +(*For simplifying the elimination rule*)
  43.113 +val sumprod_free_SEs = 
  43.114 +    Pair_inject ::
  43.115 +    map make_elim [(*Inl_neq_Inr, Inr_neq_Inl, Inl_inject, Inr_inject*)];
  43.116 +
  43.117 +(*For deriving cases rules.  
  43.118 +  read_instantiate replaces a propositional variable by a formula variable*)
  43.119 +val equals_CollectD = 
  43.120 +    read_instantiate [("W","?Q")]
  43.121 +        (make_elim (equalityD1 RS subsetD RS CollectD));
  43.122 +
  43.123 +(*Delete needless equality assumptions*)
  43.124 +val refl_thin = prove_goal HOL.thy "!!P. [| a=a;  P |] ==> P"
  43.125 +     (fn _ => [assume_tac 1]);
  43.126 +
  43.127 +end;
    44.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    44.2 +++ b/src/HOL/indrule.ML	Fri Mar 03 12:02:25 1995 +0100
    44.3 @@ -0,0 +1,184 @@
    44.4 +(*  Title: 	HOL/indrule.ML
    44.5 +    ID:         $Id$
    44.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    44.7 +    Copyright   1994  University of Cambridge
    44.8 +
    44.9 +Induction rule module -- for Inductive/Coinductive Definitions
   44.10 +
   44.11 +Proves a strong induction rule and a mutual induction rule
   44.12 +*)
   44.13 +
   44.14 +signature INDRULE =
   44.15 +  sig
   44.16 +  val induct        : thm			(*main induction rule*)
   44.17 +  val mutual_induct : thm			(*mutual induction rule*)
   44.18 +  end;
   44.19 +
   44.20 +
   44.21 +functor Indrule_Fun
   44.22 +    (structure Inductive: sig include INDUCTIVE_ARG INDUCTIVE_I end and
   44.23 +	 Intr_elim: INTR_ELIM) : INDRULE  =
   44.24 +struct
   44.25 +open Logic Ind_Syntax Inductive Intr_elim;
   44.26 +
   44.27 +val sign = sign_of thy;
   44.28 +
   44.29 +val (Const(_,recT),rec_params) = strip_comb (hd rec_tms);
   44.30 +
   44.31 +val elem_type = dest_setT (body_type recT);
   44.32 +val domTs = summands(elem_type);
   44.33 +val big_rec_name = space_implode "_" rec_names;
   44.34 +val big_rec_tm = list_comb(Const(big_rec_name,recT), rec_params);
   44.35 +
   44.36 +val _ = writeln "  Proving the induction rules...";
   44.37 +
   44.38 +(*** Prove the main induction rule ***)
   44.39 +
   44.40 +val pred_name = "P";		(*name for predicate variables*)
   44.41 +
   44.42 +val big_rec_def::part_rec_defs = Intr_elim.defs;
   44.43 +
   44.44 +(*Used to express induction rules: adds induction hypotheses.
   44.45 +   ind_alist = [(rec_tm1,pred1),...]  -- associates predicates with rec ops
   44.46 +   prem is a premise of an intr rule*)
   44.47 +fun add_induct_prem ind_alist (prem as Const("Trueprop",_) $ 
   44.48 +		 (Const("op :",_)$t$X), iprems) =
   44.49 +     (case gen_assoc (op aconv) (ind_alist, X) of
   44.50 +	  Some pred => prem :: mk_Trueprop (pred $ t) :: iprems
   44.51 +	| None => (*possibly membership in M(rec_tm), for M monotone*)
   44.52 +	    let fun mk_sb (rec_tm,pred) = 
   44.53 +		 (case binder_types (fastype_of pred) of
   44.54 +		      [T] => (rec_tm, 
   44.55 +			      Int_const T $ rec_tm $ (Collect_const T $ pred))
   44.56 +		    | _ => error 
   44.57 +		      "Bug: add_induct_prem called with non-unary predicate")
   44.58 +	    in  subst_free (map mk_sb ind_alist) prem :: iprems  end)
   44.59 +  | add_induct_prem ind_alist (prem,iprems) = prem :: iprems;
   44.60 +
   44.61 +(*Make a premise of the induction rule.*)
   44.62 +fun induct_prem ind_alist intr =
   44.63 +  let val quantfrees = map dest_Free (term_frees intr \\ rec_params)
   44.64 +      val iprems = foldr (add_induct_prem ind_alist)
   44.65 +			 (strip_imp_prems intr,[])
   44.66 +      val (t,X) = rule_concl intr
   44.67 +      val (Some pred) = gen_assoc (op aconv) (ind_alist, X)
   44.68 +      val concl = mk_Trueprop (pred $ t)
   44.69 +  in list_all_free (quantfrees, list_implies (iprems,concl)) end
   44.70 +  handle Bind => error"Recursion term not found in conclusion";
   44.71 +
   44.72 +(*Avoids backtracking by delivering the correct premise to each goal*)
   44.73 +fun ind_tac [] 0 = all_tac
   44.74 +  | ind_tac(prem::prems) i = 
   44.75 +	DEPTH_SOLVE_1 (ares_tac [Part_eqI, prem, refl] i) THEN
   44.76 +	ind_tac prems (i-1);
   44.77 +
   44.78 +val pred = Free(pred_name, elem_type --> boolT);
   44.79 +
   44.80 +val ind_prems = map (induct_prem (map (rpair pred) rec_tms)) intr_tms;
   44.81 +
   44.82 +val quant_induct = 
   44.83 +    prove_goalw_cterm part_rec_defs 
   44.84 +      (cterm_of sign (list_implies (ind_prems, 
   44.85 +				    mk_Trueprop (mk_all_imp(big_rec_tm,pred)))))
   44.86 +      (fn prems =>
   44.87 +       [rtac (impI RS allI) 1,
   44.88 +	etac raw_induct 1,
   44.89 +	REPEAT (FIRSTGOAL (eresolve_tac [IntE, CollectE, exE, conjE, disjE] 
   44.90 +			   ORELSE' hyp_subst_tac)),
   44.91 +	REPEAT (FIRSTGOAL (eresolve_tac [PartE, CollectE])),
   44.92 +	ind_tac (rev prems) (length prems)])
   44.93 +    handle e => print_sign_exn sign e;
   44.94 +
   44.95 +(*** Prove the simultaneous induction rule ***)
   44.96 +
   44.97 +(*Make distinct predicates for each inductive set.
   44.98 +  Splits cartesian products in domT, IF nested to the right! *)
   44.99 +
  44.100 +(*Given a recursive set and its domain, return the "split" predicate
  44.101 +  and a conclusion for the simultaneous induction rule*)
  44.102 +fun mk_predpair (rec_tm,domT) = 
  44.103 +  let val rec_name = (#1 o dest_Const o head_of) rec_tm
  44.104 +      val T = factors domT ---> boolT
  44.105 +      val pfree = Free(pred_name ^ "_" ^ rec_name, T)
  44.106 +      val frees = mk_frees "za" (binder_types T)
  44.107 +      val qconcl = 
  44.108 +	foldr mk_all (frees, 
  44.109 +		      imp $ (mk_mem (foldr1 mk_Pair frees, rec_tm))
  44.110 +			  $ (list_comb (pfree,frees)))
  44.111 +  in  (ap_split boolT pfree (binder_types T), 
  44.112 +      qconcl)  
  44.113 +  end;
  44.114 +
  44.115 +val (preds,qconcls) = split_list (map mk_predpair (rec_tms~~domTs));
  44.116 +
  44.117 +(*Used to form simultaneous induction lemma*)
  44.118 +fun mk_rec_imp (rec_tm,pred) = 
  44.119 +    imp $ (mk_mem (Bound 0, rec_tm)) $  (pred $ Bound 0);
  44.120 +
  44.121 +(*To instantiate the main induction rule*)
  44.122 +val induct_concl = 
  44.123 + mk_Trueprop(mk_all_imp(big_rec_tm,
  44.124 +		     Abs("z", elem_type, 
  44.125 +			 fold_bal (app conj) 
  44.126 +			          (map mk_rec_imp (rec_tms~~preds)))))
  44.127 +and mutual_induct_concl = mk_Trueprop(fold_bal (app conj) qconcls);
  44.128 +
  44.129 +val lemma = (*makes the link between the two induction rules*)
  44.130 +    prove_goalw_cterm part_rec_defs 
  44.131 +	  (cterm_of sign (mk_implies (induct_concl,mutual_induct_concl)))
  44.132 +	  (fn prems =>
  44.133 +	   [cut_facts_tac prems 1,
  44.134 +	    REPEAT (eresolve_tac [asm_rl, conjE, PartE, mp] 1
  44.135 +	     ORELSE resolve_tac [allI, impI, conjI, Part_eqI, refl] 1
  44.136 +	     ORELSE dresolve_tac [spec, mp, splitD] 1)])
  44.137 +    handle e => print_sign_exn sign e;
  44.138 +
  44.139 +(*Mutual induction follows by freeness of Inl/Inr.*)
  44.140 +
  44.141 +(*Removes Collects caused by M-operators in the intro rules*)
  44.142 +val cmonos = [subset_refl RS Int_Collect_mono] RL monos RLN (2,[rev_subsetD]);
  44.143 +
  44.144 +(*Avoids backtracking by delivering the correct premise to each goal*)
  44.145 +fun mutual_ind_tac [] 0 = all_tac
  44.146 +  | mutual_ind_tac(prem::prems) i = 
  44.147 +      DETERM
  44.148 +       (SELECT_GOAL 
  44.149 +	  ((*unpackage and use "prem" in the corresponding place*)
  44.150 +	   REPEAT (FIRSTGOAL
  44.151 +		   (etac conjE ORELSE' eq_mp_tac ORELSE' 
  44.152 +		    ares_tac [impI, conjI]))
  44.153 +	   (*prem is not allowed in the REPEAT, lest it loop!*)
  44.154 +	   THEN TRYALL (rtac prem)
  44.155 +	   THEN REPEAT
  44.156 +		  (FIRSTGOAL (ares_tac [impI] ORELSE' 
  44.157 +			      eresolve_tac (mp::cmonos)))
  44.158 +	   (*prove remaining goals by contradiction*)
  44.159 +	   THEN rewrite_goals_tac (con_defs@part_rec_defs)
  44.160 +	   THEN DEPTH_SOLVE (eresolve_tac (PartE :: sumprod_free_SEs) 1))
  44.161 +	  i)
  44.162 +	THEN mutual_ind_tac prems (i-1);
  44.163 +
  44.164 +val mutual_induct_split = 
  44.165 +    prove_goalw_cterm []
  44.166 +	  (cterm_of sign
  44.167 +	   (list_implies (map (induct_prem (rec_tms~~preds)) intr_tms,
  44.168 +			  mutual_induct_concl)))
  44.169 +	  (fn prems =>
  44.170 +	   [rtac (quant_induct RS lemma) 1,
  44.171 +	    mutual_ind_tac (rev prems) (length prems)])
  44.172 +    handle e => print_sign_exn sign e;
  44.173 +
  44.174 +(*Attempts to remove all occurrences of split*)
  44.175 +val split_tac =
  44.176 +    REPEAT (SOMEGOAL (FIRST' [rtac splitI, 
  44.177 +			      dtac splitD,
  44.178 +			      etac splitE,
  44.179 +			      bound_hyp_subst_tac]))
  44.180 +    THEN prune_params_tac;
  44.181 +
  44.182 +(*strip quantifier*)
  44.183 +val induct = standard (quant_induct RS spec RSN (2,rev_mp));
  44.184 +
  44.185 +val mutual_induct = rule_by_tactic split_tac mutual_induct_split;
  44.186 +
  44.187 +end;
    45.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    45.2 +++ b/src/HOL/intr_elim.ML	Fri Mar 03 12:02:25 1995 +0100
    45.3 @@ -0,0 +1,141 @@
    45.4 +(*  Title: 	HOL/intr_elim.ML
    45.5 +    ID:         $Id$
    45.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    45.7 +    Copyright   1994  University of Cambridge
    45.8 +
    45.9 +Introduction/elimination rule module -- for Inductive/Coinductive Definitions
   45.10 +*)
   45.11 +
   45.12 +signature INDUCTIVE_ARG =	(** Description of a (co)inductive def **)
   45.13 +  sig
   45.14 +  val thy        : theory               (*new theory with inductive defs*)
   45.15 +  val monos      : thm list		(*monotonicity of each M operator*)
   45.16 +  val con_defs   : thm list		(*definitions of the constructors*)
   45.17 +  end;
   45.18 +
   45.19 +(*internal items*)
   45.20 +signature INDUCTIVE_I =
   45.21 +  sig
   45.22 +  val rec_tms    : term list		(*the recursive sets*)
   45.23 +  val intr_tms   : term list		(*terms for the introduction rules*)
   45.24 +  end;
   45.25 +
   45.26 +signature INTR_ELIM =
   45.27 +  sig
   45.28 +  val thy        : theory               (*copy of input theory*)
   45.29 +  val defs	 : thm list		(*definitions made in thy*)
   45.30 +  val mono	 : thm			(*monotonicity for the lfp definition*)
   45.31 +  val unfold     : thm			(*fixed-point equation*)
   45.32 +  val intrs      : thm list		(*introduction rules*)
   45.33 +  val elim       : thm			(*case analysis theorem*)
   45.34 +  val raw_induct : thm			(*raw induction rule from Fp.induct*)
   45.35 +  val mk_cases : thm list -> string -> thm	(*generates case theorems*)
   45.36 +  val rec_names  : string list		(*names of recursive sets*)
   45.37 +  end;
   45.38 +
   45.39 +(*prove intr/elim rules for a fixedpoint definition*)
   45.40 +functor Intr_elim_Fun
   45.41 +    (structure Inductive: sig include INDUCTIVE_ARG INDUCTIVE_I end  
   45.42 +     and Fp: FP) : INTR_ELIM =
   45.43 +struct
   45.44 +open Logic Inductive Ind_Syntax;
   45.45 +
   45.46 +val rec_names = map (#1 o dest_Const o head_of) rec_tms;
   45.47 +val big_rec_name = space_implode "_" rec_names;
   45.48 +
   45.49 +val _ = deny (big_rec_name  mem  map ! (stamps_of_thy thy))
   45.50 +             ("Definition " ^ big_rec_name ^ 
   45.51 +	      " would clash with the theory of the same name!");
   45.52 +
   45.53 +(*fetch fp definitions from the theory*)
   45.54 +val big_rec_def::part_rec_defs = 
   45.55 +  map (get_def thy)
   45.56 +      (case rec_names of [_] => rec_names | _ => big_rec_name::rec_names);
   45.57 +
   45.58 +
   45.59 +val sign = sign_of thy;
   45.60 +
   45.61 +(********)
   45.62 +val _ = writeln "  Proving monotonicity...";
   45.63 +
   45.64 +val Const("==",_) $ _ $ (Const(_,fpT) $ fp_abs) =
   45.65 +    big_rec_def |> rep_thm |> #prop |> unvarify;
   45.66 +
   45.67 +(*For the type of the argument of mono*)
   45.68 +val [monoT] = binder_types fpT;
   45.69 +
   45.70 +val mono = 
   45.71 +    prove_goalw_cterm [] 
   45.72 +      (cterm_of sign (mk_Trueprop (Const("mono", monoT-->boolT) $ fp_abs)))
   45.73 +      (fn _ =>
   45.74 +       [rtac monoI 1,
   45.75 +	REPEAT (ares_tac (basic_monos @ monos) 1)]);
   45.76 +
   45.77 +val unfold = standard (mono RS (big_rec_def RS Fp.Tarski));
   45.78 +
   45.79 +(********)
   45.80 +val _ = writeln "  Proving the introduction rules...";
   45.81 +
   45.82 +fun intro_tacsf disjIn prems = 
   45.83 +  [(*insert prems and underlying sets*)
   45.84 +   cut_facts_tac prems 1,
   45.85 +   rtac (unfold RS ssubst) 1,
   45.86 +   REPEAT (resolve_tac [Part_eqI,CollectI] 1),
   45.87 +   (*Now 1-2 subgoals: the disjunction, perhaps equality.*)
   45.88 +   rtac disjIn 1,
   45.89 +   (*Not ares_tac, since refl must be tried before any equality assumptions;
   45.90 +     backtracking may occur if the premises have extra variables!*)
   45.91 +   DEPTH_SOLVE_1 (resolve_tac [refl,exI,conjI] 1 ORELSE assume_tac 1)];
   45.92 +
   45.93 +(*combines disjI1 and disjI2 to access the corresponding nested disjunct...*)
   45.94 +val mk_disj_rls = 
   45.95 +    let fun f rl = rl RS disjI1
   45.96 +	and g rl = rl RS disjI2
   45.97 +    in  accesses_bal(f, g, asm_rl)  end;
   45.98 +
   45.99 +val intrs = map (uncurry (prove_goalw_cterm part_rec_defs))
  45.100 +            (map (cterm_of sign) intr_tms ~~ 
  45.101 +	     map intro_tacsf (mk_disj_rls(length intr_tms)));
  45.102 +
  45.103 +(********)
  45.104 +val _ = writeln "  Proving the elimination rule...";
  45.105 +
  45.106 +(*Includes rules for Suc and Pair since they are common constructions*)
  45.107 +val elim_rls = [asm_rl, FalseE, Suc_neq_Zero, Zero_neq_Suc,
  45.108 +		make_elim Suc_inject, 
  45.109 +		refl_thin, conjE, exE, disjE];
  45.110 +
  45.111 +(*Breaks down logical connectives in the monotonic function*)
  45.112 +val basic_elim_tac =
  45.113 +    REPEAT (SOMEGOAL (eresolve_tac (elim_rls@sumprod_free_SEs)
  45.114 +	      ORELSE' bound_hyp_subst_tac))
  45.115 +    THEN prune_params_tac;
  45.116 +
  45.117 +val elim = rule_by_tactic basic_elim_tac (unfold RS equals_CollectD);
  45.118 +
  45.119 +(*Applies freeness of the given constructors, which *must* be unfolded by
  45.120 +  the given defs.  Cannot simply use the local con_defs because con_defs=[] 
  45.121 +  for inference systems.
  45.122 +fun con_elim_tac defs =
  45.123 +    rewrite_goals_tac defs THEN basic_elim_tac THEN fold_tac defs;
  45.124 + *)
  45.125 +fun con_elim_tac simps =
  45.126 +  let val elim_tac = REPEAT o (eresolve_tac (elim_rls@sumprod_free_SEs))
  45.127 +  in ALLGOALS(EVERY'[elim_tac,
  45.128 +                     asm_full_simp_tac (nat_ss addsimps simps),
  45.129 +                     elim_tac,
  45.130 +                     REPEAT o bound_hyp_subst_tac])
  45.131 +     THEN prune_params_tac
  45.132 +  end;
  45.133 +
  45.134 +
  45.135 +(*String s should have the form t:Si where Si is an inductive set*)
  45.136 +fun mk_cases defs s = 
  45.137 +    rule_by_tactic (con_elim_tac defs)
  45.138 +      (assume_read thy s  RS  elim);
  45.139 +
  45.140 +val defs = big_rec_def::part_rec_defs;
  45.141 +
  45.142 +val raw_induct = standard ([big_rec_def, mono] MRS Fp.induct);
  45.143 +end;
  45.144 +
    46.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    46.2 +++ b/src/HOL/mono.ML	Fri Mar 03 12:02:25 1995 +0100
    46.3 @@ -0,0 +1,123 @@
    46.4 +(*  Title: 	HOL/mono
    46.5 +    ID:         $Id$
    46.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    46.7 +    Copyright   1991  University of Cambridge
    46.8 +
    46.9 +Monotonicity of various operations
   46.10 +*)
   46.11 +
   46.12 +goal Set.thy "!!A B. A<=B ==> f``A <= f``B";
   46.13 +by (fast_tac set_cs 1);
   46.14 +qed "image_mono";
   46.15 +
   46.16 +goal Set.thy "!!A B. A<=B ==> Pow(A) <= Pow(B)";
   46.17 +by (fast_tac set_cs 1);
   46.18 +qed "Pow_mono";
   46.19 +
   46.20 +goal Set.thy "!!A B. A<=B ==> Union(A) <= Union(B)";
   46.21 +by (fast_tac set_cs 1);
   46.22 +qed "Union_mono";
   46.23 +
   46.24 +goal Set.thy "!!A B. B<=A ==> Inter(A) <= Inter(B)";
   46.25 +by (fast_tac set_cs 1);
   46.26 +qed "Inter_anti_mono";
   46.27 +
   46.28 +val prems = goal Set.thy
   46.29 +    "[| A<=B;  !!x. x:A ==> f(x)<=g(x) |] ==> \
   46.30 +\    (UN x:A. f(x)) <= (UN x:B. g(x))";
   46.31 +by (fast_tac (set_cs addIs (prems RL [subsetD])) 1);
   46.32 +qed "UN_mono";
   46.33 +
   46.34 +val [prem] = goal Set.thy
   46.35 +    "[| !!x. f(x)<=g(x) |] ==> (UN x. f(x)) <= (UN x. g(x))";
   46.36 +by (fast_tac (set_cs addIs [prem RS subsetD]) 1);
   46.37 +qed "UN1_mono";
   46.38 +
   46.39 +val prems = goal Set.thy
   46.40 +    "[| B<=A;  !!x. x:A ==> f(x)<=g(x) |] ==> \
   46.41 +\    (INT x:A. f(x)) <= (INT x:A. g(x))";
   46.42 +by (fast_tac (set_cs addIs (prems RL [subsetD])) 1);
   46.43 +qed "INT_anti_mono";
   46.44 +
   46.45 +(*The inclusion is POSITIVE! *)
   46.46 +val [prem] = goal Set.thy
   46.47 +    "[| !!x. f(x)<=g(x) |] ==> (INT x. f(x)) <= (INT x. g(x))";
   46.48 +by (fast_tac (set_cs addIs [prem RS subsetD]) 1);
   46.49 +qed "INT1_mono";
   46.50 +
   46.51 +goal Set.thy "!!A B. [| A<=C;  B<=D |] ==> A Un B <= C Un D";
   46.52 +by (fast_tac set_cs 1);
   46.53 +qed "Un_mono";
   46.54 +
   46.55 +goal Set.thy "!!A B. [| A<=C;  B<=D |] ==> A Int B <= C Int D";
   46.56 +by (fast_tac set_cs 1);
   46.57 +qed "Int_mono";
   46.58 +
   46.59 +goal Set.thy "!!A::'a set. [| A<=C;  D<=B |] ==> A-B <= C-D";
   46.60 +by (fast_tac set_cs 1);
   46.61 +qed "Diff_mono";
   46.62 +
   46.63 +goal Set.thy "!!A B. A<=B ==> Compl(B) <= Compl(A)";
   46.64 +by (fast_tac set_cs 1);
   46.65 +qed "Compl_anti_mono";
   46.66 +
   46.67 +val prems = goal Prod.thy
   46.68 +    "[| A<=C;  !!x. x:A ==> B<=D |] ==> Sigma A (%x.B) <= Sigma C (%x.D)";
   46.69 +by (cut_facts_tac prems 1);
   46.70 +by (fast_tac (set_cs addIs (prems RL [subsetD]) 
   46.71 +                     addSIs [SigmaI] 
   46.72 +                     addSEs [SigmaE]) 1);
   46.73 +qed "Sigma_mono";
   46.74 +
   46.75 +
   46.76 +(** Monotonicity of implications.  For inductive definitions **)
   46.77 +
   46.78 +goal Set.thy "!!A B x. A<=B ==> x:A --> x:B";
   46.79 +by (rtac impI 1);
   46.80 +by (etac subsetD 1);
   46.81 +by (assume_tac 1);
   46.82 +qed "in_mono";
   46.83 +
   46.84 +goal HOL.thy "!!P1 P2 Q1 Q2. [| P1-->Q1; P2-->Q2 |] ==> (P1&P2) --> (Q1&Q2)";
   46.85 +by (fast_tac HOL_cs 1);
   46.86 +qed "conj_mono";
   46.87 +
   46.88 +goal HOL.thy "!!P1 P2 Q1 Q2. [| P1-->Q1; P2-->Q2 |] ==> (P1|P2) --> (Q1|Q2)";
   46.89 +by (fast_tac HOL_cs 1);
   46.90 +qed "disj_mono";
   46.91 +
   46.92 +goal HOL.thy "!!P1 P2 Q1 Q2.[| Q1-->P1; P2-->Q2 |] ==> (P1-->P2)-->(Q1-->Q2)";
   46.93 +by (fast_tac HOL_cs 1);
   46.94 +qed "imp_mono";
   46.95 +
   46.96 +goal HOL.thy "P-->P";
   46.97 +by (rtac impI 1);
   46.98 +by (assume_tac 1);
   46.99 +qed "imp_refl";
  46.100 +
  46.101 +val [PQimp] = goal HOL.thy
  46.102 +    "[| !!x. P(x) --> Q(x) |] ==> (EX x.P(x)) --> (EX x.Q(x))";
  46.103 +by (fast_tac (HOL_cs addIs [PQimp RS mp]) 1);
  46.104 +qed "ex_mono";
  46.105 +
  46.106 +val [PQimp] = goal HOL.thy
  46.107 +    "[| !!x. P(x) --> Q(x) |] ==> (ALL x.P(x)) --> (ALL x.Q(x))";
  46.108 +by (fast_tac (HOL_cs addIs [PQimp RS mp]) 1);
  46.109 +qed "all_mono";
  46.110 +
  46.111 +val [PQimp] = goal Set.thy
  46.112 +    "[| !!x. P(x) --> Q(x) |] ==> Collect(P) <= Collect(Q)";
  46.113 +by (fast_tac (set_cs addIs [PQimp RS mp]) 1);
  46.114 +qed "Collect_mono";
  46.115 +
  46.116 +(*Used in indrule.ML*)
  46.117 +val [subs,PQimp] = goal Set.thy
  46.118 +    "[| A<=B;  !!x. x:A ==> P(x) --> Q(x) \
  46.119 +\    |] ==> A Int Collect(P) <= B Int Collect(Q)";
  46.120 +by (fast_tac (set_cs addIs [subs RS subsetD, PQimp RS mp]) 1);
  46.121 +qed "Int_Collect_mono";
  46.122 +
  46.123 +(*Used in intr_elim.ML and in individual datatype definitions*)
  46.124 +val basic_monos = [subset_refl, imp_refl, disj_mono, conj_mono, 
  46.125 +		   ex_mono, Collect_mono, Part_mono, in_mono];
  46.126 +
    47.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    47.2 +++ b/src/HOL/mono.thy	Fri Mar 03 12:02:25 1995 +0100
    47.3 @@ -0,0 +1,8 @@
    47.4 +(*  Title: 	HOL/mono
    47.5 +    ID:         $Id$
    47.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    47.7 +    Copyright   1991  University of Cambridge
    47.8 +
    47.9 +*)
   47.10 +
   47.11 +mono = subset
    48.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    48.2 +++ b/src/HOL/simpdata.ML	Fri Mar 03 12:02:25 1995 +0100
    48.3 @@ -0,0 +1,163 @@
    48.4 +(*  Title: 	HOL/simpdata.ML
    48.5 +    ID:         $Id$
    48.6 +    Author: 	Tobias Nipkow
    48.7 +    Copyright   1991  University of Cambridge
    48.8 +
    48.9 +Instantiation of the generic simplifier
   48.10 +*)
   48.11 +
   48.12 +open Simplifier;
   48.13 +
   48.14 +local
   48.15 +
   48.16 +fun prover s = prove_goal HOL.thy s (fn _ => [fast_tac HOL_cs 1]);
   48.17 +
   48.18 +val P_imp_P_iff_True = prover "P --> (P = True)" RS mp;
   48.19 +val P_imp_P_eq_True = P_imp_P_iff_True RS eq_reflection;
   48.20 +
   48.21 +val not_P_imp_P_iff_F = prover "~P --> (P = False)" RS mp;
   48.22 +val not_P_imp_P_eq_False = not_P_imp_P_iff_F RS eq_reflection;
   48.23 +
   48.24 +fun atomize pairs =
   48.25 +  let fun atoms th =
   48.26 +        (case concl_of th of
   48.27 +           Const("Trueprop",_) $ p =>
   48.28 +             (case head_of p of
   48.29 +                Const(a,_) =>
   48.30 +                  (case assoc(pairs,a) of
   48.31 +                     Some(rls) => flat (map atoms ([th] RL rls))
   48.32 +                   | None => [th])
   48.33 +              | _ => [th])
   48.34 +         | _ => [th])
   48.35 +  in atoms end;
   48.36 +
   48.37 +fun mk_meta_eq r = case concl_of r of
   48.38 +	Const("==",_)$_$_ => r
   48.39 +    |	_$(Const("op =",_)$_$_) => r RS eq_reflection
   48.40 +    |	_$(Const("not",_)$_) => r RS not_P_imp_P_eq_False
   48.41 +    |   _ => r RS P_imp_P_eq_True;
   48.42 +(* last 2 lines requires all formulae to be of the from Trueprop(.) *)
   48.43 +
   48.44 +fun gen_all th = forall_elim_vars (#maxidx(rep_thm th)+1) th;
   48.45 +
   48.46 +val imp_cong = impI RSN
   48.47 +    (2, prove_goal HOL.thy "(P=P')--> (P'--> (Q=Q'))--> ((P-->Q) = (P'-->Q'))"
   48.48 +	(fn _=> [fast_tac HOL_cs 1]) RS mp RS mp);
   48.49 +
   48.50 +val o_apply = prove_goalw HOL.thy [o_def] "(f o g)(x) = f(g(x))"
   48.51 + (fn _ => [rtac refl 1]);
   48.52 +
   48.53 +val simp_thms = map prover
   48.54 + [ "(x=x) = True",
   48.55 +   "(~True) = False", "(~False) = True", "(~ ~ P) = P",
   48.56 +   "(~P) ~= P", "P ~= (~P)", "(P ~= Q) = (P = (~Q))",
   48.57 +   "(True=P) = P", "(P=True) = P",
   48.58 +   "(True --> P) = P", "(False --> P) = True", 
   48.59 +   "(P --> True) = True", "(P --> P) = True",
   48.60 +   "(P --> False) = (~P)", "(P --> ~P) = (~P)",
   48.61 +   "(P & True) = P", "(True & P) = P", 
   48.62 +   "(P & False) = False", "(False & P) = False", "(P & P) = P",
   48.63 +   "(P | True) = True", "(True | P) = True", 
   48.64 +   "(P | False) = P", "(False | P) = P", "(P | P) = P",
   48.65 +   "(!x.P) = P", "(? x.P) = P", "? x. x=t", "(? x. x=t & P(x)) = P(t)",
   48.66 +   "(P|Q --> R) = ((P-->R)&(Q-->R))" ];
   48.67 +
   48.68 +in
   48.69 +
   48.70 +val meta_eq_to_obj_eq = prove_goal HOL.thy "x==y ==> x=y"
   48.71 +  (fn [prem] => [rewtac prem, rtac refl 1]);
   48.72 +
   48.73 +val eq_sym_conv = prover "(x=y) = (y=x)";
   48.74 +
   48.75 +val conj_assoc = prover "((P&Q)&R) = (P&(Q&R))";
   48.76 +
   48.77 +val if_True = prove_goalw HOL.thy [if_def] "if True x y = x"
   48.78 + (fn _=>[fast_tac (HOL_cs addIs [select_equality]) 1]);
   48.79 +
   48.80 +val if_False = prove_goalw HOL.thy [if_def] "if False x y = y"
   48.81 + (fn _=>[fast_tac (HOL_cs addIs [select_equality]) 1]);
   48.82 +
   48.83 +val if_P = prove_goal HOL.thy "P ==> if P x y = x"
   48.84 + (fn [prem] => [ stac (prem RS eqTrueI) 1, rtac if_True 1 ]);
   48.85 +
   48.86 +val if_not_P = prove_goal HOL.thy "~P ==> if P x y = y"
   48.87 + (fn [prem] => [ stac (prem RS not_P_imp_P_iff_F) 1, rtac if_False 1 ]);
   48.88 +
   48.89 +val expand_if = prove_goal HOL.thy
   48.90 +    "P(if Q x y) = ((Q --> P(x)) & (~Q --> P(y)))"
   48.91 + (fn _=> [ (res_inst_tac [("Q","Q")] (excluded_middle RS disjE) 1),
   48.92 +	 rtac (if_P RS ssubst) 2,
   48.93 +	 rtac (if_not_P RS ssubst) 1,
   48.94 +	 REPEAT(fast_tac HOL_cs 1) ]);
   48.95 +
   48.96 +val if_bool_eq = prove_goal HOL.thy "if P Q R = ((P-->Q) & (~P-->R))"
   48.97 +  (fn _ => [rtac expand_if 1]);
   48.98 +
   48.99 +infix addcongs;
  48.100 +fun ss addcongs congs = ss addeqcongs (congs RL [eq_reflection]);
  48.101 +
  48.102 +val mksimps_pairs =
  48.103 +  [("op -->", [mp]), ("op &", [conjunct1,conjunct2]),
  48.104 +   ("All", [spec]), ("True", []), ("False", []),
  48.105 +   ("if", [if_bool_eq RS iffD1])];
  48.106 +
  48.107 +fun mksimps pairs = map mk_meta_eq o atomize pairs o gen_all;
  48.108 +
  48.109 +val HOL_ss = empty_ss
  48.110 +      setmksimps (mksimps mksimps_pairs)
  48.111 +      setsolver (fn prems => resolve_tac (TrueI::refl::prems) ORELSE' atac
  48.112 +                             ORELSE' etac FalseE)
  48.113 +      setsubgoaler asm_simp_tac
  48.114 +      addsimps ([if_True, if_False, o_apply, conj_assoc] @ simp_thms)
  48.115 +      addcongs [imp_cong];
  48.116 +
  48.117 +fun split_tac splits =
  48.118 +  mk_case_split_tac (meta_eq_to_obj_eq RS iffD2) (map mk_meta_eq splits);
  48.119 +
  48.120 +(* eliminiation of existential quantifiers in assumptions *)
  48.121 +
  48.122 +val ex_all_equiv =
  48.123 +  let val lemma1 = prove_goal HOL.thy
  48.124 +        "(? x. P(x) ==> PROP Q) ==> (!!x. P(x) ==> PROP Q)"
  48.125 +        (fn prems => [resolve_tac prems 1, etac exI 1]);
  48.126 +      val lemma2 = prove_goalw HOL.thy [Ex_def]
  48.127 +        "(!!x. P(x) ==> PROP Q) ==> (? x. P(x) ==> PROP Q)"
  48.128 +        (fn prems => [REPEAT(resolve_tac prems 1)])
  48.129 +  in equal_intr lemma1 lemma2 end;
  48.130 +
  48.131 +(* '&' congruence rule: not included by default!
  48.132 +   May slow rewrite proofs down by as much as 50% *)
  48.133 +
  48.134 +val conj_cong = impI RSN
  48.135 +    (2, prove_goal HOL.thy "(P=P')--> (P'--> (Q=Q'))--> ((P&Q) = (P'&Q'))"
  48.136 +	(fn _=> [fast_tac HOL_cs 1]) RS mp RS mp);
  48.137 +
  48.138 +(** 'if' congruence rules: neither included by default! *)
  48.139 +
  48.140 +(*Simplifies x assuming c and y assuming ~c*)
  48.141 +val if_cong = prove_goal HOL.thy
  48.142 +  "[| b=c; c ==> x=u; ~c ==> y=v |] ==> if b x y = if c u v"
  48.143 +  (fn rew::prems =>
  48.144 +   [stac rew 1, stac expand_if 1, stac expand_if 1,
  48.145 +    fast_tac (HOL_cs addDs prems) 1]);
  48.146 +
  48.147 +(*Prevents simplification of x and y: much faster*)
  48.148 +val if_weak_cong = prove_goal HOL.thy
  48.149 +  "b=c ==> if b x y = if c x y"
  48.150 +  (fn [prem] => [rtac (prem RS arg_cong) 1]);
  48.151 +
  48.152 +(*Prevents simplification of t: much faster*)
  48.153 +val let_weak_cong = prove_goal HOL.thy
  48.154 +  "a = b ==> (let x=a in t(x)) = (let x=b in t(x))"
  48.155 +  (fn [prem] => [rtac (prem RS arg_cong) 1]);
  48.156 +
  48.157 +end;
  48.158 +
  48.159 +fun prove nm thm  = qed_goal nm HOL.thy thm (fn _ => [fast_tac HOL_cs 1]);
  48.160 +
  48.161 +prove "conj_commute" "(P&Q) = (Q&P)";
  48.162 +prove "conj_left_commute" "(P&(Q&R)) = (Q&(P&R))";
  48.163 +val conj_comms = [conj_commute, conj_left_commute];
  48.164 +
  48.165 +prove "conj_disj_distribL" "(P&(Q|R)) = (P&Q | P&R)";
  48.166 +prove "conj_disj_distribR" "((P|Q)&R) = (P&R | Q&R)";
    49.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    49.2 +++ b/src/HOL/subset.ML	Fri Mar 03 12:02:25 1995 +0100
    49.3 @@ -0,0 +1,135 @@
    49.4 +(*  Title: 	HOL/subset
    49.5 +    ID:         $Id$
    49.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    49.7 +    Copyright   1991  University of Cambridge
    49.8 +
    49.9 +Derived rules involving subsets
   49.10 +Union and Intersection as lattice operations
   49.11 +*)
   49.12 +
   49.13 +(*** insert ***)
   49.14 +
   49.15 +qed_goal "subset_insertI" Set.thy "B <= insert a B"
   49.16 + (fn _=> [ (rtac subsetI 1), (etac insertI2 1) ]);
   49.17 +
   49.18 +(*** Big Union -- least upper bound of a set  ***)
   49.19 +
   49.20 +val prems = goal Set.thy
   49.21 +    "B:A ==> B <= Union(A)";
   49.22 +by (REPEAT (ares_tac (prems@[subsetI,UnionI]) 1));
   49.23 +qed "Union_upper";
   49.24 +
   49.25 +val [prem] = goal Set.thy
   49.26 +    "[| !!X. X:A ==> X<=C |] ==> Union(A) <= C";
   49.27 +br subsetI 1;
   49.28 +by (REPEAT (eresolve_tac [asm_rl, UnionE, prem RS subsetD] 1));
   49.29 +qed "Union_least";
   49.30 +
   49.31 +(** General union **)
   49.32 +
   49.33 +val prems = goal Set.thy
   49.34 +    "a:A ==> B(a) <= (UN x:A. B(x))";
   49.35 +by (REPEAT (ares_tac (prems@[UN_I RS subsetI]) 1));
   49.36 +qed "UN_upper";
   49.37 +
   49.38 +val [prem] = goal Set.thy
   49.39 +    "[| !!x. x:A ==> B(x)<=C |] ==> (UN x:A. B(x)) <= C";
   49.40 +br subsetI 1;
   49.41 +by (REPEAT (eresolve_tac [asm_rl, UN_E, prem RS subsetD] 1));
   49.42 +qed "UN_least";
   49.43 +
   49.44 +goal Set.thy "B(a) <= (UN x. B(x))";
   49.45 +by (REPEAT (ares_tac [UN1_I RS subsetI] 1));
   49.46 +qed "UN1_upper";
   49.47 +
   49.48 +val [prem] = goal Set.thy "[| !!x. B(x)<=C |] ==> (UN x. B(x)) <= C";
   49.49 +br subsetI 1;
   49.50 +by (REPEAT (eresolve_tac [asm_rl, UN1_E, prem RS subsetD] 1));
   49.51 +qed "UN1_least";
   49.52 +
   49.53 +
   49.54 +(*** Big Intersection -- greatest lower bound of a set ***)
   49.55 +
   49.56 +val prems = goal Set.thy "B:A ==> Inter(A) <= B";
   49.57 +br subsetI 1;
   49.58 +by (REPEAT (resolve_tac prems 1 ORELSE etac InterD 1));
   49.59 +qed "Inter_lower";
   49.60 +
   49.61 +val [prem] = goal Set.thy
   49.62 +    "[| !!X. X:A ==> C<=X |] ==> C <= Inter(A)";
   49.63 +br (InterI RS subsetI) 1;
   49.64 +by (REPEAT (eresolve_tac [asm_rl, prem RS subsetD] 1));
   49.65 +qed "Inter_greatest";
   49.66 +
   49.67 +val prems = goal Set.thy "a:A ==> (INT x:A. B(x)) <= B(a)";
   49.68 +br subsetI 1;
   49.69 +by (REPEAT (resolve_tac prems 1 ORELSE etac INT_D 1));
   49.70 +qed "INT_lower";
   49.71 +
   49.72 +val [prem] = goal Set.thy
   49.73 +    "[| !!x. x:A ==> C<=B(x) |] ==> C <= (INT x:A. B(x))";
   49.74 +br (INT_I RS subsetI) 1;
   49.75 +by (REPEAT (eresolve_tac [asm_rl, prem RS subsetD] 1));
   49.76 +qed "INT_greatest";
   49.77 +
   49.78 +goal Set.thy "(INT x. B(x)) <= B(a)";
   49.79 +br subsetI 1;
   49.80 +by (REPEAT (resolve_tac prems 1 ORELSE etac INT1_D 1));
   49.81 +qed "INT1_lower";
   49.82 +
   49.83 +val [prem] = goal Set.thy
   49.84 +    "[| !!x. C<=B(x) |] ==> C <= (INT x. B(x))";
   49.85 +br (INT1_I RS subsetI) 1;
   49.86 +by (REPEAT (eresolve_tac [asm_rl, prem RS subsetD] 1));
   49.87 +qed "INT1_greatest";
   49.88 +
   49.89 +(*** Finite Union -- the least upper bound of 2 sets ***)
   49.90 +
   49.91 +goal Set.thy "A <= A Un B";
   49.92 +by (REPEAT (ares_tac [subsetI,UnI1] 1));
   49.93 +qed "Un_upper1";
   49.94 +
   49.95 +goal Set.thy "B <= A Un B";
   49.96 +by (REPEAT (ares_tac [subsetI,UnI2] 1));
   49.97 +qed "Un_upper2";
   49.98 +
   49.99 +val prems = goal Set.thy "[| A<=C;  B<=C |] ==> A Un B <= C";
  49.100 +by (cut_facts_tac prems 1);
  49.101 +by (DEPTH_SOLVE (ares_tac [subsetI] 1 
  49.102 +          ORELSE eresolve_tac [UnE,subsetD] 1));
  49.103 +qed "Un_least";
  49.104 +
  49.105 +(*** Finite Intersection -- the greatest lower bound of 2 sets *)
  49.106 +
  49.107 +goal Set.thy "A Int B <= A";
  49.108 +by (REPEAT (ares_tac [subsetI] 1 ORELSE etac IntE 1));
  49.109 +qed "Int_lower1";
  49.110 +
  49.111 +goal Set.thy "A Int B <= B";
  49.112 +by (REPEAT (ares_tac [subsetI] 1 ORELSE etac IntE 1));
  49.113 +qed "Int_lower2";
  49.114 +
  49.115 +val prems = goal Set.thy "[| C<=A;  C<=B |] ==> C <= A Int B";
  49.116 +by (cut_facts_tac prems 1);
  49.117 +by (REPEAT (ares_tac [subsetI,IntI] 1
  49.118 +     ORELSE etac subsetD 1));
  49.119 +qed "Int_greatest";
  49.120 +
  49.121 +(*** Set difference ***)
  49.122 +
  49.123 +qed_goal "Diff_subset" Set.thy "A-B <= (A::'a set)"
  49.124 + (fn _ => [ (REPEAT (ares_tac [subsetI] 1 ORELSE etac DiffE 1)) ]);
  49.125 +
  49.126 +(*** Monotonicity ***)
  49.127 +
  49.128 +val [prem] = goal Set.thy "mono(f) ==> f(A) Un f(B) <= f(A Un B)";
  49.129 +by (rtac Un_least 1);
  49.130 +by (rtac (Un_upper1 RS (prem RS monoD)) 1);
  49.131 +by (rtac (Un_upper2 RS (prem RS monoD)) 1);
  49.132 +qed "mono_Un";
  49.133 +
  49.134 +val [prem] = goal Set.thy "mono(f) ==> f(A Int B) <= f(A) Int f(B)";
  49.135 +by (rtac Int_greatest 1);
  49.136 +by (rtac (Int_lower1 RS (prem RS monoD)) 1);
  49.137 +by (rtac (Int_lower2 RS (prem RS monoD)) 1);
  49.138 +qed "mono_Int";
    50.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    50.2 +++ b/src/HOL/subset.thy	Fri Mar 03 12:02:25 1995 +0100
    50.3 @@ -0,0 +1,7 @@
    50.4 +(*  Title: 	HOL/subset.thy
    50.5 +    ID:         $Id$
    50.6 +    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
    50.7 +    Copyright   1994  University of Cambridge
    50.8 +*)
    50.9 +
   50.10 +subset = Fun
    51.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    51.2 +++ b/src/HOL/subtype.ML	Fri Mar 03 12:02:25 1995 +0100
    51.3 @@ -0,0 +1,141 @@
    51.4 +(*  Title:      HOL/subtype.ML
    51.5 +    ID:         $Id$
    51.6 +    Author:     Markus Wenzel, TU Muenchen
    51.7 +
    51.8 +Internal interface for subtype definitions.
    51.9 +*)
   51.10 +
   51.11 +signature SUBTYPE =
   51.12 +sig
   51.13 +  val prove_nonempty: cterm -> thm list -> tactic option -> thm
   51.14 +  val add_subtype: string -> string * string list * mixfix ->
   51.15 +    string -> string list -> thm list -> tactic option -> theory -> theory
   51.16 +  val add_subtype_i: string -> string * string list * mixfix ->
   51.17 +    term -> string list -> thm list -> tactic option -> theory -> theory
   51.18 +end;
   51.19 +
   51.20 +structure Subtype: SUBTYPE =
   51.21 +struct
   51.22 +
   51.23 +open Syntax Logic HOLogic;
   51.24 +
   51.25 +
   51.26 +(* prove non-emptyness of a set *)   (*exception ERROR*)
   51.27 +
   51.28 +val is_def = is_equals o #prop o rep_thm;
   51.29 +
   51.30 +fun prove_nonempty cset thms usr_tac =
   51.31 +  let
   51.32 +    val {T = setT, t = set, maxidx, sign} = rep_cterm cset;
   51.33 +    val T = dest_setT setT;
   51.34 +    val goal =
   51.35 +      cterm_of sign (mk_Trueprop (mk_mem (Var (("x", maxidx + 1), T), set)));
   51.36 +    val tac =
   51.37 +      TRY (rewrite_goals_tac (filter is_def thms)) THEN
   51.38 +      TRY (REPEAT_FIRST (resolve_tac (filter_out is_def thms))) THEN
   51.39 +      if_none usr_tac (TRY (ALLGOALS (fast_tac set_cs)));
   51.40 +  in
   51.41 +    prove_goalw_cterm [] goal (K [tac])
   51.42 +  end
   51.43 +  handle ERROR =>
   51.44 +    error ("Failed to prove non-emptyness of " ^ quote (string_of_cterm cset));
   51.45 +
   51.46 +
   51.47 +(* ext_subtype *)
   51.48 +
   51.49 +fun ext_subtype prep_term name (t, vs, mx) raw_set axms thms usr_tac thy =
   51.50 +  let
   51.51 +    val _ = require_thy thy "Set" "subtype definitions";
   51.52 +    val sign = sign_of thy;
   51.53 +
   51.54 +    (*rhs*)
   51.55 +    val cset = prep_term sign raw_set;
   51.56 +    val {T = setT, t = set, ...} = rep_cterm cset;
   51.57 +    val rhs_tfrees = term_tfrees set;
   51.58 +    val oldT = dest_setT setT handle TYPE _ =>
   51.59 +      error ("Not a set type: " ^ quote (Sign.string_of_typ sign setT));
   51.60 +
   51.61 +    (*lhs*)
   51.62 +    val lhs_tfrees =
   51.63 +      map (fn v => (v, if_none (assoc (rhs_tfrees, v)) termS)) vs;
   51.64 +
   51.65 +    val tname = type_name t mx;
   51.66 +    val tlen = length vs;
   51.67 +    val newT = Type (tname, map TFree lhs_tfrees);
   51.68 +
   51.69 +    val Rep_name = "Rep_" ^ name;
   51.70 +    val Abs_name = "Abs_" ^ name;
   51.71 +    val setC = Const (name, setT);
   51.72 +    val RepC = Const (Rep_name, newT --> oldT);
   51.73 +    val AbsC = Const (Abs_name, oldT --> newT);
   51.74 +    val x_new = Free ("x", newT);
   51.75 +    val y_old = Free ("y", oldT);
   51.76 +
   51.77 +    (*axioms*)
   51.78 +    val rep_type = mk_Trueprop (mk_mem (RepC $ x_new, setC));
   51.79 +    val rep_type_inv = mk_Trueprop (mk_eq (AbsC $ (RepC $ x_new), x_new));
   51.80 +    val abs_type_inv = mk_implies (mk_Trueprop (mk_mem (y_old, setC)),
   51.81 +      mk_Trueprop (mk_eq (RepC $ (AbsC $ y_old), y_old)));
   51.82 +
   51.83 +
   51.84 +    (* errors *)
   51.85 +
   51.86 +    val show_names = commas_quote o map fst;
   51.87 +
   51.88 +    val illegal_vars =
   51.89 +      if null (term_vars set) andalso null (term_tvars set) then []
   51.90 +      else ["Illegal schematic variable(s) on rhs"];
   51.91 +
   51.92 +    val dup_lhs_tfrees =
   51.93 +      (case duplicates lhs_tfrees of [] => []
   51.94 +      | dups => ["Duplicate type variables on lhs: " ^ show_names dups]);
   51.95 +
   51.96 +    val extra_rhs_tfrees =
   51.97 +      (case gen_rems (op =) (rhs_tfrees, lhs_tfrees) of [] => []
   51.98 +      | extras => ["Extra type variables on rhs: " ^ show_names extras]);
   51.99 +
  51.100 +    val illegal_frees =
  51.101 +      (case term_frees set of [] => []
  51.102 +      | xs => ["Illegal variables on rhs: " ^ show_names (map dest_Free xs)]);
  51.103 +
  51.104 +    val errs = illegal_vars @ dup_lhs_tfrees @ extra_rhs_tfrees @ illegal_frees;
  51.105 +  in
  51.106 +    if null errs then ()
  51.107 +    else error (cat_lines errs);
  51.108 +
  51.109 +    prove_nonempty cset (map (get_axiom thy) axms @ thms) usr_tac;
  51.110 +
  51.111 +    thy
  51.112 +    |> add_types [(t, tlen, mx)]
  51.113 +    |> add_arities
  51.114 +     [(tname, replicate tlen logicS, logicS),
  51.115 +      (tname, replicate tlen termS, termS)]
  51.116 +    |> add_consts_i
  51.117 +     [(name, setT, NoSyn),
  51.118 +      (Rep_name, newT --> oldT, NoSyn),
  51.119 +      (Abs_name, oldT --> newT, NoSyn)]
  51.120 +    |> add_defs_i
  51.121 +     [(name ^ "_def", mk_equals (setC, set))]
  51.122 +    |> add_axioms_i
  51.123 +     [(Rep_name, rep_type),
  51.124 +      (Rep_name ^ "_inverse", rep_type_inv),
  51.125 +      (Abs_name ^ "_inverse", abs_type_inv)]
  51.126 +  end
  51.127 +  handle ERROR =>
  51.128 +    error ("The error(s) above occurred in subtype definition " ^ quote name);
  51.129 +
  51.130 +
  51.131 +(* external interfaces *)
  51.132 +
  51.133 +fun cert_term sg tm =
  51.134 +  cterm_of sg tm handle TERM (msg, _) => error msg;
  51.135 +
  51.136 +fun read_term sg str =
  51.137 +  read_cterm sg (str, termTVar);
  51.138 +
  51.139 +val add_subtype = ext_subtype read_term;
  51.140 +val add_subtype_i = ext_subtype cert_term;
  51.141 +
  51.142 +
  51.143 +end;
  51.144 +
    52.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    52.2 +++ b/src/HOL/thy_syntax.ML	Fri Mar 03 12:02:25 1995 +0100
    52.3 @@ -0,0 +1,187 @@
    52.4 +(*  Title:      HOL/thy_syntax.ML
    52.5 +    ID:         $Id$
    52.6 +    Author:     Markus Wenzel and Lawrence C Paulson and Carsten Clasohm
    52.7 +
    52.8 +Additional theory file sections for HOL.
    52.9 +
   52.10 +TODO:
   52.11 +  move datatype / primrec stuff to pre_datatype.ML (?)
   52.12 +*)
   52.13 +
   52.14 +(*the kind of distinctiveness axioms depends on number of constructors*)
   52.15 +val dtK = 5;  (* FIXME rename?, move? *)
   52.16 +
   52.17 +structure ThySynData: THY_SYN_DATA =
   52.18 +struct
   52.19 +
   52.20 +open ThyParse;
   52.21 +
   52.22 +
   52.23 +(** subtype **)
   52.24 +
   52.25 +fun mk_subtype_decl (((((opt_name, vs), t), mx), rhs), wt) =
   52.26 +  let
   52.27 +    val name' = if_none opt_name t;
   52.28 +    val name = strip_quotes name';
   52.29 +  in
   52.30 +    (cat_lines [name', mk_triple (t, mk_list vs, mx), rhs, wt],
   52.31 +      [name ^ "_def", "Rep_" ^ name, "Rep_" ^ name ^ "_inverse",
   52.32 +        "Abs_" ^ name ^ "_inverse"])
   52.33 +  end;
   52.34 +
   52.35 +val subtype_decl =
   52.36 +  optional ("(" $$-- name --$$ ")" >> Some) None --
   52.37 +  type_args -- name -- opt_infix --$$ "=" -- string -- opt_witness
   52.38 +  >> mk_subtype_decl;
   52.39 +
   52.40 +
   52.41 +
   52.42 +(** (co)inductive **)
   52.43 +
   52.44 +(*co is either "" or "Co"*)
   52.45 +fun inductive_decl co =
   52.46 +  let
   52.47 +    fun mk_intr_name (s, _) =   (*the "op" cancels any infix status*)
   52.48 +      if Syntax.is_identifier s then "op " ^ s else "_";
   52.49 +    fun mk_params (((recs, ipairs), monos), con_defs) =
   52.50 +      let val big_rec_name = space_implode "_" (map (scan_to_id o trim) recs)
   52.51 +          and srec_tms = mk_list recs
   52.52 +          and sintrs   = mk_big_list (map snd ipairs)
   52.53 +          val stri_name = big_rec_name ^ "_Intrnl"
   52.54 +      in
   52.55 +         (";\n\n\
   52.56 +          \structure " ^ stri_name ^ " =\n\
   52.57 +          \ let open Ind_Syntax in\n\
   52.58 +          \  struct\n\
   52.59 +          \  val _ = writeln \"" ^ co ^
   52.60 +                     "Inductive definition " ^ big_rec_name ^ "\"\n\
   52.61 +          \  val rec_tms\t= map (readtm (sign_of thy) termTVar) "
   52.62 +                           ^ srec_tms ^ "\n\
   52.63 +          \  and intr_tms\t= map (readtm (sign_of thy) propT)\n"
   52.64 +                           ^ sintrs ^ "\n\
   52.65 +          \  end\n\
   52.66 +          \ end;\n\n\
   52.67 +          \val thy = thy |> " ^ co ^ "Ind.add_fp_def_i \n    (" ^
   52.68 +             stri_name ^ ".rec_tms, " ^
   52.69 +             stri_name ^ ".intr_tms)"
   52.70 +         ,
   52.71 +          "structure " ^ big_rec_name ^ " =\n\
   52.72 +          \  struct\n\
   52.73 +          \  structure Result = " ^ co ^ "Ind_section_Fun\n\
   52.74 +          \  (open " ^ stri_name ^ "\n\
   52.75 +          \   val thy\t\t= thy\n\
   52.76 +          \   val monos\t\t= " ^ monos ^ "\n\
   52.77 +          \   val con_defs\t\t= " ^ con_defs ^ ");\n\n\
   52.78 +          \  val " ^ mk_list (map mk_intr_name ipairs) ^ " = Result.intrs;\n\
   52.79 +          \  open Result\n\
   52.80 +          \  end\n"
   52.81 +         )
   52.82 +      end
   52.83 +    val ipairs = "intrs" $$-- repeat1 (ident -- !! string)
   52.84 +    fun optstring s = optional (s $$-- string) "\"[]\"" >> trim
   52.85 +  in
   52.86 +    repeat1 string -- ipairs -- optstring "monos" -- optstring "con_defs"
   52.87 +      >> mk_params
   52.88 +  end;
   52.89 +
   52.90 +
   52.91 +
   52.92 +(** datatype **)
   52.93 +
   52.94 +local
   52.95 +  (* FIXME err -> add_datatype *)
   52.96 +  fun mk_cons cs =
   52.97 +    (case duplicates (map (fst o fst) cs) of
   52.98 +      [] => map (fn ((s, ts), syn) => mk_triple (s, mk_list ts, syn)) cs
   52.99 +    | dups => error ("Duplicate constructors: " ^ commas_quote dups));
  52.100 +
  52.101 +  (*generate names of distinctiveness axioms*)
  52.102 +  fun mk_distinct_rules cs tname =
  52.103 +    let
  52.104 +      val uqcs = map (fn ((s, _), _) => strip_quotes s) cs;
  52.105 +      (*combine all constructor names with all others w/o duplicates*)
  52.106 +      fun neg_one c = map (fn c2 => quote (c ^ "_not_" ^ c2));
  52.107 +      fun neg1 [] = []
  52.108 +        | neg1 (c1 :: cs) = neg_one c1 cs @ neg1 cs;
  52.109 +    in
  52.110 +      if length uqcs < dtK then neg1 uqcs
  52.111 +      else quote (tname ^ "_ord_distinct") ::
  52.112 +        map (fn c => quote (tname ^ "_ord_" ^ c)) uqcs
  52.113 +    end;
  52.114 +
  52.115 +  fun mk_rules tname cons pre = " map (get_axiom thy) " ^
  52.116 +    mk_list (map (fn ((s, _), _) => quote (tname ^ pre ^ strip_quotes s)) cons);
  52.117 +
  52.118 +  (*generate string for calling add_datatype*)
  52.119 +  fun mk_params ((ts, tname), cons) =
  52.120 +   ("val (thy, " ^ tname ^ "_add_primrec) = Datatype.add_datatype\n"
  52.121 +    ^ mk_triple (mk_list ts, quote tname, mk_list (mk_cons cons)) ^ " thy\n\
  52.122 +    \val thy = thy",
  52.123 +    "structure " ^ tname ^ " =\n\
  52.124 +    \struct\n\
  52.125 +    \ val inject = map (get_axiom thy) " ^
  52.126 +        mk_list (map (fn ((s, _), _) => quote ("inject_" ^ strip_quotes s))
  52.127 +          (filter_out (null o snd o fst) cons)) ^ ";\n\
  52.128 +    \ val distinct = " ^
  52.129 +        (if length cons < dtK then "let val distinct' = " else "") ^
  52.130 +        "map (get_axiom thy) " ^ mk_list (mk_distinct_rules cons tname) ^
  52.131 +        (if length cons < dtK then
  52.132 +          "  in distinct' @ (map (fn t => sym COMP (t RS contrapos))\
  52.133 +          \ distinct') end"
  52.134 +         else "") ^ ";\n\
  52.135 +    \ val induct = get_axiom thy \"" ^ tname ^ "_induct\";\n\
  52.136 +    \ val cases =" ^ mk_rules tname cons "_case_" ^ ";\n\
  52.137 +    \ val recs =" ^ mk_rules tname cons "_rec_" ^ ";\n\
  52.138 +    \ val simps = inject @ distinct @ cases @ recs;\n\
  52.139 +    \ fun induct_tac a = res_inst_tac [(" ^ quote tname ^ ", a)] induct;\n\
  52.140 +    \end;\n");
  52.141 +
  52.142 +  (*parsers*)
  52.143 +  val tvars = type_args >> map (cat "dtVar");
  52.144 +  val typ =
  52.145 +    tvars -- (ident>>quote) >> (cat "dtTyp" o mk_pair o apfst mk_list) ||
  52.146 +    type_var >> cat "dtVar";
  52.147 +  val opt_typs = optional ("(" $$-- list1 typ --$$ ")") [];
  52.148 +  val constructor = name -- opt_typs -- opt_mixfix;
  52.149 +in
  52.150 +  val datatype_decl =
  52.151 +    (* FIXME tvars -> type_args *)
  52.152 +    tvars -- ident --$$ "=" -- enum1 "|" constructor >> mk_params;
  52.153 +end;
  52.154 +
  52.155 +
  52.156 +
  52.157 +(** primrec **)
  52.158 +
  52.159 +fun mk_primrec_decl ((fname, tname), axms) =
  52.160 +  let
  52.161 +    fun mk_prove (name, eqn) =
  52.162 +      "val " ^ name ^ " = store_thm (" ^ quote name ^ ", prove_goalw thy [get_def thy " 
  52.163 +      ^ fname ^ "] " ^ eqn ^ "\n\
  52.164 +      \  (fn _ => [simp_tac (HOL_ss addsimps " ^ tname ^ ".recs) 1]));";
  52.165 +    val axs = mk_list (map (fn (n, a) => mk_pair (quote n, a)) axms);
  52.166 +  in ("|> " ^ tname ^ "_add_primrec " ^ axs, cat_lines (map mk_prove axms)) end;
  52.167 +
  52.168 +val primrec_decl =
  52.169 +  name -- long_id -- repeat1 (ident -- string) >> mk_primrec_decl;
  52.170 +
  52.171 +
  52.172 +
  52.173 +(** sections **)
  52.174 +
  52.175 +val user_keywords = ["intrs", "monos", "con_defs", "|"];
  52.176 +
  52.177 +val user_sections =
  52.178 + [axm_section "subtype" "|> Subtype.add_subtype" subtype_decl,
  52.179 +  ("inductive", inductive_decl ""),
  52.180 +  ("coinductive", inductive_decl "Co"),
  52.181 +  ("datatype", datatype_decl),
  52.182 +  ("primrec", primrec_decl)];
  52.183 +
  52.184 +
  52.185 +end;
  52.186 +
  52.187 +
  52.188 +structure ThySyn = ThySynFun(ThySynData);
  52.189 +init_thy_reader ();
  52.190 +
    53.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    53.2 +++ b/src/HOL/typedef.ML	Fri Mar 03 12:02:25 1995 +0100
    53.3 @@ -0,0 +1,141 @@
    53.4 +(*  Title:      HOL/subtype.ML
    53.5 +    ID:         $Id$
    53.6 +    Author:     Markus Wenzel, TU Muenchen
    53.7 +
    53.8 +Internal interface for subtype definitions.
    53.9 +*)
   53.10 +
   53.11 +signature SUBTYPE =
   53.12 +sig
   53.13 +  val prove_nonempty: cterm -> thm list -> tactic option -> thm
   53.14 +  val add_subtype: string -> string * string list * mixfix ->
   53.15 +    string -> string list -> thm list -> tactic option -> theory -> theory
   53.16 +  val add_subtype_i: string -> string * string list * mixfix ->
   53.17 +    term -> string list -> thm list -> tactic option -> theory -> theory
   53.18 +end;
   53.19 +
   53.20 +structure Subtype: SUBTYPE =
   53.21 +struct
   53.22 +
   53.23 +open Syntax Logic HOLogic;
   53.24 +
   53.25 +
   53.26 +(* prove non-emptyness of a set *)   (*exception ERROR*)
   53.27 +
   53.28 +val is_def = is_equals o #prop o rep_thm;
   53.29 +
   53.30 +fun prove_nonempty cset thms usr_tac =
   53.31 +  let
   53.32 +    val {T = setT, t = set, maxidx, sign} = rep_cterm cset;
   53.33 +    val T = dest_setT setT;
   53.34 +    val goal =
   53.35 +      cterm_of sign (mk_Trueprop (mk_mem (Var (("x", maxidx + 1), T), set)));
   53.36 +    val tac =
   53.37 +      TRY (rewrite_goals_tac (filter is_def thms)) THEN
   53.38 +      TRY (REPEAT_FIRST (resolve_tac (filter_out is_def thms))) THEN
   53.39 +      if_none usr_tac (TRY (ALLGOALS (fast_tac set_cs)));
   53.40 +  in
   53.41 +    prove_goalw_cterm [] goal (K [tac])
   53.42 +  end
   53.43 +  handle ERROR =>
   53.44 +    error ("Failed to prove non-emptyness of " ^ quote (string_of_cterm cset));
   53.45 +
   53.46 +
   53.47 +(* ext_subtype *)
   53.48 +
   53.49 +fun ext_subtype prep_term name (t, vs, mx) raw_set axms thms usr_tac thy =
   53.50 +  let
   53.51 +    val _ = require_thy thy "Set" "subtype definitions";
   53.52 +    val sign = sign_of thy;
   53.53 +
   53.54 +    (*rhs*)
   53.55 +    val cset = prep_term sign raw_set;
   53.56 +    val {T = setT, t = set, ...} = rep_cterm cset;
   53.57 +    val rhs_tfrees = term_tfrees set;
   53.58 +    val oldT = dest_setT setT handle TYPE _ =>
   53.59 +      error ("Not a set type: " ^ quote (Sign.string_of_typ sign setT));
   53.60 +
   53.61 +    (*lhs*)
   53.62 +    val lhs_tfrees =
   53.63 +      map (fn v => (v, if_none (assoc (rhs_tfrees, v)) termS)) vs;
   53.64 +
   53.65 +    val tname = type_name t mx;
   53.66 +    val tlen = length vs;
   53.67 +    val newT = Type (tname, map TFree lhs_tfrees);
   53.68 +
   53.69 +    val Rep_name = "Rep_" ^ name;
   53.70 +    val Abs_name = "Abs_" ^ name;
   53.71 +    val setC = Const (name, setT);
   53.72 +    val RepC = Const (Rep_name, newT --> oldT);
   53.73 +    val AbsC = Const (Abs_name, oldT --> newT);
   53.74 +    val x_new = Free ("x", newT);
   53.75 +    val y_old = Free ("y", oldT);
   53.76 +
   53.77 +    (*axioms*)
   53.78 +    val rep_type = mk_Trueprop (mk_mem (RepC $ x_new, setC));
   53.79 +    val rep_type_inv = mk_Trueprop (mk_eq (AbsC $ (RepC $ x_new), x_new));
   53.80 +    val abs_type_inv = mk_implies (mk_Trueprop (mk_mem (y_old, setC)),
   53.81 +      mk_Trueprop (mk_eq (RepC $ (AbsC $ y_old), y_old)));
   53.82 +
   53.83 +
   53.84 +    (* errors *)
   53.85 +
   53.86 +    val show_names = commas_quote o map fst;
   53.87 +
   53.88 +    val illegal_vars =
   53.89 +      if null (term_vars set) andalso null (term_tvars set) then []
   53.90 +      else ["Illegal schematic variable(s) on rhs"];
   53.91 +
   53.92 +    val dup_lhs_tfrees =
   53.93 +      (case duplicates lhs_tfrees of [] => []
   53.94 +      | dups => ["Duplicate type variables on lhs: " ^ show_names dups]);
   53.95 +
   53.96 +    val extra_rhs_tfrees =
   53.97 +      (case gen_rems (op =) (rhs_tfrees, lhs_tfrees) of [] => []
   53.98 +      | extras => ["Extra type variables on rhs: " ^ show_names extras]);
   53.99 +
  53.100 +    val illegal_frees =
  53.101 +      (case term_frees set of [] => []
  53.102 +      | xs => ["Illegal variables on rhs: " ^ show_names (map dest_Free xs)]);
  53.103 +
  53.104 +    val errs = illegal_vars @ dup_lhs_tfrees @ extra_rhs_tfrees @ illegal_frees;
  53.105 +  in
  53.106 +    if null errs then ()
  53.107 +    else error (cat_lines errs);
  53.108 +
  53.109 +    prove_nonempty cset (map (get_axiom thy) axms @ thms) usr_tac;
  53.110 +
  53.111 +    thy
  53.112 +    |> add_types [(t, tlen, mx)]
  53.113 +    |> add_arities
  53.114 +     [(tname, replicate tlen logicS, logicS),
  53.115 +      (tname, replicate tlen termS, termS)]
  53.116 +    |> add_consts_i
  53.117 +     [(name, setT, NoSyn),
  53.118 +      (Rep_name, newT --> oldT, NoSyn),
  53.119 +      (Abs_name, oldT --> newT, NoSyn)]
  53.120 +    |> add_defs_i
  53.121 +     [(name ^ "_def", mk_equals (setC, set))]
  53.122 +    |> add_axioms_i
  53.123 +     [(Rep_name, rep_type),
  53.124 +      (Rep_name ^ "_inverse", rep_type_inv),
  53.125 +      (Abs_name ^ "_inverse", abs_type_inv)]
  53.126 +  end
  53.127 +  handle ERROR =>
  53.128 +    error ("The error(s) above occurred in subtype definition " ^ quote name);
  53.129 +
  53.130 +
  53.131 +(* external interfaces *)
  53.132 +
  53.133 +fun cert_term sg tm =
  53.134 +  cterm_of sg tm handle TERM (msg, _) => error msg;
  53.135 +
  53.136 +fun read_term sg str =
  53.137 +  read_cterm sg (str, termTVar);
  53.138 +
  53.139 +val add_subtype = ext_subtype read_term;
  53.140 +val add_subtype_i = ext_subtype cert_term;
  53.141 +
  53.142 +
  53.143 +end;
  53.144 +