*** empty log message ***
authornipkow
Thu Oct 12 18:44:35 2000 +0200 (2000-10-12)
changeset 1021301c2744a3786
parent 10212 33fe2d701ddd
child 10214 77349ed89f45
*** empty log message ***
src/HOL/Arith.ML
src/HOL/Arith.thy
src/HOL/Arithmetic.ML
src/HOL/Arithmetic.thy
src/HOL/Datatype_Universe.ML
src/HOL/Datatype_Universe.thy
src/HOL/Inverse_Image.ML
src/HOL/Inverse_Image.thy
src/HOL/Prod.ML
src/HOL/Prod.thy
src/HOL/Product_Type.ML
src/HOL/Product_Type.thy
src/HOL/RelPow.ML
src/HOL/RelPow.thy
src/HOL/Relation_Power.ML
src/HOL/Relation_Power.thy
src/HOL/Sum.thy
src/HOL/Sum_Type.ML
src/HOL/Sum_Type.thy
src/HOL/Trancl.ML
src/HOL/Trancl.thy
src/HOL/Transitive_Closure.ML
src/HOL/Transitive_Closure.thy
src/HOL/Univ.ML
src/HOL/Univ.thy
src/HOL/Vimage.ML
src/HOL/Vimage.thy
src/HOL/WF.ML
src/HOL/WF.thy
src/HOL/WF_Rel.ML
src/HOL/WF_Rel.thy
src/HOL/Wellfounded_Recursion.ML
src/HOL/Wellfounded_Recursion.thy
src/HOL/Wellfounded_Relations.ML
src/HOL/Wellfounded_Relations.thy
     1.1 --- a/src/HOL/Arith.ML	Thu Oct 12 18:38:23 2000 +0200
     1.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.3 @@ -1,187 +0,0 @@
     1.4 -(*  Title:      HOL/Arith.ML
     1.5 -    ID:         $Id$
     1.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     1.7 -    Copyright   1998  University of Cambridge
     1.8 -
     1.9 -Further proofs about elementary arithmetic, using the arithmetic proof
    1.10 -procedures.
    1.11 -*)
    1.12 -
    1.13 -(*legacy ...*)
    1.14 -structure Arith = struct val thy = the_context () end;
    1.15 -
    1.16 -
    1.17 -Goal "m <= m*(m::nat)";
    1.18 -by (induct_tac "m" 1);
    1.19 -by Auto_tac;
    1.20 -qed "le_square";
    1.21 -
    1.22 -Goal "(m::nat) <= m*(m*m)";
    1.23 -by (induct_tac "m" 1);
    1.24 -by Auto_tac;
    1.25 -qed "le_cube";
    1.26 -
    1.27 -
    1.28 -(*** Subtraction laws -- mostly from Clemens Ballarin ***)
    1.29 -
    1.30 -Goal "[| a < (b::nat); c <= a |] ==> a-c < b-c";
    1.31 -by (arith_tac 1);
    1.32 -qed "diff_less_mono";
    1.33 -
    1.34 -Goal "(i < j-k) = (i+k < (j::nat))";
    1.35 -by (arith_tac 1);
    1.36 -qed "less_diff_conv";
    1.37 -
    1.38 -Goal "(j-k <= (i::nat)) = (j <= i+k)";
    1.39 -by (arith_tac 1);
    1.40 -qed "le_diff_conv";
    1.41 -
    1.42 -Goal "k <= j ==> (i <= j-k) = (i+k <= (j::nat))";
    1.43 -by (arith_tac 1);
    1.44 -qed "le_diff_conv2";
    1.45 -
    1.46 -Goal "Suc i <= n ==> Suc (n - Suc i) = n - i";
    1.47 -by (arith_tac 1);
    1.48 -qed "Suc_diff_Suc";
    1.49 -
    1.50 -Goal "i <= (n::nat) ==> n - (n - i) = i";
    1.51 -by (arith_tac 1);
    1.52 -qed "diff_diff_cancel";
    1.53 -Addsimps [diff_diff_cancel];
    1.54 -
    1.55 -Goal "k <= (n::nat) ==> m <= n + m - k";
    1.56 -by (arith_tac 1);
    1.57 -qed "le_add_diff";
    1.58 -
    1.59 -Goal "m-1 < n ==> m <= n";
    1.60 -by (arith_tac 1);
    1.61 -qed "pred_less_imp_le";
    1.62 -
    1.63 -Goal "j<=i ==> i - j < Suc i - j";
    1.64 -by (arith_tac 1);
    1.65 -qed "diff_less_Suc_diff";
    1.66 -
    1.67 -Goal "i - j <= Suc i - j";
    1.68 -by (arith_tac 1);
    1.69 -qed "diff_le_Suc_diff";
    1.70 -AddIffs [diff_le_Suc_diff];
    1.71 -
    1.72 -Goal "n - Suc i <= n - i";
    1.73 -by (arith_tac 1);
    1.74 -qed "diff_Suc_le_diff";
    1.75 -AddIffs [diff_Suc_le_diff];
    1.76 -
    1.77 -Goal "!!m::nat. 0 < n ==> (m <= n-1) = (m<n)";
    1.78 -by (arith_tac 1);
    1.79 -qed "le_pred_eq";
    1.80 -
    1.81 -Goal "!!m::nat. 0 < n ==> (m-1 < n) = (m<=n)";
    1.82 -by (arith_tac 1);
    1.83 -qed "less_pred_eq";
    1.84 -
    1.85 -(*Replaces the previous diff_less and le_diff_less, which had the stronger
    1.86 -  second premise n<=m*)
    1.87 -Goal "!!m::nat. [| 0<n; 0<m |] ==> m - n < m";
    1.88 -by (arith_tac 1);
    1.89 -qed "diff_less";
    1.90 -
    1.91 -Goal "j <= (k::nat) ==> (j+i)-k = i-(k-j)";
    1.92 -by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
    1.93 -qed "diff_add_assoc_diff";
    1.94 -
    1.95 -
    1.96 -(*** Reducing subtraction to addition ***)
    1.97 -
    1.98 -Goal "n<=(l::nat) --> Suc l - n + m = Suc (l - n + m)";
    1.99 -by (simp_tac (simpset() addsplits [nat_diff_split]) 1);
   1.100 -qed_spec_mp "Suc_diff_add_le";
   1.101 -
   1.102 -Goal "i<n ==> n - Suc i < n - i";
   1.103 -by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   1.104 -qed "diff_Suc_less_diff";
   1.105 -
   1.106 -Goal "Suc(m)-n = (if m<n then 0 else Suc(m-n))";
   1.107 -by (simp_tac (simpset() addsplits [nat_diff_split]) 1);
   1.108 -qed "if_Suc_diff_le";
   1.109 -
   1.110 -Goal "Suc(m)-n <= Suc(m-n)";
   1.111 -by (simp_tac (simpset() addsplits [nat_diff_split]) 1);
   1.112 -qed "diff_Suc_le_Suc_diff";
   1.113 -
   1.114 -(** Simplification of relational expressions involving subtraction **)
   1.115 -
   1.116 -Goal "[| k <= m;  k <= (n::nat) |] ==> ((m-k) - (n-k)) = (m-n)";
   1.117 -by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   1.118 -qed "diff_diff_eq";
   1.119 -
   1.120 -Goal "[| k <= m;  k <= (n::nat) |] ==> (m-k = n-k) = (m=n)";
   1.121 -by (auto_tac (claset(), simpset() addsplits [nat_diff_split]));
   1.122 -qed "eq_diff_iff";
   1.123 -
   1.124 -Goal "[| k <= m;  k <= (n::nat) |] ==> (m-k < n-k) = (m<n)";
   1.125 -by (auto_tac (claset(), simpset() addsplits [nat_diff_split]));
   1.126 -qed "less_diff_iff";
   1.127 -
   1.128 -Goal "[| k <= m;  k <= (n::nat) |] ==> (m-k <= n-k) = (m<=n)";
   1.129 -by (auto_tac (claset(), simpset() addsplits [nat_diff_split]));
   1.130 -qed "le_diff_iff";
   1.131 -
   1.132 -
   1.133 -(** (Anti)Monotonicity of subtraction -- by Stephan Merz **)
   1.134 -
   1.135 -(* Monotonicity of subtraction in first argument *)
   1.136 -Goal "m <= (n::nat) ==> (m-l) <= (n-l)";
   1.137 -by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   1.138 -qed "diff_le_mono";
   1.139 -
   1.140 -Goal "m <= (n::nat) ==> (l-n) <= (l-m)";
   1.141 -by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   1.142 -qed "diff_le_mono2";
   1.143 -
   1.144 -Goal "[| m < (n::nat); m<l |] ==> (l-n) < (l-m)";
   1.145 -by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   1.146 -qed "diff_less_mono2";
   1.147 -
   1.148 -Goal "!!m::nat. [| m-n = 0; n-m = 0 |] ==>  m=n";
   1.149 -by (asm_full_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   1.150 -qed "diffs0_imp_equal";
   1.151 -
   1.152 -(** Lemmas for ex/Factorization **)
   1.153 -
   1.154 -Goal "!!m::nat. [| 1<n; 1<m |] ==> 1<m*n";
   1.155 -by (case_tac "m" 1);
   1.156 -by Auto_tac;
   1.157 -qed "one_less_mult"; 
   1.158 -
   1.159 -Goal "!!m::nat. [| 1<n; 1<m |] ==> n<m*n";
   1.160 -by (case_tac "m" 1);
   1.161 -by Auto_tac;
   1.162 -qed "n_less_m_mult_n"; 
   1.163 -
   1.164 -Goal "!!m::nat. [| 1<n; 1<m |] ==> n<n*m";
   1.165 -by (case_tac "m" 1);
   1.166 -by Auto_tac;
   1.167 -qed "n_less_n_mult_m"; 
   1.168 -
   1.169 -
   1.170 -(** Rewriting to pull differences out **)
   1.171 -
   1.172 -Goal "k<=j --> i - (j - k) = i + (k::nat) - j";
   1.173 -by (arith_tac 1);
   1.174 -qed "diff_diff_right";
   1.175 -
   1.176 -Goal "k <= j ==> m - Suc (j - k) = m + k - Suc j";
   1.177 -by (arith_tac 1);
   1.178 -qed "diff_Suc_diff_eq1"; 
   1.179 -
   1.180 -Goal "k <= j ==> Suc (j - k) - m = Suc j - (k + m)";
   1.181 -by (arith_tac 1);
   1.182 -qed "diff_Suc_diff_eq2"; 
   1.183 -
   1.184 -(*The others are
   1.185 -      i - j - k = i - (j + k),
   1.186 -      k <= j ==> j - k + i = j + i - k,
   1.187 -      k <= j ==> i + (j - k) = i + j - k *)
   1.188 -Addsimps [diff_diff_left, diff_diff_right, diff_add_assoc2 RS sym, 
   1.189 -	  diff_add_assoc RS sym, diff_Suc_diff_eq1, diff_Suc_diff_eq2];
   1.190 -
     2.1 --- a/src/HOL/Arith.thy	Thu Oct 12 18:38:23 2000 +0200
     2.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.3 @@ -1,21 +0,0 @@
     2.4 -(*  Title:      HOL/Arith.thy
     2.5 -    ID:         $Id$
     2.6 -
     2.7 -Setup arithmetic proof procedures.
     2.8 -*)
     2.9 -
    2.10 -theory Arith = Nat
    2.11 -files "arith_data.ML":
    2.12 -
    2.13 -setup arith_setup
    2.14 -
    2.15 -(*elimination of `-' on nat*)
    2.16 -lemma nat_diff_split:
    2.17 -    "P(a - b::nat) = (ALL d. (a<b --> P 0) & (a = b + d --> P d))"
    2.18 -  by (cases "a < b" rule: case_split) (auto simp add: diff_is_0_eq [THEN iffD2])
    2.19 -
    2.20 -ML {* val nat_diff_split = thm "nat_diff_split" *}
    2.21 -
    2.22 -lemmas [arith_split] = nat_diff_split split_min split_max
    2.23 -
    2.24 -end
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/Arithmetic.ML	Thu Oct 12 18:44:35 2000 +0200
     3.3 @@ -0,0 +1,187 @@
     3.4 +(*  Title:      HOL/Arithmetic.ML
     3.5 +    ID:         $Id$
     3.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     3.7 +    Copyright   1998  University of Cambridge
     3.8 +
     3.9 +Further proofs about elementary arithmetic, using the arithmetic proof
    3.10 +procedures.
    3.11 +*)
    3.12 +
    3.13 +(*legacy ...*)
    3.14 +structure Arithmetic = struct val thy = the_context () end;
    3.15 +
    3.16 +
    3.17 +Goal "m <= m*(m::nat)";
    3.18 +by (induct_tac "m" 1);
    3.19 +by Auto_tac;
    3.20 +qed "le_square";
    3.21 +
    3.22 +Goal "(m::nat) <= m*(m*m)";
    3.23 +by (induct_tac "m" 1);
    3.24 +by Auto_tac;
    3.25 +qed "le_cube";
    3.26 +
    3.27 +
    3.28 +(*** Subtraction laws -- mostly from Clemens Ballarin ***)
    3.29 +
    3.30 +Goal "[| a < (b::nat); c <= a |] ==> a-c < b-c";
    3.31 +by (arith_tac 1);
    3.32 +qed "diff_less_mono";
    3.33 +
    3.34 +Goal "(i < j-k) = (i+k < (j::nat))";
    3.35 +by (arith_tac 1);
    3.36 +qed "less_diff_conv";
    3.37 +
    3.38 +Goal "(j-k <= (i::nat)) = (j <= i+k)";
    3.39 +by (arith_tac 1);
    3.40 +qed "le_diff_conv";
    3.41 +
    3.42 +Goal "k <= j ==> (i <= j-k) = (i+k <= (j::nat))";
    3.43 +by (arith_tac 1);
    3.44 +qed "le_diff_conv2";
    3.45 +
    3.46 +Goal "Suc i <= n ==> Suc (n - Suc i) = n - i";
    3.47 +by (arith_tac 1);
    3.48 +qed "Suc_diff_Suc";
    3.49 +
    3.50 +Goal "i <= (n::nat) ==> n - (n - i) = i";
    3.51 +by (arith_tac 1);
    3.52 +qed "diff_diff_cancel";
    3.53 +Addsimps [diff_diff_cancel];
    3.54 +
    3.55 +Goal "k <= (n::nat) ==> m <= n + m - k";
    3.56 +by (arith_tac 1);
    3.57 +qed "le_add_diff";
    3.58 +
    3.59 +Goal "m-1 < n ==> m <= n";
    3.60 +by (arith_tac 1);
    3.61 +qed "pred_less_imp_le";
    3.62 +
    3.63 +Goal "j<=i ==> i - j < Suc i - j";
    3.64 +by (arith_tac 1);
    3.65 +qed "diff_less_Suc_diff";
    3.66 +
    3.67 +Goal "i - j <= Suc i - j";
    3.68 +by (arith_tac 1);
    3.69 +qed "diff_le_Suc_diff";
    3.70 +AddIffs [diff_le_Suc_diff];
    3.71 +
    3.72 +Goal "n - Suc i <= n - i";
    3.73 +by (arith_tac 1);
    3.74 +qed "diff_Suc_le_diff";
    3.75 +AddIffs [diff_Suc_le_diff];
    3.76 +
    3.77 +Goal "!!m::nat. 0 < n ==> (m <= n-1) = (m<n)";
    3.78 +by (arith_tac 1);
    3.79 +qed "le_pred_eq";
    3.80 +
    3.81 +Goal "!!m::nat. 0 < n ==> (m-1 < n) = (m<=n)";
    3.82 +by (arith_tac 1);
    3.83 +qed "less_pred_eq";
    3.84 +
    3.85 +(*Replaces the previous diff_less and le_diff_less, which had the stronger
    3.86 +  second premise n<=m*)
    3.87 +Goal "!!m::nat. [| 0<n; 0<m |] ==> m - n < m";
    3.88 +by (arith_tac 1);
    3.89 +qed "diff_less";
    3.90 +
    3.91 +Goal "j <= (k::nat) ==> (j+i)-k = i-(k-j)";
    3.92 +by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
    3.93 +qed "diff_add_assoc_diff";
    3.94 +
    3.95 +
    3.96 +(*** Reducing subtraction to addition ***)
    3.97 +
    3.98 +Goal "n<=(l::nat) --> Suc l - n + m = Suc (l - n + m)";
    3.99 +by (simp_tac (simpset() addsplits [nat_diff_split]) 1);
   3.100 +qed_spec_mp "Suc_diff_add_le";
   3.101 +
   3.102 +Goal "i<n ==> n - Suc i < n - i";
   3.103 +by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   3.104 +qed "diff_Suc_less_diff";
   3.105 +
   3.106 +Goal "Suc(m)-n = (if m<n then 0 else Suc(m-n))";
   3.107 +by (simp_tac (simpset() addsplits [nat_diff_split]) 1);
   3.108 +qed "if_Suc_diff_le";
   3.109 +
   3.110 +Goal "Suc(m)-n <= Suc(m-n)";
   3.111 +by (simp_tac (simpset() addsplits [nat_diff_split]) 1);
   3.112 +qed "diff_Suc_le_Suc_diff";
   3.113 +
   3.114 +(** Simplification of relational expressions involving subtraction **)
   3.115 +
   3.116 +Goal "[| k <= m;  k <= (n::nat) |] ==> ((m-k) - (n-k)) = (m-n)";
   3.117 +by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   3.118 +qed "diff_diff_eq";
   3.119 +
   3.120 +Goal "[| k <= m;  k <= (n::nat) |] ==> (m-k = n-k) = (m=n)";
   3.121 +by (auto_tac (claset(), simpset() addsplits [nat_diff_split]));
   3.122 +qed "eq_diff_iff";
   3.123 +
   3.124 +Goal "[| k <= m;  k <= (n::nat) |] ==> (m-k < n-k) = (m<n)";
   3.125 +by (auto_tac (claset(), simpset() addsplits [nat_diff_split]));
   3.126 +qed "less_diff_iff";
   3.127 +
   3.128 +Goal "[| k <= m;  k <= (n::nat) |] ==> (m-k <= n-k) = (m<=n)";
   3.129 +by (auto_tac (claset(), simpset() addsplits [nat_diff_split]));
   3.130 +qed "le_diff_iff";
   3.131 +
   3.132 +
   3.133 +(** (Anti)Monotonicity of subtraction -- by Stephan Merz **)
   3.134 +
   3.135 +(* Monotonicity of subtraction in first argument *)
   3.136 +Goal "m <= (n::nat) ==> (m-l) <= (n-l)";
   3.137 +by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   3.138 +qed "diff_le_mono";
   3.139 +
   3.140 +Goal "m <= (n::nat) ==> (l-n) <= (l-m)";
   3.141 +by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   3.142 +qed "diff_le_mono2";
   3.143 +
   3.144 +Goal "[| m < (n::nat); m<l |] ==> (l-n) < (l-m)";
   3.145 +by (asm_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   3.146 +qed "diff_less_mono2";
   3.147 +
   3.148 +Goal "!!m::nat. [| m-n = 0; n-m = 0 |] ==>  m=n";
   3.149 +by (asm_full_simp_tac (simpset() addsplits [nat_diff_split]) 1);
   3.150 +qed "diffs0_imp_equal";
   3.151 +
   3.152 +(** Lemmas for ex/Factorization **)
   3.153 +
   3.154 +Goal "!!m::nat. [| 1<n; 1<m |] ==> 1<m*n";
   3.155 +by (case_tac "m" 1);
   3.156 +by Auto_tac;
   3.157 +qed "one_less_mult"; 
   3.158 +
   3.159 +Goal "!!m::nat. [| 1<n; 1<m |] ==> n<m*n";
   3.160 +by (case_tac "m" 1);
   3.161 +by Auto_tac;
   3.162 +qed "n_less_m_mult_n"; 
   3.163 +
   3.164 +Goal "!!m::nat. [| 1<n; 1<m |] ==> n<n*m";
   3.165 +by (case_tac "m" 1);
   3.166 +by Auto_tac;
   3.167 +qed "n_less_n_mult_m"; 
   3.168 +
   3.169 +
   3.170 +(** Rewriting to pull differences out **)
   3.171 +
   3.172 +Goal "k<=j --> i - (j - k) = i + (k::nat) - j";
   3.173 +by (arith_tac 1);
   3.174 +qed "diff_diff_right";
   3.175 +
   3.176 +Goal "k <= j ==> m - Suc (j - k) = m + k - Suc j";
   3.177 +by (arith_tac 1);
   3.178 +qed "diff_Suc_diff_eq1"; 
   3.179 +
   3.180 +Goal "k <= j ==> Suc (j - k) - m = Suc j - (k + m)";
   3.181 +by (arith_tac 1);
   3.182 +qed "diff_Suc_diff_eq2"; 
   3.183 +
   3.184 +(*The others are
   3.185 +      i - j - k = i - (j + k),
   3.186 +      k <= j ==> j - k + i = j + i - k,
   3.187 +      k <= j ==> i + (j - k) = i + j - k *)
   3.188 +Addsimps [diff_diff_left, diff_diff_right, diff_add_assoc2 RS sym, 
   3.189 +	  diff_add_assoc RS sym, diff_Suc_diff_eq1, diff_Suc_diff_eq2];
   3.190 +
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/HOL/Arithmetic.thy	Thu Oct 12 18:44:35 2000 +0200
     4.3 @@ -0,0 +1,21 @@
     4.4 +(*  Title:      HOL/Arithmetic.thy
     4.5 +    ID:         $Id$
     4.6 +
     4.7 +Setup arithmetic proof procedures.
     4.8 +*)
     4.9 +
    4.10 +theory Arithmetic = Nat
    4.11 +files "arith_data.ML":
    4.12 +
    4.13 +setup arith_setup
    4.14 +
    4.15 +(*elimination of `-' on nat*)
    4.16 +lemma nat_diff_split:
    4.17 +    "P(a - b::nat) = (ALL d. (a<b --> P 0) & (a = b + d --> P d))"
    4.18 +  by (cases "a < b" rule: case_split) (auto simp add: diff_is_0_eq [THEN iffD2])
    4.19 +
    4.20 +ML {* val nat_diff_split = thm "nat_diff_split" *}
    4.21 +
    4.22 +lemmas [arith_split] = nat_diff_split split_min split_max
    4.23 +
    4.24 +end
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Datatype_Universe.ML	Thu Oct 12 18:44:35 2000 +0200
     5.3 @@ -0,0 +1,595 @@
     5.4 +(*  Title:      HOL/Datatype_Universe.ML
     5.5 +    ID:         $Id$
     5.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     5.7 +    Copyright   1991  University of Cambridge
     5.8 +*)
     5.9 +
    5.10 +(** apfst -- can be used in similar type definitions **)
    5.11 +
    5.12 +Goalw [apfst_def] "apfst f (a,b) = (f(a),b)";
    5.13 +by (rtac split 1);
    5.14 +qed "apfst_conv";
    5.15 +
    5.16 +val [major,minor] = Goal
    5.17 +    "[| q = apfst f p;  !!x y. [| p = (x,y);  q = (f(x),y) |] ==> R \
    5.18 +\    |] ==> R";
    5.19 +by (rtac PairE 1);
    5.20 +by (rtac minor 1);
    5.21 +by (assume_tac 1);
    5.22 +by (rtac (major RS trans) 1);
    5.23 +by (etac ssubst 1);
    5.24 +by (rtac apfst_conv 1);
    5.25 +qed "apfst_convE";
    5.26 +
    5.27 +(** Push -- an injection, analogous to Cons on lists **)
    5.28 +
    5.29 +Goalw [Push_def] "Push i f = Push j g  ==> i=j";
    5.30 +by (etac (fun_cong RS box_equals) 1);
    5.31 +by (rtac nat_case_0 1);
    5.32 +by (rtac nat_case_0 1);
    5.33 +qed "Push_inject1";
    5.34 +
    5.35 +Goalw [Push_def] "Push i f = Push j g  ==> f=g";
    5.36 +by (rtac (ext RS box_equals) 1);
    5.37 +by (etac fun_cong 1);
    5.38 +by (rtac (nat_case_Suc RS ext) 1);
    5.39 +by (rtac (nat_case_Suc RS ext) 1);
    5.40 +qed "Push_inject2";
    5.41 +
    5.42 +val [major,minor] = Goal
    5.43 +    "[| Push i f =Push j g;  [| i=j;  f=g |] ==> P \
    5.44 +\    |] ==> P";
    5.45 +by (rtac ((major RS Push_inject2) RS ((major RS Push_inject1) RS minor)) 1);
    5.46 +qed "Push_inject";
    5.47 +
    5.48 +Goalw [Push_def] "Push (Inr (Suc k)) f = (%z. Inr 0) ==> P";
    5.49 +by (rtac Suc_neq_Zero 1);
    5.50 +by (etac (fun_cong RS box_equals RS Inr_inject) 1);
    5.51 +by (rtac nat_case_0 1);
    5.52 +by (rtac refl 1);
    5.53 +qed "Push_neq_K0";
    5.54 +
    5.55 +(*** Isomorphisms ***)
    5.56 +
    5.57 +Goal "inj(Rep_Node)";
    5.58 +by (rtac inj_inverseI 1);       (*cannot combine by RS: multiple unifiers*)
    5.59 +by (rtac Rep_Node_inverse 1);
    5.60 +qed "inj_Rep_Node";
    5.61 +
    5.62 +Goal "inj_on Abs_Node Node";
    5.63 +by (rtac inj_on_inverseI 1);
    5.64 +by (etac Abs_Node_inverse 1);
    5.65 +qed "inj_on_Abs_Node";
    5.66 +
    5.67 +bind_thm ("Abs_Node_inject", inj_on_Abs_Node RS inj_onD);
    5.68 +
    5.69 +
    5.70 +(*** Introduction rules for Node ***)
    5.71 +
    5.72 +Goalw [Node_def] "(%k. Inr 0, a) : Node";
    5.73 +by (Blast_tac 1);
    5.74 +qed "Node_K0_I";
    5.75 +
    5.76 +Goalw [Node_def,Push_def]
    5.77 +    "p: Node ==> apfst (Push i) p : Node";
    5.78 +by (fast_tac (claset() addSIs [apfst_conv, nat_case_Suc RS trans]) 1);
    5.79 +qed "Node_Push_I";
    5.80 +
    5.81 +
    5.82 +(*** Distinctness of constructors ***)
    5.83 +
    5.84 +(** Scons vs Atom **)
    5.85 +
    5.86 +Goalw [Atom_def,Scons_def,Push_Node_def] "Scons M N ~= Atom(a)";
    5.87 +by (rtac notI 1);
    5.88 +by (etac (equalityD2 RS subsetD RS UnE) 1);
    5.89 +by (rtac singletonI 1);
    5.90 +by (REPEAT (eresolve_tac [imageE, Abs_Node_inject RS apfst_convE, 
    5.91 +                          Pair_inject, sym RS Push_neq_K0] 1
    5.92 +     ORELSE resolve_tac [Node_K0_I, Rep_Node RS Node_Push_I] 1));
    5.93 +qed "Scons_not_Atom";
    5.94 +bind_thm ("Atom_not_Scons", Scons_not_Atom RS not_sym);
    5.95 +
    5.96 +
    5.97 +(*** Injectiveness ***)
    5.98 +
    5.99 +(** Atomic nodes **)
   5.100 +
   5.101 +Goalw [Atom_def] "inj(Atom)";
   5.102 +by (blast_tac (claset() addSIs [injI, Node_K0_I] addSDs [Abs_Node_inject]) 1);
   5.103 +qed "inj_Atom";
   5.104 +bind_thm ("Atom_inject", inj_Atom RS injD);
   5.105 +
   5.106 +Goal "(Atom(a)=Atom(b)) = (a=b)";
   5.107 +by (blast_tac (claset() addSDs [Atom_inject]) 1);
   5.108 +qed "Atom_Atom_eq";
   5.109 +AddIffs [Atom_Atom_eq];
   5.110 +
   5.111 +Goalw [Leaf_def,o_def] "inj(Leaf)";
   5.112 +by (rtac injI 1);
   5.113 +by (etac (Atom_inject RS Inl_inject) 1);
   5.114 +qed "inj_Leaf";
   5.115 +
   5.116 +bind_thm ("Leaf_inject", inj_Leaf RS injD);
   5.117 +AddSDs [Leaf_inject];
   5.118 +
   5.119 +Goalw [Numb_def,o_def] "inj(Numb)";
   5.120 +by (rtac injI 1);
   5.121 +by (etac (Atom_inject RS Inr_inject) 1);
   5.122 +qed "inj_Numb";
   5.123 +
   5.124 +bind_thm ("Numb_inject", inj_Numb RS injD);
   5.125 +AddSDs [Numb_inject];
   5.126 +
   5.127 +(** Injectiveness of Push_Node **)
   5.128 +
   5.129 +val [major,minor] = Goalw [Push_Node_def]
   5.130 +    "[| Push_Node i m =Push_Node j n;  [| i=j;  m=n |] ==> P \
   5.131 +\    |] ==> P";
   5.132 +by (rtac (major RS Abs_Node_inject RS apfst_convE) 1);
   5.133 +by (REPEAT (resolve_tac [Rep_Node RS Node_Push_I] 1));
   5.134 +by (etac (sym RS apfst_convE) 1);
   5.135 +by (rtac minor 1);
   5.136 +by (etac Pair_inject 1);
   5.137 +by (etac (Push_inject1 RS sym) 1);
   5.138 +by (rtac (inj_Rep_Node RS injD) 1);
   5.139 +by (etac trans 1);
   5.140 +by (safe_tac (claset() addSEs [Push_inject,sym]));
   5.141 +qed "Push_Node_inject";
   5.142 +
   5.143 +
   5.144 +(** Injectiveness of Scons **)
   5.145 +
   5.146 +Goalw [Scons_def] "Scons M N <= Scons M' N' ==> M<=M'";
   5.147 +by (blast_tac (claset() addSDs [Push_Node_inject]) 1);
   5.148 +qed "Scons_inject_lemma1";
   5.149 +
   5.150 +Goalw [Scons_def] "Scons M N <= Scons M' N' ==> N<=N'";
   5.151 +by (blast_tac (claset() addSDs [Push_Node_inject]) 1);
   5.152 +qed "Scons_inject_lemma2";
   5.153 +
   5.154 +Goal "Scons M N = Scons M' N' ==> M=M'";
   5.155 +by (etac equalityE 1);
   5.156 +by (REPEAT (ares_tac [equalityI, Scons_inject_lemma1] 1));
   5.157 +qed "Scons_inject1";
   5.158 +
   5.159 +Goal "Scons M N = Scons M' N' ==> N=N'";
   5.160 +by (etac equalityE 1);
   5.161 +by (REPEAT (ares_tac [equalityI, Scons_inject_lemma2] 1));
   5.162 +qed "Scons_inject2";
   5.163 +
   5.164 +val [major,minor] = Goal
   5.165 +    "[| Scons M N = Scons M' N';  [| M=M';  N=N' |] ==> P \
   5.166 +\    |] ==> P";
   5.167 +by (rtac ((major RS Scons_inject2) RS ((major RS Scons_inject1) RS minor)) 1);
   5.168 +qed "Scons_inject";
   5.169 +
   5.170 +Goal "(Scons M N = Scons M' N') = (M=M' & N=N')";
   5.171 +by (blast_tac (claset() addSEs [Scons_inject]) 1);
   5.172 +qed "Scons_Scons_eq";
   5.173 +
   5.174 +(*** Distinctness involving Leaf and Numb ***)
   5.175 +
   5.176 +(** Scons vs Leaf **)
   5.177 +
   5.178 +Goalw [Leaf_def,o_def] "Scons M N ~= Leaf(a)";
   5.179 +by (rtac Scons_not_Atom 1);
   5.180 +qed "Scons_not_Leaf";
   5.181 +bind_thm ("Leaf_not_Scons", Scons_not_Leaf RS not_sym);
   5.182 +
   5.183 +AddIffs [Scons_not_Leaf, Leaf_not_Scons];
   5.184 +
   5.185 +
   5.186 +(** Scons vs Numb **)
   5.187 +
   5.188 +Goalw [Numb_def,o_def] "Scons M N ~= Numb(k)";
   5.189 +by (rtac Scons_not_Atom 1);
   5.190 +qed "Scons_not_Numb";
   5.191 +bind_thm ("Numb_not_Scons", Scons_not_Numb RS not_sym);
   5.192 +
   5.193 +AddIffs [Scons_not_Numb, Numb_not_Scons];
   5.194 +
   5.195 +
   5.196 +(** Leaf vs Numb **)
   5.197 +
   5.198 +Goalw [Leaf_def,Numb_def] "Leaf(a) ~= Numb(k)";
   5.199 +by (simp_tac (simpset() addsimps [Inl_not_Inr]) 1);
   5.200 +qed "Leaf_not_Numb";
   5.201 +bind_thm ("Numb_not_Leaf", Leaf_not_Numb RS not_sym);
   5.202 +
   5.203 +AddIffs [Leaf_not_Numb, Numb_not_Leaf];
   5.204 +
   5.205 +
   5.206 +(*** ndepth -- the depth of a node ***)
   5.207 +
   5.208 +Addsimps [apfst_conv];
   5.209 +AddIffs  [Scons_not_Atom, Atom_not_Scons, Scons_Scons_eq];
   5.210 +
   5.211 +
   5.212 +Goalw [ndepth_def] "ndepth (Abs_Node(%k. Inr 0, x)) = 0";
   5.213 +by (EVERY1[stac (Node_K0_I RS Abs_Node_inverse), stac split]);
   5.214 +by (rtac Least_equality 1);
   5.215 +by (rtac refl 1);
   5.216 +by (etac less_zeroE 1);
   5.217 +qed "ndepth_K0";
   5.218 +
   5.219 +Goal "k < Suc(LEAST x. f x = Inr 0) --> nat_case (Inr (Suc i)) f k ~= Inr 0";
   5.220 +by (induct_tac "k" 1);
   5.221 +by (ALLGOALS Simp_tac);
   5.222 +by (rtac impI 1);
   5.223 +by (etac not_less_Least 1);
   5.224 +val lemma = result();
   5.225 +
   5.226 +Goalw [ndepth_def,Push_Node_def]
   5.227 +    "ndepth (Push_Node (Inr (Suc i)) n) = Suc(ndepth(n))";
   5.228 +by (stac (Rep_Node RS Node_Push_I RS Abs_Node_inverse) 1);
   5.229 +by (cut_facts_tac [rewrite_rule [Node_def] Rep_Node] 1);
   5.230 +by Safe_tac;
   5.231 +by (etac ssubst 1);  (*instantiates type variables!*)
   5.232 +by (Simp_tac 1);
   5.233 +by (rtac Least_equality 1);
   5.234 +by (rewtac Push_def);
   5.235 +by (rtac (nat_case_Suc RS trans) 1);
   5.236 +by (etac LeastI 1);
   5.237 +by (asm_simp_tac (simpset() addsimps [lemma]) 1);
   5.238 +qed "ndepth_Push_Node";
   5.239 +
   5.240 +
   5.241 +(*** ntrunc applied to the various node sets ***)
   5.242 +
   5.243 +Goalw [ntrunc_def] "ntrunc 0 M = {}";
   5.244 +by (Blast_tac 1);
   5.245 +qed "ntrunc_0";
   5.246 +
   5.247 +Goalw [Atom_def,ntrunc_def] "ntrunc (Suc k) (Atom a) = Atom(a)";
   5.248 +by (fast_tac (claset() addss (simpset() addsimps [ndepth_K0])) 1);
   5.249 +qed "ntrunc_Atom";
   5.250 +
   5.251 +Goalw [Leaf_def,o_def] "ntrunc (Suc k) (Leaf a) = Leaf(a)";
   5.252 +by (rtac ntrunc_Atom 1);
   5.253 +qed "ntrunc_Leaf";
   5.254 +
   5.255 +Goalw [Numb_def,o_def] "ntrunc (Suc k) (Numb i) = Numb(i)";
   5.256 +by (rtac ntrunc_Atom 1);
   5.257 +qed "ntrunc_Numb";
   5.258 +
   5.259 +Goalw [Scons_def,ntrunc_def]
   5.260 +    "ntrunc (Suc k) (Scons M N) = Scons (ntrunc k M) (ntrunc k N)";
   5.261 +by (safe_tac (claset() addSIs [imageI]));
   5.262 +by (REPEAT (stac ndepth_Push_Node 3 THEN etac Suc_mono 3));
   5.263 +by (REPEAT (rtac Suc_less_SucD 1 THEN 
   5.264 +            rtac (ndepth_Push_Node RS subst) 1 THEN 
   5.265 +            assume_tac 1));
   5.266 +qed "ntrunc_Scons";
   5.267 +
   5.268 +Addsimps [ntrunc_0, ntrunc_Atom, ntrunc_Leaf, ntrunc_Numb, ntrunc_Scons];
   5.269 +
   5.270 +
   5.271 +(** Injection nodes **)
   5.272 +
   5.273 +Goalw [In0_def] "ntrunc 1 (In0 M) = {}";
   5.274 +by (Simp_tac 1);
   5.275 +by (rewtac Scons_def);
   5.276 +by (Blast_tac 1);
   5.277 +qed "ntrunc_one_In0";
   5.278 +
   5.279 +Goalw [In0_def]
   5.280 +    "ntrunc (Suc (Suc k)) (In0 M) = In0 (ntrunc (Suc k) M)";
   5.281 +by (Simp_tac 1);
   5.282 +qed "ntrunc_In0";
   5.283 +
   5.284 +Goalw [In1_def] "ntrunc 1 (In1 M) = {}";
   5.285 +by (Simp_tac 1);
   5.286 +by (rewtac Scons_def);
   5.287 +by (Blast_tac 1);
   5.288 +qed "ntrunc_one_In1";
   5.289 +
   5.290 +Goalw [In1_def]
   5.291 +    "ntrunc (Suc (Suc k)) (In1 M) = In1 (ntrunc (Suc k) M)";
   5.292 +by (Simp_tac 1);
   5.293 +qed "ntrunc_In1";
   5.294 +
   5.295 +Addsimps [ntrunc_one_In0, ntrunc_In0, ntrunc_one_In1, ntrunc_In1];
   5.296 +
   5.297 +
   5.298 +(*** Cartesian Product ***)
   5.299 +
   5.300 +Goalw [uprod_def] "[| M:A;  N:B |] ==> Scons M N : uprod A B";
   5.301 +by (REPEAT (ares_tac [singletonI,UN_I] 1));
   5.302 +qed "uprodI";
   5.303 +
   5.304 +(*The general elimination rule*)
   5.305 +val major::prems = Goalw [uprod_def]
   5.306 +    "[| c : uprod A B;  \
   5.307 +\       !!x y. [| x:A;  y:B;  c = Scons x y |] ==> P \
   5.308 +\    |] ==> P";
   5.309 +by (cut_facts_tac [major] 1);
   5.310 +by (REPEAT (eresolve_tac [asm_rl,singletonE,UN_E] 1
   5.311 +     ORELSE resolve_tac prems 1));
   5.312 +qed "uprodE";
   5.313 +
   5.314 +(*Elimination of a pair -- introduces no eigenvariables*)
   5.315 +val prems = Goal
   5.316 +    "[| Scons M N : uprod A B;      [| M:A;  N:B |] ==> P   \
   5.317 +\    |] ==> P";
   5.318 +by (rtac uprodE 1);
   5.319 +by (REPEAT (ares_tac prems 1 ORELSE eresolve_tac [Scons_inject,ssubst] 1));
   5.320 +qed "uprodE2";
   5.321 +
   5.322 +
   5.323 +(*** Disjoint Sum ***)
   5.324 +
   5.325 +Goalw [usum_def] "M:A ==> In0(M) : usum A B";
   5.326 +by (Blast_tac 1);
   5.327 +qed "usum_In0I";
   5.328 +
   5.329 +Goalw [usum_def] "N:B ==> In1(N) : usum A B";
   5.330 +by (Blast_tac 1);
   5.331 +qed "usum_In1I";
   5.332 +
   5.333 +val major::prems = Goalw [usum_def]
   5.334 +    "[| u : usum A B;  \
   5.335 +\       !!x. [| x:A;  u=In0(x) |] ==> P; \
   5.336 +\       !!y. [| y:B;  u=In1(y) |] ==> P \
   5.337 +\    |] ==> P";
   5.338 +by (rtac (major RS UnE) 1);
   5.339 +by (REPEAT (rtac refl 1 
   5.340 +     ORELSE eresolve_tac (prems@[imageE,ssubst]) 1));
   5.341 +qed "usumE";
   5.342 +
   5.343 +
   5.344 +(** Injection **)
   5.345 +
   5.346 +Goalw [In0_def,In1_def] "In0(M) ~= In1(N)";
   5.347 +by (rtac notI 1);
   5.348 +by (etac (Scons_inject1 RS Numb_inject RS Zero_neq_Suc) 1);
   5.349 +qed "In0_not_In1";
   5.350 +
   5.351 +bind_thm ("In1_not_In0", In0_not_In1 RS not_sym);
   5.352 +
   5.353 +AddIffs [In0_not_In1, In1_not_In0];
   5.354 +
   5.355 +Goalw [In0_def] "In0(M) = In0(N) ==>  M=N";
   5.356 +by (etac (Scons_inject2) 1);
   5.357 +qed "In0_inject";
   5.358 +
   5.359 +Goalw [In1_def] "In1(M) = In1(N) ==>  M=N";
   5.360 +by (etac (Scons_inject2) 1);
   5.361 +qed "In1_inject";
   5.362 +
   5.363 +Goal "(In0 M = In0 N) = (M=N)";
   5.364 +by (blast_tac (claset() addSDs [In0_inject]) 1);
   5.365 +qed "In0_eq";
   5.366 +
   5.367 +Goal "(In1 M = In1 N) = (M=N)";
   5.368 +by (blast_tac (claset() addSDs [In1_inject]) 1);
   5.369 +qed "In1_eq";
   5.370 +
   5.371 +AddIffs [In0_eq, In1_eq];
   5.372 +
   5.373 +Goal "inj In0";
   5.374 +by (blast_tac (claset() addSIs [injI]) 1);
   5.375 +qed "inj_In0";
   5.376 +
   5.377 +Goal "inj In1";
   5.378 +by (blast_tac (claset() addSIs [injI]) 1);
   5.379 +qed "inj_In1";
   5.380 +
   5.381 +
   5.382 +(*** Function spaces ***)
   5.383 +
   5.384 +Goalw [Lim_def] "Lim f = Lim g ==> f = g";
   5.385 +by (rtac ext 1);
   5.386 +by (blast_tac (claset() addSEs [Push_Node_inject]) 1);
   5.387 +qed "Lim_inject";
   5.388 +
   5.389 +Goalw [Funs_def] "S <= T ==> Funs S <= Funs T";
   5.390 +by (Blast_tac 1);
   5.391 +qed "Funs_mono";
   5.392 +
   5.393 +val [prem] = Goalw [Funs_def] "(!!x. f x : S) ==> f : Funs S";
   5.394 +by (blast_tac (claset() addIs [prem]) 1);
   5.395 +qed "FunsI";
   5.396 +
   5.397 +Goalw [Funs_def] "f : Funs S ==> f x : S";
   5.398 +by (etac CollectE 1);
   5.399 +by (etac subsetD 1);
   5.400 +by (rtac rangeI 1);
   5.401 +qed "FunsD";
   5.402 +
   5.403 +val [p1, p2] = Goalw [o_def]
   5.404 +   "[| f : Funs R; !!x. x : R ==> r (a x) = x |] ==> r o (a o f) = f";
   5.405 +by (rtac (p2 RS ext) 1);
   5.406 +by (rtac (p1 RS FunsD) 1);
   5.407 +qed "Funs_inv";
   5.408 +
   5.409 +val [p1, p2] = Goalw [o_def]
   5.410 +     "[| f : Funs (range g); !!h. f = g o h ==> P |] ==> P";
   5.411 +by (res_inst_tac [("h", "%x. @y. (f::'a=>'b) x = g y")] p2 1);
   5.412 +by (rtac ext 1);
   5.413 +by (rtac (p1 RS FunsD RS rangeE) 1);
   5.414 +by (etac (exI RS (some_eq_ex RS iffD2)) 1);
   5.415 +qed "Funs_rangeE";
   5.416 +
   5.417 +Goal "a : S ==> (%x. a) : Funs S";
   5.418 +by (rtac FunsI 1);
   5.419 +by (assume_tac 1);
   5.420 +qed "Funs_nonempty";
   5.421 +
   5.422 +
   5.423 +(*** proving equality of sets and functions using ntrunc ***)
   5.424 +
   5.425 +Goalw [ntrunc_def] "ntrunc k M <= M";
   5.426 +by (Blast_tac 1);
   5.427 +qed "ntrunc_subsetI";
   5.428 +
   5.429 +val [major] = Goalw [ntrunc_def] "(!!k. ntrunc k M <= N) ==> M<=N";
   5.430 +by (blast_tac (claset() addIs [less_add_Suc1, less_add_Suc2, 
   5.431 +			       major RS subsetD]) 1);
   5.432 +qed "ntrunc_subsetD";
   5.433 +
   5.434 +(*A generalized form of the take-lemma*)
   5.435 +val [major] = Goal "(!!k. ntrunc k M = ntrunc k N) ==> M=N";
   5.436 +by (rtac equalityI 1);
   5.437 +by (ALLGOALS (rtac ntrunc_subsetD));
   5.438 +by (ALLGOALS (rtac (ntrunc_subsetI RSN (2, subset_trans))));
   5.439 +by (rtac (major RS equalityD1) 1);
   5.440 +by (rtac (major RS equalityD2) 1);
   5.441 +qed "ntrunc_equality";
   5.442 +
   5.443 +val [major] = Goalw [o_def]
   5.444 +    "[| !!k. (ntrunc(k) o h1) = (ntrunc(k) o h2) |] ==> h1=h2";
   5.445 +by (rtac (ntrunc_equality RS ext) 1);
   5.446 +by (rtac (major RS fun_cong) 1);
   5.447 +qed "ntrunc_o_equality";
   5.448 +
   5.449 +(*** Monotonicity ***)
   5.450 +
   5.451 +Goalw [uprod_def] "[| A<=A';  B<=B' |] ==> uprod A B <= uprod A' B'";
   5.452 +by (Blast_tac 1);
   5.453 +qed "uprod_mono";
   5.454 +
   5.455 +Goalw [usum_def] "[| A<=A';  B<=B' |] ==> usum A B <= usum A' B'";
   5.456 +by (Blast_tac 1);
   5.457 +qed "usum_mono";
   5.458 +
   5.459 +Goalw [Scons_def] "[| M<=M';  N<=N' |] ==> Scons M N <= Scons M' N'";
   5.460 +by (Blast_tac 1);
   5.461 +qed "Scons_mono";
   5.462 +
   5.463 +Goalw [In0_def] "M<=N ==> In0(M) <= In0(N)";
   5.464 +by (REPEAT (ares_tac [subset_refl,Scons_mono] 1));
   5.465 +qed "In0_mono";
   5.466 +
   5.467 +Goalw [In1_def] "M<=N ==> In1(M) <= In1(N)";
   5.468 +by (REPEAT (ares_tac [subset_refl,Scons_mono] 1));
   5.469 +qed "In1_mono";
   5.470 +
   5.471 +
   5.472 +(*** Split and Case ***)
   5.473 +
   5.474 +Goalw [Split_def] "Split c (Scons M N) = c M N";
   5.475 +by (Blast_tac  1);
   5.476 +qed "Split";
   5.477 +
   5.478 +Goalw [Case_def] "Case c d (In0 M) = c(M)";
   5.479 +by (Blast_tac 1);
   5.480 +qed "Case_In0";
   5.481 +
   5.482 +Goalw [Case_def] "Case c d (In1 N) = d(N)";
   5.483 +by (Blast_tac 1);
   5.484 +qed "Case_In1";
   5.485 +
   5.486 +Addsimps [Split, Case_In0, Case_In1];
   5.487 +
   5.488 +
   5.489 +(**** UN x. B(x) rules ****)
   5.490 +
   5.491 +Goalw [ntrunc_def] "ntrunc k (UN x. f(x)) = (UN x. ntrunc k (f x))";
   5.492 +by (Blast_tac 1);
   5.493 +qed "ntrunc_UN1";
   5.494 +
   5.495 +Goalw [Scons_def] "Scons (UN x. f x) M = (UN x. Scons (f x) M)";
   5.496 +by (Blast_tac 1);
   5.497 +qed "Scons_UN1_x";
   5.498 +
   5.499 +Goalw [Scons_def] "Scons M (UN x. f x) = (UN x. Scons M (f x))";
   5.500 +by (Blast_tac 1);
   5.501 +qed "Scons_UN1_y";
   5.502 +
   5.503 +Goalw [In0_def] "In0(UN x. f(x)) = (UN x. In0(f(x)))";
   5.504 +by (rtac Scons_UN1_y 1);
   5.505 +qed "In0_UN1";
   5.506 +
   5.507 +Goalw [In1_def] "In1(UN x. f(x)) = (UN x. In1(f(x)))";
   5.508 +by (rtac Scons_UN1_y 1);
   5.509 +qed "In1_UN1";
   5.510 +
   5.511 +
   5.512 +(*** Equality for Cartesian Product ***)
   5.513 +
   5.514 +Goalw [dprod_def]
   5.515 +    "[| (M,M'):r;  (N,N'):s |] ==> (Scons M N, Scons M' N') : dprod r s";
   5.516 +by (Blast_tac 1);
   5.517 +qed "dprodI";
   5.518 +
   5.519 +(*The general elimination rule*)
   5.520 +val major::prems = Goalw [dprod_def]
   5.521 +    "[| c : dprod r s;  \
   5.522 +\       !!x y x' y'. [| (x,x') : r;  (y,y') : s;  c = (Scons x y, Scons x' y') |] ==> P \
   5.523 +\    |] ==> P";
   5.524 +by (cut_facts_tac [major] 1);
   5.525 +by (REPEAT_FIRST (eresolve_tac [asm_rl, UN_E, mem_splitE, singletonE]));
   5.526 +by (REPEAT (ares_tac prems 1 ORELSE hyp_subst_tac 1));
   5.527 +qed "dprodE";
   5.528 +
   5.529 +
   5.530 +(*** Equality for Disjoint Sum ***)
   5.531 +
   5.532 +Goalw [dsum_def]  "(M,M'):r ==> (In0(M), In0(M')) : dsum r s";
   5.533 +by (Blast_tac 1);
   5.534 +qed "dsum_In0I";
   5.535 +
   5.536 +Goalw [dsum_def]  "(N,N'):s ==> (In1(N), In1(N')) : dsum r s";
   5.537 +by (Blast_tac 1);
   5.538 +qed "dsum_In1I";
   5.539 +
   5.540 +val major::prems = Goalw [dsum_def]
   5.541 +    "[| w : dsum r s;  \
   5.542 +\       !!x x'. [| (x,x') : r;  w = (In0(x), In0(x')) |] ==> P; \
   5.543 +\       !!y y'. [| (y,y') : s;  w = (In1(y), In1(y')) |] ==> P \
   5.544 +\    |] ==> P";
   5.545 +by (cut_facts_tac [major] 1);
   5.546 +by (REPEAT_FIRST (eresolve_tac [asm_rl, UN_E, UnE, mem_splitE, singletonE]));
   5.547 +by (DEPTH_SOLVE (ares_tac prems 1 ORELSE hyp_subst_tac 1));
   5.548 +qed "dsumE";
   5.549 +
   5.550 +AddSIs [uprodI, dprodI];
   5.551 +AddIs  [usum_In0I, usum_In1I, dsum_In0I, dsum_In1I];
   5.552 +AddSEs [uprodE, dprodE, usumE, dsumE];
   5.553 +
   5.554 +
   5.555 +(*** Monotonicity ***)
   5.556 +
   5.557 +Goal "[| r<=r';  s<=s' |] ==> dprod r s <= dprod r' s'";
   5.558 +by (Blast_tac 1);
   5.559 +qed "dprod_mono";
   5.560 +
   5.561 +Goal "[| r<=r';  s<=s' |] ==> dsum r s <= dsum r' s'";
   5.562 +by (Blast_tac 1);
   5.563 +qed "dsum_mono";
   5.564 +
   5.565 +
   5.566 +(*** Bounding theorems ***)
   5.567 +
   5.568 +Goal "(dprod (A <*> B) (C <*> D)) <= (uprod A C) <*> (uprod B D)";
   5.569 +by (Blast_tac 1);
   5.570 +qed "dprod_Sigma";
   5.571 +
   5.572 +bind_thm ("dprod_subset_Sigma", [dprod_mono, dprod_Sigma] MRS subset_trans |> standard);
   5.573 +
   5.574 +(*Dependent version*)
   5.575 +Goal "(dprod (Sigma A B) (Sigma C D)) <= Sigma (uprod A C) (Split (%x y. uprod (B x) (D y)))";
   5.576 +by Safe_tac;
   5.577 +by (stac Split 1);
   5.578 +by (Blast_tac 1);
   5.579 +qed "dprod_subset_Sigma2";
   5.580 +
   5.581 +Goal "(dsum (A <*> B) (C <*> D)) <= (usum A C) <*> (usum B D)";
   5.582 +by (Blast_tac 1);
   5.583 +qed "dsum_Sigma";
   5.584 +
   5.585 +bind_thm ("dsum_subset_Sigma", [dsum_mono, dsum_Sigma] MRS subset_trans |> standard);
   5.586 +
   5.587 +
   5.588 +(*** Domain ***)
   5.589 +
   5.590 +Goal "Domain (dprod r s) = uprod (Domain r) (Domain s)";
   5.591 +by Auto_tac;
   5.592 +qed "Domain_dprod";
   5.593 +
   5.594 +Goal "Domain (dsum r s) = usum (Domain r) (Domain s)";
   5.595 +by Auto_tac;
   5.596 +qed "Domain_dsum";
   5.597 +
   5.598 +Addsimps [Domain_dprod, Domain_dsum];
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Datatype_Universe.thy	Thu Oct 12 18:44:35 2000 +0200
     6.3 @@ -0,0 +1,102 @@
     6.4 +(*  Title:      HOL/Datatype_Universe.thy
     6.5 +    ID:         $Id$
     6.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     6.7 +    Copyright   1993  University of Cambridge
     6.8 +
     6.9 +Declares the type ('a, 'b) node, a subtype of (nat=>'b+nat) * ('a+nat)
    6.10 +
    6.11 +Defines "Cartesian Product" and "Disjoint Sum" as set operations.
    6.12 +Could <*> be generalized to a general summation (Sigma)?
    6.13 +*)
    6.14 +
    6.15 +Datatype_Universe = Arithmetic + Sum_Type +
    6.16 +
    6.17 +
    6.18 +(** lists, trees will be sets of nodes **)
    6.19 +
    6.20 +typedef (Node)
    6.21 +  ('a, 'b) node = "{p. EX f x k. p = (f::nat=>'b+nat, x::'a+nat) & f k = Inr 0}"
    6.22 +
    6.23 +types
    6.24 +  'a item = ('a, unit) node set
    6.25 +  ('a, 'b) dtree = ('a, 'b) node set
    6.26 +
    6.27 +consts
    6.28 +  apfst     :: "['a=>'c, 'a*'b] => 'c*'b"
    6.29 +  Push      :: "[('b + nat), nat => ('b + nat)] => (nat => ('b + nat))"
    6.30 +
    6.31 +  Push_Node :: "[('b + nat), ('a, 'b) node] => ('a, 'b) node"
    6.32 +  ndepth    :: ('a, 'b) node => nat
    6.33 +
    6.34 +  Atom      :: "('a + nat) => ('a, 'b) dtree"
    6.35 +  Leaf      :: 'a => ('a, 'b) dtree
    6.36 +  Numb      :: nat => ('a, 'b) dtree
    6.37 +  Scons     :: [('a, 'b) dtree, ('a, 'b) dtree] => ('a, 'b) dtree
    6.38 +  In0,In1   :: ('a, 'b) dtree => ('a, 'b) dtree
    6.39 +
    6.40 +  Lim       :: ('b => ('a, 'b) dtree) => ('a, 'b) dtree
    6.41 +  Funs      :: "'u set => ('t => 'u) set"
    6.42 +
    6.43 +  ntrunc    :: [nat, ('a, 'b) dtree] => ('a, 'b) dtree
    6.44 +
    6.45 +  uprod     :: [('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set
    6.46 +  usum      :: [('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set
    6.47 +
    6.48 +  Split     :: [[('a, 'b) dtree, ('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c
    6.49 +  Case      :: [[('a, 'b) dtree]=>'c, [('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c
    6.50 +
    6.51 +  dprod     :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set] 
    6.52 +                => (('a, 'b) dtree * ('a, 'b) dtree)set"
    6.53 +  dsum      :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set] 
    6.54 +                => (('a, 'b) dtree * ('a, 'b) dtree)set"
    6.55 +
    6.56 +
    6.57 +defs
    6.58 +
    6.59 +  Push_Node_def  "Push_Node == (%n x. Abs_Node (apfst (Push n) (Rep_Node x)))"
    6.60 +
    6.61 +  (*crude "lists" of nats -- needed for the constructions*)
    6.62 +  apfst_def  "apfst == (%f (x,y). (f(x),y))"
    6.63 +  Push_def   "Push == (%b h. nat_case b h)"
    6.64 +
    6.65 +  (** operations on S-expressions -- sets of nodes **)
    6.66 +
    6.67 +  (*S-expression constructors*)
    6.68 +  Atom_def   "Atom == (%x. {Abs_Node((%k. Inr 0, x))})"
    6.69 +  Scons_def  "Scons M N == (Push_Node (Inr 1) `` M) Un (Push_Node (Inr 2) `` N)"
    6.70 +
    6.71 +  (*Leaf nodes, with arbitrary or nat labels*)
    6.72 +  Leaf_def   "Leaf == Atom o Inl"
    6.73 +  Numb_def   "Numb == Atom o Inr"
    6.74 +
    6.75 +  (*Injections of the "disjoint sum"*)
    6.76 +  In0_def    "In0(M) == Scons (Numb 0) M"
    6.77 +  In1_def    "In1(M) == Scons (Numb 1) M"
    6.78 +
    6.79 +  (*Function spaces*)
    6.80 +  Lim_def "Lim f == Union {z. ? x. z = Push_Node (Inl x) `` (f x)}"
    6.81 +  Funs_def "Funs S == {f. range f <= S}"
    6.82 +
    6.83 +  (*the set of nodes with depth less than k*)
    6.84 +  ndepth_def "ndepth(n) == (%(f,x). LEAST k. f k = Inr 0) (Rep_Node n)"
    6.85 +  ntrunc_def "ntrunc k N == {n. n:N & ndepth(n)<k}"
    6.86 +
    6.87 +  (*products and sums for the "universe"*)
    6.88 +  uprod_def  "uprod A B == UN x:A. UN y:B. { Scons x y }"
    6.89 +  usum_def   "usum A B == In0``A Un In1``B"
    6.90 +
    6.91 +  (*the corresponding eliminators*)
    6.92 +  Split_def  "Split c M == @u. ? x y. M = Scons x y & u = c x y"
    6.93 +
    6.94 +  Case_def   "Case c d M == @u.  (? x . M = In0(x) & u = c(x)) 
    6.95 +                               | (? y . M = In1(y) & u = d(y))"
    6.96 +
    6.97 +
    6.98 +  (** equality for the "universe" **)
    6.99 +
   6.100 +  dprod_def  "dprod r s == UN (x,x'):r. UN (y,y'):s. {(Scons x y, Scons x' y')}"
   6.101 +
   6.102 +  dsum_def   "dsum r s == (UN (x,x'):r. {(In0(x),In0(x'))}) Un 
   6.103 +                          (UN (y,y'):s. {(In1(y),In1(y'))})"
   6.104 +
   6.105 +end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Inverse_Image.ML	Thu Oct 12 18:44:35 2000 +0200
     7.3 @@ -0,0 +1,108 @@
     7.4 +(*  Title:      HOL/Inverse_Image.ML
     7.5 +    ID:         $Id$
     7.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     7.7 +    Copyright   1998  University of Cambridge
     7.8 +
     7.9 +Inverse image of a function
    7.10 +*)
    7.11 +
    7.12 +(** Basic rules **)
    7.13 +
    7.14 +Goalw [vimage_def] "(a : f-``B) = (f a : B)";
    7.15 +by (Blast_tac 1) ;
    7.16 +qed "vimage_eq";
    7.17 +
    7.18 +Addsimps [vimage_eq];
    7.19 +
    7.20 +Goal "(a : f-``{b}) = (f a = b)";
    7.21 +by (simp_tac (simpset() addsimps [vimage_eq]) 1) ;
    7.22 +qed "vimage_singleton_eq";
    7.23 +
    7.24 +Goalw [vimage_def]
    7.25 +    "!!A B f. [| f a = b;  b:B |] ==> a : f-``B";
    7.26 +by (Blast_tac 1) ;
    7.27 +qed "vimageI";
    7.28 +
    7.29 +Goalw [vimage_def] "f a : A ==> a : f -`` A";
    7.30 +by (Fast_tac 1);
    7.31 +qed "vimageI2";
    7.32 +
    7.33 +val major::prems = Goalw [vimage_def]
    7.34 +    "[| a: f-``B;  !!x.[| f a = x;  x:B |] ==> P |] ==> P";
    7.35 +by (rtac (major RS CollectE) 1);
    7.36 +by (blast_tac (claset() addIs prems) 1) ;
    7.37 +qed "vimageE";
    7.38 +
    7.39 +Goalw [vimage_def] "a : f -`` A ==> f a : A";
    7.40 +by (Fast_tac 1);
    7.41 +qed "vimageD";
    7.42 +
    7.43 +AddIs  [vimageI];
    7.44 +AddSEs [vimageE];
    7.45 +
    7.46 +
    7.47 +(*** Equations ***)
    7.48 +
    7.49 +Goal "f-``{} = {}";
    7.50 +by (Blast_tac 1);
    7.51 +qed "vimage_empty";
    7.52 +
    7.53 +Goal "f-``(-A) = -(f-``A)";
    7.54 +by (Blast_tac 1);
    7.55 +qed "vimage_Compl";
    7.56 +
    7.57 +Goal "f-``(A Un B) = (f-``A) Un (f-``B)";
    7.58 +by (Blast_tac 1);
    7.59 +qed "vimage_Un";
    7.60 +
    7.61 +Goal "f -`` (A Int B) = (f -`` A) Int (f -`` B)";
    7.62 +by (Fast_tac 1);
    7.63 +qed "vimage_Int";
    7.64 +
    7.65 +Goal "f -`` (Union A) = (UN X:A. f -`` X)";
    7.66 +by (Blast_tac 1);
    7.67 +qed "vimage_Union";
    7.68 +
    7.69 +Goal "f-``(UN x:A. B x) = (UN x:A. f -`` B x)";
    7.70 +by (Blast_tac 1);
    7.71 +qed "vimage_UN";
    7.72 +
    7.73 +Goal "f-``(INT x:A. B x) = (INT x:A. f -`` B x)";
    7.74 +by (Blast_tac 1);
    7.75 +qed "vimage_INT";
    7.76 +
    7.77 +Goal "f -`` Collect P = {y. P (f y)}";
    7.78 +by (Blast_tac 1);
    7.79 +qed "vimage_Collect_eq";
    7.80 +Addsimps [vimage_Collect_eq];
    7.81 +
    7.82 +(*A strange result used in Tools/inductive_package*)
    7.83 +val prems = Goal "(!!x. P (f x) = Q x) ==> f -`` (Collect P) = Collect Q";
    7.84 +by (force_tac (claset(), simpset() addsimps prems) 1);
    7.85 +qed "vimage_Collect";
    7.86 +
    7.87 +Addsimps [vimage_empty, vimage_Un, vimage_Int];
    7.88 +
    7.89 +(*NOT suitable for rewriting because of the recurrence of {a}*)
    7.90 +Goal "f-``(insert a B) = (f-``{a}) Un (f-``B)";
    7.91 +by (Blast_tac 1);
    7.92 +qed "vimage_insert";
    7.93 +
    7.94 +Goal "f-``(A-B) = (f-``A) - (f-``B)";
    7.95 +by (Blast_tac 1);
    7.96 +qed "vimage_Diff";
    7.97 +
    7.98 +Goal "f-``UNIV = UNIV";
    7.99 +by (Blast_tac 1);
   7.100 +qed "vimage_UNIV";
   7.101 +Addsimps [vimage_UNIV];
   7.102 +
   7.103 +(*NOT suitable for rewriting*)
   7.104 +Goal "f-``B = (UN y: B. f-``{y})";
   7.105 +by (Blast_tac 1);
   7.106 +qed "vimage_eq_UN";
   7.107 +
   7.108 +(*monotonicity*)
   7.109 +Goal "A<=B ==> f-``A <= f-``B";
   7.110 +by (Blast_tac 1);
   7.111 +qed "vimage_mono";
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Inverse_Image.thy	Thu Oct 12 18:44:35 2000 +0200
     8.3 @@ -0,0 +1,15 @@
     8.4 +(*  Title:      HOL/Inverse_Image.thy
     8.5 +    ID:         $Id$
     8.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     8.7 +    Copyright   1998  University of Cambridge
     8.8 +
     8.9 +Inverse image of a function
    8.10 +*)
    8.11 +
    8.12 +Inverse_Image = Set +
    8.13 +
    8.14 +constdefs
    8.15 +  vimage :: ['a => 'b, 'b set] => ('a set)   (infixr "-``" 90)
    8.16 +    "f-``B  == {x. f(x) : B}"
    8.17 +
    8.18 +end
     9.1 --- a/src/HOL/Prod.ML	Thu Oct 12 18:38:23 2000 +0200
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,602 +0,0 @@
     9.4 -(*  Title:      HOL/prod
     9.5 -    ID:         $Id$
     9.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     9.7 -    Copyright   1991  University of Cambridge
     9.8 -
     9.9 -Ordered Pairs, the Cartesian product type, the unit type
    9.10 -*)
    9.11 -
    9.12 -(** unit **)
    9.13 -
    9.14 -Goalw [Unity_def]
    9.15 -    "u = ()";
    9.16 -by (stac (rewrite_rule [unit_def] Rep_unit RS singletonD RS sym) 1);
    9.17 -by (rtac (Rep_unit_inverse RS sym) 1);
    9.18 -qed "unit_eq";
    9.19 -
    9.20 -(*simplification procedure for unit_eq.
    9.21 -  Cannot use this rule directly -- it loops!*)
    9.22 -local
    9.23 -  val unit_pat = Thm.cterm_of (Theory.sign_of (the_context ())) (Free ("x", HOLogic.unitT));
    9.24 -  val unit_meta_eq = standard (mk_meta_eq unit_eq);
    9.25 -  fun proc _ _ t =
    9.26 -    if HOLogic.is_unit t then None
    9.27 -    else Some unit_meta_eq;
    9.28 -in
    9.29 -  val unit_eq_proc = Simplifier.mk_simproc "unit_eq" [unit_pat] proc;
    9.30 -end;
    9.31 -
    9.32 -Addsimprocs [unit_eq_proc];
    9.33 -
    9.34 -Goal "(!!x::unit. PROP P x) == PROP P ()";
    9.35 -by (Simp_tac 1);
    9.36 -qed "unit_all_eq1";
    9.37 -
    9.38 -Goal "(!!x::unit. PROP P) == PROP P";
    9.39 -by (rtac triv_forall_equality 1);
    9.40 -qed "unit_all_eq2";
    9.41 -
    9.42 -Goal "P () ==> P x";
    9.43 -by (Simp_tac 1);
    9.44 -qed "unit_induct";
    9.45 -
    9.46 -(*This rewrite counters the effect of unit_eq_proc on (%u::unit. f u),
    9.47 -  replacing it by f rather than by %u.f(). *)
    9.48 -Goal "(%u::unit. f()) = f";
    9.49 -by (rtac ext 1);
    9.50 -by (Simp_tac 1);
    9.51 -qed "unit_abs_eta_conv";
    9.52 -Addsimps [unit_abs_eta_conv];
    9.53 -
    9.54 -
    9.55 -(** prod **)
    9.56 -
    9.57 -Goalw [Prod_def] "Pair_Rep a b : Prod";
    9.58 -by (EVERY1 [rtac CollectI, rtac exI, rtac exI, rtac refl]);
    9.59 -qed "ProdI";
    9.60 -
    9.61 -Goalw [Pair_Rep_def] "Pair_Rep a b = Pair_Rep a' b' ==> a=a' & b=b'";
    9.62 -by (dtac (fun_cong RS fun_cong) 1);
    9.63 -by (Blast_tac 1);
    9.64 -qed "Pair_Rep_inject";
    9.65 -
    9.66 -Goal "inj_on Abs_Prod Prod";
    9.67 -by (rtac inj_on_inverseI 1);
    9.68 -by (etac Abs_Prod_inverse 1);
    9.69 -qed "inj_on_Abs_Prod";
    9.70 -
    9.71 -val prems = Goalw [Pair_def]
    9.72 -    "[| (a, b) = (a',b');  [| a=a';  b=b' |] ==> R |] ==> R";
    9.73 -by (rtac (inj_on_Abs_Prod RS inj_onD RS Pair_Rep_inject RS conjE) 1);
    9.74 -by (REPEAT (ares_tac (prems@[ProdI]) 1));
    9.75 -qed "Pair_inject";
    9.76 -
    9.77 -Goal "((a,b) = (a',b')) = (a=a' & b=b')";
    9.78 -by (blast_tac (claset() addSEs [Pair_inject]) 1);
    9.79 -qed "Pair_eq";
    9.80 -AddIffs [Pair_eq];
    9.81 -
    9.82 -Goalw [fst_def] "fst (a,b) = a";
    9.83 -by (Blast_tac 1);
    9.84 -qed "fst_conv";
    9.85 -Goalw [snd_def] "snd (a,b) = b";
    9.86 -by (Blast_tac 1);
    9.87 -qed "snd_conv";
    9.88 -Addsimps [fst_conv, snd_conv];
    9.89 -
    9.90 -Goal "fst (x, y) = a ==> x = a";
    9.91 -by (Asm_full_simp_tac 1);
    9.92 -qed "fst_eqD";
    9.93 -Goal "snd (x, y) = a ==> y = a";
    9.94 -by (Asm_full_simp_tac 1);
    9.95 -qed "snd_eqD";
    9.96 -
    9.97 -Goalw [Pair_def] "? x y. p = (x,y)";
    9.98 -by (rtac (rewrite_rule [Prod_def] Rep_Prod RS CollectE) 1);
    9.99 -by (EVERY1[etac exE, etac exE, rtac exI, rtac exI,
   9.100 -           rtac (Rep_Prod_inverse RS sym RS trans),  etac arg_cong]);
   9.101 -qed "PairE_lemma";
   9.102 -
   9.103 -val [prem] = Goal "[| !!x y. p = (x,y) ==> Q |] ==> Q";
   9.104 -by (rtac (PairE_lemma RS exE) 1);
   9.105 -by (REPEAT (eresolve_tac [prem,exE] 1));
   9.106 -qed "PairE";
   9.107 -
   9.108 -fun pair_tac s = EVERY' [res_inst_tac [("p",s)] PairE, hyp_subst_tac,
   9.109 -                         K prune_params_tac];
   9.110 -
   9.111 -(* Do not add as rewrite rule: invalidates some proofs in IMP *)
   9.112 -Goal "p = (fst(p),snd(p))";
   9.113 -by (pair_tac "p" 1);
   9.114 -by (Asm_simp_tac 1);
   9.115 -qed "surjective_pairing";
   9.116 -Addsimps [surjective_pairing RS sym];
   9.117 -
   9.118 -Goal "? x y. z = (x, y)";
   9.119 -by (rtac exI 1);
   9.120 -by (rtac exI 1);
   9.121 -by (rtac surjective_pairing 1);
   9.122 -qed "surj_pair";
   9.123 -Addsimps [surj_pair];
   9.124 -
   9.125 -
   9.126 -bind_thm ("split_paired_all",
   9.127 -  SplitPairedAll.rule (standard (surjective_pairing RS eq_reflection)));
   9.128 -bind_thms ("split_tupled_all", [split_paired_all, unit_all_eq2]);
   9.129 -
   9.130 -(*
   9.131 -Addsimps [split_paired_all] does not work with simplifier
   9.132 -because it also affects premises in congrence rules,
   9.133 -where is can lead to premises of the form !!a b. ... = ?P(a,b)
   9.134 -which cannot be solved by reflexivity.
   9.135 -*)
   9.136 -
   9.137 -(* replace parameters of product type by individual component parameters *)
   9.138 -local
   9.139 -  fun exists_paired_all prem =   (* FIXME check deeper nesting of params!?! *)
   9.140 -    Library.exists (can HOLogic.dest_prodT o #2) (Logic.strip_params prem);
   9.141 -  val ss = HOL_basic_ss
   9.142 -    addsimps [split_paired_all, unit_all_eq2, unit_abs_eta_conv]
   9.143 -    addsimprocs [unit_eq_proc];
   9.144 -  val split_tac = full_simp_tac ss;
   9.145 -in
   9.146 -  val split_all_tac = SUBGOAL (fn (prem,i) =>
   9.147 -    if exists_paired_all prem then split_tac i else no_tac);
   9.148 -end;
   9.149 -
   9.150 -claset_ref() := claset()
   9.151 -  addSWrapper ("split_all_tac", fn tac2 => split_all_tac ORELSE' tac2);
   9.152 -
   9.153 -Goal "(!x. P x) = (!a b. P(a,b))";
   9.154 -by (Fast_tac 1);
   9.155 -qed "split_paired_All";
   9.156 -Addsimps [split_paired_All];
   9.157 -(* AddIffs is not a good idea because it makes Blast_tac loop *)
   9.158 -
   9.159 -bind_thm ("prod_induct",
   9.160 -  allI RS (allI RS (split_paired_All RS iffD2)) RS spec);
   9.161 -
   9.162 -Goal "(? x. P x) = (? a b. P(a,b))";
   9.163 -by (Fast_tac 1);
   9.164 -qed "split_paired_Ex";
   9.165 -Addsimps [split_paired_Ex];
   9.166 -
   9.167 -Goalw [split_def] "split c (a,b) = c a b";
   9.168 -by (Simp_tac 1);
   9.169 -qed "split";
   9.170 -Addsimps [split];
   9.171 -
   9.172 -(*Subsumes the old split_Pair when f is the identity function*)
   9.173 -Goal "split (%x y. f(x,y)) = f";
   9.174 -by (rtac ext 1);
   9.175 -by (pair_tac "x" 1);
   9.176 -by (Simp_tac 1);
   9.177 -qed "split_Pair_apply";
   9.178 -
   9.179 -(*Can't be added to simpset: loops!*)
   9.180 -Goal "(SOME x. P x) = (SOME (a,b). P(a,b))";
   9.181 -by (simp_tac (simpset() addsimps [split_Pair_apply]) 1);
   9.182 -qed "split_paired_Eps";
   9.183 -
   9.184 -Goal "!!s t. (s=t) = (fst(s)=fst(t) & snd(s)=snd(t))";
   9.185 -by (split_all_tac 1);
   9.186 -by (Asm_simp_tac 1);
   9.187 -qed "Pair_fst_snd_eq";
   9.188 -
   9.189 -Goal "fst p = fst q ==> snd p = snd q ==> p = q";
   9.190 -by (asm_simp_tac (simpset() addsimps [Pair_fst_snd_eq]) 1);
   9.191 -qed "prod_eqI";
   9.192 -AddXIs [prod_eqI];
   9.193 -
   9.194 -(*Prevents simplification of c: much faster*)
   9.195 -Goal "p=q ==> split c p = split c q";
   9.196 -by (etac arg_cong 1);
   9.197 -qed "split_weak_cong";
   9.198 -
   9.199 -Goal "(%(x,y). f(x,y)) = f";
   9.200 -by (rtac ext 1);
   9.201 -by (split_all_tac 1);
   9.202 -by (rtac split 1);
   9.203 -qed "split_eta";
   9.204 -
   9.205 -val prems = Goal "(!!x y. f x y = g(x,y)) ==> (%(x,y). f x y) = g";
   9.206 -by (asm_simp_tac (simpset() addsimps prems@[split_eta]) 1);
   9.207 -qed "cond_split_eta";
   9.208 -
   9.209 -(*simplification procedure for cond_split_eta.
   9.210 -  using split_eta a rewrite rule is not general enough, and using
   9.211 -  cond_split_eta directly would render some existing proofs very inefficient.
   9.212 -  similarly for split_beta. *)
   9.213 -local
   9.214 -  fun  Pair_pat k 0 (Bound m) = (m = k)
   9.215 -  |    Pair_pat k i (Const ("Pair",  _) $ Bound m $ t) = i > 0 andalso
   9.216 -                        m = k+i andalso Pair_pat k (i-1) t
   9.217 -  |    Pair_pat _ _ _ = false;
   9.218 -  fun no_args k i (Abs (_, _, t)) = no_args (k+1) i t
   9.219 -  |   no_args k i (t $ u) = no_args k i t andalso no_args k i u
   9.220 -  |   no_args k i (Bound m) = m < k orelse m > k+i
   9.221 -  |   no_args _ _ _ = true;
   9.222 -  fun split_pat tp i (Abs  (_,_,t)) = if tp 0 i t then Some (i,t) else None
   9.223 -  |   split_pat tp i (Const ("split", _) $ Abs (_, _, t)) = split_pat tp (i+1) t
   9.224 -  |   split_pat tp i _ = None;
   9.225 -  fun metaeq sg lhs rhs = mk_meta_eq (prove_goalw_cterm []
   9.226 -        (cterm_of sg (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs))))
   9.227 -        (K [simp_tac (HOL_basic_ss addsimps [cond_split_eta]) 1]));
   9.228 -  val sign = sign_of (the_context ());
   9.229 -  fun simproc name patstr = Simplifier.mk_simproc name
   9.230 -                [Thm.read_cterm sign (patstr, HOLogic.termT)];
   9.231 -
   9.232 -  val beta_patstr = "split f z";
   9.233 -  val  eta_patstr = "split f";
   9.234 -  fun beta_term_pat k i (Abs (_, _, t)) = beta_term_pat (k+1) i t
   9.235 -  |   beta_term_pat k i (t $ u) = Pair_pat k i (t $ u) orelse
   9.236 -                        (beta_term_pat k i t andalso beta_term_pat k i u)
   9.237 -  |   beta_term_pat k i t = no_args k i t;
   9.238 -  fun  eta_term_pat k i (f $ arg) = no_args k i f andalso Pair_pat k i arg
   9.239 -  |    eta_term_pat _ _ _ = false;
   9.240 -  fun subst arg k i (Abs (x, T, t)) = Abs (x, T, subst arg (k+1) i t)
   9.241 -  |   subst arg k i (t $ u) = if Pair_pat k i (t $ u) then incr_boundvars k arg
   9.242 -                              else (subst arg k i t $ subst arg k i u)
   9.243 -  |   subst arg k i t = t;
   9.244 -  fun beta_proc sg _ (s as Const ("split", _) $ Abs (_, _, t) $ arg) =
   9.245 -        (case split_pat beta_term_pat 1 t of
   9.246 -        Some (i,f) => Some (metaeq sg s (subst arg 0 i f))
   9.247 -        | None => None)
   9.248 -  |   beta_proc _ _ _ = None;
   9.249 -  fun eta_proc sg _ (s as Const ("split", _) $ Abs (_, _, t)) =
   9.250 -        (case split_pat eta_term_pat 1 t of
   9.251 -          Some (_,ft) => Some (metaeq sg s (let val (f $ arg) = ft in f end))
   9.252 -        | None => None)
   9.253 -  |   eta_proc _ _ _ = None;
   9.254 -in
   9.255 -  val split_beta_proc = simproc "split_beta" beta_patstr beta_proc;
   9.256 -  val split_eta_proc  = simproc "split_eta"   eta_patstr  eta_proc;
   9.257 -end;
   9.258 -
   9.259 -Addsimprocs [split_beta_proc,split_eta_proc];
   9.260 -
   9.261 -Goal "(%(x,y). P x y) z = P (fst z) (snd z)";
   9.262 -by (stac surjective_pairing 1 THEN rtac split 1);
   9.263 -qed "split_beta";
   9.264 -
   9.265 -(*For use with split_tac and the simplifier*)
   9.266 -Goal "R (split c p) = (! x y. p = (x,y) --> R (c x y))";
   9.267 -by (stac surjective_pairing 1);
   9.268 -by (stac split 1);
   9.269 -by (Blast_tac 1);
   9.270 -qed "split_split";
   9.271 -
   9.272 -(* could be done after split_tac has been speeded up significantly:
   9.273 -simpset_ref() := simpset() addsplits [split_split];
   9.274 -   precompute the constants involved and don't do anything unless
   9.275 -   the current goal contains one of those constants
   9.276 -*)
   9.277 -
   9.278 -Goal "R (split c p) = (~(? x y. p = (x,y) & (~R (c x y))))";
   9.279 -by (stac split_split 1);
   9.280 -by (Simp_tac 1);
   9.281 -qed "expand_split_asm";
   9.282 -
   9.283 -(** split used as a logical connective or set former **)
   9.284 -
   9.285 -(*These rules are for use with blast_tac.
   9.286 -  Could instead call simp_tac/asm_full_simp_tac using split as rewrite.*)
   9.287 -
   9.288 -Goal "!!p. [| !!a b. p=(a,b) ==> c a b |] ==> split c p";
   9.289 -by (split_all_tac 1);
   9.290 -by (Asm_simp_tac 1);
   9.291 -qed "splitI2";
   9.292 -
   9.293 -Goal "!!p. [| !!a b. (a,b)=p ==> c a b x |] ==> split c p x";
   9.294 -by (split_all_tac 1);
   9.295 -by (Asm_simp_tac 1);
   9.296 -qed "splitI2'";
   9.297 -
   9.298 -Goal "c a b ==> split c (a,b)";
   9.299 -by (Asm_simp_tac 1);
   9.300 -qed "splitI";
   9.301 -
   9.302 -val prems = Goalw [split_def]
   9.303 -    "[| split c p;  !!x y. [| p = (x,y);  c x y |] ==> Q |] ==> Q";
   9.304 -by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
   9.305 -qed "splitE";
   9.306 -
   9.307 -val prems = Goalw [split_def]
   9.308 -    "[| split c p z;  !!x y. [| p = (x,y);  c x y z |] ==> Q |] ==> Q";
   9.309 -by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
   9.310 -qed "splitE'";
   9.311 -
   9.312 -val major::prems = Goal
   9.313 -    "[| Q (split P z);  !!x y. [|z = (x, y); Q (P x y)|] ==> R  \
   9.314 -\    |] ==> R";
   9.315 -by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
   9.316 -by (rtac (split_beta RS subst) 1 THEN rtac major 1);
   9.317 -qed "splitE2";
   9.318 -
   9.319 -Goal "split R (a,b) ==> R a b";
   9.320 -by (etac (split RS iffD1) 1);
   9.321 -qed "splitD";
   9.322 -
   9.323 -Goal "z: c a b ==> z: split c (a,b)";
   9.324 -by (Asm_simp_tac 1);
   9.325 -qed "mem_splitI";
   9.326 -
   9.327 -Goal "!!p. [| !!a b. p=(a,b) ==> z: c a b |] ==> z: split c p";
   9.328 -by (split_all_tac 1);
   9.329 -by (Asm_simp_tac 1);
   9.330 -qed "mem_splitI2";
   9.331 -
   9.332 -val prems = Goalw [split_def]
   9.333 -    "[| z: split c p;  !!x y. [| p = (x,y);  z: c x y |] ==> Q |] ==> Q";
   9.334 -by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
   9.335 -qed "mem_splitE";
   9.336 -
   9.337 -AddSIs [splitI, splitI2, splitI2', mem_splitI, mem_splitI2];
   9.338 -AddSEs [splitE, splitE', mem_splitE];
   9.339 -
   9.340 -Goal "(%u. ? x y. u = (x, y) & P (x, y)) = P";
   9.341 -by (rtac ext 1);
   9.342 -by (Fast_tac 1);
   9.343 -qed "split_eta_SetCompr";
   9.344 -Addsimps [split_eta_SetCompr];
   9.345 -
   9.346 -Goal "(%u. ? x y. u = (x, y) & P x y) = split P";
   9.347 -br ext 1;
   9.348 -by (Fast_tac 1);
   9.349 -qed "split_eta_SetCompr2";
   9.350 -Addsimps [split_eta_SetCompr2];
   9.351 -
   9.352 -(* allows simplifications of nested splits in case of independent predicates *)
   9.353 -Goal "(%(a,b). P & Q a b) = (%ab. P & split Q ab)";
   9.354 -by (rtac ext 1);
   9.355 -by (Blast_tac 1);
   9.356 -qed "split_part";
   9.357 -Addsimps [split_part];
   9.358 -
   9.359 -Goal "(@(x',y'). x = x' & y = y') = (x,y)";
   9.360 -by (Blast_tac 1);
   9.361 -qed "Eps_split_eq";
   9.362 -Addsimps [Eps_split_eq];
   9.363 -(*
   9.364 -the following  would be slightly more general,
   9.365 -but cannot be used as rewrite rule:
   9.366 -### Cannot add premise as rewrite rule because it contains (type) unknowns:
   9.367 -### ?y = .x
   9.368 -Goal "[| P y; !!x. P x ==> x = y |] ==> (@(x',y). x = x' & P y) = (x,y)";
   9.369 -by (rtac some_equality 1);
   9.370 -by ( Simp_tac 1);
   9.371 -by (split_all_tac 1);
   9.372 -by (Asm_full_simp_tac 1);
   9.373 -qed "Eps_split_eq";
   9.374 -*)
   9.375 -
   9.376 -(*** prod_fun -- action of the product functor upon functions ***)
   9.377 -
   9.378 -Goalw [prod_fun_def] "prod_fun f g (a,b) = (f(a),g(b))";
   9.379 -by (rtac split 1);
   9.380 -qed "prod_fun";
   9.381 -Addsimps [prod_fun];
   9.382 -
   9.383 -Goal "prod_fun (f1 o f2) (g1 o g2) = ((prod_fun f1 g1) o (prod_fun f2 g2))";
   9.384 -by (rtac ext 1);
   9.385 -by (pair_tac "x" 1);
   9.386 -by (Asm_simp_tac 1);
   9.387 -qed "prod_fun_compose";
   9.388 -
   9.389 -Goal "prod_fun (%x. x) (%y. y) = (%z. z)";
   9.390 -by (rtac ext 1);
   9.391 -by (pair_tac "z" 1);
   9.392 -by (Asm_simp_tac 1);
   9.393 -qed "prod_fun_ident";
   9.394 -Addsimps [prod_fun_ident];
   9.395 -
   9.396 -Goal "(a,b):r ==> (f(a),g(b)) : (prod_fun f g)``r";
   9.397 -by (rtac image_eqI 1);
   9.398 -by (rtac (prod_fun RS sym) 1);
   9.399 -by (assume_tac 1);
   9.400 -qed "prod_fun_imageI";
   9.401 -
   9.402 -val major::prems = Goal
   9.403 -    "[| c: (prod_fun f g)``r;  !!x y. [| c=(f(x),g(y));  (x,y):r |] ==> P  \
   9.404 -\    |] ==> P";
   9.405 -by (rtac (major RS imageE) 1);
   9.406 -by (res_inst_tac [("p","x")] PairE 1);
   9.407 -by (resolve_tac prems 1);
   9.408 -by (Blast_tac 2);
   9.409 -by (blast_tac (claset() addIs [prod_fun]) 1);
   9.410 -qed "prod_fun_imageE";
   9.411 -
   9.412 -AddIs  [prod_fun_imageI];
   9.413 -AddSEs [prod_fun_imageE];
   9.414 -
   9.415 -
   9.416 -(*** Disjoint union of a family of sets - Sigma ***)
   9.417 -
   9.418 -Goalw [Sigma_def] "[| a:A;  b:B(a) |] ==> (a,b) : Sigma A B";
   9.419 -by (REPEAT (ares_tac [singletonI,UN_I] 1));
   9.420 -qed "SigmaI";
   9.421 -
   9.422 -AddSIs [SigmaI];
   9.423 -
   9.424 -(*The general elimination rule*)
   9.425 -val major::prems = Goalw [Sigma_def]
   9.426 -    "[| c: Sigma A B;  \
   9.427 -\       !!x y.[| x:A;  y:B(x);  c=(x,y) |] ==> P \
   9.428 -\    |] ==> P";
   9.429 -by (cut_facts_tac [major] 1);
   9.430 -by (REPEAT (eresolve_tac [UN_E, singletonE] 1 ORELSE ares_tac prems 1)) ;
   9.431 -qed "SigmaE";
   9.432 -
   9.433 -(** Elimination of (a,b):A*B -- introduces no eigenvariables **)
   9.434 -
   9.435 -Goal "(a,b) : Sigma A B ==> a : A";
   9.436 -by (etac SigmaE 1);
   9.437 -by (REPEAT (eresolve_tac [asm_rl,Pair_inject,ssubst] 1)) ;
   9.438 -qed "SigmaD1";
   9.439 -
   9.440 -Goal "(a,b) : Sigma A B ==> b : B(a)";
   9.441 -by (etac SigmaE 1);
   9.442 -by (REPEAT (eresolve_tac [asm_rl,Pair_inject,ssubst] 1)) ;
   9.443 -qed "SigmaD2";
   9.444 -
   9.445 -val [major,minor]= Goal
   9.446 -    "[| (a,b) : Sigma A B;    \
   9.447 -\       [| a:A;  b:B(a) |] ==> P   \
   9.448 -\    |] ==> P";
   9.449 -by (rtac minor 1);
   9.450 -by (rtac (major RS SigmaD1) 1);
   9.451 -by (rtac (major RS SigmaD2) 1) ;
   9.452 -qed "SigmaE2";
   9.453 -
   9.454 -AddSEs [SigmaE2, SigmaE];
   9.455 -
   9.456 -val prems = Goal
   9.457 -    "[| A<=C;  !!x. x:A ==> B x <= D x |] ==> Sigma A B <= Sigma C D";
   9.458 -by (cut_facts_tac prems 1);
   9.459 -by (blast_tac (claset() addIs (prems RL [subsetD])) 1);
   9.460 -qed "Sigma_mono";
   9.461 -
   9.462 -Goal "Sigma {} B = {}";
   9.463 -by (Blast_tac 1) ;
   9.464 -qed "Sigma_empty1";
   9.465 -
   9.466 -Goal "A <*> {} = {}";
   9.467 -by (Blast_tac 1) ;
   9.468 -qed "Sigma_empty2";
   9.469 -
   9.470 -Addsimps [Sigma_empty1,Sigma_empty2];
   9.471 -
   9.472 -Goal "UNIV <*> UNIV = UNIV";
   9.473 -by Auto_tac;
   9.474 -qed "UNIV_Times_UNIV";
   9.475 -Addsimps [UNIV_Times_UNIV];
   9.476 -
   9.477 -Goal "- (UNIV <*> A) = UNIV <*> (-A)";
   9.478 -by Auto_tac;
   9.479 -qed "Compl_Times_UNIV1";
   9.480 -
   9.481 -Goal "- (A <*> UNIV) = (-A) <*> UNIV";
   9.482 -by Auto_tac;
   9.483 -qed "Compl_Times_UNIV2";
   9.484 -
   9.485 -Addsimps [Compl_Times_UNIV1, Compl_Times_UNIV2];
   9.486 -
   9.487 -Goal "((a,b): Sigma A B) = (a:A & b:B(a))";
   9.488 -by (Blast_tac 1);
   9.489 -qed "mem_Sigma_iff";
   9.490 -AddIffs [mem_Sigma_iff];
   9.491 -
   9.492 -Goal "x:C ==> (A <*> C <= B <*> C) = (A <= B)";
   9.493 -by (Blast_tac 1);
   9.494 -qed "Times_subset_cancel2";
   9.495 -
   9.496 -Goal "x:C ==> (A <*> C = B <*> C) = (A = B)";
   9.497 -by (blast_tac (claset() addEs [equalityE]) 1);
   9.498 -qed "Times_eq_cancel2";
   9.499 -
   9.500 -Goal "Collect (split (%x y. P x & Q x y)) = (SIGMA x:Collect P. Collect (Q x))";
   9.501 -by (Fast_tac 1);
   9.502 -qed "SetCompr_Sigma_eq";
   9.503 -
   9.504 -(*** Complex rules for Sigma ***)
   9.505 -
   9.506 -Goal "{(a,b). P a & Q b} = Collect P <*> Collect Q";
   9.507 -by (Blast_tac 1);
   9.508 -qed "Collect_split";
   9.509 -
   9.510 -Addsimps [Collect_split];
   9.511 -
   9.512 -(*Suggested by Pierre Chartier*)
   9.513 -Goal "(UN (a,b):(A <*> B). E a <*> F b) = (UNION A E) <*> (UNION B F)";
   9.514 -by (Blast_tac 1);
   9.515 -qed "UN_Times_distrib";
   9.516 -
   9.517 -Goal "(ALL z: Sigma A B. P z) = (ALL x:A. ALL y: B x. P(x,y))";
   9.518 -by (Fast_tac 1);
   9.519 -qed "split_paired_Ball_Sigma";
   9.520 -Addsimps [split_paired_Ball_Sigma];
   9.521 -
   9.522 -Goal "(EX z: Sigma A B. P z) = (EX x:A. EX y: B x. P(x,y))";
   9.523 -by (Fast_tac 1);
   9.524 -qed "split_paired_Bex_Sigma";
   9.525 -Addsimps [split_paired_Bex_Sigma];
   9.526 -
   9.527 -Goal "(SIGMA i:I Un J. C(i)) = (SIGMA i:I. C(i)) Un (SIGMA j:J. C(j))";
   9.528 -by (Blast_tac 1);
   9.529 -qed "Sigma_Un_distrib1";
   9.530 -
   9.531 -Goal "(SIGMA i:I. A(i) Un B(i)) = (SIGMA i:I. A(i)) Un (SIGMA i:I. B(i))";
   9.532 -by (Blast_tac 1);
   9.533 -qed "Sigma_Un_distrib2";
   9.534 -
   9.535 -Goal "(SIGMA i:I Int J. C(i)) = (SIGMA i:I. C(i)) Int (SIGMA j:J. C(j))";
   9.536 -by (Blast_tac 1);
   9.537 -qed "Sigma_Int_distrib1";
   9.538 -
   9.539 -Goal "(SIGMA i:I. A(i) Int B(i)) = (SIGMA i:I. A(i)) Int (SIGMA i:I. B(i))";
   9.540 -by (Blast_tac 1);
   9.541 -qed "Sigma_Int_distrib2";
   9.542 -
   9.543 -Goal "(SIGMA i:I - J. C(i)) = (SIGMA i:I. C(i)) - (SIGMA j:J. C(j))";
   9.544 -by (Blast_tac 1);
   9.545 -qed "Sigma_Diff_distrib1";
   9.546 -
   9.547 -Goal "(SIGMA i:I. A(i) - B(i)) = (SIGMA i:I. A(i)) - (SIGMA i:I. B(i))";
   9.548 -by (Blast_tac 1);
   9.549 -qed "Sigma_Diff_distrib2";
   9.550 -
   9.551 -Goal "Sigma (Union X) B = (UN A:X. Sigma A B)";
   9.552 -by (Blast_tac 1);
   9.553 -qed "Sigma_Union";
   9.554 -
   9.555 -(*Non-dependent versions are needed to avoid the need for higher-order
   9.556 -  matching, especially when the rules are re-oriented*)
   9.557 -Goal "(A Un B) <*> C = (A <*> C) Un (B <*> C)";
   9.558 -by (Blast_tac 1);
   9.559 -qed "Times_Un_distrib1";
   9.560 -
   9.561 -Goal "(A Int B) <*> C = (A <*> C) Int (B <*> C)";
   9.562 -by (Blast_tac 1);
   9.563 -qed "Times_Int_distrib1";
   9.564 -
   9.565 -Goal "(A - B) <*> C = (A <*> C) - (B <*> C)";
   9.566 -by (Blast_tac 1);
   9.567 -qed "Times_Diff_distrib1";
   9.568 -
   9.569 -
   9.570 -(*Attempts to remove occurrences of split, and pair-valued parameters*)
   9.571 -val remove_split = rewrite_rule [split RS eq_reflection] o
   9.572 -                   rule_by_tactic (TRYALL split_all_tac);
   9.573 -
   9.574 -local
   9.575 -
   9.576 -(*In ap_split S T u, term u expects separate arguments for the factors of S,
   9.577 -  with result type T.  The call creates a new term expecting one argument
   9.578 -  of type S.*)
   9.579 -fun ap_split (Type ("*", [T1, T2])) T3 u =
   9.580 -      HOLogic.split_const (T1, T2, T3) $
   9.581 -      Abs("v", T1,
   9.582 -          ap_split T2 T3
   9.583 -             ((ap_split T1 (HOLogic.prodT_factors T2 ---> T3) (incr_boundvars 1 u)) $
   9.584 -              Bound 0))
   9.585 -  | ap_split T T3 u = u;
   9.586 -
   9.587 -(*Curries any Var of function type in the rule*)
   9.588 -fun split_rule_var' (t as Var (v, Type ("fun", [T1, T2])), rl) =
   9.589 -      let val T' = HOLogic.prodT_factors T1 ---> T2
   9.590 -          val newt = ap_split T1 T2 (Var (v, T'))
   9.591 -          val cterm = Thm.cterm_of (#sign (rep_thm rl))
   9.592 -      in
   9.593 -          instantiate ([], [(cterm t, cterm newt)]) rl
   9.594 -      end
   9.595 -  | split_rule_var' (t, rl) = rl;
   9.596 -
   9.597 -in
   9.598 -
   9.599 -val split_rule_var = standard o remove_split o split_rule_var';
   9.600 -
   9.601 -(*Curries ALL function variables occurring in a rule's conclusion*)
   9.602 -fun split_rule rl = remove_split (foldr split_rule_var' (term_vars (concl_of rl), rl))
   9.603 -                    |> standard;
   9.604 -
   9.605 -end;
    10.1 --- a/src/HOL/Prod.thy	Thu Oct 12 18:38:23 2000 +0200
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,109 +0,0 @@
    10.4 -(*  Title:      HOL/Prod.thy
    10.5 -    ID:         $Id$
    10.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    10.7 -    Copyright   1992  University of Cambridge
    10.8 -
    10.9 -Ordered Pairs and the Cartesian product type.
   10.10 -The unit type.
   10.11 -*)
   10.12 -
   10.13 -Prod = Fun + equalities +
   10.14 -
   10.15 -
   10.16 -(** products **)
   10.17 -
   10.18 -(* type definition *)
   10.19 -
   10.20 -constdefs
   10.21 -  Pair_Rep      :: ['a, 'b] => ['a, 'b] => bool
   10.22 -  "Pair_Rep == (%a b. %x y. x=a & y=b)"
   10.23 -
   10.24 -global
   10.25 -
   10.26 -typedef (Prod)
   10.27 -  ('a, 'b) "*"          (infixr 20)
   10.28 -    = "{f. ? a b. f = Pair_Rep (a::'a) (b::'b)}"
   10.29 -
   10.30 -syntax (symbols)
   10.31 -  "*"           :: [type, type] => type         ("(_ \\<times>/ _)" [21, 20] 20)
   10.32 -
   10.33 -syntax (HTML output)
   10.34 -  "*"           :: [type, type] => type         ("(_ \\<times>/ _)" [21, 20] 20)
   10.35 -
   10.36 -
   10.37 -(* abstract constants and syntax *)
   10.38 -
   10.39 -consts
   10.40 -  fst           :: "'a * 'b => 'a"
   10.41 -  snd           :: "'a * 'b => 'b"
   10.42 -  split         :: "[['a, 'b] => 'c, 'a * 'b] => 'c"
   10.43 -  prod_fun      :: "['a => 'b, 'c => 'd, 'a * 'c] => 'b * 'd"
   10.44 -  Pair          :: "['a, 'b] => 'a * 'b"
   10.45 -  Sigma         :: "['a set, 'a => 'b set] => ('a * 'b) set"
   10.46 -
   10.47 -
   10.48 -(* patterns -- extends pre-defined type "pttrn" used in abstractions *)
   10.49 -
   10.50 -nonterminals
   10.51 -  tuple_args patterns
   10.52 -
   10.53 -syntax
   10.54 -  "_tuple"      :: "'a => tuple_args => 'a * 'b"        ("(1'(_,/ _'))")
   10.55 -  "_tuple_arg"  :: "'a => tuple_args"                   ("_")
   10.56 -  "_tuple_args" :: "'a => tuple_args => tuple_args"     ("_,/ _")
   10.57 -  "_pattern"    :: [pttrn, patterns] => pttrn           ("'(_,/ _')")
   10.58 -  ""            :: pttrn => patterns                    ("_")
   10.59 -  "_patterns"   :: [pttrn, patterns] => patterns        ("_,/ _")
   10.60 -  "@Sigma"      :: "[pttrn, 'a set, 'b set] => ('a * 'b) set"   ("(3SIGMA _:_./ _)" 10)
   10.61 -  "@Times"      :: "['a set, 'a => 'b set] => ('a * 'b) set"    (infixr "<*>" 80)
   10.62 -
   10.63 -translations
   10.64 -  "(x, y)"       == "Pair x y"
   10.65 -  "_tuple x (_tuple_args y z)" == "_tuple x (_tuple_arg (_tuple y z))"
   10.66 -  "%(x,y,zs).b"  == "split(%x (y,zs).b)"
   10.67 -  "%(x,y).b"     == "split(%x y. b)"
   10.68 -  "_abs (Pair x y) t" => "%(x,y).t"
   10.69 -  (* The last rule accommodates tuples in `case C ... (x,y) ... => ...'
   10.70 -     The (x,y) is parsed as `Pair x y' because it is logic, not pttrn *)
   10.71 -
   10.72 -  "SIGMA x:A. B" => "Sigma A (%x. B)"
   10.73 -  "A <*> B"      => "Sigma A (_K B)"
   10.74 -
   10.75 -syntax (symbols)
   10.76 -  "@Sigma"      :: "[pttrn, 'a set, 'b set] => ('a * 'b) set"   ("(3\\<Sigma> _\\<in>_./ _)" 10)
   10.77 -  "@Times"      :: "['a set, 'a => 'b set] => ('a * 'b) set"    ("_ \\<times> _" [81, 80] 80)
   10.78 -
   10.79 -
   10.80 -(* definitions *)
   10.81 -
   10.82 -local
   10.83 -
   10.84 -defs
   10.85 -  Pair_def      "Pair a b == Abs_Prod(Pair_Rep a b)"
   10.86 -  fst_def       "fst p == @a. ? b. p = (a, b)"
   10.87 -  snd_def       "snd p == @b. ? a. p = (a, b)"
   10.88 -  split_def     "split == (%c p. c (fst p) (snd p))"
   10.89 -  prod_fun_def  "prod_fun f g == split(%x y.(f(x), g(y)))"
   10.90 -  Sigma_def     "Sigma A B == UN x:A. UN y:B(x). {(x, y)}"
   10.91 -
   10.92 -
   10.93 -
   10.94 -(** unit **)
   10.95 -
   10.96 -global
   10.97 -
   10.98 -typedef  unit = "{True}"
   10.99 -
  10.100 -consts
  10.101 -  "()"          :: unit                           ("'(')")
  10.102 -
  10.103 -local
  10.104 -
  10.105 -defs
  10.106 -  Unity_def     "() == Abs_unit True"
  10.107 -
  10.108 -end
  10.109 -
  10.110 -ML
  10.111 -
  10.112 -val print_translation = [("Sigma", dependent_tr' ("@Sigma", "@Times"))];
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/Product_Type.ML	Thu Oct 12 18:44:35 2000 +0200
    11.3 @@ -0,0 +1,602 @@
    11.4 +(*  Title:      HOL/Product_Type.ML
    11.5 +    ID:         $Id$
    11.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    11.7 +    Copyright   1991  University of Cambridge
    11.8 +
    11.9 +Ordered Pairs, the Cartesian product type, the unit type
   11.10 +*)
   11.11 +
   11.12 +(** unit **)
   11.13 +
   11.14 +Goalw [Unity_def]
   11.15 +    "u = ()";
   11.16 +by (stac (rewrite_rule [unit_def] Rep_unit RS singletonD RS sym) 1);
   11.17 +by (rtac (Rep_unit_inverse RS sym) 1);
   11.18 +qed "unit_eq";
   11.19 +
   11.20 +(*simplification procedure for unit_eq.
   11.21 +  Cannot use this rule directly -- it loops!*)
   11.22 +local
   11.23 +  val unit_pat = Thm.cterm_of (Theory.sign_of (the_context ())) (Free ("x", HOLogic.unitT));
   11.24 +  val unit_meta_eq = standard (mk_meta_eq unit_eq);
   11.25 +  fun proc _ _ t =
   11.26 +    if HOLogic.is_unit t then None
   11.27 +    else Some unit_meta_eq;
   11.28 +in
   11.29 +  val unit_eq_proc = Simplifier.mk_simproc "unit_eq" [unit_pat] proc;
   11.30 +end;
   11.31 +
   11.32 +Addsimprocs [unit_eq_proc];
   11.33 +
   11.34 +Goal "(!!x::unit. PROP P x) == PROP P ()";
   11.35 +by (Simp_tac 1);
   11.36 +qed "unit_all_eq1";
   11.37 +
   11.38 +Goal "(!!x::unit. PROP P) == PROP P";
   11.39 +by (rtac triv_forall_equality 1);
   11.40 +qed "unit_all_eq2";
   11.41 +
   11.42 +Goal "P () ==> P x";
   11.43 +by (Simp_tac 1);
   11.44 +qed "unit_induct";
   11.45 +
   11.46 +(*This rewrite counters the effect of unit_eq_proc on (%u::unit. f u),
   11.47 +  replacing it by f rather than by %u.f(). *)
   11.48 +Goal "(%u::unit. f()) = f";
   11.49 +by (rtac ext 1);
   11.50 +by (Simp_tac 1);
   11.51 +qed "unit_abs_eta_conv";
   11.52 +Addsimps [unit_abs_eta_conv];
   11.53 +
   11.54 +
   11.55 +(** prod **)
   11.56 +
   11.57 +Goalw [Prod_def] "Pair_Rep a b : Prod";
   11.58 +by (EVERY1 [rtac CollectI, rtac exI, rtac exI, rtac refl]);
   11.59 +qed "ProdI";
   11.60 +
   11.61 +Goalw [Pair_Rep_def] "Pair_Rep a b = Pair_Rep a' b' ==> a=a' & b=b'";
   11.62 +by (dtac (fun_cong RS fun_cong) 1);
   11.63 +by (Blast_tac 1);
   11.64 +qed "Pair_Rep_inject";
   11.65 +
   11.66 +Goal "inj_on Abs_Prod Prod";
   11.67 +by (rtac inj_on_inverseI 1);
   11.68 +by (etac Abs_Prod_inverse 1);
   11.69 +qed "inj_on_Abs_Prod";
   11.70 +
   11.71 +val prems = Goalw [Pair_def]
   11.72 +    "[| (a, b) = (a',b');  [| a=a';  b=b' |] ==> R |] ==> R";
   11.73 +by (rtac (inj_on_Abs_Prod RS inj_onD RS Pair_Rep_inject RS conjE) 1);
   11.74 +by (REPEAT (ares_tac (prems@[ProdI]) 1));
   11.75 +qed "Pair_inject";
   11.76 +
   11.77 +Goal "((a,b) = (a',b')) = (a=a' & b=b')";
   11.78 +by (blast_tac (claset() addSEs [Pair_inject]) 1);
   11.79 +qed "Pair_eq";
   11.80 +AddIffs [Pair_eq];
   11.81 +
   11.82 +Goalw [fst_def] "fst (a,b) = a";
   11.83 +by (Blast_tac 1);
   11.84 +qed "fst_conv";
   11.85 +Goalw [snd_def] "snd (a,b) = b";
   11.86 +by (Blast_tac 1);
   11.87 +qed "snd_conv";
   11.88 +Addsimps [fst_conv, snd_conv];
   11.89 +
   11.90 +Goal "fst (x, y) = a ==> x = a";
   11.91 +by (Asm_full_simp_tac 1);
   11.92 +qed "fst_eqD";
   11.93 +Goal "snd (x, y) = a ==> y = a";
   11.94 +by (Asm_full_simp_tac 1);
   11.95 +qed "snd_eqD";
   11.96 +
   11.97 +Goalw [Pair_def] "? x y. p = (x,y)";
   11.98 +by (rtac (rewrite_rule [Prod_def] Rep_Prod RS CollectE) 1);
   11.99 +by (EVERY1[etac exE, etac exE, rtac exI, rtac exI,
  11.100 +           rtac (Rep_Prod_inverse RS sym RS trans),  etac arg_cong]);
  11.101 +qed "PairE_lemma";
  11.102 +
  11.103 +val [prem] = Goal "[| !!x y. p = (x,y) ==> Q |] ==> Q";
  11.104 +by (rtac (PairE_lemma RS exE) 1);
  11.105 +by (REPEAT (eresolve_tac [prem,exE] 1));
  11.106 +qed "PairE";
  11.107 +
  11.108 +fun pair_tac s = EVERY' [res_inst_tac [("p",s)] PairE, hyp_subst_tac,
  11.109 +                         K prune_params_tac];
  11.110 +
  11.111 +(* Do not add as rewrite rule: invalidates some proofs in IMP *)
  11.112 +Goal "p = (fst(p),snd(p))";
  11.113 +by (pair_tac "p" 1);
  11.114 +by (Asm_simp_tac 1);
  11.115 +qed "surjective_pairing";
  11.116 +Addsimps [surjective_pairing RS sym];
  11.117 +
  11.118 +Goal "? x y. z = (x, y)";
  11.119 +by (rtac exI 1);
  11.120 +by (rtac exI 1);
  11.121 +by (rtac surjective_pairing 1);
  11.122 +qed "surj_pair";
  11.123 +Addsimps [surj_pair];
  11.124 +
  11.125 +
  11.126 +bind_thm ("split_paired_all",
  11.127 +  SplitPairedAll.rule (standard (surjective_pairing RS eq_reflection)));
  11.128 +bind_thms ("split_tupled_all", [split_paired_all, unit_all_eq2]);
  11.129 +
  11.130 +(*
  11.131 +Addsimps [split_paired_all] does not work with simplifier
  11.132 +because it also affects premises in congrence rules,
  11.133 +where is can lead to premises of the form !!a b. ... = ?P(a,b)
  11.134 +which cannot be solved by reflexivity.
  11.135 +*)
  11.136 +
  11.137 +(* replace parameters of product type by individual component parameters *)
  11.138 +local
  11.139 +  fun exists_paired_all prem =   (* FIXME check deeper nesting of params!?! *)
  11.140 +    Library.exists (can HOLogic.dest_prodT o #2) (Logic.strip_params prem);
  11.141 +  val ss = HOL_basic_ss
  11.142 +    addsimps [split_paired_all, unit_all_eq2, unit_abs_eta_conv]
  11.143 +    addsimprocs [unit_eq_proc];
  11.144 +  val split_tac = full_simp_tac ss;
  11.145 +in
  11.146 +  val split_all_tac = SUBGOAL (fn (prem,i) =>
  11.147 +    if exists_paired_all prem then split_tac i else no_tac);
  11.148 +end;
  11.149 +
  11.150 +claset_ref() := claset()
  11.151 +  addSWrapper ("split_all_tac", fn tac2 => split_all_tac ORELSE' tac2);
  11.152 +
  11.153 +Goal "(!x. P x) = (!a b. P(a,b))";
  11.154 +by (Fast_tac 1);
  11.155 +qed "split_paired_All";
  11.156 +Addsimps [split_paired_All];
  11.157 +(* AddIffs is not a good idea because it makes Blast_tac loop *)
  11.158 +
  11.159 +bind_thm ("prod_induct",
  11.160 +  allI RS (allI RS (split_paired_All RS iffD2)) RS spec);
  11.161 +
  11.162 +Goal "(? x. P x) = (? a b. P(a,b))";
  11.163 +by (Fast_tac 1);
  11.164 +qed "split_paired_Ex";
  11.165 +Addsimps [split_paired_Ex];
  11.166 +
  11.167 +Goalw [split_def] "split c (a,b) = c a b";
  11.168 +by (Simp_tac 1);
  11.169 +qed "split";
  11.170 +Addsimps [split];
  11.171 +
  11.172 +(*Subsumes the old split_Pair when f is the identity function*)
  11.173 +Goal "split (%x y. f(x,y)) = f";
  11.174 +by (rtac ext 1);
  11.175 +by (pair_tac "x" 1);
  11.176 +by (Simp_tac 1);
  11.177 +qed "split_Pair_apply";
  11.178 +
  11.179 +(*Can't be added to simpset: loops!*)
  11.180 +Goal "(SOME x. P x) = (SOME (a,b). P(a,b))";
  11.181 +by (simp_tac (simpset() addsimps [split_Pair_apply]) 1);
  11.182 +qed "split_paired_Eps";
  11.183 +
  11.184 +Goal "!!s t. (s=t) = (fst(s)=fst(t) & snd(s)=snd(t))";
  11.185 +by (split_all_tac 1);
  11.186 +by (Asm_simp_tac 1);
  11.187 +qed "Pair_fst_snd_eq";
  11.188 +
  11.189 +Goal "fst p = fst q ==> snd p = snd q ==> p = q";
  11.190 +by (asm_simp_tac (simpset() addsimps [Pair_fst_snd_eq]) 1);
  11.191 +qed "prod_eqI";
  11.192 +AddXIs [prod_eqI];
  11.193 +
  11.194 +(*Prevents simplification of c: much faster*)
  11.195 +Goal "p=q ==> split c p = split c q";
  11.196 +by (etac arg_cong 1);
  11.197 +qed "split_weak_cong";
  11.198 +
  11.199 +Goal "(%(x,y). f(x,y)) = f";
  11.200 +by (rtac ext 1);
  11.201 +by (split_all_tac 1);
  11.202 +by (rtac split 1);
  11.203 +qed "split_eta";
  11.204 +
  11.205 +val prems = Goal "(!!x y. f x y = g(x,y)) ==> (%(x,y). f x y) = g";
  11.206 +by (asm_simp_tac (simpset() addsimps prems@[split_eta]) 1);
  11.207 +qed "cond_split_eta";
  11.208 +
  11.209 +(*simplification procedure for cond_split_eta.
  11.210 +  using split_eta a rewrite rule is not general enough, and using
  11.211 +  cond_split_eta directly would render some existing proofs very inefficient.
  11.212 +  similarly for split_beta. *)
  11.213 +local
  11.214 +  fun  Pair_pat k 0 (Bound m) = (m = k)
  11.215 +  |    Pair_pat k i (Const ("Pair",  _) $ Bound m $ t) = i > 0 andalso
  11.216 +                        m = k+i andalso Pair_pat k (i-1) t
  11.217 +  |    Pair_pat _ _ _ = false;
  11.218 +  fun no_args k i (Abs (_, _, t)) = no_args (k+1) i t
  11.219 +  |   no_args k i (t $ u) = no_args k i t andalso no_args k i u
  11.220 +  |   no_args k i (Bound m) = m < k orelse m > k+i
  11.221 +  |   no_args _ _ _ = true;
  11.222 +  fun split_pat tp i (Abs  (_,_,t)) = if tp 0 i t then Some (i,t) else None
  11.223 +  |   split_pat tp i (Const ("split", _) $ Abs (_, _, t)) = split_pat tp (i+1) t
  11.224 +  |   split_pat tp i _ = None;
  11.225 +  fun metaeq sg lhs rhs = mk_meta_eq (prove_goalw_cterm []
  11.226 +        (cterm_of sg (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs))))
  11.227 +        (K [simp_tac (HOL_basic_ss addsimps [cond_split_eta]) 1]));
  11.228 +  val sign = sign_of (the_context ());
  11.229 +  fun simproc name patstr = Simplifier.mk_simproc name
  11.230 +                [Thm.read_cterm sign (patstr, HOLogic.termT)];
  11.231 +
  11.232 +  val beta_patstr = "split f z";
  11.233 +  val  eta_patstr = "split f";
  11.234 +  fun beta_term_pat k i (Abs (_, _, t)) = beta_term_pat (k+1) i t
  11.235 +  |   beta_term_pat k i (t $ u) = Pair_pat k i (t $ u) orelse
  11.236 +                        (beta_term_pat k i t andalso beta_term_pat k i u)
  11.237 +  |   beta_term_pat k i t = no_args k i t;
  11.238 +  fun  eta_term_pat k i (f $ arg) = no_args k i f andalso Pair_pat k i arg
  11.239 +  |    eta_term_pat _ _ _ = false;
  11.240 +  fun subst arg k i (Abs (x, T, t)) = Abs (x, T, subst arg (k+1) i t)
  11.241 +  |   subst arg k i (t $ u) = if Pair_pat k i (t $ u) then incr_boundvars k arg
  11.242 +                              else (subst arg k i t $ subst arg k i u)
  11.243 +  |   subst arg k i t = t;
  11.244 +  fun beta_proc sg _ (s as Const ("split", _) $ Abs (_, _, t) $ arg) =
  11.245 +        (case split_pat beta_term_pat 1 t of
  11.246 +        Some (i,f) => Some (metaeq sg s (subst arg 0 i f))
  11.247 +        | None => None)
  11.248 +  |   beta_proc _ _ _ = None;
  11.249 +  fun eta_proc sg _ (s as Const ("split", _) $ Abs (_, _, t)) =
  11.250 +        (case split_pat eta_term_pat 1 t of
  11.251 +          Some (_,ft) => Some (metaeq sg s (let val (f $ arg) = ft in f end))
  11.252 +        | None => None)
  11.253 +  |   eta_proc _ _ _ = None;
  11.254 +in
  11.255 +  val split_beta_proc = simproc "split_beta" beta_patstr beta_proc;
  11.256 +  val split_eta_proc  = simproc "split_eta"   eta_patstr  eta_proc;
  11.257 +end;
  11.258 +
  11.259 +Addsimprocs [split_beta_proc,split_eta_proc];
  11.260 +
  11.261 +Goal "(%(x,y). P x y) z = P (fst z) (snd z)";
  11.262 +by (stac surjective_pairing 1 THEN rtac split 1);
  11.263 +qed "split_beta";
  11.264 +
  11.265 +(*For use with split_tac and the simplifier*)
  11.266 +Goal "R (split c p) = (! x y. p = (x,y) --> R (c x y))";
  11.267 +by (stac surjective_pairing 1);
  11.268 +by (stac split 1);
  11.269 +by (Blast_tac 1);
  11.270 +qed "split_split";
  11.271 +
  11.272 +(* could be done after split_tac has been speeded up significantly:
  11.273 +simpset_ref() := simpset() addsplits [split_split];
  11.274 +   precompute the constants involved and don't do anything unless
  11.275 +   the current goal contains one of those constants
  11.276 +*)
  11.277 +
  11.278 +Goal "R (split c p) = (~(? x y. p = (x,y) & (~R (c x y))))";
  11.279 +by (stac split_split 1);
  11.280 +by (Simp_tac 1);
  11.281 +qed "expand_split_asm";
  11.282 +
  11.283 +(** split used as a logical connective or set former **)
  11.284 +
  11.285 +(*These rules are for use with blast_tac.
  11.286 +  Could instead call simp_tac/asm_full_simp_tac using split as rewrite.*)
  11.287 +
  11.288 +Goal "!!p. [| !!a b. p=(a,b) ==> c a b |] ==> split c p";
  11.289 +by (split_all_tac 1);
  11.290 +by (Asm_simp_tac 1);
  11.291 +qed "splitI2";
  11.292 +
  11.293 +Goal "!!p. [| !!a b. (a,b)=p ==> c a b x |] ==> split c p x";
  11.294 +by (split_all_tac 1);
  11.295 +by (Asm_simp_tac 1);
  11.296 +qed "splitI2'";
  11.297 +
  11.298 +Goal "c a b ==> split c (a,b)";
  11.299 +by (Asm_simp_tac 1);
  11.300 +qed "splitI";
  11.301 +
  11.302 +val prems = Goalw [split_def]
  11.303 +    "[| split c p;  !!x y. [| p = (x,y);  c x y |] ==> Q |] ==> Q";
  11.304 +by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
  11.305 +qed "splitE";
  11.306 +
  11.307 +val prems = Goalw [split_def]
  11.308 +    "[| split c p z;  !!x y. [| p = (x,y);  c x y z |] ==> Q |] ==> Q";
  11.309 +by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
  11.310 +qed "splitE'";
  11.311 +
  11.312 +val major::prems = Goal
  11.313 +    "[| Q (split P z);  !!x y. [|z = (x, y); Q (P x y)|] ==> R  \
  11.314 +\    |] ==> R";
  11.315 +by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
  11.316 +by (rtac (split_beta RS subst) 1 THEN rtac major 1);
  11.317 +qed "splitE2";
  11.318 +
  11.319 +Goal "split R (a,b) ==> R a b";
  11.320 +by (etac (split RS iffD1) 1);
  11.321 +qed "splitD";
  11.322 +
  11.323 +Goal "z: c a b ==> z: split c (a,b)";
  11.324 +by (Asm_simp_tac 1);
  11.325 +qed "mem_splitI";
  11.326 +
  11.327 +Goal "!!p. [| !!a b. p=(a,b) ==> z: c a b |] ==> z: split c p";
  11.328 +by (split_all_tac 1);
  11.329 +by (Asm_simp_tac 1);
  11.330 +qed "mem_splitI2";
  11.331 +
  11.332 +val prems = Goalw [split_def]
  11.333 +    "[| z: split c p;  !!x y. [| p = (x,y);  z: c x y |] ==> Q |] ==> Q";
  11.334 +by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
  11.335 +qed "mem_splitE";
  11.336 +
  11.337 +AddSIs [splitI, splitI2, splitI2', mem_splitI, mem_splitI2];
  11.338 +AddSEs [splitE, splitE', mem_splitE];
  11.339 +
  11.340 +Goal "(%u. ? x y. u = (x, y) & P (x, y)) = P";
  11.341 +by (rtac ext 1);
  11.342 +by (Fast_tac 1);
  11.343 +qed "split_eta_SetCompr";
  11.344 +Addsimps [split_eta_SetCompr];
  11.345 +
  11.346 +Goal "(%u. ? x y. u = (x, y) & P x y) = split P";
  11.347 +br ext 1;
  11.348 +by (Fast_tac 1);
  11.349 +qed "split_eta_SetCompr2";
  11.350 +Addsimps [split_eta_SetCompr2];
  11.351 +
  11.352 +(* allows simplifications of nested splits in case of independent predicates *)
  11.353 +Goal "(%(a,b). P & Q a b) = (%ab. P & split Q ab)";
  11.354 +by (rtac ext 1);
  11.355 +by (Blast_tac 1);
  11.356 +qed "split_part";
  11.357 +Addsimps [split_part];
  11.358 +
  11.359 +Goal "(@(x',y'). x = x' & y = y') = (x,y)";
  11.360 +by (Blast_tac 1);
  11.361 +qed "Eps_split_eq";
  11.362 +Addsimps [Eps_split_eq];
  11.363 +(*
  11.364 +the following  would be slightly more general,
  11.365 +but cannot be used as rewrite rule:
  11.366 +### Cannot add premise as rewrite rule because it contains (type) unknowns:
  11.367 +### ?y = .x
  11.368 +Goal "[| P y; !!x. P x ==> x = y |] ==> (@(x',y). x = x' & P y) = (x,y)";
  11.369 +by (rtac some_equality 1);
  11.370 +by ( Simp_tac 1);
  11.371 +by (split_all_tac 1);
  11.372 +by (Asm_full_simp_tac 1);
  11.373 +qed "Eps_split_eq";
  11.374 +*)
  11.375 +
  11.376 +(*** prod_fun -- action of the product functor upon functions ***)
  11.377 +
  11.378 +Goalw [prod_fun_def] "prod_fun f g (a,b) = (f(a),g(b))";
  11.379 +by (rtac split 1);
  11.380 +qed "prod_fun";
  11.381 +Addsimps [prod_fun];
  11.382 +
  11.383 +Goal "prod_fun (f1 o f2) (g1 o g2) = ((prod_fun f1 g1) o (prod_fun f2 g2))";
  11.384 +by (rtac ext 1);
  11.385 +by (pair_tac "x" 1);
  11.386 +by (Asm_simp_tac 1);
  11.387 +qed "prod_fun_compose";
  11.388 +
  11.389 +Goal "prod_fun (%x. x) (%y. y) = (%z. z)";
  11.390 +by (rtac ext 1);
  11.391 +by (pair_tac "z" 1);
  11.392 +by (Asm_simp_tac 1);
  11.393 +qed "prod_fun_ident";
  11.394 +Addsimps [prod_fun_ident];
  11.395 +
  11.396 +Goal "(a,b):r ==> (f(a),g(b)) : (prod_fun f g)``r";
  11.397 +by (rtac image_eqI 1);
  11.398 +by (rtac (prod_fun RS sym) 1);
  11.399 +by (assume_tac 1);
  11.400 +qed "prod_fun_imageI";
  11.401 +
  11.402 +val major::prems = Goal
  11.403 +    "[| c: (prod_fun f g)``r;  !!x y. [| c=(f(x),g(y));  (x,y):r |] ==> P  \
  11.404 +\    |] ==> P";
  11.405 +by (rtac (major RS imageE) 1);
  11.406 +by (res_inst_tac [("p","x")] PairE 1);
  11.407 +by (resolve_tac prems 1);
  11.408 +by (Blast_tac 2);
  11.409 +by (blast_tac (claset() addIs [prod_fun]) 1);
  11.410 +qed "prod_fun_imageE";
  11.411 +
  11.412 +AddIs  [prod_fun_imageI];
  11.413 +AddSEs [prod_fun_imageE];
  11.414 +
  11.415 +
  11.416 +(*** Disjoint union of a family of sets - Sigma ***)
  11.417 +
  11.418 +Goalw [Sigma_def] "[| a:A;  b:B(a) |] ==> (a,b) : Sigma A B";
  11.419 +by (REPEAT (ares_tac [singletonI,UN_I] 1));
  11.420 +qed "SigmaI";
  11.421 +
  11.422 +AddSIs [SigmaI];
  11.423 +
  11.424 +(*The general elimination rule*)
  11.425 +val major::prems = Goalw [Sigma_def]
  11.426 +    "[| c: Sigma A B;  \
  11.427 +\       !!x y.[| x:A;  y:B(x);  c=(x,y) |] ==> P \
  11.428 +\    |] ==> P";
  11.429 +by (cut_facts_tac [major] 1);
  11.430 +by (REPEAT (eresolve_tac [UN_E, singletonE] 1 ORELSE ares_tac prems 1)) ;
  11.431 +qed "SigmaE";
  11.432 +
  11.433 +(** Elimination of (a,b):A*B -- introduces no eigenvariables **)
  11.434 +
  11.435 +Goal "(a,b) : Sigma A B ==> a : A";
  11.436 +by (etac SigmaE 1);
  11.437 +by (REPEAT (eresolve_tac [asm_rl,Pair_inject,ssubst] 1)) ;
  11.438 +qed "SigmaD1";
  11.439 +
  11.440 +Goal "(a,b) : Sigma A B ==> b : B(a)";
  11.441 +by (etac SigmaE 1);
  11.442 +by (REPEAT (eresolve_tac [asm_rl,Pair_inject,ssubst] 1)) ;
  11.443 +qed "SigmaD2";
  11.444 +
  11.445 +val [major,minor]= Goal
  11.446 +    "[| (a,b) : Sigma A B;    \
  11.447 +\       [| a:A;  b:B(a) |] ==> P   \
  11.448 +\    |] ==> P";
  11.449 +by (rtac minor 1);
  11.450 +by (rtac (major RS SigmaD1) 1);
  11.451 +by (rtac (major RS SigmaD2) 1) ;
  11.452 +qed "SigmaE2";
  11.453 +
  11.454 +AddSEs [SigmaE2, SigmaE];
  11.455 +
  11.456 +val prems = Goal
  11.457 +    "[| A<=C;  !!x. x:A ==> B x <= D x |] ==> Sigma A B <= Sigma C D";
  11.458 +by (cut_facts_tac prems 1);
  11.459 +by (blast_tac (claset() addIs (prems RL [subsetD])) 1);
  11.460 +qed "Sigma_mono";
  11.461 +
  11.462 +Goal "Sigma {} B = {}";
  11.463 +by (Blast_tac 1) ;
  11.464 +qed "Sigma_empty1";
  11.465 +
  11.466 +Goal "A <*> {} = {}";
  11.467 +by (Blast_tac 1) ;
  11.468 +qed "Sigma_empty2";
  11.469 +
  11.470 +Addsimps [Sigma_empty1,Sigma_empty2];
  11.471 +
  11.472 +Goal "UNIV <*> UNIV = UNIV";
  11.473 +by Auto_tac;
  11.474 +qed "UNIV_Times_UNIV";
  11.475 +Addsimps [UNIV_Times_UNIV];
  11.476 +
  11.477 +Goal "- (UNIV <*> A) = UNIV <*> (-A)";
  11.478 +by Auto_tac;
  11.479 +qed "Compl_Times_UNIV1";
  11.480 +
  11.481 +Goal "- (A <*> UNIV) = (-A) <*> UNIV";
  11.482 +by Auto_tac;
  11.483 +qed "Compl_Times_UNIV2";
  11.484 +
  11.485 +Addsimps [Compl_Times_UNIV1, Compl_Times_UNIV2];
  11.486 +
  11.487 +Goal "((a,b): Sigma A B) = (a:A & b:B(a))";
  11.488 +by (Blast_tac 1);
  11.489 +qed "mem_Sigma_iff";
  11.490 +AddIffs [mem_Sigma_iff];
  11.491 +
  11.492 +Goal "x:C ==> (A <*> C <= B <*> C) = (A <= B)";
  11.493 +by (Blast_tac 1);
  11.494 +qed "Times_subset_cancel2";
  11.495 +
  11.496 +Goal "x:C ==> (A <*> C = B <*> C) = (A = B)";
  11.497 +by (blast_tac (claset() addEs [equalityE]) 1);
  11.498 +qed "Times_eq_cancel2";
  11.499 +
  11.500 +Goal "Collect (split (%x y. P x & Q x y)) = (SIGMA x:Collect P. Collect (Q x))";
  11.501 +by (Fast_tac 1);
  11.502 +qed "SetCompr_Sigma_eq";
  11.503 +
  11.504 +(*** Complex rules for Sigma ***)
  11.505 +
  11.506 +Goal "{(a,b). P a & Q b} = Collect P <*> Collect Q";
  11.507 +by (Blast_tac 1);
  11.508 +qed "Collect_split";
  11.509 +
  11.510 +Addsimps [Collect_split];
  11.511 +
  11.512 +(*Suggested by Pierre Chartier*)
  11.513 +Goal "(UN (a,b):(A <*> B). E a <*> F b) = (UNION A E) <*> (UNION B F)";
  11.514 +by (Blast_tac 1);
  11.515 +qed "UN_Times_distrib";
  11.516 +
  11.517 +Goal "(ALL z: Sigma A B. P z) = (ALL x:A. ALL y: B x. P(x,y))";
  11.518 +by (Fast_tac 1);
  11.519 +qed "split_paired_Ball_Sigma";
  11.520 +Addsimps [split_paired_Ball_Sigma];
  11.521 +
  11.522 +Goal "(EX z: Sigma A B. P z) = (EX x:A. EX y: B x. P(x,y))";
  11.523 +by (Fast_tac 1);
  11.524 +qed "split_paired_Bex_Sigma";
  11.525 +Addsimps [split_paired_Bex_Sigma];
  11.526 +
  11.527 +Goal "(SIGMA i:I Un J. C(i)) = (SIGMA i:I. C(i)) Un (SIGMA j:J. C(j))";
  11.528 +by (Blast_tac 1);
  11.529 +qed "Sigma_Un_distrib1";
  11.530 +
  11.531 +Goal "(SIGMA i:I. A(i) Un B(i)) = (SIGMA i:I. A(i)) Un (SIGMA i:I. B(i))";
  11.532 +by (Blast_tac 1);
  11.533 +qed "Sigma_Un_distrib2";
  11.534 +
  11.535 +Goal "(SIGMA i:I Int J. C(i)) = (SIGMA i:I. C(i)) Int (SIGMA j:J. C(j))";
  11.536 +by (Blast_tac 1);
  11.537 +qed "Sigma_Int_distrib1";
  11.538 +
  11.539 +Goal "(SIGMA i:I. A(i) Int B(i)) = (SIGMA i:I. A(i)) Int (SIGMA i:I. B(i))";
  11.540 +by (Blast_tac 1);
  11.541 +qed "Sigma_Int_distrib2";
  11.542 +
  11.543 +Goal "(SIGMA i:I - J. C(i)) = (SIGMA i:I. C(i)) - (SIGMA j:J. C(j))";
  11.544 +by (Blast_tac 1);
  11.545 +qed "Sigma_Diff_distrib1";
  11.546 +
  11.547 +Goal "(SIGMA i:I. A(i) - B(i)) = (SIGMA i:I. A(i)) - (SIGMA i:I. B(i))";
  11.548 +by (Blast_tac 1);
  11.549 +qed "Sigma_Diff_distrib2";
  11.550 +
  11.551 +Goal "Sigma (Union X) B = (UN A:X. Sigma A B)";
  11.552 +by (Blast_tac 1);
  11.553 +qed "Sigma_Union";
  11.554 +
  11.555 +(*Non-dependent versions are needed to avoid the need for higher-order
  11.556 +  matching, especially when the rules are re-oriented*)
  11.557 +Goal "(A Un B) <*> C = (A <*> C) Un (B <*> C)";
  11.558 +by (Blast_tac 1);
  11.559 +qed "Times_Un_distrib1";
  11.560 +
  11.561 +Goal "(A Int B) <*> C = (A <*> C) Int (B <*> C)";
  11.562 +by (Blast_tac 1);
  11.563 +qed "Times_Int_distrib1";
  11.564 +
  11.565 +Goal "(A - B) <*> C = (A <*> C) - (B <*> C)";
  11.566 +by (Blast_tac 1);
  11.567 +qed "Times_Diff_distrib1";
  11.568 +
  11.569 +
  11.570 +(*Attempts to remove occurrences of split, and pair-valued parameters*)
  11.571 +val remove_split = rewrite_rule [split RS eq_reflection] o
  11.572 +                   rule_by_tactic (TRYALL split_all_tac);
  11.573 +
  11.574 +local
  11.575 +
  11.576 +(*In ap_split S T u, term u expects separate arguments for the factors of S,
  11.577 +  with result type T.  The call creates a new term expecting one argument
  11.578 +  of type S.*)
  11.579 +fun ap_split (Type ("*", [T1, T2])) T3 u =
  11.580 +      HOLogic.split_const (T1, T2, T3) $
  11.581 +      Abs("v", T1,
  11.582 +          ap_split T2 T3
  11.583 +             ((ap_split T1 (HOLogic.prodT_factors T2 ---> T3) (incr_boundvars 1 u)) $
  11.584 +              Bound 0))
  11.585 +  | ap_split T T3 u = u;
  11.586 +
  11.587 +(*Curries any Var of function type in the rule*)
  11.588 +fun split_rule_var' (t as Var (v, Type ("fun", [T1, T2])), rl) =
  11.589 +      let val T' = HOLogic.prodT_factors T1 ---> T2
  11.590 +          val newt = ap_split T1 T2 (Var (v, T'))
  11.591 +          val cterm = Thm.cterm_of (#sign (rep_thm rl))
  11.592 +      in
  11.593 +          instantiate ([], [(cterm t, cterm newt)]) rl
  11.594 +      end
  11.595 +  | split_rule_var' (t, rl) = rl;
  11.596 +
  11.597 +in
  11.598 +
  11.599 +val split_rule_var = standard o remove_split o split_rule_var';
  11.600 +
  11.601 +(*Curries ALL function variables occurring in a rule's conclusion*)
  11.602 +fun split_rule rl = remove_split (foldr split_rule_var' (term_vars (concl_of rl), rl))
  11.603 +                    |> standard;
  11.604 +
  11.605 +end;
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Product_Type.thy	Thu Oct 12 18:44:35 2000 +0200
    12.3 @@ -0,0 +1,109 @@
    12.4 +(*  Title:      HOL/Product_Type.thy
    12.5 +    ID:         $Id$
    12.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    12.7 +    Copyright   1992  University of Cambridge
    12.8 +
    12.9 +Ordered Pairs and the Cartesian product type.
   12.10 +The unit type.
   12.11 +*)
   12.12 +
   12.13 +Product_Type = Fun + equalities +
   12.14 +
   12.15 +
   12.16 +(** products **)
   12.17 +
   12.18 +(* type definition *)
   12.19 +
   12.20 +constdefs
   12.21 +  Pair_Rep      :: ['a, 'b] => ['a, 'b] => bool
   12.22 +  "Pair_Rep == (%a b. %x y. x=a & y=b)"
   12.23 +
   12.24 +global
   12.25 +
   12.26 +typedef (Prod)
   12.27 +  ('a, 'b) "*"          (infixr 20)
   12.28 +    = "{f. ? a b. f = Pair_Rep (a::'a) (b::'b)}"
   12.29 +
   12.30 +syntax (symbols)
   12.31 +  "*"           :: [type, type] => type         ("(_ \\<times>/ _)" [21, 20] 20)
   12.32 +
   12.33 +syntax (HTML output)
   12.34 +  "*"           :: [type, type] => type         ("(_ \\<times>/ _)" [21, 20] 20)
   12.35 +
   12.36 +
   12.37 +(* abstract constants and syntax *)
   12.38 +
   12.39 +consts
   12.40 +  fst           :: "'a * 'b => 'a"
   12.41 +  snd           :: "'a * 'b => 'b"
   12.42 +  split         :: "[['a, 'b] => 'c, 'a * 'b] => 'c"
   12.43 +  prod_fun      :: "['a => 'b, 'c => 'd, 'a * 'c] => 'b * 'd"
   12.44 +  Pair          :: "['a, 'b] => 'a * 'b"
   12.45 +  Sigma         :: "['a set, 'a => 'b set] => ('a * 'b) set"
   12.46 +
   12.47 +
   12.48 +(* patterns -- extends pre-defined type "pttrn" used in abstractions *)
   12.49 +
   12.50 +nonterminals
   12.51 +  tuple_args patterns
   12.52 +
   12.53 +syntax
   12.54 +  "_tuple"      :: "'a => tuple_args => 'a * 'b"        ("(1'(_,/ _'))")
   12.55 +  "_tuple_arg"  :: "'a => tuple_args"                   ("_")
   12.56 +  "_tuple_args" :: "'a => tuple_args => tuple_args"     ("_,/ _")
   12.57 +  "_pattern"    :: [pttrn, patterns] => pttrn           ("'(_,/ _')")
   12.58 +  ""            :: pttrn => patterns                    ("_")
   12.59 +  "_patterns"   :: [pttrn, patterns] => patterns        ("_,/ _")
   12.60 +  "@Sigma"      :: "[pttrn, 'a set, 'b set] => ('a * 'b) set"   ("(3SIGMA _:_./ _)" 10)
   12.61 +  "@Times"      :: "['a set, 'a => 'b set] => ('a * 'b) set"    (infixr "<*>" 80)
   12.62 +
   12.63 +translations
   12.64 +  "(x, y)"       == "Pair x y"
   12.65 +  "_tuple x (_tuple_args y z)" == "_tuple x (_tuple_arg (_tuple y z))"
   12.66 +  "%(x,y,zs).b"  == "split(%x (y,zs).b)"
   12.67 +  "%(x,y).b"     == "split(%x y. b)"
   12.68 +  "_abs (Pair x y) t" => "%(x,y).t"
   12.69 +  (* The last rule accommodates tuples in `case C ... (x,y) ... => ...'
   12.70 +     The (x,y) is parsed as `Pair x y' because it is logic, not pttrn *)
   12.71 +
   12.72 +  "SIGMA x:A. B" => "Sigma A (%x. B)"
   12.73 +  "A <*> B"      => "Sigma A (_K B)"
   12.74 +
   12.75 +syntax (symbols)
   12.76 +  "@Sigma"      :: "[pttrn, 'a set, 'b set] => ('a * 'b) set"   ("(3\\<Sigma> _\\<in>_./ _)" 10)
   12.77 +  "@Times"      :: "['a set, 'a => 'b set] => ('a * 'b) set"    ("_ \\<times> _" [81, 80] 80)
   12.78 +
   12.79 +
   12.80 +(* definitions *)
   12.81 +
   12.82 +local
   12.83 +
   12.84 +defs
   12.85 +  Pair_def      "Pair a b == Abs_Prod(Pair_Rep a b)"
   12.86 +  fst_def       "fst p == @a. ? b. p = (a, b)"
   12.87 +  snd_def       "snd p == @b. ? a. p = (a, b)"
   12.88 +  split_def     "split == (%c p. c (fst p) (snd p))"
   12.89 +  prod_fun_def  "prod_fun f g == split(%x y.(f(x), g(y)))"
   12.90 +  Sigma_def     "Sigma A B == UN x:A. UN y:B(x). {(x, y)}"
   12.91 +
   12.92 +
   12.93 +
   12.94 +(** unit **)
   12.95 +
   12.96 +global
   12.97 +
   12.98 +typedef  unit = "{True}"
   12.99 +
  12.100 +consts
  12.101 +  "()"          :: unit                           ("'(')")
  12.102 +
  12.103 +local
  12.104 +
  12.105 +defs
  12.106 +  Unity_def     "() == Abs_unit True"
  12.107 +
  12.108 +end
  12.109 +
  12.110 +ML
  12.111 +
  12.112 +val print_translation = [("Sigma", dependent_tr' ("@Sigma", "@Times"))];
    13.1 --- a/src/HOL/RelPow.ML	Thu Oct 12 18:38:23 2000 +0200
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,117 +0,0 @@
    13.4 -(*  Title:      HOL/RelPow.ML
    13.5 -    ID:         $Id$
    13.6 -    Author:     Tobias Nipkow
    13.7 -    Copyright   1996  TU Muenchen
    13.8 -*)
    13.9 -
   13.10 -open RelPow;
   13.11 -
   13.12 -Goal "!!R:: ('a*'a)set. R^1 = R";
   13.13 -by (Simp_tac 1);
   13.14 -qed "rel_pow_1";
   13.15 -Addsimps [rel_pow_1];
   13.16 -
   13.17 -Goal "(x,x) : R^0";
   13.18 -by (Simp_tac 1);
   13.19 -qed "rel_pow_0_I";
   13.20 -
   13.21 -Goal "[| (x,y) : R^n; (y,z):R |] ==> (x,z):R^(Suc n)";
   13.22 -by (Simp_tac  1);
   13.23 -by (Blast_tac 1);
   13.24 -qed "rel_pow_Suc_I";
   13.25 -
   13.26 -Goal "!z. (x,y) : R --> (y,z):R^n -->  (x,z):R^(Suc n)";
   13.27 -by (induct_tac "n" 1);
   13.28 -by (Simp_tac  1);
   13.29 -by (Asm_full_simp_tac 1);
   13.30 -by (Blast_tac 1);
   13.31 -qed_spec_mp "rel_pow_Suc_I2";
   13.32 -
   13.33 -Goal "!!R. [| (x,y) : R^0; x=y ==> P |] ==> P";
   13.34 -by (Asm_full_simp_tac 1);
   13.35 -qed "rel_pow_0_E";
   13.36 -
   13.37 -val [major,minor] = Goal
   13.38 -  "[| (x,z) : R^(Suc n);  !!y. [| (x,y) : R^n; (y,z) : R |] ==> P |] ==> P";
   13.39 -by (cut_facts_tac [major] 1);
   13.40 -by (Asm_full_simp_tac  1);
   13.41 -by (blast_tac (claset() addIs [minor]) 1);
   13.42 -qed "rel_pow_Suc_E";
   13.43 -
   13.44 -val [p1,p2,p3] = Goal
   13.45 -    "[| (x,z) : R^n;  [| n=0; x = z |] ==> P;        \
   13.46 -\       !!y m. [| n = Suc m; (x,y) : R^m; (y,z) : R |] ==> P  \
   13.47 -\    |] ==> P";
   13.48 -by (cut_facts_tac [p1] 1);
   13.49 -by (case_tac "n" 1);
   13.50 -by (asm_full_simp_tac (simpset() addsimps [p2]) 1);
   13.51 -by (Asm_full_simp_tac 1);
   13.52 -by (etac compEpair 1);
   13.53 -by (REPEAT(ares_tac [p3] 1));
   13.54 -qed "rel_pow_E";
   13.55 -
   13.56 -Goal "!x z. (x,z):R^(Suc n) --> (? y. (x,y):R & (y,z):R^n)";
   13.57 -by (induct_tac "n" 1);
   13.58 -by (blast_tac (claset() addIs [rel_pow_0_I] 
   13.59 -	                addEs [rel_pow_0_E,rel_pow_Suc_E]) 1);
   13.60 -by (blast_tac (claset() addIs [rel_pow_Suc_I]  
   13.61 -	                addEs [rel_pow_0_E,rel_pow_Suc_E]) 1);
   13.62 -qed_spec_mp "rel_pow_Suc_D2";
   13.63 -
   13.64 -
   13.65 -Goal "!x y z. (x,y) : R^n & (y,z) : R --> (? w. (x,w) : R & (w,z) : R^n)";
   13.66 -by (induct_tac "n" 1);
   13.67 -by (ALLGOALS Asm_simp_tac);
   13.68 -by (Blast_tac 1);
   13.69 -qed_spec_mp "rel_pow_Suc_D2'";
   13.70 -
   13.71 -val [p1,p2,p3] = Goal
   13.72 -    "[| (x,z) : R^n;  [| n=0; x = z |] ==> P;        \
   13.73 -\       !!y m. [| n = Suc m; (x,y) : R; (y,z) : R^m |] ==> P  \
   13.74 -\    |] ==> P";
   13.75 -by (cut_facts_tac [p1] 1);
   13.76 -by (case_tac "n" 1);
   13.77 -by (asm_full_simp_tac (simpset() addsimps [p2]) 1);
   13.78 -by (Asm_full_simp_tac 1);
   13.79 -by (etac compEpair 1);
   13.80 -by (dtac (conjI RS rel_pow_Suc_D2') 1);
   13.81 -by (assume_tac 1);
   13.82 -by (etac exE 1);
   13.83 -by (etac p3 1);
   13.84 -by (etac conjunct1 1);
   13.85 -by (etac conjunct2 1);
   13.86 -qed "rel_pow_E2";
   13.87 -
   13.88 -Goal "!!p. p:R^* ==> p : (UN n. R^n)";
   13.89 -by (split_all_tac 1);
   13.90 -by (etac rtrancl_induct 1);
   13.91 -by (ALLGOALS (blast_tac (claset() addIs [rel_pow_0_I,rel_pow_Suc_I])));
   13.92 -qed "rtrancl_imp_UN_rel_pow";
   13.93 -
   13.94 -Goal "!y. (x,y):R^n --> (x,y):R^*";
   13.95 -by (induct_tac "n" 1);
   13.96 -by (blast_tac (claset() addIs [rtrancl_refl] addEs [rel_pow_0_E]) 1);
   13.97 -by (blast_tac (claset() addEs [rel_pow_Suc_E]
   13.98 -                       addIs [rtrancl_into_rtrancl]) 1);
   13.99 -val lemma = result() RS spec RS mp;
  13.100 -
  13.101 -Goal "!!p. p:R^n ==> p:R^*";
  13.102 -by (split_all_tac 1);
  13.103 -by (etac lemma 1);
  13.104 -qed "rel_pow_imp_rtrancl";
  13.105 -
  13.106 -Goal "R^* = (UN n. R^n)";
  13.107 -by (blast_tac (claset() addIs [rtrancl_imp_UN_rel_pow, rel_pow_imp_rtrancl]) 1);
  13.108 -qed "rtrancl_is_UN_rel_pow";
  13.109 -
  13.110 -
  13.111 -Goal "!!r::('a * 'a)set. univalent r ==> univalent (r^n)";
  13.112 -by (rtac univalentI 1);
  13.113 -by (induct_tac "n" 1);
  13.114 - by (Simp_tac 1);
  13.115 -by (fast_tac (claset() addDs [univalentD] addEs [rel_pow_Suc_E]) 1);
  13.116 -qed_spec_mp "univalent_rel_pow";
  13.117 -
  13.118 -
  13.119 -
  13.120 -
    14.1 --- a/src/HOL/RelPow.thy	Thu Oct 12 18:38:23 2000 +0200
    14.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.3 @@ -1,18 +0,0 @@
    14.4 -(*  Title:      HOL/RelPow.thy
    14.5 -    ID:         $Id$
    14.6 -    Author:     Tobias Nipkow
    14.7 -    Copyright   1996  TU Muenchen
    14.8 -
    14.9 -R^n = R O ... O R, the n-fold composition of R
   14.10 -*)
   14.11 -
   14.12 -RelPow = Nat +
   14.13 -
   14.14 -instance
   14.15 -  set :: (term) {power}   (* only ('a * 'a) set should be in power! *)
   14.16 -
   14.17 -primrec (relpow)
   14.18 -  "R^0 = Id"
   14.19 -  "R^(Suc n) = R O (R^n)"
   14.20 -
   14.21 -end
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/Relation_Power.ML	Thu Oct 12 18:44:35 2000 +0200
    15.3 @@ -0,0 +1,115 @@
    15.4 +(*  Title:      HOL/Relation_Power.ML
    15.5 +    ID:         $Id$
    15.6 +    Author:     Tobias Nipkow
    15.7 +    Copyright   1996  TU Muenchen
    15.8 +*)
    15.9 +
   15.10 +Goal "!!R:: ('a*'a)set. R^1 = R";
   15.11 +by (Simp_tac 1);
   15.12 +qed "rel_pow_1";
   15.13 +Addsimps [rel_pow_1];
   15.14 +
   15.15 +Goal "(x,x) : R^0";
   15.16 +by (Simp_tac 1);
   15.17 +qed "rel_pow_0_I";
   15.18 +
   15.19 +Goal "[| (x,y) : R^n; (y,z):R |] ==> (x,z):R^(Suc n)";
   15.20 +by (Simp_tac  1);
   15.21 +by (Blast_tac 1);
   15.22 +qed "rel_pow_Suc_I";
   15.23 +
   15.24 +Goal "!z. (x,y) : R --> (y,z):R^n -->  (x,z):R^(Suc n)";
   15.25 +by (induct_tac "n" 1);
   15.26 +by (Simp_tac  1);
   15.27 +by (Asm_full_simp_tac 1);
   15.28 +by (Blast_tac 1);
   15.29 +qed_spec_mp "rel_pow_Suc_I2";
   15.30 +
   15.31 +Goal "!!R. [| (x,y) : R^0; x=y ==> P |] ==> P";
   15.32 +by (Asm_full_simp_tac 1);
   15.33 +qed "rel_pow_0_E";
   15.34 +
   15.35 +val [major,minor] = Goal
   15.36 +  "[| (x,z) : R^(Suc n);  !!y. [| (x,y) : R^n; (y,z) : R |] ==> P |] ==> P";
   15.37 +by (cut_facts_tac [major] 1);
   15.38 +by (Asm_full_simp_tac  1);
   15.39 +by (blast_tac (claset() addIs [minor]) 1);
   15.40 +qed "rel_pow_Suc_E";
   15.41 +
   15.42 +val [p1,p2,p3] = Goal
   15.43 +    "[| (x,z) : R^n;  [| n=0; x = z |] ==> P;        \
   15.44 +\       !!y m. [| n = Suc m; (x,y) : R^m; (y,z) : R |] ==> P  \
   15.45 +\    |] ==> P";
   15.46 +by (cut_facts_tac [p1] 1);
   15.47 +by (case_tac "n" 1);
   15.48 +by (asm_full_simp_tac (simpset() addsimps [p2]) 1);
   15.49 +by (Asm_full_simp_tac 1);
   15.50 +by (etac compEpair 1);
   15.51 +by (REPEAT(ares_tac [p3] 1));
   15.52 +qed "rel_pow_E";
   15.53 +
   15.54 +Goal "!x z. (x,z):R^(Suc n) --> (? y. (x,y):R & (y,z):R^n)";
   15.55 +by (induct_tac "n" 1);
   15.56 +by (blast_tac (claset() addIs [rel_pow_0_I] 
   15.57 +	                addEs [rel_pow_0_E,rel_pow_Suc_E]) 1);
   15.58 +by (blast_tac (claset() addIs [rel_pow_Suc_I]  
   15.59 +	                addEs [rel_pow_0_E,rel_pow_Suc_E]) 1);
   15.60 +qed_spec_mp "rel_pow_Suc_D2";
   15.61 +
   15.62 +
   15.63 +Goal "!x y z. (x,y) : R^n & (y,z) : R --> (? w. (x,w) : R & (w,z) : R^n)";
   15.64 +by (induct_tac "n" 1);
   15.65 +by (ALLGOALS Asm_simp_tac);
   15.66 +by (Blast_tac 1);
   15.67 +qed_spec_mp "rel_pow_Suc_D2'";
   15.68 +
   15.69 +val [p1,p2,p3] = Goal
   15.70 +    "[| (x,z) : R^n;  [| n=0; x = z |] ==> P;        \
   15.71 +\       !!y m. [| n = Suc m; (x,y) : R; (y,z) : R^m |] ==> P  \
   15.72 +\    |] ==> P";
   15.73 +by (cut_facts_tac [p1] 1);
   15.74 +by (case_tac "n" 1);
   15.75 +by (asm_full_simp_tac (simpset() addsimps [p2]) 1);
   15.76 +by (Asm_full_simp_tac 1);
   15.77 +by (etac compEpair 1);
   15.78 +by (dtac (conjI RS rel_pow_Suc_D2') 1);
   15.79 +by (assume_tac 1);
   15.80 +by (etac exE 1);
   15.81 +by (etac p3 1);
   15.82 +by (etac conjunct1 1);
   15.83 +by (etac conjunct2 1);
   15.84 +qed "rel_pow_E2";
   15.85 +
   15.86 +Goal "!!p. p:R^* ==> p : (UN n. R^n)";
   15.87 +by (split_all_tac 1);
   15.88 +by (etac rtrancl_induct 1);
   15.89 +by (ALLGOALS (blast_tac (claset() addIs [rel_pow_0_I,rel_pow_Suc_I])));
   15.90 +qed "rtrancl_imp_UN_rel_pow";
   15.91 +
   15.92 +Goal "!y. (x,y):R^n --> (x,y):R^*";
   15.93 +by (induct_tac "n" 1);
   15.94 +by (blast_tac (claset() addIs [rtrancl_refl] addEs [rel_pow_0_E]) 1);
   15.95 +by (blast_tac (claset() addEs [rel_pow_Suc_E]
   15.96 +                       addIs [rtrancl_into_rtrancl]) 1);
   15.97 +val lemma = result() RS spec RS mp;
   15.98 +
   15.99 +Goal "!!p. p:R^n ==> p:R^*";
  15.100 +by (split_all_tac 1);
  15.101 +by (etac lemma 1);
  15.102 +qed "rel_pow_imp_rtrancl";
  15.103 +
  15.104 +Goal "R^* = (UN n. R^n)";
  15.105 +by (blast_tac (claset() addIs [rtrancl_imp_UN_rel_pow, rel_pow_imp_rtrancl]) 1);
  15.106 +qed "rtrancl_is_UN_rel_pow";
  15.107 +
  15.108 +
  15.109 +Goal "!!r::('a * 'a)set. univalent r ==> univalent (r^n)";
  15.110 +by (rtac univalentI 1);
  15.111 +by (induct_tac "n" 1);
  15.112 + by (Simp_tac 1);
  15.113 +by (fast_tac (claset() addDs [univalentD] addEs [rel_pow_Suc_E]) 1);
  15.114 +qed_spec_mp "univalent_rel_pow";
  15.115 +
  15.116 +
  15.117 +
  15.118 +
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/Relation_Power.thy	Thu Oct 12 18:44:35 2000 +0200
    16.3 @@ -0,0 +1,18 @@
    16.4 +(*  Title:      HOL/Relation_Power.thy
    16.5 +    ID:         $Id$
    16.6 +    Author:     Tobias Nipkow
    16.7 +    Copyright   1996  TU Muenchen
    16.8 +
    16.9 +R^n = R O ... O R, the n-fold composition of R
   16.10 +*)
   16.11 +
   16.12 +Relation_Power = Nat +
   16.13 +
   16.14 +instance
   16.15 +  set :: (term) {power}   (* only ('a * 'a) set should be in power! *)
   16.16 +
   16.17 +primrec (relpow)
   16.18 +  "R^0 = Id"
   16.19 +  "R^(Suc n) = R O (R^n)"
   16.20 +
   16.21 +end
    17.1 --- a/src/HOL/Sum.thy	Thu Oct 12 18:38:23 2000 +0200
    17.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.3 @@ -1,48 +0,0 @@
    17.4 -(*  Title:      HOL/Sum.thy
    17.5 -    ID:         $Id$
    17.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    17.7 -    Copyright   1992  University of Cambridge
    17.8 -
    17.9 -The disjoint sum of two types.
   17.10 -*)
   17.11 -
   17.12 -Sum = mono + Prod +
   17.13 -
   17.14 -(* type definition *)
   17.15 -
   17.16 -constdefs
   17.17 -  Inl_Rep       :: ['a, 'a, 'b, bool] => bool
   17.18 -  "Inl_Rep == (%a. %x y p. x=a & p)"
   17.19 -
   17.20 -  Inr_Rep       :: ['b, 'a, 'b, bool] => bool
   17.21 -  "Inr_Rep == (%b. %x y p. y=b & ~p)"
   17.22 -
   17.23 -global
   17.24 -
   17.25 -typedef (Sum)
   17.26 -  ('a, 'b) "+"          (infixr 10)
   17.27 -    = "{f. (? a. f = Inl_Rep(a::'a)) | (? b. f = Inr_Rep(b::'b))}"
   17.28 -
   17.29 -
   17.30 -(* abstract constants and syntax *)
   17.31 -
   17.32 -consts
   17.33 -  Inl            :: "'a => 'a + 'b"
   17.34 -  Inr            :: "'b => 'a + 'b"
   17.35 -
   17.36 -  (*disjoint sum for sets; the operator + is overloaded with wrong type!*)
   17.37 -  Plus          :: "['a set, 'b set] => ('a + 'b) set"        (infixr "<+>" 65)
   17.38 -  Part          :: ['a set, 'b => 'a] => 'a set
   17.39 -
   17.40 -local
   17.41 -
   17.42 -defs
   17.43 -  Inl_def       "Inl == (%a. Abs_Sum(Inl_Rep(a)))"
   17.44 -  Inr_def       "Inr == (%b. Abs_Sum(Inr_Rep(b)))"
   17.45 -
   17.46 -  sum_def       "A <+> B == (Inl``A) Un (Inr``B)"
   17.47 -
   17.48 -  (*for selecting out the components of a mutually recursive definition*)
   17.49 -  Part_def      "Part A h == A Int {x. ? z. x = h(z)}"
   17.50 -
   17.51 -end
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/Sum_Type.ML	Thu Oct 12 18:44:35 2000 +0200
    18.3 @@ -0,0 +1,178 @@
    18.4 +(*  Title:      HOL/Sum_Type.ML
    18.5 +    ID:         $Id$
    18.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    18.7 +    Copyright   1991  University of Cambridge
    18.8 +
    18.9 +The disjoint sum of two types
   18.10 +*)
   18.11 +
   18.12 +(** Inl_Rep and Inr_Rep: Representations of the constructors **)
   18.13 +
   18.14 +(*This counts as a non-emptiness result for admitting 'a+'b as a type*)
   18.15 +Goalw [Sum_def] "Inl_Rep(a) : Sum";
   18.16 +by (EVERY1 [rtac CollectI, rtac disjI1, rtac exI, rtac refl]);
   18.17 +qed "Inl_RepI";
   18.18 +
   18.19 +Goalw [Sum_def] "Inr_Rep(b) : Sum";
   18.20 +by (EVERY1 [rtac CollectI, rtac disjI2, rtac exI, rtac refl]);
   18.21 +qed "Inr_RepI";
   18.22 +
   18.23 +Goal "inj_on Abs_Sum Sum";
   18.24 +by (rtac inj_on_inverseI 1);
   18.25 +by (etac Abs_Sum_inverse 1);
   18.26 +qed "inj_on_Abs_Sum";
   18.27 +
   18.28 +(** Distinctness of Inl and Inr **)
   18.29 +
   18.30 +Goalw [Inl_Rep_def, Inr_Rep_def] "Inl_Rep(a) ~= Inr_Rep(b)";
   18.31 +by (EVERY1 [rtac notI,
   18.32 +            etac (fun_cong RS fun_cong RS fun_cong RS iffE), 
   18.33 +            rtac (notE RS ccontr),  etac (mp RS conjunct2), 
   18.34 +            REPEAT o (ares_tac [refl,conjI]) ]);
   18.35 +qed "Inl_Rep_not_Inr_Rep";
   18.36 +
   18.37 +Goalw [Inl_def,Inr_def] "Inl(a) ~= Inr(b)";
   18.38 +by (rtac (inj_on_Abs_Sum RS inj_on_contraD) 1);
   18.39 +by (rtac Inl_Rep_not_Inr_Rep 1);
   18.40 +by (rtac Inl_RepI 1);
   18.41 +by (rtac Inr_RepI 1);
   18.42 +qed "Inl_not_Inr";
   18.43 +
   18.44 +bind_thm ("Inr_not_Inl", Inl_not_Inr RS not_sym);
   18.45 +
   18.46 +AddIffs [Inl_not_Inr, Inr_not_Inl];
   18.47 +
   18.48 +bind_thm ("Inl_neq_Inr", Inl_not_Inr RS notE);
   18.49 +bind_thm ("Inr_neq_Inl", sym RS Inl_neq_Inr);
   18.50 +
   18.51 +
   18.52 +(** Injectiveness of Inl and Inr **)
   18.53 +
   18.54 +Goalw [Inl_Rep_def] "Inl_Rep(a) = Inl_Rep(c) ==> a=c";
   18.55 +by (etac (fun_cong RS fun_cong RS fun_cong RS iffE) 1);
   18.56 +by (Blast_tac 1);
   18.57 +qed "Inl_Rep_inject";
   18.58 +
   18.59 +Goalw [Inr_Rep_def] "Inr_Rep(b) = Inr_Rep(d) ==> b=d";
   18.60 +by (etac (fun_cong RS fun_cong RS fun_cong RS iffE) 1);
   18.61 +by (Blast_tac 1);
   18.62 +qed "Inr_Rep_inject";
   18.63 +
   18.64 +Goalw [Inl_def] "inj(Inl)";
   18.65 +by (rtac injI 1);
   18.66 +by (etac (inj_on_Abs_Sum RS inj_onD RS Inl_Rep_inject) 1);
   18.67 +by (rtac Inl_RepI 1);
   18.68 +by (rtac Inl_RepI 1);
   18.69 +qed "inj_Inl";
   18.70 +bind_thm ("Inl_inject", inj_Inl RS injD);
   18.71 +
   18.72 +Goalw [Inr_def] "inj(Inr)";
   18.73 +by (rtac injI 1);
   18.74 +by (etac (inj_on_Abs_Sum RS inj_onD RS Inr_Rep_inject) 1);
   18.75 +by (rtac Inr_RepI 1);
   18.76 +by (rtac Inr_RepI 1);
   18.77 +qed "inj_Inr";
   18.78 +bind_thm ("Inr_inject", inj_Inr RS injD);
   18.79 +
   18.80 +Goal "(Inl(x)=Inl(y)) = (x=y)";
   18.81 +by (blast_tac (claset() addSDs [Inl_inject]) 1);
   18.82 +qed "Inl_eq";
   18.83 +
   18.84 +Goal "(Inr(x)=Inr(y)) = (x=y)";
   18.85 +by (blast_tac (claset() addSDs [Inr_inject]) 1);
   18.86 +qed "Inr_eq";
   18.87 +
   18.88 +AddIffs [Inl_eq, Inr_eq];
   18.89 +
   18.90 +(*** Rules for the disjoint sum of two SETS ***)
   18.91 +
   18.92 +(** Introduction rules for the injections **)
   18.93 +
   18.94 +Goalw [sum_def] "a : A ==> Inl(a) : A <+> B";
   18.95 +by (Blast_tac 1);
   18.96 +qed "InlI";
   18.97 +
   18.98 +Goalw [sum_def] "b : B ==> Inr(b) : A <+> B";
   18.99 +by (Blast_tac 1);
  18.100 +qed "InrI";
  18.101 +
  18.102 +(** Elimination rules **)
  18.103 +
  18.104 +val major::prems = Goalw [sum_def]
  18.105 +    "[| u: A <+> B;  \
  18.106 +\       !!x. [| x:A;  u=Inl(x) |] ==> P; \
  18.107 +\       !!y. [| y:B;  u=Inr(y) |] ==> P \
  18.108 +\    |] ==> P";
  18.109 +by (rtac (major RS UnE) 1);
  18.110 +by (REPEAT (rtac refl 1
  18.111 +     ORELSE eresolve_tac (prems@[imageE,ssubst]) 1));
  18.112 +qed "PlusE";
  18.113 +
  18.114 +
  18.115 +AddSIs [InlI, InrI]; 
  18.116 +AddSEs [PlusE];
  18.117 +
  18.118 +
  18.119 +(** Exhaustion rule for sums -- a degenerate form of induction **)
  18.120 +
  18.121 +val prems = Goalw [Inl_def,Inr_def]
  18.122 +    "[| !!x::'a. s = Inl(x) ==> P;  !!y::'b. s = Inr(y) ==> P \
  18.123 +\    |] ==> P";
  18.124 +by (rtac (rewrite_rule [Sum_def] Rep_Sum RS CollectE) 1);
  18.125 +by (REPEAT (eresolve_tac [disjE,exE] 1
  18.126 +     ORELSE EVERY1 [resolve_tac prems, 
  18.127 +                    etac subst,
  18.128 +                    rtac (Rep_Sum_inverse RS sym)]));
  18.129 +qed "sumE";
  18.130 +
  18.131 +val prems = Goal "[| !!x. P (Inl x); !!x. P (Inr x) |] ==> P x";
  18.132 +by (res_inst_tac [("s","x")] sumE 1);
  18.133 +by (ALLGOALS (hyp_subst_tac THEN' (resolve_tac prems)));
  18.134 +qed "sum_induct";
  18.135 +
  18.136 +
  18.137 +(** Rules for the Part primitive **)
  18.138 +
  18.139 +Goalw [Part_def] "[| a : A;  a=h(b) |] ==> a : Part A h";
  18.140 +by (Blast_tac 1);
  18.141 +qed "Part_eqI";
  18.142 +
  18.143 +bind_thm ("PartI", refl RSN (2,Part_eqI));
  18.144 +
  18.145 +val major::prems = Goalw [Part_def]
  18.146 +    "[| a : Part A h;  !!z. [| a : A;  a=h(z) |] ==> P  \
  18.147 +\    |] ==> P";
  18.148 +by (rtac (major RS IntE) 1);
  18.149 +by (etac CollectE 1);
  18.150 +by (etac exE 1);
  18.151 +by (REPEAT (ares_tac prems 1));
  18.152 +qed "PartE";
  18.153 +
  18.154 +AddIs  [Part_eqI];
  18.155 +AddSEs [PartE];
  18.156 +
  18.157 +Goalw [Part_def] "Part A h <= A";
  18.158 +by (rtac Int_lower1 1);
  18.159 +qed "Part_subset";
  18.160 +
  18.161 +Goal "A<=B ==> Part A h <= Part B h";
  18.162 +by (Blast_tac 1);
  18.163 +qed "Part_mono";
  18.164 +
  18.165 +val basic_monos = basic_monos @ [Part_mono];
  18.166 +
  18.167 +Goalw [Part_def] "a : Part A h ==> a : A";
  18.168 +by (etac IntD1 1);
  18.169 +qed "PartD1";
  18.170 +
  18.171 +Goal "Part A (%x. x) = A";
  18.172 +by (Blast_tac 1);
  18.173 +qed "Part_id";
  18.174 +
  18.175 +Goal "Part (A Int B) h = (Part A h) Int (Part B h)";
  18.176 +by (Blast_tac 1);
  18.177 +qed "Part_Int";
  18.178 +
  18.179 +Goal "Part (A Int {x. P x}) h = (Part A h) Int {x. P x}";
  18.180 +by (Blast_tac 1);
  18.181 +qed "Part_Collect";
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/Sum_Type.thy	Thu Oct 12 18:44:35 2000 +0200
    19.3 @@ -0,0 +1,48 @@
    19.4 +(*  Title:      HOL/Sum_Type.thy
    19.5 +    ID:         $Id$
    19.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    19.7 +    Copyright   1992  University of Cambridge
    19.8 +
    19.9 +The disjoint sum of two types.
   19.10 +*)
   19.11 +
   19.12 +Sum_Type = mono + Product_Type +
   19.13 +
   19.14 +(* type definition *)
   19.15 +
   19.16 +constdefs
   19.17 +  Inl_Rep       :: ['a, 'a, 'b, bool] => bool
   19.18 +  "Inl_Rep == (%a. %x y p. x=a & p)"
   19.19 +
   19.20 +  Inr_Rep       :: ['b, 'a, 'b, bool] => bool
   19.21 +  "Inr_Rep == (%b. %x y p. y=b & ~p)"
   19.22 +
   19.23 +global
   19.24 +
   19.25 +typedef (Sum)
   19.26 +  ('a, 'b) "+"          (infixr 10)
   19.27 +    = "{f. (? a. f = Inl_Rep(a::'a)) | (? b. f = Inr_Rep(b::'b))}"
   19.28 +
   19.29 +
   19.30 +(* abstract constants and syntax *)
   19.31 +
   19.32 +consts
   19.33 +  Inl            :: "'a => 'a + 'b"
   19.34 +  Inr            :: "'b => 'a + 'b"
   19.35 +
   19.36 +  (*disjoint sum for sets; the operator + is overloaded with wrong type!*)
   19.37 +  Plus          :: "['a set, 'b set] => ('a + 'b) set"        (infixr "<+>" 65)
   19.38 +  Part          :: ['a set, 'b => 'a] => 'a set
   19.39 +
   19.40 +local
   19.41 +
   19.42 +defs
   19.43 +  Inl_def       "Inl == (%a. Abs_Sum(Inl_Rep(a)))"
   19.44 +  Inr_def       "Inr == (%b. Abs_Sum(Inr_Rep(b)))"
   19.45 +
   19.46 +  sum_def       "A <+> B == (Inl``A) Un (Inr``B)"
   19.47 +
   19.48 +  (*for selecting out the components of a mutually recursive definition*)
   19.49 +  Part_def      "Part A h == A Int {x. ? z. x = h(z)}"
   19.50 +
   19.51 +end
    20.1 --- a/src/HOL/Trancl.ML	Thu Oct 12 18:38:23 2000 +0200
    20.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.3 @@ -1,403 +0,0 @@
    20.4 -(*  Title:      HOL/Trancl
    20.5 -    ID:         $Id$
    20.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    20.7 -    Copyright   1992  University of Cambridge
    20.8 -
    20.9 -Theorems about the transitive closure of a relation
   20.10 -*)
   20.11 -
   20.12 -(** The relation rtrancl **)
   20.13 -
   20.14 -section "^*";
   20.15 -
   20.16 -Goal "mono(%s. Id Un (r O s))";
   20.17 -by (rtac monoI 1);
   20.18 -by (REPEAT (ares_tac [monoI, subset_refl, comp_mono, Un_mono] 1));
   20.19 -qed "rtrancl_fun_mono";
   20.20 -
   20.21 -bind_thm ("rtrancl_unfold", rtrancl_fun_mono RS (rtrancl_def RS def_lfp_unfold));
   20.22 -
   20.23 -(*Reflexivity of rtrancl*)
   20.24 -Goal "(a,a) : r^*";
   20.25 -by (stac rtrancl_unfold 1);
   20.26 -by (Blast_tac 1);
   20.27 -qed "rtrancl_refl";
   20.28 -
   20.29 -Addsimps [rtrancl_refl];
   20.30 -AddSIs   [rtrancl_refl];
   20.31 -
   20.32 -
   20.33 -(*Closure under composition with r*)
   20.34 -Goal "[| (a,b) : r^*;  (b,c) : r |] ==> (a,c) : r^*";
   20.35 -by (stac rtrancl_unfold 1);
   20.36 -by (Blast_tac 1);
   20.37 -qed "rtrancl_into_rtrancl";
   20.38 -
   20.39 -(*rtrancl of r contains r*)
   20.40 -Goal "!!p. p : r ==> p : r^*";
   20.41 -by (split_all_tac 1);
   20.42 -by (etac (rtrancl_refl RS rtrancl_into_rtrancl) 1);
   20.43 -qed "r_into_rtrancl";
   20.44 -
   20.45 -AddIs [r_into_rtrancl];
   20.46 -
   20.47 -(*monotonicity of rtrancl*)
   20.48 -Goalw [rtrancl_def] "r <= s ==> r^* <= s^*";
   20.49 -by (REPEAT(ares_tac [lfp_mono,Un_mono,comp_mono,subset_refl] 1));
   20.50 -qed "rtrancl_mono";
   20.51 -
   20.52 -(** standard induction rule **)
   20.53 -
   20.54 -val major::prems = Goal 
   20.55 -  "[| (a,b) : r^*; \
   20.56 -\     !!x. P(x,x); \
   20.57 -\     !!x y z.[| P(x,y); (x,y): r^*; (y,z): r |]  ==>  P(x,z) |] \
   20.58 -\  ==>  P(a,b)";
   20.59 -by (rtac ([rtrancl_def, rtrancl_fun_mono, major] MRS def_lfp_induct) 1);
   20.60 -by (blast_tac (claset() addIs prems) 1);
   20.61 -qed "rtrancl_full_induct";
   20.62 -
   20.63 -(*nice induction rule*)
   20.64 -val major::prems = Goal
   20.65 -    "[| (a::'a,b) : r^*;    \
   20.66 -\       P(a); \
   20.67 -\       !!y z.[| (a,y) : r^*;  (y,z) : r;  P(y) |] ==> P(z) |]  \
   20.68 -\     ==> P(b)";
   20.69 -(*by induction on this formula*)
   20.70 -by (subgoal_tac "! y. (a::'a,b) = (a,y) --> P(y)" 1);
   20.71 -(*now solve first subgoal: this formula is sufficient*)
   20.72 -by (Blast_tac 1);
   20.73 -(*now do the induction*)
   20.74 -by (resolve_tac [major RS rtrancl_full_induct] 1);
   20.75 -by (blast_tac (claset() addIs prems) 1);
   20.76 -by (blast_tac (claset() addIs prems) 1);
   20.77 -qed "rtrancl_induct";
   20.78 -
   20.79 -bind_thm ("rtrancl_induct2", split_rule
   20.80 -  (read_instantiate [("a","(ax,ay)"), ("b","(bx,by)")] rtrancl_induct));
   20.81 -
   20.82 -(*transitivity of transitive closure!! -- by induction.*)
   20.83 -Goalw [trans_def] "trans(r^*)";
   20.84 -by Safe_tac;
   20.85 -by (eres_inst_tac [("b","z")] rtrancl_induct 1);
   20.86 -by (ALLGOALS(blast_tac (claset() addIs [rtrancl_into_rtrancl])));
   20.87 -qed "trans_rtrancl";
   20.88 -
   20.89 -bind_thm ("rtrancl_trans", trans_rtrancl RS transD);
   20.90 -
   20.91 -
   20.92 -(*elimination of rtrancl -- by induction on a special formula*)
   20.93 -val major::prems = Goal
   20.94 -    "[| (a::'a,b) : r^*;  (a = b) ==> P;        \
   20.95 -\       !!y.[| (a,y) : r^*; (y,b) : r |] ==> P  \
   20.96 -\    |] ==> P";
   20.97 -by (subgoal_tac "(a::'a) = b  | (? y. (a,y) : r^* & (y,b) : r)" 1);
   20.98 -by (rtac (major RS rtrancl_induct) 2);
   20.99 -by (blast_tac (claset() addIs prems) 2);
  20.100 -by (blast_tac (claset() addIs prems) 2);
  20.101 -by (REPEAT (eresolve_tac ([asm_rl,exE,disjE,conjE]@prems) 1));
  20.102 -qed "rtranclE";
  20.103 -
  20.104 -bind_thm ("rtrancl_into_rtrancl2", r_into_rtrancl RS rtrancl_trans);
  20.105 -bind_thms("rtranclIs", [r_into_rtrancl, rtrancl_trans]);
  20.106 -
  20.107 -(*** More r^* equations and inclusions ***)
  20.108 -
  20.109 -Goal "(r^*)^* = r^*";
  20.110 -by Auto_tac;
  20.111 -by (etac rtrancl_induct 1);
  20.112 -by (rtac rtrancl_refl 1);
  20.113 -by (blast_tac (claset() addIs rtranclIs) 1);
  20.114 -qed "rtrancl_idemp";
  20.115 -Addsimps [rtrancl_idemp];
  20.116 -
  20.117 -Goal "R^* O R^* = R^*";
  20.118 -by (rtac set_ext 1);
  20.119 -by (split_all_tac 1);
  20.120 -by (blast_tac (claset() addIs rtranclIs) 1);
  20.121 -qed "rtrancl_idemp_self_comp";
  20.122 -Addsimps [rtrancl_idemp_self_comp];
  20.123 -
  20.124 -Goal "r <= s^* ==> r^* <= s^*";
  20.125 -by (dtac rtrancl_mono 1);
  20.126 -by (Asm_full_simp_tac 1);
  20.127 -qed "rtrancl_subset_rtrancl";
  20.128 -
  20.129 -Goal "[| R <= S; S <= R^* |] ==> S^* = R^*";
  20.130 -by (dtac rtrancl_mono 1);
  20.131 -by (dtac rtrancl_mono 1);
  20.132 -by (Asm_full_simp_tac 1);
  20.133 -by (Blast_tac 1);
  20.134 -qed "rtrancl_subset";
  20.135 -
  20.136 -Goal "(R^* Un S^*)^* = (R Un S)^*";
  20.137 -by (blast_tac (claset() addSIs [rtrancl_subset]
  20.138 -                        addIs [r_into_rtrancl, rtrancl_mono RS subsetD]) 1);
  20.139 -qed "rtrancl_Un_rtrancl";
  20.140 -
  20.141 -Goal "(R^=)^* = R^*";
  20.142 -by (blast_tac (claset() addSIs [rtrancl_subset] addIs [r_into_rtrancl]) 1);
  20.143 -qed "rtrancl_reflcl";
  20.144 -Addsimps [rtrancl_reflcl];
  20.145 -
  20.146 -Goal "(r - Id)^* = r^*";
  20.147 -by (rtac sym 1);
  20.148 -by (rtac rtrancl_subset 1);
  20.149 - by (Blast_tac 1);
  20.150 -by (Clarify_tac 1);
  20.151 -by (rename_tac "a b" 1);
  20.152 -by (case_tac "a=b" 1);
  20.153 - by (Blast_tac 1);
  20.154 -by (blast_tac (claset() addSIs [r_into_rtrancl]) 1);
  20.155 -qed "rtrancl_r_diff_Id";
  20.156 -
  20.157 -Goal "(x,y) : (r^-1)^* ==> (y,x) : r^*";
  20.158 -by (etac rtrancl_induct 1);
  20.159 -by (rtac rtrancl_refl 1);
  20.160 -by (blast_tac (claset() addIs rtranclIs) 1);
  20.161 -qed "rtrancl_converseD";
  20.162 -
  20.163 -Goal "(y,x) : r^* ==> (x,y) : (r^-1)^*";
  20.164 -by (etac rtrancl_induct 1);
  20.165 -by (rtac rtrancl_refl 1);
  20.166 -by (blast_tac (claset() addIs rtranclIs) 1);
  20.167 -qed "rtrancl_converseI";
  20.168 -
  20.169 -Goal "(r^-1)^* = (r^*)^-1";
  20.170 -(*blast_tac fails: the split_all_tac wrapper must be called to convert
  20.171 -  the set element to a pair*)
  20.172 -by (safe_tac (claset() addSDs [rtrancl_converseD] addSIs [rtrancl_converseI]));
  20.173 -qed "rtrancl_converse";
  20.174 -
  20.175 -val major::prems = Goal
  20.176 -    "[| (a,b) : r^*; P(b); \
  20.177 -\       !!y z.[| (y,z) : r;  (z,b) : r^*;  P(z) |] ==> P(y) |]  \
  20.178 -\     ==> P(a)";
  20.179 -by (rtac (major RS rtrancl_converseI RS rtrancl_induct) 1);
  20.180 -by (resolve_tac prems 1);
  20.181 -by (blast_tac (claset() addIs prems addSDs[rtrancl_converseD])1);
  20.182 -qed "converse_rtrancl_induct";
  20.183 -
  20.184 -bind_thm ("converse_rtrancl_induct2", split_rule
  20.185 -  (read_instantiate [("a","(ax,ay)"),("b","(bx,by)")]converse_rtrancl_induct));
  20.186 -
  20.187 -val major::prems = Goal
  20.188 - "[| (x,z):r^*; \
  20.189 -\    x=z ==> P; \
  20.190 -\    !!y. [| (x,y):r; (y,z):r^* |] ==> P \
  20.191 -\ |] ==> P";
  20.192 -by (subgoal_tac "x = z  | (? y. (x,y) : r & (y,z) : r^*)" 1);
  20.193 -by (rtac (major RS converse_rtrancl_induct) 2);
  20.194 -by (blast_tac (claset() addIs prems) 2);
  20.195 -by (blast_tac (claset() addIs prems) 2);
  20.196 -by (REPEAT (eresolve_tac ([asm_rl,exE,disjE,conjE]@prems) 1));
  20.197 -qed "converse_rtranclE";
  20.198 -
  20.199 -bind_thm ("converse_rtranclE2", split_rule
  20.200 -  (read_instantiate [("x","(xa,xb)"), ("z","(za,zb)")] converse_rtranclE));
  20.201 -
  20.202 -Goal "r O r^* = r^* O r";
  20.203 -by (blast_tac (claset() addEs [rtranclE, converse_rtranclE] 
  20.204 -	               addIs [rtrancl_into_rtrancl, rtrancl_into_rtrancl2]) 1);
  20.205 -qed "r_comp_rtrancl_eq";
  20.206 -
  20.207 -
  20.208 -(**** The relation trancl ****)
  20.209 -
  20.210 -section "^+";
  20.211 -
  20.212 -Goalw [trancl_def] "[| p:r^+; r <= s |] ==> p:s^+";
  20.213 -by (blast_tac (claset() addIs [rtrancl_mono RS subsetD]) 1);
  20.214 -qed "trancl_mono";
  20.215 -
  20.216 -(** Conversions between trancl and rtrancl **)
  20.217 -
  20.218 -Goalw [trancl_def]
  20.219 -    "!!p. p : r^+ ==> p : r^*";
  20.220 -by (split_all_tac 1);
  20.221 -by (etac compEpair 1);
  20.222 -by (REPEAT (ares_tac [rtrancl_into_rtrancl] 1));
  20.223 -qed "trancl_into_rtrancl";
  20.224 -
  20.225 -(*r^+ contains r*)
  20.226 -Goalw [trancl_def]
  20.227 -   "!!p. p : r ==> p : r^+";
  20.228 -by (split_all_tac 1);
  20.229 -by (REPEAT (ares_tac [prem,compI,rtrancl_refl] 1));
  20.230 -qed "r_into_trancl";
  20.231 -AddIs [r_into_trancl];
  20.232 -
  20.233 -(*intro rule by definition: from rtrancl and r*)
  20.234 -Goalw [trancl_def] "[| (a,b) : r^*;  (b,c) : r |]   ==>  (a,c) : r^+";
  20.235 -by Auto_tac;
  20.236 -qed "rtrancl_into_trancl1";
  20.237 -
  20.238 -(*intro rule from r and rtrancl*)
  20.239 -Goal "[| (a,b) : r;  (b,c) : r^* |]   ==>  (a,c) : r^+";
  20.240 -by (etac rtranclE 1);
  20.241 -by (blast_tac (claset() addIs [r_into_trancl]) 1);
  20.242 -by (rtac (rtrancl_trans RS rtrancl_into_trancl1) 1);
  20.243 -by (REPEAT (ares_tac [r_into_rtrancl] 1));
  20.244 -qed "rtrancl_into_trancl2";
  20.245 -
  20.246 -(*Nice induction rule for trancl*)
  20.247 -val major::prems = Goal
  20.248 -  "[| (a,b) : r^+;                                      \
  20.249 -\     !!y.  [| (a,y) : r |] ==> P(y);                   \
  20.250 -\     !!y z.[| (a,y) : r^+;  (y,z) : r;  P(y) |] ==> P(z)       \
  20.251 -\  |] ==> P(b)";
  20.252 -by (rtac (rewrite_rule [trancl_def] major  RS  compEpair) 1);
  20.253 -(*by induction on this formula*)
  20.254 -by (subgoal_tac "ALL z. (y,z) : r --> P(z)" 1);
  20.255 -(*now solve first subgoal: this formula is sufficient*)
  20.256 -by (Blast_tac 1);
  20.257 -by (etac rtrancl_induct 1);
  20.258 -by (ALLGOALS (blast_tac (claset() addIs (rtrancl_into_trancl1::prems))));
  20.259 -qed "trancl_induct";
  20.260 -
  20.261 -(*Another induction rule for trancl, incorporating transitivity.*)
  20.262 -val major::prems = Goal
  20.263 - "[| (x,y) : r^+; \
  20.264 -\    !!x y. (x,y) : r ==> P x y; \
  20.265 -\    !!x y z. [| (x,y) : r^+; P x y; (y,z) : r^+; P y z |] ==> P x z \
  20.266 -\ |] ==> P x y";
  20.267 -by (blast_tac (claset() addIs ([r_into_trancl,major RS trancl_induct]@prems))1);
  20.268 -qed "trancl_trans_induct";
  20.269 -
  20.270 -(*elimination of r^+ -- NOT an induction rule*)
  20.271 -val major::prems = Goal
  20.272 -    "[| (a::'a,b) : r^+;  \
  20.273 -\       (a,b) : r ==> P; \
  20.274 -\       !!y.[| (a,y) : r^+;  (y,b) : r |] ==> P  \
  20.275 -\    |] ==> P";
  20.276 -by (subgoal_tac "(a::'a,b) : r | (? y. (a,y) : r^+  &  (y,b) : r)" 1);
  20.277 -by (REPEAT (eresolve_tac ([asm_rl,disjE,exE,conjE]@prems) 1));
  20.278 -by (rtac (rewrite_rule [trancl_def] major RS compEpair) 1);
  20.279 -by (etac rtranclE 1);
  20.280 -by (Blast_tac 1);
  20.281 -by (blast_tac (claset() addSIs [rtrancl_into_trancl1]) 1);
  20.282 -qed "tranclE";
  20.283 -
  20.284 -(*Transitivity of r^+.
  20.285 -  Proved by unfolding since it uses transitivity of rtrancl. *)
  20.286 -Goalw [trancl_def] "trans(r^+)";
  20.287 -by (rtac transI 1);
  20.288 -by (REPEAT (etac compEpair 1));
  20.289 -by (rtac (rtrancl_into_rtrancl RS (rtrancl_trans RS compI)) 1);
  20.290 -by (REPEAT (assume_tac 1));
  20.291 -qed "trans_trancl";
  20.292 -
  20.293 -bind_thm ("trancl_trans", trans_trancl RS transD);
  20.294 -
  20.295 -Goalw [trancl_def] "[| (x,y):r^*; (y,z):r^+ |] ==> (x,z):r^+";
  20.296 -by (blast_tac (claset() addIs rtranclIs) 1);
  20.297 -qed "rtrancl_trancl_trancl";
  20.298 -
  20.299 -(* "[| (a,b) : r;  (b,c) : r^+ |]   ==>  (a,c) : r^+" *)
  20.300 -bind_thm ("trancl_into_trancl2", [trans_trancl, r_into_trancl] MRS transD);
  20.301 -
  20.302 -(* primitive recursion for trancl over finite relations: *)
  20.303 -Goal "(insert (y,x) r)^+ = r^+ Un {(a,b). (a,y):r^* & (x,b):r^*}";
  20.304 -by (rtac equalityI 1);
  20.305 - by (rtac subsetI 1);
  20.306 - by (split_all_tac 1);
  20.307 - by (etac trancl_induct 1);
  20.308 -  by (blast_tac (claset() addIs [r_into_trancl]) 1);
  20.309 - by (blast_tac (claset() addIs
  20.310 -     [rtrancl_into_trancl1,trancl_into_rtrancl,r_into_trancl,trancl_trans]) 1);
  20.311 -by (rtac subsetI 1);
  20.312 -by (blast_tac (claset() addIs
  20.313 -     [rtrancl_into_trancl2, rtrancl_trancl_trancl,
  20.314 -      impOfSubs rtrancl_mono, trancl_mono]) 1);
  20.315 -qed "trancl_insert";
  20.316 -
  20.317 -Goalw [trancl_def] "(r^-1)^+ = (r^+)^-1";
  20.318 -by (simp_tac (simpset() addsimps [rtrancl_converse,converse_comp]) 1);
  20.319 -by (simp_tac (simpset() addsimps [rtrancl_converse RS sym,
  20.320 -				  r_comp_rtrancl_eq]) 1);
  20.321 -qed "trancl_converse";
  20.322 -
  20.323 -Goal "(x,y) : (r^+)^-1 ==> (x,y) : (r^-1)^+";
  20.324 -by (asm_full_simp_tac (simpset() addsimps [trancl_converse]) 1);
  20.325 -qed "trancl_converseI";
  20.326 -
  20.327 -Goal "(x,y) : (r^-1)^+ ==> (x,y) : (r^+)^-1";
  20.328 -by (asm_full_simp_tac (simpset() addsimps [trancl_converse]) 1);
  20.329 -qed "trancl_converseD";
  20.330 -
  20.331 -val major::prems = Goal
  20.332 -    "[| (a,b) : r^+; !!y. (y,b) : r ==> P(y); \
  20.333 -\       !!y z.[| (y,z) : r;  (z,b) : r^+;  P(z) |] ==> P(y) |]  \
  20.334 -\     ==> P(a)";
  20.335 -by (rtac ((major RS converseI RS trancl_converseI) RS trancl_induct) 1);
  20.336 - by (resolve_tac prems 1);
  20.337 - by (etac converseD 1);
  20.338 -by (blast_tac (claset() addIs prems addSDs [trancl_converseD])1);
  20.339 -qed "converse_trancl_induct";
  20.340 -
  20.341 -Goal "(x,y):R^+ ==> ? z. (x,z):R & (z,y):R^*";
  20.342 -be converse_trancl_induct 1;
  20.343 -by Auto_tac;
  20.344 -by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  20.345 -qed "tranclD";
  20.346 -
  20.347 -(*Unused*)
  20.348 -Goal "r^-1 Int r^+ = {} ==> (x, x) ~: r^+";
  20.349 -by (subgoal_tac "!y. (x, y) : r^+ --> x~=y" 1);
  20.350 -by (Fast_tac 1);
  20.351 -by (strip_tac 1);
  20.352 -by (etac trancl_induct 1);
  20.353 -by (auto_tac (claset() addIs [r_into_trancl], simpset()));
  20.354 -qed "irrefl_tranclI";
  20.355 -
  20.356 -Goal "!!X. [| !x. (x, x) ~: r^+; (x,y) : r |] ==> x ~= y";
  20.357 -by (blast_tac (claset() addDs [r_into_trancl]) 1);
  20.358 -qed "irrefl_trancl_rD";
  20.359 -
  20.360 -Goal "[| (a,b) : r^*;  r <= A <*> A |] ==> a=b | a:A";
  20.361 -by (etac rtrancl_induct 1);
  20.362 -by Auto_tac;
  20.363 -val lemma = result();
  20.364 -
  20.365 -Goalw [trancl_def] "r <= A <*> A ==> r^+ <= A <*> A";
  20.366 -by (blast_tac (claset() addSDs [lemma]) 1);
  20.367 -qed "trancl_subset_Sigma";
  20.368 -
  20.369 -
  20.370 -Goal "(r^+)^= = r^*";
  20.371 -by Safe_tac;
  20.372 -by  (etac trancl_into_rtrancl 1);
  20.373 -by (blast_tac (claset() addEs [rtranclE] addDs [rtrancl_into_trancl1]) 1);
  20.374 -qed "reflcl_trancl";
  20.375 -Addsimps[reflcl_trancl];
  20.376 -
  20.377 -Goal "(r^=)^+ = r^*";
  20.378 -by Safe_tac;
  20.379 -by  (dtac trancl_into_rtrancl 1);
  20.380 -by  (Asm_full_simp_tac 1);
  20.381 -by (etac rtranclE 1);
  20.382 -by  Safe_tac;
  20.383 -by  (rtac r_into_trancl 1);
  20.384 -by  (Simp_tac 1);
  20.385 -by (rtac rtrancl_into_trancl1 1);
  20.386 -by (etac (rtrancl_reflcl RS equalityD2 RS subsetD) 1);
  20.387 -by (Fast_tac 1);
  20.388 -qed "trancl_reflcl";
  20.389 -Addsimps[trancl_reflcl];
  20.390 -
  20.391 -Goal "{}^+ = {}";
  20.392 -by (auto_tac (claset() addEs [trancl_induct], simpset()));
  20.393 -qed "trancl_empty";
  20.394 -Addsimps[trancl_empty];
  20.395 -
  20.396 -Goal "{}^* = Id";
  20.397 -by (rtac (reflcl_trancl RS subst) 1);
  20.398 -by (Simp_tac 1);
  20.399 -qed "rtrancl_empty";
  20.400 -Addsimps[rtrancl_empty];
  20.401 -
  20.402 -Goal "(a,b):R^* ==> a=b | a~=b & (a,b):R^+";
  20.403 -by(force_tac (claset(), simpset() addsimps [reflcl_trancl RS sym] 
  20.404 -				  delsimps [reflcl_trancl]) 1);
  20.405 -qed "rtranclD";
  20.406 -
    21.1 --- a/src/HOL/Trancl.thy	Thu Oct 12 18:38:23 2000 +0200
    21.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.3 @@ -1,31 +0,0 @@
    21.4 -(*  Title:      HOL/Trancl.thy
    21.5 -    ID:         $Id$
    21.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    21.7 -    Copyright   1992  University of Cambridge
    21.8 -
    21.9 -Relfexive and Transitive closure of a relation
   21.10 -
   21.11 -rtrancl is reflexive/transitive closure;
   21.12 -trancl  is transitive closure
   21.13 -reflcl  is reflexive closure
   21.14 -
   21.15 -These postfix operators have MAXIMUM PRIORITY, forcing their operands to be
   21.16 -      atomic.
   21.17 -*)
   21.18 -
   21.19 -Trancl = Lfp + Relation + 
   21.20 -
   21.21 -constdefs
   21.22 -  rtrancl :: "('a * 'a)set => ('a * 'a)set"   ("(_^*)" [1000] 999)
   21.23 -  "r^*  ==  lfp(%s. Id Un (r O s))"
   21.24 -
   21.25 -  trancl  :: "('a * 'a)set => ('a * 'a)set"   ("(_^+)" [1000] 999)
   21.26 -  "r^+  ==  r O rtrancl(r)"
   21.27 -
   21.28 -syntax
   21.29 -  "_reflcl"  :: "('a*'a)set => ('a*'a)set"       ("(_^=)" [1000] 999)
   21.30 -
   21.31 -translations
   21.32 -  "r^=" == "r Un Id"
   21.33 -
   21.34 -end
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/Transitive_Closure.ML	Thu Oct 12 18:44:35 2000 +0200
    22.3 @@ -0,0 +1,402 @@
    22.4 +(*  Title:      HOL/Transitive_Closure
    22.5 +    ID:         $Id$
    22.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    22.7 +    Copyright   1992  University of Cambridge
    22.8 +
    22.9 +Theorems about the transitive closure of a relation
   22.10 +*)
   22.11 +
   22.12 +(** The relation rtrancl **)
   22.13 +
   22.14 +section "^*";
   22.15 +
   22.16 +Goal "mono(%s. Id Un (r O s))";
   22.17 +by (rtac monoI 1);
   22.18 +by (REPEAT (ares_tac [monoI, subset_refl, comp_mono, Un_mono] 1));
   22.19 +qed "rtrancl_fun_mono";
   22.20 +
   22.21 +bind_thm ("rtrancl_unfold", rtrancl_fun_mono RS (rtrancl_def RS def_lfp_unfold));
   22.22 +
   22.23 +(*Reflexivity of rtrancl*)
   22.24 +Goal "(a,a) : r^*";
   22.25 +by (stac rtrancl_unfold 1);
   22.26 +by (Blast_tac 1);
   22.27 +qed "rtrancl_refl";
   22.28 +
   22.29 +Addsimps [rtrancl_refl];
   22.30 +AddSIs   [rtrancl_refl];
   22.31 +
   22.32 +
   22.33 +(*Closure under composition with r*)
   22.34 +Goal "[| (a,b) : r^*;  (b,c) : r |] ==> (a,c) : r^*";
   22.35 +by (stac rtrancl_unfold 1);
   22.36 +by (Blast_tac 1);
   22.37 +qed "rtrancl_into_rtrancl";
   22.38 +
   22.39 +(*rtrancl of r contains r*)
   22.40 +Goal "!!p. p : r ==> p : r^*";
   22.41 +by (split_all_tac 1);
   22.42 +by (etac (rtrancl_refl RS rtrancl_into_rtrancl) 1);
   22.43 +qed "r_into_rtrancl";
   22.44 +
   22.45 +AddIs [r_into_rtrancl];
   22.46 +
   22.47 +(*monotonicity of rtrancl*)
   22.48 +Goalw [rtrancl_def] "r <= s ==> r^* <= s^*";
   22.49 +by (REPEAT(ares_tac [lfp_mono,Un_mono,comp_mono,subset_refl] 1));
   22.50 +qed "rtrancl_mono";
   22.51 +
   22.52 +(** standard induction rule **)
   22.53 +
   22.54 +val major::prems = Goal 
   22.55 +  "[| (a,b) : r^*; \
   22.56 +\     !!x. P(x,x); \
   22.57 +\     !!x y z.[| P(x,y); (x,y): r^*; (y,z): r |]  ==>  P(x,z) |] \
   22.58 +\  ==>  P(a,b)";
   22.59 +by (rtac ([rtrancl_def, rtrancl_fun_mono, major] MRS def_lfp_induct) 1);
   22.60 +by (blast_tac (claset() addIs prems) 1);
   22.61 +qed "rtrancl_full_induct";
   22.62 +
   22.63 +(*nice induction rule*)
   22.64 +val major::prems = Goal
   22.65 +    "[| (a::'a,b) : r^*;    \
   22.66 +\       P(a); \
   22.67 +\       !!y z.[| (a,y) : r^*;  (y,z) : r;  P(y) |] ==> P(z) |]  \
   22.68 +\     ==> P(b)";
   22.69 +(*by induction on this formula*)
   22.70 +by (subgoal_tac "! y. (a::'a,b) = (a,y) --> P(y)" 1);
   22.71 +(*now solve first subgoal: this formula is sufficient*)
   22.72 +by (Blast_tac 1);
   22.73 +(*now do the induction*)
   22.74 +by (resolve_tac [major RS rtrancl_full_induct] 1);
   22.75 +by (blast_tac (claset() addIs prems) 1);
   22.76 +by (blast_tac (claset() addIs prems) 1);
   22.77 +qed "rtrancl_induct";
   22.78 +
   22.79 +bind_thm ("rtrancl_induct2", split_rule
   22.80 +  (read_instantiate [("a","(ax,ay)"), ("b","(bx,by)")] rtrancl_induct));
   22.81 +
   22.82 +(*transitivity of transitive closure!! -- by induction.*)
   22.83 +Goalw [trans_def] "trans(r^*)";
   22.84 +by Safe_tac;
   22.85 +by (eres_inst_tac [("b","z")] rtrancl_induct 1);
   22.86 +by (ALLGOALS(blast_tac (claset() addIs [rtrancl_into_rtrancl])));
   22.87 +qed "trans_rtrancl";
   22.88 +
   22.89 +bind_thm ("rtrancl_trans", trans_rtrancl RS transD);
   22.90 +
   22.91 +
   22.92 +(*elimination of rtrancl -- by induction on a special formula*)
   22.93 +val major::prems = Goal
   22.94 +    "[| (a::'a,b) : r^*;  (a = b) ==> P;        \
   22.95 +\       !!y.[| (a,y) : r^*; (y,b) : r |] ==> P  \
   22.96 +\    |] ==> P";
   22.97 +by (subgoal_tac "(a::'a) = b  | (? y. (a,y) : r^* & (y,b) : r)" 1);
   22.98 +by (rtac (major RS rtrancl_induct) 2);
   22.99 +by (blast_tac (claset() addIs prems) 2);
  22.100 +by (blast_tac (claset() addIs prems) 2);
  22.101 +by (REPEAT (eresolve_tac ([asm_rl,exE,disjE,conjE]@prems) 1));
  22.102 +qed "rtranclE";
  22.103 +
  22.104 +bind_thm ("rtrancl_into_rtrancl2", r_into_rtrancl RS rtrancl_trans);
  22.105 +
  22.106 +(*** More r^* equations and inclusions ***)
  22.107 +
  22.108 +Goal "(r^*)^* = r^*";
  22.109 +by Auto_tac;
  22.110 +by (etac rtrancl_induct 1);
  22.111 +by (rtac rtrancl_refl 1);
  22.112 +by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  22.113 +qed "rtrancl_idemp";
  22.114 +Addsimps [rtrancl_idemp];
  22.115 +
  22.116 +Goal "R^* O R^* = R^*";
  22.117 +by (rtac set_ext 1);
  22.118 +by (split_all_tac 1);
  22.119 +by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  22.120 +qed "rtrancl_idemp_self_comp";
  22.121 +Addsimps [rtrancl_idemp_self_comp];
  22.122 +
  22.123 +Goal "r <= s^* ==> r^* <= s^*";
  22.124 +by (dtac rtrancl_mono 1);
  22.125 +by (Asm_full_simp_tac 1);
  22.126 +qed "rtrancl_subset_rtrancl";
  22.127 +
  22.128 +Goal "[| R <= S; S <= R^* |] ==> S^* = R^*";
  22.129 +by (dtac rtrancl_mono 1);
  22.130 +by (dtac rtrancl_mono 1);
  22.131 +by (Asm_full_simp_tac 1);
  22.132 +by (Blast_tac 1);
  22.133 +qed "rtrancl_subset";
  22.134 +
  22.135 +Goal "(R^* Un S^*)^* = (R Un S)^*";
  22.136 +by (blast_tac (claset() addSIs [rtrancl_subset]
  22.137 +                        addIs [r_into_rtrancl, rtrancl_mono RS subsetD]) 1);
  22.138 +qed "rtrancl_Un_rtrancl";
  22.139 +
  22.140 +Goal "(R^=)^* = R^*";
  22.141 +by (blast_tac (claset() addSIs [rtrancl_subset] addIs [r_into_rtrancl]) 1);
  22.142 +qed "rtrancl_reflcl";
  22.143 +Addsimps [rtrancl_reflcl];
  22.144 +
  22.145 +Goal "(r - Id)^* = r^*";
  22.146 +by (rtac sym 1);
  22.147 +by (rtac rtrancl_subset 1);
  22.148 + by (Blast_tac 1);
  22.149 +by (Clarify_tac 1);
  22.150 +by (rename_tac "a b" 1);
  22.151 +by (case_tac "a=b" 1);
  22.152 + by (Blast_tac 1);
  22.153 +by (blast_tac (claset() addSIs [r_into_rtrancl]) 1);
  22.154 +qed "rtrancl_r_diff_Id";
  22.155 +
  22.156 +Goal "(x,y) : (r^-1)^* ==> (y,x) : r^*";
  22.157 +by (etac rtrancl_induct 1);
  22.158 +by (rtac rtrancl_refl 1);
  22.159 +by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  22.160 +qed "rtrancl_converseD";
  22.161 +
  22.162 +Goal "(y,x) : r^* ==> (x,y) : (r^-1)^*";
  22.163 +by (etac rtrancl_induct 1);
  22.164 +by (rtac rtrancl_refl 1);
  22.165 +by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  22.166 +qed "rtrancl_converseI";
  22.167 +
  22.168 +Goal "(r^-1)^* = (r^*)^-1";
  22.169 +(*blast_tac fails: the split_all_tac wrapper must be called to convert
  22.170 +  the set element to a pair*)
  22.171 +by (safe_tac (claset() addSDs [rtrancl_converseD] addSIs [rtrancl_converseI]));
  22.172 +qed "rtrancl_converse";
  22.173 +
  22.174 +val major::prems = Goal
  22.175 +    "[| (a,b) : r^*; P(b); \
  22.176 +\       !!y z.[| (y,z) : r;  (z,b) : r^*;  P(z) |] ==> P(y) |]  \
  22.177 +\     ==> P(a)";
  22.178 +by (rtac (major RS rtrancl_converseI RS rtrancl_induct) 1);
  22.179 +by (resolve_tac prems 1);
  22.180 +by (blast_tac (claset() addIs prems addSDs[rtrancl_converseD])1);
  22.181 +qed "converse_rtrancl_induct";
  22.182 +
  22.183 +bind_thm ("converse_rtrancl_induct2", split_rule
  22.184 +  (read_instantiate [("a","(ax,ay)"),("b","(bx,by)")]converse_rtrancl_induct));
  22.185 +
  22.186 +val major::prems = Goal
  22.187 + "[| (x,z):r^*; \
  22.188 +\    x=z ==> P; \
  22.189 +\    !!y. [| (x,y):r; (y,z):r^* |] ==> P \
  22.190 +\ |] ==> P";
  22.191 +by (subgoal_tac "x = z  | (? y. (x,y) : r & (y,z) : r^*)" 1);
  22.192 +by (rtac (major RS converse_rtrancl_induct) 2);
  22.193 +by (blast_tac (claset() addIs prems) 2);
  22.194 +by (blast_tac (claset() addIs prems) 2);
  22.195 +by (REPEAT (eresolve_tac ([asm_rl,exE,disjE,conjE]@prems) 1));
  22.196 +qed "converse_rtranclE";
  22.197 +
  22.198 +bind_thm ("converse_rtranclE2", split_rule
  22.199 +  (read_instantiate [("x","(xa,xb)"), ("z","(za,zb)")] converse_rtranclE));
  22.200 +
  22.201 +Goal "r O r^* = r^* O r";
  22.202 +by (blast_tac (claset() addEs [rtranclE, converse_rtranclE] 
  22.203 +	               addIs [rtrancl_into_rtrancl, rtrancl_into_rtrancl2]) 1);
  22.204 +qed "r_comp_rtrancl_eq";
  22.205 +
  22.206 +
  22.207 +(**** The relation trancl ****)
  22.208 +
  22.209 +section "^+";
  22.210 +
  22.211 +Goalw [trancl_def] "[| p:r^+; r <= s |] ==> p:s^+";
  22.212 +by (blast_tac (claset() addIs [rtrancl_mono RS subsetD]) 1);
  22.213 +qed "trancl_mono";
  22.214 +
  22.215 +(** Conversions between trancl and rtrancl **)
  22.216 +
  22.217 +Goalw [trancl_def]
  22.218 +    "!!p. p : r^+ ==> p : r^*";
  22.219 +by (split_all_tac 1);
  22.220 +by (etac compEpair 1);
  22.221 +by (REPEAT (ares_tac [rtrancl_into_rtrancl] 1));
  22.222 +qed "trancl_into_rtrancl";
  22.223 +
  22.224 +(*r^+ contains r*)
  22.225 +Goalw [trancl_def]
  22.226 +   "!!p. p : r ==> p : r^+";
  22.227 +by (split_all_tac 1);
  22.228 +by (REPEAT (ares_tac [prem,compI,rtrancl_refl] 1));
  22.229 +qed "r_into_trancl";
  22.230 +AddIs [r_into_trancl];
  22.231 +
  22.232 +(*intro rule by definition: from rtrancl and r*)
  22.233 +Goalw [trancl_def] "[| (a,b) : r^*;  (b,c) : r |]   ==>  (a,c) : r^+";
  22.234 +by Auto_tac;
  22.235 +qed "rtrancl_into_trancl1";
  22.236 +
  22.237 +(*intro rule from r and rtrancl*)
  22.238 +Goal "[| (a,b) : r;  (b,c) : r^* |]   ==>  (a,c) : r^+";
  22.239 +by (etac rtranclE 1);
  22.240 +by (blast_tac (claset() addIs [r_into_trancl]) 1);
  22.241 +by (rtac (rtrancl_trans RS rtrancl_into_trancl1) 1);
  22.242 +by (REPEAT (ares_tac [r_into_rtrancl] 1));
  22.243 +qed "rtrancl_into_trancl2";
  22.244 +
  22.245 +(*Nice induction rule for trancl*)
  22.246 +val major::prems = Goal
  22.247 +  "[| (a,b) : r^+;                                      \
  22.248 +\     !!y.  [| (a,y) : r |] ==> P(y);                   \
  22.249 +\     !!y z.[| (a,y) : r^+;  (y,z) : r;  P(y) |] ==> P(z)       \
  22.250 +\  |] ==> P(b)";
  22.251 +by (rtac (rewrite_rule [trancl_def] major  RS  compEpair) 1);
  22.252 +(*by induction on this formula*)
  22.253 +by (subgoal_tac "ALL z. (y,z) : r --> P(z)" 1);
  22.254 +(*now solve first subgoal: this formula is sufficient*)
  22.255 +by (Blast_tac 1);
  22.256 +by (etac rtrancl_induct 1);
  22.257 +by (ALLGOALS (blast_tac (claset() addIs (rtrancl_into_trancl1::prems))));
  22.258 +qed "trancl_induct";
  22.259 +
  22.260 +(*Another induction rule for trancl, incorporating transitivity.*)
  22.261 +val major::prems = Goal
  22.262 + "[| (x,y) : r^+; \
  22.263 +\    !!x y. (x,y) : r ==> P x y; \
  22.264 +\    !!x y z. [| (x,y) : r^+; P x y; (y,z) : r^+; P y z |] ==> P x z \
  22.265 +\ |] ==> P x y";
  22.266 +by (blast_tac (claset() addIs ([r_into_trancl,major RS trancl_induct]@prems))1);
  22.267 +qed "trancl_trans_induct";
  22.268 +
  22.269 +(*elimination of r^+ -- NOT an induction rule*)
  22.270 +val major::prems = Goal
  22.271 +    "[| (a::'a,b) : r^+;  \
  22.272 +\       (a,b) : r ==> P; \
  22.273 +\       !!y.[| (a,y) : r^+;  (y,b) : r |] ==> P  \
  22.274 +\    |] ==> P";
  22.275 +by (subgoal_tac "(a::'a,b) : r | (? y. (a,y) : r^+  &  (y,b) : r)" 1);
  22.276 +by (REPEAT (eresolve_tac ([asm_rl,disjE,exE,conjE]@prems) 1));
  22.277 +by (rtac (rewrite_rule [trancl_def] major RS compEpair) 1);
  22.278 +by (etac rtranclE 1);
  22.279 +by (Blast_tac 1);
  22.280 +by (blast_tac (claset() addSIs [rtrancl_into_trancl1]) 1);
  22.281 +qed "tranclE";
  22.282 +
  22.283 +(*Transitivity of r^+.
  22.284 +  Proved by unfolding since it uses transitivity of rtrancl. *)
  22.285 +Goalw [trancl_def] "trans(r^+)";
  22.286 +by (rtac transI 1);
  22.287 +by (REPEAT (etac compEpair 1));
  22.288 +by (rtac (rtrancl_into_rtrancl RS (rtrancl_trans RS compI)) 1);
  22.289 +by (REPEAT (assume_tac 1));
  22.290 +qed "trans_trancl";
  22.291 +
  22.292 +bind_thm ("trancl_trans", trans_trancl RS transD);
  22.293 +
  22.294 +Goalw [trancl_def] "[| (x,y):r^*; (y,z):r^+ |] ==> (x,z):r^+";
  22.295 +by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  22.296 +qed "rtrancl_trancl_trancl";
  22.297 +
  22.298 +(* "[| (a,b) : r;  (b,c) : r^+ |]   ==>  (a,c) : r^+" *)
  22.299 +bind_thm ("trancl_into_trancl2", [trans_trancl, r_into_trancl] MRS transD);
  22.300 +
  22.301 +(* primitive recursion for trancl over finite relations: *)
  22.302 +Goal "(insert (y,x) r)^+ = r^+ Un {(a,b). (a,y):r^* & (x,b):r^*}";
  22.303 +by (rtac equalityI 1);
  22.304 + by (rtac subsetI 1);
  22.305 + by (split_all_tac 1);
  22.306 + by (etac trancl_induct 1);
  22.307 +  by (blast_tac (claset() addIs [r_into_trancl]) 1);
  22.308 + by (blast_tac (claset() addIs
  22.309 +     [rtrancl_into_trancl1,trancl_into_rtrancl,r_into_trancl,trancl_trans]) 1);
  22.310 +by (rtac subsetI 1);
  22.311 +by (blast_tac (claset() addIs
  22.312 +     [rtrancl_into_trancl2, rtrancl_trancl_trancl,
  22.313 +      impOfSubs rtrancl_mono, trancl_mono]) 1);
  22.314 +qed "trancl_insert";
  22.315 +
  22.316 +Goalw [trancl_def] "(r^-1)^+ = (r^+)^-1";
  22.317 +by (simp_tac (simpset() addsimps [rtrancl_converse,converse_comp]) 1);
  22.318 +by (simp_tac (simpset() addsimps [rtrancl_converse RS sym,
  22.319 +				  r_comp_rtrancl_eq]) 1);
  22.320 +qed "trancl_converse";
  22.321 +
  22.322 +Goal "(x,y) : (r^+)^-1 ==> (x,y) : (r^-1)^+";
  22.323 +by (asm_full_simp_tac (simpset() addsimps [trancl_converse]) 1);
  22.324 +qed "trancl_converseI";
  22.325 +
  22.326 +Goal "(x,y) : (r^-1)^+ ==> (x,y) : (r^+)^-1";
  22.327 +by (asm_full_simp_tac (simpset() addsimps [trancl_converse]) 1);
  22.328 +qed "trancl_converseD";
  22.329 +
  22.330 +val major::prems = Goal
  22.331 +    "[| (a,b) : r^+; !!y. (y,b) : r ==> P(y); \
  22.332 +\       !!y z.[| (y,z) : r;  (z,b) : r^+;  P(z) |] ==> P(y) |]  \
  22.333 +\     ==> P(a)";
  22.334 +by (rtac ((major RS converseI RS trancl_converseI) RS trancl_induct) 1);
  22.335 + by (resolve_tac prems 1);
  22.336 + by (etac converseD 1);
  22.337 +by (blast_tac (claset() addIs prems addSDs [trancl_converseD])1);
  22.338 +qed "converse_trancl_induct";
  22.339 +
  22.340 +Goal "(x,y):R^+ ==> ? z. (x,z):R & (z,y):R^*";
  22.341 +be converse_trancl_induct 1;
  22.342 +by Auto_tac;
  22.343 +by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  22.344 +qed "tranclD";
  22.345 +
  22.346 +(*Unused*)
  22.347 +Goal "r^-1 Int r^+ = {} ==> (x, x) ~: r^+";
  22.348 +by (subgoal_tac "!y. (x, y) : r^+ --> x~=y" 1);
  22.349 +by (Fast_tac 1);
  22.350 +by (strip_tac 1);
  22.351 +by (etac trancl_induct 1);
  22.352 +by (auto_tac (claset() addIs [r_into_trancl], simpset()));
  22.353 +qed "irrefl_tranclI";
  22.354 +
  22.355 +Goal "!!X. [| !x. (x, x) ~: r^+; (x,y) : r |] ==> x ~= y";
  22.356 +by (blast_tac (claset() addDs [r_into_trancl]) 1);
  22.357 +qed "irrefl_trancl_rD";
  22.358 +
  22.359 +Goal "[| (a,b) : r^*;  r <= A <*> A |] ==> a=b | a:A";
  22.360 +by (etac rtrancl_induct 1);
  22.361 +by Auto_tac;
  22.362 +val lemma = result();
  22.363 +
  22.364 +Goalw [trancl_def] "r <= A <*> A ==> r^+ <= A <*> A";
  22.365 +by (blast_tac (claset() addSDs [lemma]) 1);
  22.366 +qed "trancl_subset_Sigma";
  22.367 +
  22.368 +
  22.369 +Goal "(r^+)^= = r^*";
  22.370 +by Safe_tac;
  22.371 +by  (etac trancl_into_rtrancl 1);
  22.372 +by (blast_tac (claset() addEs [rtranclE] addDs [rtrancl_into_trancl1]) 1);
  22.373 +qed "reflcl_trancl";
  22.374 +Addsimps[reflcl_trancl];
  22.375 +
  22.376 +Goal "(r^=)^+ = r^*";
  22.377 +by Safe_tac;
  22.378 +by  (dtac trancl_into_rtrancl 1);
  22.379 +by  (Asm_full_simp_tac 1);
  22.380 +by (etac rtranclE 1);
  22.381 +by  Safe_tac;
  22.382 +by  (rtac r_into_trancl 1);
  22.383 +by  (Simp_tac 1);
  22.384 +by (rtac rtrancl_into_trancl1 1);
  22.385 +by (etac (rtrancl_reflcl RS equalityD2 RS subsetD) 1);
  22.386 +by (Fast_tac 1);
  22.387 +qed "trancl_reflcl";
  22.388 +Addsimps[trancl_reflcl];
  22.389 +
  22.390 +Goal "{}^+ = {}";
  22.391 +by (auto_tac (claset() addEs [trancl_induct], simpset()));
  22.392 +qed "trancl_empty";
  22.393 +Addsimps[trancl_empty];
  22.394 +
  22.395 +Goal "{}^* = Id";
  22.396 +by (rtac (reflcl_trancl RS subst) 1);
  22.397 +by (Simp_tac 1);
  22.398 +qed "rtrancl_empty";
  22.399 +Addsimps[rtrancl_empty];
  22.400 +
  22.401 +Goal "(a,b):R^* ==> a=b | a~=b & (a,b):R^+";
  22.402 +by(force_tac (claset(), simpset() addsimps [reflcl_trancl RS sym] 
  22.403 +				  delsimps [reflcl_trancl]) 1);
  22.404 +qed "rtranclD";
  22.405 +
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/Transitive_Closure.thy	Thu Oct 12 18:44:35 2000 +0200
    23.3 @@ -0,0 +1,31 @@
    23.4 +(*  Title:      HOL/Transitive_Closure.thy
    23.5 +    ID:         $Id$
    23.6 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    23.7 +    Copyright   1992  University of Cambridge
    23.8 +
    23.9 +Relfexive and Transitive closure of a relation
   23.10 +
   23.11 +rtrancl is reflexive/transitive closure;
   23.12 +trancl  is transitive closure
   23.13 +reflcl  is reflexive closure
   23.14 +
   23.15 +These postfix operators have MAXIMUM PRIORITY, forcing their operands to be
   23.16 +      atomic.
   23.17 +*)
   23.18 +
   23.19 +Transitive_Closure = Lfp + Relation + 
   23.20 +
   23.21 +constdefs
   23.22 +  rtrancl :: "('a * 'a)set => ('a * 'a)set"   ("(_^*)" [1000] 999)
   23.23 +  "r^*  ==  lfp(%s. Id Un (r O s))"
   23.24 +
   23.25 +  trancl  :: "('a * 'a)set => ('a * 'a)set"   ("(_^+)" [1000] 999)
   23.26 +  "r^+  ==  r O rtrancl(r)"
   23.27 +
   23.28 +syntax
   23.29 +  "_reflcl"  :: "('a*'a)set => ('a*'a)set"       ("(_^=)" [1000] 999)
   23.30 +
   23.31 +translations
   23.32 +  "r^=" == "r Un Id"
   23.33 +
   23.34 +end
    24.1 --- a/src/HOL/Univ.ML	Thu Oct 12 18:38:23 2000 +0200
    24.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.3 @@ -1,595 +0,0 @@
    24.4 -(*  Title:      HOL/Univ
    24.5 -    ID:         $Id$
    24.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    24.7 -    Copyright   1991  University of Cambridge
    24.8 -*)
    24.9 -
   24.10 -(** apfst -- can be used in similar type definitions **)
   24.11 -
   24.12 -Goalw [apfst_def] "apfst f (a,b) = (f(a),b)";
   24.13 -by (rtac split 1);
   24.14 -qed "apfst_conv";
   24.15 -
   24.16 -val [major,minor] = Goal
   24.17 -    "[| q = apfst f p;  !!x y. [| p = (x,y);  q = (f(x),y) |] ==> R \
   24.18 -\    |] ==> R";
   24.19 -by (rtac PairE 1);
   24.20 -by (rtac minor 1);
   24.21 -by (assume_tac 1);
   24.22 -by (rtac (major RS trans) 1);
   24.23 -by (etac ssubst 1);
   24.24 -by (rtac apfst_conv 1);
   24.25 -qed "apfst_convE";
   24.26 -
   24.27 -(** Push -- an injection, analogous to Cons on lists **)
   24.28 -
   24.29 -Goalw [Push_def] "Push i f = Push j g  ==> i=j";
   24.30 -by (etac (fun_cong RS box_equals) 1);
   24.31 -by (rtac nat_case_0 1);
   24.32 -by (rtac nat_case_0 1);
   24.33 -qed "Push_inject1";
   24.34 -
   24.35 -Goalw [Push_def] "Push i f = Push j g  ==> f=g";
   24.36 -by (rtac (ext RS box_equals) 1);
   24.37 -by (etac fun_cong 1);
   24.38 -by (rtac (nat_case_Suc RS ext) 1);
   24.39 -by (rtac (nat_case_Suc RS ext) 1);
   24.40 -qed "Push_inject2";
   24.41 -
   24.42 -val [major,minor] = Goal
   24.43 -    "[| Push i f =Push j g;  [| i=j;  f=g |] ==> P \
   24.44 -\    |] ==> P";
   24.45 -by (rtac ((major RS Push_inject2) RS ((major RS Push_inject1) RS minor)) 1);
   24.46 -qed "Push_inject";
   24.47 -
   24.48 -Goalw [Push_def] "Push (Inr (Suc k)) f = (%z. Inr 0) ==> P";
   24.49 -by (rtac Suc_neq_Zero 1);
   24.50 -by (etac (fun_cong RS box_equals RS Inr_inject) 1);
   24.51 -by (rtac nat_case_0 1);
   24.52 -by (rtac refl 1);
   24.53 -qed "Push_neq_K0";
   24.54 -
   24.55 -(*** Isomorphisms ***)
   24.56 -
   24.57 -Goal "inj(Rep_Node)";
   24.58 -by (rtac inj_inverseI 1);       (*cannot combine by RS: multiple unifiers*)
   24.59 -by (rtac Rep_Node_inverse 1);
   24.60 -qed "inj_Rep_Node";
   24.61 -
   24.62 -Goal "inj_on Abs_Node Node";
   24.63 -by (rtac inj_on_inverseI 1);
   24.64 -by (etac Abs_Node_inverse 1);
   24.65 -qed "inj_on_Abs_Node";
   24.66 -
   24.67 -bind_thm ("Abs_Node_inject", inj_on_Abs_Node RS inj_onD);
   24.68 -
   24.69 -
   24.70 -(*** Introduction rules for Node ***)
   24.71 -
   24.72 -Goalw [Node_def] "(%k. Inr 0, a) : Node";
   24.73 -by (Blast_tac 1);
   24.74 -qed "Node_K0_I";
   24.75 -
   24.76 -Goalw [Node_def,Push_def]
   24.77 -    "p: Node ==> apfst (Push i) p : Node";
   24.78 -by (fast_tac (claset() addSIs [apfst_conv, nat_case_Suc RS trans]) 1);
   24.79 -qed "Node_Push_I";
   24.80 -
   24.81 -
   24.82 -(*** Distinctness of constructors ***)
   24.83 -
   24.84 -(** Scons vs Atom **)
   24.85 -
   24.86 -Goalw [Atom_def,Scons_def,Push_Node_def] "Scons M N ~= Atom(a)";
   24.87 -by (rtac notI 1);
   24.88 -by (etac (equalityD2 RS subsetD RS UnE) 1);
   24.89 -by (rtac singletonI 1);
   24.90 -by (REPEAT (eresolve_tac [imageE, Abs_Node_inject RS apfst_convE, 
   24.91 -                          Pair_inject, sym RS Push_neq_K0] 1
   24.92 -     ORELSE resolve_tac [Node_K0_I, Rep_Node RS Node_Push_I] 1));
   24.93 -qed "Scons_not_Atom";
   24.94 -bind_thm ("Atom_not_Scons", Scons_not_Atom RS not_sym);
   24.95 -
   24.96 -
   24.97 -(*** Injectiveness ***)
   24.98 -
   24.99 -(** Atomic nodes **)
  24.100 -
  24.101 -Goalw [Atom_def] "inj(Atom)";
  24.102 -by (blast_tac (claset() addSIs [injI, Node_K0_I] addSDs [Abs_Node_inject]) 1);
  24.103 -qed "inj_Atom";
  24.104 -bind_thm ("Atom_inject", inj_Atom RS injD);
  24.105 -
  24.106 -Goal "(Atom(a)=Atom(b)) = (a=b)";
  24.107 -by (blast_tac (claset() addSDs [Atom_inject]) 1);
  24.108 -qed "Atom_Atom_eq";
  24.109 -AddIffs [Atom_Atom_eq];
  24.110 -
  24.111 -Goalw [Leaf_def,o_def] "inj(Leaf)";
  24.112 -by (rtac injI 1);
  24.113 -by (etac (Atom_inject RS Inl_inject) 1);
  24.114 -qed "inj_Leaf";
  24.115 -
  24.116 -bind_thm ("Leaf_inject", inj_Leaf RS injD);
  24.117 -AddSDs [Leaf_inject];
  24.118 -
  24.119 -Goalw [Numb_def,o_def] "inj(Numb)";
  24.120 -by (rtac injI 1);
  24.121 -by (etac (Atom_inject RS Inr_inject) 1);
  24.122 -qed "inj_Numb";
  24.123 -
  24.124 -bind_thm ("Numb_inject", inj_Numb RS injD);
  24.125 -AddSDs [Numb_inject];
  24.126 -
  24.127 -(** Injectiveness of Push_Node **)
  24.128 -
  24.129 -val [major,minor] = Goalw [Push_Node_def]
  24.130 -    "[| Push_Node i m =Push_Node j n;  [| i=j;  m=n |] ==> P \
  24.131 -\    |] ==> P";
  24.132 -by (rtac (major RS Abs_Node_inject RS apfst_convE) 1);
  24.133 -by (REPEAT (resolve_tac [Rep_Node RS Node_Push_I] 1));
  24.134 -by (etac (sym RS apfst_convE) 1);
  24.135 -by (rtac minor 1);
  24.136 -by (etac Pair_inject 1);
  24.137 -by (etac (Push_inject1 RS sym) 1);
  24.138 -by (rtac (inj_Rep_Node RS injD) 1);
  24.139 -by (etac trans 1);
  24.140 -by (safe_tac (claset() addSEs [Push_inject,sym]));
  24.141 -qed "Push_Node_inject";
  24.142 -
  24.143 -
  24.144 -(** Injectiveness of Scons **)
  24.145 -
  24.146 -Goalw [Scons_def] "Scons M N <= Scons M' N' ==> M<=M'";
  24.147 -by (blast_tac (claset() addSDs [Push_Node_inject]) 1);
  24.148 -qed "Scons_inject_lemma1";
  24.149 -
  24.150 -Goalw [Scons_def] "Scons M N <= Scons M' N' ==> N<=N'";
  24.151 -by (blast_tac (claset() addSDs [Push_Node_inject]) 1);
  24.152 -qed "Scons_inject_lemma2";
  24.153 -
  24.154 -Goal "Scons M N = Scons M' N' ==> M=M'";
  24.155 -by (etac equalityE 1);
  24.156 -by (REPEAT (ares_tac [equalityI, Scons_inject_lemma1] 1));
  24.157 -qed "Scons_inject1";
  24.158 -
  24.159 -Goal "Scons M N = Scons M' N' ==> N=N'";
  24.160 -by (etac equalityE 1);
  24.161 -by (REPEAT (ares_tac [equalityI, Scons_inject_lemma2] 1));
  24.162 -qed "Scons_inject2";
  24.163 -
  24.164 -val [major,minor] = Goal
  24.165 -    "[| Scons M N = Scons M' N';  [| M=M';  N=N' |] ==> P \
  24.166 -\    |] ==> P";
  24.167 -by (rtac ((major RS Scons_inject2) RS ((major RS Scons_inject1) RS minor)) 1);
  24.168 -qed "Scons_inject";
  24.169 -
  24.170 -Goal "(Scons M N = Scons M' N') = (M=M' & N=N')";
  24.171 -by (blast_tac (claset() addSEs [Scons_inject]) 1);
  24.172 -qed "Scons_Scons_eq";
  24.173 -
  24.174 -(*** Distinctness involving Leaf and Numb ***)
  24.175 -
  24.176 -(** Scons vs Leaf **)
  24.177 -
  24.178 -Goalw [Leaf_def,o_def] "Scons M N ~= Leaf(a)";
  24.179 -by (rtac Scons_not_Atom 1);
  24.180 -qed "Scons_not_Leaf";
  24.181 -bind_thm ("Leaf_not_Scons", Scons_not_Leaf RS not_sym);
  24.182 -
  24.183 -AddIffs [Scons_not_Leaf, Leaf_not_Scons];
  24.184 -
  24.185 -
  24.186 -(** Scons vs Numb **)
  24.187 -
  24.188 -Goalw [Numb_def,o_def] "Scons M N ~= Numb(k)";
  24.189 -by (rtac Scons_not_Atom 1);
  24.190 -qed "Scons_not_Numb";
  24.191 -bind_thm ("Numb_not_Scons", Scons_not_Numb RS not_sym);
  24.192 -
  24.193 -AddIffs [Scons_not_Numb, Numb_not_Scons];
  24.194 -
  24.195 -
  24.196 -(** Leaf vs Numb **)
  24.197 -
  24.198 -Goalw [Leaf_def,Numb_def] "Leaf(a) ~= Numb(k)";
  24.199 -by (simp_tac (simpset() addsimps [Inl_not_Inr]) 1);
  24.200 -qed "Leaf_not_Numb";
  24.201 -bind_thm ("Numb_not_Leaf", Leaf_not_Numb RS not_sym);
  24.202 -
  24.203 -AddIffs [Leaf_not_Numb, Numb_not_Leaf];
  24.204 -
  24.205 -
  24.206 -(*** ndepth -- the depth of a node ***)
  24.207 -
  24.208 -Addsimps [apfst_conv];
  24.209 -AddIffs  [Scons_not_Atom, Atom_not_Scons, Scons_Scons_eq];
  24.210 -
  24.211 -
  24.212 -Goalw [ndepth_def] "ndepth (Abs_Node(%k. Inr 0, x)) = 0";
  24.213 -by (EVERY1[stac (Node_K0_I RS Abs_Node_inverse), stac split]);
  24.214 -by (rtac Least_equality 1);
  24.215 -by (rtac refl 1);
  24.216 -by (etac less_zeroE 1);
  24.217 -qed "ndepth_K0";
  24.218 -
  24.219 -Goal "k < Suc(LEAST x. f x = Inr 0) --> nat_case (Inr (Suc i)) f k ~= Inr 0";
  24.220 -by (induct_tac "k" 1);
  24.221 -by (ALLGOALS Simp_tac);
  24.222 -by (rtac impI 1);
  24.223 -by (etac not_less_Least 1);
  24.224 -val lemma = result();
  24.225 -
  24.226 -Goalw [ndepth_def,Push_Node_def]
  24.227 -    "ndepth (Push_Node (Inr (Suc i)) n) = Suc(ndepth(n))";
  24.228 -by (stac (Rep_Node RS Node_Push_I RS Abs_Node_inverse) 1);
  24.229 -by (cut_facts_tac [rewrite_rule [Node_def] Rep_Node] 1);
  24.230 -by Safe_tac;
  24.231 -by (etac ssubst 1);  (*instantiates type variables!*)
  24.232 -by (Simp_tac 1);
  24.233 -by (rtac Least_equality 1);
  24.234 -by (rewtac Push_def);
  24.235 -by (rtac (nat_case_Suc RS trans) 1);
  24.236 -by (etac LeastI 1);
  24.237 -by (asm_simp_tac (simpset() addsimps [lemma]) 1);
  24.238 -qed "ndepth_Push_Node";
  24.239 -
  24.240 -
  24.241 -(*** ntrunc applied to the various node sets ***)
  24.242 -
  24.243 -Goalw [ntrunc_def] "ntrunc 0 M = {}";
  24.244 -by (Blast_tac 1);
  24.245 -qed "ntrunc_0";
  24.246 -
  24.247 -Goalw [Atom_def,ntrunc_def] "ntrunc (Suc k) (Atom a) = Atom(a)";
  24.248 -by (fast_tac (claset() addss (simpset() addsimps [ndepth_K0])) 1);
  24.249 -qed "ntrunc_Atom";
  24.250 -
  24.251 -Goalw [Leaf_def,o_def] "ntrunc (Suc k) (Leaf a) = Leaf(a)";
  24.252 -by (rtac ntrunc_Atom 1);
  24.253 -qed "ntrunc_Leaf";
  24.254 -
  24.255 -Goalw [Numb_def,o_def] "ntrunc (Suc k) (Numb i) = Numb(i)";
  24.256 -by (rtac ntrunc_Atom 1);
  24.257 -qed "ntrunc_Numb";
  24.258 -
  24.259 -Goalw [Scons_def,ntrunc_def]
  24.260 -    "ntrunc (Suc k) (Scons M N) = Scons (ntrunc k M) (ntrunc k N)";
  24.261 -by (safe_tac (claset() addSIs [imageI]));
  24.262 -by (REPEAT (stac ndepth_Push_Node 3 THEN etac Suc_mono 3));
  24.263 -by (REPEAT (rtac Suc_less_SucD 1 THEN 
  24.264 -            rtac (ndepth_Push_Node RS subst) 1 THEN 
  24.265 -            assume_tac 1));
  24.266 -qed "ntrunc_Scons";
  24.267 -
  24.268 -Addsimps [ntrunc_0, ntrunc_Atom, ntrunc_Leaf, ntrunc_Numb, ntrunc_Scons];
  24.269 -
  24.270 -
  24.271 -(** Injection nodes **)
  24.272 -
  24.273 -Goalw [In0_def] "ntrunc 1 (In0 M) = {}";
  24.274 -by (Simp_tac 1);
  24.275 -by (rewtac Scons_def);
  24.276 -by (Blast_tac 1);
  24.277 -qed "ntrunc_one_In0";
  24.278 -
  24.279 -Goalw [In0_def]
  24.280 -    "ntrunc (Suc (Suc k)) (In0 M) = In0 (ntrunc (Suc k) M)";
  24.281 -by (Simp_tac 1);
  24.282 -qed "ntrunc_In0";
  24.283 -
  24.284 -Goalw [In1_def] "ntrunc 1 (In1 M) = {}";
  24.285 -by (Simp_tac 1);
  24.286 -by (rewtac Scons_def);
  24.287 -by (Blast_tac 1);
  24.288 -qed "ntrunc_one_In1";
  24.289 -
  24.290 -Goalw [In1_def]
  24.291 -    "ntrunc (Suc (Suc k)) (In1 M) = In1 (ntrunc (Suc k) M)";
  24.292 -by (Simp_tac 1);
  24.293 -qed "ntrunc_In1";
  24.294 -
  24.295 -Addsimps [ntrunc_one_In0, ntrunc_In0, ntrunc_one_In1, ntrunc_In1];
  24.296 -
  24.297 -
  24.298 -(*** Cartesian Product ***)
  24.299 -
  24.300 -Goalw [uprod_def] "[| M:A;  N:B |] ==> Scons M N : uprod A B";
  24.301 -by (REPEAT (ares_tac [singletonI,UN_I] 1));
  24.302 -qed "uprodI";
  24.303 -
  24.304 -(*The general elimination rule*)
  24.305 -val major::prems = Goalw [uprod_def]
  24.306 -    "[| c : uprod A B;  \
  24.307 -\       !!x y. [| x:A;  y:B;  c = Scons x y |] ==> P \
  24.308 -\    |] ==> P";
  24.309 -by (cut_facts_tac [major] 1);
  24.310 -by (REPEAT (eresolve_tac [asm_rl,singletonE,UN_E] 1
  24.311 -     ORELSE resolve_tac prems 1));
  24.312 -qed "uprodE";
  24.313 -
  24.314 -(*Elimination of a pair -- introduces no eigenvariables*)
  24.315 -val prems = Goal
  24.316 -    "[| Scons M N : uprod A B;      [| M:A;  N:B |] ==> P   \
  24.317 -\    |] ==> P";
  24.318 -by (rtac uprodE 1);
  24.319 -by (REPEAT (ares_tac prems 1 ORELSE eresolve_tac [Scons_inject,ssubst] 1));
  24.320 -qed "uprodE2";
  24.321 -
  24.322 -
  24.323 -(*** Disjoint Sum ***)
  24.324 -
  24.325 -Goalw [usum_def] "M:A ==> In0(M) : usum A B";
  24.326 -by (Blast_tac 1);
  24.327 -qed "usum_In0I";
  24.328 -
  24.329 -Goalw [usum_def] "N:B ==> In1(N) : usum A B";
  24.330 -by (Blast_tac 1);
  24.331 -qed "usum_In1I";
  24.332 -
  24.333 -val major::prems = Goalw [usum_def]
  24.334 -    "[| u : usum A B;  \
  24.335 -\       !!x. [| x:A;  u=In0(x) |] ==> P; \
  24.336 -\       !!y. [| y:B;  u=In1(y) |] ==> P \
  24.337 -\    |] ==> P";
  24.338 -by (rtac (major RS UnE) 1);
  24.339 -by (REPEAT (rtac refl 1 
  24.340 -     ORELSE eresolve_tac (prems@[imageE,ssubst]) 1));
  24.341 -qed "usumE";
  24.342 -
  24.343 -
  24.344 -(** Injection **)
  24.345 -
  24.346 -Goalw [In0_def,In1_def] "In0(M) ~= In1(N)";
  24.347 -by (rtac notI 1);
  24.348 -by (etac (Scons_inject1 RS Numb_inject RS Zero_neq_Suc) 1);
  24.349 -qed "In0_not_In1";
  24.350 -
  24.351 -bind_thm ("In1_not_In0", In0_not_In1 RS not_sym);
  24.352 -
  24.353 -AddIffs [In0_not_In1, In1_not_In0];
  24.354 -
  24.355 -Goalw [In0_def] "In0(M) = In0(N) ==>  M=N";
  24.356 -by (etac (Scons_inject2) 1);
  24.357 -qed "In0_inject";
  24.358 -
  24.359 -Goalw [In1_def] "In1(M) = In1(N) ==>  M=N";
  24.360 -by (etac (Scons_inject2) 1);
  24.361 -qed "In1_inject";
  24.362 -
  24.363 -Goal "(In0 M = In0 N) = (M=N)";
  24.364 -by (blast_tac (claset() addSDs [In0_inject]) 1);
  24.365 -qed "In0_eq";
  24.366 -
  24.367 -Goal "(In1 M = In1 N) = (M=N)";
  24.368 -by (blast_tac (claset() addSDs [In1_inject]) 1);
  24.369 -qed "In1_eq";
  24.370 -
  24.371 -AddIffs [In0_eq, In1_eq];
  24.372 -
  24.373 -Goal "inj In0";
  24.374 -by (blast_tac (claset() addSIs [injI]) 1);
  24.375 -qed "inj_In0";
  24.376 -
  24.377 -Goal "inj In1";
  24.378 -by (blast_tac (claset() addSIs [injI]) 1);
  24.379 -qed "inj_In1";
  24.380 -
  24.381 -
  24.382 -(*** Function spaces ***)
  24.383 -
  24.384 -Goalw [Lim_def] "Lim f = Lim g ==> f = g";
  24.385 -by (rtac ext 1);
  24.386 -by (blast_tac (claset() addSEs [Push_Node_inject]) 1);
  24.387 -qed "Lim_inject";
  24.388 -
  24.389 -Goalw [Funs_def] "S <= T ==> Funs S <= Funs T";
  24.390 -by (Blast_tac 1);
  24.391 -qed "Funs_mono";
  24.392 -
  24.393 -val [prem] = Goalw [Funs_def] "(!!x. f x : S) ==> f : Funs S";
  24.394 -by (blast_tac (claset() addIs [prem]) 1);
  24.395 -qed "FunsI";
  24.396 -
  24.397 -Goalw [Funs_def] "f : Funs S ==> f x : S";
  24.398 -by (etac CollectE 1);
  24.399 -by (etac subsetD 1);
  24.400 -by (rtac rangeI 1);
  24.401 -qed "FunsD";
  24.402 -
  24.403 -val [p1, p2] = Goalw [o_def]
  24.404 -   "[| f : Funs R; !!x. x : R ==> r (a x) = x |] ==> r o (a o f) = f";
  24.405 -by (rtac (p2 RS ext) 1);
  24.406 -by (rtac (p1 RS FunsD) 1);
  24.407 -qed "Funs_inv";
  24.408 -
  24.409 -val [p1, p2] = Goalw [o_def]
  24.410 -     "[| f : Funs (range g); !!h. f = g o h ==> P |] ==> P";
  24.411 -by (res_inst_tac [("h", "%x. @y. (f::'a=>'b) x = g y")] p2 1);
  24.412 -by (rtac ext 1);
  24.413 -by (rtac (p1 RS FunsD RS rangeE) 1);
  24.414 -by (etac (exI RS (some_eq_ex RS iffD2)) 1);
  24.415 -qed "Funs_rangeE";
  24.416 -
  24.417 -Goal "a : S ==> (%x. a) : Funs S";
  24.418 -by (rtac FunsI 1);
  24.419 -by (assume_tac 1);
  24.420 -qed "Funs_nonempty";
  24.421 -
  24.422 -
  24.423 -(*** proving equality of sets and functions using ntrunc ***)
  24.424 -
  24.425 -Goalw [ntrunc_def] "ntrunc k M <= M";
  24.426 -by (Blast_tac 1);
  24.427 -qed "ntrunc_subsetI";
  24.428 -
  24.429 -val [major] = Goalw [ntrunc_def] "(!!k. ntrunc k M <= N) ==> M<=N";
  24.430 -by (blast_tac (claset() addIs [less_add_Suc1, less_add_Suc2, 
  24.431 -			       major RS subsetD]) 1);
  24.432 -qed "ntrunc_subsetD";
  24.433 -
  24.434 -(*A generalized form of the take-lemma*)
  24.435 -val [major] = Goal "(!!k. ntrunc k M = ntrunc k N) ==> M=N";
  24.436 -by (rtac equalityI 1);
  24.437 -by (ALLGOALS (rtac ntrunc_subsetD));
  24.438 -by (ALLGOALS (rtac (ntrunc_subsetI RSN (2, subset_trans))));
  24.439 -by (rtac (major RS equalityD1) 1);
  24.440 -by (rtac (major RS equalityD2) 1);
  24.441 -qed "ntrunc_equality";
  24.442 -
  24.443 -val [major] = Goalw [o_def]
  24.444 -    "[| !!k. (ntrunc(k) o h1) = (ntrunc(k) o h2) |] ==> h1=h2";
  24.445 -by (rtac (ntrunc_equality RS ext) 1);
  24.446 -by (rtac (major RS fun_cong) 1);
  24.447 -qed "ntrunc_o_equality";
  24.448 -
  24.449 -(*** Monotonicity ***)
  24.450 -
  24.451 -Goalw [uprod_def] "[| A<=A';  B<=B' |] ==> uprod A B <= uprod A' B'";
  24.452 -by (Blast_tac 1);
  24.453 -qed "uprod_mono";
  24.454 -
  24.455 -Goalw [usum_def] "[| A<=A';  B<=B' |] ==> usum A B <= usum A' B'";
  24.456 -by (Blast_tac 1);
  24.457 -qed "usum_mono";
  24.458 -
  24.459 -Goalw [Scons_def] "[| M<=M';  N<=N' |] ==> Scons M N <= Scons M' N'";
  24.460 -by (Blast_tac 1);
  24.461 -qed "Scons_mono";
  24.462 -
  24.463 -Goalw [In0_def] "M<=N ==> In0(M) <= In0(N)";
  24.464 -by (REPEAT (ares_tac [subset_refl,Scons_mono] 1));
  24.465 -qed "In0_mono";
  24.466 -
  24.467 -Goalw [In1_def] "M<=N ==> In1(M) <= In1(N)";
  24.468 -by (REPEAT (ares_tac [subset_refl,Scons_mono] 1));
  24.469 -qed "In1_mono";
  24.470 -
  24.471 -
  24.472 -(*** Split and Case ***)
  24.473 -
  24.474 -Goalw [Split_def] "Split c (Scons M N) = c M N";
  24.475 -by (Blast_tac  1);
  24.476 -qed "Split";
  24.477 -
  24.478 -Goalw [Case_def] "Case c d (In0 M) = c(M)";
  24.479 -by (Blast_tac 1);
  24.480 -qed "Case_In0";
  24.481 -
  24.482 -Goalw [Case_def] "Case c d (In1 N) = d(N)";
  24.483 -by (Blast_tac 1);
  24.484 -qed "Case_In1";
  24.485 -
  24.486 -Addsimps [Split, Case_In0, Case_In1];
  24.487 -
  24.488 -
  24.489 -(**** UN x. B(x) rules ****)
  24.490 -
  24.491 -Goalw [ntrunc_def] "ntrunc k (UN x. f(x)) = (UN x. ntrunc k (f x))";
  24.492 -by (Blast_tac 1);
  24.493 -qed "ntrunc_UN1";
  24.494 -
  24.495 -Goalw [Scons_def] "Scons (UN x. f x) M = (UN x. Scons (f x) M)";
  24.496 -by (Blast_tac 1);
  24.497 -qed "Scons_UN1_x";
  24.498 -
  24.499 -Goalw [Scons_def] "Scons M (UN x. f x) = (UN x. Scons M (f x))";
  24.500 -by (Blast_tac 1);
  24.501 -qed "Scons_UN1_y";
  24.502 -
  24.503 -Goalw [In0_def] "In0(UN x. f(x)) = (UN x. In0(f(x)))";
  24.504 -by (rtac Scons_UN1_y 1);
  24.505 -qed "In0_UN1";
  24.506 -
  24.507 -Goalw [In1_def] "In1(UN x. f(x)) = (UN x. In1(f(x)))";
  24.508 -by (rtac Scons_UN1_y 1);
  24.509 -qed "In1_UN1";
  24.510 -
  24.511 -
  24.512 -(*** Equality for Cartesian Product ***)
  24.513 -
  24.514 -Goalw [dprod_def]
  24.515 -    "[| (M,M'):r;  (N,N'):s |] ==> (Scons M N, Scons M' N') : dprod r s";
  24.516 -by (Blast_tac 1);
  24.517 -qed "dprodI";
  24.518 -
  24.519 -(*The general elimination rule*)
  24.520 -val major::prems = Goalw [dprod_def]
  24.521 -    "[| c : dprod r s;  \
  24.522 -\       !!x y x' y'. [| (x,x') : r;  (y,y') : s;  c = (Scons x y, Scons x' y') |] ==> P \
  24.523 -\    |] ==> P";
  24.524 -by (cut_facts_tac [major] 1);
  24.525 -by (REPEAT_FIRST (eresolve_tac [asm_rl, UN_E, mem_splitE, singletonE]));
  24.526 -by (REPEAT (ares_tac prems 1 ORELSE hyp_subst_tac 1));
  24.527 -qed "dprodE";
  24.528 -
  24.529 -
  24.530 -(*** Equality for Disjoint Sum ***)
  24.531 -
  24.532 -Goalw [dsum_def]  "(M,M'):r ==> (In0(M), In0(M')) : dsum r s";
  24.533 -by (Blast_tac 1);
  24.534 -qed "dsum_In0I";
  24.535 -
  24.536 -Goalw [dsum_def]  "(N,N'):s ==> (In1(N), In1(N')) : dsum r s";
  24.537 -by (Blast_tac 1);
  24.538 -qed "dsum_In1I";
  24.539 -
  24.540 -val major::prems = Goalw [dsum_def]
  24.541 -    "[| w : dsum r s;  \
  24.542 -\       !!x x'. [| (x,x') : r;  w = (In0(x), In0(x')) |] ==> P; \
  24.543 -\       !!y y'. [| (y,y') : s;  w = (In1(y), In1(y')) |] ==> P \
  24.544 -\    |] ==> P";
  24.545 -by (cut_facts_tac [major] 1);
  24.546 -by (REPEAT_FIRST (eresolve_tac [asm_rl, UN_E, UnE, mem_splitE, singletonE]));
  24.547 -by (DEPTH_SOLVE (ares_tac prems 1 ORELSE hyp_subst_tac 1));
  24.548 -qed "dsumE";
  24.549 -
  24.550 -AddSIs [uprodI, dprodI];
  24.551 -AddIs  [usum_In0I, usum_In1I, dsum_In0I, dsum_In1I];
  24.552 -AddSEs [uprodE, dprodE, usumE, dsumE];
  24.553 -
  24.554 -
  24.555 -(*** Monotonicity ***)
  24.556 -
  24.557 -Goal "[| r<=r';  s<=s' |] ==> dprod r s <= dprod r' s'";
  24.558 -by (Blast_tac 1);
  24.559 -qed "dprod_mono";
  24.560 -
  24.561 -Goal "[| r<=r';  s<=s' |] ==> dsum r s <= dsum r' s'";
  24.562 -by (Blast_tac 1);
  24.563 -qed "dsum_mono";
  24.564 -
  24.565 -
  24.566 -(*** Bounding theorems ***)
  24.567 -
  24.568 -Goal "(dprod (A <*> B) (C <*> D)) <= (uprod A C) <*> (uprod B D)";
  24.569 -by (Blast_tac 1);
  24.570 -qed "dprod_Sigma";
  24.571 -
  24.572 -bind_thm ("dprod_subset_Sigma", [dprod_mono, dprod_Sigma] MRS subset_trans |> standard);
  24.573 -
  24.574 -(*Dependent version*)
  24.575 -Goal "(dprod (Sigma A B) (Sigma C D)) <= Sigma (uprod A C) (Split (%x y. uprod (B x) (D y)))";
  24.576 -by Safe_tac;
  24.577 -by (stac Split 1);
  24.578 -by (Blast_tac 1);
  24.579 -qed "dprod_subset_Sigma2";
  24.580 -
  24.581 -Goal "(dsum (A <*> B) (C <*> D)) <= (usum A C) <*> (usum B D)";
  24.582 -by (Blast_tac 1);
  24.583 -qed "dsum_Sigma";
  24.584 -
  24.585 -bind_thm ("dsum_subset_Sigma", [dsum_mono, dsum_Sigma] MRS subset_trans |> standard);
  24.586 -
  24.587 -
  24.588 -(*** Domain ***)
  24.589 -
  24.590 -Goal "Domain (dprod r s) = uprod (Domain r) (Domain s)";
  24.591 -by Auto_tac;
  24.592 -qed "Domain_dprod";
  24.593 -
  24.594 -Goal "Domain (dsum r s) = usum (Domain r) (Domain s)";
  24.595 -by Auto_tac;
  24.596 -qed "Domain_dsum";
  24.597 -
  24.598 -Addsimps [Domain_dprod, Domain_dsum];
    25.1 --- a/src/HOL/Univ.thy	Thu Oct 12 18:38:23 2000 +0200
    25.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.3 @@ -1,102 +0,0 @@
    25.4 -(*  Title:      HOL/Univ.thy
    25.5 -    ID:         $Id$
    25.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    25.7 -    Copyright   1993  University of Cambridge
    25.8 -
    25.9 -Declares the type ('a, 'b) node, a subtype of (nat=>'b+nat) * ('a+nat)
   25.10 -
   25.11 -Defines "Cartesian Product" and "Disjoint Sum" as set operations.
   25.12 -Could <*> be generalized to a general summation (Sigma)?
   25.13 -*)
   25.14 -
   25.15 -Univ = Arith + Sum +
   25.16 -
   25.17 -
   25.18 -(** lists, trees will be sets of nodes **)
   25.19 -
   25.20 -typedef (Node)
   25.21 -  ('a, 'b) node = "{p. EX f x k. p = (f::nat=>'b+nat, x::'a+nat) & f k = Inr 0}"
   25.22 -
   25.23 -types
   25.24 -  'a item = ('a, unit) node set
   25.25 -  ('a, 'b) dtree = ('a, 'b) node set
   25.26 -
   25.27 -consts
   25.28 -  apfst     :: "['a=>'c, 'a*'b] => 'c*'b"
   25.29 -  Push      :: "[('b + nat), nat => ('b + nat)] => (nat => ('b + nat))"
   25.30 -
   25.31 -  Push_Node :: "[('b + nat), ('a, 'b) node] => ('a, 'b) node"
   25.32 -  ndepth    :: ('a, 'b) node => nat
   25.33 -
   25.34 -  Atom      :: "('a + nat) => ('a, 'b) dtree"
   25.35 -  Leaf      :: 'a => ('a, 'b) dtree
   25.36 -  Numb      :: nat => ('a, 'b) dtree
   25.37 -  Scons     :: [('a, 'b) dtree, ('a, 'b) dtree] => ('a, 'b) dtree
   25.38 -  In0,In1   :: ('a, 'b) dtree => ('a, 'b) dtree
   25.39 -
   25.40 -  Lim       :: ('b => ('a, 'b) dtree) => ('a, 'b) dtree
   25.41 -  Funs      :: "'u set => ('t => 'u) set"
   25.42 -
   25.43 -  ntrunc    :: [nat, ('a, 'b) dtree] => ('a, 'b) dtree
   25.44 -
   25.45 -  uprod     :: [('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set
   25.46 -  usum      :: [('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set
   25.47 -
   25.48 -  Split     :: [[('a, 'b) dtree, ('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c
   25.49 -  Case      :: [[('a, 'b) dtree]=>'c, [('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c
   25.50 -
   25.51 -  dprod     :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set] 
   25.52 -                => (('a, 'b) dtree * ('a, 'b) dtree)set"
   25.53 -  dsum      :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set] 
   25.54 -                => (('a, 'b) dtree * ('a, 'b) dtree)set"
   25.55 -
   25.56 -
   25.57 -defs
   25.58 -
   25.59 -  Push_Node_def  "Push_Node == (%n x. Abs_Node (apfst (Push n) (Rep_Node x)))"
   25.60 -
   25.61 -  (*crude "lists" of nats -- needed for the constructions*)
   25.62 -  apfst_def  "apfst == (%f (x,y). (f(x),y))"
   25.63 -  Push_def   "Push == (%b h. nat_case b h)"
   25.64 -
   25.65 -  (** operations on S-expressions -- sets of nodes **)
   25.66 -
   25.67 -  (*S-expression constructors*)
   25.68 -  Atom_def   "Atom == (%x. {Abs_Node((%k. Inr 0, x))})"
   25.69 -  Scons_def  "Scons M N == (Push_Node (Inr 1) `` M) Un (Push_Node (Inr 2) `` N)"
   25.70 -
   25.71 -  (*Leaf nodes, with arbitrary or nat labels*)
   25.72 -  Leaf_def   "Leaf == Atom o Inl"
   25.73 -  Numb_def   "Numb == Atom o Inr"
   25.74 -
   25.75 -  (*Injections of the "disjoint sum"*)
   25.76 -  In0_def    "In0(M) == Scons (Numb 0) M"
   25.77 -  In1_def    "In1(M) == Scons (Numb 1) M"
   25.78 -
   25.79 -  (*Function spaces*)
   25.80 -  Lim_def "Lim f == Union {z. ? x. z = Push_Node (Inl x) `` (f x)}"
   25.81 -  Funs_def "Funs S == {f. range f <= S}"
   25.82 -
   25.83 -  (*the set of nodes with depth less than k*)
   25.84 -  ndepth_def "ndepth(n) == (%(f,x). LEAST k. f k = Inr 0) (Rep_Node n)"
   25.85 -  ntrunc_def "ntrunc k N == {n. n:N & ndepth(n)<k}"
   25.86 -
   25.87 -  (*products and sums for the "universe"*)
   25.88 -  uprod_def  "uprod A B == UN x:A. UN y:B. { Scons x y }"
   25.89 -  usum_def   "usum A B == In0``A Un In1``B"
   25.90 -
   25.91 -  (*the corresponding eliminators*)
   25.92 -  Split_def  "Split c M == @u. ? x y. M = Scons x y & u = c x y"
   25.93 -
   25.94 -  Case_def   "Case c d M == @u.  (? x . M = In0(x) & u = c(x)) 
   25.95 -                               | (? y . M = In1(y) & u = d(y))"
   25.96 -
   25.97 -
   25.98 -  (** equality for the "universe" **)
   25.99 -
  25.100 -  dprod_def  "dprod r s == UN (x,x'):r. UN (y,y'):s. {(Scons x y, Scons x' y')}"
  25.101 -
  25.102 -  dsum_def   "dsum r s == (UN (x,x'):r. {(In0(x),In0(x'))}) Un 
  25.103 -                          (UN (y,y'):s. {(In1(y),In1(y'))})"
  25.104 -
  25.105 -end
    26.1 --- a/src/HOL/Vimage.ML	Thu Oct 12 18:38:23 2000 +0200
    26.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.3 @@ -1,108 +0,0 @@
    26.4 -(*  Title:      HOL/Vimage
    26.5 -    ID:         $Id$
    26.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    26.7 -    Copyright   1998  University of Cambridge
    26.8 -
    26.9 -Inverse image of a function
   26.10 -*)
   26.11 -
   26.12 -(** Basic rules **)
   26.13 -
   26.14 -Goalw [vimage_def] "(a : f-``B) = (f a : B)";
   26.15 -by (Blast_tac 1) ;
   26.16 -qed "vimage_eq";
   26.17 -
   26.18 -Addsimps [vimage_eq];
   26.19 -
   26.20 -Goal "(a : f-``{b}) = (f a = b)";
   26.21 -by (simp_tac (simpset() addsimps [vimage_eq]) 1) ;
   26.22 -qed "vimage_singleton_eq";
   26.23 -
   26.24 -Goalw [vimage_def]
   26.25 -    "!!A B f. [| f a = b;  b:B |] ==> a : f-``B";
   26.26 -by (Blast_tac 1) ;
   26.27 -qed "vimageI";
   26.28 -
   26.29 -Goalw [vimage_def] "f a : A ==> a : f -`` A";
   26.30 -by (Fast_tac 1);
   26.31 -qed "vimageI2";
   26.32 -
   26.33 -val major::prems = Goalw [vimage_def]
   26.34 -    "[| a: f-``B;  !!x.[| f a = x;  x:B |] ==> P |] ==> P";
   26.35 -by (rtac (major RS CollectE) 1);
   26.36 -by (blast_tac (claset() addIs prems) 1) ;
   26.37 -qed "vimageE";
   26.38 -
   26.39 -Goalw [vimage_def] "a : f -`` A ==> f a : A";
   26.40 -by (Fast_tac 1);
   26.41 -qed "vimageD";
   26.42 -
   26.43 -AddIs  [vimageI];
   26.44 -AddSEs [vimageE];
   26.45 -
   26.46 -
   26.47 -(*** Equations ***)
   26.48 -
   26.49 -Goal "f-``{} = {}";
   26.50 -by (Blast_tac 1);
   26.51 -qed "vimage_empty";
   26.52 -
   26.53 -Goal "f-``(-A) = -(f-``A)";
   26.54 -by (Blast_tac 1);
   26.55 -qed "vimage_Compl";
   26.56 -
   26.57 -Goal "f-``(A Un B) = (f-``A) Un (f-``B)";
   26.58 -by (Blast_tac 1);
   26.59 -qed "vimage_Un";
   26.60 -
   26.61 -Goal "f -`` (A Int B) = (f -`` A) Int (f -`` B)";
   26.62 -by (Fast_tac 1);
   26.63 -qed "vimage_Int";
   26.64 -
   26.65 -Goal "f -`` (Union A) = (UN X:A. f -`` X)";
   26.66 -by (Blast_tac 1);
   26.67 -qed "vimage_Union";
   26.68 -
   26.69 -Goal "f-``(UN x:A. B x) = (UN x:A. f -`` B x)";
   26.70 -by (Blast_tac 1);
   26.71 -qed "vimage_UN";
   26.72 -
   26.73 -Goal "f-``(INT x:A. B x) = (INT x:A. f -`` B x)";
   26.74 -by (Blast_tac 1);
   26.75 -qed "vimage_INT";
   26.76 -
   26.77 -Goal "f -`` Collect P = {y. P (f y)}";
   26.78 -by (Blast_tac 1);
   26.79 -qed "vimage_Collect_eq";
   26.80 -Addsimps [vimage_Collect_eq];
   26.81 -
   26.82 -(*A strange result used in Tools/inductive_package*)
   26.83 -val prems = Goal "(!!x. P (f x) = Q x) ==> f -`` (Collect P) = Collect Q";
   26.84 -by (force_tac (claset(), simpset() addsimps prems) 1);
   26.85 -qed "vimage_Collect";
   26.86 -
   26.87 -Addsimps [vimage_empty, vimage_Un, vimage_Int];
   26.88 -
   26.89 -(*NOT suitable for rewriting because of the recurrence of {a}*)
   26.90 -Goal "f-``(insert a B) = (f-``{a}) Un (f-``B)";
   26.91 -by (Blast_tac 1);
   26.92 -qed "vimage_insert";
   26.93 -
   26.94 -Goal "f-``(A-B) = (f-``A) - (f-``B)";
   26.95 -by (Blast_tac 1);
   26.96 -qed "vimage_Diff";
   26.97 -
   26.98 -Goal "f-``UNIV = UNIV";
   26.99 -by (Blast_tac 1);
  26.100 -qed "vimage_UNIV";
  26.101 -Addsimps [vimage_UNIV];
  26.102 -
  26.103 -(*NOT suitable for rewriting*)
  26.104 -Goal "f-``B = (UN y: B. f-``{y})";
  26.105 -by (Blast_tac 1);
  26.106 -qed "vimage_eq_UN";
  26.107 -
  26.108 -(*monotonicity*)
  26.109 -Goal "A<=B ==> f-``A <= f-``B";
  26.110 -by (Blast_tac 1);
  26.111 -qed "vimage_mono";
    27.1 --- a/src/HOL/Vimage.thy	Thu Oct 12 18:38:23 2000 +0200
    27.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.3 @@ -1,15 +0,0 @@
    27.4 -(*  Title:      HOL/Vimage
    27.5 -    ID:         $Id$
    27.6 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    27.7 -    Copyright   1998  University of Cambridge
    27.8 -
    27.9 -Inverse image of a function
   27.10 -*)
   27.11 -
   27.12 -Vimage = Set +
   27.13 -
   27.14 -constdefs
   27.15 -  vimage :: ['a => 'b, 'b set] => ('a set)   (infixr "-``" 90)
   27.16 -    "f-``B  == {x. f(x) : B}"
   27.17 -
   27.18 -end
    28.1 --- a/src/HOL/WF.ML	Thu Oct 12 18:38:23 2000 +0200
    28.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.3 @@ -1,370 +0,0 @@
    28.4 -(*  Title:      HOL/WF.ML
    28.5 -    ID:         $Id$
    28.6 -    Author:     Tobias Nipkow, with minor changes by Konrad Slind
    28.7 -    Copyright   1992  University of Cambridge/1995 TU Munich
    28.8 -
    28.9 -Wellfoundedness, induction, and  recursion
   28.10 -*)
   28.11 -
   28.12 -Goal "x = y ==> H x z = H y z";
   28.13 -by (Asm_simp_tac 1);
   28.14 -val H_cong2 = (*freeze H!*)
   28.15 -	      read_instantiate [("H","H")] (result());
   28.16 -
   28.17 -val [prem] = Goalw [wf_def]
   28.18 - "(!!P x. (ALL x. (ALL y. (y,x) : r --> P(y)) --> P(x)) ==> P(x)) ==> wf(r)";
   28.19 -by (Clarify_tac 1);
   28.20 -by (rtac prem 1);
   28.21 -by (assume_tac 1);
   28.22 -qed "wfUNIVI";
   28.23 -
   28.24 -(*Restriction to domain A.  If r is well-founded over A then wf(r)*)
   28.25 -val [prem1,prem2] = Goalw [wf_def]
   28.26 - "[| r <= A <*> A;  \
   28.27 -\    !!x P. [| ALL x. (ALL y. (y,x) : r --> P y) --> P x;  x:A |] ==> P x |]  \
   28.28 -\ ==>  wf r";
   28.29 -by (cut_facts_tac [prem1] 1);
   28.30 -by (blast_tac (claset() addIs [prem2]) 1);
   28.31 -qed "wfI";
   28.32 -
   28.33 -val major::prems = Goalw [wf_def]
   28.34 -    "[| wf(r);          \
   28.35 -\       !!x.[| ALL y. (y,x): r --> P(y) |] ==> P(x) \
   28.36 -\    |]  ==>  P(a)";
   28.37 -by (rtac (major RS spec RS mp RS spec) 1);
   28.38 -by (blast_tac (claset() addIs prems) 1);
   28.39 -qed "wf_induct";
   28.40 -
   28.41 -(*Perform induction on i, then prove the wf(r) subgoal using prems. *)
   28.42 -fun wf_ind_tac a prems i = 
   28.43 -    EVERY [res_inst_tac [("a",a)] wf_induct i,
   28.44 -           rename_last_tac a ["1"] (i+1),
   28.45 -           ares_tac prems i];
   28.46 -
   28.47 -Goal "wf(r) ==> ALL x. (a,x):r --> (x,a)~:r";
   28.48 -by (wf_ind_tac "a" [] 1);
   28.49 -by (Blast_tac 1);
   28.50 -qed_spec_mp "wf_not_sym";
   28.51 -
   28.52 -(* [| wf r;  ~Z ==> (a,x) : r;  (x,a) ~: r ==> Z |] ==> Z *)
   28.53 -bind_thm ("wf_asym", cla_make_elim wf_not_sym);
   28.54 -
   28.55 -Goal "wf(r) ==> (a,a) ~: r";
   28.56 -by (blast_tac (claset() addEs [wf_asym]) 1);
   28.57 -qed "wf_not_refl";
   28.58 -
   28.59 -(* [| wf r;  (a,a) ~: r ==> PROP W |] ==> PROP W *)
   28.60 -bind_thm ("wf_irrefl", make_elim wf_not_refl);
   28.61 -
   28.62 -(*transitive closure of a wf relation is wf! *)
   28.63 -Goal "wf(r) ==> wf(r^+)";
   28.64 -by (stac wf_def 1);
   28.65 -by (Clarify_tac 1);
   28.66 -(*must retain the universal formula for later use!*)
   28.67 -by (rtac allE 1 THEN assume_tac 1);
   28.68 -by (etac mp 1);
   28.69 -by (eres_inst_tac [("a","x")] wf_induct 1);
   28.70 -by (blast_tac (claset() addEs [tranclE]) 1);
   28.71 -qed "wf_trancl";
   28.72 -
   28.73 -Goal "wf (r^-1) ==> wf ((r^+)^-1)";
   28.74 -by (stac (trancl_converse RS sym) 1);
   28.75 -by (etac wf_trancl 1);
   28.76 -qed "wf_converse_trancl";
   28.77 -
   28.78 -
   28.79 -(*----------------------------------------------------------------------------
   28.80 - * Minimal-element characterization of well-foundedness
   28.81 - *---------------------------------------------------------------------------*)
   28.82 -
   28.83 -Goalw [wf_def] "wf r ==> x:Q --> (EX z:Q. ALL y. (y,z):r --> y~:Q)";
   28.84 -by (dtac spec 1);
   28.85 -by (etac (mp RS spec) 1);
   28.86 -by (Blast_tac 1);
   28.87 -val lemma1 = result();
   28.88 -
   28.89 -Goalw [wf_def] "(ALL Q x. x:Q --> (EX z:Q. ALL y. (y,z):r --> y~:Q)) ==> wf r";
   28.90 -by (Clarify_tac 1);
   28.91 -by (dres_inst_tac [("x", "{x. ~ P x}")] spec 1);
   28.92 -by (Blast_tac 1);
   28.93 -val lemma2 = result();
   28.94 -
   28.95 -Goal "wf r = (ALL Q x. x:Q --> (EX z:Q. ALL y. (y,z):r --> y~:Q))";
   28.96 -by (blast_tac (claset() addSIs [lemma1, lemma2]) 1);
   28.97 -qed "wf_eq_minimal";
   28.98 -
   28.99 -(*---------------------------------------------------------------------------
  28.100 - * Wellfoundedness of subsets
  28.101 - *---------------------------------------------------------------------------*)
  28.102 -
  28.103 -Goal "[| wf(r);  p<=r |] ==> wf(p)";
  28.104 -by (full_simp_tac (simpset() addsimps [wf_eq_minimal]) 1);
  28.105 -by (Fast_tac 1);
  28.106 -qed "wf_subset";
  28.107 -
  28.108 -(*---------------------------------------------------------------------------
  28.109 - * Wellfoundedness of the empty relation.
  28.110 - *---------------------------------------------------------------------------*)
  28.111 -
  28.112 -Goal "wf({})";
  28.113 -by (simp_tac (simpset() addsimps [wf_def]) 1);
  28.114 -qed "wf_empty";
  28.115 -AddIffs [wf_empty];
  28.116 -
  28.117 -(*---------------------------------------------------------------------------
  28.118 - * Wellfoundedness of `insert'
  28.119 - *---------------------------------------------------------------------------*)
  28.120 -
  28.121 -Goal "wf(insert (y,x) r) = (wf(r) & (x,y) ~: r^*)";
  28.122 -by (rtac iffI 1);
  28.123 - by (blast_tac (claset() addEs [wf_trancl RS wf_irrefl] 
  28.124 -	addIs [rtrancl_into_trancl1,wf_subset,impOfSubs rtrancl_mono]) 1);
  28.125 -by (asm_full_simp_tac (simpset() addsimps [wf_eq_minimal]) 1);
  28.126 -by Safe_tac;
  28.127 -by (EVERY1[rtac allE, assume_tac, etac impE, Blast_tac]);
  28.128 -by (etac bexE 1);
  28.129 -by (rename_tac "a" 1);
  28.130 -by (case_tac "a = x" 1);
  28.131 - by (res_inst_tac [("x","a")]bexI 2);
  28.132 -  by (assume_tac 3);
  28.133 - by (Blast_tac 2);
  28.134 -by (case_tac "y:Q" 1);
  28.135 - by (Blast_tac 2);
  28.136 -by (res_inst_tac [("x","{z. z:Q & (z,y) : r^*}")] allE 1);
  28.137 - by (assume_tac 1);
  28.138 -by (thin_tac "ALL Q. (EX x. x : Q) --> ?P Q" 1);	(*essential for speed*)
  28.139 -(*Blast_tac with new substOccur fails*)
  28.140 -by (best_tac (claset() addIs [rtrancl_into_rtrancl2]) 1);
  28.141 -qed "wf_insert";
  28.142 -AddIffs [wf_insert];
  28.143 -
  28.144 -(*---------------------------------------------------------------------------
  28.145 - * Wellfoundedness of `disjoint union'
  28.146 - *---------------------------------------------------------------------------*)
  28.147 -
  28.148 -(*Intuition behind this proof for the case of binary union:
  28.149 -
  28.150 -  Goal: find an (R u S)-min element of a nonempty subset A.
  28.151 -  by case distinction:
  28.152 -  1. There is a step a -R-> b with a,b : A.
  28.153 -     Pick an R-min element z of the (nonempty) set {a:A | EX b:A. a -R-> b}.
  28.154 -     By definition, there is z':A s.t. z -R-> z'. Because z is R-min in the
  28.155 -     subset, z' must be R-min in A. Because z' has an R-predecessor, it cannot
  28.156 -     have an S-successor and is thus S-min in A as well.
  28.157 -  2. There is no such step.
  28.158 -     Pick an S-min element of A. In this case it must be an R-min
  28.159 -     element of A as well.
  28.160 -
  28.161 -*)
  28.162 -
  28.163 -Goal "[| ALL i:I. wf(r i); \
  28.164 -\        ALL i:I. ALL j:I. r i ~= r j --> Domain(r i) Int Range(r j) = {} & \
  28.165 -\                                         Domain(r j) Int Range(r i) = {} \
  28.166 -\     |] ==> wf(UN i:I. r i)";
  28.167 -by (asm_full_simp_tac (HOL_basic_ss addsimps [wf_eq_minimal]) 1);
  28.168 -by (Clarify_tac 1);
  28.169 -by (rename_tac "A a" 1);
  28.170 -by (case_tac "EX i:I. EX a:A. EX b:A. (b,a) : r i" 1);
  28.171 - by (Asm_full_simp_tac 2);
  28.172 - by (Best_tac 2);  (*much faster than Blast_tac*)
  28.173 -by (Clarify_tac 1);
  28.174 -by (EVERY1[dtac bspec, assume_tac,
  28.175 -	   eres_inst_tac [("x","{a. a:A & (EX b:A. (b,a) : r i)}")] allE]);
  28.176 -by (EVERY1[etac allE, etac impE]);
  28.177 - by (ALLGOALS Blast_tac);
  28.178 -qed "wf_UN";
  28.179 -
  28.180 -Goalw [Union_def]
  28.181 - "[| ALL r:R. wf r; \
  28.182 -\    ALL r:R. ALL s:R. r ~= s --> Domain r Int Range s = {} & \
  28.183 -\                                 Domain s Int Range r = {} \
  28.184 -\ |] ==> wf(Union R)";
  28.185 -by (blast_tac (claset() addIs [wf_UN]) 1);
  28.186 -qed "wf_Union";
  28.187 -
  28.188 -Goal "[| wf r; wf s; Domain r Int Range s = {}; Domain s Int Range r = {} \
  28.189 -\     |] ==> wf(r Un s)";
  28.190 -by (rtac (simplify (simpset()) (read_instantiate[("R","{r,s}")]wf_Union)) 1);
  28.191 -by (Blast_tac 1);
  28.192 -by (Blast_tac 1);
  28.193 -qed "wf_Un";
  28.194 -
  28.195 -(*---------------------------------------------------------------------------
  28.196 - * Wellfoundedness of `image'
  28.197 - *---------------------------------------------------------------------------*)
  28.198 -
  28.199 -Goal "[| wf r; inj f |] ==> wf(prod_fun f f `` r)";
  28.200 -by (asm_full_simp_tac (HOL_basic_ss addsimps [wf_eq_minimal]) 1);
  28.201 -by (Clarify_tac 1);
  28.202 -by (case_tac "EX p. f p : Q" 1);
  28.203 -by (eres_inst_tac [("x","{p. f p : Q}")]allE 1);
  28.204 -by (fast_tac (claset() addDs [injD]) 1);
  28.205 -by (Blast_tac 1);
  28.206 -qed "wf_prod_fun_image";
  28.207 -
  28.208 -(*** acyclic ***)
  28.209 -
  28.210 -Goalw [acyclic_def] "ALL x. (x, x) ~: r^+ ==> acyclic r";
  28.211 -by (assume_tac 1);
  28.212 -qed "acyclicI";
  28.213 -
  28.214 -Goalw [acyclic_def] "wf r ==> acyclic r";
  28.215 -by (blast_tac (claset() addEs [wf_trancl RS wf_irrefl]) 1);
  28.216 -qed "wf_acyclic";
  28.217 -
  28.218 -Goalw [acyclic_def] "acyclic(insert (y,x) r) = (acyclic r & (x,y) ~: r^*)";
  28.219 -by (simp_tac (simpset() addsimps [trancl_insert]) 1);
  28.220 -by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  28.221 -qed "acyclic_insert";
  28.222 -AddIffs [acyclic_insert];
  28.223 -
  28.224 -Goalw [acyclic_def] "acyclic(r^-1) = acyclic r";
  28.225 -by (simp_tac (simpset() addsimps [trancl_converse]) 1);
  28.226 -qed "acyclic_converse";
  28.227 -AddIffs [acyclic_converse];
  28.228 -
  28.229 -Goalw [acyclic_def,antisym_def] "acyclic r ==> antisym(r^*)";
  28.230 -by(blast_tac (claset() addEs [rtranclE]
  28.231 -     addIs [rtrancl_into_trancl1,rtrancl_trancl_trancl]) 1);
  28.232 -qed "acyclic_impl_antisym_rtrancl";
  28.233 -
  28.234 -(* Other direction:
  28.235 -acyclic = no loops
  28.236 -antisym = only self loops
  28.237 -Goalw [acyclic_def,antisym_def] "antisym(r^* ) ==> acyclic(r - Id)";
  28.238 -==> "antisym(r^* ) = acyclic(r - Id)";
  28.239 -*)
  28.240 -
  28.241 -Goalw [acyclic_def] "[| acyclic s; r <= s |] ==> acyclic r";
  28.242 -by (blast_tac (claset() addIs [trancl_mono]) 1);
  28.243 -qed "acyclic_subset";
  28.244 -
  28.245 -(** cut **)
  28.246 -
  28.247 -(*This rewrite rule works upon formulae; thus it requires explicit use of
  28.248 -  H_cong to expose the equality*)
  28.249 -Goalw [cut_def] "(cut f r x = cut g r x) = (ALL y. (y,x):r --> f(y)=g(y))";
  28.250 -by (simp_tac (HOL_ss addsimps [expand_fun_eq]) 1);
  28.251 -qed "cuts_eq";
  28.252 -
  28.253 -Goalw [cut_def] "(x,a):r ==> (cut f r a)(x) = f(x)";
  28.254 -by (asm_simp_tac HOL_ss 1);
  28.255 -qed "cut_apply";
  28.256 -
  28.257 -(*** is_recfun ***)
  28.258 -
  28.259 -Goalw [is_recfun_def,cut_def]
  28.260 -    "[| is_recfun r H a f;  ~(b,a):r |] ==> f(b) = arbitrary";
  28.261 -by (etac ssubst 1);
  28.262 -by (asm_simp_tac HOL_ss 1);
  28.263 -qed "is_recfun_undef";
  28.264 -
  28.265 -(*** NOTE! some simplifications need a different Solver!! ***)
  28.266 -fun indhyp_tac hyps =
  28.267 -    (cut_facts_tac hyps THEN'
  28.268 -       DEPTH_SOLVE_1 o (ares_tac [TrueI] ORELSE'
  28.269 -                        eresolve_tac [transD, mp, allE]));
  28.270 -val wf_super_ss = HOL_ss addSolver (mk_solver "WF" indhyp_tac);
  28.271 -
  28.272 -Goalw [is_recfun_def,cut_def]
  28.273 -    "[| wf(r);  trans(r);  is_recfun r H a f;  is_recfun r H b g |] ==> \
  28.274 -    \ (x,a):r --> (x,b):r --> f(x)=g(x)";
  28.275 -by (etac wf_induct 1);
  28.276 -by (REPEAT (rtac impI 1 ORELSE etac ssubst 1));
  28.277 -by (asm_simp_tac (wf_super_ss addcongs [if_cong]) 1);
  28.278 -qed_spec_mp "is_recfun_equal";
  28.279 -
  28.280 -
  28.281 -val prems as [wfr,transr,recfa,recgb,_] = goalw (the_context ()) [cut_def]
  28.282 -    "[| wf(r);  trans(r); \
  28.283 -\       is_recfun r H a f;  is_recfun r H b g;  (b,a):r |] ==> \
  28.284 -\    cut f r b = g";
  28.285 -val gundef = recgb RS is_recfun_undef
  28.286 -and fisg   = recgb RS (recfa RS (transr RS (wfr RS is_recfun_equal)));
  28.287 -by (cut_facts_tac prems 1);
  28.288 -by (rtac ext 1);
  28.289 -by (asm_simp_tac (wf_super_ss addsimps [gundef,fisg]) 1);
  28.290 -qed "is_recfun_cut";
  28.291 -
  28.292 -(*** Main Existence Lemma -- Basic Properties of the_recfun ***)
  28.293 -
  28.294 -Goalw [the_recfun_def]
  28.295 -    "is_recfun r H a f ==> is_recfun r H a (the_recfun r H a)";
  28.296 -by (eres_inst_tac [("P", "is_recfun r H a")] someI 1);
  28.297 -qed "is_the_recfun";
  28.298 -
  28.299 -Goal "[| wf(r);  trans(r) |] ==> is_recfun r H a (the_recfun r H a)";
  28.300 -by (wf_ind_tac "a" [] 1);
  28.301 -by (res_inst_tac [("f","cut (%y. H (the_recfun r H y) y) r a1")]
  28.302 -                 is_the_recfun 1);
  28.303 -by (rewtac is_recfun_def);
  28.304 -by (stac cuts_eq 1);
  28.305 -by (Clarify_tac 1);
  28.306 -by (rtac H_cong2 1);
  28.307 -by (subgoal_tac
  28.308 -         "the_recfun r H y = cut(%x. H(cut(the_recfun r H y) r x) x) r y" 1);
  28.309 - by (Blast_tac 2);
  28.310 -by (etac ssubst 1);
  28.311 -by (simp_tac (HOL_ss addsimps [cuts_eq]) 1);
  28.312 -by (Clarify_tac 1);
  28.313 -by (stac cut_apply 1);
  28.314 - by (fast_tac (claset() addDs [transD]) 1);
  28.315 -by (fold_tac [is_recfun_def]);
  28.316 -by (asm_simp_tac (wf_super_ss addsimps[is_recfun_cut]) 1);
  28.317 -qed "unfold_the_recfun";
  28.318 -
  28.319 -Goal "[| wf r; trans r; (x,a) : r; (x,b) : r |] \
  28.320 -\     ==> the_recfun r H a x = the_recfun r H b x";
  28.321 -by (best_tac (claset() addIs [is_recfun_equal, unfold_the_recfun]) 1);
  28.322 -qed "the_recfun_equal";
  28.323 -
  28.324 -(** Removal of the premise trans(r) **)
  28.325 -val th = rewrite_rule[is_recfun_def]
  28.326 -                     (trans_trancl RSN (2,(wf_trancl RS unfold_the_recfun)));
  28.327 -
  28.328 -Goalw [wfrec_def]
  28.329 -    "wf(r) ==> wfrec r H a = H (cut (wfrec r H) r a) a";
  28.330 -by (rtac H_cong2 1);
  28.331 -by (simp_tac (HOL_ss addsimps [cuts_eq]) 1);
  28.332 -by (rtac allI 1);
  28.333 -by (rtac impI 1);
  28.334 -by (res_inst_tac [("a1","a")] (th RS ssubst) 1);
  28.335 -by (assume_tac 1);
  28.336 -by (ftac wf_trancl 1);
  28.337 -by (ftac r_into_trancl 1);
  28.338 -by (asm_simp_tac (HOL_ss addsimps [cut_apply]) 1);
  28.339 -by (rtac H_cong2 1);    (*expose the equality of cuts*)
  28.340 -by (simp_tac (HOL_ss addsimps [cuts_eq, cut_apply, r_into_trancl]) 1);
  28.341 -by (blast_tac (claset() addIs [the_recfun_equal, transD, trans_trancl, 
  28.342 -			       r_into_trancl]) 1);
  28.343 -qed "wfrec";
  28.344 -
  28.345 -(*---------------------------------------------------------------------------
  28.346 - * This form avoids giant explosions in proofs.  NOTE USE OF == 
  28.347 - *---------------------------------------------------------------------------*)
  28.348 -Goal "[| f==wfrec r H;  wf(r) |] ==> f(a) = H (cut f r a) a";
  28.349 -by Auto_tac;
  28.350 -by (blast_tac (claset() addIs [wfrec]) 1);   
  28.351 -qed "def_wfrec";
  28.352 -
  28.353 -
  28.354 -(**** TFL variants ****)
  28.355 -
  28.356 -Goal "ALL R. wf R --> \
  28.357 -\      (ALL P. (ALL x. (ALL y. (y,x):R --> P y) --> P x) --> (ALL x. P x))";
  28.358 -by (Clarify_tac 1);
  28.359 -by (res_inst_tac [("r","R"),("P","P"), ("a","x")] wf_induct 1);
  28.360 -by (assume_tac 1);
  28.361 -by (Blast_tac 1);
  28.362 -qed"tfl_wf_induct";
  28.363 -
  28.364 -Goal "ALL f R. (x,a):R --> (cut f R a)(x) = f(x)";
  28.365 -by (Clarify_tac 1);
  28.366 -by (rtac cut_apply 1);
  28.367 -by (assume_tac 1);
  28.368 -qed"tfl_cut_apply";
  28.369 -
  28.370 -Goal "ALL M R f. (f=wfrec R M) --> wf R --> (ALL x. f x = M (cut f R x) x)";
  28.371 -by (Clarify_tac 1);
  28.372 -by (etac wfrec 1);
  28.373 -qed "tfl_wfrec";
    29.1 --- a/src/HOL/WF.thy	Thu Oct 12 18:38:23 2000 +0200
    29.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    29.3 @@ -1,31 +0,0 @@
    29.4 -(*  Title:      HOL/wf.ML
    29.5 -    ID:         $Id$
    29.6 -    Author:     Tobias Nipkow
    29.7 -    Copyright   1992  University of Cambridge
    29.8 -
    29.9 -Well-founded Recursion
   29.10 -*)
   29.11 -
   29.12 -WF = Trancl +
   29.13 -
   29.14 -constdefs
   29.15 -  wf         :: "('a * 'a)set => bool"
   29.16 -  "wf(r) == (!P. (!x. (!y. (y,x):r --> P(y)) --> P(x)) --> (!x. P(x)))"
   29.17 -
   29.18 -  acyclic :: "('a*'a)set => bool"
   29.19 -  "acyclic r == !x. (x,x) ~: r^+"
   29.20 -
   29.21 -  cut        :: "('a => 'b) => ('a * 'a)set => 'a => 'a => 'b"
   29.22 -  "cut f r x == (%y. if (y,x):r then f y else arbitrary)"
   29.23 -
   29.24 -  is_recfun  :: "('a * 'a)set => (('a=>'b) => ('a=>'b)) =>'a=>('a=>'b) => bool"
   29.25 -  "is_recfun r H a f == (f = cut (%x. H (cut f r x) x) r a)"
   29.26 -
   29.27 -  the_recfun :: "('a * 'a)set => (('a=>'b) => ('a=>'b)) => 'a => 'a => 'b"
   29.28 -  "the_recfun r H a  == (@f. is_recfun r H a f)"
   29.29 -
   29.30 -  wfrec      :: "('a * 'a)set => (('a=>'b) => ('a=>'b)) => 'a => 'b"
   29.31 -  "wfrec r H == (%x. H (cut (the_recfun (trancl r) (%f v. H (cut f r v) v) x)
   29.32 -                            r x)  x)"
   29.33 -
   29.34 -end
    30.1 --- a/src/HOL/WF_Rel.ML	Thu Oct 12 18:38:23 2000 +0200
    30.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    30.3 @@ -1,226 +0,0 @@
    30.4 -(*  Title: 	HOL/WF_Rel
    30.5 -    ID:         $Id$
    30.6 -    Author: 	Konrad Slind
    30.7 -    Copyright   1996  TU Munich
    30.8 -
    30.9 -Derived WF relations: inverse image, lexicographic product, measure, ...
   30.10 -*)
   30.11 -
   30.12 -
   30.13 -(*----------------------------------------------------------------------------
   30.14 - * "Less than" on the natural numbers
   30.15 - *---------------------------------------------------------------------------*)
   30.16 -
   30.17 -Goalw [less_than_def] "wf less_than"; 
   30.18 -by (rtac (wf_pred_nat RS wf_trancl) 1);
   30.19 -qed "wf_less_than";
   30.20 -AddIffs [wf_less_than];
   30.21 -
   30.22 -Goalw [less_than_def] "trans less_than"; 
   30.23 -by (rtac trans_trancl 1);
   30.24 -qed "trans_less_than";
   30.25 -AddIffs [trans_less_than];
   30.26 -
   30.27 -Goalw [less_than_def, less_def] "((x,y): less_than) = (x<y)"; 
   30.28 -by (Simp_tac 1);
   30.29 -qed "less_than_iff";
   30.30 -AddIffs [less_than_iff];
   30.31 -
   30.32 -Goal "(!!n. (ALL m. Suc m <= n --> P m) ==> P n) ==> P n";
   30.33 -by (rtac (wf_less_than RS wf_induct) 1);
   30.34 -by (resolve_tac (premises()) 1);
   30.35 -by Auto_tac;
   30.36 -qed_spec_mp "full_nat_induct";
   30.37 -
   30.38 -(*----------------------------------------------------------------------------
   30.39 - * The inverse image into a wellfounded relation is wellfounded.
   30.40 - *---------------------------------------------------------------------------*)
   30.41 -
   30.42 -Goal "wf(r) ==> wf(inv_image r (f::'a=>'b))"; 
   30.43 -by (full_simp_tac (simpset() addsimps [inv_image_def, wf_eq_minimal]) 1);
   30.44 -by (Clarify_tac 1);
   30.45 -by (subgoal_tac "EX (w::'b). w : {w. EX (x::'a). x: Q & (f x = w)}" 1);
   30.46 -by (blast_tac (claset() delrules [allE]) 2);
   30.47 -by (etac allE 1);
   30.48 -by (mp_tac 1);
   30.49 -by (Blast_tac 1);
   30.50 -qed "wf_inv_image";
   30.51 -AddSIs [wf_inv_image];
   30.52 -
   30.53 -Goalw [trans_def,inv_image_def]
   30.54 -    "!!r. trans r ==> trans (inv_image r f)";
   30.55 -by (Simp_tac 1);
   30.56 -by (Blast_tac 1);
   30.57 -qed "trans_inv_image";
   30.58 -
   30.59 -
   30.60 -(*----------------------------------------------------------------------------
   30.61 - * All measures are wellfounded.
   30.62 - *---------------------------------------------------------------------------*)
   30.63 -
   30.64 -Goalw [measure_def] "wf (measure f)";
   30.65 -by (rtac (wf_less_than RS wf_inv_image) 1);
   30.66 -qed "wf_measure";
   30.67 -AddIffs [wf_measure];
   30.68 -
   30.69 -val measure_induct = standard
   30.70 -    (asm_full_simplify (simpset() addsimps [measure_def,inv_image_def])
   30.71 -      (wf_measure RS wf_induct));
   30.72 -bind_thm ("measure_induct", measure_induct);
   30.73 -
   30.74 -(*----------------------------------------------------------------------------
   30.75 - * Wellfoundedness of lexicographic combinations
   30.76 - *---------------------------------------------------------------------------*)
   30.77 -
   30.78 -val [wfa,wfb] = goalw (the_context ()) [wf_def,lex_prod_def]
   30.79 - "[| wf(ra); wf(rb) |] ==> wf(ra <*lex*> rb)";
   30.80 -by (EVERY1 [rtac allI,rtac impI]);
   30.81 -by (simp_tac (HOL_basic_ss addsimps [split_paired_All]) 1);
   30.82 -by (rtac (wfa RS spec RS mp) 1);
   30.83 -by (EVERY1 [rtac allI,rtac impI]);
   30.84 -by (rtac (wfb RS spec RS mp) 1);
   30.85 -by (Blast_tac 1);
   30.86 -qed "wf_lex_prod";
   30.87 -AddSIs [wf_lex_prod];
   30.88 -
   30.89 -(*---------------------------------------------------------------------------
   30.90 - * Transitivity of WF combinators.
   30.91 - *---------------------------------------------------------------------------*)
   30.92 -Goalw [trans_def, lex_prod_def]
   30.93 -    "!!R1 R2. [| trans R1; trans R2 |] ==> trans (R1 <*lex*> R2)";
   30.94 -by (Simp_tac 1);
   30.95 -by (Blast_tac 1);
   30.96 -qed "trans_lex_prod";
   30.97 -AddSIs [trans_lex_prod];
   30.98 -
   30.99 -
  30.100 -(*---------------------------------------------------------------------------
  30.101 - * Wellfoundedness of proper subset on finite sets.
  30.102 - *---------------------------------------------------------------------------*)
  30.103 -Goalw [finite_psubset_def] "wf(finite_psubset)";
  30.104 -by (rtac (wf_measure RS wf_subset) 1);
  30.105 -by (simp_tac (simpset() addsimps [measure_def, inv_image_def, less_than_def,
  30.106 -				 symmetric less_def])1);
  30.107 -by (fast_tac (claset() addSEs [psubset_card_mono]) 1);
  30.108 -qed "wf_finite_psubset";
  30.109 -
  30.110 -Goalw [finite_psubset_def, trans_def] "trans finite_psubset";
  30.111 -by (simp_tac (simpset() addsimps [psubset_def]) 1);
  30.112 -by (Blast_tac 1);
  30.113 -qed "trans_finite_psubset";
  30.114 -
  30.115 -(*---------------------------------------------------------------------------
  30.116 - * Wellfoundedness of finite acyclic relations
  30.117 - * Cannot go into WF because it needs Finite.
  30.118 - *---------------------------------------------------------------------------*)
  30.119 -
  30.120 -Goal "finite r ==> acyclic r --> wf r";
  30.121 -by (etac finite_induct 1);
  30.122 - by (Blast_tac 1);
  30.123 -by (split_all_tac 1);
  30.124 -by (Asm_full_simp_tac 1);
  30.125 -qed_spec_mp "finite_acyclic_wf";
  30.126 -
  30.127 -Goal "[|finite r; acyclic r|] ==> wf (r^-1)";
  30.128 -by (etac (finite_converse RS iffD2 RS finite_acyclic_wf) 1);
  30.129 -by (etac (acyclic_converse RS iffD2) 1);
  30.130 -qed "finite_acyclic_wf_converse";
  30.131 -
  30.132 -Goal "finite r ==> wf r = acyclic r";
  30.133 -by (blast_tac (claset() addIs [finite_acyclic_wf,wf_acyclic]) 1);
  30.134 -qed "wf_iff_acyclic_if_finite";
  30.135 -
  30.136 -
  30.137 -(*---------------------------------------------------------------------------
  30.138 - * A relation is wellfounded iff it has no infinite descending chain
  30.139 - * Cannot go into WF because it needs type nat.
  30.140 - *---------------------------------------------------------------------------*)
  30.141 -
  30.142 -Goalw [wf_eq_minimal RS eq_reflection]
  30.143 -  "wf r = (~(EX f. ALL i. (f(Suc i),f i) : r))";
  30.144 -by (rtac iffI 1);
  30.145 - by (rtac notI 1);
  30.146 - by (etac exE 1);
  30.147 - by (eres_inst_tac [("x","{w. EX i. w=f i}")] allE 1);
  30.148 - by (Blast_tac 1);
  30.149 -by (etac swap 1);
  30.150 -by (Asm_full_simp_tac 1);
  30.151 -by (Clarify_tac 1);
  30.152 -by (subgoal_tac "ALL n. nat_rec x (%i y. @z. z:Q & (z,y):r) n : Q" 1);
  30.153 - by (res_inst_tac[("x","nat_rec x (%i y. @z. z:Q & (z,y):r)")]exI 1);
  30.154 - by (rtac allI 1);
  30.155 - by (Simp_tac 1);
  30.156 - by (rtac someI2_ex 1);
  30.157 -  by (Blast_tac 1);
  30.158 - by (Blast_tac 1);
  30.159 -by (rtac allI 1);
  30.160 -by (induct_tac "n" 1);
  30.161 - by (Asm_simp_tac 1);
  30.162 -by (Simp_tac 1);
  30.163 -by (rtac someI2_ex 1);
  30.164 - by (Blast_tac 1);
  30.165 -by (Blast_tac 1);
  30.166 -qed "wf_iff_no_infinite_down_chain";
  30.167 -
  30.168 -(*----------------------------------------------------------------------------
  30.169 - * Weakly decreasing sequences (w.r.t. some well-founded order) stabilize.
  30.170 - *---------------------------------------------------------------------------*)
  30.171 -
  30.172 -Goal "[| ALL i. (f (Suc i), f i) : r^* |] ==> (f (i+k), f i) : r^*";
  30.173 -by (induct_tac "k" 1);
  30.174 - by (ALLGOALS Simp_tac);
  30.175 -by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  30.176 -val lemma = result();
  30.177 -
  30.178 -Goal "[| ALL i. (f (Suc i), f i) : r^*; wf (r^+) |] \
  30.179 -\     ==> ALL m. f m = x --> (EX i. ALL k. f (m+i+k) = f (m+i))";
  30.180 -by (etac wf_induct 1);
  30.181 -by (Clarify_tac 1);
  30.182 -by (case_tac "EX j. (f (m+j), f m) : r^+" 1);
  30.183 - by (Clarify_tac 1);
  30.184 - by (subgoal_tac "EX i. ALL k. f ((m+j)+i+k) = f ((m+j)+i)" 1);
  30.185 -  by (Clarify_tac 1);
  30.186 -  by (res_inst_tac [("x","j+i")] exI 1);
  30.187 -  by (asm_full_simp_tac (simpset() addsimps add_ac) 1);
  30.188 - by (Blast_tac 1);
  30.189 -by (res_inst_tac [("x","0")] exI 1);
  30.190 -by (Clarsimp_tac 1);
  30.191 -by (dres_inst_tac [("i","m"), ("k","k")] lemma 1);
  30.192 -by (blast_tac (claset() addEs [rtranclE] addDs [rtrancl_into_trancl1]) 1);
  30.193 -val lemma = result();
  30.194 -
  30.195 -Goal "[| ALL i. (f (Suc i), f i) : r^*; wf (r^+) |] \
  30.196 -\     ==> EX i. ALL k. f (i+k) = f i";
  30.197 -by (dres_inst_tac [("x","0")] (lemma RS spec) 1);
  30.198 -by Auto_tac;
  30.199 -qed "wf_weak_decr_stable";
  30.200 -
  30.201 -(* special case: <= *)
  30.202 -
  30.203 -Goal "(m, n) : pred_nat^* = (m <= n)";
  30.204 -by (simp_tac (simpset() addsimps [less_eq, reflcl_trancl RS sym] 
  30.205 -                        delsimps [reflcl_trancl]) 1);
  30.206 -by (arith_tac 1);
  30.207 -qed "le_eq";
  30.208 -
  30.209 -Goal "ALL i. f (Suc i) <= ((f i)::nat) ==> EX i. ALL k. f (i+k) = f i";
  30.210 -by (res_inst_tac [("r","pred_nat")] wf_weak_decr_stable 1);
  30.211 -by (asm_simp_tac (simpset() addsimps [le_eq]) 1);
  30.212 -by (REPEAT (resolve_tac [wf_trancl,wf_pred_nat] 1));
  30.213 -qed "weak_decr_stable";
  30.214 -
  30.215 -(*----------------------------------------------------------------------------
  30.216 - * Wellfoundedness of same_fst
  30.217 - *---------------------------------------------------------------------------*)
  30.218 -
  30.219 -val prems = goalw thy [same_fst_def]
  30.220 -  "(!!x. P x ==> wf(R x)) ==> wf(same_fst P R)";
  30.221 -by(full_simp_tac (simpset() delcongs [imp_cong] addsimps [wf_def]) 1);
  30.222 -by(strip_tac 1);
  30.223 -by(rename_tac "a b" 1);
  30.224 -by(case_tac "wf(R a)" 1);
  30.225 - by (eres_inst_tac [("a","b")] wf_induct 1);
  30.226 - by (EVERY1[etac allE, etac allE, etac mp, rtac allI, rtac allI]);
  30.227 - by(Blast_tac 1);
  30.228 -by(blast_tac (claset() addIs prems) 1);
  30.229 -qed "wf_same_fstI";
    31.1 --- a/src/HOL/WF_Rel.thy	Thu Oct 12 18:38:23 2000 +0200
    31.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.3 @@ -1,44 +0,0 @@
    31.4 -(*  Title:      HOL/WF_Rel
    31.5 -    ID:         $Id$
    31.6 -    Author:     Konrad Slind
    31.7 -    Copyright   1995 TU Munich
    31.8 -
    31.9 -Derived WF relations: inverse image, lexicographic product, measure, ...
   31.10 -
   31.11 -The simple relational product, in which (x',y')<(x,y) iff x'<x and y'<y, is a
   31.12 -subset of the lexicographic product, and therefore does not need to be defined
   31.13 -separately.
   31.14 -*)
   31.15 -
   31.16 -WF_Rel = Finite +
   31.17 -
   31.18 -(* actually belongs to theory Finite *)
   31.19 -instance unit :: finite                  (finite_unit)
   31.20 -instance "*" :: (finite,finite) finite   (finite_Prod)
   31.21 -
   31.22 -
   31.23 -constdefs
   31.24 - less_than :: "(nat*nat)set"
   31.25 -"less_than == trancl pred_nat"
   31.26 -
   31.27 - inv_image :: "('b * 'b)set => ('a => 'b) => ('a * 'a)set"
   31.28 -"inv_image r f == {(x,y). (f(x), f(y)) : r}"
   31.29 -
   31.30 - measure   :: "('a => nat) => ('a * 'a)set"
   31.31 -"measure == inv_image less_than"
   31.32 -
   31.33 - lex_prod  :: "[('a*'a)set, ('b*'b)set] => (('a*'b)*('a*'b))set"
   31.34 -               (infixr "<*lex*>" 80)
   31.35 -"ra <*lex*> rb == {((a,b),(a',b')). (a,a') : ra | a=a' & (b,b') : rb}"
   31.36 -
   31.37 - (* finite proper subset*)
   31.38 - finite_psubset  :: "('a set * 'a set) set"
   31.39 -"finite_psubset == {(A,B). A < B & finite B}"
   31.40 -
   31.41 -(* For rec_defs where the first n parameters stay unchanged in the recursive
   31.42 -   call. See While for an application.
   31.43 -*)
   31.44 - same_fst :: "('a => bool) => ('a => ('b * 'b)set) => (('a*'b)*('a*'b))set"
   31.45 -"same_fst P R == {((x',y'),(x,y)) . x'=x & P x & (y',y) : R x}"
   31.46 -
   31.47 -end
    32.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    32.2 +++ b/src/HOL/Wellfounded_Recursion.ML	Thu Oct 12 18:44:35 2000 +0200
    32.3 @@ -0,0 +1,370 @@
    32.4 +(*  Title:      HOL/Wellfounded_Recursion.ML
    32.5 +    ID:         $Id$
    32.6 +    Author:     Tobias Nipkow, with minor changes by Konrad Slind
    32.7 +    Copyright   1992  University of Cambridge/1995 TU Munich
    32.8 +
    32.9 +Wellfoundedness, induction, and  recursion
   32.10 +*)
   32.11 +
   32.12 +Goal "x = y ==> H x z = H y z";
   32.13 +by (Asm_simp_tac 1);
   32.14 +val H_cong2 = (*freeze H!*)
   32.15 +	      read_instantiate [("H","H")] (result());
   32.16 +
   32.17 +val [prem] = Goalw [wf_def]
   32.18 + "(!!P x. (ALL x. (ALL y. (y,x) : r --> P(y)) --> P(x)) ==> P(x)) ==> wf(r)";
   32.19 +by (Clarify_tac 1);
   32.20 +by (rtac prem 1);
   32.21 +by (assume_tac 1);
   32.22 +qed "wfUNIVI";
   32.23 +
   32.24 +(*Restriction to domain A.  If r is well-founded over A then wf(r)*)
   32.25 +val [prem1,prem2] = Goalw [wf_def]
   32.26 + "[| r <= A <*> A;  \
   32.27 +\    !!x P. [| ALL x. (ALL y. (y,x) : r --> P y) --> P x;  x:A |] ==> P x |]  \
   32.28 +\ ==>  wf r";
   32.29 +by (cut_facts_tac [prem1] 1);
   32.30 +by (blast_tac (claset() addIs [prem2]) 1);
   32.31 +qed "wfI";
   32.32 +
   32.33 +val major::prems = Goalw [wf_def]
   32.34 +    "[| wf(r);          \
   32.35 +\       !!x.[| ALL y. (y,x): r --> P(y) |] ==> P(x) \
   32.36 +\    |]  ==>  P(a)";
   32.37 +by (rtac (major RS spec RS mp RS spec) 1);
   32.38 +by (blast_tac (claset() addIs prems) 1);
   32.39 +qed "wf_induct";
   32.40 +
   32.41 +(*Perform induction on i, then prove the wf(r) subgoal using prems. *)
   32.42 +fun wf_ind_tac a prems i = 
   32.43 +    EVERY [res_inst_tac [("a",a)] wf_induct i,
   32.44 +           rename_last_tac a ["1"] (i+1),
   32.45 +           ares_tac prems i];
   32.46 +
   32.47 +Goal "wf(r) ==> ALL x. (a,x):r --> (x,a)~:r";
   32.48 +by (wf_ind_tac "a" [] 1);
   32.49 +by (Blast_tac 1);
   32.50 +qed_spec_mp "wf_not_sym";
   32.51 +
   32.52 +(* [| wf r;  ~Z ==> (a,x) : r;  (x,a) ~: r ==> Z |] ==> Z *)
   32.53 +bind_thm ("wf_asym", cla_make_elim wf_not_sym);
   32.54 +
   32.55 +Goal "wf(r) ==> (a,a) ~: r";
   32.56 +by (blast_tac (claset() addEs [wf_asym]) 1);
   32.57 +qed "wf_not_refl";
   32.58 +
   32.59 +(* [| wf r;  (a,a) ~: r ==> PROP W |] ==> PROP W *)
   32.60 +bind_thm ("wf_irrefl", make_elim wf_not_refl);
   32.61 +
   32.62 +(*transitive closure of a wf relation is wf! *)
   32.63 +Goal "wf(r) ==> wf(r^+)";
   32.64 +by (stac wf_def 1);
   32.65 +by (Clarify_tac 1);
   32.66 +(*must retain the universal formula for later use!*)
   32.67 +by (rtac allE 1 THEN assume_tac 1);
   32.68 +by (etac mp 1);
   32.69 +by (eres_inst_tac [("a","x")] wf_induct 1);
   32.70 +by (blast_tac (claset() addEs [tranclE]) 1);
   32.71 +qed "wf_trancl";
   32.72 +
   32.73 +Goal "wf (r^-1) ==> wf ((r^+)^-1)";
   32.74 +by (stac (trancl_converse RS sym) 1);
   32.75 +by (etac wf_trancl 1);
   32.76 +qed "wf_converse_trancl";
   32.77 +
   32.78 +
   32.79 +(*----------------------------------------------------------------------------
   32.80 + * Minimal-element characterization of well-foundedness
   32.81 + *---------------------------------------------------------------------------*)
   32.82 +
   32.83 +Goalw [wf_def] "wf r ==> x:Q --> (EX z:Q. ALL y. (y,z):r --> y~:Q)";
   32.84 +by (dtac spec 1);
   32.85 +by (etac (mp RS spec) 1);
   32.86 +by (Blast_tac 1);
   32.87 +val lemma1 = result();
   32.88 +
   32.89 +Goalw [wf_def] "(ALL Q x. x:Q --> (EX z:Q. ALL y. (y,z):r --> y~:Q)) ==> wf r";
   32.90 +by (Clarify_tac 1);
   32.91 +by (dres_inst_tac [("x", "{x. ~ P x}")] spec 1);
   32.92 +by (Blast_tac 1);
   32.93 +val lemma2 = result();
   32.94 +
   32.95 +Goal "wf r = (ALL Q x. x:Q --> (EX z:Q. ALL y. (y,z):r --> y~:Q))";
   32.96 +by (blast_tac (claset() addSIs [lemma1, lemma2]) 1);
   32.97 +qed "wf_eq_minimal";
   32.98 +
   32.99 +(*---------------------------------------------------------------------------
  32.100 + * Wellfoundedness of subsets
  32.101 + *---------------------------------------------------------------------------*)
  32.102 +
  32.103 +Goal "[| wf(r);  p<=r |] ==> wf(p)";
  32.104 +by (full_simp_tac (simpset() addsimps [wf_eq_minimal]) 1);
  32.105 +by (Fast_tac 1);
  32.106 +qed "wf_subset";
  32.107 +
  32.108 +(*---------------------------------------------------------------------------
  32.109 + * Wellfoundedness of the empty relation.
  32.110 + *---------------------------------------------------------------------------*)
  32.111 +
  32.112 +Goal "wf({})";
  32.113 +by (simp_tac (simpset() addsimps [wf_def]) 1);
  32.114 +qed "wf_empty";
  32.115 +AddIffs [wf_empty];
  32.116 +
  32.117 +(*---------------------------------------------------------------------------
  32.118 + * Wellfoundedness of `insert'
  32.119 + *---------------------------------------------------------------------------*)
  32.120 +
  32.121 +Goal "wf(insert (y,x) r) = (wf(r) & (x,y) ~: r^*)";
  32.122 +by (rtac iffI 1);
  32.123 + by (blast_tac (claset() addEs [wf_trancl RS wf_irrefl] 
  32.124 +	addIs [rtrancl_into_trancl1,wf_subset,impOfSubs rtrancl_mono]) 1);
  32.125 +by (asm_full_simp_tac (simpset() addsimps [wf_eq_minimal]) 1);
  32.126 +by Safe_tac;
  32.127 +by (EVERY1[rtac allE, assume_tac, etac impE, Blast_tac]);
  32.128 +by (etac bexE 1);
  32.129 +by (rename_tac "a" 1);
  32.130 +by (case_tac "a = x" 1);
  32.131 + by (res_inst_tac [("x","a")]bexI 2);
  32.132 +  by (assume_tac 3);
  32.133 + by (Blast_tac 2);
  32.134 +by (case_tac "y:Q" 1);
  32.135 + by (Blast_tac 2);
  32.136 +by (res_inst_tac [("x","{z. z:Q & (z,y) : r^*}")] allE 1);
  32.137 + by (assume_tac 1);
  32.138 +by (thin_tac "ALL Q. (EX x. x : Q) --> ?P Q" 1);	(*essential for speed*)
  32.139 +(*Blast_tac with new substOccur fails*)
  32.140 +by (best_tac (claset() addIs [rtrancl_into_rtrancl2]) 1);
  32.141 +qed "wf_insert";
  32.142 +AddIffs [wf_insert];
  32.143 +
  32.144 +(*---------------------------------------------------------------------------
  32.145 + * Wellfoundedness of `disjoint union'
  32.146 + *---------------------------------------------------------------------------*)
  32.147 +
  32.148 +(*Intuition behind this proof for the case of binary union:
  32.149 +
  32.150 +  Goal: find an (R u S)-min element of a nonempty subset A.
  32.151 +  by case distinction:
  32.152 +  1. There is a step a -R-> b with a,b : A.
  32.153 +     Pick an R-min element z of the (nonempty) set {a:A | EX b:A. a -R-> b}.
  32.154 +     By definition, there is z':A s.t. z -R-> z'. Because z is R-min in the
  32.155 +     subset, z' must be R-min in A. Because z' has an R-predecessor, it cannot
  32.156 +     have an S-successor and is thus S-min in A as well.
  32.157 +  2. There is no such step.
  32.158 +     Pick an S-min element of A. In this case it must be an R-min
  32.159 +     element of A as well.
  32.160 +
  32.161 +*)
  32.162 +
  32.163 +Goal "[| ALL i:I. wf(r i); \
  32.164 +\        ALL i:I. ALL j:I. r i ~= r j --> Domain(r i) Int Range(r j) = {} & \
  32.165 +\                                         Domain(r j) Int Range(r i) = {} \
  32.166 +\     |] ==> wf(UN i:I. r i)";
  32.167 +by (asm_full_simp_tac (HOL_basic_ss addsimps [wf_eq_minimal]) 1);
  32.168 +by (Clarify_tac 1);
  32.169 +by (rename_tac "A a" 1);
  32.170 +by (case_tac "EX i:I. EX a:A. EX b:A. (b,a) : r i" 1);
  32.171 + by (Asm_full_simp_tac 2);
  32.172 + by (Best_tac 2);  (*much faster than Blast_tac*)
  32.173 +by (Clarify_tac 1);
  32.174 +by (EVERY1[dtac bspec, assume_tac,
  32.175 +	   eres_inst_tac [("x","{a. a:A & (EX b:A. (b,a) : r i)}")] allE]);
  32.176 +by (EVERY1[etac allE, etac impE]);
  32.177 + by (ALLGOALS Blast_tac);
  32.178 +qed "wf_UN";
  32.179 +
  32.180 +Goalw [Union_def]
  32.181 + "[| ALL r:R. wf r; \
  32.182 +\    ALL r:R. ALL s:R. r ~= s --> Domain r Int Range s = {} & \
  32.183 +\                                 Domain s Int Range r = {} \
  32.184 +\ |] ==> wf(Union R)";
  32.185 +by (blast_tac (claset() addIs [wf_UN]) 1);
  32.186 +qed "wf_Union";
  32.187 +
  32.188 +Goal "[| wf r; wf s; Domain r Int Range s = {}; Domain s Int Range r = {} \
  32.189 +\     |] ==> wf(r Un s)";
  32.190 +by (rtac (simplify (simpset()) (read_instantiate[("R","{r,s}")]wf_Union)) 1);
  32.191 +by (Blast_tac 1);
  32.192 +by (Blast_tac 1);
  32.193 +qed "wf_Un";
  32.194 +
  32.195 +(*---------------------------------------------------------------------------
  32.196 + * Wellfoundedness of `image'
  32.197 + *---------------------------------------------------------------------------*)
  32.198 +
  32.199 +Goal "[| wf r; inj f |] ==> wf(prod_fun f f `` r)";
  32.200 +by (asm_full_simp_tac (HOL_basic_ss addsimps [wf_eq_minimal]) 1);
  32.201 +by (Clarify_tac 1);
  32.202 +by (case_tac "EX p. f p : Q" 1);
  32.203 +by (eres_inst_tac [("x","{p. f p : Q}")]allE 1);
  32.204 +by (fast_tac (claset() addDs [injD]) 1);
  32.205 +by (Blast_tac 1);
  32.206 +qed "wf_prod_fun_image";
  32.207 +
  32.208 +(*** acyclic ***)
  32.209 +
  32.210 +Goalw [acyclic_def] "ALL x. (x, x) ~: r^+ ==> acyclic r";
  32.211 +by (assume_tac 1);
  32.212 +qed "acyclicI";
  32.213 +
  32.214 +Goalw [acyclic_def] "wf r ==> acyclic r";
  32.215 +by (blast_tac (claset() addEs [wf_trancl RS wf_irrefl]) 1);
  32.216 +qed "wf_acyclic";
  32.217 +
  32.218 +Goalw [acyclic_def] "acyclic(insert (y,x) r) = (acyclic r & (x,y) ~: r^*)";
  32.219 +by (simp_tac (simpset() addsimps [trancl_insert]) 1);
  32.220 +by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  32.221 +qed "acyclic_insert";
  32.222 +AddIffs [acyclic_insert];
  32.223 +
  32.224 +Goalw [acyclic_def] "acyclic(r^-1) = acyclic r";
  32.225 +by (simp_tac (simpset() addsimps [trancl_converse]) 1);
  32.226 +qed "acyclic_converse";
  32.227 +AddIffs [acyclic_converse];
  32.228 +
  32.229 +Goalw [acyclic_def,antisym_def] "acyclic r ==> antisym(r^*)";
  32.230 +by(blast_tac (claset() addEs [rtranclE]
  32.231 +     addIs [rtrancl_into_trancl1,rtrancl_trancl_trancl]) 1);
  32.232 +qed "acyclic_impl_antisym_rtrancl";
  32.233 +
  32.234 +(* Other direction:
  32.235 +acyclic = no loops
  32.236 +antisym = only self loops
  32.237 +Goalw [acyclic_def,antisym_def] "antisym(r^* ) ==> acyclic(r - Id)";
  32.238 +==> "antisym(r^* ) = acyclic(r - Id)";
  32.239 +*)
  32.240 +
  32.241 +Goalw [acyclic_def] "[| acyclic s; r <= s |] ==> acyclic r";
  32.242 +by (blast_tac (claset() addIs [trancl_mono]) 1);
  32.243 +qed "acyclic_subset";
  32.244 +
  32.245 +(** cut **)
  32.246 +
  32.247 +(*This rewrite rule works upon formulae; thus it requires explicit use of
  32.248 +  H_cong to expose the equality*)
  32.249 +Goalw [cut_def] "(cut f r x = cut g r x) = (ALL y. (y,x):r --> f(y)=g(y))";
  32.250 +by (simp_tac (HOL_ss addsimps [expand_fun_eq]) 1);
  32.251 +qed "cuts_eq";
  32.252 +
  32.253 +Goalw [cut_def] "(x,a):r ==> (cut f r a)(x) = f(x)";
  32.254 +by (asm_simp_tac HOL_ss 1);
  32.255 +qed "cut_apply";
  32.256 +
  32.257 +(*** is_recfun ***)
  32.258 +
  32.259 +Goalw [is_recfun_def,cut_def]
  32.260 +    "[| is_recfun r H a f;  ~(b,a):r |] ==> f(b) = arbitrary";
  32.261 +by (etac ssubst 1);
  32.262 +by (asm_simp_tac HOL_ss 1);
  32.263 +qed "is_recfun_undef";
  32.264 +
  32.265 +(*** NOTE! some simplifications need a different Solver!! ***)
  32.266 +fun indhyp_tac hyps =
  32.267 +    (cut_facts_tac hyps THEN'
  32.268 +       DEPTH_SOLVE_1 o (ares_tac [TrueI] ORELSE'
  32.269 +                        eresolve_tac [transD, mp, allE]));
  32.270 +val wf_super_ss = HOL_ss addSolver (mk_solver "WF" indhyp_tac);
  32.271 +
  32.272 +Goalw [is_recfun_def,cut_def]
  32.273 +    "[| wf(r);  trans(r);  is_recfun r H a f;  is_recfun r H b g |] ==> \
  32.274 +    \ (x,a):r --> (x,b):r --> f(x)=g(x)";
  32.275 +by (etac wf_induct 1);
  32.276 +by (REPEAT (rtac impI 1 ORELSE etac ssubst 1));
  32.277 +by (asm_simp_tac (wf_super_ss addcongs [if_cong]) 1);
  32.278 +qed_spec_mp "is_recfun_equal";
  32.279 +
  32.280 +
  32.281 +val prems as [wfr,transr,recfa,recgb,_] = goalw (the_context ()) [cut_def]
  32.282 +    "[| wf(r);  trans(r); \
  32.283 +\       is_recfun r H a f;  is_recfun r H b g;  (b,a):r |] ==> \
  32.284 +\    cut f r b = g";
  32.285 +val gundef = recgb RS is_recfun_undef
  32.286 +and fisg   = recgb RS (recfa RS (transr RS (wfr RS is_recfun_equal)));
  32.287 +by (cut_facts_tac prems 1);
  32.288 +by (rtac ext 1);
  32.289 +by (asm_simp_tac (wf_super_ss addsimps [gundef,fisg]) 1);
  32.290 +qed "is_recfun_cut";
  32.291 +
  32.292 +(*** Main Existence Lemma -- Basic Properties of the_recfun ***)
  32.293 +
  32.294 +Goalw [the_recfun_def]
  32.295 +    "is_recfun r H a f ==> is_recfun r H a (the_recfun r H a)";
  32.296 +by (eres_inst_tac [("P", "is_recfun r H a")] someI 1);
  32.297 +qed "is_the_recfun";
  32.298 +
  32.299 +Goal "[| wf(r);  trans(r) |] ==> is_recfun r H a (the_recfun r H a)";
  32.300 +by (wf_ind_tac "a" [] 1);
  32.301 +by (res_inst_tac [("f","cut (%y. H (the_recfun r H y) y) r a1")]
  32.302 +                 is_the_recfun 1);
  32.303 +by (rewtac is_recfun_def);
  32.304 +by (stac cuts_eq 1);
  32.305 +by (Clarify_tac 1);
  32.306 +by (rtac H_cong2 1);
  32.307 +by (subgoal_tac
  32.308 +         "the_recfun r H y = cut(%x. H(cut(the_recfun r H y) r x) x) r y" 1);
  32.309 + by (Blast_tac 2);
  32.310 +by (etac ssubst 1);
  32.311 +by (simp_tac (HOL_ss addsimps [cuts_eq]) 1);
  32.312 +by (Clarify_tac 1);
  32.313 +by (stac cut_apply 1);
  32.314 + by (fast_tac (claset() addDs [transD]) 1);
  32.315 +by (fold_tac [is_recfun_def]);
  32.316 +by (asm_simp_tac (wf_super_ss addsimps[is_recfun_cut]) 1);
  32.317 +qed "unfold_the_recfun";
  32.318 +
  32.319 +Goal "[| wf r; trans r; (x,a) : r; (x,b) : r |] \
  32.320 +\     ==> the_recfun r H a x = the_recfun r H b x";
  32.321 +by (best_tac (claset() addIs [is_recfun_equal, unfold_the_recfun]) 1);
  32.322 +qed "the_recfun_equal";
  32.323 +
  32.324 +(** Removal of the premise trans(r) **)
  32.325 +val th = rewrite_rule[is_recfun_def]
  32.326 +                     (trans_trancl RSN (2,(wf_trancl RS unfold_the_recfun)));
  32.327 +
  32.328 +Goalw [wfrec_def]
  32.329 +    "wf(r) ==> wfrec r H a = H (cut (wfrec r H) r a) a";
  32.330 +by (rtac H_cong2 1);
  32.331 +by (simp_tac (HOL_ss addsimps [cuts_eq]) 1);
  32.332 +by (rtac allI 1);
  32.333 +by (rtac impI 1);
  32.334 +by (res_inst_tac [("a1","a")] (th RS ssubst) 1);
  32.335 +by (assume_tac 1);
  32.336 +by (ftac wf_trancl 1);
  32.337 +by (ftac r_into_trancl 1);
  32.338 +by (asm_simp_tac (HOL_ss addsimps [cut_apply]) 1);
  32.339 +by (rtac H_cong2 1);    (*expose the equality of cuts*)
  32.340 +by (simp_tac (HOL_ss addsimps [cuts_eq, cut_apply, r_into_trancl]) 1);
  32.341 +by (blast_tac (claset() addIs [the_recfun_equal, transD, trans_trancl, 
  32.342 +			       r_into_trancl]) 1);
  32.343 +qed "wfrec";
  32.344 +
  32.345 +(*---------------------------------------------------------------------------
  32.346 + * This form avoids giant explosions in proofs.  NOTE USE OF == 
  32.347 + *---------------------------------------------------------------------------*)
  32.348 +Goal "[| f==wfrec r H;  wf(r) |] ==> f(a) = H (cut f r a) a";
  32.349 +by Auto_tac;
  32.350 +by (blast_tac (claset() addIs [wfrec]) 1);   
  32.351 +qed "def_wfrec";
  32.352 +
  32.353 +
  32.354 +(**** TFL variants ****)
  32.355 +
  32.356 +Goal "ALL R. wf R --> \
  32.357 +\      (ALL P. (ALL x. (ALL y. (y,x):R --> P y) --> P x) --> (ALL x. P x))";
  32.358 +by (Clarify_tac 1);
  32.359 +by (res_inst_tac [("r","R"),("P","P"), ("a","x")] wf_induct 1);
  32.360 +by (assume_tac 1);
  32.361 +by (Blast_tac 1);
  32.362 +qed"tfl_wf_induct";
  32.363 +
  32.364 +Goal "ALL f R. (x,a):R --> (cut f R a)(x) = f(x)";
  32.365 +by (Clarify_tac 1);
  32.366 +by (rtac cut_apply 1);
  32.367 +by (assume_tac 1);
  32.368 +qed"tfl_cut_apply";
  32.369 +
  32.370 +Goal "ALL M R f. (f=wfrec R M) --> wf R --> (ALL x. f x = M (cut f R x) x)";
  32.371 +by (Clarify_tac 1);
  32.372 +by (etac wfrec 1);
  32.373 +qed "tfl_wfrec";
    33.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    33.2 +++ b/src/HOL/Wellfounded_Recursion.thy	Thu Oct 12 18:44:35 2000 +0200
    33.3 @@ -0,0 +1,31 @@
    33.4 +(*  Title:      HOL/Wellfounded_Recursion.thy
    33.5 +    ID:         $Id$
    33.6 +    Author:     Tobias Nipkow
    33.7 +    Copyright   1992  University of Cambridge
    33.8 +
    33.9 +Well-founded Recursion
   33.10 +*)
   33.11 +
   33.12 +Wellfounded_Recursion = Transitive_Closure +
   33.13 +
   33.14 +constdefs
   33.15 +  wf         :: "('a * 'a)set => bool"
   33.16 +  "wf(r) == (!P. (!x. (!y. (y,x):r --> P(y)) --> P(x)) --> (!x. P(x)))"
   33.17 +
   33.18 +  acyclic :: "('a*'a)set => bool"
   33.19 +  "acyclic r == !x. (x,x) ~: r^+"
   33.20 +
   33.21 +  cut        :: "('a => 'b) => ('a * 'a)set => 'a => 'a => 'b"
   33.22 +  "cut f r x == (%y. if (y,x):r then f y else arbitrary)"
   33.23 +
   33.24 +  is_recfun  :: "('a * 'a)set => (('a=>'b) => ('a=>'b)) =>'a=>('a=>'b) => bool"
   33.25 +  "is_recfun r H a f == (f = cut (%x. H (cut f r x) x) r a)"
   33.26 +
   33.27 +  the_recfun :: "('a * 'a)set => (('a=>'b) => ('a=>'b)) => 'a => 'a => 'b"
   33.28 +  "the_recfun r H a  == (@f. is_recfun r H a f)"
   33.29 +
   33.30 +  wfrec      :: "('a * 'a)set => (('a=>'b) => ('a=>'b)) => 'a => 'b"
   33.31 +  "wfrec r H == (%x. H (cut (the_recfun (trancl r) (%f v. H (cut f r v) v) x)
   33.32 +                            r x)  x)"
   33.33 +
   33.34 +end
    34.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    34.2 +++ b/src/HOL/Wellfounded_Relations.ML	Thu Oct 12 18:44:35 2000 +0200
    34.3 @@ -0,0 +1,226 @@
    34.4 +(*  Title: 	HOL/Wellfounded_Relations
    34.5 +    ID:         $Id$
    34.6 +    Author: 	Konrad Slind
    34.7 +    Copyright   1996  TU Munich
    34.8 +
    34.9 +Derived WF relations: inverse image, lexicographic product, measure, ...
   34.10 +*)
   34.11 +
   34.12 +
   34.13 +(*----------------------------------------------------------------------------
   34.14 + * "Less than" on the natural numbers
   34.15 + *---------------------------------------------------------------------------*)
   34.16 +
   34.17 +Goalw [less_than_def] "wf less_than"; 
   34.18 +by (rtac (wf_pred_nat RS wf_trancl) 1);
   34.19 +qed "wf_less_than";
   34.20 +AddIffs [wf_less_than];
   34.21 +
   34.22 +Goalw [less_than_def] "trans less_than"; 
   34.23 +by (rtac trans_trancl 1);
   34.24 +qed "trans_less_than";
   34.25 +AddIffs [trans_less_than];
   34.26 +
   34.27 +Goalw [less_than_def, less_def] "((x,y): less_than) = (x<y)"; 
   34.28 +by (Simp_tac 1);
   34.29 +qed "less_than_iff";
   34.30 +AddIffs [less_than_iff];
   34.31 +
   34.32 +Goal "(!!n. (ALL m. Suc m <= n --> P m) ==> P n) ==> P n";
   34.33 +by (rtac (wf_less_than RS wf_induct) 1);
   34.34 +by (resolve_tac (premises()) 1);
   34.35 +by Auto_tac;
   34.36 +qed_spec_mp "full_nat_induct";
   34.37 +
   34.38 +(*----------------------------------------------------------------------------
   34.39 + * The inverse image into a wellfounded relation is wellfounded.
   34.40 + *---------------------------------------------------------------------------*)
   34.41 +
   34.42 +Goal "wf(r) ==> wf(inv_image r (f::'a=>'b))"; 
   34.43 +by (full_simp_tac (simpset() addsimps [inv_image_def, wf_eq_minimal]) 1);
   34.44 +by (Clarify_tac 1);
   34.45 +by (subgoal_tac "EX (w::'b). w : {w. EX (x::'a). x: Q & (f x = w)}" 1);
   34.46 +by (blast_tac (claset() delrules [allE]) 2);
   34.47 +by (etac allE 1);
   34.48 +by (mp_tac 1);
   34.49 +by (Blast_tac 1);
   34.50 +qed "wf_inv_image";
   34.51 +AddSIs [wf_inv_image];
   34.52 +
   34.53 +Goalw [trans_def,inv_image_def]
   34.54 +    "!!r. trans r ==> trans (inv_image r f)";
   34.55 +by (Simp_tac 1);
   34.56 +by (Blast_tac 1);
   34.57 +qed "trans_inv_image";
   34.58 +
   34.59 +
   34.60 +(*----------------------------------------------------------------------------
   34.61 + * All measures are wellfounded.
   34.62 + *---------------------------------------------------------------------------*)
   34.63 +
   34.64 +Goalw [measure_def] "wf (measure f)";
   34.65 +by (rtac (wf_less_than RS wf_inv_image) 1);
   34.66 +qed "wf_measure";
   34.67 +AddIffs [wf_measure];
   34.68 +
   34.69 +val measure_induct = standard
   34.70 +    (asm_full_simplify (simpset() addsimps [measure_def,inv_image_def])
   34.71 +      (wf_measure RS wf_induct));
   34.72 +bind_thm ("measure_induct", measure_induct);
   34.73 +
   34.74 +(*----------------------------------------------------------------------------
   34.75 + * Wellfoundedness of lexicographic combinations
   34.76 + *---------------------------------------------------------------------------*)
   34.77 +
   34.78 +val [wfa,wfb] = goalw (the_context ()) [wf_def,lex_prod_def]
   34.79 + "[| wf(ra); wf(rb) |] ==> wf(ra <*lex*> rb)";
   34.80 +by (EVERY1 [rtac allI,rtac impI]);
   34.81 +by (simp_tac (HOL_basic_ss addsimps [split_paired_All]) 1);
   34.82 +by (rtac (wfa RS spec RS mp) 1);
   34.83 +by (EVERY1 [rtac allI,rtac impI]);
   34.84 +by (rtac (wfb RS spec RS mp) 1);
   34.85 +by (Blast_tac 1);
   34.86 +qed "wf_lex_prod";
   34.87 +AddSIs [wf_lex_prod];
   34.88 +
   34.89 +(*---------------------------------------------------------------------------
   34.90 + * Transitivity of WF combinators.
   34.91 + *---------------------------------------------------------------------------*)
   34.92 +Goalw [trans_def, lex_prod_def]
   34.93 +    "!!R1 R2. [| trans R1; trans R2 |] ==> trans (R1 <*lex*> R2)";
   34.94 +by (Simp_tac 1);
   34.95 +by (Blast_tac 1);
   34.96 +qed "trans_lex_prod";
   34.97 +AddSIs [trans_lex_prod];
   34.98 +
   34.99 +
  34.100 +(*---------------------------------------------------------------------------
  34.101 + * Wellfoundedness of proper subset on finite sets.
  34.102 + *---------------------------------------------------------------------------*)
  34.103 +Goalw [finite_psubset_def] "wf(finite_psubset)";
  34.104 +by (rtac (wf_measure RS wf_subset) 1);
  34.105 +by (simp_tac (simpset() addsimps [measure_def, inv_image_def, less_than_def,
  34.106 +				 symmetric less_def])1);
  34.107 +by (fast_tac (claset() addSEs [psubset_card_mono]) 1);
  34.108 +qed "wf_finite_psubset";
  34.109 +
  34.110 +Goalw [finite_psubset_def, trans_def] "trans finite_psubset";
  34.111 +by (simp_tac (simpset() addsimps [psubset_def]) 1);
  34.112 +by (Blast_tac 1);
  34.113 +qed "trans_finite_psubset";
  34.114 +
  34.115 +(*---------------------------------------------------------------------------
  34.116 + * Wellfoundedness of finite acyclic relations
  34.117 + * Cannot go into WF because it needs Finite.
  34.118 + *---------------------------------------------------------------------------*)
  34.119 +
  34.120 +Goal "finite r ==> acyclic r --> wf r";
  34.121 +by (etac finite_induct 1);
  34.122 + by (Blast_tac 1);
  34.123 +by (split_all_tac 1);
  34.124 +by (Asm_full_simp_tac 1);
  34.125 +qed_spec_mp "finite_acyclic_wf";
  34.126 +
  34.127 +Goal "[|finite r; acyclic r|] ==> wf (r^-1)";
  34.128 +by (etac (finite_converse RS iffD2 RS finite_acyclic_wf) 1);
  34.129 +by (etac (acyclic_converse RS iffD2) 1);
  34.130 +qed "finite_acyclic_wf_converse";
  34.131 +
  34.132 +Goal "finite r ==> wf r = acyclic r";
  34.133 +by (blast_tac (claset() addIs [finite_acyclic_wf,wf_acyclic]) 1);
  34.134 +qed "wf_iff_acyclic_if_finite";
  34.135 +
  34.136 +
  34.137 +(*---------------------------------------------------------------------------
  34.138 + * A relation is wellfounded iff it has no infinite descending chain
  34.139 + * Cannot go into WF because it needs type nat.
  34.140 + *---------------------------------------------------------------------------*)
  34.141 +
  34.142 +Goalw [wf_eq_minimal RS eq_reflection]
  34.143 +  "wf r = (~(EX f. ALL i. (f(Suc i),f i) : r))";
  34.144 +by (rtac iffI 1);
  34.145 + by (rtac notI 1);
  34.146 + by (etac exE 1);
  34.147 + by (eres_inst_tac [("x","{w. EX i. w=f i}")] allE 1);
  34.148 + by (Blast_tac 1);
  34.149 +by (etac swap 1);
  34.150 +by (Asm_full_simp_tac 1);
  34.151 +by (Clarify_tac 1);
  34.152 +by (subgoal_tac "ALL n. nat_rec x (%i y. @z. z:Q & (z,y):r) n : Q" 1);
  34.153 + by (res_inst_tac[("x","nat_rec x (%i y. @z. z:Q & (z,y):r)")]exI 1);
  34.154 + by (rtac allI 1);
  34.155 + by (Simp_tac 1);
  34.156 + by (rtac someI2_ex 1);
  34.157 +  by (Blast_tac 1);
  34.158 + by (Blast_tac 1);
  34.159 +by (rtac allI 1);
  34.160 +by (induct_tac "n" 1);
  34.161 + by (Asm_simp_tac 1);
  34.162 +by (Simp_tac 1);
  34.163 +by (rtac someI2_ex 1);
  34.164 + by (Blast_tac 1);
  34.165 +by (Blast_tac 1);
  34.166 +qed "wf_iff_no_infinite_down_chain";
  34.167 +
  34.168 +(*----------------------------------------------------------------------------
  34.169 + * Weakly decreasing sequences (w.r.t. some well-founded order) stabilize.
  34.170 + *---------------------------------------------------------------------------*)
  34.171 +
  34.172 +Goal "[| ALL i. (f (Suc i), f i) : r^* |] ==> (f (i+k), f i) : r^*";
  34.173 +by (induct_tac "k" 1);
  34.174 + by (ALLGOALS Simp_tac);
  34.175 +by (blast_tac (claset() addIs [rtrancl_trans]) 1);
  34.176 +val lemma = result();
  34.177 +
  34.178 +Goal "[| ALL i. (f (Suc i), f i) : r^*; wf (r^+) |] \
  34.179 +\     ==> ALL m. f m = x --> (EX i. ALL k. f (m+i+k) = f (m+i))";
  34.180 +by (etac wf_induct 1);
  34.181 +by (Clarify_tac 1);
  34.182 +by (case_tac "EX j. (f (m+j), f m) : r^+" 1);
  34.183 + by (Clarify_tac 1);
  34.184 + by (subgoal_tac "EX i. ALL k. f ((m+j)+i+k) = f ((m+j)+i)" 1);
  34.185 +  by (Clarify_tac 1);
  34.186 +  by (res_inst_tac [("x","j+i")] exI 1);
  34.187 +  by (asm_full_simp_tac (simpset() addsimps add_ac) 1);
  34.188 + by (Blast_tac 1);
  34.189 +by (res_inst_tac [("x","0")] exI 1);
  34.190 +by (Clarsimp_tac 1);
  34.191 +by (dres_inst_tac [("i","m"), ("k","k")] lemma 1);
  34.192 +by (blast_tac (claset() addEs [rtranclE] addDs [rtrancl_into_trancl1]) 1);
  34.193 +val lemma = result();
  34.194 +
  34.195 +Goal "[| ALL i. (f (Suc i), f i) : r^*; wf (r^+) |] \
  34.196 +\     ==> EX i. ALL k. f (i+k) = f i";
  34.197 +by (dres_inst_tac [("x","0")] (lemma RS spec) 1);
  34.198 +by Auto_tac;
  34.199 +qed "wf_weak_decr_stable";
  34.200 +
  34.201 +(* special case: <= *)
  34.202 +
  34.203 +Goal "(m, n) : pred_nat^* = (m <= n)";
  34.204 +by (simp_tac (simpset() addsimps [less_eq, reflcl_trancl RS sym] 
  34.205 +                        delsimps [reflcl_trancl]) 1);
  34.206 +by (arith_tac 1);
  34.207 +qed "le_eq";
  34.208 +
  34.209 +Goal "ALL i. f (Suc i) <= ((f i)::nat) ==> EX i. ALL k. f (i+k) = f i";
  34.210 +by (res_inst_tac [("r","pred_nat")] wf_weak_decr_stable 1);
  34.211 +by (asm_simp_tac (simpset() addsimps [le_eq]) 1);
  34.212 +by (REPEAT (resolve_tac [wf_trancl,wf_pred_nat] 1));
  34.213 +qed "weak_decr_stable";
  34.214 +
  34.215 +(*----------------------------------------------------------------------------
  34.216 + * Wellfoundedness of same_fst
  34.217 + *---------------------------------------------------------------------------*)
  34.218 +
  34.219 +val prems = goalw thy [same_fst_def]
  34.220 +  "(!!x. P x ==> wf(R x)) ==> wf(same_fst P R)";
  34.221 +by(full_simp_tac (simpset() delcongs [imp_cong] addsimps [wf_def]) 1);
  34.222 +by(strip_tac 1);
  34.223 +by(rename_tac "a b" 1);
  34.224 +by(case_tac "wf(R a)" 1);
  34.225 + by (eres_inst_tac [("a","b")] wf_induct 1);
  34.226 + by (EVERY1[etac allE, etac allE, etac mp, rtac allI, rtac allI]);
  34.227 + by(Blast_tac 1);
  34.228 +by(blast_tac (claset() addIs prems) 1);
  34.229 +qed "wf_same_fstI";
    35.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    35.2 +++ b/src/HOL/Wellfounded_Relations.thy	Thu Oct 12 18:44:35 2000 +0200
    35.3 @@ -0,0 +1,44 @@
    35.4 +(*  Title:      HOL/Wellfounded_Relations
    35.5 +    ID:         $Id$
    35.6 +    Author:     Konrad Slind
    35.7 +    Copyright   1995 TU Munich
    35.8 +
    35.9 +Derived WF relations: inverse image, lexicographic product, measure, ...
   35.10 +
   35.11 +The simple relational product, in which (x',y')<(x,y) iff x'<x and y'<y, is a
   35.12 +subset of the lexicographic product, and therefore does not need to be defined
   35.13 +separately.
   35.14 +*)
   35.15 +
   35.16 +Wellfounded_Relations = Finite +
   35.17 +
   35.18 +(* actually belongs to theory Finite *)
   35.19 +instance unit :: finite                  (finite_unit)
   35.20 +instance "*" :: (finite,finite) finite   (finite_Prod)
   35.21 +
   35.22 +
   35.23 +constdefs
   35.24 + less_than :: "(nat*nat)set"
   35.25 +"less_than == trancl pred_nat"
   35.26 +
   35.27 + inv_image :: "('b * 'b)set => ('a => 'b) => ('a * 'a)set"
   35.28 +"inv_image r f == {(x,y). (f(x), f(y)) : r}"
   35.29 +
   35.30 + measure   :: "('a => nat) => ('a * 'a)set"
   35.31 +"measure == inv_image less_than"
   35.32 +
   35.33 + lex_prod  :: "[('a*'a)set, ('b*'b)set] => (('a*'b)*('a*'b))set"
   35.34 +               (infixr "<*lex*>" 80)
   35.35 +"ra <*lex*> rb == {((a,b),(a',b')). (a,a') : ra | a=a' & (b,b') : rb}"
   35.36 +
   35.37 + (* finite proper subset*)
   35.38 + finite_psubset  :: "('a set * 'a set) set"
   35.39 +"finite_psubset == {(A,B). A < B & finite B}"
   35.40 +
   35.41 +(* For rec_defs where the first n parameters stay unchanged in the recursive
   35.42 +   call. See While for an application.
   35.43 +*)
   35.44 + same_fst :: "('a => bool) => ('a => ('b * 'b)set) => (('a*'b)*('a*'b))set"
   35.45 +"same_fst P R == {((x',y'),(x,y)) . x'=x & P x & (y',y) : R x}"
   35.46 +
   35.47 +end