--- a/Arith.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,373 +0,0 @@
-(* Title: HOL/Arith.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Proofs about elementary arithmetic: addition, multiplication, etc.
-Tests definitions and simplifier.
-*)
-
-open Arith;
-
-(*** Basic rewrite rules for the arithmetic operators ***)
-
-val [pred_0, pred_Suc] = nat_recs pred_def;
-val [add_0,add_Suc] = nat_recs add_def;
-val [mult_0,mult_Suc] = nat_recs mult_def;
-
-(** Difference **)
-
-val diff_0 = diff_def RS def_nat_rec_0;
-
-qed_goalw "diff_0_eq_0" Arith.thy [diff_def, pred_def]
- "0 - n = 0"
- (fn _ => [nat_ind_tac "n" 1, ALLGOALS(asm_simp_tac nat_ss)]);
-
-(*Must simplify BEFORE the induction!! (Else we get a critical pair)
- Suc(m) - Suc(n) rewrites to pred(Suc(m) - n) *)
-qed_goalw "diff_Suc_Suc" Arith.thy [diff_def, pred_def]
- "Suc(m) - Suc(n) = m - n"
- (fn _ =>
- [simp_tac nat_ss 1, nat_ind_tac "n" 1, ALLGOALS(asm_simp_tac nat_ss)]);
-
-(*** Simplification over add, mult, diff ***)
-
-val arith_simps =
- [pred_0, pred_Suc, add_0, add_Suc, mult_0, mult_Suc,
- diff_0, diff_0_eq_0, diff_Suc_Suc];
-
-val arith_ss = nat_ss addsimps arith_simps;
-
-(**** Inductive properties of the operators ****)
-
-(*** Addition ***)
-
-qed_goal "add_0_right" Arith.thy "m + 0 = m"
- (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
-
-qed_goal "add_Suc_right" Arith.thy "m + Suc(n) = Suc(m+n)"
- (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
-
-val arith_ss = arith_ss addsimps [add_0_right,add_Suc_right];
-
-(*Associative law for addition*)
-qed_goal "add_assoc" Arith.thy "(m + n) + k = m + ((n + k)::nat)"
- (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
-
-(*Commutative law for addition*)
-qed_goal "add_commute" Arith.thy "m + n = n + (m::nat)"
- (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
-
-qed_goal "add_left_commute" Arith.thy "x+(y+z)=y+((x+z)::nat)"
- (fn _ => [rtac (add_commute RS trans) 1, rtac (add_assoc RS trans) 1,
- rtac (add_commute RS arg_cong) 1]);
-
-(*Addition is an AC-operator*)
-val add_ac = [add_assoc, add_commute, add_left_commute];
-
-goal Arith.thy "!!k::nat. (k + m = k + n) = (m=n)";
-by (nat_ind_tac "k" 1);
-by (simp_tac arith_ss 1);
-by (asm_simp_tac arith_ss 1);
-qed "add_left_cancel";
-
-goal Arith.thy "!!k::nat. (m + k = n + k) = (m=n)";
-by (nat_ind_tac "k" 1);
-by (simp_tac arith_ss 1);
-by (asm_simp_tac arith_ss 1);
-qed "add_right_cancel";
-
-goal Arith.thy "!!k::nat. (k + m <= k + n) = (m<=n)";
-by (nat_ind_tac "k" 1);
-by (simp_tac arith_ss 1);
-by (asm_simp_tac (arith_ss addsimps [Suc_le_mono]) 1);
-qed "add_left_cancel_le";
-
-goal Arith.thy "!!k::nat. (k + m < k + n) = (m<n)";
-by (nat_ind_tac "k" 1);
-by (simp_tac arith_ss 1);
-by (asm_simp_tac arith_ss 1);
-qed "add_left_cancel_less";
-
-(*** Multiplication ***)
-
-(*right annihilation in product*)
-qed_goal "mult_0_right" Arith.thy "m * 0 = 0"
- (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
-
-(*right Sucessor law for multiplication*)
-qed_goal "mult_Suc_right" Arith.thy "m * Suc(n) = m + (m * n)"
- (fn _ => [nat_ind_tac "m" 1,
- ALLGOALS(asm_simp_tac (arith_ss addsimps add_ac))]);
-
-val arith_ss = arith_ss addsimps [mult_0_right,mult_Suc_right];
-
-(*Commutative law for multiplication*)
-qed_goal "mult_commute" Arith.thy "m * n = n * (m::nat)"
- (fn _ => [nat_ind_tac "m" 1, ALLGOALS (asm_simp_tac arith_ss)]);
-
-(*addition distributes over multiplication*)
-qed_goal "add_mult_distrib" Arith.thy "(m + n)*k = (m*k) + ((n*k)::nat)"
- (fn _ => [nat_ind_tac "m" 1,
- ALLGOALS(asm_simp_tac (arith_ss addsimps add_ac))]);
-
-qed_goal "add_mult_distrib2" Arith.thy "k*(m + n) = (k*m) + ((k*n)::nat)"
- (fn _ => [nat_ind_tac "m" 1,
- ALLGOALS(asm_simp_tac (arith_ss addsimps add_ac))]);
-
-val arith_ss = arith_ss addsimps [add_mult_distrib,add_mult_distrib2];
-
-(*Associative law for multiplication*)
-qed_goal "mult_assoc" Arith.thy "(m * n) * k = m * ((n * k)::nat)"
- (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
-
-qed_goal "mult_left_commute" Arith.thy "x*(y*z) = y*((x*z)::nat)"
- (fn _ => [rtac trans 1, rtac mult_commute 1, rtac trans 1,
- rtac mult_assoc 1, rtac (mult_commute RS arg_cong) 1]);
-
-val mult_ac = [mult_assoc,mult_commute,mult_left_commute];
-
-(*** Difference ***)
-
-qed_goal "diff_self_eq_0" Arith.thy "m - m = 0"
- (fn _ => [nat_ind_tac "m" 1, ALLGOALS(asm_simp_tac arith_ss)]);
-
-(*Addition is the inverse of subtraction: if n<=m then n+(m-n) = m. *)
-val [prem] = goal Arith.thy "[| ~ m<n |] ==> n+(m-n) = (m::nat)";
-by (rtac (prem RS rev_mp) 1);
-by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
-by (ALLGOALS(asm_simp_tac arith_ss));
-qed "add_diff_inverse";
-
-
-(*** Remainder ***)
-
-goal Arith.thy "m - n < Suc(m)";
-by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
-by (etac less_SucE 3);
-by (ALLGOALS(asm_simp_tac arith_ss));
-qed "diff_less_Suc";
-
-goal Arith.thy "!!m::nat. m - n <= m";
-by (res_inst_tac [("m","m"), ("n","n")] diff_induct 1);
-by (ALLGOALS (asm_simp_tac arith_ss));
-by (etac le_trans 1);
-by (simp_tac (HOL_ss addsimps [le_eq_less_or_eq, lessI]) 1);
-qed "diff_le_self";
-
-goal Arith.thy "!!n::nat. (n+m) - n = m";
-by (nat_ind_tac "n" 1);
-by (ALLGOALS (asm_simp_tac arith_ss));
-qed "diff_add_inverse";
-
-goal Arith.thy "!!n::nat. n - (n+m) = 0";
-by (nat_ind_tac "n" 1);
-by (ALLGOALS (asm_simp_tac arith_ss));
-qed "diff_add_0";
-
-(*In ordinary notation: if 0<n and n<=m then m-n < m *)
-goal Arith.thy "!!m. [| 0<n; ~ m<n |] ==> m - n < m";
-by (subgoal_tac "0<n --> ~ m<n --> m - n < m" 1);
-by (fast_tac HOL_cs 1);
-by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
-by (ALLGOALS(asm_simp_tac(arith_ss addsimps [diff_less_Suc])));
-qed "div_termination";
-
-val wf_less_trans = wf_pred_nat RS wf_trancl RSN (2, def_wfrec RS trans);
-
-goalw Nat.thy [less_def] "<m,n> : pred_nat^+ = (m<n)";
-by (rtac refl 1);
-qed "less_eq";
-
-goal Arith.thy "!!m. m<n ==> m mod n = m";
-by (rtac (mod_def RS wf_less_trans) 1);
-by(asm_simp_tac HOL_ss 1);
-qed "mod_less";
-
-goal Arith.thy "!!m. [| 0<n; ~m<n |] ==> m mod n = (m-n) mod n";
-by (rtac (mod_def RS wf_less_trans) 1);
-by(asm_simp_tac (nat_ss addsimps [div_termination, cut_apply, less_eq]) 1);
-qed "mod_geq";
-
-
-(*** Quotient ***)
-
-goal Arith.thy "!!m. m<n ==> m div n = 0";
-by (rtac (div_def RS wf_less_trans) 1);
-by(asm_simp_tac nat_ss 1);
-qed "div_less";
-
-goal Arith.thy "!!M. [| 0<n; ~m<n |] ==> m div n = Suc((m-n) div n)";
-by (rtac (div_def RS wf_less_trans) 1);
-by(asm_simp_tac (nat_ss addsimps [div_termination, cut_apply, less_eq]) 1);
-qed "div_geq";
-
-(*Main Result about quotient and remainder.*)
-goal Arith.thy "!!m. 0<n ==> (m div n)*n + m mod n = m";
-by (res_inst_tac [("n","m")] less_induct 1);
-by (rename_tac "k" 1); (*Variable name used in line below*)
-by (case_tac "k<n" 1);
-by (ALLGOALS (asm_simp_tac(arith_ss addsimps (add_ac @
- [mod_less, mod_geq, div_less, div_geq,
- add_diff_inverse, div_termination]))));
-qed "mod_div_equality";
-
-
-(*** More results about difference ***)
-
-val [prem] = goal Arith.thy "m < Suc(n) ==> m-n = 0";
-by (rtac (prem RS rev_mp) 1);
-by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
-by (ALLGOALS (asm_simp_tac arith_ss));
-qed "less_imp_diff_is_0";
-
-val prems = goal Arith.thy "m-n = 0 --> n-m = 0 --> m=n";
-by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
-by (REPEAT(simp_tac arith_ss 1 THEN TRY(atac 1)));
-qed "diffs0_imp_equal_lemma";
-
-(* [| m-n = 0; n-m = 0 |] ==> m=n *)
-bind_thm ("diffs0_imp_equal", (diffs0_imp_equal_lemma RS mp RS mp));
-
-val [prem] = goal Arith.thy "m<n ==> 0<n-m";
-by (rtac (prem RS rev_mp) 1);
-by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
-by (ALLGOALS(asm_simp_tac arith_ss));
-qed "less_imp_diff_positive";
-
-val [prem] = goal Arith.thy "n < Suc(m) ==> Suc(m)-n = Suc(m-n)";
-by (rtac (prem RS rev_mp) 1);
-by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
-by (ALLGOALS(asm_simp_tac arith_ss));
-qed "Suc_diff_n";
-
-goal Arith.thy "Suc(m)-n = if(m<n, 0, Suc(m-n))";
-by(simp_tac (nat_ss addsimps [less_imp_diff_is_0, not_less_eq, Suc_diff_n]
- setloop (split_tac [expand_if])) 1);
-qed "if_Suc_diff_n";
-
-goal Arith.thy "P(k) --> (!n. P(Suc(n))--> P(n)) --> P(k-i)";
-by (res_inst_tac [("m","k"),("n","i")] diff_induct 1);
-by (ALLGOALS (strip_tac THEN' simp_tac arith_ss THEN' TRY o fast_tac HOL_cs));
-qed "zero_induct_lemma";
-
-val prems = goal Arith.thy "[| P(k); !!n. P(Suc(n)) ==> P(n) |] ==> P(0)";
-by (rtac (diff_self_eq_0 RS subst) 1);
-by (rtac (zero_induct_lemma RS mp RS mp) 1);
-by (REPEAT (ares_tac ([impI,allI]@prems) 1));
-qed "zero_induct";
-
-(*13 July 1992: loaded in 105.7s*)
-
-(**** Additional theorems about "less than" ****)
-
-goal Arith.thy "!!m. m<n --> (? k. n=Suc(m+k))";
-by (nat_ind_tac "n" 1);
-by (ALLGOALS(simp_tac arith_ss));
-by (REPEAT_FIRST (ares_tac [conjI, impI]));
-by (res_inst_tac [("x","0")] exI 2);
-by (simp_tac arith_ss 2);
-by (safe_tac HOL_cs);
-by (res_inst_tac [("x","Suc(k)")] exI 1);
-by (simp_tac arith_ss 1);
-val less_eq_Suc_add_lemma = result();
-
-(*"m<n ==> ? k. n = Suc(m+k)"*)
-bind_thm ("less_eq_Suc_add", less_eq_Suc_add_lemma RS mp);
-
-
-goal Arith.thy "n <= ((m + n)::nat)";
-by (nat_ind_tac "m" 1);
-by (ALLGOALS(simp_tac arith_ss));
-by (etac le_trans 1);
-by (rtac (lessI RS less_imp_le) 1);
-qed "le_add2";
-
-goal Arith.thy "n <= ((n + m)::nat)";
-by (simp_tac (arith_ss addsimps add_ac) 1);
-by (rtac le_add2 1);
-qed "le_add1";
-
-bind_thm ("less_add_Suc1", (lessI RS (le_add1 RS le_less_trans)));
-bind_thm ("less_add_Suc2", (lessI RS (le_add2 RS le_less_trans)));
-
-(*"i <= j ==> i <= j+m"*)
-bind_thm ("trans_le_add1", le_add1 RSN (2,le_trans));
-
-(*"i <= j ==> i <= m+j"*)
-bind_thm ("trans_le_add2", le_add2 RSN (2,le_trans));
-
-(*"i < j ==> i < j+m"*)
-bind_thm ("trans_less_add1", le_add1 RSN (2,less_le_trans));
-
-(*"i < j ==> i < m+j"*)
-bind_thm ("trans_less_add2", le_add2 RSN (2,less_le_trans));
-
-goal Arith.thy "!!k::nat. m <= n ==> m <= n+k";
-by (eresolve_tac [le_trans] 1);
-by (resolve_tac [le_add1] 1);
-qed "le_imp_add_le";
-
-goal Arith.thy "!!k::nat. m < n ==> m < n+k";
-by (eresolve_tac [less_le_trans] 1);
-by (resolve_tac [le_add1] 1);
-qed "less_imp_add_less";
-
-goal Arith.thy "m+k<=n --> m<=(n::nat)";
-by (nat_ind_tac "k" 1);
-by (ALLGOALS (asm_simp_tac arith_ss));
-by (fast_tac (HOL_cs addDs [Suc_leD]) 1);
-val add_leD1_lemma = result();
-bind_thm ("add_leD1", add_leD1_lemma RS mp);;
-
-goal Arith.thy "!!k l::nat. [| k<l; m+l = k+n |] ==> m<n";
-by (safe_tac (HOL_cs addSDs [less_eq_Suc_add]));
-by (asm_full_simp_tac
- (HOL_ss addsimps ([add_Suc_right RS sym, add_left_cancel] @add_ac)) 1);
-by (eresolve_tac [subst] 1);
-by (simp_tac (arith_ss addsimps [less_add_Suc1]) 1);
-qed "less_add_eq_less";
-
-
-(** Monotonicity of addition (from ZF/Arith) **)
-
-(** Monotonicity results **)
-
-(*strict, in 1st argument*)
-goal Arith.thy "!!i j k::nat. i < j ==> i + k < j + k";
-by (nat_ind_tac "k" 1);
-by (ALLGOALS (asm_simp_tac arith_ss));
-qed "add_less_mono1";
-
-(*strict, in both arguments*)
-goal Arith.thy "!!i j k::nat. [|i < j; k < l|] ==> i + k < j + l";
-by (rtac (add_less_mono1 RS less_trans) 1);
-by (REPEAT (etac asm_rl 1));
-by (nat_ind_tac "j" 1);
-by (ALLGOALS(asm_simp_tac arith_ss));
-qed "add_less_mono";
-
-(*A [clumsy] way of lifting < monotonicity to <= monotonicity *)
-val [lt_mono,le] = goal Arith.thy
- "[| !!i j::nat. i<j ==> f(i) < f(j); \
-\ i <= j \
-\ |] ==> f(i) <= (f(j)::nat)";
-by (cut_facts_tac [le] 1);
-by (asm_full_simp_tac (HOL_ss addsimps [le_eq_less_or_eq]) 1);
-by (fast_tac (HOL_cs addSIs [lt_mono]) 1);
-qed "less_mono_imp_le_mono";
-
-(*non-strict, in 1st argument*)
-goal Arith.thy "!!i j k::nat. i<=j ==> i + k <= j + k";
-by (res_inst_tac [("f", "%j.j+k")] less_mono_imp_le_mono 1);
-by (eresolve_tac [add_less_mono1] 1);
-by (assume_tac 1);
-qed "add_le_mono1";
-
-(*non-strict, in both arguments*)
-goal Arith.thy "!!k l::nat. [|i<=j; k<=l |] ==> i + k <= j + l";
-by (etac (add_le_mono1 RS le_trans) 1);
-by (simp_tac (HOL_ss addsimps [add_commute]) 1);
-(*j moves to the end because it is free while k, l are bound*)
-by (eresolve_tac [add_le_mono1] 1);
-qed "add_le_mono";
--- a/Arith.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,31 +0,0 @@
-(* Title: HOL/Arith.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Arithmetic operators and their definitions
-*)
-
-Arith = Nat +
-
-instance
- nat :: {plus, minus, times}
-
-consts
- pred :: "nat => nat"
- div, mod :: "[nat, nat] => nat" (infixl 70)
-
-defs
- pred_def "pred(m) == nat_rec(m, 0, %n r.n)"
- add_def "m+n == nat_rec(m, n, %u v. Suc(v))"
- diff_def "m-n == nat_rec(n, m, %u v. pred(v))"
- mult_def "m*n == nat_rec(m, 0, %u v. n + v)"
- mod_def "m mod n == wfrec(trancl(pred_nat), m, %j f. if(j<n, j, f(j-n)))"
- div_def "m div n == wfrec(trancl(pred_nat), m, %j f. if(j<n, 0, Suc(f(j-n))))"
-end
-
-(*"Difference" is subtraction of natural numbers.
- There are no negative numbers; we have
- m - n = 0 iff m<=n and m - n = Suc(k) iff m>n.
- Also, nat_rec(m, 0, %z w.z) is pred(m). *)
-
--- a/Finite.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,84 +0,0 @@
-(* Title: HOL/Finite.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Finite powerset operator
-*)
-
-open Finite;
-
-goalw Finite.thy Fin.defs "!!A B. A<=B ==> Fin(A) <= Fin(B)";
-br lfp_mono 1;
-by (REPEAT (ares_tac basic_monos 1));
-qed "Fin_mono";
-
-goalw Finite.thy Fin.defs "Fin(A) <= Pow(A)";
-by (fast_tac (set_cs addSIs [lfp_lowerbound]) 1);
-qed "Fin_subset_Pow";
-
-(* A : Fin(B) ==> A <= B *)
-val FinD = Fin_subset_Pow RS subsetD RS PowD;
-
-(*Discharging ~ x:y entails extra work*)
-val major::prems = goal Finite.thy
- "[| F:Fin(A); P({}); \
-\ !!F x. [| x:A; F:Fin(A); x~:F; P(F) |] ==> P(insert(x,F)) \
-\ |] ==> P(F)";
-by (rtac (major RS Fin.induct) 1);
-by (excluded_middle_tac "a:b" 2);
-by (etac (insert_absorb RS ssubst) 3 THEN assume_tac 3); (*backtracking!*)
-by (REPEAT (ares_tac prems 1));
-qed "Fin_induct";
-
-(** Simplification for Fin **)
-
-val Fin_ss = set_ss addsimps Fin.intrs;
-
-(*The union of two finite sets is finite*)
-val major::prems = goal Finite.thy
- "[| F: Fin(A); G: Fin(A) |] ==> F Un G : Fin(A)";
-by (rtac (major RS Fin_induct) 1);
-by (ALLGOALS (asm_simp_tac (Fin_ss addsimps (prems@[Un_insert_left]))));
-qed "Fin_UnI";
-
-(*Every subset of a finite set is finite*)
-val [subs,fin] = goal Finite.thy "[| A<=B; B: Fin(M) |] ==> A: Fin(M)";
-by (EVERY1 [subgoal_tac "ALL C. C<=B --> C: Fin(M)",
- rtac mp, etac spec,
- rtac subs]);
-by (rtac (fin RS Fin_induct) 1);
-by (simp_tac (Fin_ss addsimps [subset_Un_eq]) 1);
-by (safe_tac (set_cs addSDs [subset_insert_iff RS iffD1]));
-by (eres_inst_tac [("t","C")] (insert_Diff RS subst) 2);
-by (ALLGOALS (asm_simp_tac Fin_ss));
-qed "Fin_subset";
-
-(*The image of a finite set is finite*)
-val major::_ = goal Finite.thy
- "F: Fin(A) ==> h``F : Fin(h``A)";
-by (rtac (major RS Fin_induct) 1);
-by (simp_tac Fin_ss 1);
-by (asm_simp_tac (set_ss addsimps [image_eqI RS Fin.insertI, image_insert]) 1);
-qed "Fin_imageI";
-
-val major::prems = goal Finite.thy
- "[| c: Fin(A); b: Fin(A); \
-\ P(b); \
-\ !!(x::'a) y. [| x:A; y: Fin(A); x:y; P(y) |] ==> P(y-{x}) \
-\ |] ==> c<=b --> P(b-c)";
-by (rtac (major RS Fin_induct) 1);
-by (rtac (Diff_insert RS ssubst) 2);
-by (ALLGOALS (asm_simp_tac
- (Fin_ss addsimps (prems@[Diff_subset RS Fin_subset]))));
-qed "Fin_empty_induct_lemma";
-
-val prems = goal Finite.thy
- "[| b: Fin(A); \
-\ P(b); \
-\ !!x y. [| x:A; y: Fin(A); x:y; P(y) |] ==> P(y-{x}) \
-\ |] ==> P({})";
-by (rtac (Diff_cancel RS subst) 1);
-by (rtac (Fin_empty_induct_lemma RS mp) 1);
-by (REPEAT (ares_tac (subset_refl::prems) 1));
-qed "Fin_empty_induct";
--- a/Finite.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,17 +0,0 @@
-(* Title: HOL/Finite.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Finite powerset operator
-*)
-
-Finite = Lfp +
-consts Fin :: "'a set => 'a set set"
-
-inductive "Fin(A)"
- intrs
- emptyI "{} : Fin(A)"
- insertI "[| a: A; b: Fin(A) |] ==> insert(a,b) : Fin(A)"
-
-end
--- a/Fun.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,200 +0,0 @@
-(* Title: HOL/Fun
- ID: $Id$
- Author: Tobias Nipkow, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Lemmas about functions.
-*)
-
-goal Fun.thy "(f = g) = (!x. f(x)=g(x))";
-by (rtac iffI 1);
-by(asm_simp_tac HOL_ss 1);
-by(rtac ext 1 THEN asm_simp_tac HOL_ss 1);
-qed "expand_fun_eq";
-
-val prems = goal Fun.thy
- "[| f(x)=u; !!x. P(x) ==> g(f(x)) = x; P(x) |] ==> x=g(u)";
-by (rtac (arg_cong RS box_equals) 1);
-by (REPEAT (resolve_tac (prems@[refl]) 1));
-qed "apply_inverse";
-
-
-(*** Range of a function ***)
-
-(*Frequently b does not have the syntactic form of f(x).*)
-val [prem] = goalw Fun.thy [range_def] "b=f(x) ==> b : range(f)";
-by (EVERY1 [rtac CollectI, rtac exI, rtac prem]);
-qed "range_eqI";
-
-val rangeI = refl RS range_eqI;
-
-val [major,minor] = goalw Fun.thy [range_def]
- "[| b : range(%x.f(x)); !!x. b=f(x) ==> P |] ==> P";
-by (rtac (major RS CollectD RS exE) 1);
-by (etac minor 1);
-qed "rangeE";
-
-(*** Image of a set under a function ***)
-
-val prems = goalw Fun.thy [image_def] "[| b=f(x); x:A |] ==> b : f``A";
-by (REPEAT (resolve_tac (prems @ [CollectI,bexI,prem]) 1));
-qed "image_eqI";
-
-val imageI = refl RS image_eqI;
-
-(*The eta-expansion gives variable-name preservation.*)
-val major::prems = goalw Fun.thy [image_def]
- "[| b : (%x.f(x))``A; !!x.[| b=f(x); x:A |] ==> P |] ==> P";
-by (rtac (major RS CollectD RS bexE) 1);
-by (REPEAT (ares_tac prems 1));
-qed "imageE";
-
-goalw Fun.thy [o_def] "(f o g)``r = f``(g``r)";
-by (rtac set_ext 1);
-by (fast_tac (HOL_cs addIs [imageI] addSEs [imageE]) 1);
-qed "image_compose";
-
-goal Fun.thy "f``(A Un B) = f``A Un f``B";
-by (rtac set_ext 1);
-by (fast_tac (HOL_cs addIs [imageI,UnCI] addSEs [imageE,UnE]) 1);
-qed "image_Un";
-
-(*** inj(f): f is a one-to-one function ***)
-
-val prems = goalw Fun.thy [inj_def]
- "[| !! x y. f(x) = f(y) ==> x=y |] ==> inj(f)";
-by (fast_tac (HOL_cs addIs prems) 1);
-qed "injI";
-
-val [major] = goal Fun.thy "(!!x. g(f(x)) = x) ==> inj(f)";
-by (rtac injI 1);
-by (etac (arg_cong RS box_equals) 1);
-by (rtac major 1);
-by (rtac major 1);
-qed "inj_inverseI";
-
-val [major,minor] = goalw Fun.thy [inj_def]
- "[| inj(f); f(x) = f(y) |] ==> x=y";
-by (rtac (major RS spec RS spec RS mp) 1);
-by (rtac minor 1);
-qed "injD";
-
-(*Useful with the simplifier*)
-val [major] = goal Fun.thy "inj(f) ==> (f(x) = f(y)) = (x=y)";
-by (rtac iffI 1);
-by (etac (major RS injD) 1);
-by (etac arg_cong 1);
-qed "inj_eq";
-
-val [major] = goal Fun.thy "inj(f) ==> (@x.f(x)=f(y)) = y";
-by (rtac (major RS injD) 1);
-by (rtac selectI 1);
-by (rtac refl 1);
-qed "inj_select";
-
-(*A one-to-one function has an inverse (given using select).*)
-val [major] = goalw Fun.thy [Inv_def] "inj(f) ==> Inv(f,f(x)) = x";
-by (EVERY1 [rtac (major RS inj_select)]);
-qed "Inv_f_f";
-
-(* Useful??? *)
-val [oneone,minor] = goal Fun.thy
- "[| inj(f); !!y. y: range(f) ==> P(Inv(f,y)) |] ==> P(x)";
-by (res_inst_tac [("t", "x")] (oneone RS (Inv_f_f RS subst)) 1);
-by (rtac (rangeI RS minor) 1);
-qed "inj_transfer";
-
-
-(*** inj_onto(f,A): f is one-to-one over A ***)
-
-val prems = goalw Fun.thy [inj_onto_def]
- "(!! x y. [| f(x) = f(y); x:A; y:A |] ==> x=y) ==> inj_onto(f,A)";
-by (fast_tac (HOL_cs addIs prems addSIs [ballI]) 1);
-qed "inj_ontoI";
-
-val [major] = goal Fun.thy
- "(!!x. x:A ==> g(f(x)) = x) ==> inj_onto(f,A)";
-by (rtac inj_ontoI 1);
-by (etac (apply_inverse RS trans) 1);
-by (REPEAT (eresolve_tac [asm_rl,major] 1));
-qed "inj_onto_inverseI";
-
-val major::prems = goalw Fun.thy [inj_onto_def]
- "[| inj_onto(f,A); f(x)=f(y); x:A; y:A |] ==> x=y";
-by (rtac (major RS bspec RS bspec RS mp) 1);
-by (REPEAT (resolve_tac prems 1));
-qed "inj_ontoD";
-
-goal Fun.thy "!!x y.[| inj_onto(f,A); x:A; y:A |] ==> (f(x)=f(y)) = (x=y)";
-by (fast_tac (HOL_cs addSEs [inj_ontoD]) 1);
-qed "inj_onto_iff";
-
-val major::prems = goal Fun.thy
- "[| inj_onto(f,A); ~x=y; x:A; y:A |] ==> ~ f(x)=f(y)";
-by (rtac contrapos 1);
-by (etac (major RS inj_ontoD) 2);
-by (REPEAT (resolve_tac prems 1));
-qed "inj_onto_contraD";
-
-
-(*** Lemmas about inj ***)
-
-val prems = goalw Fun.thy [o_def]
- "[| inj(f); inj_onto(g,range(f)) |] ==> inj(g o f)";
-by (cut_facts_tac prems 1);
-by (fast_tac (HOL_cs addIs [injI,rangeI]
- addEs [injD,inj_ontoD]) 1);
-qed "comp_inj";
-
-val [prem] = goal Fun.thy "inj(f) ==> inj_onto(f,A)";
-by (fast_tac (HOL_cs addIs [prem RS injD, inj_ontoI]) 1);
-qed "inj_imp";
-
-val [prem] = goalw Fun.thy [Inv_def] "y : range(f) ==> f(Inv(f,y)) = y";
-by (EVERY1 [rtac (prem RS rangeE), rtac selectI, etac sym]);
-qed "f_Inv_f";
-
-val prems = goal Fun.thy
- "[| Inv(f,x)=Inv(f,y); x: range(f); y: range(f) |] ==> x=y";
-by (rtac (arg_cong RS box_equals) 1);
-by (REPEAT (resolve_tac (prems @ [f_Inv_f]) 1));
-qed "Inv_injective";
-
-val prems = goal Fun.thy
- "[| inj(f); A<=range(f) |] ==> inj_onto(Inv(f), A)";
-by (cut_facts_tac prems 1);
-by (fast_tac (HOL_cs addIs [inj_ontoI]
- addEs [Inv_injective,injD,subsetD]) 1);
-qed "inj_onto_Inv";
-
-
-(*** Set reasoning tools ***)
-
-val set_cs = HOL_cs
- addSIs [ballI, PowI, subsetI, InterI, INT_I, INT1_I, CollectI,
- ComplI, IntI, DiffI, UnCI, insertCI]
- addIs [bexI, UnionI, UN_I, UN1_I, imageI, rangeI]
- addSEs [bexE, make_elim PowD, UnionE, UN_E, UN1_E, DiffE,
- CollectE, ComplE, IntE, UnE, insertE, imageE, rangeE, emptyE]
- addEs [ballE, InterD, InterE, INT_D, INT_E, make_elim INT1_D,
- subsetD, subsetCE];
-
-fun cfast_tac prems = cut_facts_tac prems THEN' fast_tac set_cs;
-
-
-fun prover s = prove_goal Fun.thy s (fn _=>[fast_tac set_cs 1]);
-
-val mem_simps = map prover
- [ "(a : A Un B) = (a:A | a:B)",
- "(a : A Int B) = (a:A & a:B)",
- "(a : Compl(B)) = (~a:B)",
- "(a : A-B) = (a:A & ~a:B)",
- "(a : {b}) = (a=b)",
- "(a : {x.P(x)}) = P(a)" ];
-
-val mksimps_pairs = ("Ball",[bspec]) :: mksimps_pairs;
-
-val set_ss =
- HOL_ss addsimps mem_simps
- addcongs [ball_cong,bex_cong]
- setmksimps (mksimps mksimps_pairs);
--- a/Fun.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-(* Title: HOL/Fun.thy
- ID: $Id$
- Author: Tobias Nipkow, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Lemmas about functions.
-*)
-
-Fun = Set
--- a/Gfp.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,145 +0,0 @@
-(* Title: HOL/gfp
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-For gfp.thy. The Knaster-Tarski Theorem for greatest fixed points.
-*)
-
-open Gfp;
-
-(*** Proof of Knaster-Tarski Theorem using gfp ***)
-
-(* gfp(f) is the least upper bound of {u. u <= f(u)} *)
-
-val prems = goalw Gfp.thy [gfp_def] "[| X <= f(X) |] ==> X <= gfp(f)";
-by (rtac (CollectI RS Union_upper) 1);
-by (resolve_tac prems 1);
-qed "gfp_upperbound";
-
-val prems = goalw Gfp.thy [gfp_def]
- "[| !!u. u <= f(u) ==> u<=X |] ==> gfp(f) <= X";
-by (REPEAT (ares_tac ([Union_least]@prems) 1));
-by (etac CollectD 1);
-qed "gfp_least";
-
-val [mono] = goal Gfp.thy "mono(f) ==> gfp(f) <= f(gfp(f))";
-by (EVERY1 [rtac gfp_least, rtac subset_trans, atac,
- rtac (mono RS monoD), rtac gfp_upperbound, atac]);
-qed "gfp_lemma2";
-
-val [mono] = goal Gfp.thy "mono(f) ==> f(gfp(f)) <= gfp(f)";
-by (EVERY1 [rtac gfp_upperbound, rtac (mono RS monoD),
- rtac gfp_lemma2, rtac mono]);
-qed "gfp_lemma3";
-
-val [mono] = goal Gfp.thy "mono(f) ==> gfp(f) = f(gfp(f))";
-by (REPEAT (resolve_tac [equalityI,gfp_lemma2,gfp_lemma3,mono] 1));
-qed "gfp_Tarski";
-
-(*** Coinduction rules for greatest fixed points ***)
-
-(*weak version*)
-val prems = goal Gfp.thy
- "[| a: X; X <= f(X) |] ==> a : gfp(f)";
-by (rtac (gfp_upperbound RS subsetD) 1);
-by (REPEAT (ares_tac prems 1));
-qed "weak_coinduct";
-
-val [prem,mono] = goal Gfp.thy
- "[| X <= f(X Un gfp(f)); mono(f) |] ==> \
-\ X Un gfp(f) <= f(X Un gfp(f))";
-by (rtac (prem RS Un_least) 1);
-by (rtac (mono RS gfp_lemma2 RS subset_trans) 1);
-by (rtac (Un_upper2 RS subset_trans) 1);
-by (rtac (mono RS mono_Un) 1);
-qed "coinduct_lemma";
-
-(*strong version, thanks to Coen & Frost*)
-goal Gfp.thy
- "!!X. [| mono(f); a: X; X <= f(X Un gfp(f)) |] ==> a : gfp(f)";
-by (rtac (coinduct_lemma RSN (2, weak_coinduct)) 1);
-by (REPEAT (ares_tac [UnI1, Un_least] 1));
-qed "coinduct";
-
-val [mono,prem] = goal Gfp.thy
- "[| mono(f); a: gfp(f) |] ==> a: f(X Un gfp(f))";
-br (mono RS mono_Un RS subsetD) 1;
-br (mono RS gfp_lemma2 RS subsetD RS UnI2) 1;
-by (rtac prem 1);
-qed "gfp_fun_UnI2";
-
-(*** Even Stronger version of coinduct [by Martin Coen]
- - instead of the condition X <= f(X)
- consider X <= (f(X) Un f(f(X)) ...) Un gfp(X) ***)
-
-val [prem] = goal Gfp.thy "mono(f) ==> mono(%x.f(x) Un X Un B)";
-by (REPEAT (ares_tac [subset_refl, monoI, Un_mono, prem RS monoD] 1));
-qed "coinduct3_mono_lemma";
-
-val [prem,mono] = goal Gfp.thy
- "[| X <= f(lfp(%x.f(x) Un X Un gfp(f))); mono(f) |] ==> \
-\ lfp(%x.f(x) Un X Un gfp(f)) <= f(lfp(%x.f(x) Un X Un gfp(f)))";
-by (rtac subset_trans 1);
-by (rtac (mono RS coinduct3_mono_lemma RS lfp_lemma3) 1);
-by (rtac (Un_least RS Un_least) 1);
-by (rtac subset_refl 1);
-by (rtac prem 1);
-by (rtac (mono RS gfp_Tarski RS equalityD1 RS subset_trans) 1);
-by (rtac (mono RS monoD) 1);
-by (rtac (mono RS coinduct3_mono_lemma RS lfp_Tarski RS ssubst) 1);
-by (rtac Un_upper2 1);
-qed "coinduct3_lemma";
-
-val prems = goal Gfp.thy
- "[| mono(f); a:X; X <= f(lfp(%x.f(x) Un X Un gfp(f))) |] ==> a : gfp(f)";
-by (rtac (coinduct3_lemma RSN (2,weak_coinduct)) 1);
-by (resolve_tac (prems RL [coinduct3_mono_lemma RS lfp_Tarski RS ssubst]) 1);
-by (rtac (UnI2 RS UnI1) 1);
-by (REPEAT (resolve_tac prems 1));
-qed "coinduct3";
-
-
-(** Definition forms of gfp_Tarski and coinduct, to control unfolding **)
-
-val [rew,mono] = goal Gfp.thy "[| A==gfp(f); mono(f) |] ==> A = f(A)";
-by (rewtac rew);
-by (rtac (mono RS gfp_Tarski) 1);
-qed "def_gfp_Tarski";
-
-val rew::prems = goal Gfp.thy
- "[| A==gfp(f); mono(f); a:X; X <= f(X Un A) |] ==> a: A";
-by (rewtac rew);
-by (REPEAT (ares_tac (map (rewrite_rule [rew]) prems @ [coinduct]) 1));
-qed "def_coinduct";
-
-(*The version used in the induction/coinduction package*)
-val prems = goal Gfp.thy
- "[| A == gfp(%w. Collect(P(w))); mono(%w. Collect(P(w))); \
-\ a: X; !!z. z: X ==> P(X Un A, z) |] ==> \
-\ a : A";
-by (rtac def_coinduct 1);
-by (REPEAT (ares_tac (prems @ [subsetI,CollectI]) 1));
-qed "def_Collect_coinduct";
-
-val rew::prems = goal Gfp.thy
- "[| A==gfp(f); mono(f); a:X; X <= f(lfp(%x.f(x) Un X Un A)) |] ==> a: A";
-by (rewtac rew);
-by (REPEAT (ares_tac (map (rewrite_rule [rew]) prems @ [coinduct3]) 1));
-qed "def_coinduct3";
-
-(*Monotonicity of gfp!*)
-val prems = goal Gfp.thy
- "[| mono(f); !!Z. f(Z)<=g(Z) |] ==> gfp(f) <= gfp(g)";
-by (rtac gfp_upperbound 1);
-by (rtac subset_trans 1);
-by (rtac gfp_lemma2 1);
-by (resolve_tac prems 1);
-by (resolve_tac prems 1);
-val gfp_mono = result();
-
-(*Monotonicity of gfp!*)
-val [prem] = goal Gfp.thy "[| !!Z. f(Z)<=g(Z) |] ==> gfp(f) <= gfp(g)";
-br (gfp_upperbound RS gfp_least) 1;
-be (prem RSN (2,subset_trans)) 1;
-qed "gfp_mono";
--- a/Gfp.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,14 +0,0 @@
-(* Title: HOL/gfp.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Greatest fixed points (requires Lfp too!)
-*)
-
-Gfp = Lfp +
-consts gfp :: "['a set=>'a set] => 'a set"
-defs
- (*greatest fixed point*)
- gfp_def "gfp(f) == Union({u. u <= f(u)})"
-end
--- a/HOL.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,266 +0,0 @@
-(* Title: HOL/hol.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1991 University of Cambridge
-
-For hol.thy
-Derived rules from Appendix of Mike Gordons HOL Report, Cambridge TR 68
-*)
-
-open HOL;
-
-
-(** Equality **)
-
-qed_goal "sym" HOL.thy "s=t ==> t=s"
- (fn prems => [cut_facts_tac prems 1, etac subst 1, rtac refl 1]);
-
-(*calling "standard" reduces maxidx to 0*)
-bind_thm ("ssubst", (sym RS subst));
-
-qed_goal "trans" HOL.thy "[| r=s; s=t |] ==> r=t"
- (fn prems =>
- [rtac subst 1, resolve_tac prems 1, resolve_tac prems 1]);
-
-(*Useful with eresolve_tac for proving equalties from known equalities.
- a = b
- | |
- c = d *)
-qed_goal "box_equals" HOL.thy
- "[| a=b; a=c; b=d |] ==> c=d"
- (fn prems=>
- [ (rtac trans 1),
- (rtac trans 1),
- (rtac sym 1),
- (REPEAT (resolve_tac prems 1)) ]);
-
-(** Congruence rules for meta-application **)
-
-(*similar to AP_THM in Gordon's HOL*)
-qed_goal "fun_cong" HOL.thy "(f::'a=>'b) = g ==> f(x)=g(x)"
- (fn [prem] => [rtac (prem RS subst) 1, rtac refl 1]);
-
-(*similar to AP_TERM in Gordon's HOL and FOL's subst_context*)
-qed_goal "arg_cong" HOL.thy "x=y ==> f(x)=f(y)"
- (fn [prem] => [rtac (prem RS subst) 1, rtac refl 1]);
-
-qed_goal "cong" HOL.thy
- "[| f = g; (x::'a) = y |] ==> f(x) = g(y)"
- (fn [prem1,prem2] =>
- [rtac (prem1 RS subst) 1, rtac (prem2 RS subst) 1, rtac refl 1]);
-
-(** Equality of booleans -- iff **)
-
-qed_goal "iffI" HOL.thy
- "[| P ==> Q; Q ==> P |] ==> P=Q"
- (fn prems=> [ (REPEAT (ares_tac (prems@[impI, iff RS mp RS mp]) 1)) ]);
-
-qed_goal "iffD2" HOL.thy "[| P=Q; Q |] ==> P"
- (fn prems =>
- [rtac ssubst 1, resolve_tac prems 1, resolve_tac prems 1]);
-
-val iffD1 = sym RS iffD2;
-
-qed_goal "iffE" HOL.thy
- "[| P=Q; [| P --> Q; Q --> P |] ==> R |] ==> R"
- (fn [p1,p2] => [REPEAT(ares_tac([p1 RS iffD2, p1 RS iffD1, p2, impI])1)]);
-
-(** True **)
-
-qed_goalw "TrueI" HOL.thy [True_def] "True"
- (fn _ => [rtac refl 1]);
-
-qed_goal "eqTrueI " HOL.thy "P ==> P=True"
- (fn prems => [REPEAT(resolve_tac ([iffI,TrueI]@prems) 1)]);
-
-qed_goal "eqTrueE" HOL.thy "P=True ==> P"
- (fn prems => [REPEAT(resolve_tac (prems@[TrueI,iffD2]) 1)]);
-
-(** Universal quantifier **)
-
-qed_goalw "allI" HOL.thy [All_def] "(!!x::'a. P(x)) ==> !x. P(x)"
- (fn prems => [resolve_tac (prems RL [eqTrueI RS ext]) 1]);
-
-qed_goalw "spec" HOL.thy [All_def] "! x::'a.P(x) ==> P(x)"
- (fn prems => [rtac eqTrueE 1, resolve_tac (prems RL [fun_cong]) 1]);
-
-qed_goal "allE" HOL.thy "[| !x.P(x); P(x) ==> R |] ==> R"
- (fn major::prems=>
- [ (REPEAT (resolve_tac (prems @ [major RS spec]) 1)) ]);
-
-qed_goal "all_dupE" HOL.thy
- "[| ! x.P(x); [| P(x); ! x.P(x) |] ==> R |] ==> R"
- (fn prems =>
- [ (REPEAT (resolve_tac (prems @ (prems RL [spec])) 1)) ]);
-
-
-(** False ** Depends upon spec; it is impossible to do propositional logic
- before quantifiers! **)
-
-qed_goalw "FalseE" HOL.thy [False_def] "False ==> P"
- (fn [major] => [rtac (major RS spec) 1]);
-
-qed_goal "False_neq_True" HOL.thy "False=True ==> P"
- (fn [prem] => [rtac (prem RS eqTrueE RS FalseE) 1]);
-
-
-(** Negation **)
-
-qed_goalw "notI" HOL.thy [not_def] "(P ==> False) ==> ~P"
- (fn prems=> [rtac impI 1, eresolve_tac prems 1]);
-
-qed_goalw "notE" HOL.thy [not_def] "[| ~P; P |] ==> R"
- (fn prems => [rtac (prems MRS mp RS FalseE) 1]);
-
-(** Implication **)
-
-qed_goal "impE" HOL.thy "[| P-->Q; P; Q ==> R |] ==> R"
- (fn prems=> [ (REPEAT (resolve_tac (prems@[mp]) 1)) ]);
-
-(* Reduces Q to P-->Q, allowing substitution in P. *)
-qed_goal "rev_mp" HOL.thy "[| P; P --> Q |] ==> Q"
- (fn prems=> [ (REPEAT (resolve_tac (prems@[mp]) 1)) ]);
-
-qed_goal "contrapos" HOL.thy "[| ~Q; P==>Q |] ==> ~P"
- (fn [major,minor]=>
- [ (rtac (major RS notE RS notI) 1),
- (etac minor 1) ]);
-
-(* ~(?t = ?s) ==> ~(?s = ?t) *)
-val [not_sym] = compose(sym,2,contrapos);
-
-
-(** Existential quantifier **)
-
-qed_goalw "exI" HOL.thy [Ex_def] "P(x) ==> ? x::'a.P(x)"
- (fn prems => [rtac selectI 1, resolve_tac prems 1]);
-
-qed_goalw "exE" HOL.thy [Ex_def]
- "[| ? x::'a.P(x); !!x. P(x) ==> Q |] ==> Q"
- (fn prems => [REPEAT(resolve_tac prems 1)]);
-
-
-(** Conjunction **)
-
-qed_goalw "conjI" HOL.thy [and_def] "[| P; Q |] ==> P&Q"
- (fn prems =>
- [REPEAT (resolve_tac (prems@[allI,impI]) 1 ORELSE etac (mp RS mp) 1)]);
-
-qed_goalw "conjunct1" HOL.thy [and_def] "[| P & Q |] ==> P"
- (fn prems =>
- [resolve_tac (prems RL [spec] RL [mp]) 1, REPEAT(ares_tac [impI] 1)]);
-
-qed_goalw "conjunct2" HOL.thy [and_def] "[| P & Q |] ==> Q"
- (fn prems =>
- [resolve_tac (prems RL [spec] RL [mp]) 1, REPEAT(ares_tac [impI] 1)]);
-
-qed_goal "conjE" HOL.thy "[| P&Q; [| P; Q |] ==> R |] ==> R"
- (fn prems =>
- [cut_facts_tac prems 1, resolve_tac prems 1,
- etac conjunct1 1, etac conjunct2 1]);
-
-(** Disjunction *)
-
-qed_goalw "disjI1" HOL.thy [or_def] "P ==> P|Q"
- (fn [prem] => [REPEAT(ares_tac [allI,impI, prem RSN (2,mp)] 1)]);
-
-qed_goalw "disjI2" HOL.thy [or_def] "Q ==> P|Q"
- (fn [prem] => [REPEAT(ares_tac [allI,impI, prem RSN (2,mp)] 1)]);
-
-qed_goalw "disjE" HOL.thy [or_def] "[| P | Q; P ==> R; Q ==> R |] ==> R"
- (fn [a1,a2,a3] =>
- [rtac (mp RS mp) 1, rtac spec 1, rtac a1 1,
- rtac (a2 RS impI) 1, assume_tac 1, rtac (a3 RS impI) 1, assume_tac 1]);
-
-(** CCONTR -- classical logic **)
-
-qed_goalw "classical" HOL.thy [not_def] "(~P ==> P) ==> P"
- (fn [prem] =>
- [rtac (True_or_False RS (disjE RS eqTrueE)) 1, assume_tac 1,
- rtac (impI RS prem RS eqTrueI) 1,
- etac subst 1, assume_tac 1]);
-
-val ccontr = FalseE RS classical;
-
-(*Double negation law*)
-qed_goal "notnotD" HOL.thy "~~P ==> P"
- (fn [major]=>
- [ (rtac classical 1), (eresolve_tac [major RS notE] 1) ]);
-
-
-(** Unique existence **)
-
-qed_goalw "ex1I" HOL.thy [Ex1_def]
- "[| P(a); !!x. P(x) ==> x=a |] ==> ?! x. P(x)"
- (fn prems =>
- [REPEAT (ares_tac (prems@[exI,conjI,allI,impI]) 1)]);
-
-qed_goalw "ex1E" HOL.thy [Ex1_def]
- "[| ?! x.P(x); !!x. [| P(x); ! y. P(y) --> y=x |] ==> R |] ==> R"
- (fn major::prems =>
- [rtac (major RS exE) 1, REPEAT (etac conjE 1 ORELSE ares_tac prems 1)]);
-
-
-(** Select: Hilbert's Epsilon-operator **)
-
-(*Easier to apply than selectI: conclusion has only one occurrence of P*)
-qed_goal "selectI2" HOL.thy
- "[| P(a); !!x. P(x) ==> Q(x) |] ==> Q(@x.P(x))"
- (fn prems => [ resolve_tac prems 1,
- rtac selectI 1,
- resolve_tac prems 1 ]);
-
-qed_goal "select_equality" HOL.thy
- "[| P(a); !!x. P(x) ==> x=a |] ==> (@x.P(x)) = a"
- (fn prems => [ rtac selectI2 1,
- REPEAT (ares_tac prems 1) ]);
-
-
-(** Classical intro rules for disjunction and existential quantifiers *)
-
-qed_goal "disjCI" HOL.thy "(~Q ==> P) ==> P|Q"
- (fn prems=>
- [ (rtac classical 1),
- (REPEAT (ares_tac (prems@[disjI1,notI]) 1)),
- (REPEAT (ares_tac (prems@[disjI2,notE]) 1)) ]);
-
-qed_goal "excluded_middle" HOL.thy "~P | P"
- (fn _ => [ (REPEAT (ares_tac [disjCI] 1)) ]);
-
-(*For disjunctive case analysis*)
-fun excluded_middle_tac sP =
- res_inst_tac [("Q",sP)] (excluded_middle RS disjE);
-
-(*Classical implies (-->) elimination. *)
-qed_goal "impCE" HOL.thy "[| P-->Q; ~P ==> R; Q ==> R |] ==> R"
- (fn major::prems=>
- [ rtac (excluded_middle RS disjE) 1,
- REPEAT (DEPTH_SOLVE_1 (ares_tac (prems @ [major RS mp]) 1))]);
-
-(*Classical <-> elimination. *)
-qed_goal "iffCE" HOL.thy
- "[| P=Q; [| P; Q |] ==> R; [| ~P; ~Q |] ==> R |] ==> R"
- (fn major::prems =>
- [ (rtac (major RS iffE) 1),
- (REPEAT (DEPTH_SOLVE_1
- (eresolve_tac ([asm_rl,impCE,notE]@prems) 1))) ]);
-
-qed_goal "exCI" HOL.thy "(! x. ~P(x) ==> P(a)) ==> ? x.P(x)"
- (fn prems=>
- [ (rtac ccontr 1),
- (REPEAT (ares_tac (prems@[exI,allI,notI,notE]) 1)) ]);
-
-
-(* case distinction *)
-
-qed_goal "case_split_thm" HOL.thy "[| P ==> Q; ~P ==> Q |] ==> Q"
- (fn [p1,p2] => [cut_facts_tac [excluded_middle] 1, etac disjE 1,
- etac p2 1, etac p1 1]);
-
-fun case_tac a = res_inst_tac [("P",a)] case_split_thm;
-
-(** Standard abbreviations **)
-
-fun stac th = rtac(th RS ssubst);
-fun sstac ths = EVERY' (map stac ths);
-fun strip_tac i = REPEAT(resolve_tac [impI,allI] i);
--- a/HOL.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,165 +0,0 @@
-(* Title: HOL/HOL.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1993 University of Cambridge
-
-Higher-Order Logic
-*)
-
-HOL = Pure +
-
-classes
- term < logic
-
-axclass
- plus < term
-
-axclass
- minus < term
-
-axclass
- times < term
-
-default
- term
-
-types
- bool
-
-arities
- fun :: (term, term) term
- bool :: term
-
-
-consts
-
- (* Constants *)
-
- Trueprop :: "bool => prop" ("(_)" 5)
- not :: "bool => bool" ("~ _" [40] 40)
- True, False :: "bool"
- if :: "[bool, 'a, 'a] => 'a"
- Inv :: "('a => 'b) => ('b => 'a)"
-
- (* Binders *)
-
- Eps :: "('a => bool) => 'a" (binder "@" 10)
- All :: "('a => bool) => bool" (binder "! " 10)
- Ex :: "('a => bool) => bool" (binder "? " 10)
- Ex1 :: "('a => bool) => bool" (binder "?! " 10)
- Let :: "['a, 'a => 'b] => 'b"
-
- (* Infixes *)
-
- o :: "['b => 'c, 'a => 'b, 'a] => 'c" (infixr 50)
- "=" :: "['a, 'a] => bool" (infixl 50)
-(*"~=" :: "['a, 'a] => bool" (infixl 50)*)
- "&" :: "[bool, bool] => bool" (infixr 35)
- "|" :: "[bool, bool] => bool" (infixr 30)
- "-->" :: "[bool, bool] => bool" (infixr 25)
-
- (* Overloaded Constants *)
-
- "+" :: "['a::plus, 'a] => 'a" (infixl 65)
- "-" :: "['a::minus, 'a] => 'a" (infixl 65)
- "*" :: "['a::times, 'a] => 'a" (infixl 70)
-
-
-types
- letbinds letbind
- case_syn cases_syn
-
-syntax
-
- "~=" :: "['a, 'a] => bool" (infixl 50)
-
- (* Alternative Quantifiers *)
-
- "*All" :: "[idts, bool] => bool" ("(3ALL _./ _)" 10)
- "*Ex" :: "[idts, bool] => bool" ("(3EX _./ _)" 10)
- "*Ex1" :: "[idts, bool] => bool" ("(3EX! _./ _)" 10)
-
- (* Let expressions *)
-
- "_bind" :: "[idt, 'a] => letbind" ("(2_ =/ _)" 10)
- "" :: "letbind => letbinds" ("_")
- "_binds" :: "[letbind, letbinds] => letbinds" ("_;/ _")
- "_Let" :: "[letbinds, 'a] => 'a" ("(let (_)/ in (_))" 10)
-
- (* Case expressions *)
-
- "@case" :: "['a, cases_syn] => 'b" ("(case _ of/ _)" 10)
- "@case1" :: "['a, 'b] => case_syn" ("(2_ =>/ _)" 10)
- "" :: "case_syn => cases_syn" ("_")
- "@case2" :: "[case_syn, cases_syn] => cases_syn" ("_/ | _")
-
-translations
- "x ~= y" == "~ (x = y)"
- "ALL xs. P" => "! xs. P"
- "EX xs. P" => "? xs. P"
- "EX! xs. P" => "?! xs. P"
- "_Let(_binds(b, bs), e)" == "_Let(b, _Let(bs, e))"
- "let x = a in e" == "Let(a, %x. e)"
-
-
-rules
-
- eq_reflection "(x=y) ==> (x==y)"
-
- (* Basic Rules *)
-
- refl "t = (t::'a)"
- subst "[| s = t; P(s) |] ==> P(t::'a)"
- ext "(!!x::'a. (f(x)::'b) = g(x)) ==> (%x.f(x)) = (%x.g(x))"
- selectI "P(x::'a) ==> P(@x.P(x))"
-
- impI "(P ==> Q) ==> P-->Q"
- mp "[| P-->Q; P |] ==> Q"
-
-defs
-
- True_def "True == ((%x::bool.x)=(%x.x))"
- All_def "All(P) == (P = (%x.True))"
- Ex_def "Ex(P) == P(@x.P(x))"
- False_def "False == (!P.P)"
- not_def "~ P == P-->False"
- and_def "P & Q == !R. (P-->Q-->R) --> R"
- or_def "P | Q == !R. (P-->R) --> (Q-->R) --> R"
- Ex1_def "Ex1(P) == ? x. P(x) & (! y. P(y) --> y=x)"
-
-rules
- (* Axioms *)
-
- iff "(P-->Q) --> (Q-->P) --> (P=Q)"
- True_or_False "(P=True) | (P=False)"
-
-defs
- (* Misc Definitions *)
-
- Let_def "Let(s, f) == f(s)"
- Inv_def "Inv(f::'a=>'b) == (% y. @x. f(x)=y)"
- o_def "(f::'b=>'c) o g == (%(x::'a). f(g(x)))"
- if_def "if(P,x,y) == @z::'a. (P=True --> z=x) & (P=False --> z=y)"
-
-end
-
-
-ML
-
-(** Choice between the HOL and Isabelle style of quantifiers **)
-
-val HOL_quantifiers = ref true;
-
-fun alt_ast_tr' (name, alt_name) =
- let
- fun ast_tr' (*name*) args =
- if ! HOL_quantifiers then raise Match
- else Syntax.mk_appl (Syntax.Constant alt_name) args;
- in
- (name, ast_tr')
- end;
-
-
-val print_ast_translation =
- map alt_ast_tr' [("! ", "*All"), ("? ", "*Ex"), ("?! ", "*Ex1")];
-
--- a/IMP/Denotation.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,46 +0,0 @@
-(* Title: HOL/IMP/Denotation.thy
- ID: $Id$
- Author: Heiko Loetzbeyer & Robert Sandner, TUM
- Copyright 1994 TUM
-
-Denotational semantics of expressions & commands
-*)
-
-Denotation = Com +
-
-types com_den = "(state*state)set"
-consts
- A :: "aexp => state => nat"
- B :: "bexp => state => bool"
- C :: "com => com_den"
- Gamma :: "[bexp,com_den] => (com_den => com_den)"
-
-primrec A aexp
- A_nat "A(N(n)) = (%s. n)"
- A_loc "A(X(x)) = (%s. s(x))"
- A_op1 "A(Op1(f,a)) = (%s. f(A(a,s)))"
- A_op2 "A(Op2(f,a0,a1)) = (%s. f(A(a0,s),A(a1,s)))"
-
-primrec B bexp
- B_true "B(true) = (%s. True)"
- B_false "B(false) = (%s. False)"
- B_op "B(ROp(f,a0,a1)) = (%s. f(A(a0,s),A(a1,s)))"
- B_not "B(noti(b)) = (%s. ~B(b,s))"
- B_and "B(b0 andi b1) = (%s. B(b0,s) & B(b1,s))"
- B_or "B(b0 ori b1) = (%s. B(b0,s) | B(b1,s))"
-
-defs
- Gamma_def "Gamma(b,cd) ==
- (%phi.{st. st : (phi O cd) & B(b,fst(st))} Un
- {st. st : id & ~B(b,fst(st))})"
-
-primrec C com
- C_skip "C(skip) = id"
- C_assign "C(x := a) = {st . snd(st) = fst(st)[A(a,fst(st))/x]}"
- C_comp "C(c0 ; c1) = C(c1) O C(c0)"
- C_if "C(ifc b then c0 else c1) =
- {st. st:C(c0) & B(b,fst(st))} Un
- {st. st:C(c1) & ~B(b,fst(st))}"
- C_while "C(while b do c) = lfp(Gamma(b,C(c)))"
-
-end
--- a/IMP/Equiv.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,85 +0,0 @@
-(* Title: HOL/IMP/Equiv.ML
- ID: $Id$
- Author: Heiko Loetzbeyer & Robert Sandner, TUM
- Copyright 1994 TUM
-*)
-
-goal Equiv.thy "!n. (<a,s> -a-> n) = (n = A(a,s))";
-by (aexp.induct_tac "a" 1); (* struct. ind. *)
-by (ALLGOALS(simp_tac (HOL_ss addsimps A_simps))); (* rewr. Den. *)
-by (TRYALL (fast_tac (set_cs addSIs (evala.intrs@prems)
- addSEs evala_elim_cases)));
-bind_thm("aexp_iff", result() RS spec);
-
-goal Equiv.thy "!w. (<b,s> -b-> w) = (w = B(b,s))";
-by (bexp.induct_tac "b" 1);
-by (ALLGOALS(asm_simp_tac (HOL_ss addcongs [conj_cong]
- addsimps (aexp_iff::B_simps@evalb_simps))));
-bind_thm("bexp_iff", result() RS spec);
-
-val bexp1 = bexp_iff RS iffD1;
-val bexp2 = bexp_iff RS iffD2;
-
-val BfstI = read_instantiate_sg (sign_of Equiv.thy)
- [("P","%x.B(?b,x)")] (fst_conv RS ssubst);
-val BfstD = read_instantiate_sg (sign_of Equiv.thy)
- [("P","%x.B(?b,x)")] (fst_conv RS subst);
-
-goal Equiv.thy "!!c. <c,s> -c-> t ==> <s,t> : C(c)";
-
-(* start with rule induction *)
-be (evalc.mutual_induct RS spec RS spec RS spec RSN (2,rev_mp)) 1;
-by (rewrite_tac (Gamma_def::C_simps));
- (* simplification with HOL_ss again too agressive *)
-(* skip *)
-by (fast_tac comp_cs 1);
-(* assign *)
-by (asm_full_simp_tac (prod_ss addsimps [aexp_iff]) 1);
-(* comp *)
-by (fast_tac comp_cs 1);
-(* if *)
-by(fast_tac (set_cs addSIs [BfstI] addSDs [BfstD,bexp1]) 1);
-by(fast_tac (set_cs addSIs [BfstI] addSDs [BfstD,bexp1]) 1);
-(* while *)
-by (rtac (rewrite_rule [Gamma_def] (Gamma_mono RS lfp_Tarski RS ssubst)) 1);
-by (fast_tac (comp_cs addSIs [bexp1,BfstI] addSDs [BfstD,bexp1]) 1);
-by (rtac (rewrite_rule [Gamma_def] (Gamma_mono RS lfp_Tarski RS ssubst)) 1);
-by (fast_tac (comp_cs addSIs [bexp1,BfstI] addSDs [BfstD,bexp1]) 1);
-
-qed "com1";
-
-
-val com_ss = prod_ss addsimps (aexp_iff::bexp_iff::evalc.intrs);
-
-goal Equiv.thy "!io:C(c). <c,fst(io)> -c-> snd(io)";
-by (com.induct_tac "c" 1);
-by (rewrite_tac C_simps);
-by (safe_tac comp_cs);
-by (ALLGOALS (asm_full_simp_tac com_ss));
-
-(* comp *)
-by (REPEAT (EVERY [(dtac bspec 1),(atac 1)]));
-by (asm_full_simp_tac com_ss 1);
-
-(* while *)
-by (etac (Gamma_mono RSN (2,induct)) 1);
-by (rewrite_goals_tac [Gamma_def]);
-by (safe_tac comp_cs);
-by (EVERY1 [dtac bspec, atac]);
-by (ALLGOALS (asm_full_simp_tac com_ss));
-
-qed "com2";
-
-
-(**** Proof of Equivalence ****)
-
-val com_iff_cs = set_cs addEs [com2 RS bspec] addDs [com1];
-
-goal Equiv.thy "C(c) = {io . <c,fst(io)> -c-> snd(io)}";
-by (rtac equalityI 1);
-(* => *)
-by (fast_tac com_iff_cs 1);
-(* <= *)
-by (REPEAT (step_tac com_iff_cs 1));
-by (asm_full_simp_tac (prod_ss addsimps [surjective_pairing RS sym])1);
-qed "com_equivalence";
--- a/IMP/Equiv.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,7 +0,0 @@
-(* Title: HOL/IMP/Equiv.thy
- ID: $Id$
- Author: Heiko Loetzbeyer & Robert Sandner, TUM
- Copyright 1994 TUM
-*)
-
-Equiv = Denotation
--- a/IMP/Properties.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,41 +0,0 @@
-(* Title: HOL/IMP/Properties.ML
- ID: $Id$
- Author: Tobias Nipkow, TUM
- Copyright 1994 TUM
-
-IMP is deterministic.
-*)
-
-(* evaluation of aexp is deterministic *)
-goal Com.thy "!m n. <a,s> -a-> m & <a,s> -a-> n --> m=n";
-by(res_inst_tac[("aexp","a")]Com.aexp.induct 1);
-by(REPEAT(fast_tac (HOL_cs addSIs evala.intrs addSEs evala_elim_cases) 1));
-bind_thm("aexp_detD", conjI RS (result() RS spec RS spec RS mp));
-
-(* evaluation of bexp is deterministic *)
-goal Com.thy "!v w. <b,s> -b-> v & <b,s> -b-> w --> v=w";
-by(res_inst_tac[("bexp","b")]Com.bexp.induct 1);
-by(REPEAT(fast_tac (HOL_cs addSIs evalb.intrs addSEs evalb_elim_cases
- addDs [aexp_detD]) 1));
-bind_thm("bexp_detD", conjI RS (result() RS spec RS spec RS mp));
-
-
-val evalc_elim_cases = map (evalc.mk_cases com.simps)
- ["<skip,s> -c-> t", "<x:=a,s> -c-> t", "<c1;c2, s> -c-> t",
- "<ifc b then c1 else c2, s> -c-> t", "<while b do c,s> -c-> t"];
-
-(* evaluation of com is deterministic *)
-goal Com.thy "!!c. <c,s> -c-> t ==> !u. <c,s> -c-> u --> u=t";
-(* start with rule induction *)
-be (evalc.mutual_induct RS spec RS spec RS spec RSN (2,rev_mp)) 1;
-by(fast_tac (set_cs addSEs evalc_elim_cases) 1);
-by(fast_tac (set_cs addSEs evalc_elim_cases addDs [aexp_detD]) 1);
-by(fast_tac (set_cs addSEs evalc_elim_cases) 1);
-by(fast_tac (set_cs addSEs evalc_elim_cases addDs [bexp_detD]) 1);
-by(fast_tac (set_cs addSEs evalc_elim_cases addDs [bexp_detD]) 1);
-by(EVERY1[strip_tac, eresolve_tac evalc_elim_cases,
- atac, dtac bexp_detD, atac, etac False_neq_True]);
-by(EVERY1[strip_tac, eresolve_tac evalc_elim_cases,
- dtac bexp_detD, atac, etac (sym RS False_neq_True),
- fast_tac HOL_cs]);
-result();
--- a/IMP/Properties.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1 +0,0 @@
-Properties = "Com"
--- a/IMP/ROOT.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,24 +0,0 @@
-(* Title: HOL/IMP/ROOT.ML
- ID: $Id$
- Author: Heiko Loetzbeyer & Robert Sandner, TUM
- Copyright 1994 TUM
-
-Executes the formalization of the denotational and operational semantics of a
-simple while-language, including an equivalence proof. The whole development
-essentially formalizes/transcribes chapters 2 and 5 of
-
-Glynn Winskel. The Formal Semantics of Programming Languages.
-MIT Press, 1993.
-
-*)
-
-HOL_build_completed; (*Make examples fail if HOL did*)
-
-writeln"Root file for HOL/IMP";
-proof_timing := true;
-loadpath := [".","IMP"];
-time_use_thy "Properties";
-time_use_thy "Equiv";
-
-make_chart (); (*make HTML chart*)
-
--- a/IOA/ROOT.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,24 +0,0 @@
-(* Title: HOL/IOA/ROOT.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-This is the ROOT file for the theory of I/O-Automata.
-The formalization is by a semantic model of I/O-Automata.
-For details see
-
-@unpublished{Nipkow-Slind-IOA,
-author={Tobias Nipkow and Konrad Slind},
-title={{I/O} Automata in {Isabelle/HOL}},
-year=1994,
-note={Submitted for publication}}
-ftp://ftp.informatik.tu-muenchen.de/local/lehrstuhl/nipkow/ioa.ps.gz
-
-Should be executed in the subdirectory HOL.
-*)
-goals_limit := 1;
-
-loadpath := "IOA/meta_theory" :: "IOA/example" :: !loadpath;
-use_thy "Correctness";
-
-make_chart (); (*make HTML chart*)
--- a/IOA/example/Action.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,13 +0,0 @@
-(* Title: HOL/IOA/example/Action.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Derived rules for actions
-*)
-
-goal Action.thy "!!x. x = y ==> action_case(a,b,c,d,e,f,g,h,i,j,x) = \
-\ action_case(a,b,c,d,e,f,g,h,i,j,y)";
-by (asm_simp_tac HOL_ss 1);
-
-val action_ss = arith_ss addcongs [result()] addsimps Action.action.simps;
--- a/IOA/example/Action.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,14 +0,0 @@
-(* Title: HOL/IOA/example/Action.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The set of all actions of the system
-*)
-
-Action = Packet +
-datatype 'm action = S_msg ('m) | R_msg ('m)
- | S_pkt ('m packet) | R_pkt ('m packet)
- | S_ack (bool) | R_ack (bool)
- | C_m_s | C_m_r | C_r_s | C_r_r ('m)
-end
--- a/IOA/example/Channels.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,42 +0,0 @@
-(* Title: HOL/IOA/example/Channels.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Derived rules
-*)
-
-local
-val SS = action_ss addsimps
- (Channels.srch_asig_def ::
- Channels.rsch_asig_def ::
- actions_def :: asig_projections @ set_lemmas)
-in
-
-val in_srch_asig = prove_goal Channels.thy
- "S_msg(m) ~: actions(srch_asig) & \
- \ R_msg(m) ~: actions(srch_asig) & \
- \ S_pkt(pkt) : actions(srch_asig) & \
- \ R_pkt(pkt) : actions(srch_asig) & \
- \ S_ack(b) ~: actions(srch_asig) & \
- \ R_ack(b) ~: actions(srch_asig) & \
- \ C_m_s ~: actions(srch_asig) & \
- \ C_m_r ~: actions(srch_asig) & \
- \ C_r_s ~: actions(srch_asig) & \
- \ C_r_r(m) ~: actions(srch_asig)"
- (fn _ => [simp_tac SS 1]);
-
-val in_rsch_asig = prove_goal Channels.thy
- "S_msg(m) ~: actions(rsch_asig) & \
- \ R_msg(m) ~: actions(rsch_asig) & \
- \ S_pkt(pkt) ~: actions(rsch_asig) & \
- \ R_pkt(pkt) ~: actions(rsch_asig) & \
- \ S_ack(b) : actions(rsch_asig) & \
- \ R_ack(b) : actions(rsch_asig) & \
- \ C_m_s ~: actions(rsch_asig) & \
- \ C_m_r ~: actions(rsch_asig) & \
- \ C_r_s ~: actions(rsch_asig) & \
- \ C_r_r(m) ~: actions(rsch_asig)"
- (fn _ => [simp_tac SS 1]);
-
-end;
--- a/IOA/example/Channels.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,69 +0,0 @@
-(* Title: HOL/IOA/example/Channels.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The (faulty) transmission channels (both directions)
-*)
-
-Channels = IOA + Action + Multiset +
-
-consts
-
-srch_asig,
-rsch_asig :: "'m action signature"
-
-srch_trans :: "('m action, 'm packet multiset)transition set"
-rsch_trans :: "('m action, bool multiset)transition set"
-
-srch_ioa :: "('m action, 'm packet multiset)ioa"
-rsch_ioa :: "('m action, bool multiset)ioa"
-
-defs
-
-srch_asig_def "srch_asig == <UN pkt. {S_pkt(pkt)},
- UN pkt. {R_pkt(pkt)},
- {}>"
-
-rsch_asig_def "rsch_asig == <UN b. {S_ack(b)},
- UN b. {R_ack(b)},
- {}>"
-
-srch_trans_def "srch_trans ==
- {tr. let s = fst(tr);
- t = snd(snd(tr))
- in
- case fst(snd(tr))
- of S_msg(m) => False |
- R_msg(m) => False |
- S_pkt(pkt) => t = addm(s, pkt) |
- R_pkt(pkt) => count(s, pkt) ~= 0 & t = delm(s, pkt) |
- S_ack(b) => False |
- R_ack(b) => False |
- C_m_s => False |
- C_m_r => False |
- C_r_s => False |
- C_r_r(m) => False}"
-
-rsch_trans_def "rsch_trans ==
- {tr. let s = fst(tr);
- t = snd(snd(tr))
- in
- case fst(snd(tr))
- of
- S_msg(m) => False |
- R_msg(m) => False |
- S_pkt(pkt) => False |
- R_pkt(pkt) => False |
- S_ack(b) => t = addm(s,b) |
- R_ack(b) => count(s,b) ~= 0 & t = delm(s,b) |
- C_m_s => False |
- C_m_r => False |
- C_r_s => False |
- C_r_r(m) => False}"
-
-
-srch_ioa_def "srch_ioa == <srch_asig, {{|}}, srch_trans>"
-rsch_ioa_def "rsch_ioa == <rsch_asig, {{|}}, rsch_trans>"
-
-end
--- a/IOA/example/Correctness.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,103 +0,0 @@
-(* Title: HOL/IOA/example/Correctness.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The main correctness proof: Impl implements Spec
-*)
-
-open Impl;
-open Spec;
-
-val hom_ss = impl_ss;
-val hom_ioas = [Spec.ioa_def, Spec.trans_def,
- Sender.sender_trans_def,Receiver.receiver_trans_def]
- @ impl_ioas;
-
-val hom_ss' = hom_ss addsimps hom_ioas;
-
-val impl_asigs = [Sender.sender_asig_def,Receiver.receiver_asig_def,
- Channels.srch_asig_def,Channels.rsch_asig_def];
-
-(* A lemma about restricting the action signature of the implementation
- * to that of the specification.
- ****************************)
-goal Correctness.thy
- "a:externals(asig_of(restrict(impl_ioa,externals(spec_sig)))) = \
-\ (case a of \
-\ S_msg(m) => True \
-\ | R_msg(m) => True \
-\ | S_pkt(pkt) => False \
-\ | R_pkt(pkt) => False \
-\ | S_ack(b) => False \
-\ | R_ack(b) => False \
-\ | C_m_s => False \
-\ | C_m_r => False \
-\ | C_r_s => False \
-\ | C_r_r(m) => False)";
- by(simp_tac (hom_ss addcongs [if_weak_cong]
- addsimps ([externals_def, restrict_def, restrict_asig_def,
- asig_of_par, asig_comp_def, Spec.sig_def] @
- asig_projections @ impl_ioas @ impl_asigs)) 1);
- by(Action.action.induct_tac "a" 1);
- by(ALLGOALS(simp_tac (action_ss addsimps
- (actions_def :: asig_projections @ set_lemmas))));
-qed "externals_lemma";
-
-
-val sels = [Sender.sbit_def, Sender.sq_def, Sender.ssending_def,
- Receiver.rbit_def, Receiver.rq_def, Receiver.rsending_def];
-
-(* Proof of correctness *)
-goalw Correctness.thy [Spec.ioa_def, Solve.is_weak_pmap_def]
- "is_weak_pmap(hom, restrict(impl_ioa,externals(spec_sig)), spec_ioa)";
-by(simp_tac (hom_ss addsimps
- (Correctness.hom_def::[cancel_restrict,externals_lemma])) 1);
-br conjI 1;
-by(simp_tac (hom_ss addsimps impl_ioas) 1);
-br ballI 1;
-bd CollectD 1;
-by(asm_simp_tac (hom_ss addsimps sels) 1);
-by(REPEAT(rtac allI 1));
-br imp_conj_lemma 1; (* from lemmas.ML *)
-by(Action.action.induct_tac "a" 1);
-by(asm_simp_tac (hom_ss' setloop (split_tac [expand_if])) 1);
-by(forward_tac [inv4] 1);
-by(asm_full_simp_tac (hom_ss addsimps
- [imp_ex_equiv,neq_Nil_conv,ex_all_equiv]) 1);
-by(simp_tac hom_ss' 1);
-by(simp_tac hom_ss' 1);
-by(simp_tac hom_ss' 1);
-by(simp_tac hom_ss' 1);
-by(simp_tac hom_ss' 1);
-by(simp_tac hom_ss' 1);
-by(simp_tac hom_ss' 1);
-
-by(asm_simp_tac hom_ss' 1);
-by(forward_tac [inv4] 1);
-by(forward_tac [inv2] 1);
-be disjE 1;
-by(asm_simp_tac hom_ss 1);
-by(asm_full_simp_tac (hom_ss addsimps
- [imp_ex_equiv,neq_Nil_conv,ex_all_equiv]) 1);
-
-by(asm_simp_tac hom_ss' 1);
-by(forward_tac [inv2] 1);
-be disjE 1;
-
-by(forward_tac [inv3] 1);
-by(case_tac "sq(sen(s))=[]" 1);
-
-by(asm_full_simp_tac hom_ss' 1);
-by(fast_tac (HOL_cs addSDs [add_leD1 RS leD]) 1);
-
-by(case_tac "m = hd(sq(sen(s)))" 1);
-
-by(asm_full_simp_tac (hom_ss addsimps
- [imp_ex_equiv,neq_Nil_conv,ex_all_equiv]) 1);
-
-by(asm_full_simp_tac hom_ss 1);
-by(fast_tac (HOL_cs addSDs [add_leD1 RS leD]) 1);
-
-by(asm_full_simp_tac hom_ss 1);
-result();
--- a/IOA/example/Correctness.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,22 +0,0 @@
-(* Title: HOL/IOA/example/Correctness.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The main correctness proof: Impl implements Spec
-*)
-
-Correctness = Solve + Impl + Spec +
-
-consts
-
-hom :: "'m impl_state => 'm list"
-
-defs
-
-hom_def
-"hom(s) == rq(rec(s)) @ if(rbit(rec(s)) = sbit(sen(s)),
- sq(sen(s)),
- ttl(sq(sen(s))))"
-
-end
--- a/IOA/example/Impl.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,392 +0,0 @@
-(* Title: HOL/IOA/example/Impl.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The implementation --- Invariants
-*)
-
-val impl_ioas =
- [Impl.impl_def,
- Sender.sender_ioa_def,
- Receiver.receiver_ioa_def,
- Channels.srch_ioa_def,
- Channels.rsch_ioa_def];
-
-val transitions = [Sender.sender_trans_def, Receiver.receiver_trans_def,
- Channels.srch_trans_def, Channels.rsch_trans_def];
-
-
-val impl_ss = merge_ss(action_ss,list_ss)
- addcongs [let_weak_cong]
- addsimps [Let_def, ioa_triple_proj, starts_of_par, trans_of_par4,
- in_sender_asig, in_receiver_asig, in_srch_asig,
- in_rsch_asig, count_addm_simp, count_delm_simp,
- Multiset.countm_empty_def, Multiset.delm_empty_def,
- (* Multiset.count_def, *) count_empty,
- Packet.hdr_def, Packet.msg_def];
-
-goal Impl.thy
- "fst(x) = sen(x) & \
-\ fst(snd(x)) = rec(x) & \
-\ fst(snd(snd(x))) = srch(x) & \
-\ snd(snd(snd(x))) = rsch(x)";
-by(simp_tac (HOL_ss addsimps
- [Impl.sen_def,Impl.rec_def,Impl.srch_def,Impl.rsch_def]) 1);
-val impl_ss = impl_ss addsimps [result()];
-
-goal Impl.thy "a:actions(sender_asig) \
-\ | a:actions(receiver_asig) \
-\ | a:actions(srch_asig) \
-\ | a:actions(rsch_asig)";
- by(Action.action.induct_tac "a" 1);
- by(ALLGOALS(simp_tac impl_ss));
-val impl_ss = impl_ss addsimps [result()];
-
-
-(* Instantiation of a tautology? *)
-goal Packet.thy "!x. x = packet --> hdr(x) = hdr(packet)";
- by (simp_tac (HOL_ss addsimps [Packet.hdr_def]) 1);
-qed "eq_packet_imp_eq_hdr";
-
-
-(* INVARIANT 1 *)
-val ss = impl_ss addcongs [if_weak_cong] addsimps transitions;
-
-goalw Impl.thy impl_ioas "invariant(impl_ioa,inv1)";
-br invariantI 1;
-by(asm_full_simp_tac (impl_ss addsimps
- [Impl.inv1_def, Impl.hdr_sum_def,
- Sender.srcvd_def, Sender.ssent_def,
- Receiver.rsent_def,Receiver.rrcvd_def]) 1);
-
-by(simp_tac (HOL_ss addsimps [fork_lemma,Impl.inv1_def]) 1);
-
-(* Split proof in two *)
-by (rtac conjI 1);
-
-(* First half *)
-by(asm_full_simp_tac (impl_ss addsimps [Impl.inv1_def]) 1);
-br Action.action.induct 1;
-
-val tac = asm_simp_tac (ss addcongs [conj_cong]
- addsimps [Suc_pred_lemma]
- setloop (split_tac [expand_if]));
-
-by(EVERY1[tac, tac, tac, tac, tac, tac, tac, tac, tac, tac]);
-
-(* Now the other half *)
-by(asm_full_simp_tac (impl_ss addsimps [Impl.inv1_def]) 1);
-br Action.action.induct 1;
-by(EVERY1[tac, tac]);
-
-(* detour 1 *)
-by (tac 1);
-by (rtac impI 1);
-by (REPEAT (etac conjE 1));
-by (asm_simp_tac (impl_ss addsimps [Impl.hdr_sum_def, Multiset.count_def,
- Multiset.countm_nonempty_def]
- setloop (split_tac [expand_if])) 1);
-(* detour 2 *)
-by (tac 1);
-by (rtac impI 1);
-by (REPEAT (etac conjE 1));
-by (asm_full_simp_tac (impl_ss addsimps
- [Impl.hdr_sum_def,
- Multiset.count_def,
- Multiset.countm_nonempty_def,
- Multiset.delm_nonempty_def,
- left_plus_cancel,left_plus_cancel_inside_succ,
- unzero_less]
- setloop (split_tac [expand_if])) 1);
-by (rtac allI 1);
-by (rtac conjI 1);
-by (rtac impI 1);
-by (hyp_subst_tac 1);
-
-by (rtac (pred_suc RS mp RS sym RS iffD2) 1);
-by (dtac less_le_trans 1);
-by (cut_facts_tac [rewrite_rule[Packet.hdr_def]
- eq_packet_imp_eq_hdr RS countm_props] 1);;
-by (assume_tac 1);
-by (assume_tac 1);
-
-by (rtac (countm_done_delm RS mp RS sym) 1);
-by (rtac refl 1);
-by (asm_simp_tac (HOL_ss addsimps [Multiset.count_def]) 1);
-
-by (rtac impI 1);
-by (asm_full_simp_tac (HOL_ss addsimps [neg_flip]) 1);
-by (hyp_subst_tac 1);
-by (rtac countm_spurious_delm 1);
-by (simp_tac HOL_ss 1);
-
-by (EVERY1[tac, tac, tac, tac, tac, tac]);
-
-qed "inv1";
-
-
-
-(* INVARIANT 2 *)
-
- goal Impl.thy "invariant(impl_ioa, inv2)";
-
- by (rtac invariantI1 1);
- (* Base case *)
- by (asm_full_simp_tac (impl_ss addsimps
- (Impl.inv2_def :: (receiver_projections
- @ sender_projections @ impl_ioas))) 1);
-
- by (asm_simp_tac (impl_ss addsimps impl_ioas) 1);
- by (Action.action.induct_tac "a" 1);
-
- (* 10 cases. First 4 are simple, since state doesn't change wrt. invariant *)
- (* 10 *)
- by (asm_simp_tac (impl_ss addsimps (Impl.inv2_def::transitions)) 1);
- (* 9 *)
- by (asm_simp_tac (impl_ss addsimps (Impl.inv2_def::transitions)) 1);
- (* 8 *)
- by (asm_simp_tac (impl_ss addsimps (Impl.inv2_def::transitions)) 2);
- (* 7 *)
- by (asm_simp_tac (impl_ss addsimps (Impl.inv2_def::transitions)) 3);
- (* 6 *)
- by(forward_tac [rewrite_rule [Impl.inv1_def]
- (inv1 RS invariantE) RS conjunct1] 1);
- by (asm_full_simp_tac (impl_ss addsimps [leq_imp_leq_suc,Impl.inv2_def]
- addsimps transitions) 1);
- (* 5 *)
- by (asm_full_simp_tac (impl_ss addsimps [leq_imp_leq_suc,Impl.inv2_def]
- addsimps transitions) 1);
- (* 4 *)
- by (forward_tac [rewrite_rule [Impl.inv1_def]
- (inv1 RS invariantE) RS conjunct1] 1);
- by (asm_full_simp_tac (impl_ss addsimps [Impl.inv2_def]
- addsimps transitions) 1);
- by (fast_tac (HOL_cs addDs [add_leD1,leD]) 1);
-
- (* 3 *)
- by (forward_tac [rewrite_rule [Impl.inv1_def] (inv1 RS invariantE)] 1);
-
- by (asm_full_simp_tac (impl_ss addsimps
- (Impl.inv2_def::transitions)) 1);
- by (fold_tac [rewrite_rule [Packet.hdr_def]Impl.hdr_sum_def]);
- by (fast_tac (HOL_cs addDs [add_leD1,leD]) 1);
-
- (* 2 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (Impl.inv2_def::transitions)) 1);
- by(forward_tac [rewrite_rule [Impl.inv1_def]
- (inv1 RS invariantE) RS conjunct1] 1);
- by (rtac impI 1);
- by (rtac impI 1);
- by (REPEAT (etac conjE 1));
- by (dres_inst_tac [("k","count(rsch(s), ~ sbit(sen(s)))")]
- (standard(leq_add_leq RS mp)) 1);
- by (asm_full_simp_tac HOL_ss 1);
-
- (* 1 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (Impl.inv2_def::transitions)) 1);
- by(forward_tac [rewrite_rule [Impl.inv1_def]
- (inv1 RS invariantE) RS conjunct2] 1);
- by (rtac impI 1);
- by (rtac impI 1);
- by (REPEAT (etac conjE 1));
- by (fold_tac [rewrite_rule[Packet.hdr_def]Impl.hdr_sum_def]);
- by (dres_inst_tac [("k","hdr_sum(srch(s), sbit(sen(s)))")]
- (standard(leq_add_leq RS mp)) 1);
- by (asm_full_simp_tac HOL_ss 1);
-qed "inv2";
-
-
-(* INVARIANT 3 *)
-goal Impl.thy "invariant(impl_ioa, inv3)";
-
- by (rtac invariantI 1);
- (* Base case *)
- by (asm_full_simp_tac (impl_ss addsimps
- (Impl.inv3_def :: (receiver_projections
- @ sender_projections @ impl_ioas))) 1);
-
- by (asm_simp_tac (impl_ss addsimps impl_ioas) 1);
- by (Action.action.induct_tac "a" 1);
-
- (* 10 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::not_hd_append::Impl.inv3_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 9 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::not_hd_append::Impl.inv3_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 8 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::not_hd_append::Impl.inv3_def::transitions)
- setloop (split_tac [expand_if])) 1);
- by (strip_tac 1 THEN REPEAT (etac conjE 1));
- by (asm_full_simp_tac (HOL_ss addsimps [cons_imp_not_null]) 1);
- by (hyp_subst_tac 1);
- by (etac exE 1);
- by (asm_full_simp_tac list_ss 1);
-
- (* 7 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (Suc_pred_lemma::append_cons::not_hd_append::Impl.inv3_def::transitions)
- setloop (split_tac [expand_if])) 1);
- by (fast_tac HOL_cs 1);
-
- (* 6 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::not_hd_append::Impl.inv3_def::transitions)
- setloop (split_tac [expand_if])) 1);
- (* 5 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::not_hd_append::Impl.inv3_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 4 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::not_hd_append::Impl.inv3_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 3 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::not_hd_append::Impl.inv3_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 2 *)
- by (asm_full_simp_tac (impl_ss addsimps transitions) 1);
- by (simp_tac (HOL_ss addsimps [Impl.inv3_def]) 1);
- by (strip_tac 1 THEN REPEAT (etac conjE 1));
- by (rtac (imp_or_lem RS iffD2) 1);
- by (rtac impI 1);
- by (forward_tac [rewrite_rule [Impl.inv2_def] (inv2 RS invariantE)] 1);
- by (asm_full_simp_tac list_ss 1);
- by (REPEAT (etac conjE 1));
- by (res_inst_tac [("j","count(ssent(sen(s)),~ sbit(sen(s)))"),
- ("k","count(rsent(rec(s)), sbit(sen(s)))")] le_trans 1);
- by (forward_tac [rewrite_rule [Impl.inv1_def]
- (inv1 RS invariantE) RS conjunct2] 1);
- by (asm_full_simp_tac (list_ss addsimps
- [Impl.hdr_sum_def, Multiset.count_def]) 1);
- by (rtac (less_eq_add_cong RS mp RS mp) 1);
- by (rtac countm_props 1);
- by (simp_tac (list_ss addsimps [Packet.hdr_def]) 1);
- by (rtac countm_props 1);
- by (simp_tac (list_ss addsimps [Packet.hdr_def]) 1);
- by (assume_tac 1);
-
-
- (* 1 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::not_hd_append::Impl.inv3_def::transitions)
- setloop (split_tac [expand_if])) 1);
- by (strip_tac 1 THEN REPEAT (etac conjE 1));
- by (rtac (imp_or_lem RS iffD2) 1);
- by (rtac impI 1);
- by (forward_tac [rewrite_rule [Impl.inv2_def] (inv2 RS invariantE)] 1);
- by (asm_full_simp_tac list_ss 1);
- by (REPEAT (etac conjE 1));
- by (dtac mp 1);
- by (assume_tac 1);
- by (etac allE 1);
- by (dtac (imp_or_lem RS iffD1) 1);
- by (dtac mp 1);
- by (assume_tac 1);
- by (assume_tac 1);
-qed "inv3";
-
-
-
-(* INVARIANT 4 *)
-
-goal Impl.thy "invariant(impl_ioa, inv4)";
-
- by (rtac invariantI 1);
- (* Base case *)
- by (asm_full_simp_tac (impl_ss addsimps
- (Impl.inv4_def :: (receiver_projections
- @ sender_projections @ impl_ioas))) 1);
-
- by (asm_simp_tac (impl_ss addsimps impl_ioas) 1);
- by (Action.action.induct_tac "a" 1);
-
- (* 10 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 9 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 8 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
- (* 7 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 6 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 5 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 4 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 3 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- (* 2 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
-
- by (strip_tac 1 THEN REPEAT (etac conjE 1));
- by(forward_tac [rewrite_rule [Impl.inv2_def]
- (inv2 RS invariantE)] 1);
-
- by (asm_full_simp_tac list_ss 1);
-
- (* 1 *)
- by (asm_full_simp_tac (impl_ss addsimps
- (append_cons::Impl.inv4_def::transitions)
- setloop (split_tac [expand_if])) 1);
- by (strip_tac 1 THEN REPEAT (etac conjE 1));
- by (rtac ccontr 1);
- by(forward_tac [rewrite_rule [Impl.inv2_def]
- (inv2 RS invariantE)] 1);
- by(forward_tac [rewrite_rule [Impl.inv3_def]
- (inv3 RS invariantE)] 1);
- by (asm_full_simp_tac list_ss 1);
- by (eres_inst_tac [("x","m")] allE 1);
- by (dtac less_le_trans 1);
- by (dtac (left_add_leq RS mp) 1);
- by (asm_full_simp_tac list_ss 1);
- by (asm_full_simp_tac arith_ss 1);
-qed "inv4";
-
-
-
-(* rebind them *)
-
-val inv1 = rewrite_rule [Impl.inv1_def] (inv1 RS invariantE);
-val inv2 = rewrite_rule [Impl.inv2_def] (inv2 RS invariantE);
-val inv3 = rewrite_rule [Impl.inv3_def] (inv3 RS invariantE);
-val inv4 = rewrite_rule [Impl.inv4_def] (inv4 RS invariantE);
-
--- a/IOA/example/Impl.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,71 +0,0 @@
-(* Title: HOL/IOA/example/Impl.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The implementation
-*)
-
-Impl = Sender + Receiver + Channels +
-
-types
-
-'m impl_state
-= "'m sender_state * 'm receiver_state * 'm packet multiset * bool multiset"
-(* sender_state * receiver_state * srch_state * rsch_state *)
-
-
-consts
- impl_ioa :: "('m action, 'm impl_state)ioa"
- sen :: "'m impl_state => 'm sender_state"
- rec :: "'m impl_state => 'm receiver_state"
- srch :: "'m impl_state => 'm packet multiset"
- rsch :: "'m impl_state => bool multiset"
- inv1, inv2,
- inv3, inv4 :: "'m impl_state => bool"
- hdr_sum :: "'m packet multiset => bool => nat"
-
-defs
-
- impl_def
- "impl_ioa == (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"
-
- sen_def "sen == fst"
- rec_def "rec == fst o snd"
- srch_def "srch == fst o snd o snd"
- rsch_def "rsch == snd o snd o snd"
-
-hdr_sum_def
- "hdr_sum(M,b) == countm(M,%pkt.hdr(pkt) = b)"
-
-(* Lemma 5.1 *)
-inv1_def
- "inv1(s) ==
- (!b. count(rsent(rec(s)),b) = count(srcvd(sen(s)),b) + count(rsch(s),b))
- & (!b. count(ssent(sen(s)),b)
- = hdr_sum(rrcvd(rec(s)),b) + hdr_sum(srch(s),b))"
-
-(* Lemma 5.2 *)
- inv2_def "inv2(s) ==
- (rbit(rec(s)) = sbit(sen(s)) &
- ssending(sen(s)) &
- count(rsent(rec(s)),~sbit(sen(s))) <= count(ssent(sen(s)),~sbit(sen(s))) &
- count(ssent(sen(s)),~sbit(sen(s))) <= count(rsent(rec(s)),sbit(sen(s))))
- |
- (rbit(rec(s)) = (~sbit(sen(s))) &
- rsending(rec(s)) &
- count(ssent(sen(s)),~sbit(sen(s))) <= count(rsent(rec(s)),sbit(sen(s))) &
- count(rsent(rec(s)),sbit(sen(s))) <= count(ssent(sen(s)),sbit(sen(s))))"
-
-(* Lemma 5.3 *)
- inv3_def "inv3(s) ==
- rbit(rec(s)) = sbit(sen(s))
- --> (!m. sq(sen(s))=[] | m ~= hd(sq(sen(s)))
- --> count(rrcvd(rec(s)),<sbit(sen(s)),m>)
- + count(srch(s),<sbit(sen(s)),m>)
- <= count(rsent(rec(s)),~sbit(sen(s))))"
-
-(* Lemma 5.4 *)
- inv4_def "inv4(s) == rbit(rec(s)) = (~sbit(sen(s))) --> sq(sen(s)) ~= []"
-
-end
--- a/IOA/example/Lemmas.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,239 +0,0 @@
-(* Title: HOL/IOA/example/Lemmas.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-(Mostly) Arithmetic lemmas
-Should realy go in Arith.ML.
-Also: Get rid of all the --> in favour of ==> !!!
-*)
-
-(* Logic *)
-val prems = goal HOL.thy "(P ==> Q-->R) ==> P&Q --> R";
- by(fast_tac (HOL_cs addDs prems) 1);
-qed "imp_conj_lemma";
-
-goal HOL.thy "(P --> (? x. Q(x))) = (? x. P --> Q(x))";
- by(fast_tac HOL_cs 1);
-qed "imp_ex_equiv";
-
-goal HOL.thy "(A --> B & C) = ((A --> B) & (A --> C))";
- by (fast_tac HOL_cs 1);
-qed "fork_lemma";
-
-goal HOL.thy "((A --> B) & (C --> B)) = ((A | C) --> B)";
- by (fast_tac HOL_cs 1);
-qed "imp_or_lem";
-
-goal HOL.thy "(X = (~ Y)) = ((~X) = Y)";
- by (fast_tac HOL_cs 1);
-qed "neg_flip";
-
-goal HOL.thy "P --> Q(M) --> Q(if(P,M,N))";
- by (rtac impI 1);
- by (rtac impI 1);
- by (rtac (expand_if RS iffD2) 1);
- by (fast_tac HOL_cs 1);
-qed "imp_true_decompose";
-
-goal HOL.thy "(~P) --> Q(N) --> Q(if(P,M,N))";
- by (rtac impI 1);
- by (rtac impI 1);
- by (rtac (expand_if RS iffD2) 1);
- by (fast_tac HOL_cs 1);
-qed "imp_false_decompose";
-
-
-(* Sets *)
-val set_lemmas =
- map (fn s => prove_goal Set.thy s (fn _ => [fast_tac set_cs 1]))
- ["f(x) : (UN x. {f(x)})",
- "f(x,y) : (UN x y. {f(x,y)})",
- "!!a. (!x. a ~= f(x)) ==> a ~: (UN x. {f(x)})",
- "!!a. (!x y. a ~= f(x,y)) ==> a ~: (UN x y. {f(x,y)})"];
-
-
-(* Arithmetic *)
-goal Arith.thy "n ~= 0 --> Suc(m+pred(n)) = m+n";
- by (nat_ind_tac "n" 1);
- by (REPEAT(simp_tac arith_ss 1));
-val Suc_pred_lemma = store_thm("Suc_pred_lemma", result() RS mp);
-
-goal Arith.thy "x <= y --> x <= Suc(y)";
- by (rtac impI 1);
- by (rtac (le_eq_less_or_eq RS iffD2) 1);
- by (rtac disjI1 1);
- by (dtac (le_eq_less_or_eq RS iffD1) 1);
- by (etac disjE 1);
- by (etac less_SucI 1);
- by (asm_simp_tac nat_ss 1);
-val leq_imp_leq_suc = store_thm("leq_imp_leq_suc", result() RS mp);
-
-(* Same as previous! *)
-goal Arith.thy "(x::nat)<=y --> x<=Suc(y)";
- by (simp_tac (arith_ss addsimps [le_eq_less_or_eq]) 1);
-qed "leq_suc";
-
-goal Arith.thy "((m::nat) + n = m + p) = (n = p)";
- by (nat_ind_tac "m" 1);
- by (simp_tac arith_ss 1);
- by (asm_simp_tac arith_ss 1);
-qed "left_plus_cancel";
-
-goal Arith.thy "((x::nat) + y = Suc(x + z)) = (y = Suc(z))";
- by (nat_ind_tac "x" 1);
- by (simp_tac arith_ss 1);
- by (asm_simp_tac arith_ss 1);
-qed "left_plus_cancel_inside_succ";
-
-goal Arith.thy "(x ~= 0) = (? y. x = Suc(y))";
- by (nat_ind_tac "x" 1);
- by (simp_tac arith_ss 1);
- by (asm_simp_tac arith_ss 1);
- by (fast_tac HOL_cs 1);
-qed "nonzero_is_succ";
-
-goal Arith.thy "(m::nat) < n --> m + p < n + p";
- by (nat_ind_tac "p" 1);
- by (simp_tac arith_ss 1);
- by (asm_simp_tac arith_ss 1);
-qed "less_add_same_less";
-
-goal Arith.thy "(x::nat)<= y --> x<=y+k";
- by (nat_ind_tac "k" 1);
- by (simp_tac arith_ss 1);
- by (asm_full_simp_tac (arith_ss addsimps [leq_suc]) 1);
-qed "leq_add_leq";
-
-goal Arith.thy "(x::nat) + y <= z --> x <= z";
- by (nat_ind_tac "y" 1);
- by (simp_tac arith_ss 1);
- by (asm_simp_tac arith_ss 1);
- by (rtac impI 1);
- by (dtac Suc_leD 1);
- by (fast_tac HOL_cs 1);
-qed "left_add_leq";
-
-goal Arith.thy "(A::nat) < B --> C < D --> A + C < B + D";
- by (rtac impI 1);
- by (rtac impI 1);
- by (rtac less_trans 1);
- by (rtac (less_add_same_less RS mp) 1);
- by (assume_tac 1);
- by (rtac (add_commute RS ssubst)1);;
- by (res_inst_tac [("m1","B")] (add_commute RS ssubst) 1);
- by (rtac (less_add_same_less RS mp) 1);
- by (assume_tac 1);
-qed "less_add_cong";
-
-goal Arith.thy "(A::nat) <= B --> C <= D --> A + C <= B + D";
- by (rtac impI 1);
- by (rtac impI 1);
- by (asm_full_simp_tac (arith_ss addsimps [le_eq_less_or_eq]) 1);
- by (safe_tac HOL_cs);
- by (rtac (less_add_cong RS mp RS mp) 1);
- by (assume_tac 1);
- by (assume_tac 1);
- by (rtac (less_add_same_less RS mp) 1);
- by (assume_tac 1);
- by (rtac (add_commute RS ssubst)1);;
- by (res_inst_tac [("m1","B")] (add_commute RS ssubst) 1);
- by (rtac (less_add_same_less RS mp) 1);
- by (assume_tac 1);
-qed "less_eq_add_cong";
-
-goal Arith.thy "(w <= y) --> ((x::nat) + y <= z) --> (x + w <= z)";
- by (rtac impI 1);
- by (dtac (less_eq_add_cong RS mp) 1);
- by (cut_facts_tac [le_refl] 1);
- by (dres_inst_tac [("P","x<=x")] mp 1);by (assume_tac 1);
- by (asm_full_simp_tac (HOL_ss addsimps [add_commute]) 1);
- by (rtac impI 1);
- by (etac le_trans 1);
- by (assume_tac 1);
-qed "leq_add_left_cong";
-
-goal Arith.thy "(? x. y = Suc(x)) = (~(y = 0))";
- by (nat_ind_tac "y" 1);
- by (simp_tac arith_ss 1);
- by (rtac iffI 1);
- by (asm_full_simp_tac arith_ss 1);
- by (fast_tac HOL_cs 1);
-qed "suc_not_zero";
-
-goal Arith.thy "Suc(x) <= y --> (? z. y = Suc(z))";
- by (rtac impI 1);
- by (asm_full_simp_tac (arith_ss addsimps [le_eq_less_or_eq]) 1);
- by (safe_tac HOL_cs);
- by (fast_tac HOL_cs 2);
- by (asm_simp_tac (arith_ss addsimps [suc_not_zero]) 1);
- by (rtac ccontr 1);
- by (asm_full_simp_tac (arith_ss addsimps [suc_not_zero]) 1);
- by (hyp_subst_tac 1);
- by (asm_full_simp_tac arith_ss 1);
-qed "suc_leq_suc";
-
-goal Arith.thy "~0<n --> n = 0";
- by (nat_ind_tac "n" 1);
- by (asm_simp_tac arith_ss 1);
- by (safe_tac HOL_cs);
- by (asm_full_simp_tac arith_ss 1);
- by (asm_full_simp_tac arith_ss 1);
-qed "zero_eq";
-
-goal Arith.thy "x < Suc(y) --> x<=y";
- by (nat_ind_tac "n" 1);
- by (asm_simp_tac arith_ss 1);
- by (safe_tac HOL_cs);
- by (etac less_imp_le 1);
-qed "less_suc_imp_leq";
-
-goal Arith.thy "0<x --> Suc(pred(x)) = x";
- by (nat_ind_tac "x" 1);
- by (simp_tac arith_ss 1);
- by (asm_simp_tac arith_ss 1);
-qed "suc_pred_id";
-
-goal Arith.thy "0<x --> (pred(x) = y) = (x = Suc(y))";
- by (nat_ind_tac "x" 1);
- by (simp_tac arith_ss 1);
- by (asm_simp_tac arith_ss 1);
-qed "pred_suc";
-
-goal Arith.thy "(x ~= 0) = (0<x)";
- by (nat_ind_tac "x" 1);
- by (simp_tac arith_ss 1);
- by (asm_simp_tac arith_ss 1);
-qed "unzero_less";
-
-(* Odd proof. Why do induction? *)
-goal Arith.thy "((x::nat) = y + z) --> (y <= x)";
- by (nat_ind_tac "y" 1);
- by (simp_tac arith_ss 1);
- by (simp_tac (arith_ss addsimps
- [Suc_le_mono, le_refl RS (leq_add_leq RS mp)]) 1);
-qed "plus_leq_lem";
-
-(* Lists *)
-
-goal List.thy "(xs @ (y#ys)) ~= []";
- by (list.induct_tac "xs" 1);
- by (simp_tac list_ss 1);
- by (asm_simp_tac list_ss 1);
-qed "append_cons";
-
-goal List.thy "(x ~= hd(xs@ys)) = (x ~= if(xs = [], hd(ys), hd(xs)))";
- by (list.induct_tac "xs" 1);
- by (simp_tac list_ss 1);
- by (asm_full_simp_tac list_ss 1);
-qed "not_hd_append";
-
-goal List.thy "(L = (x#rst)) --> (L = []) --> P";
- by (simp_tac list_ss 1);
-qed "list_cases";
-
-goal List.thy "(? L2. L1 = x#L2) --> (L1 ~= [])";
- by (strip_tac 1);
- by (etac exE 1);
- by (asm_simp_tac list_ss 1);
-qed "cons_imp_not_null";
--- a/IOA/example/Lemmas.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-(* Title: HOL/IOA/example/Lemmas.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Arithmetic lemmas
-*)
-
-Lemmas = Arith
--- a/IOA/example/Multiset.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,84 +0,0 @@
-(* Title: HOL/IOA/example/Multiset.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Axiomatic multisets.
-Should be done as a subtype and moved to a global place.
-*)
-
-goalw Multiset.thy [Multiset.count_def, Multiset.countm_empty_def]
- "count({|},x) = 0";
- by (rtac refl 1);
-qed "count_empty";
-
-goal Multiset.thy
- "count(addm(M,x),y) = if(y=x,Suc(count(M,y)),count(M,y))";
- by (asm_simp_tac (arith_ss addsimps
- [Multiset.count_def,Multiset.countm_nonempty_def]
- setloop (split_tac [expand_if])) 1);
-qed "count_addm_simp";
-
-goal Multiset.thy "count(M,y) <= count(addm(M,x),y)";
- by (simp_tac (arith_ss addsimps [count_addm_simp]
- setloop (split_tac [expand_if])) 1);
- by (rtac impI 1);
- by (rtac (le_refl RS (leq_suc RS mp)) 1);
-qed "count_leq_addm";
-
-goalw Multiset.thy [Multiset.count_def]
- "count(delm(M,x),y) = if(y=x,pred(count(M,y)),count(M,y))";
- by (res_inst_tac [("M","M")] Multiset.induction 1);
- by (asm_simp_tac (arith_ss
- addsimps [Multiset.delm_empty_def,Multiset.countm_empty_def]
- setloop (split_tac [expand_if])) 1);
- by (asm_full_simp_tac (arith_ss
- addsimps [Multiset.delm_nonempty_def,
- Multiset.countm_nonempty_def]
- setloop (split_tac [expand_if])) 1);
- by (safe_tac HOL_cs);
- by (asm_full_simp_tac HOL_ss 1);
-qed "count_delm_simp";
-
-goal Multiset.thy "!!M. (!x. P(x) --> Q(x)) ==> (countm(M,P) <= countm(M,Q))";
- by (res_inst_tac [("M","M")] Multiset.induction 1);
- by (simp_tac (arith_ss addsimps [Multiset.countm_empty_def]) 1);
- by (simp_tac (arith_ss addsimps[Multiset.countm_nonempty_def]) 1);
- by (etac (less_eq_add_cong RS mp RS mp) 1);
- by (asm_full_simp_tac (arith_ss addsimps [le_eq_less_or_eq]
- setloop (split_tac [expand_if])) 1);
-qed "countm_props";
-
-goal Multiset.thy "!!P. ~P(obj) ==> countm(M,P) = countm(delm(M,obj),P)";
- by (res_inst_tac [("M","M")] Multiset.induction 1);
- by (simp_tac (arith_ss addsimps [Multiset.delm_empty_def,
- Multiset.countm_empty_def]) 1);
- by (asm_simp_tac (arith_ss addsimps[Multiset.countm_nonempty_def,
- Multiset.delm_nonempty_def]
- setloop (split_tac [expand_if])) 1);
-qed "countm_spurious_delm";
-
-
-goal Multiset.thy "!!P. P(x) ==> 0<count(M,x) --> 0<countm(M,P)";
- by (res_inst_tac [("M","M")] Multiset.induction 1);
- by (simp_tac (arith_ss addsimps
- [Multiset.delm_empty_def,Multiset.count_def,
- Multiset.countm_empty_def]) 1);
- by (asm_simp_tac (arith_ss addsimps
- [Multiset.count_def,Multiset.delm_nonempty_def,
- Multiset.countm_nonempty_def]
- setloop (split_tac [expand_if])) 1);
-val pos_count_imp_pos_countm = store_thm("pos_count_imp_pos_countm", standard(result() RS mp));
-
-goal Multiset.thy
- "!!P. P(x) ==> 0<count(M,x) --> countm(delm(M,x),P) = pred(countm(M,P))";
- by (res_inst_tac [("M","M")] Multiset.induction 1);
- by (simp_tac (arith_ss addsimps
- [Multiset.delm_empty_def,
- Multiset.countm_empty_def]) 1);
- by (asm_simp_tac (arith_ss addsimps
- [eq_sym_conv,count_addm_simp,Multiset.delm_nonempty_def,
- Multiset.countm_nonempty_def,pos_count_imp_pos_countm,
- suc_pred_id]
- setloop (split_tac [expand_if])) 1);
-qed "countm_done_delm";
--- a/IOA/example/Multiset.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,48 +0,0 @@
-(* Title: HOL/IOA/example/Multiset.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Axiomatic multisets.
-Should be done as a subtype and moved to a global place.
-*)
-
-Multiset = Arith + "Lemmas" +
-
-types
-
- 'a multiset
-
-arities
-
- multiset :: (term) term
-
-consts
-
- "{|}" :: "'a multiset" ("{|}")
- addm :: "['a multiset, 'a] => 'a multiset"
- delm :: "['a multiset, 'a] => 'a multiset"
- countm :: "['a multiset, 'a => bool] => nat"
- count :: "['a multiset, 'a] => nat"
-
-rules
-
-delm_empty_def
- "delm({|},x) = {|}"
-
-delm_nonempty_def
- "delm(addm(M,x),y) == if(x=y,M,addm(delm(M,y),x))"
-
-countm_empty_def
- "countm({|},P) == 0"
-
-countm_nonempty_def
- "countm(addm(M,x),P) == countm(M,P) + if(P(x), Suc(0), 0)"
-
-count_def
- "count(M,x) == countm(M, %y.y = x)"
-
-induction
- "[| P({|}); !!M x. P(M) ==> P(addm(M,x)) |] ==> P(M)"
-
-end
--- a/IOA/example/Packet.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,25 +0,0 @@
-(* Title: HOL/IOA/example/Packet.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Packets
-*)
-
-Packet = Arith +
-
-types
-
- 'msg packet = "bool * 'msg"
-
-consts
-
- hdr :: "'msg packet => bool"
- msg :: "'msg packet => 'msg"
-
-defs
-
- hdr_def "hdr == fst"
- msg_def "msg == snd"
-
-end
--- a/IOA/example/Read_me Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,177 +0,0 @@
-Isabelle Verification of a protocol using IOA.
-
-------------------------------------------------------------------------------
-The theory structure looks like this picture:
-
- Correctness
-
- Impl
-
-Sender Receiver Channels Spec
-
- Action IOA Multisets
-
- Packet List
-
- Arith
-
-------------------------------------------------------------------------------
-
-The System.
-
-The system being proved correct is a parallel composition of 4 processes:
-
- Sender || Schannel || Receiver || Rchannel
-
-Accordingly, the system state is a 4-tuple:
-
- (Sender_state, Schannel_state, Receiver_state, Rchannel_state)
-
-------------------------------------------------------------------------------
-Packets.
-
-The objects going over the medium from Sender to Receiver are modelled
-with the type
-
- 'm packet = bool * 'm
-
-This expresses that messages (modelled by polymorphic type "'m") are
-sent with a single header bit. Packet fields are accessed by
-
- hdr<b,m> = b
- mesg<b,m> = m
-------------------------------------------------------------------------------
-
-The Sender.
-
-The state of the process "Sender" is a 5-tuple:
-
- 1. messages : 'm list (* sq *)
- 2. sent : bool multiset (* ssent *)
- 3. received : bool multiset (* srcvd *)
- 4. header : bool (* sbit *)
- 5. mode : bool (* ssending *)
-
-
-The Receiver.
-
-The state of the process "Receiver" is a 5-tuple:
-
- 1. messages : 'm list (* rq *)
- 2. replies : bool multiset (* rsent *)
- 3. received : 'm packet multiset (* rrcvd *)
- 4. header : bool (* rbit *)
- 5. mode : bool (* rsending *)
-
-
-The Channels.
-
-The Sender and Receiver each have a proprietary channel, named
-"Schannel" and "Rchannel" respectively. The messages sent by the Sender
-and Receiver are never lost, but the channels may mix them
-up. Accordingly, multisets are used in modelling the state of the
-channels. The state of "Schannel" is modelled with the following type:
-
- 'm packet multiset
-
-The state of "Rchannel" is modelled with the following type:
-
- bool multiset
-
-This expresses that replies from the Receiver are just one bit.
-
-------------------------------------------------------------------------------
-
-The events.
-
-An `execution' of the system is modelled by a sequence of
-
- <system_state, action, system_state>
-
-transitions. The actions, or events, of the system are described by the
-following ML-style datatype declaration:
-
- 'm action = S_msg ('m) (* Rqt for Sender to send mesg *)
- | R_msg ('m) (* Mesg taken from Receiver's queue *)
- | S_pkt_sr ('m packet) (* Packet arrives in Schannel *)
- | R_pkt_sr ('m packet) (* Packet leaves Schannel *)
- | S_pkt_rs (bool) (* Packet arrives in Rchannel *)
- | R_pkt_rs (bool) (* Packet leaves Rchannel *)
- | C_m_s (* Change mode in Sender *)
- | C_m_r (* Change mode in Receiver *)
- | C_r_s (* Change round in Sender *)
- | C_r_r ('m) (* Change round in Receiver *)
-
-------------------------------------------------------------------------------
-
-The Specification.
-
-The abstract description of system behaviour is given by defining an
-IO/automaton named "Spec". The state of Spec is a message queue,
-modelled as an "'m list". The only actions performed in the abstract
-system are: "S_msg(m)" (putting message "m" at the end of the queue);
-and "R_msg(m)" (taking message "m" from the head of the queue).
-
-
-------------------------------------------------------------------------------
-
-The Verification.
-
-The verification proceeds by showing that a certain mapping ("hom") from
-the concrete system state to the abstract system state is a `weak
-possibilities map` from "Impl" to "Spec".
-
-
- hom : (S_state * Sch_state * R_state * Rch_state) -> queue
-
-The verification depends on several system invariants that relate the
-states of the 4 processes. These invariants must hold in all reachable
-states of the system. These invariants are difficult to make sense of;
-however, we attempt to give loose English paraphrases of them.
-
-Invariant 1.
-
-This expresses that no packets from the Receiver to the Sender are
-dropped by Rchannel. The analogous statement for Schannel is also true.
-
- !b. R.replies b = S.received b + Rch b
- /\
- !pkt. S.sent(hdr(pkt)) = R.received(hdr(b)) + Sch(pkt)
-
-
-Invariant 2.
-
-This expresses a complicated relationship about how many messages are
-sent and header bits.
-
- R.header = S.header
- /\ S.mode = SENDING
- /\ R.replies (flip S.header) <= S.sent (flip S.header)
- /\ S.sent (flip S.header) <= R.replies header
- OR
- R.header = flip S.header
- /\ R.mode = SENDING
- /\ S.sent (flip S.header) <= R.replies S.header
- /\ R.replies S.header <= S.sent S.header
-
-
-Invariant 3.
-
-The number of incoming messages in the Receiver plus the number of those
-messages in transit (in Schannel) is not greater than the number of
-replies, provided the message isn't current and the header bits agree.
-
- let mesg = <S.header, m>
- in
- R.header = S.header
- ==>
- !m. (S.messages = [] \/ m ~= hd S.messages)
- ==> R.received mesg + Sch mesg <= R.replies (flip S.header)
-
-
-Invariant 4.
-
-If the headers are opposite, then the Sender queue has a message in it.
-
- R.header = flip S.header ==> S.messages ~= []
-
--- a/IOA/example/Receiver.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,30 +0,0 @@
-(* Title: HOL/IOA/example/Receiver.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-*)
-
-goal Receiver.thy
- "S_msg(m) ~: actions(receiver_asig) & \
-\ R_msg(m) : actions(receiver_asig) & \
-\ S_pkt(pkt) ~: actions(receiver_asig) & \
-\ R_pkt(pkt) : actions(receiver_asig) & \
-\ S_ack(b) : actions(receiver_asig) & \
-\ R_ack(b) ~: actions(receiver_asig) & \
-\ C_m_s ~: actions(receiver_asig) & \
-\ C_m_r : actions(receiver_asig) & \
-\ C_r_s ~: actions(receiver_asig) & \
-\ C_r_r(m) : actions(receiver_asig)";
- by(simp_tac (action_ss addsimps
- (Receiver.receiver_asig_def :: actions_def ::
- asig_projections @ set_lemmas)) 1);
-qed "in_receiver_asig";
-
-val receiver_projections =
- [Receiver.rq_def,
- Receiver.rsent_def,
- Receiver.rrcvd_def,
- Receiver.rbit_def,
- Receiver.rsending_def];
-
-
--- a/IOA/example/Receiver.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,89 +0,0 @@
-(* Title: HOL/IOA/example/Receiver.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The implementation: receiver
-*)
-
-Receiver = List + IOA + Action + Multiset +
-
-types
-
-'m receiver_state
-= "'m list * bool multiset * 'm packet multiset * bool * bool"
-(* messages #replies #received header mode *)
-
-consts
-
- receiver_asig :: "'m action signature"
- receiver_trans:: "('m action, 'm receiver_state)transition set"
- receiver_ioa :: "('m action, 'm receiver_state)ioa"
- rq :: "'m receiver_state => 'm list"
- rsent :: "'m receiver_state => bool multiset"
- rrcvd :: "'m receiver_state => 'm packet multiset"
- rbit :: "'m receiver_state => bool"
- rsending :: "'m receiver_state => bool"
-
-defs
-
-rq_def "rq == fst"
-rsent_def "rsent == fst o snd"
-rrcvd_def "rrcvd == fst o snd o snd"
-rbit_def "rbit == fst o snd o snd o snd"
-rsending_def "rsending == snd o snd o snd o snd"
-
-receiver_asig_def "receiver_asig ==
- <UN pkt. {R_pkt(pkt)},
- (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
- insert(C_m_r, UN m. {C_r_r(m)})>"
-
-receiver_trans_def "receiver_trans ==
- {tr. let s = fst(tr);
- t = snd(snd(tr))
- in
- case fst(snd(tr))
- of
- S_msg(m) => False |
- R_msg(m) => rq(s) = (m # rq(t)) &
- rsent(t)=rsent(s) &
- rrcvd(t)=rrcvd(s) &
- rbit(t)=rbit(s) &
- rsending(t)=rsending(s) |
- S_pkt(pkt) => False |
- R_pkt(pkt) => rq(t) = rq(s) &
- rsent(t) = rsent(s) &
- rrcvd(t) = addm(rrcvd(s),pkt) &
- rbit(t) = rbit(s) &
- rsending(t) = rsending(s) |
- S_ack(b) => b = rbit(s) &
- rq(t) = rq(s) &
- rsent(t) = addm(rsent(s),rbit(s)) &
- rrcvd(t) = rrcvd(s) &
- rbit(t)=rbit(s) &
- rsending(s) &
- rsending(t) |
- R_ack(b) => False |
- C_m_s => False |
- C_m_r => count(rsent(s),~rbit(s)) < countm(rrcvd(s),%y.hdr(y)=rbit(s)) &
- rq(t) = rq(s) &
- rsent(t)=rsent(s) &
- rrcvd(t)=rrcvd(s) &
- rbit(t)=rbit(s) &
- rsending(s) &
- ~rsending(t) |
- C_r_s => False |
- C_r_r(m) => count(rsent(s),rbit(s)) <= countm(rrcvd(s),%y.hdr(y)=rbit(s)) &
- count(rsent(s),~rbit(s)) < count(rrcvd(s),<rbit(s),m>) &
- rq(t) = rq(s)@[m] &
- rsent(t)=rsent(s) &
- rrcvd(t)=rrcvd(s) &
- rbit(t) = (~rbit(s)) &
- ~rsending(s) &
- rsending(t)}"
-
-
-receiver_ioa_def "receiver_ioa ==
- <receiver_asig, {<[],{|},{|},False,False>}, receiver_trans>"
-
-end
--- a/IOA/example/Sender.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,25 +0,0 @@
-(* Title: HOL/IOA/example/Sender.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-*)
-
-goal Sender.thy
- "S_msg(m) : actions(sender_asig) & \
-\ R_msg(m) ~: actions(sender_asig) & \
-\ S_pkt(pkt) : actions(sender_asig) & \
-\ R_pkt(pkt) ~: actions(sender_asig) & \
-\ S_ack(b) ~: actions(sender_asig) & \
-\ R_ack(b) : actions(sender_asig) & \
-\ C_m_s : actions(sender_asig) & \
-\ C_m_r ~: actions(sender_asig) & \
-\ C_r_s : actions(sender_asig) & \
-\ C_r_r(m) ~: actions(sender_asig)";
-by(simp_tac (action_ss addsimps
- (Sender.sender_asig_def :: actions_def ::
- asig_projections @ set_lemmas)) 1);
-qed "in_sender_asig";
-
-val sender_projections =
- [Sender.sq_def,Sender.ssent_def,Sender.srcvd_def,
- Sender.sbit_def,Sender.ssending_def];
--- a/IOA/example/Sender.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,85 +0,0 @@
-(* Title: HOL/IOA/example/Sender.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The implementation: sender
-*)
-
-Sender = IOA + Action + Multiset + List +
-
-types
-
-'m sender_state = "'m list * bool multiset * bool multiset * bool * bool"
-(* messages #sent #received header mode *)
-
-consts
-
-sender_asig :: "'m action signature"
-sender_trans :: "('m action, 'm sender_state)transition set"
-sender_ioa :: "('m action, 'm sender_state)ioa"
-sq :: "'m sender_state => 'm list"
-ssent,srcvd :: "'m sender_state => bool multiset"
-sbit :: "'m sender_state => bool"
-ssending :: "'m sender_state => bool"
-
-defs
-
-sq_def "sq == fst"
-ssent_def "ssent == fst o snd"
-srcvd_def "srcvd == fst o snd o snd"
-sbit_def "sbit == fst o snd o snd o snd"
-ssending_def "ssending == snd o snd o snd o snd"
-
-sender_asig_def
- "sender_asig == <(UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
- UN pkt. {S_pkt(pkt)},
- {C_m_s,C_r_s}>"
-
-sender_trans_def "sender_trans ==
- {tr. let s = fst(tr);
- t = snd(snd(tr))
- in case fst(snd(tr))
- of
- S_msg(m) => sq(t)=sq(s)@[m] &
- ssent(t)=ssent(s) &
- srcvd(t)=srcvd(s) &
- sbit(t)=sbit(s) &
- ssending(t)=ssending(s) |
- R_msg(m) => False |
- S_pkt(pkt) => hdr(pkt) = sbit(s) &
- (? Q. sq(s) = (msg(pkt)#Q)) &
- sq(t) = sq(s) &
- ssent(t) = addm(ssent(s),sbit(s)) &
- srcvd(t) = srcvd(s) &
- sbit(t) = sbit(s) &
- ssending(s) &
- ssending(t) |
- R_pkt(pkt) => False |
- S_ack(b) => False |
- R_ack(b) => sq(t)=sq(s) &
- ssent(t)=ssent(s) &
- srcvd(t) = addm(srcvd(s),b) &
- sbit(t)=sbit(s) &
- ssending(t)=ssending(s) |
- C_m_s => count(ssent(s),~sbit(s)) < count(srcvd(s),~sbit(s)) &
- sq(t)=sq(s) &
- ssent(t)=ssent(s) &
- srcvd(t)=srcvd(s) &
- sbit(t)=sbit(s) &
- ssending(s) &
- ~ssending(t) |
- C_m_r => False |
- C_r_s => count(ssent(s),sbit(s)) <= count(srcvd(s),~sbit(s)) &
- sq(t)=tl(sq(s)) &
- ssent(t)=ssent(s) &
- srcvd(t)=srcvd(s) &
- sbit(t) = (~sbit(s)) &
- ~ssending(s) &
- ssending(t) |
- C_r_r(m) => False}"
-
-sender_ioa_def "sender_ioa ==
- <sender_asig, {<[],{|},{|},False,True>}, sender_trans>"
-
-end
--- a/IOA/example/Spec.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,42 +0,0 @@
-(* Title: HOL/IOA/example/Spec.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The specification of reliable transmission
-*)
-
-Spec = List + IOA + Action +
-
-consts
-
-spec_sig :: "'m action signature"
-spec_trans :: "('m action, 'm list)transition set"
-spec_ioa :: "('m action, 'm list)ioa"
-
-defs
-
-sig_def "spec_sig == <UN m.{S_msg(m)},
- UN m.{R_msg(m)},
- {}>"
-
-trans_def "spec_trans ==
- {tr. let s = fst(tr);
- t = snd(snd(tr))
- in
- case fst(snd(tr))
- of
- S_msg(m) => t = s@[m] |
- R_msg(m) => s = (m#t) |
- S_pkt(pkt) => False |
- R_pkt(pkt) => False |
- S_ack(b) => False |
- R_ack(b) => False |
- C_m_s => False |
- C_m_r => False |
- C_r_s => False |
- C_r_r(m) => False}"
-
-ioa_def "spec_ioa == <spec_sig, {[]}, spec_trans>"
-
-end
--- a/IOA/meta_theory/Asig.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,11 +0,0 @@
-(* Title: HOL/IOA/meta_theory/Asig.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Action signatures
-*)
-
-open Asig;
-
-val asig_projections = [asig_inputs_def, asig_outputs_def, asig_internals_def];
--- a/IOA/meta_theory/Asig.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,45 +0,0 @@
-(* Title: HOL/IOA/meta_theory/Asig.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Action signatures
-*)
-
-Asig = Option +
-
-types
-
-'a signature = "('a set * 'a set * 'a set)"
-
-consts
- actions,inputs,outputs,internals,externals
- ::"'action signature => 'action set"
- is_asig ::"'action signature => bool"
- mk_ext_asig ::"'action signature => 'action signature"
-
-
-defs
-
-asig_inputs_def "inputs == fst"
-asig_outputs_def "outputs == (fst o snd)"
-asig_internals_def "internals == (snd o snd)"
-
-actions_def
- "actions(asig) == (inputs(asig) Un outputs(asig) Un internals(asig))"
-
-externals_def
- "externals(asig) == (inputs(asig) Un outputs(asig))"
-
-is_asig_def
- "is_asig(triple) ==
- ((inputs(triple) Int outputs(triple) = {}) &
- (outputs(triple) Int internals(triple) = {}) &
- (inputs(triple) Int internals(triple) = {}))"
-
-
-mk_ext_asig_def
- "mk_ext_asig(triple) == <inputs(triple), outputs(triple), {}>"
-
-
-end
--- a/IOA/meta_theory/IOA.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,149 +0,0 @@
-(* Title: HOL/IOA/meta_theory/IOA.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The I/O automata of Lynch and Tuttle.
-*)
-
-open IOA Asig;
-
-val ioa_projections = [asig_of_def, starts_of_def, trans_of_def];
-
-val exec_rws = [executions_def,is_execution_fragment_def];
-
-goal IOA.thy
-"asig_of(<x,y,z>) = x & starts_of(<x,y,z>) = y & trans_of(<x,y,z>) = z";
- by (simp_tac (SS addsimps ioa_projections) 1);
- qed "ioa_triple_proj";
-
-goalw IOA.thy [ioa_def,state_trans_def,actions_def, is_asig_def]
- "!!A. [| IOA(A); <s1,a,s2>:trans_of(A) |] ==> a:actions(asig_of(A))";
- by (REPEAT(etac conjE 1));
- by (EVERY1[etac allE, etac impE, atac]);
- by (asm_full_simp_tac SS 1);
-qed "trans_in_actions";
-
-
-goal IOA.thy "filter_oseq(p,filter_oseq(p,s)) = filter_oseq(p,s)";
- by (simp_tac (SS addsimps [filter_oseq_def]) 1);
- by (rtac ext 1);
- by (Option.option.induct_tac "s(i)" 1);
- by (simp_tac SS 1);
- by (simp_tac (SS setloop (split_tac [expand_if])) 1);
-qed "filter_oseq_idemp";
-
-goalw IOA.thy [mk_behaviour_def,filter_oseq_def]
-"(mk_behaviour(A, s, n) = None) = \
-\ (s(n)=None | (? a. s(n)=Some(a) & a ~: externals(asig_of(A)))) \
-\ & \
-\ (mk_behaviour(A, s, n) = Some(a)) = \
-\ (s(n)=Some(a) & a : externals(asig_of(A)))";
- by (Option.option.induct_tac "s(n)" 1);
- by (ALLGOALS (simp_tac (SS setloop (split_tac [expand_if]))));
- by (fast_tac HOL_cs 1);
-qed "mk_behaviour_thm";
-
-goalw IOA.thy [reachable_def] "!!A. s:starts_of(A) ==> reachable(A,s)";
- by (res_inst_tac [("x","<%i.None,%i.s>")] bexI 1);
- by (simp_tac SS 1);
- by (asm_simp_tac (SS addsimps exec_rws) 1);
-qed "reachable_0";
-
-goalw IOA.thy (reachable_def::exec_rws)
-"!!A. [| reachable(A,s); <s,a,t> : trans_of(A) |] ==> reachable(A,t)";
- by(asm_full_simp_tac SS 1);
- by(safe_tac set_cs);
- by(res_inst_tac [("x","<%i.if(i<n,fst(ex,i),if(i=n,Some(a),None)), \
- \ %i.if(i<Suc(n),snd(ex,i),t)>")] bexI 1);
- by(res_inst_tac [("x","Suc(n)")] exI 1);
- by(simp_tac SS 1);
- by(asm_simp_tac (SS delsimps [less_Suc_eq]) 1);
- by(REPEAT(rtac allI 1));
- by(res_inst_tac [("m","na"),("n","n")] (make_elim less_linear) 1);
- be disjE 1;
- by(asm_simp_tac SS 1);
- be disjE 1;
- by(asm_simp_tac SS 1);
- by(fast_tac HOL_cs 1);
- by(forward_tac [less_not_sym] 1);
- by(asm_simp_tac (SS addsimps [less_not_refl2]) 1);
-qed "reachable_n";
-
-val [p1,p2] = goalw IOA.thy [invariant_def]
- "[| !!s. s:starts_of(A) ==> P(s); \
-\ !!s t a. [|reachable(A,s); P(s)|] ==> <s,a,t>: trans_of(A) --> P(t) |] \
-\ ==> invariant(A,P)";
- by (rewrite_goals_tac(reachable_def::Let_def::exec_rws));
- by (safe_tac set_cs);
- by (res_inst_tac [("Q","reachable(A,snd(ex,n))")] conjunct1 1);
- by (nat_ind_tac "n" 1);
- by (fast_tac (set_cs addIs [p1,reachable_0]) 1);
- by (eres_inst_tac[("x","n1")]allE 1);
- by (eres_inst_tac[("P","%x.!a.?Q(x,a)"), ("opt","fst(ex,n1)")] optE 1);
- by (asm_simp_tac HOL_ss 1);
- by (safe_tac HOL_cs);
- by (etac (p2 RS mp) 1);
- by (ALLGOALS(fast_tac(set_cs addDs [hd Option.option.inject RS iffD1,
- reachable_n])));
-qed "invariantI";
-
-val [p1,p2] = goal IOA.thy
- "[| !!s. s : starts_of(A) ==> P(s); \
-\ !!s t a. reachable(A, s) ==> P(s) --> <s,a,t>:trans_of(A) --> P(t) \
-\ |] ==> invariant(A, P)";
- by (fast_tac (HOL_cs addSIs [invariantI] addSDs [p1,p2]) 1);
-qed "invariantI1";
-
-val [p1,p2] = goalw IOA.thy [invariant_def]
-"[| invariant(A,P); reachable(A,s) |] ==> P(s)";
- br(p2 RS (p1 RS spec RS mp))1;
-qed "invariantE";
-
-goal IOA.thy
-"actions(asig_comp(a,b)) = actions(a) Un actions(b)";
- by(simp_tac (prod_ss addsimps
- ([actions_def,asig_comp_def]@asig_projections)) 1);
- by(fast_tac eq_cs 1);
-qed "actions_asig_comp";
-
-goal IOA.thy
-"starts_of(A || B) = {p. fst(p):starts_of(A) & snd(p):starts_of(B)}";
- by(simp_tac (SS addsimps (par_def::ioa_projections)) 1);
-qed "starts_of_par";
-
-(* Every state in an execution is reachable *)
-goalw IOA.thy [reachable_def]
-"!!A. ex:executions(A) ==> !n. reachable(A, snd(ex,n))";
- by (fast_tac set_cs 1);
-qed "states_of_exec_reachable";
-
-
-goal IOA.thy
-"<s,a,t> : trans_of(A || B || C || D) = \
-\ ((a:actions(asig_of(A)) | a:actions(asig_of(B)) | a:actions(asig_of(C)) | \
-\ a:actions(asig_of(D))) & \
-\ if(a:actions(asig_of(A)), <fst(s),a,fst(t)>:trans_of(A), fst(t)=fst(s)) & \
-\ if(a:actions(asig_of(B)), <fst(snd(s)),a,fst(snd(t))>:trans_of(B), \
-\ fst(snd(t))=fst(snd(s))) & \
-\ if(a:actions(asig_of(C)), \
-\ <fst(snd(snd(s))),a,fst(snd(snd(t)))>:trans_of(C), \
-\ fst(snd(snd(t)))=fst(snd(snd(s)))) & \
-\ if(a:actions(asig_of(D)), \
-\ <snd(snd(snd(s))),a,snd(snd(snd(t)))>:trans_of(D), \
-\ snd(snd(snd(t)))=snd(snd(snd(s)))))";
- by(simp_tac (SS addsimps ([par_def,actions_asig_comp,Pair_fst_snd_eq]@
- ioa_projections)
- setloop (split_tac [expand_if])) 1);
-qed "trans_of_par4";
-
-goal IOA.thy "starts_of(restrict(ioa,acts)) = starts_of(ioa) & \
-\ trans_of(restrict(ioa,acts)) = trans_of(ioa) & \
-\ reachable(restrict(ioa,acts),s) = reachable(ioa,s)";
-by(simp_tac (SS addsimps ([is_execution_fragment_def,executions_def,
- reachable_def,restrict_def]@ioa_projections)) 1);
-qed "cancel_restrict";
-
-goal IOA.thy "asig_of(A || B) = asig_comp(asig_of(A),asig_of(B))";
- by(simp_tac (SS addsimps (par_def::ioa_projections)) 1);
-qed "asig_of_par";
--- a/IOA/meta_theory/IOA.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,186 +0,0 @@
-(* Title: HOL/IOA/meta_theory/IOA.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-The I/O automata of Lynch and Tuttle.
-*)
-
-IOA = Asig +
-
-types
- 'a seq = "nat => 'a"
- 'a oseq = "nat => 'a option"
- ('a,'b)execution = "'a oseq * 'b seq"
- ('a,'s)transition = "('s * 'a * 's)"
- ('a,'s)ioa = "'a signature * 's set * ('a,'s)transition set"
-
-consts
-
- (* IO automata *)
- state_trans::"['action signature, ('action,'state)transition set] => bool"
- asig_of ::"('action,'state)ioa => 'action signature"
- starts_of ::"('action,'state)ioa => 'state set"
- trans_of ::"('action,'state)ioa => ('action,'state)transition set"
- IOA ::"('action,'state)ioa => bool"
-
- (* Executions, schedules, and behaviours *)
-
- is_execution_fragment,
- has_execution ::"[('action,'state)ioa, ('action,'state)execution] => bool"
- executions :: "('action,'state)ioa => ('action,'state)execution set"
- mk_behaviour :: "[('action,'state)ioa, 'action oseq] => 'action oseq"
- reachable :: "[('action,'state)ioa, 'state] => bool"
- invariant :: "[('action,'state)ioa, 'state=>bool] => bool"
- has_behaviour :: "[('action,'state)ioa, 'action oseq] => bool"
- behaviours :: "('action,'state)ioa => 'action oseq set"
-
- (* Composition of action signatures and automata *)
- compatible_asigs ::"('a => 'action signature) => bool"
- asig_composition ::"('a => 'action signature) => 'action signature"
- compatible_ioas ::"('a => ('action,'state)ioa) => bool"
- ioa_composition ::"('a => ('action, 'state)ioa) =>('action,'a => 'state)ioa"
-
- (* binary composition of action signatures and automata *)
- compat_asigs ::"['action signature, 'action signature] => bool"
- asig_comp ::"['action signature, 'action signature] => 'action signature"
- compat_ioas ::"[('action,'state)ioa, ('action,'state)ioa] => bool"
- "||" ::"[('a,'s)ioa, ('a,'t)ioa] => ('a,'s*'t)ioa" (infixr 10)
-
- (* Filtering and hiding *)
- filter_oseq :: "('a => bool) => 'a oseq => 'a oseq"
-
- restrict_asig :: "['a signature, 'a set] => 'a signature"
- restrict :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
-
- (* Notions of correctness *)
- ioa_implements :: "[('action,'state1)ioa, ('action,'state2)ioa] => bool"
-
-
-defs
-
-state_trans_def
- "state_trans(asig,R) ==
- (!triple. triple:R --> fst(snd(triple)):actions(asig)) &
- (!a. (a:inputs(asig)) --> (!s1. ? s2. <s1,a,s2>:R))"
-
-
-asig_of_def "asig_of == fst"
-starts_of_def "starts_of == (fst o snd)"
-trans_of_def "trans_of == (snd o snd)"
-
-ioa_def
- "IOA(ioa) == (is_asig(asig_of(ioa)) &
- (~ starts_of(ioa) = {}) &
- state_trans(asig_of(ioa),trans_of(ioa)))"
-
-
-(* An execution fragment is modelled with a pair of sequences:
- * the first is the action options, the second the state sequence.
- * Finite executions have None actions from some point on.
- *******)
-is_execution_fragment_def
- "is_execution_fragment(A,ex) ==
- let act = fst(ex); state = snd(ex)
- in !n a. (act(n)=None --> state(Suc(n)) = state(n)) &
- (act(n)=Some(a) --> <state(n),a,state(Suc(n))>:trans_of(A))"
-
-
-executions_def
- "executions(ioa) == {e. snd(e,0):starts_of(ioa) &
- is_execution_fragment(ioa,e)}"
-
-
-(* Is a state reachable. Using an inductive definition, this could be defined
- * by the following 2 rules
- *
- * x:starts_of(ioa)
- * ----------------
- * reachable(ioa,x)
- *
- * reachable(ioa,s) & ? <s,a,s'>:trans_of(ioa)
- * -------------------------------------------
- * reachable(ioa,s')
- *
- * A direkt definition follows.
- *******************************)
-reachable_def
- "reachable(ioa,s) == (? ex:executions(ioa). ? n. snd(ex,n) = s)"
-
-
-invariant_def "invariant(A,P) == (!s. reachable(A,s) --> P(s))"
-
-
-(* Restrict the trace to those members of the set s *)
-filter_oseq_def
- "filter_oseq(p,s) ==
- (%i.case s(i)
- of None => None
- | Some(x) => if(p(x),Some(x),None))"
-
-
-mk_behaviour_def
- "mk_behaviour(ioa) == filter_oseq(%a.a:externals(asig_of(ioa)))"
-
-
-(* Does an ioa have an execution with the given behaviour *)
-has_behaviour_def
- "has_behaviour(ioa,b) ==
- (? ex:executions(ioa). b = mk_behaviour(ioa,fst(ex)))"
-
-
-(* All the behaviours of an ioa *)
-behaviours_def
- "behaviours(ioa) == {b. has_behaviour(ioa,b)}"
-
-
-compat_asigs_def
- "compat_asigs (a1,a2) ==
- (((outputs(a1) Int outputs(a2)) = {}) &
- ((internals(a1) Int actions(a2)) = {}) &
- ((internals(a2) Int actions(a1)) = {}))"
-
-
-compat_ioas_def
- "compat_ioas(ioa1,ioa2) == compat_asigs (asig_of(ioa1)) (asig_of(ioa2))"
-
-
-asig_comp_def
- "asig_comp (a1,a2) ==
- (<(inputs(a1) Un inputs(a2)) - (outputs(a1) Un outputs(a2)),
- (outputs(a1) Un outputs(a2)),
- (internals(a1) Un internals(a2))>)"
-
-
-par_def
- "(ioa1 || ioa2) ==
- <asig_comp(asig_of(ioa1),asig_of(ioa2)),
- {pr. fst(pr):starts_of(ioa1) & snd(pr):starts_of(ioa2)},
- {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
- in (a:actions(asig_of(ioa1)) | a:actions(asig_of(ioa2))) &
- if(a:actions(asig_of(ioa1)),
- <fst(s),a,fst(t)>:trans_of(ioa1),
- fst(t) = fst(s))
- &
- if(a:actions(asig_of(ioa2)),
- <snd(s),a,snd(t)>:trans_of(ioa2),
- snd(t) = snd(s))}>"
-
-
-restrict_asig_def
- "restrict_asig(asig,actns) ==
- <inputs(asig) Int actns, outputs(asig) Int actns,
- internals(asig) Un (externals(asig) - actns)>"
-
-
-restrict_def
- "restrict(ioa,actns) ==
- <restrict_asig(asig_of(ioa),actns), starts_of(ioa), trans_of(ioa)>"
-
-
-ioa_implements_def
- "ioa_implements(ioa1,ioa2) ==
- (externals(asig_of(ioa1)) = externals(asig_of(ioa2)) &
- behaviours(ioa1) <= behaviours(ioa2))"
-
-end
--- a/IOA/meta_theory/Option.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,16 +0,0 @@
-(* Title: Option.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Derived rules
-*)
-
-val option_rws = Let_def :: Option.option.simps;
-val SS = arith_ss addsimps option_rws;
-
-val [prem] = goal Option.thy "P(opt) ==> P(None) | (? x. P(Some(x)))";
- br (prem RS rev_mp) 1;
- by (Option.option.induct_tac "opt" 1);
- by (ALLGOALS(fast_tac HOL_cs));
-val optE = store_thm("optE", standard(result() RS disjE));
--- a/IOA/meta_theory/Option.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,11 +0,0 @@
-(* Title: Option.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Datatype 'a option
-*)
-
-Option = Arith +
-datatype 'a option = None | Some('a)
-end
--- a/IOA/meta_theory/Solve.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,45 +0,0 @@
-(* Title: HOL/IOA/meta_theory/Solve.ML
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Weak possibilities mapping (abstraction)
-*)
-
-open Solve;
-
-val SS = SS addsimps [mk_behaviour_thm,trans_in_actions];
-
-goalw Solve.thy [is_weak_pmap_def,behaviours_def]
- "!!f. [| IOA(C); IOA(A); externals(asig_of(C)) = externals(asig_of(A)); \
-\ is_weak_pmap(f,C,A) |] ==> behaviours(C) <= behaviours(A)";
-
- by (simp_tac(SS addsimps [has_behaviour_def])1);
- by (safe_tac set_cs);
-
- (* give execution of abstract automata *)
- by (res_inst_tac[("x","<mk_behaviour(A,fst(ex)),%i.f(snd(ex,i))>")] bexI 1);
-
- (* Behaviours coincide *)
- by (asm_simp_tac (SS addsimps [mk_behaviour_def,filter_oseq_idemp])1);
-
- (* Use lemma *)
- by (forward_tac [states_of_exec_reachable] 1);
-
- (* Now show that it's an execution *)
- by (asm_full_simp_tac(SS addsimps [executions_def]) 1);
- by (safe_tac set_cs);
-
- (* Start states map to start states *)
- by (dtac bspec 1);
- by (atac 1);
-
- (* Show that it's an execution fragment *)
- by (asm_full_simp_tac (SS addsimps [is_execution_fragment_def])1);
- by (safe_tac HOL_cs);
-
- by (eres_inst_tac [("x","snd(ex,n)")] allE 1);
- by (eres_inst_tac [("x","snd(ex,Suc(n))")] allE 1);
- by (eres_inst_tac [("x","a")] allE 1);
- by (asm_full_simp_tac SS 1);
-qed "trace_inclusion";
--- a/IOA/meta_theory/Solve.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,26 +0,0 @@
-(* Title: HOL/IOA/meta_theory/Solve.thy
- ID: $Id$
- Author: Tobias Nipkow & Konrad Slind
- Copyright 1994 TU Muenchen
-
-Weak possibilities mapping (abstraction)
-*)
-
-Solve = IOA +
-
-consts
-
- is_weak_pmap :: "['c => 'a, ('action,'c)ioa,('action,'a)ioa] => bool"
-
-defs
-
-is_weak_pmap_def
- "is_weak_pmap(f,C,A) ==
- (!s:starts_of(C). f(s):starts_of(A)) &
- (!s t a. reachable(C,s) &
- <s,a,t>:trans_of(C)
- --> if(a:externals(asig_of(C)),
- <f(s),a,f(t)>:trans_of(A),
- f(s)=f(t)))"
-
-end
--- a/Inductive.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,94 +0,0 @@
-(* Title: HOL/inductive.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-(Co)Inductive Definitions for HOL
-
-Inductive definitions use least fixedpoints with standard products and sums
-Coinductive definitions use greatest fixedpoints with Quine products and sums
-
-Sums are used only for mutual recursion;
-Products are used only to derive "streamlined" induction rules for relations
-*)
-
-local open Ind_Syntax
-in
-
-fun gen_fp_oper a (X,T,t) =
- let val setT = mk_setT T
- in Const(a, (setT-->setT)-->setT) $ absfree(X, setT, t) end;
-
-structure Lfp_items =
- struct
- val oper = gen_fp_oper "lfp"
- val Tarski = def_lfp_Tarski
- val induct = def_induct
- end;
-
-structure Gfp_items =
- struct
- val oper = gen_fp_oper "gfp"
- val Tarski = def_gfp_Tarski
- val induct = def_Collect_coinduct
- end;
-
-end;
-
-
-functor Ind_section_Fun (Inductive: sig include INDUCTIVE_ARG INDUCTIVE_I end)
- : sig include INTR_ELIM INDRULE end =
-struct
-structure Intr_elim = Intr_elim_Fun(structure Inductive=Inductive and
- Fp=Lfp_items);
-
-structure Indrule = Indrule_Fun
- (structure Inductive=Inductive and Intr_elim=Intr_elim);
-
-open Intr_elim Indrule
-end;
-
-
-structure Ind = Add_inductive_def_Fun (Lfp_items);
-
-
-signature INDUCTIVE_STRING =
- sig
- val thy_name : string (*name of the new theory*)
- val srec_tms : string list (*recursion terms*)
- val sintrs : string list (*desired introduction rules*)
- end;
-
-
-(*For upwards compatibility: can be called directly from ML*)
-functor Inductive_Fun
- (Inductive: sig include INDUCTIVE_STRING INDUCTIVE_ARG end)
- : sig include INTR_ELIM INDRULE end =
-Ind_section_Fun
- (open Inductive Ind_Syntax
- val sign = sign_of thy;
- val rec_tms = map (readtm sign termTVar) srec_tms
- and intr_tms = map (readtm sign propT) sintrs;
- val thy = thy |> Ind.add_fp_def_i(rec_tms, intr_tms)
- |> add_thyname thy_name);
-
-
-
-signature COINDRULE =
- sig
- val coinduct : thm
- end;
-
-
-functor CoInd_section_Fun
- (Inductive: sig include INDUCTIVE_ARG INDUCTIVE_I end)
- : sig include INTR_ELIM COINDRULE end =
-struct
-structure Intr_elim = Intr_elim_Fun(structure Inductive=Inductive and Fp=Gfp_items);
-
-open Intr_elim
-val coinduct = raw_induct
-end;
-
-
-structure CoInd = Add_inductive_def_Fun(Gfp_items);
--- a/Inductive.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1 +0,0 @@
-Inductive = Gfp + Prod
--- a/Integ/Equiv.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,272 +0,0 @@
-(* Title: Equiv.ML
- ID: $Id$
- Authors: Riccardo Mattolini, Dip. Sistemi e Informatica
- Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 Universita' di Firenze
- Copyright 1993 University of Cambridge
-
-Equivalence relations in HOL Set Theory
-*)
-
-open Equiv;
-
-(*** Suppes, Theorem 70: r is an equiv relation iff converse(r) O r = r ***)
-
-(** first half: equiv(A,r) ==> converse(r) O r = r **)
-
-goalw Equiv.thy [trans_def,sym_def,converse_def]
- "!!r. [| sym(r); trans(r) |] ==> converse(r) O r <= r";
-by (fast_tac (comp_cs addSEs [converseD]) 1);
-qed "sym_trans_comp_subset";
-
-goalw Equiv.thy [refl_def]
- "!!A r. refl(A,r) ==> r <= converse(r) O r";
-by (fast_tac (rel_cs addIs [compI]) 1);
-qed "refl_comp_subset";
-
-goalw Equiv.thy [equiv_def]
- "!!A r. equiv(A,r) ==> converse(r) O r = r";
-by (rtac equalityI 1);
-by (REPEAT (ares_tac [sym_trans_comp_subset, refl_comp_subset] 1
- ORELSE etac conjE 1));
-qed "equiv_comp_eq";
-
-(*second half*)
-goalw Equiv.thy [equiv_def,refl_def,sym_def,trans_def]
- "!!A r. [| converse(r) O r = r; Domain(r) = A |] ==> equiv(A,r)";
-by (etac equalityE 1);
-by (subgoal_tac "ALL x y. <x,y> : r --> <y,x> : r" 1);
-by (safe_tac set_cs);
-by (fast_tac (set_cs addSIs [converseI] addIs [compI]) 3);
-by (ALLGOALS (fast_tac (rel_cs addIs [compI] addSEs [compE])));
-qed "comp_equivI";
-
-(** Equivalence classes **)
-
-(*Lemma for the next result*)
-goalw Equiv.thy [equiv_def,trans_def,sym_def]
- "!!A r. [| equiv(A,r); <a,b>: r |] ==> r^^{a} <= r^^{b}";
-by (safe_tac rel_cs);
-by (rtac ImageI 1);
-by (fast_tac rel_cs 2);
-by (fast_tac rel_cs 1);
-qed "equiv_class_subset";
-
-goal Equiv.thy "!!A r. [| equiv(A,r); <a,b>: r |] ==> r^^{a} = r^^{b}";
-by (REPEAT (ares_tac [equalityI, equiv_class_subset] 1));
-by (rewrite_goals_tac [equiv_def,sym_def]);
-by (fast_tac rel_cs 1);
-qed "equiv_class_eq";
-
-val prems = goalw Equiv.thy [equiv_def,refl_def]
- "[| equiv(A,r); a: A |] ==> a: r^^{a}";
-by (cut_facts_tac prems 1);
-by (fast_tac rel_cs 1);
-qed "equiv_class_self";
-
-(*Lemma for the next result*)
-goalw Equiv.thy [equiv_def,refl_def]
- "!!A r. [| equiv(A,r); r^^{b} <= r^^{a}; b: A |] ==> <a,b>: r";
-by (fast_tac rel_cs 1);
-qed "subset_equiv_class";
-
-val prems = goal Equiv.thy
- "[| r^^{a} = r^^{b}; equiv(A,r); b: A |] ==> <a,b>: r";
-by (REPEAT (resolve_tac (prems @ [equalityD2, subset_equiv_class]) 1));
-qed "eq_equiv_class";
-
-(*thus r^^{a} = r^^{b} as well*)
-goalw Equiv.thy [equiv_def,trans_def,sym_def]
- "!!A r. [| equiv(A,r); x: (r^^{a} Int r^^{b}) |] ==> <a,b>: r";
-by (fast_tac rel_cs 1);
-qed "equiv_class_nondisjoint";
-
-val [major] = goalw Equiv.thy [equiv_def,refl_def]
- "equiv(A,r) ==> r <= Sigma(A,%x.A)";
-by (rtac (major RS conjunct1 RS conjunct1) 1);
-qed "equiv_type";
-
-goal Equiv.thy
- "!!A r. equiv(A,r) ==> (<x,y>: r) = (r^^{x} = r^^{y} & x:A & y:A)";
-by (safe_tac rel_cs);
-by ((rtac equiv_class_eq 1) THEN (assume_tac 1) THEN (assume_tac 1));
-by ((rtac eq_equiv_class 3) THEN
- (assume_tac 4) THEN (assume_tac 4) THEN (assume_tac 3));
-by ((dtac equiv_type 1) THEN (dtac rev_subsetD 1) THEN
- (assume_tac 1) THEN (dtac SigmaD1 1) THEN (assume_tac 1));
-by ((dtac equiv_type 1) THEN (dtac rev_subsetD 1) THEN
- (assume_tac 1) THEN (dtac SigmaD2 1) THEN (assume_tac 1));
-qed "equiv_class_eq_iff";
-
-goal Equiv.thy
- "!!A r. [| equiv(A,r); x: A; y: A |] ==> (r^^{x} = r^^{y}) = (<x,y>: r)";
-by (safe_tac rel_cs);
-by ((rtac eq_equiv_class 1) THEN
- (assume_tac 1) THEN (assume_tac 1) THEN (assume_tac 1));
-by ((rtac equiv_class_eq 1) THEN
- (assume_tac 1) THEN (assume_tac 1));
-qed "eq_equiv_class_iff";
-
-(*** Quotients ***)
-
-(** Introduction/elimination rules -- needed? **)
-
-val prems = goalw Equiv.thy [quotient_def] "x:A ==> r^^{x}: A/r";
-by (rtac UN_I 1);
-by (resolve_tac prems 1);
-by (rtac singletonI 1);
-qed "quotientI";
-
-val [major,minor] = goalw Equiv.thy [quotient_def]
- "[| X:(A/r); !!x. [| X = r^^{x}; x:A |] ==> P |] \
-\ ==> P";
-by (resolve_tac [major RS UN_E] 1);
-by (rtac minor 1);
-by (assume_tac 2);
-by (fast_tac rel_cs 1);
-qed "quotientE";
-
-(** Not needed by Theory Integ --> bypassed **)
-(**goalw Equiv.thy [equiv_def,refl_def,quotient_def]
- "!!A r. equiv(A,r) ==> Union(A/r) = A";
-by (fast_tac eq_cs 1);
-qed "Union_quotient";
-**)
-
-(** Not needed by Theory Integ --> bypassed **)
-(*goalw Equiv.thy [quotient_def]
- "!!A r. [| equiv(A,r); X: A/r; Y: A/r |] ==> X=Y | (X Int Y <= 0)";
-by (safe_tac (ZF_cs addSIs [equiv_class_eq]));
-by (assume_tac 1);
-by (rewrite_goals_tac [equiv_def,trans_def,sym_def]);
-by (fast_tac ZF_cs 1);
-qed "quotient_disj";
-**)
-
-(**** Defining unary operations upon equivalence classes ****)
-
-(* theorem needed to prove UN_equiv_class *)
-goal Set.thy "!!A. [| a:A; ! y:A. b(y)=b(a) |] ==> (UN y:A. b(y))=b(a)";
-by (fast_tac (eq_cs addSEs [equalityE]) 1);
-qed "UN_singleton_lemma";
-val UN_singleton = ballI RSN (2,UN_singleton_lemma);
-
-
-(** These proofs really require as local premises
- equiv(A,r); congruent(r,b)
-**)
-
-(*Conversion rule*)
-val prems as [equivA,bcong,_] = goal Equiv.thy
- "[| equiv(A,r); congruent(r,b); a: A |] ==> (UN x:r^^{a}. b(x)) = b(a)";
-by (cut_facts_tac prems 1);
-by (rtac UN_singleton 1);
-by (rtac equiv_class_self 1);
-by (assume_tac 1);
-by (assume_tac 1);
-by (rewrite_goals_tac [equiv_def,congruent_def,sym_def]);
-by (fast_tac rel_cs 1);
-qed "UN_equiv_class";
-
-(*Resolve th against the "local" premises*)
-val localize = RSLIST [equivA,bcong];
-
-(*type checking of UN x:r``{a}. b(x) *)
-val _::_::prems = goalw Equiv.thy [quotient_def]
- "[| equiv(A,r); congruent(r,b); X: A/r; \
-\ !!x. x : A ==> b(x) : B |] \
-\ ==> (UN x:X. b(x)) : B";
-by (cut_facts_tac prems 1);
-by (safe_tac rel_cs);
-by (rtac (localize UN_equiv_class RS ssubst) 1);
-by (REPEAT (ares_tac prems 1));
-qed "UN_equiv_class_type";
-
-(*Sufficient conditions for injectiveness. Could weaken premises!
- major premise could be an inclusion; bcong could be !!y. y:A ==> b(y):B
-*)
-val _::_::prems = goalw Equiv.thy [quotient_def]
- "[| equiv(A,r); congruent(r,b); \
-\ (UN x:X. b(x))=(UN y:Y. b(y)); X: A/r; Y: A/r; \
-\ !!x y. [| x:A; y:A; b(x)=b(y) |] ==> <x,y>:r |] \
-\ ==> X=Y";
-by (cut_facts_tac prems 1);
-by (safe_tac rel_cs);
-by (rtac (equivA RS equiv_class_eq) 1);
-by (REPEAT (ares_tac prems 1));
-by (etac box_equals 1);
-by (REPEAT (ares_tac [localize UN_equiv_class] 1));
-qed "UN_equiv_class_inject";
-
-
-(**** Defining binary operations upon equivalence classes ****)
-
-
-goalw Equiv.thy [congruent_def,congruent2_def,equiv_def,refl_def]
- "!!A r. [| equiv(A,r); congruent2(r,b); a: A |] ==> congruent(r,b(a))";
-by (fast_tac rel_cs 1);
-qed "congruent2_implies_congruent";
-
-val equivA::prems = goalw Equiv.thy [congruent_def]
- "[| equiv(A,r); congruent2(r,b); a: A |] ==> \
-\ congruent(r, %x1. UN x2:r^^{a}. b(x1,x2))";
-by (cut_facts_tac (equivA::prems) 1);
-by (safe_tac rel_cs);
-by (rtac (equivA RS equiv_type RS subsetD RS SigmaE2) 1);
-by (assume_tac 1);
-by (asm_simp_tac (prod_ss addsimps [equivA RS UN_equiv_class,
- congruent2_implies_congruent]) 1);
-by (rewrite_goals_tac [congruent2_def,equiv_def,refl_def]);
-by (fast_tac rel_cs 1);
-qed "congruent2_implies_congruent_UN";
-
-val prems as equivA::_ = goal Equiv.thy
- "[| equiv(A,r); congruent2(r,b); a1: A; a2: A |] \
-\ ==> (UN x1:r^^{a1}. UN x2:r^^{a2}. b(x1,x2)) = b(a1,a2)";
-by (cut_facts_tac prems 1);
-by (asm_simp_tac (prod_ss addsimps [equivA RS UN_equiv_class,
- congruent2_implies_congruent,
- congruent2_implies_congruent_UN]) 1);
-qed "UN_equiv_class2";
-
-(*type checking*)
-val prems = goalw Equiv.thy [quotient_def]
- "[| equiv(A,r); congruent2(r,b); \
-\ X1: A/r; X2: A/r; \
-\ !!x1 x2. [| x1: A; x2: A |] ==> b(x1,x2) : B |] \
-\ ==> (UN x1:X1. UN x2:X2. b(x1,x2)) : B";
-by (cut_facts_tac prems 1);
-by (safe_tac rel_cs);
-by (REPEAT (ares_tac (prems@[UN_equiv_class_type,
- congruent2_implies_congruent_UN,
- congruent2_implies_congruent, quotientI]) 1));
-qed "UN_equiv_class_type2";
-
-
-(*Suggested by John Harrison -- the two subproofs may be MUCH simpler
- than the direct proof*)
-val prems = goalw Equiv.thy [congruent2_def,equiv_def,refl_def]
- "[| equiv(A,r); \
-\ !! y z w. [| w: A; <y,z> : r |] ==> b(y,w) = b(z,w); \
-\ !! y z w. [| w: A; <y,z> : r |] ==> b(w,y) = b(w,z) \
-\ |] ==> congruent2(r,b)";
-by (cut_facts_tac prems 1);
-by (safe_tac rel_cs);
-by (rtac trans 1);
-by (REPEAT (ares_tac prems 1
- ORELSE etac (subsetD RS SigmaE2) 1 THEN assume_tac 2 THEN assume_tac 1));
-qed "congruent2I";
-
-val [equivA,commute,congt] = goal Equiv.thy
- "[| equiv(A,r); \
-\ !! y z. [| y: A; z: A |] ==> b(y,z) = b(z,y); \
-\ !! y z w. [| w: A; <y,z>: r |] ==> b(w,y) = b(w,z) \
-\ |] ==> congruent2(r,b)";
-by (resolve_tac [equivA RS congruent2I] 1);
-by (rtac (commute RS trans) 1);
-by (rtac (commute RS trans RS sym) 3);
-by (rtac sym 5);
-by (REPEAT (ares_tac [congt] 1
- ORELSE etac (equivA RS equiv_type RS subsetD RS SigmaE2) 1));
-qed "congruent2_commuteI";
-
--- a/Integ/Equiv.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-(* Title: Equiv.thy
- ID: $Id$
- Authors: Riccardo Mattolini, Dip. Sistemi e Informatica
- Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 Universita' di Firenze
- Copyright 1993 University of Cambridge
-
-Equivalence relations in Higher-Order Set Theory
-*)
-
-Equiv = Relation +
-consts
- refl,equiv :: "['a set,('a*'a) set]=>bool"
- sym :: "('a*'a) set=>bool"
- "'/" :: "['a set,('a*'a) set]=>'a set set" (infixl 90)
- (*set of equiv classes*)
- congruent :: "[('a*'a) set,'a=>'b]=>bool"
- congruent2 :: "[('a*'a) set,['a,'a]=>'b]=>bool"
-
-defs
- refl_def "refl(A,r) == r <= Sigma(A,%x.A) & (ALL x: A. <x,x> : r)"
- sym_def "sym(r) == ALL x y. <x,y>: r --> <y,x>: r"
- equiv_def "equiv(A,r) == refl(A,r) & sym(r) & trans(r)"
- quotient_def "A/r == UN x:A. {r^^{x}}"
- congruent_def "congruent(r,b) == ALL y z. <y,z>:r --> b(y)=b(z)"
- congruent2_def "congruent2(r,b) == ALL y1 z1 y2 z2.
- <y1,z1>:r --> <y2,z2>:r --> b(y1,y2) = b(z1,z2)"
-end
--- a/Integ/Integ.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,752 +0,0 @@
-(* Title: Integ.ML
- ID: $Id$
- Authors: Riccardo Mattolini, Dip. Sistemi e Informatica
- Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 Universita' di Firenze
- Copyright 1993 University of Cambridge
-
-The integers as equivalence classes over nat*nat.
-
-Could also prove...
-"znegative(z) ==> $# zmagnitude(z) = $~ z"
-"~ znegative(z) ==> $# zmagnitude(z) = z"
-< is a linear ordering
-+ and * are monotonic wrt <
-*)
-
-open Integ;
-
-
-(*** Proving that intrel is an equivalence relation ***)
-
-val eqa::eqb::prems = goal Arith.thy
- "[| (x1::nat) + y2 = x2 + y1; x2 + y3 = x3 + y2 |] ==> \
-\ x1 + y3 = x3 + y1";
-by (res_inst_tac [("k2","x2")] (add_left_cancel RS iffD1) 1);
-by (rtac (add_left_commute RS trans) 1);
-by (rtac (eqb RS ssubst) 1);
-by (rtac (add_left_commute RS trans) 1);
-by (rtac (eqa RS ssubst) 1);
-by (rtac (add_left_commute) 1);
-qed "integ_trans_lemma";
-
-(** Natural deduction for intrel **)
-
-val prems = goalw Integ.thy [intrel_def]
- "[| x1+y2 = x2+y1|] ==> \
-\ <<x1,y1>,<x2,y2>>: intrel";
-by (fast_tac (rel_cs addIs prems) 1);
-qed "intrelI";
-
-(*intrelE is hard to derive because fast_tac tries hyp_subst_tac so soon*)
-goalw Integ.thy [intrel_def]
- "p: intrel --> (EX x1 y1 x2 y2. \
-\ p = <<x1,y1>,<x2,y2>> & x1+y2 = x2+y1)";
-by (fast_tac rel_cs 1);
-qed "intrelE_lemma";
-
-val [major,minor] = goal Integ.thy
- "[| p: intrel; \
-\ !!x1 y1 x2 y2. [| p = <<x1,y1>,<x2,y2>>; x1+y2 = x2+y1|] ==> Q |] \
-\ ==> Q";
-by (cut_facts_tac [major RS (intrelE_lemma RS mp)] 1);
-by (REPEAT (eresolve_tac [asm_rl,exE,conjE,minor] 1));
-qed "intrelE";
-
-val intrel_cs = rel_cs addSIs [intrelI] addSEs [intrelE];
-
-goal Integ.thy "<<x1,y1>,<x2,y2>>: intrel = (x1+y2 = x2+y1)";
-by (fast_tac intrel_cs 1);
-qed "intrel_iff";
-
-goal Integ.thy "<x,x>: intrel";
-by (rtac (surjective_pairing RS ssubst) 1 THEN rtac (refl RS intrelI) 1);
-qed "intrel_refl";
-
-goalw Integ.thy [equiv_def, refl_def, sym_def, trans_def]
- "equiv({x::(nat*nat).True}, intrel)";
-by (fast_tac (intrel_cs addSIs [intrel_refl]
- addSEs [sym, integ_trans_lemma]) 1);
-qed "equiv_intrel";
-
-val equiv_intrel_iff =
- [TrueI, TrueI] MRS
- ([CollectI, CollectI] MRS
- (equiv_intrel RS eq_equiv_class_iff));
-
-goalw Integ.thy [Integ_def,intrel_def,quotient_def] "intrel^^{<x,y>}:Integ";
-by (fast_tac set_cs 1);
-qed "intrel_in_integ";
-
-goal Integ.thy "inj_onto(Abs_Integ,Integ)";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_Integ_inverse 1);
-qed "inj_onto_Abs_Integ";
-
-val intrel_ss =
- arith_ss addsimps [equiv_intrel_iff, inj_onto_Abs_Integ RS inj_onto_iff,
- intrel_iff, intrel_in_integ, Abs_Integ_inverse];
-
-goal Integ.thy "inj(Rep_Integ)";
-by (rtac inj_inverseI 1);
-by (rtac Rep_Integ_inverse 1);
-qed "inj_Rep_Integ";
-
-
-
-
-(** znat: the injection from nat to Integ **)
-
-goal Integ.thy "inj(znat)";
-by (rtac injI 1);
-by (rewtac znat_def);
-by (dtac (inj_onto_Abs_Integ RS inj_ontoD) 1);
-by (REPEAT (rtac intrel_in_integ 1));
-by (dtac eq_equiv_class 1);
-by (rtac equiv_intrel 1);
-by (fast_tac set_cs 1);
-by (safe_tac intrel_cs);
-by (asm_full_simp_tac arith_ss 1);
-qed "inj_znat";
-
-
-(**** zminus: unary negation on Integ ****)
-
-goalw Integ.thy [congruent_def]
- "congruent(intrel,%p. split(%x y. intrel^^{<y,x>},p))";
-by (safe_tac intrel_cs);
-by (asm_simp_tac (intrel_ss addsimps add_ac) 1);
-qed "zminus_congruent";
-
-
-(*Resolve th against the corresponding facts for zminus*)
-val zminus_ize = RSLIST [equiv_intrel, zminus_congruent];
-
-goalw Integ.thy [zminus_def]
- "$~ Abs_Integ(intrel^^{<x,y>}) = Abs_Integ(intrel ^^ {<y,x>})";
-by (res_inst_tac [("f","Abs_Integ")] arg_cong 1);
-by (simp_tac (set_ss addsimps
- [intrel_in_integ RS Abs_Integ_inverse,zminus_ize UN_equiv_class]) 1);
-by (rewtac split_def);
-by (simp_tac prod_ss 1);
-qed "zminus";
-
-(*by lcp*)
-val [prem] = goal Integ.thy
- "(!!x y. z = Abs_Integ(intrel^^{<x,y>}) ==> P) ==> P";
-by (res_inst_tac [("x1","z")]
- (rewrite_rule [Integ_def] Rep_Integ RS quotientE) 1);
-by (dres_inst_tac [("f","Abs_Integ")] arg_cong 1);
-by (res_inst_tac [("p","x")] PairE 1);
-by (rtac prem 1);
-by (asm_full_simp_tac (HOL_ss addsimps [Rep_Integ_inverse]) 1);
-qed "eq_Abs_Integ";
-
-goal Integ.thy "$~ ($~ z) = z";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (asm_simp_tac (HOL_ss addsimps [zminus]) 1);
-qed "zminus_zminus";
-
-goal Integ.thy "inj(zminus)";
-by (rtac injI 1);
-by (dres_inst_tac [("f","zminus")] arg_cong 1);
-by (asm_full_simp_tac (HOL_ss addsimps [zminus_zminus]) 1);
-qed "inj_zminus";
-
-goalw Integ.thy [znat_def] "$~ ($#0) = $#0";
-by (simp_tac (arith_ss addsimps [zminus]) 1);
-qed "zminus_0";
-
-
-(**** znegative: the test for negative integers ****)
-
-goal Arith.thy "!!m x n::nat. n+m=x ==> m<=x";
-by (dtac (disjI2 RS less_or_eq_imp_le) 1);
-by (asm_full_simp_tac (arith_ss addsimps add_ac) 1);
-by (dtac add_leD1 1);
-by (assume_tac 1);
-qed "not_znegative_znat_lemma";
-
-
-goalw Integ.thy [znegative_def, znat_def]
- "~ znegative($# n)";
-by (simp_tac intrel_ss 1);
-by (safe_tac intrel_cs);
-by (rtac ccontr 1);
-by (etac notE 1);
-by (asm_full_simp_tac arith_ss 1);
-by (dtac not_znegative_znat_lemma 1);
-by (fast_tac (HOL_cs addDs [leD]) 1);
-qed "not_znegative_znat";
-
-goalw Integ.thy [znegative_def, znat_def] "znegative($~ $# Suc(n))";
-by (simp_tac (intrel_ss addsimps [zminus]) 1);
-by (REPEAT (ares_tac [exI, conjI] 1));
-by (rtac (intrelI RS ImageI) 2);
-by (rtac singletonI 3);
-by (simp_tac arith_ss 2);
-by (rtac less_add_Suc1 1);
-qed "znegative_zminus_znat";
-
-
-(**** zmagnitude: magnitide of an integer, as a natural number ****)
-
-goal Arith.thy "!!n::nat. n - Suc(n+m)=0";
-by (nat_ind_tac "n" 1);
-by (ALLGOALS(asm_simp_tac arith_ss));
-qed "diff_Suc_add_0";
-
-goal Arith.thy "Suc((n::nat)+m)-n=Suc(m)";
-by (nat_ind_tac "n" 1);
-by (ALLGOALS(asm_simp_tac arith_ss));
-qed "diff_Suc_add_inverse";
-
-goalw Integ.thy [congruent_def]
- "congruent(intrel, split(%x y. intrel^^{<(y-x) + (x-(y::nat)),0>}))";
-by (safe_tac intrel_cs);
-by (asm_simp_tac intrel_ss 1);
-by (etac rev_mp 1);
-by (res_inst_tac [("m","x1"),("n","y1")] diff_induct 1);
-by (asm_simp_tac (arith_ss addsimps [inj_Suc RS inj_eq]) 3);
-by (asm_simp_tac (arith_ss addsimps [diff_add_inverse,diff_add_0]) 2);
-by (asm_simp_tac arith_ss 1);
-by (rtac impI 1);
-by (etac subst 1);
-by (res_inst_tac [("m1","x")] (add_commute RS ssubst) 1);
-by (asm_simp_tac (arith_ss addsimps [diff_add_inverse,diff_add_0]) 1);
-by (rtac impI 1);
-by (asm_simp_tac (arith_ss addsimps
- [diff_add_inverse, diff_add_0, diff_Suc_add_0,
- diff_Suc_add_inverse]) 1);
-qed "zmagnitude_congruent";
-
-(*Resolve th against the corresponding facts for zmagnitude*)
-val zmagnitude_ize = RSLIST [equiv_intrel, zmagnitude_congruent];
-
-
-goalw Integ.thy [zmagnitude_def]
- "zmagnitude (Abs_Integ(intrel^^{<x,y>})) = \
-\ Abs_Integ(intrel^^{<(y - x) + (x - y),0>})";
-by (res_inst_tac [("f","Abs_Integ")] arg_cong 1);
-by (asm_simp_tac (intrel_ss addsimps [zmagnitude_ize UN_equiv_class]) 1);
-qed "zmagnitude";
-
-goalw Integ.thy [znat_def] "zmagnitude($# n) = $#n";
-by (asm_simp_tac (intrel_ss addsimps [zmagnitude]) 1);
-qed "zmagnitude_znat";
-
-goalw Integ.thy [znat_def] "zmagnitude($~ $# n) = $#n";
-by (asm_simp_tac (intrel_ss addsimps [zmagnitude, zminus]) 1);
-qed "zmagnitude_zminus_znat";
-
-
-(**** zadd: addition on Integ ****)
-
-(** Congruence property for addition **)
-
-goalw Integ.thy [congruent2_def]
- "congruent2(intrel, %p1 p2. \
-\ split(%x1 y1. split(%x2 y2. intrel^^{<x1+x2, y1+y2>},p2),p1))";
-(*Proof via congruent2_commuteI seems longer*)
-by (safe_tac intrel_cs);
-by (asm_simp_tac (intrel_ss addsimps [add_assoc]) 1);
-(*The rest should be trivial, but rearranging terms is hard*)
-by (res_inst_tac [("x1","x1a")] (add_left_commute RS ssubst) 1);
-by (asm_simp_tac (arith_ss addsimps [add_assoc RS sym]) 1);
-by (asm_simp_tac (arith_ss addsimps add_ac) 1);
-qed "zadd_congruent2";
-
-(*Resolve th against the corresponding facts for zadd*)
-val zadd_ize = RSLIST [equiv_intrel, zadd_congruent2];
-
-goalw Integ.thy [zadd_def]
- "Abs_Integ(intrel^^{<x1,y1>}) + Abs_Integ(intrel^^{<x2,y2>}) = \
-\ Abs_Integ(intrel^^{<x1+x2, y1+y2>})";
-by (asm_simp_tac
- (intrel_ss addsimps [zadd_ize UN_equiv_class2]) 1);
-qed "zadd";
-
-goalw Integ.thy [znat_def] "$#0 + z = z";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (asm_simp_tac (arith_ss addsimps [zadd]) 1);
-qed "zadd_0";
-
-goal Integ.thy "$~ (z + w) = $~ z + $~ w";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","w")] eq_Abs_Integ 1);
-by (asm_simp_tac (arith_ss addsimps [zminus,zadd]) 1);
-qed "zminus_zadd_distrib";
-
-goal Integ.thy "(z::int) + w = w + z";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","w")] eq_Abs_Integ 1);
-by (asm_simp_tac (intrel_ss addsimps (add_ac @ [zadd])) 1);
-qed "zadd_commute";
-
-goal Integ.thy "((z1::int) + z2) + z3 = z1 + (z2 + z3)";
-by (res_inst_tac [("z","z1")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","z2")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","z3")] eq_Abs_Integ 1);
-by (asm_simp_tac (arith_ss addsimps [zadd, add_assoc]) 1);
-qed "zadd_assoc";
-
-(*For AC rewriting*)
-goal Integ.thy "(x::int)+(y+z)=y+(x+z)";
-by (rtac (zadd_commute RS trans) 1);
-by (rtac (zadd_assoc RS trans) 1);
-by (rtac (zadd_commute RS arg_cong) 1);
-qed "zadd_left_commute";
-
-(*Integer addition is an AC operator*)
-val zadd_ac = [zadd_assoc,zadd_commute,zadd_left_commute];
-
-goalw Integ.thy [znat_def] "$# (m + n) = ($#m) + ($#n)";
-by (asm_simp_tac (arith_ss addsimps [zadd]) 1);
-qed "znat_add";
-
-goalw Integ.thy [znat_def] "z + ($~ z) = $#0";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (asm_simp_tac (intrel_ss addsimps [zminus, zadd, add_commute]) 1);
-qed "zadd_zminus_inverse";
-
-goal Integ.thy "($~ z) + z = $#0";
-by (rtac (zadd_commute RS trans) 1);
-by (rtac zadd_zminus_inverse 1);
-qed "zadd_zminus_inverse2";
-
-goal Integ.thy "z + $#0 = z";
-by (rtac (zadd_commute RS trans) 1);
-by (rtac zadd_0 1);
-qed "zadd_0_right";
-
-
-(*Need properties of subtraction? Or use $- just as an abbreviation!*)
-
-(**** zmult: multiplication on Integ ****)
-
-(** Congruence property for multiplication **)
-
-goal Integ.thy "((k::nat) + l) + (m + n) = (k + m) + (n + l)";
-by (simp_tac (arith_ss addsimps add_ac) 1);
-qed "zmult_congruent_lemma";
-
-goal Integ.thy
- "congruent2(intrel, %p1 p2. \
-\ split(%x1 y1. split(%x2 y2. \
-\ intrel^^{<x1*x2 + y1*y2, x1*y2 + y1*x2>}, p2), p1))";
-by (rtac (equiv_intrel RS congruent2_commuteI) 1);
-by (safe_tac intrel_cs);
-by (rewtac split_def);
-by (simp_tac (arith_ss addsimps add_ac@mult_ac) 1);
-by (asm_simp_tac (arith_ss addsimps add_ac@mult_ac) 1);
-by (rtac (intrelI RS(equiv_intrel RS equiv_class_eq)) 1);
-by (rtac (zmult_congruent_lemma RS trans) 1);
-by (rtac (zmult_congruent_lemma RS trans RS sym) 1);
-by (rtac (zmult_congruent_lemma RS trans RS sym) 1);
-by (rtac (zmult_congruent_lemma RS trans RS sym) 1);
-by (asm_simp_tac (HOL_ss addsimps [add_mult_distrib RS sym]) 1);
-by (asm_simp_tac (arith_ss addsimps add_ac@mult_ac) 1);
-qed "zmult_congruent2";
-
-(*Resolve th against the corresponding facts for zmult*)
-val zmult_ize = RSLIST [equiv_intrel, zmult_congruent2];
-
-goalw Integ.thy [zmult_def]
- "Abs_Integ((intrel^^{<x1,y1>})) * Abs_Integ((intrel^^{<x2,y2>})) = \
-\ Abs_Integ(intrel ^^ {<x1*x2 + y1*y2, x1*y2 + y1*x2>})";
-by (simp_tac (intrel_ss addsimps [zmult_ize UN_equiv_class2]) 1);
-qed "zmult";
-
-goalw Integ.thy [znat_def] "$#0 * z = $#0";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (asm_simp_tac (arith_ss addsimps [zmult]) 1);
-qed "zmult_0";
-
-goalw Integ.thy [znat_def] "$#Suc(0) * z = z";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (asm_simp_tac (arith_ss addsimps [zmult, add_0_right]) 1);
-qed "zmult_1";
-
-goal Integ.thy "($~ z) * w = $~ (z * w)";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","w")] eq_Abs_Integ 1);
-by (asm_simp_tac (intrel_ss addsimps ([zminus, zmult] @ add_ac)) 1);
-qed "zmult_zminus";
-
-
-goal Integ.thy "($~ z) * ($~ w) = (z * w)";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","w")] eq_Abs_Integ 1);
-by (asm_simp_tac (intrel_ss addsimps ([zminus, zmult] @ add_ac)) 1);
-qed "zmult_zminus_zminus";
-
-goal Integ.thy "(z::int) * w = w * z";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","w")] eq_Abs_Integ 1);
-by (asm_simp_tac (intrel_ss addsimps ([zmult] @ add_ac @ mult_ac)) 1);
-qed "zmult_commute";
-
-goal Integ.thy "z * $# 0 = $#0";
-by (rtac ([zmult_commute, zmult_0] MRS trans) 1);
-qed "zmult_0_right";
-
-goal Integ.thy "z * $#Suc(0) = z";
-by (rtac ([zmult_commute, zmult_1] MRS trans) 1);
-qed "zmult_1_right";
-
-goal Integ.thy "((z1::int) * z2) * z3 = z1 * (z2 * z3)";
-by (res_inst_tac [("z","z1")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","z2")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","z3")] eq_Abs_Integ 1);
-by (asm_simp_tac (intrel_ss addsimps ([zmult] @ add_ac @ mult_ac)) 1);
-qed "zmult_assoc";
-
-(*For AC rewriting*)
-qed_goal "zmult_left_commute" Integ.thy
- "(z1::int)*(z2*z3) = z2*(z1*z3)"
- (fn _ => [rtac (zmult_commute RS trans) 1, rtac (zmult_assoc RS trans) 1,
- rtac (zmult_commute RS arg_cong) 1]);
-
-(*Integer multiplication is an AC operator*)
-val zmult_ac = [zmult_assoc, zmult_commute, zmult_left_commute];
-
-goal Integ.thy "((z1::int) + z2) * w = (z1 * w) + (z2 * w)";
-by (res_inst_tac [("z","z1")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","z2")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","w")] eq_Abs_Integ 1);
-by (asm_simp_tac
- (intrel_ss addsimps ([zadd, zmult, add_mult_distrib] @
- add_ac @ mult_ac)) 1);
-qed "zadd_zmult_distrib";
-
-val zmult_commute'= read_instantiate [("z","w")] zmult_commute;
-
-goal Integ.thy "w * ($~ z) = $~ (w * z)";
-by (simp_tac (HOL_ss addsimps [zmult_commute', zmult_zminus]) 1);
-qed "zmult_zminus_right";
-
-goal Integ.thy "(w::int) * (z1 + z2) = (w * z1) + (w * z2)";
-by (simp_tac (HOL_ss addsimps [zmult_commute',zadd_zmult_distrib]) 1);
-qed "zadd_zmult_distrib2";
-
-val zadd_simps =
- [zadd_0, zadd_0_right, zadd_zminus_inverse, zadd_zminus_inverse2];
-
-val zminus_simps = [zminus_zminus, zminus_0, zminus_zadd_distrib];
-
-val zmult_simps = [zmult_0, zmult_1, zmult_0_right, zmult_1_right,
- zmult_zminus, zmult_zminus_right];
-
-val integ_ss =
- arith_ss addsimps (zadd_simps @ zminus_simps @ zmult_simps @
- [zmagnitude_znat, zmagnitude_zminus_znat]);
-
-
-(**** Additional Theorems (by Mattolini; proofs mainly by lcp) ****)
-
-(* Some Theorems about zsuc and zpred *)
-goalw Integ.thy [zsuc_def] "$#(Suc(n)) = zsuc($# n)";
-by (simp_tac (arith_ss addsimps [znat_add RS sym]) 1);
-qed "znat_Suc";
-
-goalw Integ.thy [zpred_def,zsuc_def,zdiff_def] "$~ zsuc(z) = zpred($~ z)";
-by (simp_tac integ_ss 1);
-qed "zminus_zsuc";
-
-goalw Integ.thy [zpred_def,zsuc_def,zdiff_def] "$~ zpred(z) = zsuc($~ z)";
-by (simp_tac integ_ss 1);
-qed "zminus_zpred";
-
-goalw Integ.thy [zsuc_def,zpred_def,zdiff_def]
- "zpred(zsuc(z)) = z";
-by (simp_tac (integ_ss addsimps [zadd_assoc]) 1);
-qed "zpred_zsuc";
-
-goalw Integ.thy [zsuc_def,zpred_def,zdiff_def]
- "zsuc(zpred(z)) = z";
-by (simp_tac (integ_ss addsimps [zadd_assoc]) 1);
-qed "zsuc_zpred";
-
-goal Integ.thy "(zpred(z)=w) = (z=zsuc(w))";
-by (safe_tac HOL_cs);
-by (rtac (zsuc_zpred RS sym) 1);
-by (rtac zpred_zsuc 1);
-qed "zpred_to_zsuc";
-
-goal Integ.thy "(zsuc(z)=w)=(z=zpred(w))";
-by (safe_tac HOL_cs);
-by (rtac (zpred_zsuc RS sym) 1);
-by (rtac zsuc_zpred 1);
-qed "zsuc_to_zpred";
-
-goal Integ.thy "($~ z = w) = (z = $~ w)";
-by (safe_tac HOL_cs);
-by (rtac (zminus_zminus RS sym) 1);
-by (rtac zminus_zminus 1);
-qed "zminus_exchange";
-
-goal Integ.thy"(zsuc(z)=zsuc(w)) = (z=w)";
-by (safe_tac intrel_cs);
-by (dres_inst_tac [("f","zpred")] arg_cong 1);
-by (asm_full_simp_tac (HOL_ss addsimps [zpred_zsuc]) 1);
-qed "bijective_zsuc";
-
-goal Integ.thy"(zpred(z)=zpred(w)) = (z=w)";
-by (safe_tac intrel_cs);
-by (dres_inst_tac [("f","zsuc")] arg_cong 1);
-by (asm_full_simp_tac (HOL_ss addsimps [zsuc_zpred]) 1);
-qed "bijective_zpred";
-
-(* Additional Theorems about zadd *)
-
-goalw Integ.thy [zsuc_def] "zsuc(z) + w = zsuc(z+w)";
-by (simp_tac (arith_ss addsimps zadd_ac) 1);
-qed "zadd_zsuc";
-
-goalw Integ.thy [zsuc_def] "w + zsuc(z) = zsuc(w+z)";
-by (simp_tac (arith_ss addsimps zadd_ac) 1);
-qed "zadd_zsuc_right";
-
-goalw Integ.thy [zpred_def,zdiff_def] "zpred(z) + w = zpred(z+w)";
-by (simp_tac (arith_ss addsimps zadd_ac) 1);
-qed "zadd_zpred";
-
-goalw Integ.thy [zpred_def,zdiff_def] "w + zpred(z) = zpred(w+z)";
-by (simp_tac (arith_ss addsimps zadd_ac) 1);
-qed "zadd_zpred_right";
-
-
-(* Additional Theorems about zmult *)
-
-goalw Integ.thy [zsuc_def] "zsuc(w) * z = z + w * z";
-by (simp_tac (integ_ss addsimps [zadd_zmult_distrib, zadd_commute]) 1);
-qed "zmult_zsuc";
-
-goalw Integ.thy [zsuc_def] "z * zsuc(w) = z + w * z";
-by (simp_tac
- (integ_ss addsimps [zadd_zmult_distrib2, zadd_commute, zmult_commute]) 1);
-qed "zmult_zsuc_right";
-
-goalw Integ.thy [zpred_def, zdiff_def] "zpred(w) * z = w * z - z";
-by (simp_tac (integ_ss addsimps [zadd_zmult_distrib]) 1);
-qed "zmult_zpred";
-
-goalw Integ.thy [zpred_def, zdiff_def] "z * zpred(w) = w * z - z";
-by (simp_tac (integ_ss addsimps [zadd_zmult_distrib2, zmult_commute]) 1);
-qed "zmult_zpred_right";
-
-(* Further Theorems about zsuc and zpred *)
-goal Integ.thy "$#Suc(m) ~= $#0";
-by (simp_tac (integ_ss addsimps [inj_znat RS inj_eq]) 1);
-qed "znat_Suc_not_znat_Zero";
-
-bind_thm ("znat_Zero_not_znat_Suc", (znat_Suc_not_znat_Zero RS not_sym));
-
-
-goalw Integ.thy [zsuc_def,znat_def] "w ~= zsuc(w)";
-by (res_inst_tac [("z","w")] eq_Abs_Integ 1);
-by (asm_full_simp_tac (intrel_ss addsimps [zadd]) 1);
-qed "n_not_zsuc_n";
-
-val zsuc_n_not_n = n_not_zsuc_n RS not_sym;
-
-goal Integ.thy "w ~= zpred(w)";
-by (safe_tac HOL_cs);
-by (dres_inst_tac [("x","w"),("f","zsuc")] arg_cong 1);
-by (asm_full_simp_tac (HOL_ss addsimps [zsuc_zpred,zsuc_n_not_n]) 1);
-qed "n_not_zpred_n";
-
-val zpred_n_not_n = n_not_zpred_n RS not_sym;
-
-
-(* Theorems about less and less_equal *)
-
-goalw Integ.thy [zless_def, znegative_def, zdiff_def, znat_def]
- "!!w. w<z ==> ? n. z = w + $#(Suc(n))";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","w")] eq_Abs_Integ 1);
-by (safe_tac intrel_cs);
-by (asm_full_simp_tac (intrel_ss addsimps [zadd, zminus]) 1);
-by (safe_tac (intrel_cs addSDs [less_eq_Suc_add]));
-by (res_inst_tac [("x","k")] exI 1);
-by (asm_full_simp_tac (HOL_ss addsimps ([add_Suc RS sym] @ add_ac)) 1);
-(*To cancel x2, rename it to be first!*)
-by (rename_tac "a b c" 1);
-by (asm_full_simp_tac (HOL_ss addsimps (add_left_cancel::add_ac)) 1);
-qed "zless_eq_zadd_Suc";
-
-goalw Integ.thy [zless_def, znegative_def, zdiff_def, znat_def]
- "z < z + $#(Suc(n))";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (safe_tac intrel_cs);
-by (simp_tac (intrel_ss addsimps [zadd, zminus]) 1);
-by (REPEAT_SOME (ares_tac [refl, exI, singletonI, ImageI, conjI, intrelI]));
-by (rtac le_less_trans 1);
-by (rtac lessI 2);
-by (asm_simp_tac (arith_ss addsimps ([le_add1,add_left_cancel_le]@add_ac)) 1);
-qed "zless_zadd_Suc";
-
-goal Integ.thy "!!z1 z2 z3. [| z1<z2; z2<z3 |] ==> z1 < (z3::int)";
-by (safe_tac (HOL_cs addSDs [zless_eq_zadd_Suc]));
-by (simp_tac
- (arith_ss addsimps [zadd_assoc, zless_zadd_Suc, znat_add RS sym]) 1);
-qed "zless_trans";
-
-goalw Integ.thy [zsuc_def] "z<zsuc(z)";
-by (rtac zless_zadd_Suc 1);
-qed "zlessI";
-
-val zless_zsucI = zlessI RSN (2,zless_trans);
-
-goal Integ.thy "!!z w::int. z<w ==> ~w<z";
-by (safe_tac (HOL_cs addSDs [zless_eq_zadd_Suc]));
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (safe_tac intrel_cs);
-by (asm_full_simp_tac (intrel_ss addsimps ([znat_def, zadd])) 1);
-by (asm_full_simp_tac
- (HOL_ss addsimps [add_left_cancel, add_assoc, add_Suc_right RS sym]) 1);
-by (resolve_tac [less_not_refl2 RS notE] 1);
-by (etac sym 2);
-by (REPEAT (resolve_tac [lessI, trans_less_add2, less_SucI] 1));
-qed "zless_not_sym";
-
-(* [| n<m; m<n |] ==> R *)
-bind_thm ("zless_asym", (zless_not_sym RS notE));
-
-goal Integ.thy "!!z::int. ~ z<z";
-by (resolve_tac [zless_asym RS notI] 1);
-by (REPEAT (assume_tac 1));
-qed "zless_not_refl";
-
-(* z<z ==> R *)
-bind_thm ("zless_anti_refl", (zless_not_refl RS notE));
-
-goal Integ.thy "!!w. z<w ==> w ~= (z::int)";
-by(fast_tac (HOL_cs addEs [zless_anti_refl]) 1);
-qed "zless_not_refl2";
-
-
-(*"Less than" is a linear ordering*)
-goalw Integ.thy [zless_def, znegative_def, zdiff_def]
- "z<w | z=w | w<(z::int)";
-by (res_inst_tac [("z","z")] eq_Abs_Integ 1);
-by (res_inst_tac [("z","w")] eq_Abs_Integ 1);
-by (safe_tac intrel_cs);
-by (asm_full_simp_tac
- (intrel_ss addsimps [zadd, zminus, Image_iff, Bex_def]) 1);
-by (res_inst_tac [("m1", "x+ya"), ("n1", "xa+y")] (less_linear RS disjE) 1);
-by (etac disjE 2);
-by (assume_tac 2);
-by (DEPTH_SOLVE
- (swap_res_tac [exI] 1 THEN
- swap_res_tac [exI] 1 THEN
- etac conjI 1 THEN
- simp_tac (arith_ss addsimps add_ac) 1));
-qed "zless_linear";
-
-
-(*** Properties of <= ***)
-
-goalw Integ.thy [zless_def, znegative_def, zdiff_def, znat_def]
- "($#m < $#n) = (m<n)";
-by (simp_tac
- (intrel_ss addsimps [zadd, zminus, Image_iff, Bex_def]) 1);
-by (fast_tac (HOL_cs addIs [add_commute] addSEs [less_add_eq_less]) 1);
-qed "zless_eq_less";
-
-goalw Integ.thy [zle_def, le_def] "($#m <= $#n) = (m<=n)";
-by (simp_tac (HOL_ss addsimps [zless_eq_less]) 1);
-qed "zle_eq_le";
-
-goalw Integ.thy [zle_def] "!!w. ~(w<z) ==> z<=(w::int)";
-by (assume_tac 1);
-qed "zleI";
-
-goalw Integ.thy [zle_def] "!!w. z<=w ==> ~(w<(z::int))";
-by (assume_tac 1);
-qed "zleD";
-
-val zleE = make_elim zleD;
-
-goalw Integ.thy [zle_def] "!!z. ~ z <= w ==> w<(z::int)";
-by (fast_tac HOL_cs 1);
-qed "not_zleE";
-
-goalw Integ.thy [zle_def] "!!z. z < w ==> z <= (w::int)";
-by (fast_tac (HOL_cs addEs [zless_asym]) 1);
-qed "zless_imp_zle";
-
-goalw Integ.thy [zle_def] "!!z. z <= w ==> z < w | z=(w::int)";
-by (cut_facts_tac [zless_linear] 1);
-by (fast_tac (HOL_cs addEs [zless_anti_refl,zless_asym]) 1);
-qed "zle_imp_zless_or_eq";
-
-goalw Integ.thy [zle_def] "!!z. z<w | z=w ==> z <=(w::int)";
-by (cut_facts_tac [zless_linear] 1);
-by (fast_tac (HOL_cs addEs [zless_anti_refl,zless_asym]) 1);
-qed "zless_or_eq_imp_zle";
-
-goal Integ.thy "(x <= (y::int)) = (x < y | x=y)";
-by (REPEAT(ares_tac [iffI, zless_or_eq_imp_zle, zle_imp_zless_or_eq] 1));
-qed "zle_eq_zless_or_eq";
-
-goal Integ.thy "w <= (w::int)";
-by (simp_tac (HOL_ss addsimps [zle_eq_zless_or_eq]) 1);
-qed "zle_refl";
-
-val prems = goal Integ.thy "!!i. [| i <= j; j < k |] ==> i < (k::int)";
-by (dtac zle_imp_zless_or_eq 1);
-by (fast_tac (HOL_cs addIs [zless_trans]) 1);
-qed "zle_zless_trans";
-
-goal Integ.thy "!!i. [| i <= j; j <= k |] ==> i <= (k::int)";
-by (EVERY1 [dtac zle_imp_zless_or_eq, dtac zle_imp_zless_or_eq,
- rtac zless_or_eq_imp_zle, fast_tac (HOL_cs addIs [zless_trans])]);
-qed "zle_trans";
-
-goal Integ.thy "!!z. [| z <= w; w <= z |] ==> z = (w::int)";
-by (EVERY1 [dtac zle_imp_zless_or_eq, dtac zle_imp_zless_or_eq,
- fast_tac (HOL_cs addEs [zless_anti_refl,zless_asym])]);
-qed "zle_anti_sym";
-
-
-goal Integ.thy "!!w w' z::int. z + w' = z + w ==> w' = w";
-by (dres_inst_tac [("f", "%x. x + $~z")] arg_cong 1);
-by (asm_full_simp_tac (integ_ss addsimps zadd_ac) 1);
-qed "zadd_left_cancel";
-
-
-(*** Monotonicity results ***)
-
-goal Integ.thy "!!v w z::int. v < w ==> v + z < w + z";
-by (safe_tac (HOL_cs addSDs [zless_eq_zadd_Suc]));
-by (simp_tac (HOL_ss addsimps zadd_ac) 1);
-by (simp_tac (HOL_ss addsimps [zadd_assoc RS sym, zless_zadd_Suc]) 1);
-qed "zadd_zless_mono1";
-
-goal Integ.thy "!!v w z::int. (v+z < w+z) = (v < w)";
-by (safe_tac (HOL_cs addSEs [zadd_zless_mono1]));
-by (dres_inst_tac [("z", "$~z")] zadd_zless_mono1 1);
-by (asm_full_simp_tac (integ_ss addsimps [zadd_assoc]) 1);
-qed "zadd_left_cancel_zless";
-
-goal Integ.thy "!!v w z::int. (v+z <= w+z) = (v <= w)";
-by (asm_full_simp_tac
- (integ_ss addsimps [zle_def, zadd_left_cancel_zless]) 1);
-qed "zadd_left_cancel_zle";
-
-(*"v<=w ==> v+z <= w+z"*)
-bind_thm ("zadd_zle_mono1", zadd_left_cancel_zle RS iffD2);
-
-
-goal Integ.thy "!!z' z::int. [| w'<=w; z'<=z |] ==> w' + z' <= w + z";
-by (etac (zadd_zle_mono1 RS zle_trans) 1);
-by (simp_tac (HOL_ss addsimps [zadd_commute]) 1);
-(*w moves to the end because it is free while z', z are bound*)
-by (etac zadd_zle_mono1 1);
-qed "zadd_zle_mono";
-
-goal Integ.thy "!!w z::int. z<=$#0 ==> w+z <= w";
-by (dres_inst_tac [("z", "w")] zadd_zle_mono1 1);
-by (asm_full_simp_tac (integ_ss addsimps [zadd_commute]) 1);
-qed "zadd_zle_self";
--- a/Integ/Integ.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,79 +0,0 @@
-(* Title: Integ.thy
- ID: $Id$
- Authors: Riccardo Mattolini, Dip. Sistemi e Informatica
- Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 Universita' di Firenze
- Copyright 1993 University of Cambridge
-
-The integers as equivalence classes over nat*nat.
-*)
-
-Integ = Equiv + Arith +
-consts
- intrel :: "((nat * nat) * (nat * nat)) set"
-
-defs
- intrel_def
- "intrel == {p. ? x1 y1 x2 y2. p=<<x1::nat,y1>,<x2,y2>> & x1+y2 = x2+y1}"
-
-subtype (Integ)
- int = "{x::(nat*nat).True}/intrel" (Equiv.quotient_def)
-
-instance
- int :: {ord, plus, times, minus}
-
-consts
- zNat :: "nat set"
- znat :: "nat => int" ("$# _" [80] 80)
- zminus :: "int => int" ("$~ _" [80] 80)
- znegative :: "int => bool"
- zmagnitude :: "int => int"
- zdiv,zmod :: "[int,int]=>int" (infixl 70)
- zpred,zsuc :: "int=>int"
-
-defs
- zNat_def "zNat == {x::nat. True}"
-
- znat_def "$# m == Abs_Integ(intrel ^^ {<m,0>})"
-
- zminus_def
- "$~ Z == Abs_Integ(UN p:Rep_Integ(Z). split(%x y. intrel^^{<y,x>},p))"
-
- znegative_def
- "znegative(Z) == EX x y. x<y & <x,y::nat>:Rep_Integ(Z)"
-
- zmagnitude_def
- "zmagnitude(Z) == Abs_Integ(UN p:Rep_Integ(Z).split(%x y. intrel^^{<(y-x) + (x-y),0>},p))"
-
- zadd_def
- "Z1 + Z2 ==
- Abs_Integ(UN p1:Rep_Integ(Z1). UN p2:Rep_Integ(Z2).
- split(%x1 y1. split(%x2 y2. intrel^^{<x1+x2, y1+y2>},p2),p1))"
-
- zdiff_def "Z1 - Z2 == Z1 + zminus(Z2)"
-
- zless_def "Z1<Z2 == znegative(Z1 - Z2)"
-
- zle_def "Z1 <= (Z2::int) == ~(Z2 < Z1)"
-
- zmult_def
- "Z1 * Z2 ==
- Abs_Integ(UN p1:Rep_Integ(Z1). UN p2:Rep_Integ(Z2). split(%x1 y1.
- split(%x2 y2. intrel^^{<x1*x2 + y1*y2, x1*y2 + y1*x2>},p2),p1))"
-
- zdiv_def
- "Z1 zdiv Z2 ==
- Abs_Integ(UN p1:Rep_Integ(Z1). UN p2:Rep_Integ(Z2). split(%x1 y1.
- split(%x2 y2. intrel^^{<(x1-y1)div(x2-y2)+(y1-x1)div(y2-x2),
- (x1-y1)div(y2-x2)+(y1-x1)div(x2-y2)>},p2),p1))"
-
- zmod_def
- "Z1 zmod Z2 ==
- Abs_Integ(UN p1:Rep_Integ(Z1).UN p2:Rep_Integ(Z2).split(%x1 y1.
- split(%x2 y2. intrel^^{<(x1-y1)mod((x2-y2)+(y2-x2)),
- (x1-y1)mod((x2-y2)+(x2-y2))>},p2),p1))"
-
- zsuc_def "zsuc(Z) == Z + $# Suc(0)"
-
- zpred_def "zpred(Z) == Z - $# Suc(0)"
-end
--- a/Integ/ROOT.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,14 +0,0 @@
-(* Title: Old_HOL/Integ/ROOT.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1995 University of Cambridge
-
-The Integers in HOL (ported from ZF by Riccardo Mattolini)
-*)
-
-HOL_build_completed; (*Cause examples to fail if HOL did*)
-
-loadpath := ["Integ"];
-time_use_thy "Integ";
-
-make_chart (); (*make HTML chart*)
--- a/Integ/Relation.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,98 +0,0 @@
-(* Title: Relation.ML
- ID: $Id$
- Authors: Riccardo Mattolini, Dip. Sistemi e Informatica
- Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 Universita' di Firenze
- Copyright 1993 University of Cambridge
-
-Functions represented as relations in HOL Set Theory
-*)
-
-val RSLIST = curry (op MRS);
-
-open Relation;
-
-goalw Relation.thy [converse_def] "!!a b r. <a,b>:r ==> <b,a>:converse(r)";
-by (simp_tac prod_ss 1);
-by (fast_tac set_cs 1);
-qed "converseI";
-
-goalw Relation.thy [converse_def] "!!a b r. <a,b> : converse(r) ==> <b,a> : r";
-by (fast_tac comp_cs 1);
-qed "converseD";
-
-qed_goalw "converseE" Relation.thy [converse_def]
- "[| yx : converse(r); \
-\ !!x y. [| yx=<y,x>; <x,y>:r |] ==> P \
-\ |] ==> P"
- (fn [major,minor]=>
- [ (rtac (major RS CollectE) 1),
- (REPEAT (eresolve_tac [bexE,exE, conjE, minor] 1)),
- (hyp_subst_tac 1),
- (assume_tac 1) ]);
-
-val converse_cs = comp_cs addSIs [converseI]
- addSEs [converseD,converseE];
-
-qed_goalw "Domain_iff" Relation.thy [Domain_def]
- "a: Domain(r) = (EX y. <a,y>: r)"
- (fn _=> [ (fast_tac comp_cs 1) ]);
-
-qed_goal "DomainI" Relation.thy "!!a b r. <a,b>: r ==> a: Domain(r)"
- (fn _ => [ (etac (exI RS (Domain_iff RS iffD2)) 1) ]);
-
-qed_goal "DomainE" Relation.thy
- "[| a : Domain(r); !!y. <a,y>: r ==> P |] ==> P"
- (fn prems=>
- [ (rtac (Domain_iff RS iffD1 RS exE) 1),
- (REPEAT (ares_tac prems 1)) ]);
-
-qed_goalw "RangeI" Relation.thy [Range_def] "!!a b r.<a,b>: r ==> b : Range(r)"
- (fn _ => [ (etac (converseI RS DomainI) 1) ]);
-
-qed_goalw "RangeE" Relation.thy [Range_def]
- "[| b : Range(r); !!x. <x,b>: r ==> P |] ==> P"
- (fn major::prems=>
- [ (rtac (major RS DomainE) 1),
- (resolve_tac prems 1),
- (etac converseD 1) ]);
-
-(*** Image of a set under a function/relation ***)
-
-qed_goalw "Image_iff" Relation.thy [Image_def]
- "b : r^^A = (? x:A. <x,b>:r)"
- (fn _ => [ fast_tac (comp_cs addIs [RangeI]) 1 ]);
-
-qed_goal "Image_singleton_iff" Relation.thy
- "(b : r^^{a}) = (<a,b>:r)"
- (fn _ => [ rtac (Image_iff RS trans) 1,
- fast_tac comp_cs 1 ]);
-
-qed_goalw "ImageI" Relation.thy [Image_def]
- "!!a b r. [| <a,b>: r; a:A |] ==> b : r^^A"
- (fn _ => [ (REPEAT (ares_tac [CollectI,RangeI,bexI] 1)),
- (resolve_tac [conjI ] 1),
- (resolve_tac [RangeI] 1),
- (REPEAT (fast_tac set_cs 1))]);
-
-qed_goalw "ImageE" Relation.thy [Image_def]
- "[| b: r^^A; !!x.[| <x,b>: r; x:A |] ==> P |] ==> P"
- (fn major::prems=>
- [ (rtac (major RS CollectE) 1),
- (safe_tac set_cs),
- (etac RangeE 1),
- (rtac (hd prems) 1),
- (REPEAT (etac bexE 1 ORELSE ares_tac prems 1)) ]);
-
-qed_goal "Image_subset" Relation.thy
- "!!A B r. r <= Sigma(A,%x.B) ==> r^^C <= B"
- (fn _ =>
- [ (rtac subsetI 1),
- (REPEAT (eresolve_tac [asm_rl, ImageE, subsetD RS SigmaD2] 1)) ]);
-
-val rel_cs = converse_cs addSIs [converseI]
- addIs [ImageI, DomainI, RangeI]
- addSEs [ImageE, DomainE, RangeE];
-
-val rel_eq_cs = rel_cs addSIs [equalityI];
-
--- a/Integ/Relation.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,24 +0,0 @@
-(* Title: Relation.thy
- ID: $Id$
- Author: Riccardo Mattolini, Dip. Sistemi e Informatica
- and Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 Universita' di Firenze
- Copyright 1993 University of Cambridge
-
-Functions represented as relations in Higher-Order Set Theory
-*)
-
-Relation = Trancl +
-consts
- converse :: "('a*'a) set => ('a*'a) set"
- "^^" :: "[('a*'a) set,'a set] => 'a set" (infixl 90)
- Domain :: "('a*'a) set => 'a set"
- Range :: "('a*'a) set => 'a set"
-
-defs
- converse_def "converse(r) == {z. (? w:r. ? x y. w=<x,y> & z=<y,x>)}"
- Domain_def "Domain(r) == {z. ! x. (z=x --> (? y. <x,y>:r))}"
- Range_def "Range(r) == Domain(converse(r))"
- Image_def "r ^^ s == {y. y:Range(r) & (? x:s. <x,y>:r)}"
-
-end
--- a/Lfp.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,74 +0,0 @@
-(* Title: HOL/lfp.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-For lfp.thy. The Knaster-Tarski Theorem
-*)
-
-open Lfp;
-
-(*** Proof of Knaster-Tarski Theorem ***)
-
-(* lfp(f) is the greatest lower bound of {u. f(u) <= u} *)
-
-val prems = goalw Lfp.thy [lfp_def] "[| f(A) <= A |] ==> lfp(f) <= A";
-by (rtac (CollectI RS Inter_lower) 1);
-by (resolve_tac prems 1);
-qed "lfp_lowerbound";
-
-val prems = goalw Lfp.thy [lfp_def]
- "[| !!u. f(u) <= u ==> A<=u |] ==> A <= lfp(f)";
-by (REPEAT (ares_tac ([Inter_greatest]@prems) 1));
-by (etac CollectD 1);
-qed "lfp_greatest";
-
-val [mono] = goal Lfp.thy "mono(f) ==> f(lfp(f)) <= lfp(f)";
-by (EVERY1 [rtac lfp_greatest, rtac subset_trans,
- rtac (mono RS monoD), rtac lfp_lowerbound, atac, atac]);
-qed "lfp_lemma2";
-
-val [mono] = goal Lfp.thy "mono(f) ==> lfp(f) <= f(lfp(f))";
-by (EVERY1 [rtac lfp_lowerbound, rtac (mono RS monoD),
- rtac lfp_lemma2, rtac mono]);
-qed "lfp_lemma3";
-
-val [mono] = goal Lfp.thy "mono(f) ==> lfp(f) = f(lfp(f))";
-by (REPEAT (resolve_tac [equalityI,lfp_lemma2,lfp_lemma3,mono] 1));
-qed "lfp_Tarski";
-
-
-(*** General induction rule for least fixed points ***)
-
-val [lfp,mono,indhyp] = goal Lfp.thy
- "[| a: lfp(f); mono(f); \
-\ !!x. [| x: f(lfp(f) Int {x.P(x)}) |] ==> P(x) \
-\ |] ==> P(a)";
-by (res_inst_tac [("a","a")] (Int_lower2 RS subsetD RS CollectD) 1);
-by (rtac (lfp RSN (2, lfp_lowerbound RS subsetD)) 1);
-by (EVERY1 [rtac Int_greatest, rtac subset_trans,
- rtac (Int_lower1 RS (mono RS monoD)),
- rtac (mono RS lfp_lemma2),
- rtac (CollectI RS subsetI), rtac indhyp, atac]);
-qed "induct";
-
-(** Definition forms of lfp_Tarski and induct, to control unfolding **)
-
-val [rew,mono] = goal Lfp.thy "[| h==lfp(f); mono(f) |] ==> h = f(h)";
-by (rewtac rew);
-by (rtac (mono RS lfp_Tarski) 1);
-qed "def_lfp_Tarski";
-
-val rew::prems = goal Lfp.thy
- "[| A == lfp(f); mono(f); a:A; \
-\ !!x. [| x: f(A Int {x.P(x)}) |] ==> P(x) \
-\ |] ==> P(a)";
-by (EVERY1 [rtac induct, (*backtracking to force correct induction*)
- REPEAT1 o (ares_tac (map (rewrite_rule [rew]) prems))]);
-qed "def_induct";
-
-(*Monotonicity of lfp!*)
-val [prem] = goal Lfp.thy "[| !!Z. f(Z)<=g(Z) |] ==> lfp(f) <= lfp(g)";
-br (lfp_lowerbound RS lfp_greatest) 1;
-be (prem RS subset_trans) 1;
-qed "lfp_mono";
--- a/Lfp.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,14 +0,0 @@
-(* Title: HOL/lfp.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-The Knaster-Tarski Theorem
-*)
-
-Lfp = mono +
-consts lfp :: "['a set=>'a set] => 'a set"
-defs
- (*least fixed point*)
- lfp_def "lfp(f) == Inter({u. f(u) <= u})"
-end
--- a/List.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,157 +0,0 @@
-(* Title: HOL/List
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-List lemmas
-*)
-
-open List;
-
-val [Nil_not_Cons,Cons_not_Nil] = list.distinct;
-
-bind_thm("Cons_neq_Nil", Cons_not_Nil RS notE);
-bind_thm("Nil_neq_Cons", sym RS Cons_neq_Nil);
-
-bind_thm("Cons_inject", (hd list.inject) RS iffD1 RS conjE);
-
-val list_ss = HOL_ss addsimps list.simps;
-
-goal List.thy "!x. xs ~= x#xs";
-by (list.induct_tac "xs" 1);
-by (ALLGOALS (asm_simp_tac list_ss));
-qed "not_Cons_self";
-
-goal List.thy "(xs ~= []) = (? y ys. xs = y#ys)";
-by (list.induct_tac "xs" 1);
-by(simp_tac list_ss 1);
-by(asm_simp_tac list_ss 1);
-by(REPEAT(resolve_tac [exI,refl,conjI] 1));
-qed "neq_Nil_conv";
-
-val list_ss = arith_ss addsimps list.simps @
- [null_Nil, null_Cons, hd_Cons, tl_Cons, ttl_Nil, ttl_Cons,
- mem_Nil, mem_Cons,
- append_Nil, append_Cons,
- map_Nil, map_Cons,
- flat_Nil, flat_Cons,
- list_all_Nil, list_all_Cons,
- filter_Nil, filter_Cons,
- foldl_Nil, foldl_Cons,
- length_Nil, length_Cons];
-
-
-(** @ - append **)
-
-goal List.thy "(xs@ys)@zs = xs@(ys@zs)";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "append_assoc";
-
-goal List.thy "xs @ [] = xs";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "append_Nil2";
-
-goal List.thy "(xs@ys = []) = (xs=[] & ys=[])";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "append_is_Nil";
-
-goal List.thy "(xs @ ys = xs @ zs) = (ys=zs)";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "same_append_eq";
-
-
-(** mem **)
-
-goal List.thy "x mem (xs@ys) = (x mem xs | x mem ys)";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (list_ss setloop (split_tac [expand_if]))));
-qed "mem_append";
-
-goal List.thy "x mem [x:xs.P(x)] = (x mem xs & P(x))";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (list_ss setloop (split_tac [expand_if]))));
-qed "mem_filter";
-
-(** list_all **)
-
-goal List.thy "(Alls x:xs.True) = True";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "list_all_True";
-
-goal List.thy "list_all(p,xs@ys) = (list_all(p,xs) & list_all(p,ys))";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "list_all_conj";
-
-goal List.thy "(Alls x:xs.P(x)) = (!x. x mem xs --> P(x))";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (list_ss setloop (split_tac [expand_if]))));
-by(fast_tac HOL_cs 1);
-qed "list_all_mem_conv";
-
-
-(** list_case **)
-
-goal List.thy
- "P(list_case(a,f,xs)) = ((xs=[] --> P(a)) & \
-\ (!y ys. xs=y#ys --> P(f(y,ys))))";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-by(fast_tac HOL_cs 1);
-qed "expand_list_case";
-
-goal List.thy "(xs=[] --> P([])) & (!y ys. xs=y#ys --> P(y#ys)) --> P(xs)";
-by(list.induct_tac "xs" 1);
-by(fast_tac HOL_cs 1);
-by(fast_tac HOL_cs 1);
-bind_thm("list_eq_cases",
- impI RSN (2,allI RSN (2,allI RSN (2,impI RS (conjI RS (result() RS mp))))));
-
-(** flat **)
-
-goal List.thy "flat(xs@ys) = flat(xs)@flat(ys)";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (list_ss addsimps [append_assoc])));
-qed"flat_append";
-
-(** length **)
-
-goal List.thy "length(xs@ys) = length(xs)+length(ys)";
-by (list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed"length_append";
-
-(** nth **)
-
-val [nth_0,nth_Suc] = nat_recs nth_def;
-store_thm("nth_0",nth_0);
-store_thm("nth_Suc",nth_Suc);
-
-(** Additional mapping lemmas **)
-
-goal List.thy "map(%x.x, xs) = xs";
-by (list.induct_tac "xs" 1);
-by (ALLGOALS (asm_simp_tac list_ss));
-qed "map_ident";
-
-goal List.thy "map(f, xs@ys) = map(f,xs) @ map(f,ys)";
-by (list.induct_tac "xs" 1);
-by (ALLGOALS (asm_simp_tac list_ss));
-qed "map_append";
-
-goalw List.thy [o_def] "map(f o g, xs) = map(f, map(g, xs))";
-by (list.induct_tac "xs" 1);
-by (ALLGOALS (asm_simp_tac list_ss));
-qed "map_compose";
-
-val list_ss = list_ss addsimps
- [not_Cons_self, append_assoc, append_Nil2, append_is_Nil, same_append_eq,
- mem_append, mem_filter,
- map_ident, map_append, map_compose,
- flat_append, length_append, list_all_True, list_all_conj, nth_0, nth_Suc];
-
--- a/List.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,83 +0,0 @@
-(* Title: HOL/List.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Definition of type 'a list as a datatype. This allows primrec to work.
-
-*)
-
-List = Arith +
-
-datatype 'a list = "[]" ("[]") | "#"('a,'a list) (infixr 65)
-
-consts
-
- null :: "'a list => bool"
- hd :: "'a list => 'a"
- tl,ttl :: "'a list => 'a list"
- mem :: "['a, 'a list] => bool" (infixl 55)
- list_all :: "('a => bool) => ('a list => bool)"
- map :: "('a=>'b) => ('a list => 'b list)"
- "@" :: "['a list, 'a list] => 'a list" (infixr 65)
- filter :: "['a => bool, 'a list] => 'a list"
- foldl :: "[['b,'a] => 'b, 'b, 'a list] => 'b"
- length :: "'a list => nat"
- flat :: "'a list list => 'a list"
- nth :: "[nat, 'a list] => 'a"
-
-syntax
- (* list Enumeration *)
- "@list" :: "args => 'a list" ("[(_)]")
-
- (* Special syntax for list_all and filter *)
- "@Alls" :: "[idt, 'a list, bool] => bool" ("(2Alls _:_./ _)" 10)
- "@filter" :: "[idt, 'a list, bool] => 'a list" ("(1[_:_ ./ _])")
-
-translations
- "[x, xs]" == "x#[xs]"
- "[x]" == "x#[]"
-
- "[x:xs . P]" == "filter(%x.P,xs)"
- "Alls x:xs.P" == "list_all(%x.P,xs)"
-
-primrec null list
- null_Nil "null([]) = True"
- null_Cons "null(x#xs) = False"
-primrec hd list
- hd_Nil "hd([]) = (@x.False)"
- hd_Cons "hd(x#xs) = x"
-primrec tl list
- tl_Nil "tl([]) = (@x.False)"
- tl_Cons "tl(x#xs) = xs"
-primrec ttl list
- (* a "total" version of tl: *)
- ttl_Nil "ttl([]) = []"
- ttl_Cons "ttl(x#xs) = xs"
-primrec "op mem" list
- mem_Nil "x mem [] = False"
- mem_Cons "x mem (y#ys) = if(y=x, True, x mem ys)"
-primrec list_all list
- list_all_Nil "list_all(P,[]) = True"
- list_all_Cons "list_all(P,x#xs) = (P(x) & list_all(P,xs))"
-primrec map list
- map_Nil "map(f,[]) = []"
- map_Cons "map(f,x#xs) = f(x)#map(f,xs)"
-primrec "op @" list
- append_Nil "[] @ ys = ys"
- append_Cons "(x#xs)@ys = x#(xs@ys)"
-primrec filter list
- filter_Nil "filter(P,[]) = []"
- filter_Cons "filter(P,x#xs) = if(P(x), x#filter(P,xs), filter(P,xs))"
-primrec foldl list
- foldl_Nil "foldl(f,a,[]) = a"
- foldl_Cons "foldl(f,a,x#xs) = foldl(f, f(a,x), xs)"
-primrec length list
- length_Nil "length([]) = 0"
- length_Cons "length(x#xs) = Suc(length(xs))"
-primrec flat list
- flat_Nil "flat([]) = []"
- flat_Cons "flat(x#xs) = x @ flat(xs)"
-defs
- nth_def "nth(n) == nat_rec(n, hd, %m r xs. r(tl(xs)))"
-end
--- a/Makefile Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,118 +0,0 @@
-# $Id$
-#########################################################################
-# #
-# Makefile for Isabelle (Old_HOL) #
-# #
-#########################################################################
-
-#To make the system, cd to this directory and type
-# make
-#To make the system and test it on standard examples, type
-# make test
-
-#Environment variable ISABELLECOMP specifies the compiler.
-#Environment variable ISABELLEBIN specifies the destination directory.
-#For Poly/ML, ISABELLEBIN must begin with a /
-
-#Makes pure Isabelle (Pure) if this file is ABSENT -- but not
-#if it is out of date, since this Makefile does not know its dependencies!
-
-BIN = $(ISABELLEBIN)
-COMP = $(ISABELLECOMP)
-NAMES = HOL Ord Set Fun subset equalities Prod Trancl Sum WF \
- mono Lfp Gfp Nat Inductive Finite Arith Sexp Univ List
-
-FILES = ROOT.ML add_ind_def.ML datatype.ML hologic.ML\
- ind_syntax.ML indrule.ML intr_elim.ML simpdata.ML\
- subtype.ML thy_syntax.ML ../Pure/section_utils.ML\
- ../Provers/hypsubst.ML ../Provers/classical.ML\
- ../Provers/simplifier.ML ../Provers/splitter.ML\
- $(NAMES:%=%.thy) $(NAMES:%=%.ML)
-
-$(BIN)/Old_HOL: $(BIN)/Pure $(FILES)
- if [ -d $${ISABELLEBIN:?}/Pure ];\
- then echo Bad value for ISABELLEBIN: \
- $(BIN) is the Isabelle source directory; \
- exit 1; \
- fi;\
- case "$(COMP)" in \
- poly*) echo 'make_database"$(BIN)/Old_HOL"; quit();' \
- | $(COMP) $(BIN)/Pure;\
- if [ "$${MAKE_HTML-undefined}" != "undefined" ]; \
- then echo 'open PolyML; init_html (); exit_use"ROOT";' \
- | $(COMP) $(BIN)/Old_HOL;\
- else echo 'open PolyML; exit_use"ROOT";' \
- | $(COMP) $(BIN)/Old_HOL;\
- fi;;\
- sml*) if [ "$${MAKE_HTML-undefined}" != "undefined" ];\
- then echo 'init_html (); exit_use"ROOT.ML"; xML"$(BIN)/Old_HOL" banner;' | $(BIN)/Pure;\
- else echo 'exit_use"ROOT.ML"; xML"$(BIN)/Old_HOL" banner;' \
- | $(BIN)/Pure;\
- fi;;\
- *) echo Bad value for ISABELLECOMP: \
- $(COMP) is not poly or sml; exit 1;;\
- esac
-
-$(BIN)/Pure:
- cd ../Pure; $(MAKE)
-
-#### Testing of HOL
-
-#A macro referring to the object-logic (depends on ML compiler)
-LOGIC:sh=case $ISABELLECOMP in \
- poly*) echo "$ISABELLECOMP $ISABELLEBIN/Old_HOL" ;;\
- sml*) echo "$ISABELLEBIN/Old_HOL" ;;\
- *) echo "echo Bad value for ISABELLECOMP: \
- $ISABELLEBIN is not poly or sml; exit 1" ;;\
- esac
-
-##IMP-semantics example
-IMP_NAMES = Com Denotation Equiv Properties
-IMP_FILES = IMP/ROOT.ML $(IMP_NAMES:%=IMP/%.thy) $(IMP_NAMES:%=IMP/%.ML)
-
-IMP: $(BIN)/Old_HOL $(IMP_FILES)
- echo 'exit_use"IMP/ROOT.ML";quit();' | $(LOGIC)
-
-##The integers in HOL
-INTEG_NAMES = Relation Equiv Integ
-
-INTEG_FILES = Integ/ROOT.ML \
- $(INTEG_NAMES:%=Integ/%.thy) $(INTEG_NAMES:%=Integ/%.ML)
-
-Integ: $(BIN)/Old_HOL $(INTEG_FILES)
- echo 'exit_use"Integ/ROOT.ML";quit();' | $(LOGIC)
-
-##I/O Automata
-IOA_EX_NAMES = Action Channels Correctness Impl Lemmas Multiset Receiver Sender
-IOA_MT_NAMES = Asig IOA Option Solve
-
-IOA_FILES = IOA/ROOT.ML IOA/example/Packet.thy IOA/example/Spec.thy\
- $(IOA_EX_NAMES:%=IOA/example/%.thy) $(IOA_EX_NAMES:%=IOA/example/%.ML)\
- $(IOA_MT_NAMES:%=IOA/meta_theory/%.thy) $(IOA_MT_NAMES:%=IOA/meta_theory/%.ML)
-
-IOA: $(BIN)/Old_HOL $(IOA_FILES)
- echo 'exit_use"IOA/ROOT.ML";quit();' | $(LOGIC)
-
-##Properties of substitutions
-SUBST_NAMES = AList Setplus Subst Unifier UTerm UTLemmas
-
-SUBST_FILES = Subst/ROOT.ML \
- $(SUBST_NAMES:%=Subst/%.thy) $(SUBST_NAMES:%=Subst/%.ML)
-
-Subst: $(BIN)/Old_HOL $(SUBST_FILES)
- echo 'exit_use"Subst/ROOT.ML";quit();' | $(LOGIC)
-
-##Miscellaneous examples
-EX_NAMES = LexProd MT Acc PropLog Puzzle Qsort LList Rec Simult Term String
-
-EX_FILES = ex/ROOT.ML ex/cla.ML ex/meson.ML ex/mesontest.ML ex/rel.ML \
- ex/set.ML $(EX_NAMES:%=ex/%.thy) $(EX_NAMES:%=ex/%.ML)
-
-ex: $(BIN)/Old_HOL $(EX_FILES)
- echo 'exit_use"ex/ROOT.ML";quit();' | $(LOGIC)
-
-#Full test.
-test: $(BIN)/Old_HOL IMP Integ IOA Subst ex
- echo 'Test examples ran successfully' > test
-
-.PRECIOUS: $(BIN)/Pure $(BIN)/Old_HOL
--- a/Nat.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,437 +0,0 @@
-(* Title: HOL/nat
- ID: $Id$
- Author: Tobias Nipkow, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-For nat.thy. Type nat is defined as a set (Nat) over the type ind.
-*)
-
-open Nat;
-
-goal Nat.thy "mono(%X. {Zero_Rep} Un (Suc_Rep``X))";
-by (REPEAT (ares_tac [monoI, subset_refl, image_mono, Un_mono] 1));
-qed "Nat_fun_mono";
-
-val Nat_unfold = Nat_fun_mono RS (Nat_def RS def_lfp_Tarski);
-
-(* Zero is a natural number -- this also justifies the type definition*)
-goal Nat.thy "Zero_Rep: Nat";
-by (rtac (Nat_unfold RS ssubst) 1);
-by (rtac (singletonI RS UnI1) 1);
-qed "Zero_RepI";
-
-val prems = goal Nat.thy "i: Nat ==> Suc_Rep(i) : Nat";
-by (rtac (Nat_unfold RS ssubst) 1);
-by (rtac (imageI RS UnI2) 1);
-by (resolve_tac prems 1);
-qed "Suc_RepI";
-
-(*** Induction ***)
-
-val major::prems = goal Nat.thy
- "[| i: Nat; P(Zero_Rep); \
-\ !!j. [| j: Nat; P(j) |] ==> P(Suc_Rep(j)) |] ==> P(i)";
-by (rtac ([Nat_def, Nat_fun_mono, major] MRS def_induct) 1);
-by (fast_tac (set_cs addIs prems) 1);
-qed "Nat_induct";
-
-val prems = goalw Nat.thy [Zero_def,Suc_def]
- "[| P(0); \
-\ !!k. P(k) ==> P(Suc(k)) |] ==> P(n)";
-by (rtac (Rep_Nat_inverse RS subst) 1); (*types force good instantiation*)
-by (rtac (Rep_Nat RS Nat_induct) 1);
-by (REPEAT (ares_tac prems 1
- ORELSE eresolve_tac [Abs_Nat_inverse RS subst] 1));
-qed "nat_induct";
-
-(*Perform induction on n. *)
-fun nat_ind_tac a i =
- EVERY [res_inst_tac [("n",a)] nat_induct i,
- rename_last_tac a ["1"] (i+1)];
-
-(*A special form of induction for reasoning about m<n and m-n*)
-val prems = goal Nat.thy
- "[| !!x. P(x,0); \
-\ !!y. P(0,Suc(y)); \
-\ !!x y. [| P(x,y) |] ==> P(Suc(x),Suc(y)) \
-\ |] ==> P(m,n)";
-by (res_inst_tac [("x","m")] spec 1);
-by (nat_ind_tac "n" 1);
-by (rtac allI 2);
-by (nat_ind_tac "x" 2);
-by (REPEAT (ares_tac (prems@[allI]) 1 ORELSE etac spec 1));
-qed "diff_induct";
-
-(*Case analysis on the natural numbers*)
-val prems = goal Nat.thy
- "[| n=0 ==> P; !!x. n = Suc(x) ==> P |] ==> P";
-by (subgoal_tac "n=0 | (EX x. n = Suc(x))" 1);
-by (fast_tac (HOL_cs addSEs prems) 1);
-by (nat_ind_tac "n" 1);
-by (rtac (refl RS disjI1) 1);
-by (fast_tac HOL_cs 1);
-qed "natE";
-
-(*** Isomorphisms: Abs_Nat and Rep_Nat ***)
-
-(*We can't take these properties as axioms, or take Abs_Nat==Inv(Rep_Nat),
- since we assume the isomorphism equations will one day be given by Isabelle*)
-
-goal Nat.thy "inj(Rep_Nat)";
-by (rtac inj_inverseI 1);
-by (rtac Rep_Nat_inverse 1);
-qed "inj_Rep_Nat";
-
-goal Nat.thy "inj_onto(Abs_Nat,Nat)";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_Nat_inverse 1);
-qed "inj_onto_Abs_Nat";
-
-(*** Distinctness of constructors ***)
-
-goalw Nat.thy [Zero_def,Suc_def] "Suc(m) ~= 0";
-by (rtac (inj_onto_Abs_Nat RS inj_onto_contraD) 1);
-by (rtac Suc_Rep_not_Zero_Rep 1);
-by (REPEAT (resolve_tac [Rep_Nat, Suc_RepI, Zero_RepI] 1));
-qed "Suc_not_Zero";
-
-bind_thm ("Zero_not_Suc", (Suc_not_Zero RS not_sym));
-
-bind_thm ("Suc_neq_Zero", (Suc_not_Zero RS notE));
-val Zero_neq_Suc = sym RS Suc_neq_Zero;
-
-(** Injectiveness of Suc **)
-
-goalw Nat.thy [Suc_def] "inj(Suc)";
-by (rtac injI 1);
-by (dtac (inj_onto_Abs_Nat RS inj_ontoD) 1);
-by (REPEAT (resolve_tac [Rep_Nat, Suc_RepI] 1));
-by (dtac (inj_Suc_Rep RS injD) 1);
-by (etac (inj_Rep_Nat RS injD) 1);
-qed "inj_Suc";
-
-val Suc_inject = inj_Suc RS injD;;
-
-goal Nat.thy "(Suc(m)=Suc(n)) = (m=n)";
-by (EVERY1 [rtac iffI, etac Suc_inject, etac arg_cong]);
-qed "Suc_Suc_eq";
-
-goal Nat.thy "n ~= Suc(n)";
-by (nat_ind_tac "n" 1);
-by (ALLGOALS(asm_simp_tac (HOL_ss addsimps [Zero_not_Suc,Suc_Suc_eq])));
-qed "n_not_Suc_n";
-
-val Suc_n_not_n = n_not_Suc_n RS not_sym;
-
-(*** nat_case -- the selection operator for nat ***)
-
-goalw Nat.thy [nat_case_def] "nat_case(a, f, 0) = a";
-by (fast_tac (set_cs addIs [select_equality] addEs [Zero_neq_Suc]) 1);
-qed "nat_case_0";
-
-goalw Nat.thy [nat_case_def] "nat_case(a, f, Suc(k)) = f(k)";
-by (fast_tac (set_cs addIs [select_equality]
- addEs [make_elim Suc_inject, Suc_neq_Zero]) 1);
-qed "nat_case_Suc";
-
-(** Introduction rules for 'pred_nat' **)
-
-goalw Nat.thy [pred_nat_def] "<n, Suc(n)> : pred_nat";
-by (fast_tac set_cs 1);
-qed "pred_natI";
-
-val major::prems = goalw Nat.thy [pred_nat_def]
- "[| p : pred_nat; !!x n. [| p = <n, Suc(n)> |] ==> R \
-\ |] ==> R";
-by (rtac (major RS CollectE) 1);
-by (REPEAT (eresolve_tac ([asm_rl,exE]@prems) 1));
-qed "pred_natE";
-
-goalw Nat.thy [wf_def] "wf(pred_nat)";
-by (strip_tac 1);
-by (nat_ind_tac "x" 1);
-by (fast_tac (HOL_cs addSEs [mp, pred_natE, Pair_inject,
- make_elim Suc_inject]) 2);
-by (fast_tac (HOL_cs addSEs [mp, pred_natE, Pair_inject, Zero_neq_Suc]) 1);
-qed "wf_pred_nat";
-
-
-(*** nat_rec -- by wf recursion on pred_nat ***)
-
-bind_thm ("nat_rec_unfold", (wf_pred_nat RS (nat_rec_def RS def_wfrec)));
-
-(** conversion rules **)
-
-goal Nat.thy "nat_rec(0,c,h) = c";
-by (rtac (nat_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps [nat_case_0]) 1);
-qed "nat_rec_0";
-
-goal Nat.thy "nat_rec(Suc(n), c, h) = h(n, nat_rec(n,c,h))";
-by (rtac (nat_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps [nat_case_Suc, pred_natI, cut_apply]) 1);
-qed "nat_rec_Suc";
-
-(*These 2 rules ease the use of primitive recursion. NOTE USE OF == *)
-val [rew] = goal Nat.thy
- "[| !!n. f(n) == nat_rec(n,c,h) |] ==> f(0) = c";
-by (rewtac rew);
-by (rtac nat_rec_0 1);
-qed "def_nat_rec_0";
-
-val [rew] = goal Nat.thy
- "[| !!n. f(n) == nat_rec(n,c,h) |] ==> f(Suc(n)) = h(n,f(n))";
-by (rewtac rew);
-by (rtac nat_rec_Suc 1);
-qed "def_nat_rec_Suc";
-
-fun nat_recs def =
- [standard (def RS def_nat_rec_0),
- standard (def RS def_nat_rec_Suc)];
-
-
-(*** Basic properties of "less than" ***)
-
-(** Introduction properties **)
-
-val prems = goalw Nat.thy [less_def] "[| i<j; j<k |] ==> i<(k::nat)";
-by (rtac (trans_trancl RS transD) 1);
-by (resolve_tac prems 1);
-by (resolve_tac prems 1);
-qed "less_trans";
-
-goalw Nat.thy [less_def] "n < Suc(n)";
-by (rtac (pred_natI RS r_into_trancl) 1);
-qed "lessI";
-
-(* i<j ==> i<Suc(j) *)
-val less_SucI = lessI RSN (2, less_trans);
-
-goal Nat.thy "0 < Suc(n)";
-by (nat_ind_tac "n" 1);
-by (rtac lessI 1);
-by (etac less_trans 1);
-by (rtac lessI 1);
-qed "zero_less_Suc";
-
-(** Elimination properties **)
-
-val prems = goalw Nat.thy [less_def] "n<m ==> ~ m<(n::nat)";
-by(fast_tac (HOL_cs addIs ([wf_pred_nat, wf_trancl RS wf_asym]@prems))1);
-qed "less_not_sym";
-
-(* [| n<m; m<n |] ==> R *)
-bind_thm ("less_asym", (less_not_sym RS notE));
-
-goalw Nat.thy [less_def] "~ n<(n::nat)";
-by (rtac notI 1);
-by (etac (wf_pred_nat RS wf_trancl RS wf_anti_refl) 1);
-qed "less_not_refl";
-
-(* n<n ==> R *)
-bind_thm ("less_anti_refl", (less_not_refl RS notE));
-
-goal Nat.thy "!!m. n<m ==> m ~= (n::nat)";
-by(fast_tac (HOL_cs addEs [less_anti_refl]) 1);
-qed "less_not_refl2";
-
-
-val major::prems = goalw Nat.thy [less_def]
- "[| i<k; k=Suc(i) ==> P; !!j. [| i<j; k=Suc(j) |] ==> P \
-\ |] ==> P";
-by (rtac (major RS tranclE) 1);
-by (REPEAT_FIRST (bound_hyp_subst_tac ORELSE'
- eresolve_tac (prems@[pred_natE, Pair_inject])));
-by (rtac refl 1);
-qed "lessE";
-
-goal Nat.thy "~ n<0";
-by (rtac notI 1);
-by (etac lessE 1);
-by (etac Zero_neq_Suc 1);
-by (etac Zero_neq_Suc 1);
-qed "not_less0";
-
-(* n<0 ==> R *)
-bind_thm ("less_zeroE", (not_less0 RS notE));
-
-val [major,less,eq] = goal Nat.thy
- "[| m < Suc(n); m<n ==> P; m=n ==> P |] ==> P";
-by (rtac (major RS lessE) 1);
-by (rtac eq 1);
-by (fast_tac (HOL_cs addSDs [Suc_inject]) 1);
-by (rtac less 1);
-by (fast_tac (HOL_cs addSDs [Suc_inject]) 1);
-qed "less_SucE";
-
-goal Nat.thy "(m < Suc(n)) = (m < n | m = n)";
-by (fast_tac (HOL_cs addSIs [lessI]
- addEs [less_trans, less_SucE]) 1);
-qed "less_Suc_eq";
-
-
-(** Inductive (?) properties **)
-
-val [prem] = goal Nat.thy "Suc(m) < n ==> m<n";
-by (rtac (prem RS rev_mp) 1);
-by (nat_ind_tac "n" 1);
-by (rtac impI 1);
-by (etac less_zeroE 1);
-by (fast_tac (HOL_cs addSIs [lessI RS less_SucI]
- addSDs [Suc_inject]
- addEs [less_trans, lessE]) 1);
-qed "Suc_lessD";
-
-val [major,minor] = goal Nat.thy
- "[| Suc(i)<k; !!j. [| i<j; k=Suc(j) |] ==> P \
-\ |] ==> P";
-by (rtac (major RS lessE) 1);
-by (etac (lessI RS minor) 1);
-by (etac (Suc_lessD RS minor) 1);
-by (assume_tac 1);
-qed "Suc_lessE";
-
-val [major] = goal Nat.thy "Suc(m) < Suc(n) ==> m<n";
-by (rtac (major RS lessE) 1);
-by (REPEAT (rtac lessI 1
- ORELSE eresolve_tac [make_elim Suc_inject, ssubst, Suc_lessD] 1));
-qed "Suc_less_SucD";
-
-val prems = goal Nat.thy "m<n ==> Suc(m) < Suc(n)";
-by (subgoal_tac "m<n --> Suc(m) < Suc(n)" 1);
-by (fast_tac (HOL_cs addIs prems) 1);
-by (nat_ind_tac "n" 1);
-by (rtac impI 1);
-by (etac less_zeroE 1);
-by (fast_tac (HOL_cs addSIs [lessI]
- addSDs [Suc_inject]
- addEs [less_trans, lessE]) 1);
-qed "Suc_mono";
-
-goal Nat.thy "(Suc(m) < Suc(n)) = (m<n)";
-by (EVERY1 [rtac iffI, etac Suc_less_SucD, etac Suc_mono]);
-qed "Suc_less_eq";
-
-goal Nat.thy "~(Suc(n) < n)";
-by(fast_tac (HOL_cs addEs [Suc_lessD RS less_anti_refl]) 1);
-qed "not_Suc_n_less_n";
-
-(*"Less than" is a linear ordering*)
-goal Nat.thy "m<n | m=n | n<(m::nat)";
-by (nat_ind_tac "m" 1);
-by (nat_ind_tac "n" 1);
-by (rtac (refl RS disjI1 RS disjI2) 1);
-by (rtac (zero_less_Suc RS disjI1) 1);
-by (fast_tac (HOL_cs addIs [lessI, Suc_mono, less_SucI] addEs [lessE]) 1);
-qed "less_linear";
-
-(*Can be used with less_Suc_eq to get n=m | n<m *)
-goal Nat.thy "(~ m < n) = (n < Suc(m))";
-by (res_inst_tac [("m","m"),("n","n")] diff_induct 1);
-by(ALLGOALS(asm_simp_tac (HOL_ss addsimps
- [not_less0,zero_less_Suc,Suc_less_eq])));
-qed "not_less_eq";
-
-(*Complete induction, aka course-of-values induction*)
-val prems = goalw Nat.thy [less_def]
- "[| !!n. [| ! m::nat. m<n --> P(m) |] ==> P(n) |] ==> P(n)";
-by (wf_ind_tac "n" [wf_pred_nat RS wf_trancl] 1);
-by (eresolve_tac prems 1);
-qed "less_induct";
-
-
-(*** Properties of <= ***)
-
-goalw Nat.thy [le_def] "0 <= n";
-by (rtac not_less0 1);
-qed "le0";
-
-val nat_simps = [not_less0, less_not_refl, zero_less_Suc, lessI,
- Suc_less_eq, less_Suc_eq, le0, not_Suc_n_less_n,
- Suc_not_Zero, Zero_not_Suc, Suc_Suc_eq,
- n_not_Suc_n, Suc_n_not_n,
- nat_case_0, nat_case_Suc, nat_rec_0, nat_rec_Suc];
-
-val nat_ss0 = sum_ss addsimps nat_simps;
-
-(*Prevents simplification of f and g: much faster*)
-qed_goal "nat_case_weak_cong" Nat.thy
- "m=n ==> nat_case(a,f,m) = nat_case(a,f,n)"
- (fn [prem] => [rtac (prem RS arg_cong) 1]);
-
-qed_goal "nat_rec_weak_cong" Nat.thy
- "m=n ==> nat_rec(m,a,f) = nat_rec(n,a,f)"
- (fn [prem] => [rtac (prem RS arg_cong) 1]);
-
-val prems = goalw Nat.thy [le_def] "~(n<m) ==> m<=(n::nat)";
-by (resolve_tac prems 1);
-qed "leI";
-
-val prems = goalw Nat.thy [le_def] "m<=n ==> ~(n<(m::nat))";
-by (resolve_tac prems 1);
-qed "leD";
-
-val leE = make_elim leD;
-
-goalw Nat.thy [le_def] "!!m. ~ m <= n ==> n<(m::nat)";
-by (fast_tac HOL_cs 1);
-qed "not_leE";
-
-goalw Nat.thy [le_def] "!!m. m < n ==> Suc(m) <= n";
-by(simp_tac nat_ss0 1);
-by (fast_tac (HOL_cs addEs [less_anti_refl,less_asym]) 1);
-qed "lessD";
-
-goalw Nat.thy [le_def] "!!m. Suc(m) <= n ==> m <= n";
-by(asm_full_simp_tac nat_ss0 1);
-by(fast_tac HOL_cs 1);
-qed "Suc_leD";
-
-goalw Nat.thy [le_def] "!!m. m < n ==> m <= (n::nat)";
-by (fast_tac (HOL_cs addEs [less_asym]) 1);
-qed "less_imp_le";
-
-goalw Nat.thy [le_def] "!!m. m <= n ==> m < n | m=(n::nat)";
-by (cut_facts_tac [less_linear] 1);
-by (fast_tac (HOL_cs addEs [less_anti_refl,less_asym]) 1);
-qed "le_imp_less_or_eq";
-
-goalw Nat.thy [le_def] "!!m. m<n | m=n ==> m <=(n::nat)";
-by (cut_facts_tac [less_linear] 1);
-by (fast_tac (HOL_cs addEs [less_anti_refl,less_asym]) 1);
-by (flexflex_tac);
-qed "less_or_eq_imp_le";
-
-goal Nat.thy "(x <= (y::nat)) = (x < y | x=y)";
-by (REPEAT(ares_tac [iffI,less_or_eq_imp_le,le_imp_less_or_eq] 1));
-qed "le_eq_less_or_eq";
-
-goal Nat.thy "n <= (n::nat)";
-by(simp_tac (HOL_ss addsimps [le_eq_less_or_eq]) 1);
-qed "le_refl";
-
-val prems = goal Nat.thy "!!i. [| i <= j; j < k |] ==> i < (k::nat)";
-by (dtac le_imp_less_or_eq 1);
-by (fast_tac (HOL_cs addIs [less_trans]) 1);
-qed "le_less_trans";
-
-goal Nat.thy "!!i. [| i < j; j <= k |] ==> i < (k::nat)";
-by (dtac le_imp_less_or_eq 1);
-by (fast_tac (HOL_cs addIs [less_trans]) 1);
-qed "less_le_trans";
-
-goal Nat.thy "!!i. [| i <= j; j <= k |] ==> i <= (k::nat)";
-by (EVERY1[dtac le_imp_less_or_eq, dtac le_imp_less_or_eq,
- rtac less_or_eq_imp_le, fast_tac (HOL_cs addIs [less_trans])]);
-qed "le_trans";
-
-val prems = goal Nat.thy "!!m. [| m <= n; n <= m |] ==> m = (n::nat)";
-by (EVERY1[dtac le_imp_less_or_eq, dtac le_imp_less_or_eq,
- fast_tac (HOL_cs addEs [less_anti_refl,less_asym])]);
-qed "le_anti_sym";
-
-goal Nat.thy "(Suc(n) <= Suc(m)) = (n <= m)";
-by (simp_tac (nat_ss0 addsimps [le_eq_less_or_eq]) 1);
-qed "Suc_le_mono";
-
-val nat_ss = nat_ss0 addsimps [le_refl,Suc_le_mono];
--- a/Nat.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,70 +0,0 @@
-(* Title: HOL/Nat.thy
- ID: $Id$
- Author: Tobias Nipkow, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-Definition of types ind and nat.
-
-Type nat is defined as a set Nat over type ind.
-*)
-
-Nat = WF +
-
-(** type ind **)
-
-types
- ind
-
-arities
- ind :: term
-
-consts
- Zero_Rep :: "ind"
- Suc_Rep :: "ind => ind"
-
-rules
- (*the axiom of infinity in 2 parts*)
- inj_Suc_Rep "inj(Suc_Rep)"
- Suc_Rep_not_Zero_Rep "Suc_Rep(x) ~= Zero_Rep"
-
-
-
-(** type nat **)
-
-(* type definition *)
-
-subtype (Nat)
- nat = "lfp(%X. {Zero_Rep} Un (Suc_Rep``X))" (lfp_def)
-
-instance
- nat :: ord
-
-
-(* abstract constants and syntax *)
-
-consts
- "0" :: "nat" ("0")
- Suc :: "nat => nat"
- nat_case :: "['a, nat => 'a, nat] => 'a"
- pred_nat :: "(nat * nat) set"
- nat_rec :: "[nat, 'a, [nat, 'a] => 'a] => 'a"
-
-translations
- "case p of 0 => a | Suc(y) => b" == "nat_case(a, %y.b, p)"
-
-defs
- Zero_def "0 == Abs_Nat(Zero_Rep)"
- Suc_def "Suc == (%n. Abs_Nat(Suc_Rep(Rep_Nat(n))))"
-
- (*nat operations and recursion*)
- nat_case_def "nat_case(a, f, n) == @z. (n=0 --> z=a)
- & (!x. n=Suc(x) --> z=f(x))"
- pred_nat_def "pred_nat == {p. ? n. p = <n, Suc(n)>}"
-
- less_def "m<n == <m,n>:trancl(pred_nat)"
-
- le_def "m<=(n::nat) == ~(n<m)"
-
- nat_rec_def "nat_rec(n, c, d) == wfrec(pred_nat, n,
- nat_case(%g.c, %m g. d(m, g(m))))"
-end
--- a/Ord.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,21 +0,0 @@
-(* Title: HOL/Ord.ML
- ID: $Id$
- Author: Tobias Nipkow, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-The type class for ordered types
-*)
-
-open Ord;
-
-val [prem] = goalw Ord.thy [mono_def]
- "[| !!A B. A <= B ==> f(A) <= f(B) |] ==> mono(f)";
-by (REPEAT (ares_tac [allI, impI, prem] 1));
-qed "monoI";
-
-val [major,minor] = goalw Ord.thy [mono_def]
- "[| mono(f); A <= B |] ==> f(A) <= f(B)";
-by (rtac (major RS spec RS spec RS mp) 1);
-by (rtac minor 1);
-qed "monoD";
-
--- a/Ord.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,25 +0,0 @@
-(* Title: HOL/Ord.thy
- ID: $Id$
- Author: Tobias Nipkow, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-The type class for ordered types (* FIXME improve comment *)
-*)
-
-Ord = HOL +
-
-axclass
- ord < term
-
-consts
- "<", "<=" :: "['a::ord, 'a] => bool" (infixl 50)
- mono :: "['a::ord => 'b::ord] => bool" (*monotonicity*)
- min, max :: "['a::ord, 'a] => 'a"
-
-defs
- mono_def "mono(f) == (!A B. A <= B --> f(A) <= f(B))"
- min_def "min(a, b) == if(a <= b, a, b)"
- max_def "max(a, b) == if(a <= b, b, a)"
-
-end
-
--- a/Prod.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,237 +0,0 @@
-(* Title: HOL/prod
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-For prod.thy. Ordered Pairs, the Cartesian product type, the unit type
-*)
-
-open Prod;
-
-(*This counts as a non-emptiness result for admitting 'a * 'b as a type*)
-goalw Prod.thy [Prod_def] "Pair_Rep(a,b) : Prod";
-by (EVERY1 [rtac CollectI, rtac exI, rtac exI, rtac refl]);
-qed "ProdI";
-
-val [major] = goalw Prod.thy [Pair_Rep_def]
- "Pair_Rep(a, b) = Pair_Rep(a',b') ==> a=a' & b=b'";
-by (EVERY1 [rtac (major RS fun_cong RS fun_cong RS subst),
- rtac conjI, rtac refl, rtac refl]);
-qed "Pair_Rep_inject";
-
-goal Prod.thy "inj_onto(Abs_Prod,Prod)";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_Prod_inverse 1);
-qed "inj_onto_Abs_Prod";
-
-val prems = goalw Prod.thy [Pair_def]
- "[| <a, b> = <a',b'>; [| a=a'; b=b' |] ==> R |] ==> R";
-by (rtac (inj_onto_Abs_Prod RS inj_ontoD RS Pair_Rep_inject RS conjE) 1);
-by (REPEAT (ares_tac (prems@[ProdI]) 1));
-qed "Pair_inject";
-
-goal Prod.thy "(<a,b> = <a',b'>) = (a=a' & b=b')";
-by (fast_tac (set_cs addIs [Pair_inject]) 1);
-qed "Pair_eq";
-
-goalw Prod.thy [fst_def] "fst(<a,b>) = a";
-by (fast_tac (set_cs addIs [select_equality] addSEs [Pair_inject]) 1);
-qed "fst_conv";
-
-goalw Prod.thy [snd_def] "snd(<a,b>) = b";
-by (fast_tac (set_cs addIs [select_equality] addSEs [Pair_inject]) 1);
-qed "snd_conv";
-
-goalw Prod.thy [Pair_def] "? x y. p = <x,y>";
-by (rtac (rewrite_rule [Prod_def] Rep_Prod RS CollectE) 1);
-by (EVERY1[etac exE, etac exE, rtac exI, rtac exI,
- rtac (Rep_Prod_inverse RS sym RS trans), etac arg_cong]);
-qed "PairE_lemma";
-
-val [prem] = goal Prod.thy "[| !!x y. p = <x,y> ==> Q |] ==> Q";
-by (rtac (PairE_lemma RS exE) 1);
-by (REPEAT (eresolve_tac [prem,exE] 1));
-qed "PairE";
-
-goalw Prod.thy [split_def] "split(c, <a,b>) = c(a,b)";
-by (sstac [fst_conv, snd_conv] 1);
-by (rtac refl 1);
-qed "split";
-
-val prod_ss = set_ss addsimps [fst_conv, snd_conv, split, Pair_eq];
-
-goal Prod.thy "(s=t) = (fst(s)=fst(t) & snd(s)=snd(t))";
-by (res_inst_tac[("p","s")] PairE 1);
-by (res_inst_tac[("p","t")] PairE 1);
-by (asm_simp_tac prod_ss 1);
-qed "Pair_fst_snd_eq";
-
-(*Prevents simplification of c: much faster*)
-qed_goal "split_weak_cong" Prod.thy
- "p=q ==> split(c,p) = split(c,q)"
- (fn [prem] => [rtac (prem RS arg_cong) 1]);
-
-(* Do not add as rewrite rule: invalidates some proofs in IMP *)
-goal Prod.thy "p = <fst(p),snd(p)>";
-by (res_inst_tac [("p","p")] PairE 1);
-by (asm_simp_tac prod_ss 1);
-qed "surjective_pairing";
-
-goal Prod.thy "p = split(%x y.<x,y>, p)";
-by (res_inst_tac [("p","p")] PairE 1);
-by (asm_simp_tac prod_ss 1);
-qed "surjective_pairing2";
-
-(*For use with split_tac and the simplifier*)
-goal Prod.thy "R(split(c,p)) = (! x y. p = <x,y> --> R(c(x,y)))";
-by (stac surjective_pairing 1);
-by (stac split 1);
-by (fast_tac (HOL_cs addSEs [Pair_inject]) 1);
-qed "expand_split";
-
-(** split used as a logical connective or set former **)
-
-(*These rules are for use with fast_tac.
- Could instead call simp_tac/asm_full_simp_tac using split as rewrite.*)
-
-goal Prod.thy "!!a b c. c(a,b) ==> split(c, <a,b>)";
-by (asm_simp_tac prod_ss 1);
-qed "splitI";
-
-val prems = goalw Prod.thy [split_def]
- "[| split(c,p); !!x y. [| p = <x,y>; c(x,y) |] ==> Q |] ==> Q";
-by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
-qed "splitE";
-
-goal Prod.thy "!!R a b. split(R,<a,b>) ==> R(a,b)";
-by (etac (split RS iffD1) 1);
-qed "splitD";
-
-goal Prod.thy "!!a b c. z: c(a,b) ==> z: split(c, <a,b>)";
-by (asm_simp_tac prod_ss 1);
-qed "mem_splitI";
-
-val prems = goalw Prod.thy [split_def]
- "[| z: split(c,p); !!x y. [| p = <x,y>; z: c(x,y) |] ==> Q |] ==> Q";
-by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1));
-qed "mem_splitE";
-
-(*** prod_fun -- action of the product functor upon functions ***)
-
-goalw Prod.thy [prod_fun_def] "prod_fun(f,g,<a,b>) = <f(a),g(b)>";
-by (rtac split 1);
-qed "prod_fun";
-
-goal Prod.thy
- "prod_fun(f1 o f2, g1 o g2) = (prod_fun(f1,g1) o prod_fun(f2,g2))";
-by (rtac ext 1);
-by (res_inst_tac [("p","x")] PairE 1);
-by (asm_simp_tac (prod_ss addsimps [prod_fun,o_def]) 1);
-qed "prod_fun_compose";
-
-goal Prod.thy "prod_fun(%x.x, %y.y) = (%z.z)";
-by (rtac ext 1);
-by (res_inst_tac [("p","z")] PairE 1);
-by (asm_simp_tac (prod_ss addsimps [prod_fun]) 1);
-qed "prod_fun_ident";
-
-val prems = goal Prod.thy "<a,b>:r ==> <f(a),g(b)> : prod_fun(f,g)``r";
-by (rtac image_eqI 1);
-by (rtac (prod_fun RS sym) 1);
-by (resolve_tac prems 1);
-qed "prod_fun_imageI";
-
-val major::prems = goal Prod.thy
- "[| c: prod_fun(f,g)``r; !!x y. [| c=<f(x),g(y)>; <x,y>:r |] ==> P \
-\ |] ==> P";
-by (rtac (major RS imageE) 1);
-by (res_inst_tac [("p","x")] PairE 1);
-by (resolve_tac prems 1);
-by (fast_tac HOL_cs 2);
-by (fast_tac (HOL_cs addIs [prod_fun]) 1);
-qed "prod_fun_imageE";
-
-(*** Disjoint union of a family of sets - Sigma ***)
-
-qed_goalw "SigmaI" Prod.thy [Sigma_def]
- "[| a:A; b:B(a) |] ==> <a,b> : Sigma(A,B)"
- (fn prems=> [ (REPEAT (resolve_tac (prems@[singletonI,UN_I]) 1)) ]);
-
-(*The general elimination rule*)
-qed_goalw "SigmaE" Prod.thy [Sigma_def]
- "[| c: Sigma(A,B); \
-\ !!x y.[| x:A; y:B(x); c=<x,y> |] ==> P \
-\ |] ==> P"
- (fn major::prems=>
- [ (cut_facts_tac [major] 1),
- (REPEAT (eresolve_tac [UN_E, singletonE] 1 ORELSE ares_tac prems 1)) ]);
-
-(** Elimination of <a,b>:A*B -- introduces no eigenvariables **)
-qed_goal "SigmaD1" Prod.thy "<a,b> : Sigma(A,B) ==> a : A"
- (fn [major]=>
- [ (rtac (major RS SigmaE) 1),
- (REPEAT (eresolve_tac [asm_rl,Pair_inject,ssubst] 1)) ]);
-
-qed_goal "SigmaD2" Prod.thy "<a,b> : Sigma(A,B) ==> b : B(a)"
- (fn [major]=>
- [ (rtac (major RS SigmaE) 1),
- (REPEAT (eresolve_tac [asm_rl,Pair_inject,ssubst] 1)) ]);
-
-qed_goal "SigmaE2" Prod.thy
- "[| <a,b> : Sigma(A,B); \
-\ [| a:A; b:B(a) |] ==> P \
-\ |] ==> P"
- (fn [major,minor]=>
- [ (rtac minor 1),
- (rtac (major RS SigmaD1) 1),
- (rtac (major RS SigmaD2) 1) ]);
-
-(*** Domain of a relation ***)
-
-val prems = goalw Prod.thy [image_def] "<a,b> : r ==> a : fst``r";
-by (rtac CollectI 1);
-by (rtac bexI 1);
-by (rtac (fst_conv RS sym) 1);
-by (resolve_tac prems 1);
-qed "fst_imageI";
-
-val major::prems = goal Prod.thy
- "[| a : fst``r; !!y.[| <a,y> : r |] ==> P |] ==> P";
-by (rtac (major RS imageE) 1);
-by (resolve_tac prems 1);
-by (etac ssubst 1);
-by (rtac (surjective_pairing RS subst) 1);
-by (assume_tac 1);
-qed "fst_imageE";
-
-(*** Range of a relation ***)
-
-val prems = goalw Prod.thy [image_def] "<a,b> : r ==> b : snd``r";
-by (rtac CollectI 1);
-by (rtac bexI 1);
-by (rtac (snd_conv RS sym) 1);
-by (resolve_tac prems 1);
-qed "snd_imageI";
-
-val major::prems = goal Prod.thy
- "[| a : snd``r; !!y.[| <y,a> : r |] ==> P |] ==> P";
-by (rtac (major RS imageE) 1);
-by (resolve_tac prems 1);
-by (etac ssubst 1);
-by (rtac (surjective_pairing RS subst) 1);
-by (assume_tac 1);
-qed "snd_imageE";
-
-(** Exhaustion rule for unit -- a degenerate form of induction **)
-
-goalw Prod.thy [Unity_def]
- "u = Unity";
-by (stac (rewrite_rule [Unit_def] Rep_Unit RS CollectD RS sym) 1);
-by (rtac (Rep_Unit_inverse RS sym) 1);
-qed "unit_eq";
-
-val prod_cs = set_cs addSIs [SigmaI, mem_splitI]
- addIs [fst_imageI, snd_imageI, prod_fun_imageI]
- addSEs [SigmaE2, SigmaE, mem_splitE,
- fst_imageE, snd_imageE, prod_fun_imageE,
- Pair_inject];
--- a/Prod.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,66 +0,0 @@
-(* Title: HOL/Prod.thy
- ID: Prod.thy,v 1.5 1994/08/19 09:04:27 lcp Exp
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-Ordered Pairs and the Cartesian product type.
-The unit type.
-*)
-
-Prod = Fun +
-
-(** Products **)
-
-(* type definition *)
-
-consts
- Pair_Rep :: "['a, 'b] => ['a, 'b] => bool"
-
-defs
- Pair_Rep_def "Pair_Rep == (%a b. %x y. x=a & y=b)"
-
-subtype (Prod)
- ('a, 'b) "*" (infixr 20)
- = "{f. ? a b. f = Pair_Rep(a::'a, b::'b)}"
-
-
-(* abstract constants and syntax *)
-
-consts
- fst :: "'a * 'b => 'a"
- snd :: "'a * 'b => 'b"
- split :: "[['a, 'b] => 'c, 'a * 'b] => 'c"
- prod_fun :: "['a => 'b, 'c => 'd, 'a * 'c] => 'b * 'd"
- Pair :: "['a, 'b] => 'a * 'b"
- Sigma :: "['a set, 'a => 'b set] => ('a * 'b) set"
-
-syntax
- "@Tuple" :: "args => 'a * 'b" ("(1<_>)")
-
-translations
- "<x, y, z>" == "<x, <y, z>>"
- "<x, y>" == "Pair(x, y)"
- "<x>" => "x"
-
-defs
- Pair_def "Pair(a, b) == Abs_Prod(Pair_Rep(a, b))"
- fst_def "fst(p) == @a. ? b. p = <a, b>"
- snd_def "snd(p) == @b. ? a. p = <a, b>"
- split_def "split(c, p) == c(fst(p), snd(p))"
- prod_fun_def "prod_fun(f, g) == split(%x y.<f(x), g(y)>)"
- Sigma_def "Sigma(A, B) == UN x:A. UN y:B(x). {<x, y>}"
-
-
-
-(** Unit **)
-
-subtype (Unit)
- unit = "{p. p = True}"
-
-consts
- Unity :: "unit" ("<>")
-
-defs
- Unity_def "Unity == Abs_Unit(True)"
-
-end
--- a/README Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,23 +0,0 @@
- HOL: Higher-Order Logic
-
-This directory contains the Standard ML sources of the Isabelle system for
-Higher-Order Logic. Important files include
-
-ROOT.ML -- loads all source files. Enter an ML image containing Pure
-Isabelle and type: use "ROOT.ML";
-
-Makefile -- compiles the files under Poly/ML or SML of New Jersey
-
-ex -- subdirectory containing examples. To execute them, enter an ML image
-containing HOL and type: use "ex/ROOT.ML";
-
-Subst -- subdirectory defining a theory of substitution and unification.
-
-Useful references on Higher-Order Logic:
-
- P. B. Andrews,
- An Introduction to Mathematical Logic and Type Theory
- (Academic Press, 1986).
-
- J. Lambek and P. J. Scott,
- Introduction to Higher Order Categorical Logic (CUP, 1986)
--- a/ROOT.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,90 +0,0 @@
-(* Title: Old_HOL/ROOT.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1993 University of Cambridge
-
-Adds Classical Higher-order Logic to a database containing Pure Isabelle.
-Should be executed in the subdirectory Old_HOL.
-*)
-
-val banner = "Higher-Order Logic";
-writeln banner;
-
-print_depth 1;
-set eta_contract;
-
-(* Add user sections *)
-use "../Pure/section_utils.ML";
-use "thy_syntax.ML";
-
-use_thy "HOL";
-use "../Provers/splitter.ML";
-use "../Provers/hypsubst.ML";
-use "../Provers/classical.ML";
-
-(** Applying HypsubstFun to generate hyp_subst_tac **)
-
-structure Hypsubst_Data =
- struct
- structure Simplifier = Simplifier
- (*Take apart an equality judgement; otherwise raise Match!*)
- fun dest_eq (Const("Trueprop",_) $ (Const("op =",_) $ t $ u)) = (t,u);
- val eq_reflection = eq_reflection
- val imp_intr = impI
- val rev_mp = rev_mp
- val subst = subst
- val sym = sym
- end;
-
-structure Hypsubst = HypsubstFun(Hypsubst_Data);
-open Hypsubst;
-
-(*** Applying ClassicalFun to create a classical prover ***)
-structure Classical_Data =
- struct
- val sizef = size_of_thm
- val mp = mp
- val not_elim = notE
- val classical = classical
- val hyp_subst_tacs=[hyp_subst_tac]
- end;
-
-structure Classical = ClassicalFun(Classical_Data);
-open Classical;
-
-(*Propositional rules*)
-val prop_cs = empty_cs addSIs [refl,TrueI,conjI,disjCI,impI,notI,iffI]
- addSEs [conjE,disjE,impCE,FalseE,iffE];
-
-(*Quantifier rules*)
-val HOL_cs = prop_cs addSIs [allI] addIs [exI,ex1I]
- addSEs [exE,ex1E] addEs [allE];
-
-use "simpdata.ML";
-use_thy "Ord";
-use_thy "subset";
-use_thy "equalities";
-use "hologic.ML";
-use "subtype.ML";
-use_thy "Prod";
-use_thy "Sum";
-use_thy "Gfp";
-use_thy "Nat";
-
-use "datatype.ML";
-use "ind_syntax.ML";
-use "add_ind_def.ML";
-use "intr_elim.ML";
-use "indrule.ML";
-use_thy "Inductive";
-
-use_thy "Finite";
-use_thy "Sexp";
-use_thy "List";
-
-init_pps ();
-print_depth 8;
-
-make_chart (); (*make HTML chart*)
-
-val HOL_build_completed = (); (*indicate successful build*)
--- a/Set.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,447 +0,0 @@
-(* Title: HOL/set
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-For set.thy. Set theory for higher-order logic. A set is simply a predicate.
-*)
-
-open Set;
-
-val [prem] = goal Set.thy "[| P(a) |] ==> a : {x.P(x)}";
-by (rtac (mem_Collect_eq RS ssubst) 1);
-by (rtac prem 1);
-qed "CollectI";
-
-val prems = goal Set.thy "[| a : {x.P(x)} |] ==> P(a)";
-by (resolve_tac (prems RL [mem_Collect_eq RS subst]) 1);
-qed "CollectD";
-
-val [prem] = goal Set.thy "[| !!x. (x:A) = (x:B) |] ==> A = B";
-by (rtac (prem RS ext RS arg_cong RS box_equals) 1);
-by (rtac Collect_mem_eq 1);
-by (rtac Collect_mem_eq 1);
-qed "set_ext";
-
-val [prem] = goal Set.thy "[| !!x. P(x)=Q(x) |] ==> {x. P(x)} = {x. Q(x)}";
-by (rtac (prem RS ext RS arg_cong) 1);
-qed "Collect_cong";
-
-val CollectE = make_elim CollectD;
-
-(*** Bounded quantifiers ***)
-
-val prems = goalw Set.thy [Ball_def]
- "[| !!x. x:A ==> P(x) |] ==> ! x:A. P(x)";
-by (REPEAT (ares_tac (prems @ [allI,impI]) 1));
-qed "ballI";
-
-val [major,minor] = goalw Set.thy [Ball_def]
- "[| ! x:A. P(x); x:A |] ==> P(x)";
-by (rtac (minor RS (major RS spec RS mp)) 1);
-qed "bspec";
-
-val major::prems = goalw Set.thy [Ball_def]
- "[| ! x:A. P(x); P(x) ==> Q; x~:A ==> Q |] ==> Q";
-by (rtac (major RS spec RS impCE) 1);
-by (REPEAT (eresolve_tac prems 1));
-qed "ballE";
-
-(*Takes assumptions ! x:A.P(x) and a:A; creates assumption P(a)*)
-fun ball_tac i = etac ballE i THEN contr_tac (i+1);
-
-val prems = goalw Set.thy [Bex_def]
- "[| P(x); x:A |] ==> ? x:A. P(x)";
-by (REPEAT (ares_tac (prems @ [exI,conjI]) 1));
-qed "bexI";
-
-qed_goal "bexCI" Set.thy
- "[| ! x:A. ~P(x) ==> P(a); a:A |] ==> ? x:A.P(x)"
- (fn prems=>
- [ (rtac classical 1),
- (REPEAT (ares_tac (prems@[bexI,ballI,notI,notE]) 1)) ]);
-
-val major::prems = goalw Set.thy [Bex_def]
- "[| ? x:A. P(x); !!x. [| x:A; P(x) |] ==> Q |] ==> Q";
-by (rtac (major RS exE) 1);
-by (REPEAT (eresolve_tac (prems @ [asm_rl,conjE]) 1));
-qed "bexE";
-
-(*Trival rewrite rule; (! x:A.P)=P holds only if A is nonempty!*)
-val prems = goal Set.thy
- "(! x:A. True) = True";
-by (REPEAT (ares_tac [TrueI,ballI,iffI] 1));
-qed "ball_rew";
-
-(** Congruence rules **)
-
-val prems = goal Set.thy
- "[| A=B; !!x. x:B ==> P(x) = Q(x) |] ==> \
-\ (! x:A. P(x)) = (! x:B. Q(x))";
-by (resolve_tac (prems RL [ssubst]) 1);
-by (REPEAT (ares_tac [ballI,iffI] 1
- ORELSE eresolve_tac ([make_elim bspec, mp] @ (prems RL [iffE])) 1));
-qed "ball_cong";
-
-val prems = goal Set.thy
- "[| A=B; !!x. x:B ==> P(x) = Q(x) |] ==> \
-\ (? x:A. P(x)) = (? x:B. Q(x))";
-by (resolve_tac (prems RL [ssubst]) 1);
-by (REPEAT (etac bexE 1
- ORELSE ares_tac ([bexI,iffI] @ (prems RL [iffD1,iffD2])) 1));
-qed "bex_cong";
-
-(*** Subsets ***)
-
-val prems = goalw Set.thy [subset_def] "(!!x.x:A ==> x:B) ==> A <= B";
-by (REPEAT (ares_tac (prems @ [ballI]) 1));
-qed "subsetI";
-
-(*Rule in Modus Ponens style*)
-val major::prems = goalw Set.thy [subset_def] "[| A <= B; c:A |] ==> c:B";
-by (rtac (major RS bspec) 1);
-by (resolve_tac prems 1);
-qed "subsetD";
-
-(*The same, with reversed premises for use with etac -- cf rev_mp*)
-qed_goal "rev_subsetD" Set.thy "[| c:A; A <= B |] ==> c:B"
- (fn prems=> [ (REPEAT (resolve_tac (prems@[subsetD]) 1)) ]);
-
-(*Classical elimination rule*)
-val major::prems = goalw Set.thy [subset_def]
- "[| A <= B; c~:A ==> P; c:B ==> P |] ==> P";
-by (rtac (major RS ballE) 1);
-by (REPEAT (eresolve_tac prems 1));
-qed "subsetCE";
-
-(*Takes assumptions A<=B; c:A and creates the assumption c:B *)
-fun set_mp_tac i = etac subsetCE i THEN mp_tac i;
-
-qed_goal "subset_refl" Set.thy "A <= (A::'a set)"
- (fn _=> [ (REPEAT (ares_tac [subsetI] 1)) ]);
-
-val prems = goal Set.thy "[| A<=B; B<=C |] ==> A<=(C::'a set)";
-by (cut_facts_tac prems 1);
-by (REPEAT (ares_tac [subsetI] 1 ORELSE set_mp_tac 1));
-qed "subset_trans";
-
-
-(*** Equality ***)
-
-(*Anti-symmetry of the subset relation*)
-val prems = goal Set.thy "[| A <= B; B <= A |] ==> A = (B::'a set)";
-by (rtac (iffI RS set_ext) 1);
-by (REPEAT (ares_tac (prems RL [subsetD]) 1));
-qed "subset_antisym";
-val equalityI = subset_antisym;
-
-(* Equality rules from ZF set theory -- are they appropriate here? *)
-val prems = goal Set.thy "A = B ==> A<=(B::'a set)";
-by (resolve_tac (prems RL [subst]) 1);
-by (rtac subset_refl 1);
-qed "equalityD1";
-
-val prems = goal Set.thy "A = B ==> B<=(A::'a set)";
-by (resolve_tac (prems RL [subst]) 1);
-by (rtac subset_refl 1);
-qed "equalityD2";
-
-val prems = goal Set.thy
- "[| A = B; [| A<=B; B<=(A::'a set) |] ==> P |] ==> P";
-by (resolve_tac prems 1);
-by (REPEAT (resolve_tac (prems RL [equalityD1,equalityD2]) 1));
-qed "equalityE";
-
-val major::prems = goal Set.thy
- "[| A = B; [| c:A; c:B |] ==> P; [| c~:A; c~:B |] ==> P |] ==> P";
-by (rtac (major RS equalityE) 1);
-by (REPEAT (contr_tac 1 ORELSE eresolve_tac ([asm_rl,subsetCE]@prems) 1));
-qed "equalityCE";
-
-(*Lemma for creating induction formulae -- for "pattern matching" on p
- To make the induction hypotheses usable, apply "spec" or "bspec" to
- put universal quantifiers over the free variables in p. *)
-val prems = goal Set.thy
- "[| p:A; !!z. z:A ==> p=z --> R |] ==> R";
-by (rtac mp 1);
-by (REPEAT (resolve_tac (refl::prems) 1));
-qed "setup_induction";
-
-
-(*** Set complement -- Compl ***)
-
-val prems = goalw Set.thy [Compl_def]
- "[| c:A ==> False |] ==> c : Compl(A)";
-by (REPEAT (ares_tac (prems @ [CollectI,notI]) 1));
-qed "ComplI";
-
-(*This form, with negated conclusion, works well with the Classical prover.
- Negated assumptions behave like formulae on the right side of the notional
- turnstile...*)
-val major::prems = goalw Set.thy [Compl_def]
- "[| c : Compl(A) |] ==> c~:A";
-by (rtac (major RS CollectD) 1);
-qed "ComplD";
-
-val ComplE = make_elim ComplD;
-
-
-(*** Binary union -- Un ***)
-
-val prems = goalw Set.thy [Un_def] "c:A ==> c : A Un B";
-by (REPEAT (resolve_tac (prems @ [CollectI,disjI1]) 1));
-qed "UnI1";
-
-val prems = goalw Set.thy [Un_def] "c:B ==> c : A Un B";
-by (REPEAT (resolve_tac (prems @ [CollectI,disjI2]) 1));
-qed "UnI2";
-
-(*Classical introduction rule: no commitment to A vs B*)
-qed_goal "UnCI" Set.thy "(c~:B ==> c:A) ==> c : A Un B"
- (fn prems=>
- [ (rtac classical 1),
- (REPEAT (ares_tac (prems@[UnI1,notI]) 1)),
- (REPEAT (ares_tac (prems@[UnI2,notE]) 1)) ]);
-
-val major::prems = goalw Set.thy [Un_def]
- "[| c : A Un B; c:A ==> P; c:B ==> P |] ==> P";
-by (rtac (major RS CollectD RS disjE) 1);
-by (REPEAT (eresolve_tac prems 1));
-qed "UnE";
-
-
-(*** Binary intersection -- Int ***)
-
-val prems = goalw Set.thy [Int_def]
- "[| c:A; c:B |] ==> c : A Int B";
-by (REPEAT (resolve_tac (prems @ [CollectI,conjI]) 1));
-qed "IntI";
-
-val [major] = goalw Set.thy [Int_def] "c : A Int B ==> c:A";
-by (rtac (major RS CollectD RS conjunct1) 1);
-qed "IntD1";
-
-val [major] = goalw Set.thy [Int_def] "c : A Int B ==> c:B";
-by (rtac (major RS CollectD RS conjunct2) 1);
-qed "IntD2";
-
-val [major,minor] = goal Set.thy
- "[| c : A Int B; [| c:A; c:B |] ==> P |] ==> P";
-by (rtac minor 1);
-by (rtac (major RS IntD1) 1);
-by (rtac (major RS IntD2) 1);
-qed "IntE";
-
-
-(*** Set difference ***)
-
-qed_goalw "DiffI" Set.thy [set_diff_def]
- "[| c : A; c ~: B |] ==> c : A - B"
- (fn prems=> [ (REPEAT (resolve_tac (prems @ [CollectI,conjI]) 1)) ]);
-
-qed_goalw "DiffD1" Set.thy [set_diff_def]
- "c : A - B ==> c : A"
- (fn [major]=> [ (rtac (major RS CollectD RS conjunct1) 1) ]);
-
-qed_goalw "DiffD2" Set.thy [set_diff_def]
- "[| c : A - B; c : B |] ==> P"
- (fn [major,minor]=>
- [rtac (minor RS (major RS CollectD RS conjunct2 RS notE)) 1]);
-
-qed_goal "DiffE" Set.thy
- "[| c : A - B; [| c:A; c~:B |] ==> P |] ==> P"
- (fn prems=>
- [ (resolve_tac prems 1),
- (REPEAT (ares_tac (prems RL [DiffD1, DiffD2 RS notI]) 1)) ]);
-
-qed_goal "Diff_iff" Set.thy "(c : A-B) = (c:A & c~:B)"
- (fn _ => [ (fast_tac (HOL_cs addSIs [DiffI] addSEs [DiffE]) 1) ]);
-
-
-(*** The empty set -- {} ***)
-
-qed_goalw "emptyE" Set.thy [empty_def] "a:{} ==> P"
- (fn [prem] => [rtac (prem RS CollectD RS FalseE) 1]);
-
-qed_goal "empty_subsetI" Set.thy "{} <= A"
- (fn _ => [ (REPEAT (ares_tac [equalityI,subsetI,emptyE] 1)) ]);
-
-qed_goal "equals0I" Set.thy "[| !!y. y:A ==> False |] ==> A={}"
- (fn prems=>
- [ (REPEAT (ares_tac (prems@[empty_subsetI,subsetI,equalityI]) 1
- ORELSE eresolve_tac (prems RL [FalseE]) 1)) ]);
-
-qed_goal "equals0D" Set.thy "[| A={}; a:A |] ==> P"
- (fn [major,minor]=>
- [ (rtac (minor RS (major RS equalityD1 RS subsetD RS emptyE)) 1) ]);
-
-
-(*** Augmenting a set -- insert ***)
-
-qed_goalw "insertI1" Set.thy [insert_def] "a : insert(a,B)"
- (fn _ => [rtac (CollectI RS UnI1) 1, rtac refl 1]);
-
-qed_goalw "insertI2" Set.thy [insert_def] "a : B ==> a : insert(b,B)"
- (fn [prem]=> [ (rtac (prem RS UnI2) 1) ]);
-
-qed_goalw "insertE" Set.thy [insert_def]
- "[| a : insert(b,A); a=b ==> P; a:A ==> P |] ==> P"
- (fn major::prems=>
- [ (rtac (major RS UnE) 1),
- (REPEAT (eresolve_tac (prems @ [CollectE]) 1)) ]);
-
-qed_goal "insert_iff" Set.thy "a : insert(b,A) = (a=b | a:A)"
- (fn _ => [fast_tac (HOL_cs addIs [insertI1,insertI2] addSEs [insertE]) 1]);
-
-(*Classical introduction rule*)
-qed_goal "insertCI" Set.thy "(a~:B ==> a=b) ==> a: insert(b,B)"
- (fn [prem]=>
- [ (rtac (disjCI RS (insert_iff RS iffD2)) 1),
- (etac prem 1) ]);
-
-(*** Singletons, using insert ***)
-
-qed_goal "singletonI" Set.thy "a : {a}"
- (fn _=> [ (rtac insertI1 1) ]);
-
-qed_goal "singletonE" Set.thy "[| a: {b}; a=b ==> P |] ==> P"
- (fn major::prems=>
- [ (rtac (major RS insertE) 1),
- (REPEAT (eresolve_tac (prems @ [emptyE]) 1)) ]);
-
-goalw Set.thy [insert_def] "!!a. b : {a} ==> b=a";
-by(fast_tac (HOL_cs addSEs [emptyE,CollectE,UnE]) 1);
-qed "singletonD";
-
-val singletonE = make_elim singletonD;
-
-val [major] = goal Set.thy "{a}={b} ==> a=b";
-by (rtac (major RS equalityD1 RS subsetD RS singletonD) 1);
-by (rtac singletonI 1);
-qed "singleton_inject";
-
-(*** Unions of families -- UNION x:A. B(x) is Union(B``A) ***)
-
-(*The order of the premises presupposes that A is rigid; b may be flexible*)
-val prems = goalw Set.thy [UNION_def]
- "[| a:A; b: B(a) |] ==> b: (UN x:A. B(x))";
-by (REPEAT (resolve_tac (prems @ [bexI,CollectI]) 1));
-qed "UN_I";
-
-val major::prems = goalw Set.thy [UNION_def]
- "[| b : (UN x:A. B(x)); !!x.[| x:A; b: B(x) |] ==> R |] ==> R";
-by (rtac (major RS CollectD RS bexE) 1);
-by (REPEAT (ares_tac prems 1));
-qed "UN_E";
-
-val prems = goal Set.thy
- "[| A=B; !!x. x:B ==> C(x) = D(x) |] ==> \
-\ (UN x:A. C(x)) = (UN x:B. D(x))";
-by (REPEAT (etac UN_E 1
- ORELSE ares_tac ([UN_I,equalityI,subsetI] @
- (prems RL [equalityD1,equalityD2] RL [subsetD])) 1));
-qed "UN_cong";
-
-
-(*** Intersections of families -- INTER x:A. B(x) is Inter(B``A) *)
-
-val prems = goalw Set.thy [INTER_def]
- "(!!x. x:A ==> b: B(x)) ==> b : (INT x:A. B(x))";
-by (REPEAT (ares_tac ([CollectI,ballI] @ prems) 1));
-qed "INT_I";
-
-val major::prems = goalw Set.thy [INTER_def]
- "[| b : (INT x:A. B(x)); a:A |] ==> b: B(a)";
-by (rtac (major RS CollectD RS bspec) 1);
-by (resolve_tac prems 1);
-qed "INT_D";
-
-(*"Classical" elimination -- by the Excluded Middle on a:A *)
-val major::prems = goalw Set.thy [INTER_def]
- "[| b : (INT x:A. B(x)); b: B(a) ==> R; a~:A ==> R |] ==> R";
-by (rtac (major RS CollectD RS ballE) 1);
-by (REPEAT (eresolve_tac prems 1));
-qed "INT_E";
-
-val prems = goal Set.thy
- "[| A=B; !!x. x:B ==> C(x) = D(x) |] ==> \
-\ (INT x:A. C(x)) = (INT x:B. D(x))";
-by (REPEAT_FIRST (resolve_tac [INT_I,equalityI,subsetI]));
-by (REPEAT (dtac INT_D 1
- ORELSE ares_tac (prems RL [equalityD1,equalityD2] RL [subsetD]) 1));
-qed "INT_cong";
-
-
-(*** Unions over a type; UNION1(B) = Union(range(B)) ***)
-
-(*The order of the premises presupposes that A is rigid; b may be flexible*)
-val prems = goalw Set.thy [UNION1_def]
- "b: B(x) ==> b: (UN x. B(x))";
-by (REPEAT (resolve_tac (prems @ [TrueI, CollectI RS UN_I]) 1));
-qed "UN1_I";
-
-val major::prems = goalw Set.thy [UNION1_def]
- "[| b : (UN x. B(x)); !!x. b: B(x) ==> R |] ==> R";
-by (rtac (major RS UN_E) 1);
-by (REPEAT (ares_tac prems 1));
-qed "UN1_E";
-
-
-(*** Intersections over a type; INTER1(B) = Inter(range(B)) *)
-
-val prems = goalw Set.thy [INTER1_def]
- "(!!x. b: B(x)) ==> b : (INT x. B(x))";
-by (REPEAT (ares_tac (INT_I::prems) 1));
-qed "INT1_I";
-
-val [major] = goalw Set.thy [INTER1_def]
- "b : (INT x. B(x)) ==> b: B(a)";
-by (rtac (TrueI RS (CollectI RS (major RS INT_D))) 1);
-qed "INT1_D";
-
-(*** Unions ***)
-
-(*The order of the premises presupposes that C is rigid; A may be flexible*)
-val prems = goalw Set.thy [Union_def]
- "[| X:C; A:X |] ==> A : Union(C)";
-by (REPEAT (resolve_tac (prems @ [UN_I]) 1));
-qed "UnionI";
-
-val major::prems = goalw Set.thy [Union_def]
- "[| A : Union(C); !!X.[| A:X; X:C |] ==> R |] ==> R";
-by (rtac (major RS UN_E) 1);
-by (REPEAT (ares_tac prems 1));
-qed "UnionE";
-
-(*** Inter ***)
-
-val prems = goalw Set.thy [Inter_def]
- "[| !!X. X:C ==> A:X |] ==> A : Inter(C)";
-by (REPEAT (ares_tac ([INT_I] @ prems) 1));
-qed "InterI";
-
-(*A "destruct" rule -- every X in C contains A as an element, but
- A:X can hold when X:C does not! This rule is analogous to "spec". *)
-val major::prems = goalw Set.thy [Inter_def]
- "[| A : Inter(C); X:C |] ==> A:X";
-by (rtac (major RS INT_D) 1);
-by (resolve_tac prems 1);
-qed "InterD";
-
-(*"Classical" elimination rule -- does not require proving X:C *)
-val major::prems = goalw Set.thy [Inter_def]
- "[| A : Inter(C); A:X ==> R; X~:C ==> R |] ==> R";
-by (rtac (major RS INT_E) 1);
-by (REPEAT (eresolve_tac prems 1));
-qed "InterE";
-
-(*** Powerset ***)
-
-qed_goalw "PowI" Set.thy [Pow_def] "!!A B. A <= B ==> A : Pow(B)"
- (fn _ => [ (etac CollectI 1) ]);
-
-qed_goalw "PowD" Set.thy [Pow_def] "!!A B. A : Pow(B) ==> A<=B"
- (fn _=> [ (etac CollectD 1) ]);
-
-val Pow_bottom = empty_subsetI RS PowI; (* {}: Pow(B) *)
-val Pow_top = subset_refl RS PowI; (* A : Pow(A) *)
--- a/Set.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,145 +0,0 @@
-(* Title: HOL/Set.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1993 University of Cambridge
-*)
-
-Set = Ord +
-
-types
- 'a set
-
-arities
- set :: (term) term
-
-instance
- set :: (term) {ord, minus}
-
-consts
- "{}" :: "'a set" ("{}")
- insert :: "['a, 'a set] => 'a set"
- Collect :: "('a => bool) => 'a set" (*comprehension*)
- Compl :: "('a set) => 'a set" (*complement*)
- Int :: "['a set, 'a set] => 'a set" (infixl 70)
- Un :: "['a set, 'a set] => 'a set" (infixl 65)
- UNION, INTER :: "['a set, 'a => 'b set] => 'b set" (*general*)
- UNION1 :: "['a => 'b set] => 'b set" (binder "UN " 10)
- INTER1 :: "['a => 'b set] => 'b set" (binder "INT " 10)
- Union, Inter :: "(('a set)set) => 'a set" (*of a set*)
- Pow :: "'a set => 'a set set" (*powerset*)
- range :: "('a => 'b) => 'b set" (*of function*)
- Ball, Bex :: "['a set, 'a => bool] => bool" (*bounded quantifiers*)
- inj, surj :: "('a => 'b) => bool" (*inj/surjective*)
- inj_onto :: "['a => 'b, 'a set] => bool"
- "``" :: "['a => 'b, 'a set] => ('b set)" (infixl 90)
- ":" :: "['a, 'a set] => bool" (infixl 50) (*membership*)
-
-
-syntax
-
- "~:" :: "['a, 'a set] => bool" (infixl 50)
-
- "@Finset" :: "args => 'a set" ("{(_)}")
-
- "@Coll" :: "[idt, bool] => 'a set" ("(1{_./ _})")
- "@SetCompr" :: "['a, idts, bool] => 'a set" ("(1{_ |/_./ _})")
-
- (* Big Intersection / Union *)
-
- "@INTER" :: "[idt, 'a set, 'b set] => 'b set" ("(3INT _:_./ _)" 10)
- "@UNION" :: "[idt, 'a set, 'b set] => 'b set" ("(3UN _:_./ _)" 10)
-
- (* Bounded Quantifiers *)
-
- "@Ball" :: "[idt, 'a set, bool] => bool" ("(3! _:_./ _)" 10)
- "@Bex" :: "[idt, 'a set, bool] => bool" ("(3? _:_./ _)" 10)
- "*Ball" :: "[idt, 'a set, bool] => bool" ("(3ALL _:_./ _)" 10)
- "*Bex" :: "[idt, 'a set, bool] => bool" ("(3EX _:_./ _)" 10)
-
-translations
- "x ~: y" == "~ (x : y)"
- "{x, xs}" == "insert(x, {xs})"
- "{x}" == "insert(x, {})"
- "{x. P}" == "Collect(%x. P)"
- "INT x:A. B" == "INTER(A, %x. B)"
- "UN x:A. B" == "UNION(A, %x. B)"
- "! x:A. P" == "Ball(A, %x. P)"
- "? x:A. P" == "Bex(A, %x. P)"
- "ALL x:A. P" => "Ball(A, %x. P)"
- "EX x:A. P" => "Bex(A, %x. P)"
-
-
-rules
-
- (* Isomorphisms between Predicates and Sets *)
-
- mem_Collect_eq "(a : {x.P(x)}) = P(a)"
- Collect_mem_eq "{x.x:A} = A"
-
-
-defs
- Ball_def "Ball(A, P) == ! x. x:A --> P(x)"
- Bex_def "Bex(A, P) == ? x. x:A & P(x)"
- subset_def "A <= B == ! x:A. x:B"
- Compl_def "Compl(A) == {x. ~x:A}"
- Un_def "A Un B == {x.x:A | x:B}"
- Int_def "A Int B == {x.x:A & x:B}"
- set_diff_def "A - B == {x. x:A & ~x:B}"
- INTER_def "INTER(A, B) == {y. ! x:A. y: B(x)}"
- UNION_def "UNION(A, B) == {y. ? x:A. y: B(x)}"
- INTER1_def "INTER1(B) == INTER({x.True}, B)"
- UNION1_def "UNION1(B) == UNION({x.True}, B)"
- Inter_def "Inter(S) == (INT x:S. x)"
- Union_def "Union(S) == (UN x:S. x)"
- Pow_def "Pow(A) == {B. B <= A}"
- empty_def "{} == {x. False}"
- insert_def "insert(a, B) == {x.x=a} Un B"
- range_def "range(f) == {y. ? x. y=f(x)}"
- image_def "f``A == {y. ? x:A. y=f(x)}"
- inj_def "inj(f) == ! x y. f(x)=f(y) --> x=y"
- inj_onto_def "inj_onto(f, A) == ! x:A. ! y:A. f(x)=f(y) --> x=y"
- surj_def "surj(f) == ! y. ? x. y=f(x)"
-
-end
-
-ML
-
-local
-
-(* Translates between { e | x1..xn. P} and {u. ? x1..xn. u=e & P} *)
-(* {y. ? x1..xn. y = e & P} is only translated if [0..n] subset bvs(e) *)
-
-val ex_tr = snd(mk_binder_tr("? ","Ex"));
-
-fun nvars(Const("_idts",_) $ _ $ idts) = nvars(idts)+1
- | nvars(_) = 1;
-
-fun setcompr_tr[e,idts,b] =
- let val eq = Syntax.const("op =") $ Bound(nvars(idts)) $ e
- val P = Syntax.const("op &") $ eq $ b
- val exP = ex_tr [idts,P]
- in Syntax.const("Collect") $ Abs("",dummyT,exP) end;
-
-val ex_tr' = snd(mk_binder_tr' ("Ex","DUMMY"));
-
-fun setcompr_tr'[Abs(_,_,P)] =
- let fun ok(Const("Ex",_)$Abs(_,_,P),n) = ok(P,n+1)
- | ok(Const("op &",_) $ (Const("op =",_) $ Bound(m) $ e) $ _, n) =
- if n>0 andalso m=n andalso
- ((0 upto (n-1)) subset add_loose_bnos(e,0,[]))
- then () else raise Match
-
- fun tr'(_ $ abs) =
- let val _ $ idts $ (_ $ (_ $ _ $ e) $ Q) = ex_tr'[abs]
- in Syntax.const("@SetCompr") $ e $ idts $ Q end
- in ok(P,0); tr'(P) end;
-
-in
-
-val parse_translation = [("@SetCompr", setcompr_tr)];
-val print_translation = [("Collect", setcompr_tr')];
-val print_ast_translation =
- map HOL.alt_ast_tr' [("@Ball", "*Ball"), ("@Bex", "*Bex")];
-
-end;
-
--- a/Sexp.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,135 +0,0 @@
-(* Title: HOL/Sexp
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-S-expressions, general binary trees for defining recursive data structures
-*)
-
-open Sexp;
-
-(** sexp_case **)
-
-val sexp_free_cs =
- set_cs addSDs [Leaf_inject, Numb_inject, Scons_inject]
- addSEs [Leaf_neq_Scons, Leaf_neq_Numb,
- Numb_neq_Scons, Numb_neq_Leaf,
- Scons_neq_Leaf, Scons_neq_Numb];
-
-goalw Sexp.thy [sexp_case_def] "sexp_case(c, d, e, Leaf(a)) = c(a)";
-by (resolve_tac [select_equality] 1);
-by (ALLGOALS (fast_tac sexp_free_cs));
-qed "sexp_case_Leaf";
-
-goalw Sexp.thy [sexp_case_def] "sexp_case(c, d, e, Numb(k)) = d(k)";
-by (resolve_tac [select_equality] 1);
-by (ALLGOALS (fast_tac sexp_free_cs));
-qed "sexp_case_Numb";
-
-goalw Sexp.thy [sexp_case_def] "sexp_case(c, d, e, M$N) = e(M,N)";
-by (resolve_tac [select_equality] 1);
-by (ALLGOALS (fast_tac sexp_free_cs));
-qed "sexp_case_Scons";
-
-
-(** Introduction rules for sexp constructors **)
-
-val [prem] = goalw Sexp.thy [In0_def]
- "M: sexp ==> In0(M) : sexp";
-by (rtac (prem RS (sexp.NumbI RS sexp.SconsI)) 1);
-qed "sexp_In0I";
-
-val [prem] = goalw Sexp.thy [In1_def]
- "M: sexp ==> In1(M) : sexp";
-by (rtac (prem RS (sexp.NumbI RS sexp.SconsI)) 1);
-qed "sexp_In1I";
-
-val sexp_cs = set_cs addIs sexp.intrs@[SigmaI, uprodI];
-
-goal Sexp.thy "range(Leaf) <= sexp";
-by (fast_tac sexp_cs 1);
-qed "range_Leaf_subset_sexp";
-
-val [major] = goal Sexp.thy "M$N : sexp ==> M: sexp & N: sexp";
-by (rtac (major RS setup_induction) 1);
-by (etac sexp.induct 1);
-by (ALLGOALS
- (fast_tac (set_cs addSEs [Scons_neq_Leaf,Scons_neq_Numb,Scons_inject])));
-qed "Scons_D";
-
-(** Introduction rules for 'pred_sexp' **)
-
-goalw Sexp.thy [pred_sexp_def] "pred_sexp <= Sigma(sexp, %u.sexp)";
-by (fast_tac sexp_cs 1);
-qed "pred_sexp_subset_Sigma";
-
-(* <a,b> : pred_sexp^+ ==> a : sexp *)
-val trancl_pred_sexpD1 =
- pred_sexp_subset_Sigma RS trancl_subset_Sigma RS subsetD RS SigmaD1
-and trancl_pred_sexpD2 =
- pred_sexp_subset_Sigma RS trancl_subset_Sigma RS subsetD RS SigmaD2;
-
-val prems = goalw Sexp.thy [pred_sexp_def]
- "[| M: sexp; N: sexp |] ==> <M, M$N> : pred_sexp";
-by (fast_tac (set_cs addIs prems) 1);
-qed "pred_sexpI1";
-
-val prems = goalw Sexp.thy [pred_sexp_def]
- "[| M: sexp; N: sexp |] ==> <N, M$N> : pred_sexp";
-by (fast_tac (set_cs addIs prems) 1);
-qed "pred_sexpI2";
-
-(*Combinations involving transitivity and the rules above*)
-val pred_sexp_t1 = pred_sexpI1 RS r_into_trancl
-and pred_sexp_t2 = pred_sexpI2 RS r_into_trancl;
-
-val pred_sexp_trans1 = pred_sexp_t1 RSN (2, trans_trancl RS transD)
-and pred_sexp_trans2 = pred_sexp_t2 RSN (2, trans_trancl RS transD);
-
-(*Proves goals of the form <M,N>:pred_sexp^+ provided M,N:sexp*)
-val pred_sexp_simps =
- sexp.intrs @
- [pred_sexp_t1, pred_sexp_t2,
- pred_sexp_trans1, pred_sexp_trans2, cut_apply];
-val pred_sexp_ss = HOL_ss addsimps pred_sexp_simps;
-
-val major::prems = goalw Sexp.thy [pred_sexp_def]
- "[| p : pred_sexp; \
-\ !!M N. [| p = <M, M$N>; M: sexp; N: sexp |] ==> R; \
-\ !!M N. [| p = <N, M$N>; M: sexp; N: sexp |] ==> R \
-\ |] ==> R";
-by (cut_facts_tac [major] 1);
-by (REPEAT (eresolve_tac ([asm_rl,emptyE,insertE,UN_E]@prems) 1));
-qed "pred_sexpE";
-
-goal Sexp.thy "wf(pred_sexp)";
-by (rtac (pred_sexp_subset_Sigma RS wfI) 1);
-by (etac sexp.induct 1);
-by (fast_tac (HOL_cs addSEs [mp, pred_sexpE, Pair_inject, Scons_inject]) 3);
-by (fast_tac (HOL_cs addSEs [mp, pred_sexpE, Pair_inject, Numb_neq_Scons]) 2);
-by (fast_tac (HOL_cs addSEs [mp, pred_sexpE, Pair_inject, Leaf_neq_Scons]) 1);
-qed "wf_pred_sexp";
-
-(*** sexp_rec -- by wf recursion on pred_sexp ***)
-
-(** conversion rules **)
-
-val sexp_rec_unfold = wf_pred_sexp RS (sexp_rec_def RS def_wfrec);
-
-
-goal Sexp.thy "sexp_rec(Leaf(a), c, d, h) = c(a)";
-by (stac sexp_rec_unfold 1);
-by (rtac sexp_case_Leaf 1);
-qed "sexp_rec_Leaf";
-
-goal Sexp.thy "sexp_rec(Numb(k), c, d, h) = d(k)";
-by (stac sexp_rec_unfold 1);
-by (rtac sexp_case_Numb 1);
-qed "sexp_rec_Numb";
-
-goal Sexp.thy "!!M. [| M: sexp; N: sexp |] ==> \
-\ sexp_rec(M$N, c, d, h) = h(M, N, sexp_rec(M,c,d,h), sexp_rec(N,c,d,h))";
-by (rtac (sexp_rec_unfold RS trans) 1);
-by (asm_simp_tac(HOL_ss addsimps
- [sexp_case_Scons,pred_sexpI1,pred_sexpI2,cut_apply])1);
-qed "sexp_rec_Scons";
--- a/Sexp.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,40 +0,0 @@
-(* Title: HOL/Sexp
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-S-expressions, general binary trees for defining recursive data structures
-*)
-
-Sexp = Univ +
-consts
- sexp :: "'a item set"
-
- sexp_case :: "['a=>'b, nat=>'b, ['a item, 'a item]=>'b,
- 'a item] => 'b"
-
- sexp_rec :: "['a item, 'a=>'b, nat=>'b,
- ['a item, 'a item, 'b, 'b]=>'b] => 'b"
-
- pred_sexp :: "('a item * 'a item)set"
-
-inductive "sexp"
- intrs
- LeafI "Leaf(a): sexp"
- NumbI "Numb(a): sexp"
- SconsI "[| M: sexp; N: sexp |] ==> M$N : sexp"
-
-defs
-
- sexp_case_def
- "sexp_case(c,d,e,M) == @ z. (? x. M=Leaf(x) & z=c(x))
- | (? k. M=Numb(k) & z=d(k))
- | (? N1 N2. M = N1 $ N2 & z=e(N1,N2))"
-
- pred_sexp_def
- "pred_sexp == UN M: sexp. UN N: sexp. {<M, M$N>, <N, M$N>}"
-
- sexp_rec_def
- "sexp_rec(M,c,d,e) == wfrec(pred_sexp, M,
- %M g. sexp_case(c, d, %N1 N2. e(N1, N2, g(N1), g(N2)), M))"
-end
--- a/Subst/AList.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,33 +0,0 @@
-(* Title: Substitutions/AList.ML
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-For AList.thy.
-*)
-
-open AList;
-
-val al_rews =
- let fun mk_thm s = prove_goalw AList.thy [alist_rec_def,assoc_def] s
- (fn _ => [simp_tac list_ss 1])
- in map mk_thm
- ["alist_rec([],c,d) = c",
- "alist_rec(<a,b>#al,c,d) = d(a,b,al,alist_rec(al,c,d))",
- "assoc(v,d,[]) = d",
- "assoc(v,d,<a,b>#al) = if(v=a,b,assoc(v,d,al))"] end;
-
-val prems = goal AList.thy
- "[| P([]); \
-\ !!x y xs. P(xs) ==> P(<x,y>#xs) |] ==> P(l)";
-by (list.induct_tac "l" 1);
-by (resolve_tac prems 1);
-by (rtac PairE 1);
-by (etac ssubst 1);
-by (resolve_tac prems 1);
-by (assume_tac 1);
-qed "alist_induct";
-
-(*Perform induction on xs. *)
-fun alist_ind_tac a M =
- EVERY [res_inst_tac [("l",a)] alist_induct M,
- rename_last_tac a ["1"] (M+1)];
--- a/Subst/AList.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,21 +0,0 @@
-(* Title: Substitutions/alist.thy
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Association lists.
-*)
-
-AList = List +
-
-consts
-
- alist_rec :: "[('a*'b)list, 'c, ['a, 'b, ('a*'b)list, 'c]=>'c] => 'c"
- assoc :: "['a,'b,('a*'b) list] => 'b"
-
-rules
-
- alist_rec_def "alist_rec(al,b,c) == list_rec(b, split(c), al)"
-
- assoc_def "assoc(v,d,al) == alist_rec(al,d,%x y xs g.if(v=x,y,g))"
-
-end
--- a/Subst/ROOT.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,39 +0,0 @@
-(* Title: Old_HOL/Subst/ROOT.ML
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Substitution and Unification in Higher-Order Logic.
-
-Implements Manna & Waldinger's formalization, with Paulson's simplifications:
-
-Z Manna & R Waldinger, Deductive Synthesis of the Unification Algorithm.
-SCP 1 (1981), 5-48
-
-L C Paulson, Verifying the Unification Algorithm in LCF. SCP 5 (1985), 143-170
-
-setplus - minor additions to HOL's set theory
-alist - association lists
-uterm - inductive data type of terms
-utlemmas - definition of occurs and vars_of for terms
-subst - substitutions
-unifier - specification of unification and conditions for
- correctness and termination
-
-To load, go to the parent directory and type use"Subst/ROOT.ML";
-*)
-
-HOL_build_completed; (*Cause examples to fail if HOL did*)
-
-writeln"Root file for Substitutions and Unification";
-loadpath := ["Subst"];
-use_thy "Subst/Setplus";
-
-use_thy "Subst/AList";
-use_thy "Subst/UTerm";
-use_thy "Subst/UTLemmas";
-
-use_thy "Subst/Subst";
-use_thy "Subst/Unifier";
-writeln"END: Root file for Substitutions and Unification";
-
-make_chart (); (*make HTML chart*)
--- a/Subst/Setplus.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,64 +0,0 @@
-(* Title: Substitutions/setplus.ML
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-For setplus.thy.
-Properties of subsets and empty sets.
-*)
-
-open Setplus;
-
-(*********)
-
-(*** Rules for subsets ***)
-
-goal Set.thy "A <= B = (! t.t:A --> t:B)";
-by (fast_tac set_cs 1);
-qed "subset_iff";
-
-goalw Setplus.thy [ssubset_def] "A < B = ((A <= B) & ~(A=B))";
-by (rtac refl 1);
-qed "ssubset_iff";
-
-goal Setplus.thy "((A::'a set) <= B) = ((A < B) | (A=B))";
-by (simp_tac (set_ss addsimps [ssubset_iff]) 1);
-by (fast_tac set_cs 1);
-qed "subseteq_iff_subset_eq";
-
-(*Rule in Modus Ponens style*)
-goal Setplus.thy "A < B --> c:A --> c:B";
-by (simp_tac (set_ss addsimps [ssubset_iff]) 1);
-by (fast_tac set_cs 1);
-qed "ssubsetD";
-
-(*********)
-
-goalw Setplus.thy [empty_def] "~ a : {}";
-by (fast_tac set_cs 1);
-qed "not_in_empty";
-
-goalw Setplus.thy [empty_def] "(A = {}) = (ALL a.~ a:A)";
-by (fast_tac (set_cs addIs [set_ext]) 1);
-qed "empty_iff";
-
-
-(*********)
-
-goal Set.thy "(~A=B) = ((? x.x:A & ~x:B) | (? x.~x:A & x:B))";
-by (fast_tac (set_cs addIs [set_ext]) 1);
-qed "not_equal_iff";
-
-(*********)
-
-val setplus_rews = [ssubset_iff,not_in_empty,empty_iff];
-
-(*********)
-
-(*Case analysis for rewriting; P also gets rewritten*)
-val [prem1,prem2] = goal HOL.thy "[| P-->Q; ~P-->Q |] ==> Q";
-by (rtac (excluded_middle RS disjE) 1);
-by (etac (prem2 RS mp) 1);
-by (etac (prem1 RS mp) 1);
-qed "imp_excluded_middle";
-
-fun imp_excluded_middle_tac s = res_inst_tac [("P",s)] imp_excluded_middle;
--- a/Subst/Setplus.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,14 +0,0 @@
-(* Title: Substitutions/setplus.thy
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Minor additions to HOL's set theory
-*)
-
-Setplus = Set +
-
-rules
-
- ssubset_def "A < B == A <= B & ~ A=B"
-
-end
--- a/Subst/Subst.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,185 +0,0 @@
-(* Title: Substitutions/subst.ML
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-For subst.thy.
-*)
-
-open Subst;
-
-(***********)
-
-val subst_defs = [subst_def,comp_def,sdom_def];
-
-val raw_subst_ss = utlemmas_ss addsimps al_rews;
-
-local fun mk_thm s = prove_goalw Subst.thy subst_defs s
- (fn _ => [simp_tac raw_subst_ss 1])
-in val subst_rews = map mk_thm
-["Const(c) <| al = Const(c)",
- "Comb(t,u) <| al = Comb(t <| al, u <| al)",
- "[] <> bl = bl",
- "<a,b>#al <> bl = <a,b <| bl> # (al <> bl)",
- "sdom([]) = {}",
- "sdom(<a,b>#al) = if(Var(a)=b,sdom(al) Int Compl({a}),sdom(al) Un {a})"
-];
- (* This rewrite isn't always desired *)
- val Var_subst = mk_thm "Var(x) <| al = assoc(x,Var(x),al)";
-end;
-
-val subst_ss = raw_subst_ss addsimps subst_rews;
-
-(**** Substitutions ****)
-
-goal Subst.thy "t <| [] = t";
-by (uterm_ind_tac "t" 1);
-by (ALLGOALS (asm_simp_tac (subst_ss addsimps [Var_subst])));
-qed "subst_Nil";
-
-goal Subst.thy "t <: u --> t <| s <: u <| s";
-by (uterm_ind_tac "u" 1);
-by (ALLGOALS (asm_simp_tac subst_ss));
-val subst_mono = store_thm("subst_mono", result() RS mp);
-
-goal Subst.thy "~ (Var(v) <: t) --> t <| <v,t <| s>#s = t <| s";
-by (imp_excluded_middle_tac "t = Var(v)" 1);
-by (res_inst_tac [("P",
- "%x.~x=Var(v) --> ~(Var(v) <: x) --> x <| <v,t<|s>#s=x<|s")]
- uterm_induct 2);
-by (ALLGOALS (simp_tac (subst_ss addsimps [Var_subst])));
-by (fast_tac HOL_cs 1);
-val Var_not_occs = store_thm("Var_not_occs", result() RS mp);
-
-goal Subst.thy
- "(t <|r = t <|s) = (! v.v : vars_of(t) --> Var(v) <|r = Var(v) <|s)";
-by (uterm_ind_tac "t" 1);
-by (REPEAT (etac rev_mp 3));
-by (ALLGOALS (asm_simp_tac subst_ss));
-by (ALLGOALS (fast_tac HOL_cs));
-qed "agreement";
-
-goal Subst.thy "~ v: vars_of(t) --> t <| <v,u>#s = t <| s";
-by(simp_tac(subst_ss addsimps [agreement,Var_subst]
- setloop (split_tac [expand_if])) 1);
-val repl_invariance = store_thm("repl_invariance", result() RS mp);
-
-val asms = goal Subst.thy
- "v : vars_of(t) --> w : vars_of(t <| <v,Var(w)>#s)";
-by (uterm_ind_tac "t" 1);
-by (ALLGOALS (asm_simp_tac (subst_ss addsimps [Var_subst])));
-val Var_in_subst = store_thm("Var_in_subst", result() RS mp);
-
-(**** Equality between Substitutions ****)
-
-goalw Subst.thy [subst_eq_def] "r =s= s = (! t.t <| r = t <| s)";
-by (simp_tac subst_ss 1);
-qed "subst_eq_iff";
-
-local fun mk_thm s = prove_goal Subst.thy s
- (fn prems => [cut_facts_tac prems 1,
- REPEAT (etac rev_mp 1),
- simp_tac (subst_ss addsimps [subst_eq_iff]) 1])
-in
- val subst_refl = mk_thm "r = s ==> r =s= s";
- val subst_sym = mk_thm "r =s= s ==> s =s= r";
- val subst_trans = mk_thm "[| q =s= r; r =s= s |] ==> q =s= s";
-end;
-
-val eq::prems = goalw Subst.thy [subst_eq_def]
- "[| r =s= s; P(t <| r,u <| r) |] ==> P(t <| s,u <| s)";
-by (resolve_tac [eq RS spec RS subst] 1);
-by (resolve_tac (prems RL [eq RS spec RS subst]) 1);
-qed "subst_subst2";
-
-val ssubst_subst2 = subst_sym RS subst_subst2;
-
-(**** Composition of Substitutions ****)
-
-goal Subst.thy "s <> [] = s";
-by (alist_ind_tac "s" 1);
-by (ALLGOALS (asm_simp_tac (subst_ss addsimps [subst_Nil])));
-qed "comp_Nil";
-
-goal Subst.thy "(t <| r <> s) = (t <| r <| s)";
-by (uterm_ind_tac "t" 1);
-by (ALLGOALS (asm_simp_tac (subst_ss addsimps [Var_subst])));
-by (alist_ind_tac "r" 1);
-by (ALLGOALS (asm_simp_tac (subst_ss addsimps [Var_subst,subst_Nil]
- setloop (split_tac [expand_if]))));
-qed "subst_comp";
-
-goal Subst.thy "q <> r <> s =s= q <> (r <> s)";
-by (simp_tac (subst_ss addsimps [subst_eq_iff,subst_comp]) 1);
-qed "comp_assoc";
-
-goal Subst.thy "<w,Var(w) <| s>#s =s= s";
-by (rtac (allI RS (subst_eq_iff RS iffD2)) 1);
-by (uterm_ind_tac "t" 1);
-by (REPEAT (etac rev_mp 3));
-by (ALLGOALS (simp_tac (subst_ss addsimps[Var_subst]
- setloop (split_tac [expand_if]))));
-qed "Cons_trivial";
-
-val [prem] = goal Subst.thy "q <> r =s= s ==> t <| q <| r = t <| s";
-by (simp_tac (subst_ss addsimps [prem RS (subst_eq_iff RS iffD1),
- subst_comp RS sym]) 1);
-qed "comp_subst_subst";
-
-(**** Domain and range of Substitutions ****)
-
-goal Subst.thy "(v : sdom(s)) = (~ Var(v) <| s = Var(v))";
-by (alist_ind_tac "s" 1);
-by (ALLGOALS (asm_simp_tac (subst_ss addsimps [Var_subst]
- setloop (split_tac[expand_if]))));
-by (fast_tac HOL_cs 1);
-qed "sdom_iff";
-
-goalw Subst.thy [srange_def]
- "v : srange(s) = (? w.w : sdom(s) & v : vars_of(Var(w) <| s))";
-by (fast_tac set_cs 1);
-qed "srange_iff";
-
-goal Subst.thy "(t <| s = t) = (sdom(s) Int vars_of(t) = {})";
-by (uterm_ind_tac "t" 1);
-by (REPEAT (etac rev_mp 3));
-by (ALLGOALS (simp_tac (subst_ss addsimps [sdom_iff,Var_subst])));
-by (ALLGOALS (fast_tac set_cs));
-qed "invariance";
-
-goal Subst.thy "v : sdom(s) --> ~v : srange(s) --> ~v : vars_of(t <| s)";
-by (uterm_ind_tac "t" 1);
-by (imp_excluded_middle_tac "x : sdom(s)" 1);
-by (ALLGOALS (asm_simp_tac (subst_ss addsimps [sdom_iff,srange_iff])));
-by (ALLGOALS (fast_tac set_cs));
-val Var_elim = store_thm("Var_elim", result() RS mp RS mp);
-
-val asms = goal Subst.thy
- "[| v : sdom(s); v : vars_of(t <| s) |] ==> v : srange(s)";
-by (REPEAT (ares_tac (asms @ [Var_elim RS swap RS classical]) 1));
-qed "Var_elim2";
-
-goal Subst.thy "v : vars_of(t <| s) --> v : srange(s) | v : vars_of(t)";
-by (uterm_ind_tac "t" 1);
-by (REPEAT_SOME (etac rev_mp ));
-by (ALLGOALS (simp_tac (subst_ss addsimps [sdom_iff,srange_iff])));
-by (REPEAT (step_tac (set_cs addIs [vars_var_iff RS iffD1 RS sym]) 1));
-by (etac notE 1);
-by (etac subst 1);
-by (ALLGOALS (fast_tac set_cs));
-val Var_intro = store_thm("Var_intro", result() RS mp);
-
-goal Subst.thy
- "v : srange(s) --> (? w.w : sdom(s) & v : vars_of(Var(w) <| s))";
-by (simp_tac (subst_ss addsimps [srange_iff]) 1);
-val srangeE = store_thm("srangeE", make_elim (result() RS mp));
-
-val asms = goal Subst.thy
- "sdom(s) Int srange(s) = {} = (! t.sdom(s) Int vars_of(t <| s) = {})";
-by (simp_tac subst_ss 1);
-by (fast_tac (set_cs addIs [Var_elim2] addEs [srangeE]) 1);
-qed "dom_range_disjoint";
-
-val asms = goal Subst.thy "~ u <| s = u --> (? x.x : sdom(s))";
-by (simp_tac (subst_ss addsimps [invariance]) 1);
-by (fast_tac set_cs 1);
-val subst_not_empty = store_thm("subst_not_empty", result() RS mp);
--- a/Subst/Subst.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,37 +0,0 @@
-(* Title: Substitutions/subst.thy
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Substitutions on uterms
-*)
-
-Subst = Setplus + AList + UTLemmas +
-
-consts
-
- "=s=" :: "[('a*('a uterm)) list,('a*('a uterm)) list] => bool" (infixr 52)
-
- "<|" :: "['a uterm,('a*('a uterm)) list] => 'a uterm" (infixl 55)
- "<>" :: "[('a*('a uterm)) list, ('a*('a uterm)) list] =>
- ('a*('a uterm)) list" (infixl 56)
- sdom :: "('a*('a uterm)) list => 'a set"
- srange :: "('a*('a uterm)) list => 'a set"
-
-rules
-
- subst_eq_def "r =s= s == ALL t.t <| r = t <| s"
-
- subst_def
- "t <| al == uterm_rec(t, %x.assoc(x,Var(x),al),
- %x.Const(x),
- %u v q r.Comb(q,r))"
-
- comp_def "al <> bl == alist_rec(al,bl,%x y xs g.<x,y <| bl>#g)"
-
- sdom_def
- "sdom(al) == alist_rec(al, {},
- %x y xs g.if(Var(x)=y, g Int Compl({x}), g Un {x}))"
- srange_def
- "srange(al) == Union({y. EX x:sdom(al).y=vars_of(Var(x) <| al)})"
-
-end
--- a/Subst/UTLemmas.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,77 +0,0 @@
-(* Title: Substitutions/UTLemmas.ML
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-For UTLemmas.thy.
-*)
-
-open UTLemmas;
-
-(***********)
-
-val utlemmas_defs = [vars_of_def,occs_def];
-
-local fun mk_thm s = prove_goalw UTLemmas.thy utlemmas_defs s
- (fn _ => [simp_tac uterm_ss 1])
-in val utlemmas_rews = map mk_thm
- ["vars_of(Const(c)) = {}",
- "vars_of(Var(x)) = {x}",
- "vars_of(Comb(t,u)) = vars_of(t) Un vars_of(u)",
- "t <: Const(c) = False",
- "t <: Var(x) = False",
- "t <: Comb(u,v) = (t=u | t=v | t <: u | t <: v)"];
-end;
-
-val utlemmas_ss = prod_ss addsimps (setplus_rews @ uterm_rews @ utlemmas_rews);
-
-(**** occs irrefl ****)
-
-goal UTLemmas.thy "t <: u & u <: v --> t <: v";
-by (uterm_ind_tac "v" 1);
-by (ALLGOALS (simp_tac utlemmas_ss));
-by (fast_tac HOL_cs 1);
-val occs_trans = store_thm("occs_trans", conjI RS (result() RS mp));
-
-goal UTLemmas.thy "~ t <: v --> ~ t <: u | ~ u <: v";
-by (fast_tac (HOL_cs addIs [occs_trans]) 1);
-val contr_occs_trans = store_thm("contr_occs_trans", result() RS mp);
-
-goal UTLemmas.thy "t <: Comb(t,u)";
-by (simp_tac utlemmas_ss 1);
-qed "occs_Comb1";
-
-goal UTLemmas.thy "u <: Comb(t,u)";
-by (simp_tac utlemmas_ss 1);
-qed "occs_Comb2";
-
-goal HOL.thy "(~(P|Q)) = (~P & ~Q)";
-by (fast_tac HOL_cs 1);
-qed "demorgan_disj";
-
-goal UTLemmas.thy "~ t <: t";
-by (uterm_ind_tac "t" 1);
-by (ALLGOALS (simp_tac (utlemmas_ss addsimps [demorgan_disj])));
-by (REPEAT (resolve_tac [impI,conjI] 1 ORELSE
- (etac contrapos 1 THEN etac subst 1 THEN
- resolve_tac [occs_Comb1,occs_Comb2] 1) ORELSE
- (etac (contr_occs_trans RS disjE) 1 THEN assume_tac 2) ORELSE
- eresolve_tac ([occs_Comb1,occs_Comb2] RLN(2,[notE])) 1));
-qed "occs_irrefl";
-
-goal UTLemmas.thy "t <: u --> ~t=u";
-by (fast_tac (HOL_cs addEs [occs_irrefl RS notE]) 1);
-val occs_irrefl2 = store_thm("occs_irrefl2", result() RS mp);
-
-
-(**** vars_of lemmas ****)
-
-goal UTLemmas.thy "(v : vars_of(Var(w))) = (w=v)";
-by (simp_tac utlemmas_ss 1);
-by (fast_tac HOL_cs 1);
-qed "vars_var_iff";
-
-goal UTLemmas.thy "(x : vars_of(t)) = (Var(x) <: t | Var(x) = t)";
-by (uterm_ind_tac "t" 1);
-by (ALLGOALS (simp_tac utlemmas_ss));
-by (fast_tac HOL_cs 1);
-qed "vars_iff_occseq";
--- a/Subst/UTLemmas.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,20 +0,0 @@
-(* Title: Substitutions/utermlemmas.thy
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Additional definitions for uterms that are not part of the basic inductive definition.
-*)
-
-UTLemmas = UTerm + Setplus +
-
-consts
-
- vars_of :: "'a uterm=>'a set"
- "<:" :: "['a uterm,'a uterm]=>bool" (infixl 54)
-
-rules (*Definitions*)
-
- vars_of_def "vars_of(t) == uterm_rec(t,%x.{x},%x.{},%u v q r.q Un r)"
- occs_def "s <: t == uterm_rec(t,%x.False,%x.False,%u v q r.s=u | s=v | q | r)"
-
-end
--- a/Subst/UTerm.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,270 +0,0 @@
-(* Title: Substitutions/uterm.ML
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Simple term structure for unifiation.
-Binary trees with leaves that are constants or variables.
-*)
-
-open UTerm;
-
-val uterm_con_defs = [VAR_def, CONST_def, COMB_def];
-
-goal UTerm.thy "uterm(A) = A <+> A <+> (uterm(A) <*> uterm(A))";
-let val rew = rewrite_rule uterm_con_defs in
-by (fast_tac (univ_cs addSIs (equalityI :: map rew uterm.intrs)
- addEs [rew uterm.elim]) 1)
-end;
-qed "uterm_unfold";
-
-(** the uterm functional **)
-
-(*This justifies using uterm in other recursive type definitions*)
-goalw UTerm.thy uterm.defs "!!A B. A<=B ==> uterm(A) <= uterm(B)";
-by (REPEAT (ares_tac (lfp_mono::basic_monos) 1));
-qed "uterm_mono";
-
-(** Type checking rules -- uterm creates well-founded sets **)
-
-goalw UTerm.thy (uterm_con_defs @ uterm.defs) "uterm(sexp) <= sexp";
-by (rtac lfp_lowerbound 1);
-by (fast_tac (univ_cs addIs sexp.intrs@[sexp_In0I,sexp_In1I]) 1);
-qed "uterm_sexp";
-
-(* A <= sexp ==> uterm(A) <= sexp *)
-bind_thm ("uterm_subset_sexp", ([uterm_mono, uterm_sexp] MRS subset_trans));
-
-(** Induction **)
-
-(*Induction for the type 'a uterm *)
-val prems = goalw UTerm.thy [Var_def,Const_def,Comb_def]
- "[| !!x.P(Var(x)); !!x.P(Const(x)); \
-\ !!u v. [| P(u); P(v) |] ==> P(Comb(u,v)) |] ==> P(t)";
-by (rtac (Rep_uterm_inverse RS subst) 1); (*types force good instantiation*)
-by (rtac (Rep_uterm RS uterm.induct) 1);
-by (REPEAT (ares_tac prems 1
- ORELSE eresolve_tac [rangeE, ssubst, Abs_uterm_inverse RS subst] 1));
-qed "uterm_induct";
-
-(*Perform induction on xs. *)
-fun uterm_ind_tac a M =
- EVERY [res_inst_tac [("t",a)] uterm_induct M,
- rename_last_tac a ["1"] (M+1)];
-
-
-(*** Isomorphisms ***)
-
-goal UTerm.thy "inj(Rep_uterm)";
-by (rtac inj_inverseI 1);
-by (rtac Rep_uterm_inverse 1);
-qed "inj_Rep_uterm";
-
-goal UTerm.thy "inj_onto(Abs_uterm,uterm(range(Leaf)))";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_uterm_inverse 1);
-qed "inj_onto_Abs_uterm";
-
-(** Distinctness of constructors **)
-
-goalw UTerm.thy uterm_con_defs "~ CONST(c) = COMB(u,v)";
-by (rtac notI 1);
-by (etac (In1_inject RS (In0_not_In1 RS notE)) 1);
-qed "CONST_not_COMB";
-bind_thm ("COMB_not_CONST", (CONST_not_COMB RS not_sym));
-bind_thm ("CONST_neq_COMB", (CONST_not_COMB RS notE));
-val COMB_neq_CONST = sym RS CONST_neq_COMB;
-
-goalw UTerm.thy uterm_con_defs "~ COMB(u,v) = VAR(x)";
-by (rtac In1_not_In0 1);
-qed "COMB_not_VAR";
-bind_thm ("VAR_not_COMB", (COMB_not_VAR RS not_sym));
-bind_thm ("COMB_neq_VAR", (COMB_not_VAR RS notE));
-val VAR_neq_COMB = sym RS COMB_neq_VAR;
-
-goalw UTerm.thy uterm_con_defs "~ VAR(x) = CONST(c)";
-by (rtac In0_not_In1 1);
-qed "VAR_not_CONST";
-bind_thm ("CONST_not_VAR", (VAR_not_CONST RS not_sym));
-bind_thm ("VAR_neq_CONST", (VAR_not_CONST RS notE));
-val CONST_neq_VAR = sym RS VAR_neq_CONST;
-
-
-goalw UTerm.thy [Const_def,Comb_def] "~ Const(c) = Comb(u,v)";
-by (rtac (CONST_not_COMB RS (inj_onto_Abs_uterm RS inj_onto_contraD)) 1);
-by (REPEAT (resolve_tac (uterm.intrs @ [rangeI, Rep_uterm]) 1));
-qed "Const_not_Comb";
-bind_thm ("Comb_not_Const", (Const_not_Comb RS not_sym));
-bind_thm ("Const_neq_Comb", (Const_not_Comb RS notE));
-val Comb_neq_Const = sym RS Const_neq_Comb;
-
-goalw UTerm.thy [Comb_def,Var_def] "~ Comb(u,v) = Var(x)";
-by (rtac (COMB_not_VAR RS (inj_onto_Abs_uterm RS inj_onto_contraD)) 1);
-by (REPEAT (resolve_tac (uterm.intrs @ [rangeI, Rep_uterm]) 1));
-qed "Comb_not_Var";
-bind_thm ("Var_not_Comb", (Comb_not_Var RS not_sym));
-bind_thm ("Comb_neq_Var", (Comb_not_Var RS notE));
-val Var_neq_Comb = sym RS Comb_neq_Var;
-
-goalw UTerm.thy [Var_def,Const_def] "~ Var(x) = Const(c)";
-by (rtac (VAR_not_CONST RS (inj_onto_Abs_uterm RS inj_onto_contraD)) 1);
-by (REPEAT (resolve_tac (uterm.intrs @ [rangeI, Rep_uterm]) 1));
-qed "Var_not_Const";
-bind_thm ("Const_not_Var", (Var_not_Const RS not_sym));
-bind_thm ("Var_neq_Const", (Var_not_Const RS notE));
-val Const_neq_Var = sym RS Var_neq_Const;
-
-
-(** Injectiveness of CONST and Const **)
-
-val inject_cs = HOL_cs addSEs [Scons_inject]
- addSDs [In0_inject,In1_inject];
-
-goalw UTerm.thy [VAR_def] "(VAR(M)=VAR(N)) = (M=N)";
-by (fast_tac inject_cs 1);
-qed "VAR_VAR_eq";
-
-goalw UTerm.thy [CONST_def] "(CONST(M)=CONST(N)) = (M=N)";
-by (fast_tac inject_cs 1);
-qed "CONST_CONST_eq";
-
-goalw UTerm.thy [COMB_def] "(COMB(K,L)=COMB(M,N)) = (K=M & L=N)";
-by (fast_tac inject_cs 1);
-qed "COMB_COMB_eq";
-
-bind_thm ("VAR_inject", (VAR_VAR_eq RS iffD1));
-bind_thm ("CONST_inject", (CONST_CONST_eq RS iffD1));
-bind_thm ("COMB_inject", (COMB_COMB_eq RS iffD1 RS conjE));
-
-
-(*For reasoning about abstract uterm constructors*)
-val uterm_cs = set_cs addIs uterm.intrs @ [Rep_uterm]
- addSEs [CONST_neq_COMB,COMB_neq_VAR,VAR_neq_CONST,
- COMB_neq_CONST,VAR_neq_COMB,CONST_neq_VAR,
- COMB_inject]
- addSDs [VAR_inject,CONST_inject,
- inj_onto_Abs_uterm RS inj_ontoD,
- inj_Rep_uterm RS injD, Leaf_inject];
-
-goalw UTerm.thy [Var_def] "(Var(x)=Var(y)) = (x=y)";
-by (fast_tac uterm_cs 1);
-qed "Var_Var_eq";
-bind_thm ("Var_inject", (Var_Var_eq RS iffD1));
-
-goalw UTerm.thy [Const_def] "(Const(x)=Const(y)) = (x=y)";
-by (fast_tac uterm_cs 1);
-qed "Const_Const_eq";
-bind_thm ("Const_inject", (Const_Const_eq RS iffD1));
-
-goalw UTerm.thy [Comb_def] "(Comb(u,v)=Comb(x,y)) = (u=x & v=y)";
-by (fast_tac uterm_cs 1);
-qed "Comb_Comb_eq";
-bind_thm ("Comb_inject", (Comb_Comb_eq RS iffD1 RS conjE));
-
-val [major] = goal UTerm.thy "VAR(M): uterm(A) ==> M : A";
-by (rtac (major RS setup_induction) 1);
-by (etac uterm.induct 1);
-by (ALLGOALS (fast_tac uterm_cs));
-qed "VAR_D";
-
-val [major] = goal UTerm.thy "CONST(M): uterm(A) ==> M : A";
-by (rtac (major RS setup_induction) 1);
-by (etac uterm.induct 1);
-by (ALLGOALS (fast_tac uterm_cs));
-qed "CONST_D";
-
-val [major] = goal UTerm.thy
- "COMB(M,N): uterm(A) ==> M: uterm(A) & N: uterm(A)";
-by (rtac (major RS setup_induction) 1);
-by (etac uterm.induct 1);
-by (ALLGOALS (fast_tac uterm_cs));
-qed "COMB_D";
-
-(*Basic ss with constructors and their freeness*)
-val uterm_free_simps = uterm.intrs @
- [Const_not_Comb,Comb_not_Var,Var_not_Const,
- Comb_not_Const,Var_not_Comb,Const_not_Var,
- Var_Var_eq,Const_Const_eq,Comb_Comb_eq,
- CONST_not_COMB,COMB_not_VAR,VAR_not_CONST,
- COMB_not_CONST,VAR_not_COMB,CONST_not_VAR,
- VAR_VAR_eq,CONST_CONST_eq,COMB_COMB_eq];
-val uterm_free_ss = HOL_ss addsimps uterm_free_simps;
-
-goal UTerm.thy "!u. t~=Comb(t,u)";
-by (uterm_ind_tac "t" 1);
-by (rtac (Var_not_Comb RS allI) 1);
-by (rtac (Const_not_Comb RS allI) 1);
-by (asm_simp_tac uterm_free_ss 1);
-qed "t_not_Comb_t";
-
-goal UTerm.thy "!t. u~=Comb(t,u)";
-by (uterm_ind_tac "u" 1);
-by (rtac (Var_not_Comb RS allI) 1);
-by (rtac (Const_not_Comb RS allI) 1);
-by (asm_simp_tac uterm_free_ss 1);
-qed "u_not_Comb_u";
-
-
-(*** UTerm_rec -- by wf recursion on pred_sexp ***)
-
-val UTerm_rec_unfold =
- [UTerm_rec_def, wf_pred_sexp RS wf_trancl] MRS def_wfrec;
-
-(** conversion rules **)
-
-goalw UTerm.thy [VAR_def] "UTerm_rec(VAR(x),b,c,d) = b(x)";
-by (rtac (UTerm_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps [Case_In0]) 1);
-qed "UTerm_rec_VAR";
-
-goalw UTerm.thy [CONST_def] "UTerm_rec(CONST(x),b,c,d) = c(x)";
-by (rtac (UTerm_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps [Case_In0,Case_In1]) 1);
-qed "UTerm_rec_CONST";
-
-goalw UTerm.thy [COMB_def]
- "!!M N. [| M: sexp; N: sexp |] ==> \
-\ UTerm_rec(COMB(M,N), b, c, d) = \
-\ d(M, N, UTerm_rec(M,b,c,d), UTerm_rec(N,b,c,d))";
-by (rtac (UTerm_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps [Split,Case_In1]) 1);
-by (asm_simp_tac (pred_sexp_ss addsimps [In1_def]) 1);
-qed "UTerm_rec_COMB";
-
-(*** uterm_rec -- by UTerm_rec ***)
-
-val Rep_uterm_in_sexp =
- Rep_uterm RS (range_Leaf_subset_sexp RS uterm_subset_sexp RS subsetD);
-
-val uterm_rec_simps =
- uterm.intrs @
- [UTerm_rec_VAR, UTerm_rec_CONST, UTerm_rec_COMB,
- Abs_uterm_inverse, Rep_uterm_inverse,
- Rep_uterm, rangeI, inj_Leaf, Inv_f_f, Rep_uterm_in_sexp];
-val uterm_rec_ss = HOL_ss addsimps uterm_rec_simps;
-
-goalw UTerm.thy [uterm_rec_def, Var_def] "uterm_rec(Var(x),b,c,d) = b(x)";
-by (simp_tac uterm_rec_ss 1);
-qed "uterm_rec_Var";
-
-goalw UTerm.thy [uterm_rec_def, Const_def] "uterm_rec(Const(x),b,c,d) = c(x)";
-by (simp_tac uterm_rec_ss 1);
-qed "uterm_rec_Const";
-
-goalw UTerm.thy [uterm_rec_def, Comb_def]
- "uterm_rec(Comb(u,v),b,c,d) = d(u,v,uterm_rec(u,b,c,d),uterm_rec(v,b,c,d))";
-by (simp_tac uterm_rec_ss 1);
-qed "uterm_rec_Comb";
-
-val uterm_simps = [UTerm_rec_VAR, UTerm_rec_CONST, UTerm_rec_COMB,
- uterm_rec_Var, uterm_rec_Const, uterm_rec_Comb];
-val uterm_ss = uterm_free_ss addsimps uterm_simps;
-
-
-(**********)
-
-val uterm_rews = [uterm_rec_Var,uterm_rec_Const,uterm_rec_Comb,
- t_not_Comb_t,u_not_Comb_u,
- Const_not_Comb,Comb_not_Var,Var_not_Const,
- Comb_not_Const,Var_not_Comb,Const_not_Var,
- Var_Var_eq,Const_Const_eq,Comb_Comb_eq];
-
--- a/Subst/UTerm.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,65 +0,0 @@
-(* Title: Substitutions/UTerm.thy
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Simple term structure for unifiation.
-Binary trees with leaves that are constants or variables.
-*)
-
-UTerm = Sexp +
-
-types uterm 1
-
-arities
- uterm :: (term)term
-
-consts
- uterm :: "'a item set => 'a item set"
- Rep_uterm :: "'a uterm => 'a item"
- Abs_uterm :: "'a item => 'a uterm"
- VAR :: "'a item => 'a item"
- CONST :: "'a item => 'a item"
- COMB :: "['a item, 'a item] => 'a item"
- Var :: "'a => 'a uterm"
- Const :: "'a => 'a uterm"
- Comb :: "['a uterm, 'a uterm] => 'a uterm"
- UTerm_rec :: "['a item, 'a item => 'b, 'a item => 'b,
- ['a item , 'a item, 'b, 'b]=>'b] => 'b"
- uterm_rec :: "['a uterm, 'a => 'b, 'a => 'b,
- ['a uterm, 'a uterm,'b,'b]=>'b] => 'b"
-
-defs
- (*defining the concrete constructors*)
- VAR_def "VAR(v) == In0(v)"
- CONST_def "CONST(v) == In1(In0(v))"
- COMB_def "COMB(t,u) == In1(In1(t $ u))"
-
-inductive "uterm(A)"
- intrs
- VAR_I "v:A ==> VAR(v) : uterm(A)"
- CONST_I "c:A ==> CONST(c) : uterm(A)"
- COMB_I "[| M:uterm(A); N:uterm(A) |] ==> COMB(M,N) : uterm(A)"
-
-rules
- (*faking a type definition...*)
- Rep_uterm "Rep_uterm(xs): uterm(range(Leaf))"
- Rep_uterm_inverse "Abs_uterm(Rep_uterm(xs)) = xs"
- Abs_uterm_inverse "M: uterm(range(Leaf)) ==> Rep_uterm(Abs_uterm(M)) = M"
-
-defs
- (*defining the abstract constructors*)
- Var_def "Var(v) == Abs_uterm(VAR(Leaf(v)))"
- Const_def "Const(c) == Abs_uterm(CONST(Leaf(c)))"
- Comb_def "Comb(t,u) == Abs_uterm(COMB(Rep_uterm(t),Rep_uterm(u)))"
-
- (*uterm recursion*)
- UTerm_rec_def
- "UTerm_rec(M,b,c,d) == wfrec(trancl(pred_sexp), M,
- Case(%x g.b(x), Case(%y g. c(y), Split(%x y g. d(x,y,g(x),g(y))))))"
-
- uterm_rec_def
- "uterm_rec(t,b,c,d) ==
- UTerm_rec(Rep_uterm(t), %x.b(Inv(Leaf,x)), %x.c(Inv(Leaf,x)),
- %x y q r.d(Abs_uterm(x),Abs_uterm(y),q,r))"
-
-end
--- a/Subst/Unifier.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,299 +0,0 @@
-(* Title: Substitutions/unifier.ML
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-For unifier.thy.
-Properties of unifiers.
-Cases for partial correctness of algorithm and conditions for termination.
-*)
-
-open Unifier;
-
-val unify_defs =
- [Idem_def,Unifier_def,MoreGeneral_def,MGUnifier_def,MGIUnifier_def];
-
-(**** Unifiers ****)
-
-goalw Unifier.thy [Unifier_def] "Unifier(s,t,u) = (t <| s = u <| s)";
-by (rtac refl 1);
-qed "Unifier_iff";
-
-goal Unifier.thy
- "Unifier(s,Comb(t,u),Comb(v,w)) --> Unifier(s,t,v) & Unifier(s,u,w)";
-by (simp_tac (subst_ss addsimps [Unifier_iff]) 1);
-val Unifier_Comb = store_thm("Unifier_Comb", result() RS mp RS conjE);
-
-goal Unifier.thy
- "~v : vars_of(t) --> ~v : vars_of(u) -->Unifier(s,t,u) --> \
-\ Unifier(<v,r>#s,t,u)";
-by (simp_tac (subst_ss addsimps [Unifier_iff,repl_invariance]) 1);
-val Cons_Unifier = store_thm("Cons_Unifier", result() RS mp RS mp RS mp);
-
-(**** Most General Unifiers ****)
-
-goalw Unifier.thy [MoreGeneral_def] "r >> s = (EX q. s =s= r <> q)";
-by (rtac refl 1);
-qed "MoreGen_iff";
-
-goal Unifier.thy "[] >> s";
-by (simp_tac (subst_ss addsimps [MoreGen_iff]) 1);
-by (fast_tac (set_cs addIs [refl RS subst_refl]) 1);
-qed "MoreGen_Nil";
-
-goalw Unifier.thy unify_defs
- "MGUnifier(s,t,u) = (ALL r.Unifier(r,t,u) = s >> r)";
-by (REPEAT (ares_tac [iffI,allI] 1 ORELSE
- eresolve_tac [conjE,allE,mp,exE,ssubst_subst2] 1));
-by (asm_simp_tac (subst_ss addsimps [subst_comp]) 1);
-by (fast_tac (set_cs addIs [comp_Nil RS sym RS subst_refl]) 1);
-qed "MGU_iff";
-
-val [prem] = goal Unifier.thy
- "~ Var(v) <: t ==> MGUnifier([<v,t>],Var(v),t)";
-by (simp_tac (subst_ss addsimps [MGU_iff,MoreGen_iff,Unifier_iff]) 1);
-by (REPEAT_SOME (step_tac set_cs));
-by (etac subst 1);
-by (etac ssubst_subst2 2);
-by (rtac (Cons_trivial RS subst_sym) 1);
-by (simp_tac (subst_ss addsimps [prem RS Var_not_occs,Var_subst]) 1);
-qed "MGUnifier_Var";
-
-(**** Most General Idempotent Unifiers ****)
-
-goal Unifier.thy "r <> r =s= r --> s =s= r <> q --> r <> s =s= s";
-by (simp_tac (subst_ss addsimps [subst_eq_iff,subst_comp]) 1);
-val MGIU_iff_lemma = store_thm("MGIU_iff_lemma", result() RS mp RS mp);
-
-goalw Unifier.thy unify_defs
- "MGIUnifier(s,t,u) = \
-\ (Idem(s) & Unifier(s,t,u) & (ALL r.Unifier(r,t,u) --> s<>r=s=r))";
-by (fast_tac (set_cs addEs [subst_sym,MGIU_iff_lemma]) 1);
-qed "MGIU_iff";
-
-(**** Idempotence ****)
-
-goalw Unifier.thy unify_defs "Idem(s) = (s <> s =s= s)";
-by (rtac refl 1);
-qed "raw_Idem_iff";
-
-goal Unifier.thy "Idem(s) = (sdom(s) Int srange(s) = {})";
-by (simp_tac (subst_ss addsimps [raw_Idem_iff,subst_eq_iff,subst_comp,
- invariance,dom_range_disjoint])1);
-qed "Idem_iff";
-
-goal Unifier.thy "Idem([])";
-by (simp_tac (subst_ss addsimps [raw_Idem_iff,refl RS subst_refl]) 1);
-qed "Idem_Nil";
-
-goal Unifier.thy "~ (Var(v) <: t) --> Idem([<v,t>])";
-by (simp_tac (subst_ss addsimps [Var_subst,vars_iff_occseq,Idem_iff,srange_iff]
- setloop (split_tac [expand_if])) 1);
-by (fast_tac set_cs 1);
-val Var_Idem = store_thm("Var_Idem", result() RS mp);
-
-val [prem] = goalw Unifier.thy [Idem_def]
- "Idem(r) ==> Unifier(s,t <| r,u <| r) --> Unifier(r <> s,t <| r,u <| r)";
-by (simp_tac (subst_ss addsimps
- [Unifier_iff,subst_comp,prem RS comp_subst_subst]) 1);
-val Unifier_Idem_subst = store_thm("Unifier_Idem_subst", result() RS mp);
-
-val [prem] = goal Unifier.thy
- "r <> s =s= s ==> Unifier(s,t,u) --> Unifier(s,t <| r,u <| r)";
-by (simp_tac (subst_ss addsimps
- [Unifier_iff,subst_comp,prem RS comp_subst_subst]) 1);
-val Unifier_comp_subst = store_thm("Unifier_comp_subst", result() RS mp);
-
-(*** The domain of a MGIU is a subset of the variables in the terms ***)
-(*** NB this and one for range are only needed for termination ***)
-
-val [prem] = goal Unifier.thy
- "~ vars_of(Var(x) <| r) = vars_of(Var(x) <| s) ==> ~r =s= s";
-by (rtac (prem RS contrapos) 1);
-by (fast_tac (set_cs addEs [subst_subst2]) 1);
-qed "lemma_lemma";
-
-val prems = goal Unifier.thy
- "x : sdom(s) --> ~x : srange(s) --> \
-\ ~vars_of(Var(x) <| s<> <x,Var(x)>#s) = \
-\ vars_of(Var(x) <| <x,Var(x)>#s)";
-by (simp_tac (subst_ss addsimps [not_equal_iff]) 1);
-by (REPEAT (resolve_tac [impI,disjI2] 1));
-by(res_inst_tac [("x","x")] exI 1);
-br conjI 1;
-by (asm_simp_tac (subst_ss addsimps [Var_elim,subst_comp,repl_invariance]) 1);
-by (asm_simp_tac (subst_ss addsimps [Var_subst]) 1);
-val MGIU_sdom_lemma = store_thm("MGIU_sdom_lemma", result() RS mp RS mp RS lemma_lemma RS notE);
-
-goal Unifier.thy "MGIUnifier(s,t,u) --> sdom(s) <= vars_of(t) Un vars_of(u)";
-by (subgoal_tac "! P Q.(P | Q) = (~( ~P & ~Q))" 1);
-by (asm_simp_tac (subst_ss addsimps [MGIU_iff,Idem_iff,subset_iff]) 1);
-by (safe_tac set_cs);
-by (eresolve_tac ([spec] RL [impE]) 1);
-by (rtac Cons_Unifier 1);
-by (ALLGOALS (fast_tac (set_cs addIs [Cons_Unifier,MGIU_sdom_lemma])));
-val MGIU_sdom = store_thm("MGIU_sdom", result() RS mp);
-
-(*** The range of a MGIU is a subset of the variables in the terms ***)
-
-val prems = goal HOL.thy "P = Q ==> (~P) = (~Q)";
-by (simp_tac (set_ss addsimps prems) 1);
-qed "not_cong";
-
-val prems = goal Unifier.thy
- "~w=x --> x : vars_of(Var(w) <| s) --> w : sdom(s) --> ~w : srange(s) --> \
-\ ~vars_of(Var(w) <| s<> <x,Var(w)>#s) = \
-\ vars_of(Var(w) <| <x,Var(w)>#s)";
-by (simp_tac (subst_ss addsimps [not_equal_iff]) 1);
-by (REPEAT (resolve_tac [impI,disjI1] 1));
-by(res_inst_tac [("x","w")] exI 1);
-by (ALLGOALS (asm_simp_tac (subst_ss addsimps [Var_elim,subst_comp,
- vars_var_iff RS not_cong RS iffD2 RS repl_invariance]) ));
-by (fast_tac (set_cs addIs [Var_in_subst]) 1);
-val MGIU_srange_lemma = store_thm("MGIU_srange_lemma", result() RS mp RS mp RS mp RS mp RS lemma_lemma RS notE);
-
-goal Unifier.thy "MGIUnifier(s,t,u) --> srange(s) <= vars_of(t) Un vars_of(u)";
-by (subgoal_tac "! P Q.(P | Q) = (~( ~P & ~Q))" 1);
-by (asm_simp_tac (subst_ss addsimps [MGIU_iff,srange_iff,subset_iff]) 1);
-by (simp_tac (subst_ss addsimps [Idem_iff]) 1);
-by (safe_tac set_cs);
-by (eresolve_tac ([spec] RL [impE]) 1);
-by (rtac Cons_Unifier 1);
-by (imp_excluded_middle_tac "w=ta" 4);
-by (fast_tac (set_cs addEs [MGIU_srange_lemma]) 5);
-by (ALLGOALS (fast_tac (set_cs addIs [Var_elim2])));
-val MGIU_srange = store_thm("MGIU_srange", result() RS mp);
-
-(*************** Correctness of a simple unification algorithm ***************)
-(* *)
-(* fun unify Const(m) Const(n) = if m=n then Nil else Fail *)
-(* | unify Const(m) _ = Fail *)
-(* | unify Var(v) t = if Var(v)<:t then Fail else <v,t>#Nil *)
-(* | unify Comb(t,u) Const(n) = Fail *)
-(* | unify Comb(t,u) Var(v) = if Var(v) <: Comb(t,u) then Fail *)
-(* else <v,Comb(t,u>#Nil *)
-(* | unify Comb(t,u) Comb(v,w) = let s = unify t v *)
-(* in if s=Fail then Fail *)
-(* else unify (u<|s) (w<|s); *)
-
-(**** Cases for the partial correctness of the algorithm ****)
-
-goalw Unifier.thy unify_defs "MGIUnifier(s,t,u) = MGIUnifier(s,u,t)";
-by (safe_tac (HOL_cs addSEs ([sym]@([spec] RL [mp]))));
-qed "Unify_comm";
-
-goal Unifier.thy "MGIUnifier([],Const(n),Const(n))";
-by (simp_tac (subst_ss addsimps
- [MGIU_iff,MGU_iff,Unifier_iff,subst_eq_iff,Idem_Nil]) 1);
-qed "Unify1";
-
-goal Unifier.thy "~m=n --> (ALL l.~Unifier(l,Const(m),Const(n)))";
-by (simp_tac (subst_ss addsimps[Unifier_iff]) 1);
-val Unify2 = store_thm("Unify2", result() RS mp);
-
-val [prem] = goalw Unifier.thy [MGIUnifier_def]
- "~Var(v) <: t ==> MGIUnifier([<v,t>],Var(v),t)";
-by (fast_tac (HOL_cs addSIs [prem RS MGUnifier_Var,prem RS Var_Idem]) 1);
-qed "Unify3";
-
-val [prem] = goal Unifier.thy "Var(v) <: t ==> (ALL l.~Unifier(l,Var(v),t))";
-by (simp_tac (subst_ss addsimps
- [Unifier_iff,prem RS subst_mono RS occs_irrefl2]) 1);
-qed "Unify4";
-
-goal Unifier.thy "ALL l.~Unifier(l,Const(m),Comb(t,u))";
-by (simp_tac (subst_ss addsimps [Unifier_iff]) 1);
-qed "Unify5";
-
-goal Unifier.thy
- "(ALL l.~Unifier(l,t,v)) --> (ALL l.~Unifier(l,Comb(t,u),Comb(v,w)))";
-by (simp_tac (subst_ss addsimps [Unifier_iff]) 1);
-val Unify6 = store_thm("Unify6", result() RS mp);
-
-goal Unifier.thy "MGIUnifier(s,t,v) --> (ALL l.~Unifier(l,u <| s,w <| s)) --> \
-\ (ALL l.~Unifier(l,Comb(t,u),Comb(v,w)))";
-by (simp_tac (subst_ss addsimps [MGIU_iff]) 1);
-by (fast_tac (set_cs addIs [Unifier_comp_subst] addSEs [Unifier_Comb]) 1);
-val Unify7 = store_thm("Unify7", result() RS mp RS mp);
-
-val [p1,p2,p3] = goal Unifier.thy
- "[| Idem(r); Unifier(s,t <| r,u <| r); \
-\ (! q.Unifier(q,t <| r,u <| r) --> s <> q =s= q) |] ==> \
-\ Idem(r <> s)";
-by (cut_facts_tac [p1,
- p2 RS (p1 RS Unifier_Idem_subst RS (p3 RS spec RS mp))] 1);
-by (REPEAT_SOME (etac rev_mp));
-by (simp_tac (subst_ss addsimps [raw_Idem_iff,subst_eq_iff,subst_comp]) 1);
-qed "Unify8_lemma1";
-
-val [p1,p2,p3,p4] = goal Unifier.thy
- "[| Unifier(q,t,v); Unifier(q,u,w); (! q.Unifier(q,t,v) --> r <> q =s= q); \
-\ (! q.Unifier(q,u <| r,w <| r) --> s <> q =s= q) |] ==> \
-\ r <> s <> q =s= q";
-val pp = p1 RS (p3 RS spec RS mp);
-by (cut_facts_tac [pp,
- p2 RS (pp RS Unifier_comp_subst) RS (p4 RS spec RS mp)] 1);
-by (REPEAT_SOME (etac rev_mp));
-by (simp_tac (subst_ss addsimps [subst_eq_iff,subst_comp]) 1);
-qed "Unify8_lemma2";
-
-goal Unifier.thy "MGIUnifier(r,t,v) --> MGIUnifier(s,u <| r,w <| r) --> \
-\ MGIUnifier(r <> s,Comb(t,u),Comb(v,w))";
-by (simp_tac (subst_ss addsimps [MGIU_iff,subst_comp,comp_assoc]) 1);
-by (safe_tac HOL_cs);
-by (REPEAT (etac rev_mp 2));
-by (simp_tac (subst_ss addsimps
- [Unifier_iff,MGIU_iff,subst_comp,comp_assoc]) 2);
-by (ALLGOALS (fast_tac (set_cs addEs
- [Unifier_Comb,Unify8_lemma1,Unify8_lemma2])));
-qed "Unify8";
-
-
-(********************** Termination of the algorithm *************************)
-(* *)
-(*UWFD is a well-founded relation that orders the 2 recursive calls in unify *)
-(* NB well-foundedness of UWFD isn't proved *)
-
-
-goalw Unifier.thy [UWFD_def] "UWFD(t,t',Comb(t,u),Comb(t',u'))";
-by (simp_tac subst_ss 1);
-by (fast_tac set_cs 1);
-qed "UnifyWFD1";
-
-val [prem] = goal Unifier.thy
- "MGIUnifier(s,t,t') ==> vars_of(u <| s) Un vars_of(u' <| s) <= \
-\ vars_of(Comb(t,u)) Un vars_of(Comb(t',u'))";
-by (subgoal_tac "vars_of(u <| s) Un vars_of(u' <| s) <= \
-\ srange(s) Un vars_of(u) Un srange(s) Un vars_of(u')" 1);
-by (etac subset_trans 1);
-by (ALLGOALS (simp_tac (subst_ss addsimps [Var_intro,subset_iff])));
-by (ALLGOALS (fast_tac (set_cs addDs
- [Var_intro,prem RS MGIU_srange RS subsetD])));
-qed "UWFD2_lemma1";
-
-val [major,minor] = goal Unifier.thy
- "[| MGIUnifier(s,t,t'); ~ u <| s = u |] ==> \
-\ ~ vars_of(u <| s) Un vars_of(u' <| s) = \
-\ (vars_of(t) Un vars_of(u)) Un (vars_of(t') Un vars_of(u'))";
-by (cut_facts_tac
- [major RS (MGIU_iff RS iffD1) RS conjunct1 RS (Idem_iff RS iffD1)] 1);
-by (rtac (minor RS subst_not_empty RS exE) 1);
-by (rtac (make_elim ((major RS MGIU_sdom) RS subsetD)) 1 THEN assume_tac 1);
-by (rtac (disjI2 RS (not_equal_iff RS iffD2)) 1);
-by (REPEAT (etac rev_mp 1));
-by (asm_simp_tac subst_ss 1);
-by (fast_tac (set_cs addIs [Var_elim2]) 1);
-qed "UWFD2_lemma2";
-
-val [prem] = goalw Unifier.thy [UWFD_def]
- "MGIUnifier(s,t,t') ==> UWFD(u <| s,u' <| s,Comb(t,u),Comb(t',u'))";
-by (cut_facts_tac
- [prem RS UWFD2_lemma1 RS (subseteq_iff_subset_eq RS iffD1)] 1);
-by (imp_excluded_middle_tac "u <| s = u" 1);
-by (simp_tac (set_ss addsimps [occs_Comb2] ) 1);
-by (rtac impI 1 THEN etac subst 1 THEN assume_tac 1);
-by (rtac impI 1);
-by (rtac (conjI RS (ssubset_iff RS iffD2) RS disjI1) 1);
-by (asm_simp_tac (set_ss addsimps [subseteq_iff_subset_eq]) 1);
-by (asm_simp_tac subst_ss 1);
-by (fast_tac (set_cs addDs [prem RS UWFD2_lemma2]) 1);
-qed "UnifyWFD2";
--- a/Subst/Unifier.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,33 +0,0 @@
-(* Title: Subst/unifier.thy
- Author: Martin Coen, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Definition of most general idempotent unifier
-*)
-
-Unifier = Subst +
-
-consts
-
- Idem :: "('a*('a uterm))list=> bool"
- Unifier :: "[('a*('a uterm))list,'a uterm,'a uterm] => bool"
- ">>" :: "[('a*('a uterm))list,('a*('a uterm))list] => bool" (infixr 52)
- MGUnifier :: "[('a*('a uterm))list,'a uterm,'a uterm] => bool"
- MGIUnifier :: "[('a*('a uterm))list,'a uterm,'a uterm] => bool"
- UWFD :: "['a uterm,'a uterm,'a uterm,'a uterm] => bool"
-
-rules (*Definitions*)
-
- Idem_def "Idem(s) == s <> s =s= s"
- Unifier_def "Unifier(s,t,u) == t <| s = u <| s"
- MoreGeneral_def "r >> s == ? q.s =s= r <> q"
- MGUnifier_def "MGUnifier(s,t,u) == Unifier(s,t,u) &
- (! r.Unifier(r,t,u) --> s >> r)"
- MGIUnifier_def "MGIUnifier(s,t,u) == MGUnifier(s,t,u) & Idem(s)"
-
- UWFD_def
- "UWFD(x,y,x',y') ==
- (vars_of(x) Un vars_of(y) < vars_of(x') Un vars_of(y')) |
- (vars_of(x) Un vars_of(y) = vars_of(x') Un vars_of(y') & x <: x')"
-
-end
--- a/Sum.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,204 +0,0 @@
-(* Title: HOL/Sum.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-For Sum.thy. The disjoint sum of two types
-*)
-
-open Sum;
-
-(** Inl_Rep and Inr_Rep: Representations of the constructors **)
-
-(*This counts as a non-emptiness result for admitting 'a+'b as a type*)
-goalw Sum.thy [Sum_def] "Inl_Rep(a) : Sum";
-by (EVERY1 [rtac CollectI, rtac disjI1, rtac exI, rtac refl]);
-qed "Inl_RepI";
-
-goalw Sum.thy [Sum_def] "Inr_Rep(b) : Sum";
-by (EVERY1 [rtac CollectI, rtac disjI2, rtac exI, rtac refl]);
-qed "Inr_RepI";
-
-goal Sum.thy "inj_onto(Abs_Sum,Sum)";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_Sum_inverse 1);
-qed "inj_onto_Abs_Sum";
-
-(** Distinctness of Inl and Inr **)
-
-goalw Sum.thy [Inl_Rep_def, Inr_Rep_def] "Inl_Rep(a) ~= Inr_Rep(b)";
-by (EVERY1 [rtac notI,
- etac (fun_cong RS fun_cong RS fun_cong RS iffE),
- rtac (notE RS ccontr), etac (mp RS conjunct2),
- REPEAT o (ares_tac [refl,conjI]) ]);
-qed "Inl_Rep_not_Inr_Rep";
-
-goalw Sum.thy [Inl_def,Inr_def] "Inl(a) ~= Inr(b)";
-by (rtac (inj_onto_Abs_Sum RS inj_onto_contraD) 1);
-by (rtac Inl_Rep_not_Inr_Rep 1);
-by (rtac Inl_RepI 1);
-by (rtac Inr_RepI 1);
-qed "Inl_not_Inr";
-
-bind_thm ("Inl_neq_Inr", (Inl_not_Inr RS notE));
-val Inr_neq_Inl = sym RS Inl_neq_Inr;
-
-goal Sum.thy "(Inl(a)=Inr(b)) = False";
-by (simp_tac (HOL_ss addsimps [Inl_not_Inr]) 1);
-qed "Inl_Inr_eq";
-
-goal Sum.thy "(Inr(b)=Inl(a)) = False";
-by (simp_tac (HOL_ss addsimps [Inl_not_Inr RS not_sym]) 1);
-qed "Inr_Inl_eq";
-
-
-(** Injectiveness of Inl and Inr **)
-
-val [major] = goalw Sum.thy [Inl_Rep_def] "Inl_Rep(a) = Inl_Rep(c) ==> a=c";
-by (rtac (major RS fun_cong RS fun_cong RS fun_cong RS iffE) 1);
-by (fast_tac HOL_cs 1);
-qed "Inl_Rep_inject";
-
-val [major] = goalw Sum.thy [Inr_Rep_def] "Inr_Rep(b) = Inr_Rep(d) ==> b=d";
-by (rtac (major RS fun_cong RS fun_cong RS fun_cong RS iffE) 1);
-by (fast_tac HOL_cs 1);
-qed "Inr_Rep_inject";
-
-goalw Sum.thy [Inl_def] "inj(Inl)";
-by (rtac injI 1);
-by (etac (inj_onto_Abs_Sum RS inj_ontoD RS Inl_Rep_inject) 1);
-by (rtac Inl_RepI 1);
-by (rtac Inl_RepI 1);
-qed "inj_Inl";
-val Inl_inject = inj_Inl RS injD;
-
-goalw Sum.thy [Inr_def] "inj(Inr)";
-by (rtac injI 1);
-by (etac (inj_onto_Abs_Sum RS inj_ontoD RS Inr_Rep_inject) 1);
-by (rtac Inr_RepI 1);
-by (rtac Inr_RepI 1);
-qed "inj_Inr";
-val Inr_inject = inj_Inr RS injD;
-
-goal Sum.thy "(Inl(x)=Inl(y)) = (x=y)";
-by (fast_tac (HOL_cs addSEs [Inl_inject]) 1);
-qed "Inl_eq";
-
-goal Sum.thy "(Inr(x)=Inr(y)) = (x=y)";
-by (fast_tac (HOL_cs addSEs [Inr_inject]) 1);
-qed "Inr_eq";
-
-(*** Rules for the disjoint sum of two SETS ***)
-
-(** Introduction rules for the injections **)
-
-goalw Sum.thy [sum_def] "!!a A B. a : A ==> Inl(a) : A plus B";
-by (REPEAT (ares_tac [UnI1,imageI] 1));
-qed "InlI";
-
-goalw Sum.thy [sum_def] "!!b A B. b : B ==> Inr(b) : A plus B";
-by (REPEAT (ares_tac [UnI2,imageI] 1));
-qed "InrI";
-
-(** Elimination rules **)
-
-val major::prems = goalw Sum.thy [sum_def]
- "[| u: A plus B; \
-\ !!x. [| x:A; u=Inl(x) |] ==> P; \
-\ !!y. [| y:B; u=Inr(y) |] ==> P \
-\ |] ==> P";
-by (rtac (major RS UnE) 1);
-by (REPEAT (rtac refl 1
- ORELSE eresolve_tac (prems@[imageE,ssubst]) 1));
-qed "plusE";
-
-
-val sum_cs = set_cs addSIs [InlI, InrI]
- addSEs [plusE, Inl_neq_Inr, Inr_neq_Inl]
- addSDs [Inl_inject, Inr_inject];
-
-
-(** sum_case -- the selection operator for sums **)
-
-goalw Sum.thy [sum_case_def] "sum_case(f, g, Inl(x)) = f(x)";
-by (fast_tac (sum_cs addIs [select_equality]) 1);
-qed "sum_case_Inl";
-
-goalw Sum.thy [sum_case_def] "sum_case(f, g, Inr(x)) = g(x)";
-by (fast_tac (sum_cs addIs [select_equality]) 1);
-qed "sum_case_Inr";
-
-(** Exhaustion rule for sums -- a degenerate form of induction **)
-
-val prems = goalw Sum.thy [Inl_def,Inr_def]
- "[| !!x::'a. s = Inl(x) ==> P; !!y::'b. s = Inr(y) ==> P \
-\ |] ==> P";
-by (rtac (rewrite_rule [Sum_def] Rep_Sum RS CollectE) 1);
-by (REPEAT (eresolve_tac [disjE,exE] 1
- ORELSE EVERY1 [resolve_tac prems,
- etac subst,
- rtac (Rep_Sum_inverse RS sym)]));
-qed "sumE";
-
-goal Sum.thy "sum_case(%x::'a. f(Inl(x)), %y::'b. f(Inr(y)), s) = f(s)";
-by (EVERY1 [res_inst_tac [("s","s")] sumE,
- etac ssubst, rtac sum_case_Inl,
- etac ssubst, rtac sum_case_Inr]);
-qed "surjective_sum";
-
-goal Sum.thy "R(sum_case(f,g,s)) = \
-\ ((! x. s = Inl(x) --> R(f(x))) & (! y. s = Inr(y) --> R(g(y))))";
-by (rtac sumE 1);
-by (etac ssubst 1);
-by (stac sum_case_Inl 1);
-by (fast_tac (set_cs addSEs [make_elim Inl_inject, Inl_neq_Inr]) 1);
-by (etac ssubst 1);
-by (stac sum_case_Inr 1);
-by (fast_tac (set_cs addSEs [make_elim Inr_inject, Inr_neq_Inl]) 1);
-qed "expand_sum_case";
-
-val sum_ss = prod_ss addsimps [Inl_eq, Inr_eq, Inl_Inr_eq, Inr_Inl_eq,
- sum_case_Inl, sum_case_Inr];
-
-(*Prevents simplification of f and g: much faster*)
-qed_goal "sum_case_weak_cong" Sum.thy
- "s=t ==> sum_case(f,g,s) = sum_case(f,g,t)"
- (fn [prem] => [rtac (prem RS arg_cong) 1]);
-
-
-
-
-(** Rules for the Part primitive **)
-
-goalw Sum.thy [Part_def]
- "!!a b A h. [| a : A; a=h(b) |] ==> a : Part(A,h)";
-by (fast_tac set_cs 1);
-qed "Part_eqI";
-
-val PartI = refl RSN (2,Part_eqI);
-
-val major::prems = goalw Sum.thy [Part_def]
- "[| a : Part(A,h); !!z. [| a : A; a=h(z) |] ==> P \
-\ |] ==> P";
-by (rtac (major RS IntE) 1);
-by (etac CollectE 1);
-by (etac exE 1);
-by (REPEAT (ares_tac prems 1));
-qed "PartE";
-
-goalw Sum.thy [Part_def] "Part(A,h) <= A";
-by (rtac Int_lower1 1);
-qed "Part_subset";
-
-goal Sum.thy "!!A B. A<=B ==> Part(A,h) <= Part(B,h)";
-by (fast_tac (set_cs addSIs [PartI] addSEs [PartE]) 1);
-qed "Part_mono";
-
-goalw Sum.thy [Part_def] "!!a. a : Part(A,h) ==> a : A";
-by (etac IntD1 1);
-qed "PartD1";
-
-goal Sum.thy "Part(A,%x.x) = A";
-by (fast_tac (set_cs addIs [PartI,equalityI] addSEs [PartE]) 1);
-qed "Part_id";
-
--- a/Sum.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,51 +0,0 @@
-(* Title: HOL/Sum.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-The disjoint sum of two types.
-*)
-
-Sum = Prod +
-
-(* type definition *)
-
-consts
- Inl_Rep :: "['a, 'a, 'b, bool] => bool"
- Inr_Rep :: "['b, 'a, 'b, bool] => bool"
-
-defs
- Inl_Rep_def "Inl_Rep == (%a. %x y p. x=a & p)"
- Inr_Rep_def "Inr_Rep == (%b. %x y p. y=b & ~p)"
-
-subtype (Sum)
- ('a, 'b) "+" (infixr 10)
- = "{f. (? a. f = Inl_Rep(a::'a)) | (? b. f = Inr_Rep(b::'b))}"
-
-
-(* abstract constants and syntax *)
-
-consts
- Inl :: "'a => 'a + 'b"
- Inr :: "'b => 'a + 'b"
- sum_case :: "['a => 'c, 'b => 'c, 'a + 'b] => 'c"
-
- (*disjoint sum for sets; the operator + is overloaded with wrong type!*)
- "plus" :: "['a set, 'b set] => ('a + 'b) set" (infixr 65)
- Part :: "['a set, 'b => 'a] => 'a set"
-
-translations
- "case p of Inl(x) => a | Inr(y) => b" == "sum_case(%x.a, %y.b, p)"
-
-defs
- Inl_def "Inl == (%a. Abs_Sum(Inl_Rep(a)))"
- Inr_def "Inr == (%b. Abs_Sum(Inr_Rep(b)))"
- sum_case_def "sum_case(f, g, p) == @z. (!x. p=Inl(x) --> z=f(x))
- & (!y. p=Inr(y) --> z=g(y))"
-
- sum_def "A plus B == (Inl``A) Un (Inr``B)"
-
- (*for selecting out the components of a mutually recursive definition*)
- Part_def "Part(A, h) == A Int {x. ? z. x = h(z)}"
-
-end
--- a/Trancl.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,237 +0,0 @@
-(* Title: HOL/trancl
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-For trancl.thy. Theorems about the transitive closure of a relation
-*)
-
-open Trancl;
-
-(** Natural deduction for trans(r) **)
-
-val prems = goalw Trancl.thy [trans_def]
- "(!! x y z. [| <x,y>:r; <y,z>:r |] ==> <x,z>:r) ==> trans(r)";
-by (REPEAT (ares_tac (prems@[allI,impI]) 1));
-qed "transI";
-
-val major::prems = goalw Trancl.thy [trans_def]
- "[| trans(r); <a,b>:r; <b,c>:r |] ==> <a,c>:r";
-by (cut_facts_tac [major] 1);
-by (fast_tac (HOL_cs addIs prems) 1);
-qed "transD";
-
-(** Identity relation **)
-
-goalw Trancl.thy [id_def] "<a,a> : id";
-by (rtac CollectI 1);
-by (rtac exI 1);
-by (rtac refl 1);
-qed "idI";
-
-val major::prems = goalw Trancl.thy [id_def]
- "[| p: id; !!x.[| p = <x,x> |] ==> P \
-\ |] ==> P";
-by (rtac (major RS CollectE) 1);
-by (etac exE 1);
-by (eresolve_tac prems 1);
-qed "idE";
-
-goalw Trancl.thy [id_def] "<a,b>:id = (a=b)";
-by(fast_tac prod_cs 1);
-qed "pair_in_id_conv";
-
-(** Composition of two relations **)
-
-val prems = goalw Trancl.thy [comp_def]
- "[| <a,b>:s; <b,c>:r |] ==> <a,c> : r O s";
-by (fast_tac (set_cs addIs prems) 1);
-qed "compI";
-
-(*proof requires higher-level assumptions or a delaying of hyp_subst_tac*)
-val prems = goalw Trancl.thy [comp_def]
- "[| xz : r O s; \
-\ !!x y z. [| xz = <x,z>; <x,y>:s; <y,z>:r |] ==> P \
-\ |] ==> P";
-by (cut_facts_tac prems 1);
-by (REPEAT (eresolve_tac [CollectE, exE, conjE] 1 ORELSE ares_tac prems 1));
-qed "compE";
-
-val prems = goal Trancl.thy
- "[| <a,c> : r O s; \
-\ !!y. [| <a,y>:s; <y,c>:r |] ==> P \
-\ |] ==> P";
-by (rtac compE 1);
-by (REPEAT (ares_tac prems 1 ORELSE eresolve_tac [Pair_inject,ssubst] 1));
-qed "compEpair";
-
-val comp_cs = prod_cs addIs [compI, idI] addSEs [compE, idE];
-
-goal Trancl.thy "!!r s. [| r'<=r; s'<=s |] ==> (r' O s') <= (r O s)";
-by (fast_tac comp_cs 1);
-qed "comp_mono";
-
-goal Trancl.thy
- "!!r s. [| s <= Sigma(A,%x.B); r <= Sigma(B,%x.C) |] ==> \
-\ (r O s) <= Sigma(A,%x.C)";
-by (fast_tac comp_cs 1);
-qed "comp_subset_Sigma";
-
-
-(** The relation rtrancl **)
-
-goal Trancl.thy "mono(%s. id Un (r O s))";
-by (rtac monoI 1);
-by (REPEAT (ares_tac [monoI, subset_refl, comp_mono, Un_mono] 1));
-qed "rtrancl_fun_mono";
-
-val rtrancl_unfold = rtrancl_fun_mono RS (rtrancl_def RS def_lfp_Tarski);
-
-(*Reflexivity of rtrancl*)
-goal Trancl.thy "<a,a> : r^*";
-by (stac rtrancl_unfold 1);
-by (fast_tac comp_cs 1);
-qed "rtrancl_refl";
-
-(*Closure under composition with r*)
-val prems = goal Trancl.thy
- "[| <a,b> : r^*; <b,c> : r |] ==> <a,c> : r^*";
-by (stac rtrancl_unfold 1);
-by (fast_tac (comp_cs addIs prems) 1);
-qed "rtrancl_into_rtrancl";
-
-(*rtrancl of r contains r*)
-val [prem] = goal Trancl.thy "[| <a,b> : r |] ==> <a,b> : r^*";
-by (rtac (rtrancl_refl RS rtrancl_into_rtrancl) 1);
-by (rtac prem 1);
-qed "r_into_rtrancl";
-
-(*monotonicity of rtrancl*)
-goalw Trancl.thy [rtrancl_def] "!!r s. r <= s ==> r^* <= s^*";
-by(REPEAT(ares_tac [lfp_mono,Un_mono,comp_mono,subset_refl] 1));
-qed "rtrancl_mono";
-
-(** standard induction rule **)
-
-val major::prems = goal Trancl.thy
- "[| <a,b> : r^*; \
-\ !!x. P(<x,x>); \
-\ !!x y z.[| P(<x,y>); <x,y>: r^*; <y,z>: r |] ==> P(<x,z>) |] \
-\ ==> P(<a,b>)";
-by (rtac ([rtrancl_def, rtrancl_fun_mono, major] MRS def_induct) 1);
-by (fast_tac (comp_cs addIs prems) 1);
-qed "rtrancl_full_induct";
-
-(*nice induction rule*)
-val major::prems = goal Trancl.thy
- "[| <a::'a,b> : r^*; \
-\ P(a); \
-\ !!y z.[| <a,y> : r^*; <y,z> : r; P(y) |] ==> P(z) |] \
-\ ==> P(b)";
-(*by induction on this formula*)
-by (subgoal_tac "! y. <a::'a,b> = <a,y> --> P(y)" 1);
-(*now solve first subgoal: this formula is sufficient*)
-by (fast_tac HOL_cs 1);
-(*now do the induction*)
-by (resolve_tac [major RS rtrancl_full_induct] 1);
-by (fast_tac (comp_cs addIs prems) 1);
-by (fast_tac (comp_cs addIs prems) 1);
-qed "rtrancl_induct";
-
-(*transitivity of transitive closure!! -- by induction.*)
-goal Trancl.thy "trans(r^*)";
-by (rtac transI 1);
-by (res_inst_tac [("b","z")] rtrancl_induct 1);
-by (DEPTH_SOLVE (eresolve_tac [asm_rl, rtrancl_into_rtrancl] 1));
-qed "trans_rtrancl";
-
-(*elimination of rtrancl -- by induction on a special formula*)
-val major::prems = goal Trancl.thy
- "[| <a::'a,b> : r^*; (a = b) ==> P; \
-\ !!y.[| <a,y> : r^*; <y,b> : r |] ==> P \
-\ |] ==> P";
-by (subgoal_tac "(a::'a) = b | (? y. <a,y> : r^* & <y,b> : r)" 1);
-by (rtac (major RS rtrancl_induct) 2);
-by (fast_tac (set_cs addIs prems) 2);
-by (fast_tac (set_cs addIs prems) 2);
-by (REPEAT (eresolve_tac ([asm_rl,exE,disjE,conjE]@prems) 1));
-qed "rtranclE";
-
-
-(**** The relation trancl ****)
-
-(** Conversions between trancl and rtrancl **)
-
-val [major] = goalw Trancl.thy [trancl_def]
- "<a,b> : r^+ ==> <a,b> : r^*";
-by (resolve_tac [major RS compEpair] 1);
-by (REPEAT (ares_tac [rtrancl_into_rtrancl] 1));
-qed "trancl_into_rtrancl";
-
-(*r^+ contains r*)
-val [prem] = goalw Trancl.thy [trancl_def]
- "[| <a,b> : r |] ==> <a,b> : r^+";
-by (REPEAT (ares_tac [prem,compI,rtrancl_refl] 1));
-qed "r_into_trancl";
-
-(*intro rule by definition: from rtrancl and r*)
-val prems = goalw Trancl.thy [trancl_def]
- "[| <a,b> : r^*; <b,c> : r |] ==> <a,c> : r^+";
-by (REPEAT (resolve_tac ([compI]@prems) 1));
-qed "rtrancl_into_trancl1";
-
-(*intro rule from r and rtrancl*)
-val prems = goal Trancl.thy
- "[| <a,b> : r; <b,c> : r^* |] ==> <a,c> : r^+";
-by (resolve_tac (prems RL [rtranclE]) 1);
-by (etac subst 1);
-by (resolve_tac (prems RL [r_into_trancl]) 1);
-by (rtac (trans_rtrancl RS transD RS rtrancl_into_trancl1) 1);
-by (REPEAT (ares_tac (prems@[r_into_rtrancl]) 1));
-qed "rtrancl_into_trancl2";
-
-(*elimination of r^+ -- NOT an induction rule*)
-val major::prems = goal Trancl.thy
- "[| <a::'a,b> : r^+; \
-\ <a,b> : r ==> P; \
-\ !!y.[| <a,y> : r^+; <y,b> : r |] ==> P \
-\ |] ==> P";
-by (subgoal_tac "<a::'a,b> : r | (? y. <a,y> : r^+ & <y,b> : r)" 1);
-by (REPEAT (eresolve_tac ([asm_rl,disjE,exE,conjE]@prems) 1));
-by (rtac (rewrite_rule [trancl_def] major RS compEpair) 1);
-by (etac rtranclE 1);
-by (fast_tac comp_cs 1);
-by (fast_tac (comp_cs addSIs [rtrancl_into_trancl1]) 1);
-qed "tranclE";
-
-(*Transitivity of r^+.
- Proved by unfolding since it uses transitivity of rtrancl. *)
-goalw Trancl.thy [trancl_def] "trans(r^+)";
-by (rtac transI 1);
-by (REPEAT (etac compEpair 1));
-by (rtac (rtrancl_into_rtrancl RS (trans_rtrancl RS transD RS compI)) 1);
-by (REPEAT (assume_tac 1));
-qed "trans_trancl";
-
-val prems = goal Trancl.thy
- "[| <a,b> : r; <b,c> : r^+ |] ==> <a,c> : r^+";
-by (rtac (r_into_trancl RS (trans_trancl RS transD)) 1);
-by (resolve_tac prems 1);
-by (resolve_tac prems 1);
-qed "trancl_into_trancl2";
-
-
-val major::prems = goal Trancl.thy
- "[| <a,b> : r^*; r <= Sigma(A,%x.A) |] ==> a=b | a:A";
-by (cut_facts_tac prems 1);
-by (rtac (major RS rtrancl_induct) 1);
-by (rtac (refl RS disjI1) 1);
-by (fast_tac (comp_cs addSEs [SigmaE2]) 1);
-qed "trancl_subset_Sigma_lemma";
-
-goalw Trancl.thy [trancl_def]
- "!!r. r <= Sigma(A,%x.A) ==> trancl(r) <= Sigma(A,%x.A)";
-by (fast_tac (comp_cs addSDs [trancl_subset_Sigma_lemma]) 1);
-qed "trancl_subset_Sigma";
-
-val prod_ss = prod_ss addsimps [pair_in_id_conv];
--- a/Trancl.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,26 +0,0 @@
-(* Title: HOL/trancl.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-Transitive closure of a relation
-
-rtrancl is refl/transitive closure; trancl is transitive closure
-*)
-
-Trancl = Lfp + Prod +
-consts
- trans :: "('a * 'a)set => bool" (*transitivity predicate*)
- id :: "('a * 'a)set"
- rtrancl :: "('a * 'a)set => ('a * 'a)set" ("(_^*)" [100] 100)
- trancl :: "('a * 'a)set => ('a * 'a)set" ("(_^+)" [100] 100)
- O :: "[('b * 'c)set, ('a * 'b)set] => ('a * 'c)set" (infixr 60)
-defs
-trans_def "trans(r) == (!x y z. <x,y>:r --> <y,z>:r --> <x,z>:r)"
-comp_def (*composition of relations*)
- "r O s == {xz. ? x y z. xz = <x,z> & <x,y>:s & <y,z>:r}"
-id_def (*the identity relation*)
- "id == {p. ? x. p = <x,x>}"
-rtrancl_def "r^* == lfp(%s. id Un (r O s))"
-trancl_def "r^+ == r O rtrancl(r)"
-end
--- a/Univ.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,615 +0,0 @@
-(* Title: HOL/univ
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-For univ.thy
-*)
-
-open Univ;
-
-(** LEAST -- the least number operator **)
-
-
-val [prem1,prem2] = goalw Univ.thy [Least_def]
- "[| P(k); !!x. x<k ==> ~P(x) |] ==> (LEAST x.P(x)) = k";
-by (rtac select_equality 1);
-by (fast_tac (HOL_cs addSIs [prem1,prem2]) 1);
-by (cut_facts_tac [less_linear] 1);
-by (fast_tac (HOL_cs addSIs [prem1] addSDs [prem2]) 1);
-qed "Least_equality";
-
-val [prem] = goal Univ.thy "P(k) ==> P(LEAST x.P(x))";
-by (rtac (prem RS rev_mp) 1);
-by (res_inst_tac [("n","k")] less_induct 1);
-by (rtac impI 1);
-by (rtac classical 1);
-by (res_inst_tac [("s","n")] (Least_equality RS ssubst) 1);
-by (assume_tac 1);
-by (assume_tac 2);
-by (fast_tac HOL_cs 1);
-qed "LeastI";
-
-(*Proof is almost identical to the one above!*)
-val [prem] = goal Univ.thy "P(k) ==> (LEAST x.P(x)) <= k";
-by (rtac (prem RS rev_mp) 1);
-by (res_inst_tac [("n","k")] less_induct 1);
-by (rtac impI 1);
-by (rtac classical 1);
-by (res_inst_tac [("s","n")] (Least_equality RS ssubst) 1);
-by (assume_tac 1);
-by (rtac le_refl 2);
-by (fast_tac (HOL_cs addIs [less_imp_le,le_trans]) 1);
-qed "Least_le";
-
-val [prem] = goal Univ.thy "k < (LEAST x.P(x)) ==> ~P(k)";
-by (rtac notI 1);
-by (etac (rewrite_rule [le_def] Least_le RS notE) 1);
-by (rtac prem 1);
-qed "not_less_Least";
-
-
-(** apfst -- can be used in similar type definitions **)
-
-goalw Univ.thy [apfst_def] "apfst(f,<a,b>) = <f(a),b>";
-by (rtac split 1);
-qed "apfst_conv";
-
-val [major,minor] = goal Univ.thy
- "[| q = apfst(f,p); !!x y. [| p = <x,y>; q = <f(x),y> |] ==> R \
-\ |] ==> R";
-by (rtac PairE 1);
-by (rtac minor 1);
-by (assume_tac 1);
-by (rtac (major RS trans) 1);
-by (etac ssubst 1);
-by (rtac apfst_conv 1);
-qed "apfst_convE";
-
-(** Push -- an injection, analogous to Cons on lists **)
-
-val [major] = goalw Univ.thy [Push_def] "Push(i,f)=Push(j,g) ==> i=j";
-by (rtac (major RS fun_cong RS box_equals RS Suc_inject) 1);
-by (rtac nat_case_0 1);
-by (rtac nat_case_0 1);
-qed "Push_inject1";
-
-val [major] = goalw Univ.thy [Push_def] "Push(i,f)=Push(j,g) ==> f=g";
-by (rtac (major RS fun_cong RS ext RS box_equals) 1);
-by (rtac (nat_case_Suc RS ext) 1);
-by (rtac (nat_case_Suc RS ext) 1);
-qed "Push_inject2";
-
-val [major,minor] = goal Univ.thy
- "[| Push(i,f)=Push(j,g); [| i=j; f=g |] ==> P \
-\ |] ==> P";
-by (rtac ((major RS Push_inject2) RS ((major RS Push_inject1) RS minor)) 1);
-qed "Push_inject";
-
-val [major] = goalw Univ.thy [Push_def] "Push(k,f)=(%z.0) ==> P";
-by (rtac (major RS fun_cong RS box_equals RS Suc_neq_Zero) 1);
-by (rtac nat_case_0 1);
-by (rtac refl 1);
-qed "Push_neq_K0";
-
-(*** Isomorphisms ***)
-
-goal Univ.thy "inj(Rep_Node)";
-by (rtac inj_inverseI 1); (*cannot combine by RS: multiple unifiers*)
-by (rtac Rep_Node_inverse 1);
-qed "inj_Rep_Node";
-
-goal Univ.thy "inj_onto(Abs_Node,Node)";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_Node_inverse 1);
-qed "inj_onto_Abs_Node";
-
-val Abs_Node_inject = inj_onto_Abs_Node RS inj_ontoD;
-
-
-(*** Introduction rules for Node ***)
-
-goalw Univ.thy [Node_def] "<%k. 0,a> : Node";
-by (fast_tac set_cs 1);
-qed "Node_K0_I";
-
-goalw Univ.thy [Node_def,Push_def]
- "!!p. p: Node ==> apfst(Push(i), p) : Node";
-by (fast_tac (set_cs addSIs [apfst_conv, nat_case_Suc RS trans]) 1);
-qed "Node_Push_I";
-
-
-(*** Distinctness of constructors ***)
-
-(** Scons vs Atom **)
-
-goalw Univ.thy [Atom_def,Scons_def,Push_Node_def] "(M$N) ~= Atom(a)";
-by (rtac notI 1);
-by (etac (equalityD2 RS subsetD RS UnE) 1);
-by (rtac singletonI 1);
-by (REPEAT (eresolve_tac [imageE, Abs_Node_inject RS apfst_convE,
- Pair_inject, sym RS Push_neq_K0] 1
- ORELSE resolve_tac [Node_K0_I, Rep_Node RS Node_Push_I] 1));
-qed "Scons_not_Atom";
-bind_thm ("Atom_not_Scons", (Scons_not_Atom RS not_sym));
-
-bind_thm ("Scons_neq_Atom", (Scons_not_Atom RS notE));
-val Atom_neq_Scons = sym RS Scons_neq_Atom;
-
-(*** Injectiveness ***)
-
-(** Atomic nodes **)
-
-goalw Univ.thy [Atom_def] "inj(Atom)";
-by (rtac injI 1);
-by (etac (singleton_inject RS Abs_Node_inject RS Pair_inject) 1);
-by (REPEAT (ares_tac [Node_K0_I] 1));
-qed "inj_Atom";
-val Atom_inject = inj_Atom RS injD;
-
-goalw Univ.thy [Leaf_def,o_def] "inj(Leaf)";
-by (rtac injI 1);
-by (etac (Atom_inject RS Inl_inject) 1);
-qed "inj_Leaf";
-
-val Leaf_inject = inj_Leaf RS injD;
-
-goalw Univ.thy [Numb_def,o_def] "inj(Numb)";
-by (rtac injI 1);
-by (etac (Atom_inject RS Inr_inject) 1);
-qed "inj_Numb";
-
-val Numb_inject = inj_Numb RS injD;
-
-(** Injectiveness of Push_Node **)
-
-val [major,minor] = goalw Univ.thy [Push_Node_def]
- "[| Push_Node(i,m)=Push_Node(j,n); [| i=j; m=n |] ==> P \
-\ |] ==> P";
-by (rtac (major RS Abs_Node_inject RS apfst_convE) 1);
-by (REPEAT (resolve_tac [Rep_Node RS Node_Push_I] 1));
-by (etac (sym RS apfst_convE) 1);
-by (rtac minor 1);
-by (etac Pair_inject 1);
-by (etac (Push_inject1 RS sym) 1);
-by (rtac (inj_Rep_Node RS injD) 1);
-by (etac trans 1);
-by (safe_tac (HOL_cs addSEs [Pair_inject,Push_inject,sym]));
-qed "Push_Node_inject";
-
-
-(** Injectiveness of Scons **)
-
-val [major] = goalw Univ.thy [Scons_def] "M$N <= M'$N' ==> M<=M'";
-by (cut_facts_tac [major] 1);
-by (fast_tac (set_cs addSDs [Suc_inject]
- addSEs [Push_Node_inject, Zero_neq_Suc]) 1);
-qed "Scons_inject_lemma1";
-
-val [major] = goalw Univ.thy [Scons_def] "M$N <= M'$N' ==> N<=N'";
-by (cut_facts_tac [major] 1);
-by (fast_tac (set_cs addSDs [Suc_inject]
- addSEs [Push_Node_inject, Suc_neq_Zero]) 1);
-qed "Scons_inject_lemma2";
-
-val [major] = goal Univ.thy "M$N = M'$N' ==> M=M'";
-by (rtac (major RS equalityE) 1);
-by (REPEAT (ares_tac [equalityI, Scons_inject_lemma1] 1));
-qed "Scons_inject1";
-
-val [major] = goal Univ.thy "M$N = M'$N' ==> N=N'";
-by (rtac (major RS equalityE) 1);
-by (REPEAT (ares_tac [equalityI, Scons_inject_lemma2] 1));
-qed "Scons_inject2";
-
-val [major,minor] = goal Univ.thy
- "[| M$N = M'$N'; [| M=M'; N=N' |] ==> P \
-\ |] ==> P";
-by (rtac ((major RS Scons_inject2) RS ((major RS Scons_inject1) RS minor)) 1);
-qed "Scons_inject";
-
-(*rewrite rules*)
-goal Univ.thy "(Atom(a)=Atom(b)) = (a=b)";
-by (fast_tac (HOL_cs addSEs [Atom_inject]) 1);
-qed "Atom_Atom_eq";
-
-goal Univ.thy "(M$N = M'$N') = (M=M' & N=N')";
-by (fast_tac (HOL_cs addSEs [Scons_inject]) 1);
-qed "Scons_Scons_eq";
-
-(*** Distinctness involving Leaf and Numb ***)
-
-(** Scons vs Leaf **)
-
-goalw Univ.thy [Leaf_def,o_def] "(M$N) ~= Leaf(a)";
-by (rtac Scons_not_Atom 1);
-qed "Scons_not_Leaf";
-bind_thm ("Leaf_not_Scons", (Scons_not_Leaf RS not_sym));
-
-bind_thm ("Scons_neq_Leaf", (Scons_not_Leaf RS notE));
-val Leaf_neq_Scons = sym RS Scons_neq_Leaf;
-
-(** Scons vs Numb **)
-
-goalw Univ.thy [Numb_def,o_def] "(M$N) ~= Numb(k)";
-by (rtac Scons_not_Atom 1);
-qed "Scons_not_Numb";
-bind_thm ("Numb_not_Scons", (Scons_not_Numb RS not_sym));
-
-bind_thm ("Scons_neq_Numb", (Scons_not_Numb RS notE));
-val Numb_neq_Scons = sym RS Scons_neq_Numb;
-
-(** Leaf vs Numb **)
-
-goalw Univ.thy [Leaf_def,Numb_def] "Leaf(a) ~= Numb(k)";
-by (simp_tac (HOL_ss addsimps [Atom_Atom_eq,Inl_not_Inr]) 1);
-qed "Leaf_not_Numb";
-bind_thm ("Numb_not_Leaf", (Leaf_not_Numb RS not_sym));
-
-bind_thm ("Leaf_neq_Numb", (Leaf_not_Numb RS notE));
-val Numb_neq_Leaf = sym RS Leaf_neq_Numb;
-
-
-(*** ndepth -- the depth of a node ***)
-
-val univ_simps = [apfst_conv,Scons_not_Atom,Atom_not_Scons,Scons_Scons_eq];
-val univ_ss = nat_ss addsimps univ_simps;
-
-
-goalw Univ.thy [ndepth_def] "ndepth (Abs_Node(<%k.0, x>)) = 0";
-by (sstac [Node_K0_I RS Abs_Node_inverse, split] 1);
-by (rtac Least_equality 1);
-by (rtac refl 1);
-by (etac less_zeroE 1);
-qed "ndepth_K0";
-
-goal Univ.thy "k < Suc(LEAST x. f(x)=0) --> nat_case(Suc(i), f, k) ~= 0";
-by (nat_ind_tac "k" 1);
-by (ALLGOALS (simp_tac nat_ss));
-by (rtac impI 1);
-by (etac not_less_Least 1);
-qed "ndepth_Push_lemma";
-
-goalw Univ.thy [ndepth_def,Push_Node_def]
- "ndepth (Push_Node(i,n)) = Suc(ndepth(n))";
-by (stac (Rep_Node RS Node_Push_I RS Abs_Node_inverse) 1);
-by (cut_facts_tac [rewrite_rule [Node_def] Rep_Node] 1);
-by (safe_tac set_cs);
-be ssubst 1; (*instantiates type variables!*)
-by (simp_tac univ_ss 1);
-by (rtac Least_equality 1);
-by (rewtac Push_def);
-by (rtac (nat_case_Suc RS trans) 1);
-by (etac LeastI 1);
-by (etac (ndepth_Push_lemma RS mp) 1);
-qed "ndepth_Push_Node";
-
-
-(*** ntrunc applied to the various node sets ***)
-
-goalw Univ.thy [ntrunc_def] "ntrunc(0, M) = {}";
-by (safe_tac (set_cs addSIs [equalityI] addSEs [less_zeroE]));
-qed "ntrunc_0";
-
-goalw Univ.thy [Atom_def,ntrunc_def] "ntrunc(Suc(k), Atom(a)) = Atom(a)";
-by (safe_tac (set_cs addSIs [equalityI]));
-by (stac ndepth_K0 1);
-by (rtac zero_less_Suc 1);
-qed "ntrunc_Atom";
-
-goalw Univ.thy [Leaf_def,o_def] "ntrunc(Suc(k), Leaf(a)) = Leaf(a)";
-by (rtac ntrunc_Atom 1);
-qed "ntrunc_Leaf";
-
-goalw Univ.thy [Numb_def,o_def] "ntrunc(Suc(k), Numb(i)) = Numb(i)";
-by (rtac ntrunc_Atom 1);
-qed "ntrunc_Numb";
-
-goalw Univ.thy [Scons_def,ntrunc_def]
- "ntrunc(Suc(k), M$N) = ntrunc(k,M) $ ntrunc(k,N)";
-by (safe_tac (set_cs addSIs [equalityI,imageI]));
-by (REPEAT (stac ndepth_Push_Node 3 THEN etac Suc_mono 3));
-by (REPEAT (rtac Suc_less_SucD 1 THEN
- rtac (ndepth_Push_Node RS subst) 1 THEN
- assume_tac 1));
-qed "ntrunc_Scons";
-
-(** Injection nodes **)
-
-goalw Univ.thy [In0_def] "ntrunc(Suc(0), In0(M)) = {}";
-by (simp_tac (univ_ss addsimps [ntrunc_Scons,ntrunc_0]) 1);
-by (rewtac Scons_def);
-by (safe_tac (set_cs addSIs [equalityI]));
-qed "ntrunc_one_In0";
-
-goalw Univ.thy [In0_def]
- "ntrunc(Suc(Suc(k)), In0(M)) = In0 (ntrunc(Suc(k),M))";
-by (simp_tac (univ_ss addsimps [ntrunc_Scons,ntrunc_Numb]) 1);
-qed "ntrunc_In0";
-
-goalw Univ.thy [In1_def] "ntrunc(Suc(0), In1(M)) = {}";
-by (simp_tac (univ_ss addsimps [ntrunc_Scons,ntrunc_0]) 1);
-by (rewtac Scons_def);
-by (safe_tac (set_cs addSIs [equalityI]));
-qed "ntrunc_one_In1";
-
-goalw Univ.thy [In1_def]
- "ntrunc(Suc(Suc(k)), In1(M)) = In1 (ntrunc(Suc(k),M))";
-by (simp_tac (univ_ss addsimps [ntrunc_Scons,ntrunc_Numb]) 1);
-qed "ntrunc_In1";
-
-
-(*** Cartesian Product ***)
-
-goalw Univ.thy [uprod_def] "!!M N. [| M:A; N:B |] ==> (M$N) : A<*>B";
-by (REPEAT (ares_tac [singletonI,UN_I] 1));
-qed "uprodI";
-
-(*The general elimination rule*)
-val major::prems = goalw Univ.thy [uprod_def]
- "[| c : A<*>B; \
-\ !!x y. [| x:A; y:B; c=x$y |] ==> P \
-\ |] ==> P";
-by (cut_facts_tac [major] 1);
-by (REPEAT (eresolve_tac [asm_rl,singletonE,UN_E] 1
- ORELSE resolve_tac prems 1));
-qed "uprodE";
-
-(*Elimination of a pair -- introduces no eigenvariables*)
-val prems = goal Univ.thy
- "[| (M$N) : A<*>B; [| M:A; N:B |] ==> P \
-\ |] ==> P";
-by (rtac uprodE 1);
-by (REPEAT (ares_tac prems 1 ORELSE eresolve_tac [Scons_inject,ssubst] 1));
-qed "uprodE2";
-
-
-(*** Disjoint Sum ***)
-
-goalw Univ.thy [usum_def] "!!M. M:A ==> In0(M) : A<+>B";
-by (fast_tac set_cs 1);
-qed "usum_In0I";
-
-goalw Univ.thy [usum_def] "!!N. N:B ==> In1(N) : A<+>B";
-by (fast_tac set_cs 1);
-qed "usum_In1I";
-
-val major::prems = goalw Univ.thy [usum_def]
- "[| u : A<+>B; \
-\ !!x. [| x:A; u=In0(x) |] ==> P; \
-\ !!y. [| y:B; u=In1(y) |] ==> P \
-\ |] ==> P";
-by (rtac (major RS UnE) 1);
-by (REPEAT (rtac refl 1
- ORELSE eresolve_tac (prems@[imageE,ssubst]) 1));
-qed "usumE";
-
-
-(** Injection **)
-
-goalw Univ.thy [In0_def,In1_def] "In0(M) ~= In1(N)";
-by (rtac notI 1);
-by (etac (Scons_inject1 RS Numb_inject RS Zero_neq_Suc) 1);
-qed "In0_not_In1";
-
-bind_thm ("In1_not_In0", (In0_not_In1 RS not_sym));
-bind_thm ("In0_neq_In1", (In0_not_In1 RS notE));
-val In1_neq_In0 = sym RS In0_neq_In1;
-
-val [major] = goalw Univ.thy [In0_def] "In0(M) = In0(N) ==> M=N";
-by (rtac (major RS Scons_inject2) 1);
-qed "In0_inject";
-
-val [major] = goalw Univ.thy [In1_def] "In1(M) = In1(N) ==> M=N";
-by (rtac (major RS Scons_inject2) 1);
-qed "In1_inject";
-
-
-(*** proving equality of sets and functions using ntrunc ***)
-
-goalw Univ.thy [ntrunc_def] "ntrunc(k,M) <= M";
-by (fast_tac set_cs 1);
-qed "ntrunc_subsetI";
-
-val [major] = goalw Univ.thy [ntrunc_def]
- "(!!k. ntrunc(k,M) <= N) ==> M<=N";
-by (fast_tac (set_cs addIs [less_add_Suc1, less_add_Suc2,
- major RS subsetD]) 1);
-qed "ntrunc_subsetD";
-
-(*A generalized form of the take-lemma*)
-val [major] = goal Univ.thy "(!!k. ntrunc(k,M) = ntrunc(k,N)) ==> M=N";
-by (rtac equalityI 1);
-by (ALLGOALS (rtac ntrunc_subsetD));
-by (ALLGOALS (rtac (ntrunc_subsetI RSN (2, subset_trans))));
-by (rtac (major RS equalityD1) 1);
-by (rtac (major RS equalityD2) 1);
-qed "ntrunc_equality";
-
-val [major] = goalw Univ.thy [o_def]
- "[| !!k. (ntrunc(k) o h1) = (ntrunc(k) o h2) |] ==> h1=h2";
-by (rtac (ntrunc_equality RS ext) 1);
-by (rtac (major RS fun_cong) 1);
-qed "ntrunc_o_equality";
-
-(*** Monotonicity ***)
-
-goalw Univ.thy [uprod_def] "!!A B. [| A<=A'; B<=B' |] ==> A<*>B <= A'<*>B'";
-by (fast_tac set_cs 1);
-qed "uprod_mono";
-
-goalw Univ.thy [usum_def] "!!A B. [| A<=A'; B<=B' |] ==> A<+>B <= A'<+>B'";
-by (fast_tac set_cs 1);
-qed "usum_mono";
-
-goalw Univ.thy [Scons_def] "!!M N. [| M<=M'; N<=N' |] ==> M$N <= M'$N'";
-by (fast_tac set_cs 1);
-qed "Scons_mono";
-
-goalw Univ.thy [In0_def] "!!M N. M<=N ==> In0(M) <= In0(N)";
-by (REPEAT (ares_tac [subset_refl,Scons_mono] 1));
-qed "In0_mono";
-
-goalw Univ.thy [In1_def] "!!M N. M<=N ==> In1(M) <= In1(N)";
-by (REPEAT (ares_tac [subset_refl,Scons_mono] 1));
-qed "In1_mono";
-
-
-(*** Split and Case ***)
-
-goalw Univ.thy [Split_def] "Split(c, M$N) = c(M,N)";
-by (fast_tac (set_cs addIs [select_equality] addEs [Scons_inject]) 1);
-qed "Split";
-
-goalw Univ.thy [Case_def] "Case(c, d, In0(M)) = c(M)";
-by (fast_tac (set_cs addIs [select_equality]
- addEs [make_elim In0_inject, In0_neq_In1]) 1);
-qed "Case_In0";
-
-goalw Univ.thy [Case_def] "Case(c, d, In1(N)) = d(N)";
-by (fast_tac (set_cs addIs [select_equality]
- addEs [make_elim In1_inject, In1_neq_In0]) 1);
-qed "Case_In1";
-
-(**** UN x. B(x) rules ****)
-
-goalw Univ.thy [ntrunc_def] "ntrunc(k, UN x.f(x)) = (UN x. ntrunc(k, f(x)))";
-by (fast_tac (set_cs addIs [equalityI]) 1);
-qed "ntrunc_UN1";
-
-goalw Univ.thy [Scons_def] "(UN x.f(x)) $ M = (UN x. f(x) $ M)";
-by (fast_tac (set_cs addIs [equalityI]) 1);
-qed "Scons_UN1_x";
-
-goalw Univ.thy [Scons_def] "M $ (UN x.f(x)) = (UN x. M $ f(x))";
-by (fast_tac (set_cs addIs [equalityI]) 1);
-qed "Scons_UN1_y";
-
-goalw Univ.thy [In0_def] "In0(UN x.f(x)) = (UN x. In0(f(x)))";
-br Scons_UN1_y 1;
-qed "In0_UN1";
-
-goalw Univ.thy [In1_def] "In1(UN x.f(x)) = (UN x. In1(f(x)))";
-br Scons_UN1_y 1;
-qed "In1_UN1";
-
-
-(*** Equality : the diagonal relation ***)
-
-goalw Univ.thy [diag_def] "!!a A. [| a=b; a:A |] ==> <a,b> : diag(A)";
-by (fast_tac set_cs 1);
-qed "diag_eqI";
-
-val diagI = refl RS diag_eqI |> standard;
-
-(*The general elimination rule*)
-val major::prems = goalw Univ.thy [diag_def]
- "[| c : diag(A); \
-\ !!x y. [| x:A; c = <x,x> |] ==> P \
-\ |] ==> P";
-by (rtac (major RS UN_E) 1);
-by (REPEAT (eresolve_tac [asm_rl,singletonE] 1 ORELSE resolve_tac prems 1));
-qed "diagE";
-
-(*** Equality for Cartesian Product ***)
-
-goalw Univ.thy [dprod_def]
- "!!r s. [| <M,M'>:r; <N,N'>:s |] ==> <M$N, M'$N'> : r<**>s";
-by (fast_tac prod_cs 1);
-qed "dprodI";
-
-(*The general elimination rule*)
-val major::prems = goalw Univ.thy [dprod_def]
- "[| c : r<**>s; \
-\ !!x y x' y'. [| <x,x'> : r; <y,y'> : s; c = <x$y,x'$y'> |] ==> P \
-\ |] ==> P";
-by (cut_facts_tac [major] 1);
-by (REPEAT_FIRST (eresolve_tac [asm_rl, UN_E, mem_splitE, singletonE]));
-by (REPEAT (ares_tac prems 1 ORELSE hyp_subst_tac 1));
-qed "dprodE";
-
-
-(*** Equality for Disjoint Sum ***)
-
-goalw Univ.thy [dsum_def] "!!r. <M,M'>:r ==> <In0(M), In0(M')> : r<++>s";
-by (fast_tac prod_cs 1);
-qed "dsum_In0I";
-
-goalw Univ.thy [dsum_def] "!!r. <N,N'>:s ==> <In1(N), In1(N')> : r<++>s";
-by (fast_tac prod_cs 1);
-qed "dsum_In1I";
-
-val major::prems = goalw Univ.thy [dsum_def]
- "[| w : r<++>s; \
-\ !!x x'. [| <x,x'> : r; w = <In0(x), In0(x')> |] ==> P; \
-\ !!y y'. [| <y,y'> : s; w = <In1(y), In1(y')> |] ==> P \
-\ |] ==> P";
-by (cut_facts_tac [major] 1);
-by (REPEAT_FIRST (eresolve_tac [asm_rl, UN_E, UnE, mem_splitE, singletonE]));
-by (DEPTH_SOLVE (ares_tac prems 1 ORELSE hyp_subst_tac 1));
-qed "dsumE";
-
-
-val univ_cs =
- prod_cs addSIs [diagI, uprodI, dprodI]
- addIs [usum_In0I, usum_In1I, dsum_In0I, dsum_In1I]
- addSEs [diagE, uprodE, dprodE, usumE, dsumE];
-
-
-(*** Monotonicity ***)
-
-goal Univ.thy "!!r s. [| r<=r'; s<=s' |] ==> r<**>s <= r'<**>s'";
-by (fast_tac univ_cs 1);
-qed "dprod_mono";
-
-goal Univ.thy "!!r s. [| r<=r'; s<=s' |] ==> r<++>s <= r'<++>s'";
-by (fast_tac univ_cs 1);
-qed "dsum_mono";
-
-
-(*** Bounding theorems ***)
-
-goal Univ.thy "diag(A) <= Sigma(A,%x.A)";
-by (fast_tac univ_cs 1);
-qed "diag_subset_Sigma";
-
-goal Univ.thy "(Sigma(A,%x.B) <**> Sigma(C,%x.D)) <= Sigma(A<*>C, %z. B<*>D)";
-by (fast_tac univ_cs 1);
-qed "dprod_Sigma";
-
-val dprod_subset_Sigma = [dprod_mono, dprod_Sigma] MRS subset_trans |>standard;
-
-(*Dependent version*)
-goal Univ.thy
- "(Sigma(A,B) <**> Sigma(C,D)) <= Sigma(A<*>C, Split(%x y. B(x)<*>D(y)))";
-by (safe_tac univ_cs);
-by (stac Split 1);
-by (fast_tac univ_cs 1);
-qed "dprod_subset_Sigma2";
-
-goal Univ.thy "(Sigma(A,%x.B) <++> Sigma(C,%x.D)) <= Sigma(A<+>C, %z. B<+>D)";
-by (fast_tac univ_cs 1);
-qed "dsum_Sigma";
-
-val dsum_subset_Sigma = [dsum_mono, dsum_Sigma] MRS subset_trans |> standard;
-
-
-(*** Domain ***)
-
-goal Univ.thy "fst `` diag(A) = A";
-by (fast_tac (prod_cs addIs [equalityI, diagI] addSEs [diagE]) 1);
-qed "fst_image_diag";
-
-goal Univ.thy "fst `` (r<**>s) = (fst``r) <*> (fst``s)";
-by (fast_tac (prod_cs addIs [equalityI, uprodI, dprodI]
- addSEs [uprodE, dprodE]) 1);
-qed "fst_image_dprod";
-
-goal Univ.thy "fst `` (r<++>s) = (fst``r) <+> (fst``s)";
-by (fast_tac (prod_cs addIs [equalityI, usum_In0I, usum_In1I,
- dsum_In0I, dsum_In1I]
- addSEs [usumE, dsumE]) 1);
-qed "fst_image_dsum";
-
-val fst_image_simps = [fst_image_diag, fst_image_dprod, fst_image_dsum];
-val fst_image_ss = univ_ss addsimps fst_image_simps;
--- a/Univ.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,103 +0,0 @@
-(* Title: HOL/Univ.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Move LEAST to Nat.thy??? Could it be defined for all types 'a::ord?
-
-Declares the type 'a node, a subtype of (nat=>nat) * ('a+nat)
-
-Defines "Cartesian Product" and "Disjoint Sum" as set operations.
-Could <*> be generalized to a general summation (Sigma)?
-*)
-
-Univ = Arith + Sum +
-
-(** lists, trees will be sets of nodes **)
-
-subtype (Node)
- 'a node = "{p. EX f x k. p = <f::nat=>nat, x::'a+nat> & f(k)=0}"
-
-types
- 'a item = "'a node set"
-
-consts
- Least :: "(nat=>bool) => nat" (binder "LEAST " 10)
-
- apfst :: "['a=>'c, 'a*'b] => 'c*'b"
- Push :: "[nat, nat=>nat] => (nat=>nat)"
-
- Push_Node :: "[nat, 'a node] => 'a node"
- ndepth :: "'a node => nat"
-
- Atom :: "('a+nat) => 'a item"
- Leaf :: "'a => 'a item"
- Numb :: "nat => 'a item"
- "$" :: "['a item, 'a item]=> 'a item" (infixr 60)
- In0,In1 :: "'a item => 'a item"
-
- ntrunc :: "[nat, 'a item] => 'a item"
-
- "<*>" :: "['a item set, 'a item set]=> 'a item set" (infixr 80)
- "<+>" :: "['a item set, 'a item set]=> 'a item set" (infixr 70)
-
- Split :: "[['a item, 'a item]=>'b, 'a item] => 'b"
- Case :: "[['a item]=>'b, ['a item]=>'b, 'a item] => 'b"
-
- diag :: "'a set => ('a * 'a)set"
- "<**>" :: "[('a item * 'a item)set, ('a item * 'a item)set]
- => ('a item * 'a item)set" (infixr 80)
- "<++>" :: "[('a item * 'a item)set, ('a item * 'a item)set]
- => ('a item * 'a item)set" (infixr 70)
-
-defs
-
- (*least number operator*)
- Least_def "Least(P) == @k. P(k) & (ALL j. j<k --> ~P(j))"
-
- Push_Node_def "Push_Node == (%n x. Abs_Node (apfst(Push(n),Rep_Node(x))))"
-
- (*crude "lists" of nats -- needed for the constructions*)
- apfst_def "apfst == (%f. split(%x y. <f(x),y>))"
- Push_def "Push == (%b h. nat_case(Suc(b),h))"
-
- (** operations on S-expressions -- sets of nodes **)
-
- (*S-expression constructors*)
- Atom_def "Atom == (%x. {Abs_Node(<%k.0, x>)})"
- Scons_def "M$N == (Push_Node(0) `` M) Un (Push_Node(Suc(0)) `` N)"
-
- (*Leaf nodes, with arbitrary or nat labels*)
- Leaf_def "Leaf == Atom o Inl"
- Numb_def "Numb == Atom o Inr"
-
- (*Injections of the "disjoint sum"*)
- In0_def "In0(M) == Numb(0) $ M"
- In1_def "In1(M) == Numb(Suc(0)) $ M"
-
- (*the set of nodes with depth less than k*)
- ndepth_def "ndepth(n) == split(%f x. LEAST k. f(k)=0, Rep_Node(n))"
- ntrunc_def "ntrunc(k,N) == {n. n:N & ndepth(n)<k}"
-
- (*products and sums for the "universe"*)
- uprod_def "A<*>B == UN x:A. UN y:B. { (x$y) }"
- usum_def "A<+>B == In0``A Un In1``B"
-
- (*the corresponding eliminators*)
- Split_def "Split(c,M) == @u. ? x y. M = x$y & u = c(x,y)"
-
- Case_def "Case(c,d,M) == @u. (? x . M = In0(x) & u = c(x))
- | (? y . M = In1(y) & u = d(y))"
-
-
- (** diagonal sets and equality for the "universe" **)
-
- diag_def "diag(A) == UN x:A. {<x,x>}"
-
- dprod_def "r<**>s == UN u:r. split(%x x'.
- UN v:s. split(%y y'. {<x$y,x'$y'>}, v), u)"
-
- dsum_def "r<++>s == (UN u:r. split(%x x'. {<In0(x),In0(x')>}, u)) Un
- (UN v:s. split(%y y'. {<In1(y),In1(y')>}, v))"
-
-end
--- a/WF.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,197 +0,0 @@
-(* Title: HOL/wf.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1992 University of Cambridge
-
-For wf.thy. Well-founded Recursion
-*)
-
-open WF;
-
-val H_cong = read_instantiate [("f","H")] (standard(refl RS cong RS cong));
-val H_cong1 = refl RS H_cong;
-
-(*Restriction to domain A. If r is well-founded over A then wf(r)*)
-val [prem1,prem2] = goalw WF.thy [wf_def]
- "[| r <= Sigma(A, %u.A); \
-\ !!x P. [| ! x. (! y. <y,x> : r --> P(y)) --> P(x); x:A |] ==> P(x) |] \
-\ ==> wf(r)";
-by (strip_tac 1);
-by (rtac allE 1);
-by (assume_tac 1);
-by (best_tac (HOL_cs addSEs [prem1 RS subsetD RS SigmaE2] addIs [prem2]) 1);
-qed "wfI";
-
-val major::prems = goalw WF.thy [wf_def]
- "[| wf(r); \
-\ !!x.[| ! y. <y,x>: r --> P(y) |] ==> P(x) \
-\ |] ==> P(a)";
-by (rtac (major RS spec RS mp RS spec) 1);
-by (fast_tac (HOL_cs addEs prems) 1);
-qed "wf_induct";
-
-(*Perform induction on i, then prove the wf(r) subgoal using prems. *)
-fun wf_ind_tac a prems i =
- EVERY [res_inst_tac [("a",a)] wf_induct i,
- rename_last_tac a ["1"] (i+1),
- ares_tac prems i];
-
-val prems = goal WF.thy "[| wf(r); <a,x>:r; <x,a>:r |] ==> P";
-by (subgoal_tac "! x. <a,x>:r --> <x,a>:r --> P" 1);
-by (fast_tac (HOL_cs addIs prems) 1);
-by (wf_ind_tac "a" prems 1);
-by (fast_tac set_cs 1);
-qed "wf_asym";
-
-val prems = goal WF.thy "[| wf(r); <a,a>: r |] ==> P";
-by (rtac wf_asym 1);
-by (REPEAT (resolve_tac prems 1));
-qed "wf_anti_refl";
-
-(*transitive closure of a WF relation is WF!*)
-val [prem] = goal WF.thy "wf(r) ==> wf(r^+)";
-by (rewtac wf_def);
-by (strip_tac 1);
-(*must retain the universal formula for later use!*)
-by (rtac allE 1 THEN assume_tac 1);
-by (etac mp 1);
-by (res_inst_tac [("a","x")] (prem RS wf_induct) 1);
-by (rtac (impI RS allI) 1);
-by (etac tranclE 1);
-by (fast_tac HOL_cs 1);
-by (fast_tac HOL_cs 1);
-qed "wf_trancl";
-
-
-(** cut **)
-
-(*This rewrite rule works upon formulae; thus it requires explicit use of
- H_cong to expose the equality*)
-goalw WF.thy [cut_def]
- "(cut(f,r,x) = cut(g,r,x)) = (!y. <y,x>:r --> f(y)=g(y))";
-by(simp_tac (HOL_ss addsimps [expand_fun_eq]
- setloop (split_tac [expand_if])) 1);
-qed "cut_cut_eq";
-
-goalw WF.thy [cut_def] "!!x. <x,a>:r ==> cut(f,r,a)(x) = f(x)";
-by(asm_simp_tac HOL_ss 1);
-qed "cut_apply";
-
-
-(*** is_recfun ***)
-
-goalw WF.thy [is_recfun_def,cut_def]
- "!!f. [| is_recfun(r,a,H,f); ~<b,a>:r |] ==> f(b) = (@z.True)";
-by (etac ssubst 1);
-by(asm_simp_tac HOL_ss 1);
-qed "is_recfun_undef";
-
-(*eresolve_tac transD solves <a,b>:r using transitivity AT MOST ONCE
- mp amd allE instantiate induction hypotheses*)
-fun indhyp_tac hyps =
- ares_tac (TrueI::hyps) ORELSE'
- (cut_facts_tac hyps THEN'
- DEPTH_SOLVE_1 o (ares_tac [TrueI] ORELSE'
- eresolve_tac [transD, mp, allE]));
-
-(*** NOTE! some simplifications need a different finish_tac!! ***)
-fun indhyp_tac hyps =
- resolve_tac (TrueI::refl::hyps) ORELSE'
- (cut_facts_tac hyps THEN'
- DEPTH_SOLVE_1 o (ares_tac [TrueI] ORELSE'
- eresolve_tac [transD, mp, allE]));
-val wf_super_ss = HOL_ss setsolver indhyp_tac;
-
-val prems = goalw WF.thy [is_recfun_def,cut_def]
- "[| wf(r); trans(r); is_recfun(r,a,H,f); is_recfun(r,b,H,g) |] ==> \
- \ <x,a>:r --> <x,b>:r --> f(x)=g(x)";
-by (cut_facts_tac prems 1);
-by (etac wf_induct 1);
-by (REPEAT (rtac impI 1 ORELSE etac ssubst 1));
-by (asm_simp_tac (wf_super_ss addcongs [if_cong]) 1);
-qed "is_recfun_equal_lemma";
-bind_thm ("is_recfun_equal", (is_recfun_equal_lemma RS mp RS mp));
-
-
-val prems as [wfr,transr,recfa,recgb,_] = goalw WF.thy [cut_def]
- "[| wf(r); trans(r); \
-\ is_recfun(r,a,H,f); is_recfun(r,b,H,g); <b,a>:r |] ==> \
-\ cut(f,r,b) = g";
-val gundef = recgb RS is_recfun_undef
-and fisg = recgb RS (recfa RS (transr RS (wfr RS is_recfun_equal)));
-by (cut_facts_tac prems 1);
-by (rtac ext 1);
-by (asm_simp_tac (wf_super_ss addsimps [gundef,fisg]
- setloop (split_tac [expand_if])) 1);
-qed "is_recfun_cut";
-
-(*** Main Existence Lemma -- Basic Properties of the_recfun ***)
-
-val prems = goalw WF.thy [the_recfun_def]
- "is_recfun(r,a,H,f) ==> is_recfun(r, a, H, the_recfun(r,a,H))";
-by (res_inst_tac [("P", "is_recfun(r,a,H)")] selectI 1);
-by (resolve_tac prems 1);
-qed "is_the_recfun";
-
-val prems = goal WF.thy
- "[| wf(r); trans(r) |] ==> is_recfun(r, a, H, the_recfun(r,a,H))";
-by (cut_facts_tac prems 1);
-by (wf_ind_tac "a" prems 1);
-by (res_inst_tac [("f", "cut(%y. wftrec(r,y,H), r, a1)")] is_the_recfun 1);
-by (rewrite_goals_tac [is_recfun_def, wftrec_def]);
-by (rtac (cut_cut_eq RS ssubst) 1);
-(*Applying the substitution: must keep the quantified assumption!!*)
-by (EVERY1 [strip_tac, rtac H_cong1, rtac allE, atac,
- etac (mp RS ssubst), atac]);
-by (fold_tac [is_recfun_def]);
-by (asm_simp_tac (wf_super_ss addsimps[cut_apply,is_recfun_cut,cut_cut_eq]) 1);
-qed "unfold_the_recfun";
-
-
-(*Beware incompleteness of unification!*)
-val prems = goal WF.thy
- "[| wf(r); trans(r); <c,a>:r; <c,b>:r |] \
-\ ==> the_recfun(r,a,H,c) = the_recfun(r,b,H,c)";
-by (DEPTH_SOLVE (ares_tac (prems@[is_recfun_equal,unfold_the_recfun]) 1));
-qed "the_recfun_equal";
-
-val prems = goal WF.thy
- "[| wf(r); trans(r); <b,a>:r |] \
-\ ==> cut(the_recfun(r,a,H),r,b) = the_recfun(r,b,H)";
-by (REPEAT (ares_tac (prems@[is_recfun_cut,unfold_the_recfun]) 1));
-qed "the_recfun_cut";
-
-(*** Unfolding wftrec ***)
-
-goalw WF.thy [wftrec_def]
- "!!r. [| wf(r); trans(r) |] ==> \
-\ wftrec(r,a,H) = H(a, cut(%x.wftrec(r,x,H), r, a))";
-by (EVERY1 [stac (rewrite_rule [is_recfun_def] unfold_the_recfun),
- REPEAT o atac, rtac H_cong1]);
-by (asm_simp_tac (HOL_ss addsimps [cut_cut_eq,the_recfun_cut]) 1);
-qed "wftrec";
-
-(*Unused but perhaps interesting*)
-val prems = goal WF.thy
- "[| wf(r); trans(r); !!f x. H(x, cut(f,r,x)) = H(x,f) |] ==> \
-\ wftrec(r,a,H) = H(a, %x.wftrec(r,x,H))";
-by (rtac (wftrec RS trans) 1);
-by (REPEAT (resolve_tac prems 1));
-qed "wftrec2";
-
-(** Removal of the premise trans(r) **)
-
-goalw WF.thy [wfrec_def]
- "!!r. wf(r) ==> wfrec(r,a,H) = H(a, cut(%x.wfrec(r,x,H), r, a))";
-by (etac (wf_trancl RS wftrec RS ssubst) 1);
-by (rtac trans_trancl 1);
-by (rtac (refl RS H_cong) 1); (*expose the equality of cuts*)
-by (simp_tac (HOL_ss addsimps [cut_cut_eq, cut_apply, r_into_trancl]) 1);
-qed "wfrec";
-
-(*This form avoids giant explosions in proofs. NOTE USE OF == *)
-val rew::prems = goal WF.thy
- "[| !!x. f(x)==wfrec(r,x,H); wf(r) |] ==> f(a) = H(a, cut(%x.f(x),r,a))";
-by (rewtac rew);
-by (REPEAT (resolve_tac (prems@[wfrec]) 1));
-qed "def_wfrec";
--- a/WF.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,30 +0,0 @@
-(* Title: HOL/wf.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1992 University of Cambridge
-
-Well-founded Recursion
-*)
-
-WF = Trancl +
-consts
- wf :: "('a * 'a)set => bool"
- cut :: "['a => 'b, ('a * 'a)set, 'a] => 'a => 'b"
- wftrec,wfrec :: "[('a * 'a)set, 'a, ['a,'a=>'b]=>'b] => 'b"
- is_recfun :: "[('a * 'a)set, 'a, ['a,'a=>'b]=>'b, 'a=>'b] => bool"
- the_recfun :: "[('a * 'a)set, 'a, ['a,'a=>'b]=>'b] => 'a=>'b"
-
-defs
- wf_def "wf(r) == (!P. (!x. (!y. <y,x>:r --> P(y)) --> P(x)) --> (!x.P(x)))"
-
- cut_def "cut(f,r,x) == (%y. if(<y,x>:r, f(y), @z.True))"
-
- is_recfun_def "is_recfun(r,a,H,f) == (f = cut(%x.H(x, cut(f,r,x)), r, a))"
-
- the_recfun_def "the_recfun(r,a,H) == (@f.is_recfun(r,a,H,f))"
-
- wftrec_def "wftrec(r,a,H) == H(a, the_recfun(r,a,H))"
-
- (*version not requiring transitivity*)
- wfrec_def "wfrec(r,a,H) == wftrec(trancl(r), a, %x f. H(x, cut(f,r,x)))"
-end
--- a/add_ind_def.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,244 +0,0 @@
-(* Title: HOL/add_ind_def.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Fixedpoint definition module -- for Inductive/Coinductive Definitions
-
-Features:
-* least or greatest fixedpoints
-* user-specified product and sum constructions
-* mutually recursive definitions
-* definitions involving arbitrary monotone operators
-* automatically proves introduction and elimination rules
-
-The recursive sets must *already* be declared as constants in parent theory!
-
- Introduction rules have the form
- [| ti:M(Sj), ..., P(x), ... |] ==> t: Sk |]
- where M is some monotone operator (usually the identity)
- P(x) is any (non-conjunctive) side condition on the free variables
- ti, t are any terms
- Sj, Sk are two of the sets being defined in mutual recursion
-
-Sums are used only for mutual recursion;
-Products are used only to derive "streamlined" induction rules for relations
-
-Nestings of disjoint sum types:
- (a+(b+c)) for 3, ((a+b)+(c+d)) for 4, ((a+b)+(c+(d+e))) for 5,
- ((a+(b+c))+(d+(e+f))) for 6
-*)
-
-signature FP = (** Description of a fixed point operator **)
- sig
- val oper : string * typ * term -> term (*fixed point operator*)
- val Tarski : thm (*Tarski's fixed point theorem*)
- val induct : thm (*induction/coinduction rule*)
- end;
-
-
-signature ADD_INDUCTIVE_DEF =
- sig
- val add_fp_def_i : term list * term list -> theory -> theory
- end;
-
-
-
-(*Declares functions to add fixedpoint/constructor defs to a theory*)
-functor Add_inductive_def_Fun (Fp: FP) : ADD_INDUCTIVE_DEF =
-struct
-open Logic Ind_Syntax;
-
-(*internal version*)
-fun add_fp_def_i (rec_tms, intr_tms) thy =
- let
- val sign = sign_of thy;
-
- (*recT and rec_params should agree for all mutually recursive components*)
- val rec_hds = map head_of rec_tms;
-
- val _ = assert_all is_Const rec_hds
- (fn t => "Recursive set not previously declared as constant: " ^
- Sign.string_of_term sign t);
-
- (*Now we know they are all Consts, so get their names, type and params*)
- val rec_names = map (#1 o dest_Const) rec_hds
- and (Const(_,recT),rec_params) = strip_comb (hd rec_tms);
-
- val _ = assert_all Syntax.is_identifier rec_names
- (fn a => "Name of recursive set not an identifier: " ^ a);
-
- local (*Checking the introduction rules*)
- val intr_sets = map (#2 o rule_concl_msg sign) intr_tms;
- fun intr_ok set =
- case head_of set of Const(a,_) => a mem rec_names | _ => false;
- in
- val _ = assert_all intr_ok intr_sets
- (fn t => "Conclusion of rule does not name a recursive set: " ^
- Sign.string_of_term sign t);
- end;
-
- val _ = assert_all is_Free rec_params
- (fn t => "Param in recursion term not a free variable: " ^
- Sign.string_of_term sign t);
-
- (*** Construct the lfp definition ***)
- val mk_variant = variant (foldr add_term_names (intr_tms,[]));
-
- val z = mk_variant"z" and X = mk_variant"X" and w = mk_variant"w";
-
- (*Probably INCORRECT for mutual recursion!*)
- val domTs = summands(dest_setT (body_type recT));
- val dom_sumT = fold_bal mk_sum domTs;
- val dom_set = mk_setT dom_sumT;
-
- val freez = Free(z, dom_sumT)
- and freeX = Free(X, dom_set);
- (*type of w may be any of the domTs*)
-
- fun dest_tprop (Const("Trueprop",_) $ P) = P
- | dest_tprop Q = error ("Ill-formed premise of introduction rule: " ^
- Sign.string_of_term sign Q);
-
- (*Makes a disjunct from an introduction rule*)
- fun lfp_part intr = (*quantify over rule's free vars except parameters*)
- let val prems = map dest_tprop (strip_imp_prems intr)
- val _ = seq (fn rec_hd => seq (chk_prem rec_hd) prems) rec_hds
- val exfrees = term_frees intr \\ rec_params
- val zeq = eq_const dom_sumT $ freez $ (#1 (rule_concl intr))
- in foldr mk_exists (exfrees, fold_bal (app conj) (zeq::prems)) end;
-
- (*The Part(A,h) terms -- compose injections to make h*)
- fun mk_Part (Bound 0, _) = freeX (*no mutual rec, no Part needed*)
- | mk_Part (h, domT) =
- let val goodh = mend_sum_types (h, dom_sumT)
- and Part_const =
- Const("Part", [dom_set, domT-->dom_sumT]---> dom_set)
- in Part_const $ freeX $ Abs(w,domT,goodh) end;
-
- (*Access to balanced disjoint sums via injections*)
- val parts = map mk_Part
- (accesses_bal (ap Inl, ap Inr, Bound 0) (length domTs) ~~
- domTs);
-
- (*replace each set by the corresponding Part(A,h)*)
- val part_intrs = map (subst_free (rec_tms ~~ parts) o lfp_part) intr_tms;
-
- val lfp_rhs = Fp.oper(X, dom_sumT,
- mk_Collect(z, dom_sumT,
- fold_bal (app disj) part_intrs))
-
- val _ = seq (fn rec_hd => deny (rec_hd occs lfp_rhs)
- "Illegal occurrence of recursion operator")
- rec_hds;
-
- (*** Make the new theory ***)
-
- (*A key definition:
- If no mutual recursion then it equals the one recursive set.
- If mutual recursion then it differs from all the recursive sets. *)
- val big_rec_name = space_implode "_" rec_names;
-
- (*Big_rec... is the union of the mutually recursive sets*)
- val big_rec_tm = list_comb(Const(big_rec_name,recT), rec_params);
-
- (*The individual sets must already be declared*)
- val axpairs = map mk_defpair
- ((big_rec_tm, lfp_rhs) ::
- (case parts of
- [_] => [] (*no mutual recursion*)
- | _ => rec_tms ~~ (*define the sets as Parts*)
- map (subst_atomic [(freeX, big_rec_tm)]) parts));
-
- val _ = seq (writeln o Sign.string_of_term sign o #2) axpairs
-
- in thy |> add_defs_i axpairs end
-
-
-(****************************************************************OMITTED
-
-(*Expects the recursive sets to have been defined already.
- con_ty_lists specifies the constructors in the form (name,prems,mixfix) *)
-fun add_constructs_def (rec_names, con_ty_lists) thy =
-* let
-* val _ = writeln" Defining the constructor functions...";
-* val case_name = "f"; (*name for case variables*)
-
-* (** Define the constructors **)
-
-* (*The empty tuple is 0*)
-* fun mk_tuple [] = Const("0",iT)
-* | mk_tuple args = foldr1 mk_Pair args;
-
-* fun mk_inject n k u = access_bal(ap Inl, ap Inr, u) n k;
-
-* val npart = length rec_names; (*total # of mutually recursive parts*)
-
-* (*Make constructor definition; kpart is # of this mutually recursive part*)
-* fun mk_con_defs (kpart, con_ty_list) =
-* let val ncon = length con_ty_list (*number of constructors*)
- fun mk_def (((id,T,syn), name, args, prems), kcon) =
- (*kcon is index of constructor*)
- mk_defpair (list_comb (Const(name,T), args),
- mk_inject npart kpart
- (mk_inject ncon kcon (mk_tuple args)))
-* in map mk_def (con_ty_list ~~ (1 upto ncon)) end;
-
-* (** Define the case operator **)
-
-* (*Combine split terms using case; yields the case operator for one part*)
-* fun call_case case_list =
-* let fun call_f (free,args) =
- ap_split T free (map (#2 o dest_Free) args)
-* in fold_bal (app sum_case) (map call_f case_list) end;
-
-* (** Generating function variables for the case definition
- Non-identifiers (e.g. infixes) get a name of the form f_op_nnn. **)
-
-* (*Treatment of a single constructor*)
-* fun add_case (((id,T,syn), name, args, prems), (opno,cases)) =
- if Syntax.is_identifier id
- then (opno,
- (Free(case_name ^ "_" ^ id, T), args) :: cases)
- else (opno+1,
- (Free(case_name ^ "_op_" ^ string_of_int opno, T), args) ::
- cases)
-
-* (*Treatment of a list of constructors, for one part*)
-* fun add_case_list (con_ty_list, (opno,case_lists)) =
- let val (opno',case_list) = foldr add_case (con_ty_list, (opno,[]))
- in (opno', case_list :: case_lists) end;
-
-* (*Treatment of all parts*)
-* val (_, case_lists) = foldr add_case_list (con_ty_lists, (1,[]));
-
-* val big_case_typ = flat (map (map (#2 o #1)) con_ty_lists) ---> (iT-->iT);
-
-* val big_rec_name = space_implode "_" rec_names;
-
-* val big_case_name = big_rec_name ^ "_case";
-
-* (*The list of all the function variables*)
-* val big_case_args = flat (map (map #1) case_lists);
-
-* val big_case_tm =
- list_comb (Const(big_case_name, big_case_typ), big_case_args);
-
-* val big_case_def = mk_defpair
- (big_case_tm, fold_bal (app sum_case) (map call_case case_lists));
-
-* (** Build the new theory **)
-
-* val const_decs =
- (big_case_name, big_case_typ, NoSyn) :: map #1 (flat con_ty_lists);
-
-* val axpairs =
- big_case_def :: flat (map mk_con_defs ((1 upto npart) ~~ con_ty_lists))
-
-* in thy |> add_consts_i const_decs |> add_defs_i axpairs end;
-****************************************************************)
-end;
-
-
-
-
--- a/datatype.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,486 +0,0 @@
-(* Title: HOL/datatype.ML
- ID: $Id$
- Author: Max Breitling, Carsten Clasohm, Tobias Nipkow, Norbert Voelker
- Copyright 1995 TU Muenchen
-*)
-
-
-(*used for constructor parameters*)
-datatype dt_type = dtVar of string |
- dtTyp of dt_type list * string |
- dtRek of dt_type list * string;
-
-structure Datatype =
-struct
-local
-
-val mysort = sort;
-open ThyParse HOLogic;
-exception Impossible;
-exception RecError of string;
-
-val is_dtRek = (fn dtRek _ => true | _ => false);
-fun opt_parens s = if s = "" then "" else enclose "(" ")" s;
-
-(* ----------------------------------------------------------------------- *)
-(* Derivation of the primrec combinator application from the equations *)
-
-(* substitute fname(ls,xk,rs) by yk(ls,rs) in t for (xk,yk) in pairs *)
-
-fun subst_apps (_,_) [] t = t
- | subst_apps (fname,rpos) pairs t =
- let
- fun subst (Abs(a,T,t)) = Abs(a,T,subst t)
- | subst (funct $ body) =
- let val (f,b) = strip_comb (funct$body)
- in
- if is_Const f andalso fst(dest_Const f) = fname
- then
- let val (ls,rest) = (take(rpos,b), drop(rpos,b));
- val (xk,rs) = (hd rest,tl rest)
- handle LIST _ => raise RecError "not enough arguments \
- \ in recursive application on rhs"
- in
- (case assoc (pairs,xk) of
- None => raise RecError
- ("illegal occurence of " ^ fname ^ " on rhs")
- | Some(U) => list_comb(U,map subst (ls @ rs)))
- end
- else list_comb(f, map subst b)
- end
- | subst(t) = t
- in subst t end;
-
-(* abstract rhs *)
-
-fun abst_rec (fname,rpos,tc,ls,cargs,rs,rhs) =
- let val rargs = (map fst o
- (filter (fn (a,T) => is_dtRek T))) (cargs ~~ tc);
- val subs = map (fn (s,T) => (s,dummyT))
- (rev(rename_wrt_term rhs rargs));
- val subst_rhs = subst_apps (fname,rpos)
- (map Free rargs ~~ map Free subs) rhs;
- in
- list_abs_free (cargs @ subs @ ls @ rs, subst_rhs)
- end;
-
-(* parsing the prim rec equations *)
-
-fun dest_eq ( Const("Trueprop",_) $ (Const ("op =",_) $ lhs $ rhs))
- = (lhs, rhs)
- | dest_eq _ = raise RecError "not a proper equation";
-
-fun dest_rec eq =
- let val (lhs,rhs) = dest_eq eq;
- val (name,args) = strip_comb lhs;
- val (ls',rest) = take_prefix is_Free args;
- val (middle,rs') = take_suffix is_Free rest;
- val rpos = length ls';
- val (c,cargs') = strip_comb (hd middle)
- handle LIST "hd" => raise RecError "constructor missing";
- val (ls,cargs,rs) = (map dest_Free ls', map dest_Free cargs'
- , map dest_Free rs')
- handle TERM ("dest_Free",_) =>
- raise RecError "constructor has illegal argument in pattern";
- in
- if length middle > 1 then
- raise RecError "more than one non-variable in pattern"
- else if not(null(findrep (map fst (ls @ rs @ cargs)))) then
- raise RecError "repeated variable name in pattern"
- else (fst(dest_Const name) handle TERM _ =>
- raise RecError "function is not declared as constant in theory"
- ,rpos,ls,fst( dest_Const c),cargs,rs,rhs)
- end;
-
-(* check function specified for all constructors and sort function terms *)
-
-fun check_and_sort (n,its) =
- if length its = n
- then map snd (mysort (fn ((i : int,_),(j,_)) => i<j) its)
- else raise error "Primrec definition error:\n\
- \Please give an equation for every constructor";
-
-(* translate rec equations into function arguments suitable for rec comb *)
-(* theory parameter needed for printing error messages *)
-
-fun trans_recs _ _ [] = error("No primrec equations.")
- | trans_recs thy cs' (eq1::eqs) =
- let val (name1,rpos1,ls1,_,_,_,_) = dest_rec eq1
- handle RecError s =>
- error("Primrec definition error: " ^ s ^ ":\n"
- ^ " " ^ Sign.string_of_term (sign_of thy) eq1);
- val tcs = map (fn (_,c,T,_,_) => (c,T)) cs';
- val cs = map fst tcs;
- fun trans_recs' _ [] = []
- | trans_recs' cis (eq::eqs) =
- let val (name,rpos,ls,c,cargs,rs,rhs) = dest_rec eq;
- val tc = assoc(tcs,c);
- val i = (1 + find (c,cs)) handle LIST "find" => 0;
- in
- if name <> name1 then
- raise RecError "function names inconsistent"
- else if rpos <> rpos1 then
- raise RecError "position of rec. argument inconsistent"
- else if i = 0 then
- raise RecError "illegal argument in pattern"
- else if i mem cis then
- raise RecError "constructor already occured as pattern "
- else (i,abst_rec (name,rpos,the tc,ls,cargs,rs,rhs))
- :: trans_recs' (i::cis) eqs
- end
- handle RecError s =>
- error("Primrec definition error\n" ^ s ^ "\n"
- ^ " " ^ Sign.string_of_term (sign_of thy) eq);
- in ( name1, ls1
- , check_and_sort (length cs, trans_recs' [] (eq1::eqs)))
- end ;
-
-in
- fun add_datatype (typevars, tname, cons_list') thy =
- let
- fun typid(dtRek(_,id)) = id
- | typid(dtVar s) = implode (tl (explode s))
- | typid(dtTyp(_,id)) = id;
-
- fun index_vnames(vn::vns,tab) =
- (case assoc(tab,vn) of
- None => if vn mem vns
- then (vn^"1") :: index_vnames(vns,(vn,2)::tab)
- else vn :: index_vnames(vns,tab)
- | Some(i) => (vn^(string_of_int i)) ::
- index_vnames(vns,(vn,i+1)::tab))
- | index_vnames([],tab) = [];
-
- fun mk_var_names types = index_vnames(map typid types,[]);
-
- (*search for free type variables and convert recursive *)
- fun analyse_types (cons, types, syn) =
- let fun analyse(t as dtVar v) =
- if t mem typevars then t
- else error ("Free type variable " ^ v ^ " on rhs.")
- | analyse(dtTyp(typl,s)) =
- if tname <> s then dtTyp(analyses typl, s)
- else if typevars = typl then dtRek(typl, s)
- else error (s ^ " used in different ways")
- | analyse(dtRek _) = raise Impossible
- and analyses ts = map analyse ts;
- in (cons, Syntax.const_name cons syn, analyses types,
- mk_var_names types, syn)
- end;
-
- (*test if all elements are recursive, i.e. if the type is empty*)
-
- fun non_empty (cs : ('a * 'b * dt_type list * 'c *'d) list) =
- not(forall (exists is_dtRek o #3) cs) orelse
- error("Empty datatype not allowed!");
-
- val cons_list = map analyse_types cons_list';
- val dummy = non_empty cons_list;
- val num_of_cons = length cons_list;
-
- (* Auxiliary functions to construct argument and equation lists *)
-
- (*generate 'var_n, ..., var_m'*)
- fun Args(var, delim, n, m) =
- space_implode delim (map (fn n => var^string_of_int(n)) (n upto m));
-
- fun C_exp name vns = name ^ opt_parens(commas vns);
-
- (*Arg_eqs([x1,...,xn],[y1,...,yn]) = "x1 = y1 & ... & xn = yn" *)
- fun arg_eqs vns vns' =
- let fun mkeq(x,x') = x ^ "=" ^ x'
- in space_implode " & " (map mkeq (vns~~vns')) end
-
- (*Pretty printers for type lists;
- pp_typlist1: parentheses, pp_typlist2: brackets*)
- fun pp_typ (dtVar s) = s
- | pp_typ (dtTyp (typvars, id)) =
- if null typvars then id else (pp_typlist1 typvars) ^ id
- | pp_typ (dtRek (typvars, id)) = (pp_typlist1 typvars) ^ id
- and
- pp_typlist' ts = commas (map pp_typ ts)
- and
- pp_typlist1 ts = if null ts then "" else parens (pp_typlist' ts);
-
- fun pp_typlist2 ts = if null ts then "" else brackets (pp_typlist' ts);
-
- (* Generate syntax translation for case rules *)
- fun calc_xrules c_nr y_nr ((_, name, _, vns, _) :: cs) =
- let val arity = length vns;
- val body = "z" ^ string_of_int(c_nr);
- val args1 = if arity=0 then ""
- else parens (Args ("y", ",", y_nr, y_nr+arity-1));
- val args2 = if arity=0 then ""
- else "% " ^ Args ("y", " ", y_nr, y_nr+arity-1)
- ^ ". ";
- val (rest1,rest2) =
- if null cs then ("","")
- else let val (h1, h2) = calc_xrules (c_nr+1) (y_nr+arity) cs
- in (" | " ^ h1, ", " ^ h2) end;
- in (name ^ args1 ^ " => " ^ body ^ rest1, args2 ^ body ^ rest2) end
- | calc_xrules _ _ [] = raise Impossible;
-
- val xrules =
- let val (first_part, scnd_part) = calc_xrules 1 1 cons_list
- in [("logic", "case x of " ^ first_part) <->
- ("logic", tname ^ "_case(" ^ scnd_part ^ ", x)" )]
- end;
-
- (*type declarations for constructors*)
- fun const_type (id, _, typlist, _, syn) =
- (id,
- (if null typlist then "" else pp_typlist2 typlist ^ " => ") ^
- pp_typlist1 typevars ^ tname, syn);
-
-
- fun assumpt (dtRek _ :: ts, v :: vs ,found) =
- let val h = if found then ";P(" ^ v ^ ")" else "[| P(" ^ v ^ ")"
- in h ^ (assumpt (ts, vs, true)) end
- | assumpt (t :: ts, v :: vs, found) = assumpt (ts, vs, found)
- | assumpt ([], [], found) = if found then "|] ==>" else ""
- | assumpt _ = raise Impossible;
-
- fun t_inducting ((_, name, types, vns, _) :: cs) =
- let
- val h = if null types then " P(" ^ name ^ ")"
- else " !!" ^ (space_implode " " vns) ^ "." ^
- (assumpt (types, vns, false)) ^
- "P(" ^ C_exp name vns ^ ")";
- val rest = t_inducting cs;
- in if rest = "" then h else h ^ "; " ^ rest end
- | t_inducting [] = "";
-
- fun t_induct cl typ_name =
- "[|" ^ t_inducting cl ^ "|] ==> P(" ^ typ_name ^ ")";
-
- fun gen_typlist typevar f ((_, _, ts, _, _) :: cs) =
- let val h = if (length ts) > 0
- then pp_typlist2(f ts) ^ "=>"
- else ""
- in h ^ typevar ^ "," ^ (gen_typlist typevar f cs) end
- | gen_typlist _ _ [] = "";
-
-
-(* -------------------------------------------------------------------- *)
-(* The case constant and rules *)
-
- val t_case = tname ^ "_case";
-
- fun case_rule n (id, name, _, vns, _) =
- let val args = opt_parens(commas vns)
- in (t_case ^ "_" ^ id,
- t_case ^ "(" ^ Args("f", ",", 1, num_of_cons)
- ^ "," ^ name ^ args ^ ") = f"^string_of_int(n) ^ args)
- end
-
- fun case_rules n (c :: cs) = case_rule n c :: case_rules(n+1) cs
- | case_rules _ [] = [];
-
- val datatype_arity = length typevars;
-
- val types = [(tname, datatype_arity, NoSyn)];
-
- val arities =
- let val term_list = replicate datatype_arity termS;
- in [(tname, term_list, termS)]
- end;
-
- val datatype_name = pp_typlist1 typevars ^ tname;
-
- val new_tvar_name = variant (map (fn dtVar s => s) typevars) "'z";
-
- val case_const =
- (t_case,
- "[" ^ gen_typlist new_tvar_name I cons_list
- ^ pp_typlist1 typevars ^ tname ^ "] =>" ^ new_tvar_name,
- NoSyn);
-
- val rules_case = case_rules 1 cons_list;
-
-(* -------------------------------------------------------------------- *)
-(* The prim-rec combinator *)
-
- val t_rec = tname ^ "_rec"
-
-(* adding type variables for dtRek types to end of list of dt_types *)
-
- fun add_reks ts =
- ts @ map (fn _ => dtVar new_tvar_name) (filter is_dtRek ts);
-
-(* positions of the dtRek types in a list of dt_types, starting from 1 *)
- fun rek_vars ts vns = map snd (filter (is_dtRek o fst) (ts ~~ vns))
-
- fun rec_rule n (id,name,ts,vns,_) =
- let val args = commas vns
- val fargs = Args("f",",",1,num_of_cons)
- fun rarg vn = "," ^ t_rec ^ parens(fargs ^ "," ^ vn)
- val rargs = implode (map rarg (rek_vars ts vns))
- in
- ( t_rec ^ "_" ^ id
- , t_rec ^ parens(fargs ^ "," ^ name ^ (opt_parens args)) ^ " = f"
- ^ string_of_int(n) ^ opt_parens (args ^ rargs))
- end
-
- fun rec_rules n (c::cs) = rec_rule n c :: rec_rules (n+1) cs
- | rec_rules _ [] = [];
-
- val rec_const =
- (t_rec,
- "[" ^ (gen_typlist new_tvar_name add_reks cons_list)
- ^ (pp_typlist1 typevars) ^ tname ^ "] =>" ^ new_tvar_name,
- NoSyn);
-
- val rules_rec = rec_rules 1 cons_list
-
-(* -------------------------------------------------------------------- *)
- val consts =
- map const_type cons_list
- @ (if num_of_cons < dtK then []
- else [(tname ^ "_ord", datatype_name ^ "=>nat", NoSyn)])
- @ [case_const,rec_const];
-
-
- fun Ci_ing ((id, name, _, vns, _) :: cs) =
- if null vns then Ci_ing cs
- else let val vns' = variantlist(vns,vns)
- in ("inject_" ^ id,
- "(" ^ (C_exp name vns) ^ "=" ^ (C_exp name vns')
- ^ ") = (" ^ (arg_eqs vns vns') ^ ")") :: (Ci_ing cs)
- end
- | Ci_ing [] = [];
-
- fun Ci_negOne (id1,name1,_,vns1,_) (id2,name2,_,vns2,_) =
- let val vns2' = variantlist(vns2,vns1)
- val ax = C_exp name1 vns1 ^ "~=" ^ C_exp name2 vns2'
- in (id1 ^ "_not_" ^ id2, ax) end;
-
- fun Ci_neg1 [] = []
- | Ci_neg1 (c1::cs) = (map (Ci_negOne c1) cs) @ Ci_neg1 cs;
-
- fun suc_expr n =
- if n=0 then "0" else "Suc(" ^ suc_expr(n-1) ^ ")";
-
- fun Ci_neg2() =
- let val ord_t = tname ^ "_ord";
- val cis = cons_list ~~ (0 upto (num_of_cons - 1))
- fun Ci_neg2equals ((id, name, _, vns, _), n) =
- let val ax = ord_t ^ "(" ^ (C_exp name vns) ^ ") = " ^ (suc_expr n)
- in (ord_t ^ "_" ^ id, ax) end
- in (ord_t ^ "_distinct", ord_t^"(x) ~= "^ord_t^"(y) ==> x ~= y") ::
- (map Ci_neg2equals cis)
- end;
-
- val rules_distinct = if num_of_cons < dtK then Ci_neg1 cons_list
- else Ci_neg2();
-
- val rules_inject = Ci_ing cons_list;
-
- val rule_induct = (tname ^ "_induct", t_induct cons_list tname);
-
- val rules = rule_induct ::
- (rules_inject @ rules_distinct @ rules_case @ rules_rec);
-
- fun add_primrec eqns thy =
- let val rec_comb = Const(t_rec,dummyT)
- val teqns = map (fn neq => snd(read_axm (sign_of thy) neq)) eqns
- val (fname,ls,fns) = trans_recs thy cons_list teqns
- val rhs =
- list_abs_free
- (ls @ [(tname,dummyT)]
- ,list_comb(rec_comb
- , fns @ map Bound (0 ::(length ls downto 1))));
- val sg = sign_of thy;
- val defpair = mk_defpair (Const(fname,dummyT),rhs)
- val defpairT as (_, _ $ Const(_,T) $ _ ) = inferT_axm sg defpair;
- val varT = Type.varifyT T;
- val ftyp = the (Sign.const_type sg fname);
- in
- if Type.typ_instance (#tsig(Sign.rep_sg sg), ftyp, varT)
- then add_defs_i [defpairT] thy
- else error("Primrec definition error: \ntype of " ^ fname
- ^ " is not instance of type deduced from equations")
- end;
-
- in
- (thy
- |> add_types types
- |> add_arities arities
- |> add_consts consts
- |> add_trrules xrules
- |> add_axioms rules,add_primrec)
- end
-end
-end
-
-(*
-Informal description of functions used in datatype.ML for the Isabelle/HOL
-implementation of prim. rec. function definitions. (N. Voelker, Feb. 1995)
-
-* subst_apps (fname,rpos) pairs t:
- substitute the term
- fname(ls,xk,rs)
- by
- yk(ls,rs)
- in t for (xk,yk) in pairs, where rpos = length ls.
- Applied with :
- fname = function name
- rpos = position of recursive argument
- pairs = list of pairs (xk,yk), where
- xk are the rec. arguments of the constructor in the pattern,
- yk is a variable with name derived from xk
- t = rhs of equation
-
-* abst_rec (fname,rpos,tc,ls,cargs,rs,rhs)
- - filter recursive arguments from constructor arguments cargs,
- - perform substitutions on rhs,
- - derive list subs of new variable names yk for use in subst_apps,
- - abstract rhs with respect to cargs, subs, ls and rs.
-
-* dest_eq t
- destruct a term denoting an equation into lhs and rhs.
-
-* dest_req eq
- destruct an equation of the form
- name (vl1..vlrpos, Ci(vi1..vin), vr1..vrn) = rhs
- into
- - function name (name)
- - position of the first non-variable parameter (rpos)
- - the list of first rpos parameters (ls = [vl1..vlrpos])
- - the constructor (fst( dest_Const c) = Ci)
- - the arguments of the constructor (cargs = [vi1..vin])
- - the rest of the variables in the pattern (rs = [vr1..vrn])
- - the right hand side of the equation (rhs).
-
-* check_and_sort (n,its)
- check that n = length its holds, and sort elements of its by
- first component.
-
-* trans_recs thy cs' (eq1::eqs)
- destruct eq1 into name1, rpos1, ls1, etc..
- get constructor list with and without type (tcs resp. cs) from cs',
- for every equation:
- destruct it into (name,rpos,ls,c,cargs,rs,rhs)
- get typed constructor tc from c and tcs
- determine the index i of the constructor
- check function name and position of rec. argument by comparison
- with first equation
- check for repeated variable names in pattern
- derive function term f_i which is used as argument of the rec. combinator
- sort the terms f_i according to i and return them together
- with the function name and the parameter of the definition (ls).
-
-* Application:
-
- The rec. combinator is applied to the function terms resulting from
- trans_rec. This results in a function which takes the recursive arg.
- as first parameter and then the arguments corresponding to ls. The
- order of parameters is corrected by setting the rhs equal to
-
- list_abs_free
- (ls @ [(tname,dummyT)]
- ,list_comb(rec_comb
- , fns @ map Bound (0 ::(length ls downto 1))));
-
- Note the de-Bruijn indices counting the number of lambdas between the
- variable and its binding.
-*)
--- a/equalities.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,333 +0,0 @@
-(* Title: HOL/equalities
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Equalities involving union, intersection, inclusion, etc.
-*)
-
-writeln"File HOL/equalities";
-
-val eq_cs = set_cs addSIs [equalityI];
-
-(** The membership relation, : **)
-
-goal Set.thy "x ~: {}";
-by(fast_tac set_cs 1);
-qed "in_empty";
-
-goal Set.thy "x : insert(y,A) = (x=y | x:A)";
-by(fast_tac set_cs 1);
-qed "in_insert";
-
-(** insert **)
-
-goal Set.thy "!!a. a:A ==> insert(a,A) = A";
-by (fast_tac eq_cs 1);
-qed "insert_absorb";
-
-goal Set.thy "(insert(x,A) <= B) = (x:B & A <= B)";
-by (fast_tac set_cs 1);
-qed "insert_subset";
-
-(** Image **)
-
-goal Set.thy "f``{} = {}";
-by (fast_tac eq_cs 1);
-qed "image_empty";
-
-goal Set.thy "f``insert(a,B) = insert(f(a), f``B)";
-by (fast_tac eq_cs 1);
-qed "image_insert";
-
-(** Binary Intersection **)
-
-goal Set.thy "A Int A = A";
-by (fast_tac eq_cs 1);
-qed "Int_absorb";
-
-goal Set.thy "A Int B = B Int A";
-by (fast_tac eq_cs 1);
-qed "Int_commute";
-
-goal Set.thy "(A Int B) Int C = A Int (B Int C)";
-by (fast_tac eq_cs 1);
-qed "Int_assoc";
-
-goal Set.thy "{} Int B = {}";
-by (fast_tac eq_cs 1);
-qed "Int_empty_left";
-
-goal Set.thy "A Int {} = {}";
-by (fast_tac eq_cs 1);
-qed "Int_empty_right";
-
-goal Set.thy "A Int (B Un C) = (A Int B) Un (A Int C)";
-by (fast_tac eq_cs 1);
-qed "Int_Un_distrib";
-
-goal Set.thy "(A<=B) = (A Int B = A)";
-by (fast_tac (eq_cs addSEs [equalityE]) 1);
-qed "subset_Int_eq";
-
-(** Binary Union **)
-
-goal Set.thy "A Un A = A";
-by (fast_tac eq_cs 1);
-qed "Un_absorb";
-
-goal Set.thy "A Un B = B Un A";
-by (fast_tac eq_cs 1);
-qed "Un_commute";
-
-goal Set.thy "(A Un B) Un C = A Un (B Un C)";
-by (fast_tac eq_cs 1);
-qed "Un_assoc";
-
-goal Set.thy "{} Un B = B";
-by(fast_tac eq_cs 1);
-qed "Un_empty_left";
-
-goal Set.thy "A Un {} = A";
-by(fast_tac eq_cs 1);
-qed "Un_empty_right";
-
-goal Set.thy "insert(a,B) Un C = insert(a,B Un C)";
-by(fast_tac eq_cs 1);
-qed "Un_insert_left";
-
-goal Set.thy "(A Int B) Un C = (A Un C) Int (B Un C)";
-by (fast_tac eq_cs 1);
-qed "Un_Int_distrib";
-
-goal Set.thy
- "(A Int B) Un (B Int C) Un (C Int A) = (A Un B) Int (B Un C) Int (C Un A)";
-by (fast_tac eq_cs 1);
-qed "Un_Int_crazy";
-
-goal Set.thy "(A<=B) = (A Un B = B)";
-by (fast_tac (eq_cs addSEs [equalityE]) 1);
-qed "subset_Un_eq";
-
-goal Set.thy "(A <= insert(b,C)) = (A <= C | b:A & A-{b} <= C)";
-by (fast_tac eq_cs 1);
-qed "subset_insert_iff";
-
-goal Set.thy "(A Un B = {}) = (A = {} & B = {})";
-by (fast_tac (eq_cs addEs [equalityCE]) 1);
-qed "Un_empty";
-
-(** Simple properties of Compl -- complement of a set **)
-
-goal Set.thy "A Int Compl(A) = {}";
-by (fast_tac eq_cs 1);
-qed "Compl_disjoint";
-
-goal Set.thy "A Un Compl(A) = {x.True}";
-by (fast_tac eq_cs 1);
-qed "Compl_partition";
-
-goal Set.thy "Compl(Compl(A)) = A";
-by (fast_tac eq_cs 1);
-qed "double_complement";
-
-goal Set.thy "Compl(A Un B) = Compl(A) Int Compl(B)";
-by (fast_tac eq_cs 1);
-qed "Compl_Un";
-
-goal Set.thy "Compl(A Int B) = Compl(A) Un Compl(B)";
-by (fast_tac eq_cs 1);
-qed "Compl_Int";
-
-goal Set.thy "Compl(UN x:A. B(x)) = (INT x:A. Compl(B(x)))";
-by (fast_tac eq_cs 1);
-qed "Compl_UN";
-
-goal Set.thy "Compl(INT x:A. B(x)) = (UN x:A. Compl(B(x)))";
-by (fast_tac eq_cs 1);
-qed "Compl_INT";
-
-(*Halmos, Naive Set Theory, page 16.*)
-
-goal Set.thy "((A Int B) Un C = A Int (B Un C)) = (C<=A)";
-by (fast_tac (eq_cs addSEs [equalityE]) 1);
-qed "Un_Int_assoc_eq";
-
-
-(** Big Union and Intersection **)
-
-goal Set.thy "Union({}) = {}";
-by (fast_tac eq_cs 1);
-qed "Union_empty";
-
-goal Set.thy "Union(insert(a,B)) = a Un Union(B)";
-by (fast_tac eq_cs 1);
-qed "Union_insert";
-
-goal Set.thy "Union(A Un B) = Union(A) Un Union(B)";
-by (fast_tac eq_cs 1);
-qed "Union_Un_distrib";
-
-goal Set.thy "Union(A Int B) <= Union(A) Int Union(B)";
-by (fast_tac set_cs 1);
-qed "Union_Int_subset";
-
-val prems = goal Set.thy
- "(Union(C) Int A = {}) = (! B:C. B Int A = {})";
-by (fast_tac (eq_cs addSEs [equalityE]) 1);
-qed "Union_disjoint";
-
-goal Set.thy "Inter(A Un B) = Inter(A) Int Inter(B)";
-by (best_tac eq_cs 1);
-qed "Inter_Un_distrib";
-
-(** Unions and Intersections of Families **)
-
-(*Basic identities*)
-
-goal Set.thy "Union(range(f)) = (UN x.f(x))";
-by (fast_tac eq_cs 1);
-qed "Union_range_eq";
-
-goal Set.thy "Inter(range(f)) = (INT x.f(x))";
-by (fast_tac eq_cs 1);
-qed "Inter_range_eq";
-
-goal Set.thy "Union(B``A) = (UN x:A. B(x))";
-by (fast_tac eq_cs 1);
-qed "Union_image_eq";
-
-goal Set.thy "Inter(B``A) = (INT x:A. B(x))";
-by (fast_tac eq_cs 1);
-qed "Inter_image_eq";
-
-goal Set.thy "!!A. a: A ==> (UN y:A. c) = c";
-by (fast_tac eq_cs 1);
-qed "UN_constant";
-
-goal Set.thy "!!A. a: A ==> (INT y:A. c) = c";
-by (fast_tac eq_cs 1);
-qed "INT_constant";
-
-goal Set.thy "(UN x.B) = B";
-by (fast_tac eq_cs 1);
-qed "UN1_constant";
-
-goal Set.thy "(INT x.B) = B";
-by (fast_tac eq_cs 1);
-qed "INT1_constant";
-
-goal Set.thy "(UN x:A. B(x)) = Union({Y. ? x:A. Y=B(x)})";
-by (fast_tac eq_cs 1);
-qed "UN_eq";
-
-(*Look: it has an EXISTENTIAL quantifier*)
-goal Set.thy "(INT x:A. B(x)) = Inter({Y. ? x:A. Y=B(x)})";
-by (fast_tac eq_cs 1);
-qed "INT_eq";
-
-(*Distributive laws...*)
-
-goal Set.thy "A Int Union(B) = (UN C:B. A Int C)";
-by (fast_tac eq_cs 1);
-qed "Int_Union";
-
-(* Devlin, Fundamentals of Contemporary Set Theory, page 12, exercise 5:
- Union of a family of unions **)
-goal Set.thy "(UN x:C. A(x) Un B(x)) = Union(A``C) Un Union(B``C)";
-by (fast_tac eq_cs 1);
-qed "Un_Union_image";
-
-(*Equivalent version*)
-goal Set.thy "(UN i:I. A(i) Un B(i)) = (UN i:I. A(i)) Un (UN i:I. B(i))";
-by (fast_tac eq_cs 1);
-qed "UN_Un_distrib";
-
-goal Set.thy "A Un Inter(B) = (INT C:B. A Un C)";
-by (fast_tac eq_cs 1);
-qed "Un_Inter";
-
-goal Set.thy "(INT x:C. A(x) Int B(x)) = Inter(A``C) Int Inter(B``C)";
-by (best_tac eq_cs 1);
-qed "Int_Inter_image";
-
-(*Equivalent version*)
-goal Set.thy "(INT i:I. A(i) Int B(i)) = (INT i:I. A(i)) Int (INT i:I. B(i))";
-by (fast_tac eq_cs 1);
-qed "INT_Int_distrib";
-
-(*Halmos, Naive Set Theory, page 35.*)
-goal Set.thy "B Int (UN i:I. A(i)) = (UN i:I. B Int A(i))";
-by (fast_tac eq_cs 1);
-qed "Int_UN_distrib";
-
-goal Set.thy "B Un (INT i:I. A(i)) = (INT i:I. B Un A(i))";
-by (fast_tac eq_cs 1);
-qed "Un_INT_distrib";
-
-goal Set.thy
- "(UN i:I. A(i)) Int (UN j:J. B(j)) = (UN i:I. UN j:J. A(i) Int B(j))";
-by (fast_tac eq_cs 1);
-qed "Int_UN_distrib2";
-
-goal Set.thy
- "(INT i:I. A(i)) Un (INT j:J. B(j)) = (INT i:I. INT j:J. A(i) Un B(j))";
-by (fast_tac eq_cs 1);
-qed "Un_INT_distrib2";
-
-(** Simple properties of Diff -- set difference **)
-
-goal Set.thy "A-A = {}";
-by (fast_tac eq_cs 1);
-qed "Diff_cancel";
-
-goal Set.thy "{}-A = {}";
-by (fast_tac eq_cs 1);
-qed "empty_Diff";
-
-goal Set.thy "A-{} = A";
-by (fast_tac eq_cs 1);
-qed "Diff_empty";
-
-(*NOT SUITABLE FOR REWRITING since {a} == insert(a,0)*)
-goal Set.thy "A - insert(a,B) = A - B - {a}";
-by (fast_tac eq_cs 1);
-qed "Diff_insert";
-
-(*NOT SUITABLE FOR REWRITING since {a} == insert(a,0)*)
-goal Set.thy "A - insert(a,B) = A - {a} - B";
-by (fast_tac eq_cs 1);
-qed "Diff_insert2";
-
-val prems = goal Set.thy "a:A ==> insert(a,A-{a}) = A";
-by (fast_tac (eq_cs addSIs prems) 1);
-qed "insert_Diff";
-
-goal Set.thy "A Int (B-A) = {}";
-by (fast_tac eq_cs 1);
-qed "Diff_disjoint";
-
-goal Set.thy "!!A. A<=B ==> A Un (B-A) = B";
-by (fast_tac eq_cs 1);
-qed "Diff_partition";
-
-goal Set.thy "!!A. [| A<=B; B<= C |] ==> (B - (C - A)) = (A :: 'a set)";
-by (fast_tac eq_cs 1);
-qed "double_diff";
-
-goal Set.thy "A - (B Un C) = (A-B) Int (A-C)";
-by (fast_tac eq_cs 1);
-qed "Diff_Un";
-
-goal Set.thy "A - (B Int C) = (A-B) Un (A-C)";
-by (fast_tac eq_cs 1);
-qed "Diff_Int";
-
-val set_ss = set_ss addsimps
- [in_empty,in_insert,insert_subset,
- Int_absorb,Int_empty_left,Int_empty_right,
- Un_absorb,Un_empty_left,Un_empty_right,Un_empty,
- UN1_constant,image_empty,
- Compl_disjoint,double_complement,
- Union_empty,Union_insert,empty_subsetI,subset_refl,
- Diff_cancel,empty_Diff,Diff_empty,Diff_disjoint];
--- a/equalities.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-(* Title: HOL/equalities
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Equalities involving union, intersection, inclusion, etc.
-*)
-
-equalities = subset
--- a/ex/Acc.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,63 +0,0 @@
-(* Title: HOL/ex/Acc
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Inductive definition of acc(r)
-
-See Ch. Paulin-Mohring, Inductive Definitions in the System Coq.
-Research Report 92-49, LIP, ENS Lyon. Dec 1992.
-*)
-
-open Acc;
-
-(*The intended introduction rule*)
-val prems = goal Acc.thy
- "[| !!b. <b,a>:r ==> b: acc(r) |] ==> a: acc(r)";
-by (fast_tac (set_cs addIs (prems @
- map (rewrite_rule [pred_def]) acc.intrs)) 1);
-qed "accI";
-
-goal Acc.thy "!!a b r. [| b: acc(r); <a,b>: r |] ==> a: acc(r)";
-by (etac acc.elim 1);
-by (rewtac pred_def);
-by (fast_tac set_cs 1);
-qed "acc_downward";
-
-val [major,indhyp] = goal Acc.thy
- "[| a : acc(r); \
-\ !!x. [| x: acc(r); ALL y. <y,x>:r --> P(y) |] ==> P(x) \
-\ |] ==> P(a)";
-by (rtac (major RS acc.induct) 1);
-by (rtac indhyp 1);
-by (resolve_tac acc.intrs 1);
-by (rewtac pred_def);
-by (fast_tac set_cs 2);
-by (etac (Int_lower1 RS Pow_mono RS subsetD) 1);
-qed "acc_induct";
-
-
-val [major] = goal Acc.thy "r <= Sigma(acc(r), %u. acc(r)) ==> wf(r)";
-by (rtac (major RS wfI) 1);
-by (etac acc.induct 1);
-by (rewtac pred_def);
-by (fast_tac set_cs 1);
-qed "acc_wfI";
-
-val [major] = goal Acc.thy "wf(r) ==> ALL x. <x,y>: r | <y,x>:r --> y: acc(r)";
-by (rtac (major RS wf_induct) 1);
-by (rtac (impI RS allI) 1);
-by (rtac accI 1);
-by (fast_tac set_cs 1);
-qed "acc_wfD_lemma";
-
-val [major] = goal Acc.thy "wf(r) ==> r <= Sigma(acc(r), %u. acc(r))";
-by (rtac subsetI 1);
-by (res_inst_tac [("p", "x")] PairE 1);
-by (fast_tac (set_cs addSIs [SigmaI,
- major RS acc_wfD_lemma RS spec RS mp]) 1);
-qed "acc_wfD";
-
-goal Acc.thy "wf(r) = (r <= Sigma(acc(r), %u. acc(r)))";
-by (EVERY1 [rtac iffI, etac acc_wfD, etac acc_wfI]);
-qed "wf_acc_iff";
--- a/ex/Acc.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,26 +0,0 @@
-(* Title: HOL/ex/Acc.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Inductive definition of acc(r)
-
-See Ch. Paulin-Mohring, Inductive Definitions in the System Coq.
-Research Report 92-49, LIP, ENS Lyon. Dec 1992.
-*)
-
-Acc = WF +
-
-consts
- pred :: "['b, ('a * 'b)set] => 'a set" (*Set of predecessors*)
- acc :: "('a * 'a)set => 'a set" (*Accessible part*)
-
-defs
- pred_def "pred(x,r) == {y. <y,x>:r}"
-
-inductive "acc(r)"
- intrs
- pred "pred(a,r): Pow(acc(r)) ==> a: acc(r)"
- monos "[Pow_mono]"
-
-end
--- a/ex/InSort.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,46 +0,0 @@
-(* Title: HOL/ex/insort.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Correctness proof of insertion sort.
-*)
-
-val insort_ss = sorting_ss addsimps
- [InSort.ins_Nil,InSort.ins_Cons,InSort.insort_Nil,InSort.insort_Cons];
-
-goalw InSort.thy [Sorting.total_def]
- "!!f. [| total(f); ~f(x,y) |] ==> f(y,x)";
-by(fast_tac HOL_cs 1);
-qed "totalD";
-
-goalw InSort.thy [Sorting.transf_def]
- "!!f. [| transf(f); f(b,a) |] ==> !x. f(a,x) --> f(b,x)";
-by(fast_tac HOL_cs 1);
-qed "transfD";
-
-goal InSort.thy "list_all(p,ins(f,x,xs)) = (list_all(p,xs) & p(x))";
-by(list.induct_tac "xs" 1);
-by(asm_simp_tac insort_ss 1);
-by(asm_simp_tac (insort_ss setloop (split_tac [expand_if])) 1);
-by(fast_tac HOL_cs 1);
-val insort_ss = insort_ss addsimps [result()];
-
-goal InSort.thy "(!x. p(x) --> q(x)) --> list_all(p,xs) --> list_all(q,xs)";
-by(list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (insort_ss setloop (split_tac [expand_if]))));
-qed "list_all_imp";
-
-val prems = goal InSort.thy
- "[| total(f); transf(f) |] ==> sorted(f,ins(f,x,xs)) = sorted(f,xs)";
-by(list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (insort_ss setloop (split_tac [expand_if]))));
-by(cut_facts_tac prems 1);
-by(cut_inst_tac [("p","f(a)"),("q","f(x)")] list_all_imp 1);
-by(fast_tac (HOL_cs addDs [totalD,transfD]) 1);
-val insort_ss = insort_ss addsimps [result()];
-
-goal InSort.thy "!!f. [| total(f); transf(f) |] ==> sorted(f,insort(f,xs))";
-by(list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac insort_ss));
-result();
--- a/ex/InSort.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,21 +0,0 @@
-(* Title: HOL/ex/insort.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Insertion sort
-*)
-
-InSort = Sorting +
-
-consts
- ins :: "[['a,'a]=>bool, 'a, 'a list] => 'a list"
- insort :: "[['a,'a]=>bool, 'a list] => 'a list"
-
-primrec ins List.list
- ins_Nil "ins(f,x,[]) = [x]"
- ins_Cons "ins(f,x,y#ys) = if(f(x,y), x#y#ys, y#ins(f,x,ys))"
-primrec insort List.list
- insort_Nil "insort(f,[]) = []"
- insort_Cons "insort(f,x#xs) = ins(f,x,insort(f,xs))"
-end
--- a/ex/LList.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,880 +0,0 @@
-(* Title: HOL/llist
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-SHOULD LListD_Fun_CONS_I, etc., be equations (for rewriting)?
-*)
-
-open LList;
-
-(** Simplification **)
-
-val llist_ss = univ_ss addcongs [split_weak_cong, sum_case_weak_cong]
- setloop split_tac [expand_split, expand_sum_case];
-
-(*For adding _eqI rules to a simpset; we must remove Pair_eq because
- it may turn an instance of reflexivity into a conjunction!*)
-fun add_eqI ss = ss addsimps [range_eqI, image_eqI]
- delsimps [Pair_eq];
-
-
-(*This justifies using llist in other recursive type definitions*)
-goalw LList.thy llist.defs "!!A B. A<=B ==> llist(A) <= llist(B)";
-by (rtac gfp_mono 1);
-by (REPEAT (ares_tac basic_monos 1));
-qed "llist_mono";
-
-
-goal LList.thy "llist(A) = {Numb(0)} <+> (A <*> llist(A))";
-let val rew = rewrite_rule [NIL_def, CONS_def] in
-by (fast_tac (univ_cs addSIs (equalityI :: map rew llist.intrs)
- addEs [rew llist.elim]) 1)
-end;
-qed "llist_unfold";
-
-
-(*** Type checking by coinduction, using list_Fun
- THE COINDUCTIVE DEFINITION PACKAGE COULD DO THIS!
-***)
-
-goalw LList.thy [list_Fun_def]
- "!!M. [| M : X; X <= list_Fun(A, X Un llist(A)) |] ==> M : llist(A)";
-by (etac llist.coinduct 1);
-by (etac (subsetD RS CollectD) 1);
-by (assume_tac 1);
-qed "llist_coinduct";
-
-goalw LList.thy [list_Fun_def, NIL_def] "NIL: list_Fun(A,X)";
-by (fast_tac set_cs 1);
-qed "list_Fun_NIL_I";
-
-goalw LList.thy [list_Fun_def,CONS_def]
- "!!M N. [| M: A; N: X |] ==> CONS(M,N) : list_Fun(A,X)";
-by (fast_tac set_cs 1);
-qed "list_Fun_CONS_I";
-
-(*Utilise the "strong" part, i.e. gfp(f)*)
-goalw LList.thy (llist.defs @ [list_Fun_def])
- "!!M N. M: llist(A) ==> M : list_Fun(A, X Un llist(A))";
-by (etac (llist.mono RS gfp_fun_UnI2) 1);
-qed "list_Fun_llist_I";
-
-(*** LList_corec satisfies the desired recurion equation ***)
-
-(*A continuity result?*)
-goalw LList.thy [CONS_def] "CONS(M, UN x.f(x)) = (UN x. CONS(M, f(x)))";
-by (simp_tac (univ_ss addsimps [In1_UN1, Scons_UN1_y]) 1);
-qed "CONS_UN1";
-
-(*UNUSED; obsolete?
-goal Prod.thy "split(p, %x y.UN z.f(x,y,z)) = (UN z. split(p, %x y.f(x,y,z)))";
-by (simp_tac (prod_ss setloop (split_tac [expand_split])) 1);
-qed "split_UN1";
-
-goal Sum.thy "sum_case(s,f,%y.UN z.g(y,z)) = (UN z.sum_case(s,f,%y. g(y,z)))";
-by (simp_tac (sum_ss setloop (split_tac [expand_sum_case])) 1);
-qed "sum_case2_UN1";
-*)
-
-val prems = goalw LList.thy [CONS_def]
- "[| M<=M'; N<=N' |] ==> CONS(M,N) <= CONS(M',N')";
-by (REPEAT (resolve_tac ([In1_mono,Scons_mono]@prems) 1));
-qed "CONS_mono";
-
-val corec_fun_simps = [LList_corec_fun_def RS def_nat_rec_0,
- LList_corec_fun_def RS def_nat_rec_Suc];
-val corec_fun_ss = llist_ss addsimps corec_fun_simps;
-
-(** The directions of the equality are proved separately **)
-
-goalw LList.thy [LList_corec_def]
- "LList_corec(a,f) <= sum_case(%u.NIL, \
-\ split(%z w. CONS(z, LList_corec(w,f))), f(a))";
-by (rtac UN1_least 1);
-by (res_inst_tac [("n","k")] natE 1);
-by (ALLGOALS (asm_simp_tac corec_fun_ss));
-by (REPEAT (resolve_tac [allI, impI, subset_refl RS CONS_mono, UN1_upper] 1));
-qed "LList_corec_subset1";
-
-goalw LList.thy [LList_corec_def]
- "sum_case(%u.NIL, split(%z w. CONS(z, LList_corec(w,f))), f(a)) <= \
-\ LList_corec(a,f)";
-by (simp_tac (corec_fun_ss addsimps [CONS_UN1]) 1);
-by (safe_tac set_cs);
-by (ALLGOALS (res_inst_tac [("x","Suc(?k)")] UN1_I THEN'
- asm_simp_tac corec_fun_ss));
-qed "LList_corec_subset2";
-
-(*the recursion equation for LList_corec -- NOT SUITABLE FOR REWRITING!*)
-goal LList.thy
- "LList_corec(a,f) = sum_case(%u. NIL, \
-\ split(%z w. CONS(z, LList_corec(w,f))), f(a))";
-by (REPEAT (resolve_tac [equalityI, LList_corec_subset1,
- LList_corec_subset2] 1));
-qed "LList_corec";
-
-(*definitional version of same*)
-val [rew] = goal LList.thy
- "[| !!x. h(x) == LList_corec(x,f) |] ==> \
-\ h(a) = sum_case(%u.NIL, split(%z w. CONS(z, h(w))), f(a))";
-by (rewtac rew);
-by (rtac LList_corec 1);
-qed "def_LList_corec";
-
-(*A typical use of co-induction to show membership in the gfp.
- Bisimulation is range(%x. LList_corec(x,f)) *)
-goal LList.thy "LList_corec(a,f) : llist({u.True})";
-by (res_inst_tac [("X", "range(%x.LList_corec(x,?g))")] llist_coinduct 1);
-by (rtac rangeI 1);
-by (safe_tac set_cs);
-by (stac LList_corec 1);
-by (simp_tac (llist_ss addsimps [list_Fun_NIL_I, list_Fun_CONS_I, CollectI]
- |> add_eqI) 1);
-qed "LList_corec_type";
-
-(*Lemma for the proof of llist_corec*)
-goal LList.thy
- "LList_corec(a, %z.sum_case(Inl, split(%v w.Inr(<Leaf(v),w>)), f(z))) : \
-\ llist(range(Leaf))";
-by (res_inst_tac [("X", "range(%x.LList_corec(x,?g))")] llist_coinduct 1);
-by (rtac rangeI 1);
-by (safe_tac set_cs);
-by (stac LList_corec 1);
-by (asm_simp_tac (llist_ss addsimps [list_Fun_NIL_I]) 1);
-by (fast_tac (set_cs addSIs [list_Fun_CONS_I]) 1);
-qed "LList_corec_type2";
-
-
-(**** llist equality as a gfp; the bisimulation principle ****)
-
-(*This theorem is actually used, unlike the many similar ones in ZF*)
-goal LList.thy "LListD(r) = diag({Numb(0)}) <++> (r <**> LListD(r))";
-let val rew = rewrite_rule [NIL_def, CONS_def] in
-by (fast_tac (univ_cs addSIs (equalityI :: map rew LListD.intrs)
- addEs [rew LListD.elim]) 1)
-end;
-qed "LListD_unfold";
-
-goal LList.thy "!M N. <M,N> : LListD(diag(A)) --> ntrunc(k,M) = ntrunc(k,N)";
-by (res_inst_tac [("n", "k")] less_induct 1);
-by (safe_tac set_cs);
-by (etac LListD.elim 1);
-by (safe_tac (prod_cs addSEs [diagE]));
-by (res_inst_tac [("n", "n")] natE 1);
-by (asm_simp_tac (univ_ss addsimps [ntrunc_0]) 1);
-by (rename_tac "n'" 1);
-by (res_inst_tac [("n", "n'")] natE 1);
-by (asm_simp_tac (univ_ss addsimps [CONS_def, ntrunc_one_In1]) 1);
-by (asm_simp_tac (univ_ss addsimps [CONS_def, ntrunc_In1, ntrunc_Scons]) 1);
-qed "LListD_implies_ntrunc_equality";
-
-(*The domain of the LListD relation*)
-goalw LList.thy (llist.defs @ [NIL_def, CONS_def])
- "fst``LListD(diag(A)) <= llist(A)";
-by (rtac gfp_upperbound 1);
-(*avoids unfolding LListD on the rhs*)
-by (res_inst_tac [("P", "%x. fst``x <= ?B")] (LListD_unfold RS ssubst) 1);
-by (simp_tac fst_image_ss 1);
-by (fast_tac univ_cs 1);
-qed "fst_image_LListD";
-
-(*This inclusion justifies the use of coinduction to show M=N*)
-goal LList.thy "LListD(diag(A)) <= diag(llist(A))";
-by (rtac subsetI 1);
-by (res_inst_tac [("p","x")] PairE 1);
-by (safe_tac HOL_cs);
-by (rtac diag_eqI 1);
-by (rtac (LListD_implies_ntrunc_equality RS spec RS spec RS mp RS
- ntrunc_equality) 1);
-by (assume_tac 1);
-by (etac (fst_imageI RS (fst_image_LListD RS subsetD)) 1);
-qed "LListD_subset_diag";
-
-(** Coinduction, using LListD_Fun
- THE COINDUCTIVE DEFINITION PACKAGE COULD DO THIS!
- **)
-
-goalw LList.thy [LListD_Fun_def]
- "!!M. [| M : X; X <= LListD_Fun(r, X Un LListD(r)) |] ==> M : LListD(r)";
-by (etac LListD.coinduct 1);
-by (etac (subsetD RS CollectD) 1);
-by (assume_tac 1);
-qed "LListD_coinduct";
-
-goalw LList.thy [LListD_Fun_def,NIL_def] "<NIL,NIL> : LListD_Fun(r,s)";
-by (fast_tac set_cs 1);
-qed "LListD_Fun_NIL_I";
-
-goalw LList.thy [LListD_Fun_def,CONS_def]
- "!!x. [| x:A; <M,N>:s |] ==> <CONS(x,M), CONS(x,N)> : LListD_Fun(diag(A),s)";
-by (fast_tac univ_cs 1);
-qed "LListD_Fun_CONS_I";
-
-(*Utilise the "strong" part, i.e. gfp(f)*)
-goalw LList.thy (LListD.defs @ [LListD_Fun_def])
- "!!M N. M: LListD(r) ==> M : LListD_Fun(r, X Un LListD(r))";
-by (etac (LListD.mono RS gfp_fun_UnI2) 1);
-qed "LListD_Fun_LListD_I";
-
-
-(*This converse inclusion helps to strengthen LList_equalityI*)
-goal LList.thy "diag(llist(A)) <= LListD(diag(A))";
-by (rtac subsetI 1);
-by (etac LListD_coinduct 1);
-by (rtac subsetI 1);
-by (etac diagE 1);
-by (etac ssubst 1);
-by (eresolve_tac [llist.elim] 1);
-by (ALLGOALS
- (asm_simp_tac (llist_ss addsimps [diagI, LListD_Fun_NIL_I,
- LListD_Fun_CONS_I])));
-qed "diag_subset_LListD";
-
-goal LList.thy "LListD(diag(A)) = diag(llist(A))";
-by (REPEAT (resolve_tac [equalityI, LListD_subset_diag,
- diag_subset_LListD] 1));
-qed "LListD_eq_diag";
-
-goal LList.thy
- "!!M N. M: llist(A) ==> <M,M> : LListD_Fun(diag(A), X Un diag(llist(A)))";
-by (rtac (LListD_eq_diag RS subst) 1);
-by (rtac LListD_Fun_LListD_I 1);
-by (asm_simp_tac (HOL_ss addsimps [LListD_eq_diag, diagI]) 1);
-qed "LListD_Fun_diag_I";
-
-
-(** To show two LLists are equal, exhibit a bisimulation!
- [also admits true equality]
- Replace "A" by some particular set, like {x.True}??? *)
-goal LList.thy
- "!!r. [| <M,N> : r; r <= LListD_Fun(diag(A), r Un diag(llist(A))) \
-\ |] ==> M=N";
-by (rtac (LListD_subset_diag RS subsetD RS diagE) 1);
-by (etac LListD_coinduct 1);
-by (asm_simp_tac (HOL_ss addsimps [LListD_eq_diag]) 1);
-by (safe_tac prod_cs);
-qed "LList_equalityI";
-
-
-(*** Finality of llist(A): Uniqueness of functions defined by corecursion ***)
-
-(*abstract proof using a bisimulation*)
-val [prem1,prem2] = goal LList.thy
- "[| !!x. h1(x) = sum_case(%u.NIL, split(%z w. CONS(z,h1(w))), f(x)); \
-\ !!x. h2(x) = sum_case(%u.NIL, split(%z w. CONS(z,h2(w))), f(x)) |]\
-\ ==> h1=h2";
-by (rtac ext 1);
-(*next step avoids an unknown (and flexflex pair) in simplification*)
-by (res_inst_tac [("A", "{u.True}"),
- ("r", "range(%u. <h1(u),h2(u)>)")] LList_equalityI 1);
-by (rtac rangeI 1);
-by (safe_tac set_cs);
-by (stac prem1 1);
-by (stac prem2 1);
-by (simp_tac (llist_ss addsimps [LListD_Fun_NIL_I,
- CollectI RS LListD_Fun_CONS_I]
- |> add_eqI) 1);
-qed "LList_corec_unique";
-
-val [prem] = goal LList.thy
- "[| !!x. h(x) = sum_case(%u.NIL, split(%z w. CONS(z,h(w))), f(x)) |] \
-\ ==> h = (%x.LList_corec(x,f))";
-by (rtac (LList_corec RS (prem RS LList_corec_unique)) 1);
-qed "equals_LList_corec";
-
-
-(** Obsolete LList_corec_unique proof: complete induction, not coinduction **)
-
-goalw LList.thy [CONS_def] "ntrunc(Suc(0), CONS(M,N)) = {}";
-by (rtac ntrunc_one_In1 1);
-qed "ntrunc_one_CONS";
-
-goalw LList.thy [CONS_def]
- "ntrunc(Suc(Suc(k)), CONS(M,N)) = CONS (ntrunc(k,M), ntrunc(k,N))";
-by (simp_tac (HOL_ss addsimps [ntrunc_Scons,ntrunc_In1]) 1);
-qed "ntrunc_CONS";
-
-val [prem1,prem2] = goal LList.thy
- "[| !!x. h1(x) = sum_case(%u.NIL, split(%z w. CONS(z,h1(w))), f(x)); \
-\ !!x. h2(x) = sum_case(%u.NIL, split(%z w. CONS(z,h2(w))), f(x)) |]\
-\ ==> h1=h2";
-by (rtac (ntrunc_equality RS ext) 1);
-by (res_inst_tac [("x", "x")] spec 1);
-by (res_inst_tac [("n", "k")] less_induct 1);
-by (rtac allI 1);
-by (stac prem1 1);
-by (stac prem2 1);
-by (simp_tac (sum_ss setloop (split_tac [expand_split,expand_sum_case])) 1);
-by (strip_tac 1);
-by (res_inst_tac [("n", "n")] natE 1);
-by (res_inst_tac [("n", "xc")] natE 2);
-by (ALLGOALS(asm_simp_tac(nat_ss addsimps
- [ntrunc_0,ntrunc_one_CONS,ntrunc_CONS])));
-result();
-
-
-(*** Lconst -- defined directly using lfp, but equivalent to a LList_corec ***)
-
-goal LList.thy "mono(CONS(M))";
-by (REPEAT (ares_tac [monoI, subset_refl, CONS_mono] 1));
-qed "Lconst_fun_mono";
-
-(* Lconst(M) = CONS(M,Lconst(M)) *)
-bind_thm ("Lconst", (Lconst_fun_mono RS (Lconst_def RS def_lfp_Tarski)));
-
-(*A typical use of co-induction to show membership in the gfp.
- The containing set is simply the singleton {Lconst(M)}. *)
-goal LList.thy "!!M A. M:A ==> Lconst(M): llist(A)";
-by (rtac (singletonI RS llist_coinduct) 1);
-by (safe_tac set_cs);
-by (res_inst_tac [("P", "%u. u: ?A")] (Lconst RS ssubst) 1);
-by (REPEAT (ares_tac [list_Fun_CONS_I, singletonI, UnI1] 1));
-qed "Lconst_type";
-
-goal LList.thy "Lconst(M) = LList_corec(M, %x.Inr(<x,x>))";
-by (rtac (equals_LList_corec RS fun_cong) 1);
-by (simp_tac sum_ss 1);
-by (rtac Lconst 1);
-qed "Lconst_eq_LList_corec";
-
-(*Thus we could have used gfp in the definition of Lconst*)
-goal LList.thy "gfp(%N. CONS(M, N)) = LList_corec(M, %x.Inr(<x,x>))";
-by (rtac (equals_LList_corec RS fun_cong) 1);
-by (simp_tac sum_ss 1);
-by (rtac (Lconst_fun_mono RS gfp_Tarski) 1);
-qed "gfp_Lconst_eq_LList_corec";
-
-
-(*** Isomorphisms ***)
-
-goal LList.thy "inj(Rep_llist)";
-by (rtac inj_inverseI 1);
-by (rtac Rep_llist_inverse 1);
-qed "inj_Rep_llist";
-
-goal LList.thy "inj_onto(Abs_llist,llist(range(Leaf)))";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_llist_inverse 1);
-qed "inj_onto_Abs_llist";
-
-(** Distinctness of constructors **)
-
-goalw LList.thy [LNil_def,LCons_def] "~ LCons(x,xs) = LNil";
-by (rtac (CONS_not_NIL RS (inj_onto_Abs_llist RS inj_onto_contraD)) 1);
-by (REPEAT (resolve_tac (llist.intrs @ [rangeI, Rep_llist]) 1));
-qed "LCons_not_LNil";
-
-bind_thm ("LNil_not_LCons", (LCons_not_LNil RS not_sym));
-
-bind_thm ("LCons_neq_LNil", (LCons_not_LNil RS notE));
-val LNil_neq_LCons = sym RS LCons_neq_LNil;
-
-(** llist constructors **)
-
-goalw LList.thy [LNil_def]
- "Rep_llist(LNil) = NIL";
-by (rtac (llist.NIL_I RS Abs_llist_inverse) 1);
-qed "Rep_llist_LNil";
-
-goalw LList.thy [LCons_def]
- "Rep_llist(LCons(x,l)) = CONS(Leaf(x),Rep_llist(l))";
-by (REPEAT (resolve_tac [llist.CONS_I RS Abs_llist_inverse,
- rangeI, Rep_llist] 1));
-qed "Rep_llist_LCons";
-
-(** Injectiveness of CONS and LCons **)
-
-goalw LList.thy [CONS_def] "(CONS(M,N)=CONS(M',N')) = (M=M' & N=N')";
-by (fast_tac (HOL_cs addSEs [Scons_inject, make_elim In1_inject]) 1);
-qed "CONS_CONS_eq";
-
-bind_thm ("CONS_inject", (CONS_CONS_eq RS iffD1 RS conjE));
-
-
-(*For reasoning about abstract llist constructors*)
-val llist_cs = set_cs addIs [Rep_llist]@llist.intrs
- addSEs [CONS_neq_NIL,NIL_neq_CONS,CONS_inject]
- addSDs [inj_onto_Abs_llist RS inj_ontoD,
- inj_Rep_llist RS injD, Leaf_inject];
-
-goalw LList.thy [LCons_def] "(LCons(x,xs)=LCons(y,ys)) = (x=y & xs=ys)";
-by (fast_tac llist_cs 1);
-qed "LCons_LCons_eq";
-bind_thm ("LCons_inject", (LCons_LCons_eq RS iffD1 RS conjE));
-
-val [major] = goal LList.thy "CONS(M,N): llist(A) ==> M: A & N: llist(A)";
-by (rtac (major RS llist.elim) 1);
-by (etac CONS_neq_NIL 1);
-by (fast_tac llist_cs 1);
-qed "CONS_D";
-
-
-(****** Reasoning about llist(A) ******)
-
-(*Don't use llist_ss, as it does case splits!*)
-val List_case_ss = univ_ss addsimps [List_case_NIL, List_case_CONS];
-
-(*A special case of list_equality for functions over lazy lists*)
-val [Mlist,gMlist,NILcase,CONScase] = goal LList.thy
- "[| M: llist(A); g(NIL): llist(A); \
-\ f(NIL)=g(NIL); \
-\ !!x l. [| x:A; l: llist(A) |] ==> \
-\ <f(CONS(x,l)),g(CONS(x,l))> : \
-\ LListD_Fun(diag(A), (%u.<f(u),g(u)>)``llist(A) Un \
-\ diag(llist(A))) \
-\ |] ==> f(M) = g(M)";
-by (rtac LList_equalityI 1);
-by (rtac (Mlist RS imageI) 1);
-by (rtac subsetI 1);
-by (etac imageE 1);
-by (etac ssubst 1);
-by (etac llist.elim 1);
-by (etac ssubst 1);
-by (stac NILcase 1);
-by (rtac (gMlist RS LListD_Fun_diag_I) 1);
-by (etac ssubst 1);
-by (REPEAT (ares_tac [CONScase] 1));
-qed "LList_fun_equalityI";
-
-
-(*** The functional "Lmap" ***)
-
-goal LList.thy "Lmap(f,NIL) = NIL";
-by (rtac (Lmap_def RS def_LList_corec RS trans) 1);
-by (simp_tac List_case_ss 1);
-qed "Lmap_NIL";
-
-goal LList.thy "Lmap(f, CONS(M,N)) = CONS(f(M), Lmap(f,N))";
-by (rtac (Lmap_def RS def_LList_corec RS trans) 1);
-by (simp_tac List_case_ss 1);
-qed "Lmap_CONS";
-
-(*Another type-checking proof by coinduction*)
-val [major,minor] = goal LList.thy
- "[| M: llist(A); !!x. x:A ==> f(x):B |] ==> Lmap(f,M): llist(B)";
-by (rtac (major RS imageI RS llist_coinduct) 1);
-by (safe_tac set_cs);
-by (etac llist.elim 1);
-by (ALLGOALS (asm_simp_tac (HOL_ss addsimps [Lmap_NIL,Lmap_CONS])));
-by (REPEAT (ares_tac [list_Fun_NIL_I, list_Fun_CONS_I,
- minor, imageI, UnI1] 1));
-qed "Lmap_type";
-
-(*This type checking rule synthesises a sufficiently large set for f*)
-val [major] = goal LList.thy "M: llist(A) ==> Lmap(f,M): llist(f``A)";
-by (rtac (major RS Lmap_type) 1);
-by (etac imageI 1);
-qed "Lmap_type2";
-
-(** Two easy results about Lmap **)
-
-val [prem] = goalw LList.thy [o_def]
- "M: llist(A) ==> Lmap(f o g, M) = Lmap(f, Lmap(g, M))";
-by (rtac (prem RS imageI RS LList_equalityI) 1);
-by (safe_tac set_cs);
-by (etac llist.elim 1);
-by (ALLGOALS (asm_simp_tac (HOL_ss addsimps [Lmap_NIL,Lmap_CONS])));
-by (REPEAT (ares_tac [LListD_Fun_NIL_I, imageI, UnI1,
- rangeI RS LListD_Fun_CONS_I] 1));
-qed "Lmap_compose";
-
-val [prem] = goal LList.thy "M: llist(A) ==> Lmap(%x.x, M) = M";
-by (rtac (prem RS imageI RS LList_equalityI) 1);
-by (safe_tac set_cs);
-by (etac llist.elim 1);
-by (ALLGOALS (asm_simp_tac (HOL_ss addsimps [Lmap_NIL,Lmap_CONS])));
-by (REPEAT (ares_tac [LListD_Fun_NIL_I, imageI RS UnI1,
- rangeI RS LListD_Fun_CONS_I] 1));
-qed "Lmap_ident";
-
-
-(*** Lappend -- its two arguments cause some complications! ***)
-
-goalw LList.thy [Lappend_def] "Lappend(NIL,NIL) = NIL";
-by (rtac (LList_corec RS trans) 1);
-by (simp_tac List_case_ss 1);
-qed "Lappend_NIL_NIL";
-
-goalw LList.thy [Lappend_def]
- "Lappend(NIL,CONS(N,N')) = CONS(N, Lappend(NIL,N'))";
-by (rtac (LList_corec RS trans) 1);
-by (simp_tac List_case_ss 1);
-qed "Lappend_NIL_CONS";
-
-goalw LList.thy [Lappend_def]
- "Lappend(CONS(M,M'), N) = CONS(M, Lappend(M',N))";
-by (rtac (LList_corec RS trans) 1);
-by (simp_tac List_case_ss 1);
-qed "Lappend_CONS";
-
-val Lappend_ss =
- List_case_ss addsimps [llist.NIL_I, Lappend_NIL_NIL, Lappend_NIL_CONS,
- Lappend_CONS, LListD_Fun_CONS_I]
- |> add_eqI;
-
-goal LList.thy "!!M. M: llist(A) ==> Lappend(NIL,M) = M";
-by (etac LList_fun_equalityI 1);
-by (ALLGOALS (asm_simp_tac Lappend_ss));
-qed "Lappend_NIL";
-
-goal LList.thy "!!M. M: llist(A) ==> Lappend(M,NIL) = M";
-by (etac LList_fun_equalityI 1);
-by (ALLGOALS (asm_simp_tac Lappend_ss));
-qed "Lappend_NIL2";
-
-(** Alternative type-checking proofs for Lappend **)
-
-(*weak co-induction: bisimulation and case analysis on both variables*)
-goal LList.thy
- "!!M N. [| M: llist(A); N: llist(A) |] ==> Lappend(M,N): llist(A)";
-by (res_inst_tac
- [("X", "UN u:llist(A). UN v: llist(A). {Lappend(u,v)}")] llist_coinduct 1);
-by (fast_tac set_cs 1);
-by (safe_tac set_cs);
-by (eres_inst_tac [("a", "u")] llist.elim 1);
-by (eres_inst_tac [("a", "v")] llist.elim 1);
-by (ALLGOALS
- (asm_simp_tac Lappend_ss THEN'
- fast_tac (set_cs addSIs [llist.NIL_I, list_Fun_NIL_I, list_Fun_CONS_I])));
-qed "Lappend_type";
-
-(*strong co-induction: bisimulation and case analysis on one variable*)
-goal LList.thy
- "!!M N. [| M: llist(A); N: llist(A) |] ==> Lappend(M,N): llist(A)";
-by (res_inst_tac [("X", "(%u.Lappend(u,N))``llist(A)")] llist_coinduct 1);
-by (etac imageI 1);
-by (rtac subsetI 1);
-by (etac imageE 1);
-by (eres_inst_tac [("a", "u")] llist.elim 1);
-by (asm_simp_tac (Lappend_ss addsimps [Lappend_NIL, list_Fun_llist_I]) 1);
-by (asm_simp_tac Lappend_ss 1);
-by (fast_tac (set_cs addSIs [list_Fun_CONS_I]) 1);
-qed "Lappend_type";
-
-(**** Lazy lists as the type 'a llist -- strongly typed versions of above ****)
-
-(** llist_case: case analysis for 'a llist **)
-
-val Rep_llist_simps =
- [List_case_NIL, List_case_CONS,
- Abs_llist_inverse, Rep_llist_inverse,
- Rep_llist, rangeI, inj_Leaf, Inv_f_f]
- @ llist.intrs;
-val Rep_llist_ss = llist_ss addsimps Rep_llist_simps;
-
-goalw LList.thy [llist_case_def,LNil_def] "llist_case(c, d, LNil) = c";
-by (simp_tac Rep_llist_ss 1);
-qed "llist_case_LNil";
-
-goalw LList.thy [llist_case_def,LCons_def]
- "llist_case(c, d, LCons(M,N)) = d(M,N)";
-by (simp_tac Rep_llist_ss 1);
-qed "llist_case_LCons";
-
-(*Elimination is case analysis, not induction.*)
-val [prem1,prem2] = goalw LList.thy [NIL_def,CONS_def]
- "[| l=LNil ==> P; !!x l'. l=LCons(x,l') ==> P \
-\ |] ==> P";
-by (rtac (Rep_llist RS llist.elim) 1);
-by (rtac (inj_Rep_llist RS injD RS prem1) 1);
-by (stac Rep_llist_LNil 1);
-by (assume_tac 1);
-by (etac rangeE 1);
-by (rtac (inj_Rep_llist RS injD RS prem2) 1);
-by (asm_simp_tac (HOL_ss addsimps [Rep_llist_LCons]) 1);
-by (etac (Abs_llist_inverse RS ssubst) 1);
-by (rtac refl 1);
-qed "llistE";
-
-(** llist_corec: corecursion for 'a llist **)
-
-goalw LList.thy [llist_corec_def,LNil_def,LCons_def]
- "llist_corec(a,f) = sum_case(%u. LNil, \
-\ split(%z w. LCons(z, llist_corec(w,f))), f(a))";
-by (stac LList_corec 1);
-by (res_inst_tac [("s","f(a)")] sumE 1);
-by (asm_simp_tac (llist_ss addsimps [LList_corec_type2,Abs_llist_inverse]) 1);
-by (res_inst_tac [("p","y")] PairE 1);
-by (asm_simp_tac (llist_ss addsimps [LList_corec_type2,Abs_llist_inverse]) 1);
-(*FIXME: correct case splits usd to be found automatically:
-by (ASM_SIMP_TAC(llist_ss addsimps [LList_corec_type2,Abs_llist_inverse]) 1);*)
-qed "llist_corec";
-
-(*definitional version of same*)
-val [rew] = goal LList.thy
- "[| !!x. h(x) == llist_corec(x,f) |] ==> \
-\ h(a) = sum_case(%u.LNil, split(%z w. LCons(z, h(w))), f(a))";
-by (rewtac rew);
-by (rtac llist_corec 1);
-qed "def_llist_corec";
-
-(**** Proofs about type 'a llist functions ****)
-
-(*** Deriving llist_equalityI -- llist equality is a bisimulation ***)
-
-goalw LList.thy [LListD_Fun_def]
- "!!r A. r <= Sigma(llist(A), %x.llist(A)) ==> \
-\ LListD_Fun(diag(A),r) <= Sigma(llist(A), %x.llist(A))";
-by (stac llist_unfold 1);
-by (simp_tac (HOL_ss addsimps [NIL_def, CONS_def]) 1);
-by (fast_tac univ_cs 1);
-qed "LListD_Fun_subset_Sigma_llist";
-
-goal LList.thy
- "prod_fun(Rep_llist,Rep_llist) `` r <= \
-\ Sigma(llist(range(Leaf)), %x.llist(range(Leaf)))";
-by (fast_tac (prod_cs addIs [Rep_llist]) 1);
-qed "subset_Sigma_llist";
-
-val [prem] = goal LList.thy
- "r <= Sigma(llist(range(Leaf)), %x.llist(range(Leaf))) ==> \
-\ prod_fun(Rep_llist o Abs_llist, Rep_llist o Abs_llist) `` r <= r";
-by (safe_tac prod_cs);
-by (rtac (prem RS subsetD RS SigmaE2) 1);
-by (assume_tac 1);
-by (asm_simp_tac (HOL_ss addsimps [o_def,prod_fun,Abs_llist_inverse]) 1);
-qed "prod_fun_lemma";
-
-goal LList.thy
- "prod_fun(Rep_llist, Rep_llist) `` range(%x. <x, x>) = \
-\ diag(llist(range(Leaf)))";
-by (rtac equalityI 1);
-by (fast_tac (univ_cs addIs [Rep_llist]) 1);
-by (fast_tac (univ_cs addSEs [Abs_llist_inverse RS subst]) 1);
-qed "prod_fun_range_eq_diag";
-
-(** To show two llists are equal, exhibit a bisimulation!
- [also admits true equality] **)
-val [prem1,prem2] = goalw LList.thy [llistD_Fun_def]
- "[| <l1,l2> : r; r <= llistD_Fun(r Un range(%x.<x,x>)) |] ==> l1=l2";
-by (rtac (inj_Rep_llist RS injD) 1);
-by (res_inst_tac [("r", "prod_fun(Rep_llist,Rep_llist)``r"),
- ("A", "range(Leaf)")]
- LList_equalityI 1);
-by (rtac (prem1 RS prod_fun_imageI) 1);
-by (rtac (prem2 RS image_mono RS subset_trans) 1);
-by (rtac (image_compose RS subst) 1);
-by (rtac (prod_fun_compose RS subst) 1);
-by (rtac (image_Un RS ssubst) 1);
-by (stac prod_fun_range_eq_diag 1);
-by (rtac (LListD_Fun_subset_Sigma_llist RS prod_fun_lemma) 1);
-by (rtac (subset_Sigma_llist RS Un_least) 1);
-by (rtac diag_subset_Sigma 1);
-qed "llist_equalityI";
-
-(** Rules to prove the 2nd premise of llist_equalityI **)
-goalw LList.thy [llistD_Fun_def,LNil_def] "<LNil,LNil> : llistD_Fun(r)";
-by (rtac (LListD_Fun_NIL_I RS prod_fun_imageI) 1);
-qed "llistD_Fun_LNil_I";
-
-val [prem] = goalw LList.thy [llistD_Fun_def,LCons_def]
- "<l1,l2>:r ==> <LCons(x,l1), LCons(x,l2)> : llistD_Fun(r)";
-by (rtac (rangeI RS LListD_Fun_CONS_I RS prod_fun_imageI) 1);
-by (rtac (prem RS prod_fun_imageI) 1);
-qed "llistD_Fun_LCons_I";
-
-(*Utilise the "strong" part, i.e. gfp(f)*)
-goalw LList.thy [llistD_Fun_def]
- "!!l. <l,l> : llistD_Fun(r Un range(%x.<x,x>))";
-by (rtac (Rep_llist_inverse RS subst) 1);
-by (rtac prod_fun_imageI 1);
-by (rtac (image_Un RS ssubst) 1);
-by (stac prod_fun_range_eq_diag 1);
-by (rtac (Rep_llist RS LListD_Fun_diag_I) 1);
-qed "llistD_Fun_range_I";
-
-(*A special case of list_equality for functions over lazy lists*)
-val [prem1,prem2] = goal LList.thy
- "[| f(LNil)=g(LNil); \
-\ !!x l. <f(LCons(x,l)),g(LCons(x,l))> : \
-\ llistD_Fun(range(%u. <f(u),g(u)>) Un range(%v. <v,v>)) \
-\ |] ==> f(l) = (g(l :: 'a llist) :: 'b llist)";
-by (res_inst_tac [("r", "range(%u. <f(u),g(u)>)")] llist_equalityI 1);
-by (rtac rangeI 1);
-by (rtac subsetI 1);
-by (etac rangeE 1);
-by (etac ssubst 1);
-by (res_inst_tac [("l", "u")] llistE 1);
-by (etac ssubst 1);
-by (stac prem1 1);
-by (rtac llistD_Fun_range_I 1);
-by (etac ssubst 1);
-by (rtac prem2 1);
-qed "llist_fun_equalityI";
-
-(*simpset for llist bisimulations*)
-val llistD_simps = [llist_case_LNil, llist_case_LCons,
- llistD_Fun_LNil_I, llistD_Fun_LCons_I];
-(*Don't use llist_ss, as it does case splits!*)
-val llistD_ss = univ_ss addsimps llistD_simps |> add_eqI;
-
-
-(*** The functional "lmap" ***)
-
-goal LList.thy "lmap(f,LNil) = LNil";
-by (rtac (lmap_def RS def_llist_corec RS trans) 1);
-by (simp_tac llistD_ss 1);
-qed "lmap_LNil";
-
-goal LList.thy "lmap(f, LCons(M,N)) = LCons(f(M), lmap(f,N))";
-by (rtac (lmap_def RS def_llist_corec RS trans) 1);
-by (simp_tac llistD_ss 1);
-qed "lmap_LCons";
-
-
-(** Two easy results about lmap **)
-
-goal LList.thy "lmap(f o g, l) = lmap(f, lmap(g, l))";
-by (res_inst_tac [("l","l")] llist_fun_equalityI 1);
-by (ALLGOALS (simp_tac (llistD_ss addsimps [lmap_LNil, lmap_LCons])));
-qed "lmap_compose";
-
-goal LList.thy "lmap(%x.x, l) = l";
-by (res_inst_tac [("l","l")] llist_fun_equalityI 1);
-by (ALLGOALS (simp_tac (llistD_ss addsimps [lmap_LNil, lmap_LCons])));
-qed "lmap_ident";
-
-
-(*** iterates -- llist_fun_equalityI cannot be used! ***)
-
-goal LList.thy "iterates(f,x) = LCons(x, iterates(f,f(x)))";
-by (rtac (iterates_def RS def_llist_corec RS trans) 1);
-by (simp_tac sum_ss 1);
-qed "iterates";
-
-goal LList.thy "lmap(f, iterates(f,x)) = iterates(f,f(x))";
-by (res_inst_tac [("r", "range(%u.<lmap(f,iterates(f,u)),iterates(f,f(u))>)")]
- llist_equalityI 1);
-by (rtac rangeI 1);
-by (safe_tac set_cs);
-by (res_inst_tac [("x1", "f(u)")] (iterates RS ssubst) 1);
-by (res_inst_tac [("x1", "u")] (iterates RS ssubst) 1);
-by (simp_tac (llistD_ss addsimps [lmap_LCons]) 1);
-qed "lmap_iterates";
-
-goal LList.thy "iterates(f,x) = LCons(x, lmap(f, iterates(f,x)))";
-by (rtac (lmap_iterates RS ssubst) 1);
-by (rtac iterates 1);
-qed "iterates_lmap";
-
-(*** A rather complex proof about iterates -- cf Andy Pitts ***)
-
-(** Two lemmas about natrec(n,x,%m.g), which is essentially (g^n)(x) **)
-
-goal LList.thy
- "nat_rec(n, LCons(b, l), %m. lmap(f)) = \
-\ LCons(nat_rec(n, b, %m. f), nat_rec(n, l, %m. lmap(f)))";
-by (nat_ind_tac "n" 1);
-by (ALLGOALS (asm_simp_tac (nat_ss addsimps [lmap_LCons])));
-qed "fun_power_lmap";
-
-goal Nat.thy "nat_rec(n, g(x), %m. g) = nat_rec(Suc(n), x, %m. g)";
-by (nat_ind_tac "n" 1);
-by (ALLGOALS (asm_simp_tac nat_ss));
-qed "fun_power_Suc";
-
-val Pair_cong = read_instantiate_sg (sign_of Prod.thy)
- [("f","Pair")] (standard(refl RS cong RS cong));
-
-(*The bisimulation consists of {<lmap(f)^n (h(u)), lmap(f)^n (iterates(f,u))>}
- for all u and all n::nat.*)
-val [prem] = goal LList.thy
- "(!!x. h(x) = LCons(x, lmap(f,h(x)))) ==> h = iterates(f)";
-by (rtac ext 1);
-by (res_inst_tac [("r",
- "UN u. range(%n. <nat_rec(n, h(u), %m y.lmap(f,y)), \
-\ nat_rec(n, iterates(f,u), %m y.lmap(f,y))>)")]
- llist_equalityI 1);
-by (REPEAT (resolve_tac [UN1_I, range_eqI, Pair_cong, nat_rec_0 RS sym] 1));
-by (safe_tac set_cs);
-by (stac iterates 1);
-by (stac prem 1);
-by (stac fun_power_lmap 1);
-by (stac fun_power_lmap 1);
-by (rtac llistD_Fun_LCons_I 1);
-by (rtac (lmap_iterates RS subst) 1);
-by (stac fun_power_Suc 1);
-by (stac fun_power_Suc 1);
-by (rtac (UN1_I RS UnI1) 1);
-by (rtac rangeI 1);
-qed "iterates_equality";
-
-
-(*** lappend -- its two arguments cause some complications! ***)
-
-goalw LList.thy [lappend_def] "lappend(LNil,LNil) = LNil";
-by (rtac (llist_corec RS trans) 1);
-by (simp_tac llistD_ss 1);
-qed "lappend_LNil_LNil";
-
-goalw LList.thy [lappend_def]
- "lappend(LNil,LCons(l,l')) = LCons(l, lappend(LNil,l'))";
-by (rtac (llist_corec RS trans) 1);
-by (simp_tac llistD_ss 1);
-qed "lappend_LNil_LCons";
-
-goalw LList.thy [lappend_def]
- "lappend(LCons(l,l'), N) = LCons(l, lappend(l',N))";
-by (rtac (llist_corec RS trans) 1);
-by (simp_tac llistD_ss 1);
-qed "lappend_LCons";
-
-goal LList.thy "lappend(LNil,l) = l";
-by (res_inst_tac [("l","l")] llist_fun_equalityI 1);
-by (ALLGOALS
- (simp_tac (llistD_ss addsimps [lappend_LNil_LNil, lappend_LNil_LCons])));
-qed "lappend_LNil";
-
-goal LList.thy "lappend(l,LNil) = l";
-by (res_inst_tac [("l","l")] llist_fun_equalityI 1);
-by (ALLGOALS
- (simp_tac (llistD_ss addsimps [lappend_LNil_LNil, lappend_LCons])));
-qed "lappend_LNil2";
-
-(*The infinite first argument blocks the second*)
-goal LList.thy "lappend(iterates(f,x), N) = iterates(f,x)";
-by (res_inst_tac [("r", "range(%u.<lappend(iterates(f,u),N),iterates(f,u)>)")]
- llist_equalityI 1);
-by (rtac rangeI 1);
-by (safe_tac set_cs);
-by (stac iterates 1);
-by (simp_tac (llistD_ss addsimps [lappend_LCons]) 1);
-qed "lappend_iterates";
-
-(** Two proofs that lmap distributes over lappend **)
-
-(*Long proof requiring case analysis on both both arguments*)
-goal LList.thy "lmap(f, lappend(l,n)) = lappend(lmap(f,l), lmap(f,n))";
-by (res_inst_tac
- [("r",
- "UN n. range(%l.<lmap(f,lappend(l,n)), lappend(lmap(f,l),lmap(f,n))>)")]
- llist_equalityI 1);
-by (rtac UN1_I 1);
-by (rtac rangeI 1);
-by (safe_tac set_cs);
-by (res_inst_tac [("l", "l")] llistE 1);
-by (res_inst_tac [("l", "n")] llistE 1);
-by (ALLGOALS (asm_simp_tac (llistD_ss addsimps
- [lappend_LNil_LNil,lappend_LCons,lappend_LNil_LCons,
- lmap_LNil,lmap_LCons])));
-by (REPEAT_SOME (ares_tac [llistD_Fun_LCons_I, UN1_I RS UnI1, rangeI]));
-by (rtac range_eqI 1);
-by (rtac (refl RS Pair_cong) 1);
-by (stac lmap_LNil 1);
-by (rtac refl 1);
-qed "lmap_lappend_distrib";
-
-(*Shorter proof of theorem above using llist_equalityI as strong coinduction*)
-goal LList.thy "lmap(f, lappend(l,n)) = lappend(lmap(f,l), lmap(f,n))";
-by (res_inst_tac [("l","l")] llist_fun_equalityI 1);
-by (simp_tac (llistD_ss addsimps [lappend_LNil, lmap_LNil])1);
-by (simp_tac (llistD_ss addsimps [lappend_LCons, lmap_LCons]) 1);
-qed "lmap_lappend_distrib";
-
-(*Without strong coinduction, three case analyses might be needed*)
-goal LList.thy "lappend(lappend(l1,l2) ,l3) = lappend(l1, lappend(l2,l3))";
-by (res_inst_tac [("l","l1")] llist_fun_equalityI 1);
-by (simp_tac (llistD_ss addsimps [lappend_LNil])1);
-by (simp_tac (llistD_ss addsimps [lappend_LCons]) 1);
-qed "lappend_assoc";
--- a/ex/LList.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,145 +0,0 @@
-(* Title: HOL/LList.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Definition of type 'a llist by a greatest fixed point
-
-Shares NIL, CONS, List_case with List.thy
-
-Still needs filter and flatten functions -- hard because they need
-bounds on the amount of lookahead required.
-
-Could try (but would it work for the gfp analogue of term?)
- LListD_Fun_def "LListD_Fun(A) == (%Z.diag({Numb(0)}) <++> diag(A) <**> Z)"
-
-A nice but complex example would be [ML for the Working Programmer, page 176]
- from(1) = enumerate (Lmap (Lmap(pack), makeqq(from(1),from(1))))
-
-Previous definition of llistD_Fun was explicit:
- llistD_Fun_def
- "llistD_Fun(r) ==
- {<LNil,LNil>} Un
- (UN x. (split(%l1 l2.<LCons(x,l1),LCons(x,l2)>))``r)"
-*)
-
-LList = Gfp + SList +
-
-types
- 'a llist
-
-arities
- llist :: (term)term
-
-consts
- list_Fun :: "['a item set, 'a item set] => 'a item set"
- LListD_Fun ::
- "[('a item * 'a item)set, ('a item * 'a item)set] =>
- ('a item * 'a item)set"
-
- llist :: "'a item set => 'a item set"
- LListD :: "('a item * 'a item)set => ('a item * 'a item)set"
- llistD_Fun :: "('a llist * 'a llist)set => ('a llist * 'a llist)set"
-
- Rep_llist :: "'a llist => 'a item"
- Abs_llist :: "'a item => 'a llist"
- LNil :: "'a llist"
- LCons :: "['a, 'a llist] => 'a llist"
-
- llist_case :: "['b, ['a, 'a llist]=>'b, 'a llist] => 'b"
-
- LList_corec_fun :: "[nat, 'a=>unit+('b item * 'a), 'a] => 'b item"
- LList_corec :: "['a, 'a => unit + ('b item * 'a)] => 'b item"
- llist_corec :: "['a, 'a => unit + ('b * 'a)] => 'b llist"
-
- Lmap :: "('a item => 'b item) => ('a item => 'b item)"
- lmap :: "('a=>'b) => ('a llist => 'b llist)"
-
- iterates :: "['a => 'a, 'a] => 'a llist"
-
- Lconst :: "'a item => 'a item"
- Lappend :: "['a item, 'a item] => 'a item"
- lappend :: "['a llist, 'a llist] => 'a llist"
-
-
-coinductive "llist(A)"
- intrs
- NIL_I "NIL: llist(A)"
- CONS_I "[| a: A; M: llist(A) |] ==> CONS(a,M) : llist(A)"
-
-coinductive "LListD(r)"
- intrs
- NIL_I "<NIL, NIL> : LListD(r)"
- CONS_I "[| <a,b>: r; <M,N> : LListD(r)
- |] ==> <CONS(a,M), CONS(b,N)> : LListD(r)"
-
-defs
- (*Now used exclusively for abbreviating the coinduction rule*)
- list_Fun_def "list_Fun(A,X) ==
- {z. z = NIL | (? M a. z = CONS(a, M) & a : A & M : X)}"
-
- LListD_Fun_def "LListD_Fun(r,X) ==
- {z. z = <NIL, NIL> |
- (? M N a b. z = <CONS(a, M), CONS(b, N)> &
- <a, b> : r & <M, N> : X)}"
-
- (*defining the abstract constructors*)
- LNil_def "LNil == Abs_llist(NIL)"
- LCons_def "LCons(x,xs) == Abs_llist(CONS(Leaf(x), Rep_llist(xs)))"
-
- llist_case_def
- "llist_case(c,d,l) ==
- List_case(c, %x y. d(Inv(Leaf,x), Abs_llist(y)), Rep_llist(l))"
-
- LList_corec_fun_def
- "LList_corec_fun(k,f) ==
- nat_rec(k, %x. {},
- %j r x. sum_case(%u.NIL, split(%z w. CONS(z, r(w))), f(x)))"
-
- LList_corec_def
- "LList_corec(a,f) == UN k. LList_corec_fun(k,f,a)"
-
- llist_corec_def
- "llist_corec(a,f) ==
- Abs_llist(LList_corec(a, %z.sum_case(%x.Inl(x),
- split(%v w. Inr(<Leaf(v), w>)), f(z))))"
-
- llistD_Fun_def
- "llistD_Fun(r) ==
- prod_fun(Abs_llist,Abs_llist) ``
- LListD_Fun(diag(range(Leaf)),
- prod_fun(Rep_llist,Rep_llist) `` r)"
-
- Lconst_def "Lconst(M) == lfp(%N. CONS(M, N))"
-
- Lmap_def
- "Lmap(f,M) == LList_corec(M, List_case(Inl(Unity), %x M'. Inr(<f(x), M'>)))"
-
- lmap_def
- "lmap(f,l) == llist_corec(l, llist_case(Inl(Unity), %y z. Inr(<f(y), z>)))"
-
- iterates_def "iterates(f,a) == llist_corec(a, %x. Inr(<x, f(x)>))"
-
-(*Append generates its result by applying f, where
- f(<NIL,NIL>) = Inl(Unity)
- f(<NIL, CONS(N1,N2)>) = Inr(<N1, <NIL,N2>)
- f(<CONS(M1,M2), N>) = Inr(<M1, <M2,N>)
-*)
-
- Lappend_def
- "Lappend(M,N) == LList_corec(<M,N>,
- split(List_case(List_case(Inl(Unity), %N1 N2. Inr(<N1, <NIL,N2>>)),
- %M1 M2 N. Inr(<M1, <M2,N>>))))"
-
- lappend_def
- "lappend(l,n) == llist_corec(<l,n>,
- split(llist_case(llist_case(Inl(Unity), %n1 n2. Inr(<n1, <LNil,n2>>)),
- %l1 l2 n. Inr(<l1, <l2,n>>))))"
-
-rules
- (*faking a type definition...*)
- Rep_llist "Rep_llist(xs): llist(range(Leaf))"
- Rep_llist_inverse "Abs_llist(Rep_llist(xs)) = xs"
- Abs_llist_inverse "M: llist(range(Leaf)) ==> Rep_llist(Abs_llist(M)) = M"
-
-end
--- a/ex/LexProd.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,24 +0,0 @@
-(* Title: HOL/ex/lex-prod.ML
- ID: $Id$
- Author: Tobias Nipkow, TU Munich
- Copyright 1993 TU Munich
-
-For lex-prod.thy.
-The lexicographic product of two wellfounded relations is again wellfounded.
-*)
-
-val prems = goal Prod.thy "!a b. P(<a,b>) ==> !p.P(p)";
-by (cut_facts_tac prems 1);
-by (rtac allI 1);
-by (rtac (surjective_pairing RS ssubst) 1);
-by (fast_tac HOL_cs 1);
-qed "split_all_pair";
-
-val [wfa,wfb] = goalw LexProd.thy [wf_def,LexProd.lex_prod_def]
- "[| wf(ra); wf(rb) |] ==> wf(ra**rb)";
-by (EVERY1 [rtac allI,rtac impI, rtac split_all_pair]);
-by (rtac (wfa RS spec RS mp) 1);
-by (EVERY1 [rtac allI,rtac impI]);
-by (rtac (wfb RS spec RS mp) 1);
-by (fast_tac (set_cs addSEs [Pair_inject]) 1);
-qed "wf_lex_prod";
--- a/ex/LexProd.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,15 +0,0 @@
-(* Title: HOL/ex/lex-prod.thy
- ID: $Id$
- Author: Tobias Nipkow, TU Munich
- Copyright 1993 TU Munich
-
-The lexicographic product of two relations.
-*)
-
-LexProd = WF + Prod +
-consts "**" :: "[('a*'a)set, ('b*'b)set] => (('a*'b)*('a*'b))set" (infixl 70)
-rules
-lex_prod_def "ra**rb == {p. ? a a' b b'.
- p = <<a,b>,<a',b'>> & (<a,a'> : ra | a=a' & <b,b'> : rb)}"
-end
-
--- a/ex/MT.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,799 +0,0 @@
-(* Title: HOL/ex/mt.ML
- ID: $Id$
- Author: Jacob Frost, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Based upon the article
- Robin Milner and Mads Tofte,
- Co-induction in Relational Semantics,
- Theoretical Computer Science 87 (1991), pages 209-220.
-
-Written up as
- Jacob Frost, A Case Study of Co-induction in Isabelle/HOL
- Report 308, Computer Lab, University of Cambridge (1993).
-
-NEEDS TO USE INDUCTIVE DEFS PACKAGE
-*)
-
-open MT;
-
-val prems = goal MT.thy "~a:{b} ==> ~a=b";
-by (cut_facts_tac prems 1);
-by (rtac notI 1);
-by (dtac notE 1);
-by (hyp_subst_tac 1);
-by (rtac singletonI 1);
-by (assume_tac 1);
-qed "notsingletonI";
-
-(* ############################################################ *)
-(* Inference systems *)
-(* ############################################################ *)
-
-val infsys_mono_tac =
- (rewtac subset_def) THEN (safe_tac HOL_cs) THEN (rtac ballI 1) THEN
- (rtac CollectI 1) THEN (dtac CollectD 1) THEN
- REPEAT
- ( (TRY ((etac disjE 1) THEN (rtac disjI2 2) THEN (rtac disjI1 1))) THEN
- (REPEAT (etac exE 1)) THEN (REPEAT (rtac exI 1)) THEN (fast_tac set_cs 1)
- );
-
-val prems = goal MT.thy "P(a,b) ==> P(fst(<a,b>),snd(<a,b>))";
-by (simp_tac (prod_ss addsimps prems) 1);
-qed "infsys_p1";
-
-val prems = goal MT.thy "!!a b. P(fst(<a,b>),snd(<a,b>)) ==> P(a,b)";
-by (asm_full_simp_tac prod_ss 1);
-qed "infsys_p2";
-
-val prems = goal MT.thy
- "P(a,b,c) ==> P(fst(fst(<<a,b>,c>)),snd(fst(<<a,b>,c>)),snd(<<a,b>,c>))";
-by (simp_tac (prod_ss addsimps prems) 1);
-qed "infsys_pp1";
-
-goal MT.thy
- "!!a.P(fst(fst(<<a,b>,c>)),snd(fst(<<a,b>,c>)),snd(<<a,b>,c>)) ==> P(a,b,c)";
-by (asm_full_simp_tac prod_ss 1);
-qed "infsys_pp2";
-
-(* ############################################################ *)
-(* Fixpoints *)
-(* ############################################################ *)
-
-(* Least fixpoints *)
-
-val prems = goal MT.thy "[| mono(f); x:f(lfp(f)) |] ==> x:lfp(f)";
-by (rtac subsetD 1);
-by (rtac lfp_lemma2 1);
-by (resolve_tac prems 1);
-by (resolve_tac prems 1);
-qed "lfp_intro2";
-
-val prems = goal MT.thy
- " [| x:lfp(f); mono(f); !!y. y:f(lfp(f)) ==> P(y) |] ==> \
-\ P(x)";
-by (cut_facts_tac prems 1);
-by (resolve_tac prems 1);
-by (rtac subsetD 1);
-by (rtac lfp_lemma3 1);
-by (assume_tac 1);
-by (assume_tac 1);
-qed "lfp_elim2";
-
-val prems = goal MT.thy
- " [| x:lfp(f); mono(f); !!y. y:f(lfp(f) Int {x.P(x)}) ==> P(y) |] ==> \
-\ P(x)";
-by (cut_facts_tac prems 1);
-by (etac induct 1);
-by (assume_tac 1);
-by (eresolve_tac prems 1);
-qed "lfp_ind2";
-
-(* Greatest fixpoints *)
-
-(* Note : "[| x:S; S <= f(S Un gfp(f)); mono(f) |] ==> x:gfp(f)" *)
-
-val [cih,monoh] = goal MT.thy "[| x:f({x} Un gfp(f)); mono(f) |] ==> x:gfp(f)";
-by (rtac (cih RSN (2,gfp_upperbound RS subsetD)) 1);
-by (rtac (monoh RS monoD) 1);
-by (rtac (UnE RS subsetI) 1);
-by (assume_tac 1);
-by (fast_tac (set_cs addSIs [cih]) 1);
-by (rtac (monoh RS monoD RS subsetD) 1);
-by (rtac Un_upper2 1);
-by (etac (monoh RS gfp_lemma2 RS subsetD) 1);
-qed "gfp_coind2";
-
-val [gfph,monoh,caseh] = goal MT.thy
- "[| x:gfp(f); mono(f); !! y. y:f(gfp(f)) ==> P(y) |] ==> P(x)";
-by (rtac caseh 1);
-by (rtac subsetD 1);
-by (rtac gfp_lemma2 1);
-by (rtac monoh 1);
-by (rtac gfph 1);
-qed "gfp_elim2";
-
-(* ############################################################ *)
-(* Expressions *)
-(* ############################################################ *)
-
-val e_injs = [e_const_inj, e_var_inj, e_fn_inj, e_fix_inj, e_app_inj];
-
-val e_disjs =
- [ e_disj_const_var,
- e_disj_const_fn,
- e_disj_const_fix,
- e_disj_const_app,
- e_disj_var_fn,
- e_disj_var_fix,
- e_disj_var_app,
- e_disj_fn_fix,
- e_disj_fn_app,
- e_disj_fix_app
- ];
-
-val e_disj_si = e_disjs @ (e_disjs RL [not_sym]);
-val e_disj_se = (e_disj_si RL [notE]);
-
-fun e_ext_cs cs = cs addSIs e_disj_si addSEs e_disj_se addSDs e_injs;
-
-(* ############################################################ *)
-(* Values *)
-(* ############################################################ *)
-
-val v_disjs = [v_disj_const_clos];
-val v_disj_si = v_disjs @ (v_disjs RL [not_sym]);
-val v_disj_se = (v_disj_si RL [notE]);
-
-val v_injs = [v_const_inj, v_clos_inj];
-
-fun v_ext_cs cs = cs addSIs v_disj_si addSEs v_disj_se addSDs v_injs;
-
-(* ############################################################ *)
-(* Evaluations *)
-(* ############################################################ *)
-
-(* Monotonicity of eval_fun *)
-
-goalw MT.thy [mono_def, eval_fun_def] "mono(eval_fun)";
-(*Causes the most horrendous flexflex-trace.*)
-by infsys_mono_tac;
-qed "eval_fun_mono";
-
-(* Introduction rules *)
-
-goalw MT.thy [eval_def, eval_rel_def] "ve |- e_const(c) ---> v_const(c)";
-by (rtac lfp_intro2 1);
-by (rtac eval_fun_mono 1);
-by (rewtac eval_fun_def);
-by (fast_tac set_cs 1);
-qed "eval_const";
-
-val prems = goalw MT.thy [eval_def, eval_rel_def]
- "ev:ve_dom(ve) ==> ve |- e_var(ev) ---> ve_app(ve,ev)";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac eval_fun_mono 1);
-by (rewtac eval_fun_def);
-by (fast_tac set_cs 1);
-qed "eval_var";
-
-val prems = goalw MT.thy [eval_def, eval_rel_def]
- "ve |- fn ev => e ---> v_clos(<|ev,e,ve|>)";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac eval_fun_mono 1);
-by (rewtac eval_fun_def);
-by (fast_tac set_cs 1);
-qed "eval_fn";
-
-val prems = goalw MT.thy [eval_def, eval_rel_def]
- " cl = <| ev1, e, ve + {ev2 |-> v_clos(cl)} |> ==> \
-\ ve |- fix ev2(ev1) = e ---> v_clos(cl)";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac eval_fun_mono 1);
-by (rewtac eval_fun_def);
-by (fast_tac set_cs 1);
-qed "eval_fix";
-
-val prems = goalw MT.thy [eval_def, eval_rel_def]
- " [| ve |- e1 ---> v_const(c1); ve |- e2 ---> v_const(c2) |] ==> \
-\ ve |- e1 @ e2 ---> v_const(c_app(c1,c2))";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac eval_fun_mono 1);
-by (rewtac eval_fun_def);
-by (fast_tac set_cs 1);
-qed "eval_app1";
-
-val prems = goalw MT.thy [eval_def, eval_rel_def]
- " [| ve |- e1 ---> v_clos(<|xm,em,vem|>); \
-\ ve |- e2 ---> v2; \
-\ vem + {xm |-> v2} |- em ---> v \
-\ |] ==> \
-\ ve |- e1 @ e2 ---> v";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac eval_fun_mono 1);
-by (rewtac eval_fun_def);
-by (fast_tac (set_cs addSIs [disjI2]) 1);
-qed "eval_app2";
-
-(* Strong elimination, induction on evaluations *)
-
-val prems = goalw MT.thy [eval_def, eval_rel_def]
- " [| ve |- e ---> v; \
-\ !!ve c. P(<<ve,e_const(c)>,v_const(c)>); \
-\ !!ev ve. ev:ve_dom(ve) ==> P(<<ve,e_var(ev)>,ve_app(ve,ev)>); \
-\ !!ev ve e. P(<<ve,fn ev => e>,v_clos(<|ev,e,ve|>)>); \
-\ !!ev1 ev2 ve cl e. \
-\ cl = <| ev1, e, ve + {ev2 |-> v_clos(cl)} |> ==> \
-\ P(<<ve,fix ev2(ev1) = e>,v_clos(cl)>); \
-\ !!ve c1 c2 e1 e2. \
-\ [| P(<<ve,e1>,v_const(c1)>); P(<<ve,e2>,v_const(c2)>) |] ==> \
-\ P(<<ve,e1 @ e2>,v_const(c_app(c1,c2))>); \
-\ !!ve vem xm e1 e2 em v v2. \
-\ [| P(<<ve,e1>,v_clos(<|xm,em,vem|>)>); \
-\ P(<<ve,e2>,v2>); \
-\ P(<<vem + {xm |-> v2},em>,v>) \
-\ |] ==> \
-\ P(<<ve,e1 @ e2>,v>) \
-\ |] ==> \
-\ P(<<ve,e>,v>)";
-by (resolve_tac (prems RL [lfp_ind2]) 1);
-by (rtac eval_fun_mono 1);
-by (rewtac eval_fun_def);
-by (dtac CollectD 1);
-by (safe_tac HOL_cs);
-by (ALLGOALS (resolve_tac prems));
-by (ALLGOALS (fast_tac set_cs));
-qed "eval_ind0";
-
-val prems = goal MT.thy
- " [| ve |- e ---> v; \
-\ !!ve c. P(ve,e_const(c),v_const(c)); \
-\ !!ev ve. ev:ve_dom(ve) ==> P(ve,e_var(ev),ve_app(ve,ev)); \
-\ !!ev ve e. P(ve,fn ev => e,v_clos(<|ev,e,ve|>)); \
-\ !!ev1 ev2 ve cl e. \
-\ cl = <| ev1, e, ve + {ev2 |-> v_clos(cl)} |> ==> \
-\ P(ve,fix ev2(ev1) = e,v_clos(cl)); \
-\ !!ve c1 c2 e1 e2. \
-\ [| P(ve,e1,v_const(c1)); P(ve,e2,v_const(c2)) |] ==> \
-\ P(ve,e1 @ e2,v_const(c_app(c1,c2))); \
-\ !!ve vem evm e1 e2 em v v2. \
-\ [| P(ve,e1,v_clos(<|evm,em,vem|>)); \
-\ P(ve,e2,v2); \
-\ P(vem + {evm |-> v2},em,v) \
-\ |] ==> P(ve,e1 @ e2,v) \
-\ |] ==> P(ve,e,v)";
-by (res_inst_tac [("P","P")] infsys_pp2 1);
-by (rtac eval_ind0 1);
-by (ALLGOALS (rtac infsys_pp1));
-by (ALLGOALS (resolve_tac prems));
-by (REPEAT ((assume_tac 1) ORELSE (dtac infsys_pp2 1)));
-qed "eval_ind";
-
-(* ############################################################ *)
-(* Elaborations *)
-(* ############################################################ *)
-
-goalw MT.thy [mono_def, elab_fun_def] "mono(elab_fun)";
-by infsys_mono_tac;
-qed "elab_fun_mono";
-
-(* Introduction rules *)
-
-val prems = goalw MT.thy [elab_def, elab_rel_def]
- "c isof ty ==> te |- e_const(c) ===> ty";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac elab_fun_mono 1);
-by (rewtac elab_fun_def);
-by (fast_tac set_cs 1);
-qed "elab_const";
-
-val prems = goalw MT.thy [elab_def, elab_rel_def]
- "x:te_dom(te) ==> te |- e_var(x) ===> te_app(te,x)";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac elab_fun_mono 1);
-by (rewtac elab_fun_def);
-by (fast_tac set_cs 1);
-qed "elab_var";
-
-val prems = goalw MT.thy [elab_def, elab_rel_def]
- "te + {x |=> ty1} |- e ===> ty2 ==> te |- fn x => e ===> ty1->ty2";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac elab_fun_mono 1);
-by (rewtac elab_fun_def);
-by (fast_tac set_cs 1);
-qed "elab_fn";
-
-val prems = goalw MT.thy [elab_def, elab_rel_def]
- " te + {f |=> ty1->ty2} + {x |=> ty1} |- e ===> ty2 ==> \
-\ te |- fix f(x) = e ===> ty1->ty2";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac elab_fun_mono 1);
-by (rewtac elab_fun_def);
-by (rtac CollectI 1);
-by (rtac disjI2 1);
-by (rtac disjI2 1);
-by (rtac disjI2 1);
-by (rtac disjI1 1);
-by (fast_tac HOL_cs 1);
-qed "elab_fix";
-
-val prems = goalw MT.thy [elab_def, elab_rel_def]
- " [| te |- e1 ===> ty1->ty2; te |- e2 ===> ty1 |] ==> \
-\ te |- e1 @ e2 ===> ty2";
-by (cut_facts_tac prems 1);
-by (rtac lfp_intro2 1);
-by (rtac elab_fun_mono 1);
-by (rewtac elab_fun_def);
-by (fast_tac (set_cs addSIs [disjI2]) 1);
-qed "elab_app";
-
-(* Strong elimination, induction on elaborations *)
-
-val prems = goalw MT.thy [elab_def, elab_rel_def]
- " [| te |- e ===> t; \
-\ !!te c t. c isof t ==> P(<<te,e_const(c)>,t>); \
-\ !!te x. x:te_dom(te) ==> P(<<te,e_var(x)>,te_app(te,x)>); \
-\ !!te x e t1 t2. \
-\ [| te + {x |=> t1} |- e ===> t2; P(<<te + {x |=> t1},e>,t2>) |] ==> \
-\ P(<<te,fn x => e>,t1->t2>); \
-\ !!te f x e t1 t2. \
-\ [| te + {f |=> t1->t2} + {x |=> t1} |- e ===> t2; \
-\ P(<<te + {f |=> t1->t2} + {x |=> t1},e>,t2>) \
-\ |] ==> \
-\ P(<<te,fix f(x) = e>,t1->t2>); \
-\ !!te e1 e2 t1 t2. \
-\ [| te |- e1 ===> t1->t2; P(<<te,e1>,t1->t2>); \
-\ te |- e2 ===> t1; P(<<te,e2>,t1>) \
-\ |] ==> \
-\ P(<<te,e1 @ e2>,t2>) \
-\ |] ==> \
-\ P(<<te,e>,t>)";
-by (resolve_tac (prems RL [lfp_ind2]) 1);
-by (rtac elab_fun_mono 1);
-by (rewtac elab_fun_def);
-by (dtac CollectD 1);
-by (safe_tac HOL_cs);
-by (ALLGOALS (resolve_tac prems));
-by (ALLGOALS (fast_tac set_cs));
-qed "elab_ind0";
-
-val prems = goal MT.thy
- " [| te |- e ===> t; \
-\ !!te c t. c isof t ==> P(te,e_const(c),t); \
-\ !!te x. x:te_dom(te) ==> P(te,e_var(x),te_app(te,x)); \
-\ !!te x e t1 t2. \
-\ [| te + {x |=> t1} |- e ===> t2; P(te + {x |=> t1},e,t2) |] ==> \
-\ P(te,fn x => e,t1->t2); \
-\ !!te f x e t1 t2. \
-\ [| te + {f |=> t1->t2} + {x |=> t1} |- e ===> t2; \
-\ P(te + {f |=> t1->t2} + {x |=> t1},e,t2) \
-\ |] ==> \
-\ P(te,fix f(x) = e,t1->t2); \
-\ !!te e1 e2 t1 t2. \
-\ [| te |- e1 ===> t1->t2; P(te,e1,t1->t2); \
-\ te |- e2 ===> t1; P(te,e2,t1) \
-\ |] ==> \
-\ P(te,e1 @ e2,t2) \
-\ |] ==> \
-\ P(te,e,t)";
-by (res_inst_tac [("P","P")] infsys_pp2 1);
-by (rtac elab_ind0 1);
-by (ALLGOALS (rtac infsys_pp1));
-by (ALLGOALS (resolve_tac prems));
-by (REPEAT ((assume_tac 1) ORELSE (dtac infsys_pp2 1)));
-qed "elab_ind";
-
-(* Weak elimination, case analysis on elaborations *)
-
-val prems = goalw MT.thy [elab_def, elab_rel_def]
- " [| te |- e ===> t; \
-\ !!te c t. c isof t ==> P(<<te,e_const(c)>,t>); \
-\ !!te x. x:te_dom(te) ==> P(<<te,e_var(x)>,te_app(te,x)>); \
-\ !!te x e t1 t2. \
-\ te + {x |=> t1} |- e ===> t2 ==> P(<<te,fn x => e>,t1->t2>); \
-\ !!te f x e t1 t2. \
-\ te + {f |=> t1->t2} + {x |=> t1} |- e ===> t2 ==> \
-\ P(<<te,fix f(x) = e>,t1->t2>); \
-\ !!te e1 e2 t1 t2. \
-\ [| te |- e1 ===> t1->t2; te |- e2 ===> t1 |] ==> \
-\ P(<<te,e1 @ e2>,t2>) \
-\ |] ==> \
-\ P(<<te,e>,t>)";
-by (resolve_tac (prems RL [lfp_elim2]) 1);
-by (rtac elab_fun_mono 1);
-by (rewtac elab_fun_def);
-by (dtac CollectD 1);
-by (safe_tac HOL_cs);
-by (ALLGOALS (resolve_tac prems));
-by (ALLGOALS (fast_tac set_cs));
-qed "elab_elim0";
-
-val prems = goal MT.thy
- " [| te |- e ===> t; \
-\ !!te c t. c isof t ==> P(te,e_const(c),t); \
-\ !!te x. x:te_dom(te) ==> P(te,e_var(x),te_app(te,x)); \
-\ !!te x e t1 t2. \
-\ te + {x |=> t1} |- e ===> t2 ==> P(te,fn x => e,t1->t2); \
-\ !!te f x e t1 t2. \
-\ te + {f |=> t1->t2} + {x |=> t1} |- e ===> t2 ==> \
-\ P(te,fix f(x) = e,t1->t2); \
-\ !!te e1 e2 t1 t2. \
-\ [| te |- e1 ===> t1->t2; te |- e2 ===> t1 |] ==> \
-\ P(te,e1 @ e2,t2) \
-\ |] ==> \
-\ P(te,e,t)";
-by (res_inst_tac [("P","P")] infsys_pp2 1);
-by (rtac elab_elim0 1);
-by (ALLGOALS (rtac infsys_pp1));
-by (ALLGOALS (resolve_tac prems));
-by (REPEAT ((assume_tac 1) ORELSE (dtac infsys_pp2 1)));
-qed "elab_elim";
-
-(* Elimination rules for each expression *)
-
-fun elab_e_elim_tac p =
- ( (rtac elab_elim 1) THEN
- (resolve_tac p 1) THEN
- (REPEAT (fast_tac (e_ext_cs HOL_cs) 1))
- );
-
-val prems = goal MT.thy "te |- e ===> t ==> (e = e_const(c) --> c isof t)";
-by (elab_e_elim_tac prems);
-qed "elab_const_elim_lem";
-
-val prems = goal MT.thy "te |- e_const(c) ===> t ==> c isof t";
-by (cut_facts_tac prems 1);
-by (dtac elab_const_elim_lem 1);
-by (fast_tac prop_cs 1);
-qed "elab_const_elim";
-
-val prems = goal MT.thy
- "te |- e ===> t ==> (e = e_var(x) --> t=te_app(te,x) & x:te_dom(te))";
-by (elab_e_elim_tac prems);
-qed "elab_var_elim_lem";
-
-val prems = goal MT.thy
- "te |- e_var(ev) ===> t ==> t=te_app(te,ev) & ev : te_dom(te)";
-by (cut_facts_tac prems 1);
-by (dtac elab_var_elim_lem 1);
-by (fast_tac prop_cs 1);
-qed "elab_var_elim";
-
-val prems = goal MT.thy
- " te |- e ===> t ==> \
-\ ( e = fn x1 => e1 --> \
-\ (? t1 t2.t=t_fun(t1,t2) & te + {x1 |=> t1} |- e1 ===> t2) \
-\ )";
-by (elab_e_elim_tac prems);
-qed "elab_fn_elim_lem";
-
-val prems = goal MT.thy
- " te |- fn x1 => e1 ===> t ==> \
-\ (? t1 t2. t=t1->t2 & te + {x1 |=> t1} |- e1 ===> t2)";
-by (cut_facts_tac prems 1);
-by (dtac elab_fn_elim_lem 1);
-by (fast_tac prop_cs 1);
-qed "elab_fn_elim";
-
-val prems = goal MT.thy
- " te |- e ===> t ==> \
-\ (e = fix f(x) = e1 --> \
-\ (? t1 t2. t=t1->t2 & te + {f |=> t1->t2} + {x |=> t1} |- e1 ===> t2))";
-by (elab_e_elim_tac prems);
-qed "elab_fix_elim_lem";
-
-val prems = goal MT.thy
- " te |- fix ev1(ev2) = e1 ===> t ==> \
-\ (? t1 t2. t=t1->t2 & te + {ev1 |=> t1->t2} + {ev2 |=> t1} |- e1 ===> t2)";
-by (cut_facts_tac prems 1);
-by (dtac elab_fix_elim_lem 1);
-by (fast_tac prop_cs 1);
-qed "elab_fix_elim";
-
-val prems = goal MT.thy
- " te |- e ===> t2 ==> \
-\ (e = e1 @ e2 --> (? t1 . te |- e1 ===> t1->t2 & te |- e2 ===> t1))";
-by (elab_e_elim_tac prems);
-qed "elab_app_elim_lem";
-
-val prems = goal MT.thy
- "te |- e1 @ e2 ===> t2 ==> (? t1 . te |- e1 ===> t1->t2 & te |- e2 ===> t1)";
-by (cut_facts_tac prems 1);
-by (dtac elab_app_elim_lem 1);
-by (fast_tac prop_cs 1);
-qed "elab_app_elim";
-
-(* ############################################################ *)
-(* The extended correspondence relation *)
-(* ############################################################ *)
-
-(* Monotonicity of hasty_fun *)
-
-goalw MT.thy [mono_def,MT.hasty_fun_def] "mono(hasty_fun)";
-by infsys_mono_tac;
-bind_thm("mono_hasty_fun", result());
-
-(*
- Because hasty_rel has been defined as the greatest fixpoint of hasty_fun it
- enjoys two strong indtroduction (co-induction) rules and an elimination rule.
-*)
-
-(* First strong indtroduction (co-induction) rule for hasty_rel *)
-
-val prems = goalw MT.thy [hasty_rel_def] "c isof t ==> <v_const(c),t> : hasty_rel";
-by (cut_facts_tac prems 1);
-by (rtac gfp_coind2 1);
-by (rewtac MT.hasty_fun_def);
-by (rtac CollectI 1);
-by (rtac disjI1 1);
-by (fast_tac HOL_cs 1);
-by (rtac mono_hasty_fun 1);
-qed "hasty_rel_const_coind";
-
-(* Second strong introduction (co-induction) rule for hasty_rel *)
-
-val prems = goalw MT.thy [hasty_rel_def]
- " [| te |- fn ev => e ===> t; \
-\ ve_dom(ve) = te_dom(te); \
-\ ! ev1. \
-\ ev1:ve_dom(ve) --> \
-\ <ve_app(ve,ev1),te_app(te,ev1)> : {<v_clos(<|ev,e,ve|>),t>} Un hasty_rel \
-\ |] ==> \
-\ <v_clos(<|ev,e,ve|>),t> : hasty_rel";
-by (cut_facts_tac prems 1);
-by (rtac gfp_coind2 1);
-by (rewtac hasty_fun_def);
-by (rtac CollectI 1);
-by (rtac disjI2 1);
-by (fast_tac HOL_cs 1);
-by (rtac mono_hasty_fun 1);
-qed "hasty_rel_clos_coind";
-
-(* Elimination rule for hasty_rel *)
-
-val prems = goalw MT.thy [hasty_rel_def]
- " [| !! c t.c isof t ==> P(<v_const(c),t>); \
-\ !! te ev e t ve. \
-\ [| te |- fn ev => e ===> t; \
-\ ve_dom(ve) = te_dom(te); \
-\ !ev1.ev1:ve_dom(ve) --> <ve_app(ve,ev1),te_app(te,ev1)> : hasty_rel \
-\ |] ==> P(<v_clos(<|ev,e,ve|>),t>); \
-\ <v,t> : hasty_rel \
-\ |] ==> P(<v,t>)";
-by (cut_facts_tac prems 1);
-by (etac gfp_elim2 1);
-by (rtac mono_hasty_fun 1);
-by (rewtac hasty_fun_def);
-by (dtac CollectD 1);
-by (fold_goals_tac [hasty_fun_def]);
-by (safe_tac HOL_cs);
-by (ALLGOALS (resolve_tac prems));
-by (ALLGOALS (fast_tac set_cs));
-qed "hasty_rel_elim0";
-
-val prems = goal MT.thy
- " [| <v,t> : hasty_rel; \
-\ !! c t.c isof t ==> P(v_const(c),t); \
-\ !! te ev e t ve. \
-\ [| te |- fn ev => e ===> t; \
-\ ve_dom(ve) = te_dom(te); \
-\ !ev1.ev1:ve_dom(ve) --> <ve_app(ve,ev1),te_app(te,ev1)> : hasty_rel \
-\ |] ==> P(v_clos(<|ev,e,ve|>),t) \
-\ |] ==> P(v,t)";
-by (res_inst_tac [("P","P")] infsys_p2 1);
-by (rtac hasty_rel_elim0 1);
-by (ALLGOALS (rtac infsys_p1));
-by (ALLGOALS (resolve_tac prems));
-by (REPEAT ((assume_tac 1) ORELSE (dtac infsys_p2 1)));
-qed "hasty_rel_elim";
-
-(* Introduction rules for hasty *)
-
-val prems = goalw MT.thy [hasty_def] "c isof t ==> v_const(c) hasty t";
-by (resolve_tac (prems RL [hasty_rel_const_coind]) 1);
-qed "hasty_const";
-
-val prems = goalw MT.thy [hasty_def,hasty_env_def]
- "te |- fn ev => e ===> t & ve hastyenv te ==> v_clos(<|ev,e,ve|>) hasty t";
-by (cut_facts_tac prems 1);
-by (rtac hasty_rel_clos_coind 1);
-by (ALLGOALS (fast_tac set_cs));
-qed "hasty_clos";
-
-(* Elimination on constants for hasty *)
-
-val prems = goalw MT.thy [hasty_def]
- "v hasty t ==> (!c.(v = v_const(c) --> c isof t))";
-by (cut_facts_tac prems 1);
-by (rtac hasty_rel_elim 1);
-by (ALLGOALS (fast_tac (v_ext_cs HOL_cs)));
-qed "hasty_elim_const_lem";
-
-val prems = goal MT.thy "v_const(c) hasty t ==> c isof t";
-by (cut_facts_tac (prems RL [hasty_elim_const_lem]) 1);
-by (fast_tac HOL_cs 1);
-qed "hasty_elim_const";
-
-(* Elimination on closures for hasty *)
-
-val prems = goalw MT.thy [hasty_env_def,hasty_def]
- " v hasty t ==> \
-\ ! x e ve. \
-\ v=v_clos(<|x,e,ve|>) --> (? te.te |- fn x => e ===> t & ve hastyenv te)";
-by (cut_facts_tac prems 1);
-by (rtac hasty_rel_elim 1);
-by (ALLGOALS (fast_tac (v_ext_cs HOL_cs)));
-qed "hasty_elim_clos_lem";
-
-val prems = goal MT.thy
- "v_clos(<|ev,e,ve|>) hasty t ==> ? te.te |- fn ev => e ===> t & ve hastyenv te ";
-by (cut_facts_tac (prems RL [hasty_elim_clos_lem]) 1);
-by (fast_tac HOL_cs 1);
-qed "hasty_elim_clos";
-
-(* ############################################################ *)
-(* The pointwise extension of hasty to environments *)
-(* ############################################################ *)
-
-goal MT.thy
- "!!ve. [| ve hastyenv te; v hasty t |] ==> \
-\ ve + {ev |-> v} hastyenv te + {ev |=> t}";
-by (rewtac hasty_env_def);
-by (asm_full_simp_tac (HOL_ss addsimps [ve_dom_owr, te_dom_owr]) 1);
-by (safe_tac HOL_cs);
-by (excluded_middle_tac "ev=x" 1);
-by (asm_full_simp_tac (HOL_ss addsimps [ve_app_owr2, te_app_owr2]) 1);
-by (fast_tac set_cs 1);
-by (asm_simp_tac (HOL_ss addsimps [ve_app_owr1, te_app_owr1]) 1);
-qed "hasty_env1";
-
-(* ############################################################ *)
-(* The Consistency theorem *)
-(* ############################################################ *)
-
-val prems = goal MT.thy
- "[| ve hastyenv te ; te |- e_const(c) ===> t |] ==> v_const(c) hasty t";
-by (cut_facts_tac prems 1);
-by (dtac elab_const_elim 1);
-by (etac hasty_const 1);
-qed "consistency_const";
-
-val prems = goalw MT.thy [hasty_env_def]
- " [| ev : ve_dom(ve); ve hastyenv te ; te |- e_var(ev) ===> t |] ==> \
-\ ve_app(ve,ev) hasty t";
-by (cut_facts_tac prems 1);
-by (dtac elab_var_elim 1);
-by (fast_tac HOL_cs 1);
-qed "consistency_var";
-
-val prems = goal MT.thy
- " [| ve hastyenv te ; te |- fn ev => e ===> t |] ==> \
-\ v_clos(<| ev, e, ve |>) hasty t";
-by (cut_facts_tac prems 1);
-by (rtac hasty_clos 1);
-by (fast_tac prop_cs 1);
-qed "consistency_fn";
-
-val prems = goalw MT.thy [hasty_env_def,hasty_def]
- " [| cl = <| ev1, e, ve + { ev2 |-> v_clos(cl) } |>; \
-\ ve hastyenv te ; \
-\ te |- fix ev2 ev1 = e ===> t \
-\ |] ==> \
-\ v_clos(cl) hasty t";
-by (cut_facts_tac prems 1);
-by (dtac elab_fix_elim 1);
-by (safe_tac HOL_cs);
-(*Do a single unfolding of cl*)
-by ((forward_tac [ssubst] 1) THEN (assume_tac 2));
-by (rtac hasty_rel_clos_coind 1);
-by (etac elab_fn 1);
-by (asm_simp_tac (HOL_ss addsimps [ve_dom_owr, te_dom_owr]) 1);
-
-by (asm_simp_tac (HOL_ss addsimps [ve_dom_owr]) 1);
-by (safe_tac HOL_cs);
-by (excluded_middle_tac "ev2=ev1a" 1);
-by (asm_full_simp_tac (HOL_ss addsimps [ve_app_owr2, te_app_owr2]) 1);
-by (fast_tac set_cs 1);
-
-by (asm_simp_tac (HOL_ss addsimps [ve_app_owr1, te_app_owr1]) 1);
-by (hyp_subst_tac 1);
-by (etac subst 1);
-by (fast_tac set_cs 1);
-qed "consistency_fix";
-
-val prems = goal MT.thy
- " [| ! t te. ve hastyenv te --> te |- e1 ===> t --> v_const(c1) hasty t; \
-\ ! t te. ve hastyenv te --> te |- e2 ===> t --> v_const(c2) hasty t; \
-\ ve hastyenv te ; te |- e1 @ e2 ===> t \
-\ |] ==> \
-\ v_const(c_app(c1,c2)) hasty t";
-by (cut_facts_tac prems 1);
-by (dtac elab_app_elim 1);
-by (safe_tac HOL_cs);
-by (rtac hasty_const 1);
-by (rtac isof_app 1);
-by (rtac hasty_elim_const 1);
-by (fast_tac HOL_cs 1);
-by (rtac hasty_elim_const 1);
-by (fast_tac HOL_cs 1);
-qed "consistency_app1";
-
-val prems = goal MT.thy
- " [| ! t te. \
-\ ve hastyenv te --> \
-\ te |- e1 ===> t --> v_clos(<|evm, em, vem|>) hasty t; \
-\ ! t te. ve hastyenv te --> te |- e2 ===> t --> v2 hasty t; \
-\ ! t te. \
-\ vem + { evm |-> v2 } hastyenv te --> te |- em ===> t --> v hasty t; \
-\ ve hastyenv te ; \
-\ te |- e1 @ e2 ===> t \
-\ |] ==> \
-\ v hasty t";
-by (cut_facts_tac prems 1);
-by (dtac elab_app_elim 1);
-by (safe_tac HOL_cs);
-by ((etac allE 1) THEN (etac allE 1) THEN (etac impE 1));
-by (assume_tac 1);
-by (etac impE 1);
-by (assume_tac 1);
-by ((etac allE 1) THEN (etac allE 1) THEN (etac impE 1));
-by (assume_tac 1);
-by (etac impE 1);
-by (assume_tac 1);
-by (dtac hasty_elim_clos 1);
-by (safe_tac HOL_cs);
-by (dtac elab_fn_elim 1);
-by (safe_tac HOL_cs);
-by (dtac t_fun_inj 1);
-by (safe_tac prop_cs);
-by ((dtac hasty_env1 1) THEN (assume_tac 1) THEN (fast_tac HOL_cs 1));
-qed "consistency_app2";
-
-val [major] = goal MT.thy
- "ve |- e ---> v ==> \
-\ (! t te. ve hastyenv te --> te |- e ===> t --> v hasty t)";
-
-(* Proof by induction on the structure of evaluations *)
-
-by (rtac (major RS eval_ind) 1);
-by (safe_tac HOL_cs);
-by (DEPTH_SOLVE
- (ares_tac [consistency_const, consistency_var, consistency_fn,
- consistency_fix, consistency_app1, consistency_app2] 1));
-qed "consistency";
-
-(* ############################################################ *)
-(* The Basic Consistency theorem *)
-(* ############################################################ *)
-
-val prems = goalw MT.thy [isof_env_def,hasty_env_def]
- "ve isofenv te ==> ve hastyenv te";
-by (cut_facts_tac prems 1);
-by (safe_tac HOL_cs);
-by (etac allE 1);
-by (etac impE 1);
-by (assume_tac 1);
-by (etac exE 1);
-by (etac conjE 1);
-by (dtac hasty_const 1);
-by (asm_simp_tac HOL_ss 1);
-qed "basic_consistency_lem";
-
-val prems = goal MT.thy
- "[| ve isofenv te; ve |- e ---> v_const(c); te |- e ===> t |] ==> c isof t";
-by (cut_facts_tac prems 1);
-by (rtac hasty_elim_const 1);
-by (dtac consistency 1);
-by (fast_tac (HOL_cs addSIs [basic_consistency_lem]) 1);
-qed "basic_consistency";
-
-
--- a/ex/MT.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,278 +0,0 @@
-(* Title: HOL/ex/mt.thy
- ID: $Id$
- Author: Jacob Frost, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Based upon the article
- Robin Milner and Mads Tofte,
- Co-induction in Relational Semantics,
- Theoretical Computer Science 87 (1991), pages 209-220.
-
-Written up as
- Jacob Frost, A Case Study of Co_induction in Isabelle/HOL
- Report 308, Computer Lab, University of Cambridge (1993).
-*)
-
-MT = Gfp + Sum +
-
-types
- Const
-
- ExVar
- Ex
-
- TyConst
- Ty
-
- Clos
- Val
-
- ValEnv
- TyEnv
-
-arities
- Const :: term
-
- ExVar :: term
- Ex :: term
-
- TyConst :: term
- Ty :: term
-
- Clos :: term
- Val :: term
-
- ValEnv :: term
- TyEnv :: term
-
-consts
- c_app :: "[Const, Const] => Const"
-
- e_const :: "Const => Ex"
- e_var :: "ExVar => Ex"
- e_fn :: "[ExVar, Ex] => Ex" ("fn _ => _" [0,51] 1000)
- e_fix :: "[ExVar, ExVar, Ex] => Ex" ("fix _ ( _ ) = _" [0,51,51] 1000)
- e_app :: "[Ex, Ex] => Ex" ("_ @ _" [51,51] 1000)
- e_const_fst :: "Ex => Const"
-
- t_const :: "TyConst => Ty"
- t_fun :: "[Ty, Ty] => Ty" ("_ -> _" [51,51] 1000)
-
- v_const :: "Const => Val"
- v_clos :: "Clos => Val"
-
- ve_emp :: "ValEnv"
- ve_owr :: "[ValEnv, ExVar, Val] => ValEnv" ("_ + { _ |-> _ }" [36,0,0] 50)
- ve_dom :: "ValEnv => ExVar set"
- ve_app :: "[ValEnv, ExVar] => Val"
-
- clos_mk :: "[ExVar, Ex, ValEnv] => Clos" ("<| _ , _ , _ |>" [0,0,0] 1000)
-
- te_emp :: "TyEnv"
- te_owr :: "[TyEnv, ExVar, Ty] => TyEnv" ("_ + { _ |=> _ }" [36,0,0] 50)
- te_app :: "[TyEnv, ExVar] => Ty"
- te_dom :: "TyEnv => ExVar set"
-
- eval_fun :: "((ValEnv * Ex) * Val) set => ((ValEnv * Ex) * Val) set"
- eval_rel :: "((ValEnv * Ex) * Val) set"
- eval :: "[ValEnv, Ex, Val] => bool" ("_ |- _ ---> _" [36,0,36] 50)
-
- elab_fun :: "((TyEnv * Ex) * Ty) set => ((TyEnv * Ex) * Ty) set"
- elab_rel :: "((TyEnv * Ex) * Ty) set"
- elab :: "[TyEnv, Ex, Ty] => bool" ("_ |- _ ===> _" [36,0,36] 50)
-
- isof :: "[Const, Ty] => bool" ("_ isof _" [36,36] 50)
- isof_env :: "[ValEnv,TyEnv] => bool" ("_ isofenv _")
-
- hasty_fun :: "(Val * Ty) set => (Val * Ty) set"
- hasty_rel :: "(Val * Ty) set"
- hasty :: "[Val, Ty] => bool" ("_ hasty _" [36,36] 50)
- hasty_env :: "[ValEnv,TyEnv] => bool" ("_ hastyenv _ " [36,36] 35)
-
-rules
-
-(*
- Expression constructors must be injective, distinct and it must be possible
- to do induction over expressions.
-*)
-
-(* All the constructors are injective *)
-
- e_const_inj "e_const(c1) = e_const(c2) ==> c1 = c2"
- e_var_inj "e_var(ev1) = e_var(ev2) ==> ev1 = ev2"
- e_fn_inj "fn ev1 => e1 = fn ev2 => e2 ==> ev1 = ev2 & e1 = e2"
- e_fix_inj
- " fix ev11e(v12) = e1 = fix ev21(ev22) = e2 ==>
- ev11 = ev21 & ev12 = ev22 & e1 = e2
- "
- e_app_inj "e11 @ e12 = e21 @ e22 ==> e11 = e21 & e12 = e22"
-
-(* All constructors are distinct *)
-
- e_disj_const_var "~e_const(c) = e_var(ev)"
- e_disj_const_fn "~e_const(c) = fn ev => e"
- e_disj_const_fix "~e_const(c) = fix ev1(ev2) = e"
- e_disj_const_app "~e_const(c) = e1 @ e2"
- e_disj_var_fn "~e_var(ev1) = fn ev2 => e"
- e_disj_var_fix "~e_var(ev) = fix ev1(ev2) = e"
- e_disj_var_app "~e_var(ev) = e1 @ e2"
- e_disj_fn_fix "~fn ev1 => e1 = fix ev21(ev22) = e2"
- e_disj_fn_app "~fn ev1 => e1 = e21 @ e22"
- e_disj_fix_app "~fix ev11(ev12) = e1 = e21 @ e22"
-
-(* Strong elimination, induction on expressions *)
-
- e_ind
- " [| !!ev. P(e_var(ev));
- !!c. P(e_const(c));
- !!ev e. P(e) ==> P(fn ev => e);
- !!ev1 ev2 e. P(e) ==> P(fix ev1(ev2) = e);
- !!e1 e2. P(e1) ==> P(e2) ==> P(e1 @ e2)
- |] ==>
- P(e)
- "
-
-(* Types - same scheme as for expressions *)
-
-(* All constructors are injective *)
-
- t_const_inj "t_const(c1) = t_const(c2) ==> c1 = c2"
- t_fun_inj "t11 -> t12 = t21 -> t22 ==> t11 = t21 & t12 = t22"
-
-(* All constructors are distinct, not needed so far ... *)
-
-(* Strong elimination, induction on types *)
-
- t_ind
- "[| !!p. P(t_const(p)); !!t1 t2. P(t1) ==> P(t2) ==> P(t_fun(t1,t2)) |]
- ==> P(t)"
-
-
-(* Values - same scheme again *)
-
-(* All constructors are injective *)
-
- v_const_inj "v_const(c1) = v_const(c2) ==> c1 = c2"
- v_clos_inj
- " v_clos(<|ev1,e1,ve1|>) = v_clos(<|ev2,e2,ve2|>) ==>
- ev1 = ev2 & e1 = e2 & ve1 = ve2"
-
-(* All constructors are distinct *)
-
- v_disj_const_clos "~v_const(c) = v_clos(cl)"
-
-(* Strong elimination, induction on values, not needed yet ... *)
-
-
-(*
- Value environments bind variables to values. Only the following trivial
- properties are needed.
-*)
-
- ve_dom_owr "ve_dom(ve + {ev |-> v}) = ve_dom(ve) Un {ev}"
-
- ve_app_owr1 "ve_app(ve + {ev |-> v},ev)=v"
- ve_app_owr2 "~ev1=ev2 ==> ve_app(ve+{ev1 |-> v},ev2)=ve_app(ve,ev2)"
-
-
-(* Type Environments bind variables to types. The following trivial
-properties are needed. *)
-
- te_dom_owr "te_dom(te + {ev |=> t}) = te_dom(te) Un {ev}"
-
- te_app_owr1 "te_app(te + {ev |=> t},ev)=t"
- te_app_owr2 "~ev1=ev2 ==> te_app(te+{ev1 |=> t},ev2)=te_app(te,ev2)"
-
-
-(* The dynamic semantics is defined inductively by a set of inference
-rules. These inference rules allows one to draw conclusions of the form ve
-|- e ---> v, read the expression e evaluates to the value v in the value
-environment ve. Therefore the relation _ |- _ ---> _ is defined in Isabelle
-as the least fixpoint of the functor eval_fun below. From this definition
-introduction rules and a strong elimination (induction) rule can be
-derived.
-*)
-
- eval_fun_def
- " eval_fun(s) ==
- { pp.
- (? ve c. pp=<<ve,e_const(c)>,v_const(c)>) |
- (? ve x. pp=<<ve,e_var(x)>,ve_app(ve,x)> & x:ve_dom(ve)) |
- (? ve e x. pp=<<ve,fn x => e>,v_clos(<|x,e,ve|>)>)|
- ( ? ve e x f cl.
- pp=<<ve,fix f(x) = e>,v_clos(cl)> &
- cl=<|x, e, ve+{f |-> v_clos(cl)} |>
- ) |
- ( ? ve e1 e2 c1 c2.
- pp=<<ve,e1 @ e2>,v_const(c_app(c1,c2))> &
- <<ve,e1>,v_const(c1)>:s & <<ve,e2>,v_const(c2)>:s
- ) |
- ( ? ve vem e1 e2 em xm v v2.
- pp=<<ve,e1 @ e2>,v> &
- <<ve,e1>,v_clos(<|xm,em,vem|>)>:s &
- <<ve,e2>,v2>:s &
- <<vem+{xm |-> v2},em>,v>:s
- )
- }"
-
- eval_rel_def "eval_rel == lfp(eval_fun)"
- eval_def "ve |- e ---> v == <<ve,e>,v>:eval_rel"
-
-(* The static semantics is defined in the same way as the dynamic
-semantics. The relation te |- e ===> t express the expression e has the
-type t in the type environment te.
-*)
-
- elab_fun_def
- "elab_fun(s) ==
- { pp.
- (? te c t. pp=<<te,e_const(c)>,t> & c isof t) |
- (? te x. pp=<<te,e_var(x)>,te_app(te,x)> & x:te_dom(te)) |
- (? te x e t1 t2. pp=<<te,fn x => e>,t1->t2> & <<te+{x |=> t1},e>,t2>:s) |
- (? te f x e t1 t2.
- pp=<<te,fix f(x)=e>,t1->t2> & <<te+{f |=> t1->t2}+{x |=> t1},e>,t2>:s
- ) |
- (? te e1 e2 t1 t2.
- pp=<<te,e1 @ e2>,t2> & <<te,e1>,t1->t2>:s & <<te,e2>,t1>:s
- )
- }"
-
- elab_rel_def "elab_rel == lfp(elab_fun)"
- elab_def "te |- e ===> t == <<te,e>,t>:elab_rel"
-
-(* The original correspondence relation *)
-
- isof_env_def
- " ve isofenv te ==
- ve_dom(ve) = te_dom(te) &
- ( ! x.
- x:ve_dom(ve) -->
- (? c.ve_app(ve,x) = v_const(c) & c isof te_app(te,x))
- )
- "
-
- isof_app "[| c1 isof t1->t2; c2 isof t1 |] ==> c_app(c1,c2) isof t2"
-
-(* The extented correspondence relation *)
-
- hasty_fun_def
- " hasty_fun(r) ==
- { p.
- ( ? c t. p = <v_const(c),t> & c isof t) |
- ( ? ev e ve t te.
- p = <v_clos(<|ev,e,ve|>),t> &
- te |- fn ev => e ===> t &
- ve_dom(ve) = te_dom(te) &
- (! ev1.ev1:ve_dom(ve) --> <ve_app(ve,ev1),te_app(te,ev1)> : r)
- )
- }
- "
-
- hasty_rel_def "hasty_rel == gfp(hasty_fun)"
- hasty_def "v hasty t == <v,t> : hasty_rel"
- hasty_env_def
- " ve hastyenv te ==
- ve_dom(ve) = te_dom(te) &
- (! x. x: ve_dom(ve) --> ve_app(ve,x) hasty te_app(te,x))"
-
-end
--- a/ex/NatSum.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,43 +0,0 @@
-(* Title: HOL/ex/natsum.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Summing natural numbers, squares and cubes. Could be continued...
-*)
-
-val natsum_ss = arith_ss addsimps
- ([NatSum.sum_0,NatSum.sum_Suc] @ add_ac);
-
-(*The sum of the first n positive integers equals n(n+1)/2.*)
-goal NatSum.thy "Suc(Suc(0))*sum(%i.i,Suc(n)) = n*Suc(n)";
-by (simp_tac natsum_ss 1);
-by (nat_ind_tac "n" 1);
-by (simp_tac natsum_ss 1);
-by (asm_simp_tac natsum_ss 1);
-qed "sum_of_naturals";
-
-goal NatSum.thy
- "Suc(Suc(Suc(Suc(Suc(Suc(0))))))*sum(%i.i*i,Suc(n)) = \
-\ n*Suc(n)*Suc(Suc(Suc(0))*n)";
-by (simp_tac natsum_ss 1);
-by (nat_ind_tac "n" 1);
-by (simp_tac natsum_ss 1);
-by (asm_simp_tac natsum_ss 1);
-qed "sum_of_squares";
-
-goal NatSum.thy
- "Suc(Suc(Suc(Suc(0))))*sum(%i.i*i*i,Suc(n)) = n*n*Suc(n)*Suc(n)";
-by (simp_tac natsum_ss 1);
-by (nat_ind_tac "n" 1);
-by (simp_tac natsum_ss 1);
-by (asm_simp_tac natsum_ss 1);
-qed "sum_of_cubes";
-
-(*The sum of the first n odd numbers equals n squared.*)
-goal NatSum.thy "sum(%i.Suc(i+i), n) = n*n";
-by (nat_ind_tac "n" 1);
-by (simp_tac natsum_ss 1);
-by (asm_simp_tac natsum_ss 1);
-qed "sum_of_odds";
-
--- a/ex/NatSum.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,13 +0,0 @@
-(* Title: HOL/ex/natsum.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-A summation operator. sum(f,n+1) is the sum of all f(i), i=0...n.
-*)
-
-NatSum = Arith +
-consts sum :: "[nat=>nat, nat] => nat"
-rules sum_0 "sum(f,0) = 0"
- sum_Suc "sum(f,Suc(n)) = f(n) + sum(f,n)"
-end
--- a/ex/PropLog.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,234 +0,0 @@
-(* Title: HOL/ex/pl.ML
- ID: $Id$
- Author: Tobias Nipkow & Lawrence C Paulson
- Copyright 1994 TU Muenchen & University of Cambridge
-
-Soundness and completeness of propositional logic w.r.t. truth-tables.
-
-Prove: If H|=p then G|=p where G:Fin(H)
-*)
-
-open PropLog;
-
-(** Monotonicity **)
-goalw PropLog.thy thms.defs "!!G H. G<=H ==> thms(G) <= thms(H)";
-by (rtac lfp_mono 1);
-by (REPEAT (ares_tac basic_monos 1));
-qed "thms_mono";
-
-(*Rule is called I for Identity Combinator, not for Introduction*)
-goal PropLog.thy "H |- p->p";
-by(best_tac (HOL_cs addIs [thms.K,thms.S,thms.MP]) 1);
-qed "thms_I";
-
-(** Weakening, left and right **)
-
-(* "[| G<=H; G |- p |] ==> H |- p"
- This order of premises is convenient with RS
-*)
-bind_thm ("weaken_left", (thms_mono RS subsetD));
-
-(* H |- p ==> insert(a,H) |- p *)
-val weaken_left_insert = subset_insertI RS weaken_left;
-
-val weaken_left_Un1 = Un_upper1 RS weaken_left;
-val weaken_left_Un2 = Un_upper2 RS weaken_left;
-
-goal PropLog.thy "!!H. H |- q ==> H |- p->q";
-by(fast_tac (HOL_cs addIs [thms.K,thms.MP]) 1);
-qed "weaken_right";
-
-(*The deduction theorem*)
-goal PropLog.thy "!!H. insert(p,H) |- q ==> H |- p->q";
-by (etac thms.induct 1);
-by (fast_tac (set_cs addIs [thms_I, thms.H RS weaken_right]) 1);
-by (fast_tac (set_cs addIs [thms.K RS weaken_right]) 1);
-by (fast_tac (set_cs addIs [thms.S RS weaken_right]) 1);
-by (fast_tac (set_cs addIs [thms.DN RS weaken_right]) 1);
-by (fast_tac (set_cs addIs [thms.S RS thms.MP RS thms.MP]) 1);
-qed "deduction";
-
-
-(* "[| insert(p,H) |- q; H |- p |] ==> H |- q"
- The cut rule - not used
-*)
-val cut = deduction RS thms.MP;
-
-(* H |- false ==> H |- p *)
-val thms_falseE = weaken_right RS (thms.DN RS thms.MP);
-
-(* [| H |- p->false; H |- p; q: pl |] ==> H |- q *)
-bind_thm ("thms_notE", (thms.MP RS thms_falseE));
-
-(** The function eval **)
-
-val pl_ss = set_ss addsimps
- (PropLog.pl.simps @ [eval2_false, eval2_var, eval2_imp]
- @ [hyps_false, hyps_var, hyps_imp]);
-
-goalw PropLog.thy [eval_def] "tt[false] = False";
-by (simp_tac pl_ss 1);
-qed "eval_false";
-
-goalw PropLog.thy [eval_def] "tt[#v] = (v:tt)";
-by (simp_tac pl_ss 1);
-qed "eval_var";
-
-goalw PropLog.thy [eval_def] "tt[p->q] = (tt[p]-->tt[q])";
-by (simp_tac pl_ss 1);
-qed "eval_imp";
-
-val pl_ss = pl_ss addsimps [eval_false, eval_var, eval_imp];
-
-(*Soundness of the rules wrt truth-table semantics*)
-goalw PropLog.thy [sat_def] "!!H. H |- p ==> H |= p";
-by (etac thms.induct 1);
-by (fast_tac (set_cs addSDs [eval_imp RS iffD1 RS mp]) 5);
-by (ALLGOALS (asm_simp_tac pl_ss));
-qed "soundness";
-
-(*** Towards the completeness proof ***)
-
-goal PropLog.thy "!!H. H |- p->false ==> H |- p->q";
-by (rtac deduction 1);
-by (etac (weaken_left_insert RS thms_notE) 1);
-by (rtac thms.H 1);
-by (rtac insertI1 1);
-qed "false_imp";
-
-val [premp,premq] = goal PropLog.thy
- "[| H |- p; H |- q->false |] ==> H |- (p->q)->false";
-by (rtac deduction 1);
-by (rtac (premq RS weaken_left_insert RS thms.MP) 1);
-by (rtac (thms.H RS thms.MP) 1);
-by (rtac insertI1 1);
-by (rtac (premp RS weaken_left_insert) 1);
-qed "imp_false";
-
-(*This formulation is required for strong induction hypotheses*)
-goal PropLog.thy "hyps(p,tt) |- if(tt[p], p, p->false)";
-by (rtac (expand_if RS iffD2) 1);
-by(PropLog.pl.induct_tac "p" 1);
-by (ALLGOALS (simp_tac (pl_ss addsimps [thms_I, thms.H])));
-by (fast_tac (set_cs addIs [weaken_left_Un1, weaken_left_Un2,
- weaken_right, imp_false]
- addSEs [false_imp]) 1);
-qed "hyps_thms_if";
-
-(*Key lemma for completeness; yields a set of assumptions satisfying p*)
-val [sat] = goalw PropLog.thy [sat_def] "{} |= p ==> hyps(p,tt) |- p";
-by (rtac (sat RS spec RS mp RS if_P RS subst) 1 THEN
- rtac hyps_thms_if 2);
-by (fast_tac set_cs 1);
-qed "sat_thms_p";
-
-(*For proving certain theorems in our new propositional logic*)
-val thms_cs =
- set_cs addSIs [deduction] addIs [thms.H, thms.H RS thms.MP];
-
-(*The excluded middle in the form of an elimination rule*)
-goal PropLog.thy "H |- (p->q) -> ((p->false)->q) -> q";
-by (rtac (deduction RS deduction) 1);
-by (rtac (thms.DN RS thms.MP) 1);
-by (ALLGOALS (best_tac (thms_cs addSIs prems)));
-qed "thms_excluded_middle";
-
-(*Hard to prove directly because it requires cuts*)
-val prems = goal PropLog.thy
- "[| insert(p,H) |- q; insert(p->false,H) |- q |] ==> H |- q";
-by (rtac (thms_excluded_middle RS thms.MP RS thms.MP) 1);
-by (REPEAT (resolve_tac (prems@[deduction]) 1));
-qed "thms_excluded_middle_rule";
-
-(*** Completeness -- lemmas for reducing the set of assumptions ***)
-
-(*For the case hyps(p,t)-insert(#v,Y) |- p;
- we also have hyps(p,t)-{#v} <= hyps(p, t-{v}) *)
-goal PropLog.thy "hyps(p, t-{v}) <= insert(#v->false, hyps(p,t)-{#v})";
-by (PropLog.pl.induct_tac "p" 1);
-by (simp_tac pl_ss 1);
-by (simp_tac (pl_ss setloop (split_tac [expand_if])) 1);
-by (simp_tac pl_ss 1);
-by (fast_tac set_cs 1);
-qed "hyps_Diff";
-
-(*For the case hyps(p,t)-insert(#v -> false,Y) |- p;
- we also have hyps(p,t)-{#v->false} <= hyps(p, insert(v,t)) *)
-goal PropLog.thy "hyps(p, insert(v,t)) <= insert(#v, hyps(p,t)-{#v->false})";
-by (PropLog.pl.induct_tac "p" 1);
-by (simp_tac pl_ss 1);
-by (simp_tac (pl_ss setloop (split_tac [expand_if])) 1);
-by (simp_tac pl_ss 1);
-by (fast_tac set_cs 1);
-qed "hyps_insert";
-
-(** Two lemmas for use with weaken_left **)
-
-goal Set.thy "B-C <= insert(a, B-insert(a,C))";
-by (fast_tac set_cs 1);
-qed "insert_Diff_same";
-
-goal Set.thy "insert(a, B-{c}) - D <= insert(a, B-insert(c,D))";
-by (fast_tac set_cs 1);
-qed "insert_Diff_subset2";
-
-(*The set hyps(p,t) is finite, and elements have the form #v or #v->false;
- could probably prove the stronger hyps(p,t) : Fin(hyps(p,{}) Un hyps(p,nat))*)
-goal PropLog.thy "hyps(p,t) : Fin(UN v:{x.True}. {#v, #v->false})";
-by (PropLog.pl.induct_tac "p" 1);
-by (ALLGOALS (simp_tac (pl_ss setloop (split_tac [expand_if])) THEN'
- fast_tac (set_cs addSIs Fin.intrs@[Fin_UnI])));
-qed "hyps_finite";
-
-val Diff_weaken_left = subset_refl RSN (2, Diff_mono) RS weaken_left;
-
-(*Induction on the finite set of assumptions hyps(p,t0).
- We may repeatedly subtract assumptions until none are left!*)
-val [sat] = goal PropLog.thy
- "{} |= p ==> !t. hyps(p,t) - hyps(p,t0) |- p";
-by (rtac (hyps_finite RS Fin_induct) 1);
-by (simp_tac (pl_ss addsimps [sat RS sat_thms_p]) 1);
-by (safe_tac set_cs);
-(*Case hyps(p,t)-insert(#v,Y) |- p *)
-by (rtac thms_excluded_middle_rule 1);
-by (rtac (insert_Diff_same RS weaken_left) 1);
-by (etac spec 1);
-by (rtac (insert_Diff_subset2 RS weaken_left) 1);
-by (rtac (hyps_Diff RS Diff_weaken_left) 1);
-by (etac spec 1);
-(*Case hyps(p,t)-insert(#v -> false,Y) |- p *)
-by (rtac thms_excluded_middle_rule 1);
-by (rtac (insert_Diff_same RS weaken_left) 2);
-by (etac spec 2);
-by (rtac (insert_Diff_subset2 RS weaken_left) 1);
-by (rtac (hyps_insert RS Diff_weaken_left) 1);
-by (etac spec 1);
-qed "completeness_0_lemma";
-
-(*The base case for completeness*)
-val [sat] = goal PropLog.thy "{} |= p ==> {} |- p";
-by (rtac (Diff_cancel RS subst) 1);
-by (rtac (sat RS (completeness_0_lemma RS spec)) 1);
-qed "completeness_0";
-
-(*A semantic analogue of the Deduction Theorem*)
-val [sat] = goalw PropLog.thy [sat_def] "insert(p,H) |= q ==> H |= p->q";
-by (simp_tac pl_ss 1);
-by (cfast_tac [sat] 1);
-qed "sat_imp";
-
-val [finite] = goal PropLog.thy "H: Fin({p.True}) ==> !p. H |= p --> H |- p";
-by (rtac (finite RS Fin_induct) 1);
-by (safe_tac (set_cs addSIs [completeness_0]));
-by (rtac (weaken_left_insert RS thms.MP) 1);
-by (fast_tac (set_cs addSIs [sat_imp]) 1);
-by (fast_tac thms_cs 1);
-qed "completeness_lemma";
-
-val completeness = completeness_lemma RS spec RS mp;
-
-val [finite] = goal PropLog.thy "H: Fin({p.True}) ==> (H |- p) = (H |= p)";
-by (fast_tac (set_cs addSEs [soundness, finite RS completeness]) 1);
-qed "thms_iff";
-
-writeln"Reached end of file.";
--- a/ex/PropLog.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,45 +0,0 @@
-(* Title: HOL/ex/PropLog.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Inductive definition of propositional logic.
-*)
-
-PropLog = Finite +
-datatype
- 'a pl = false | var ('a) ("#_" [1000]) | "->" ('a pl,'a pl) (infixr 90)
-consts
- thms :: "'a pl set => 'a pl set"
- "|-" :: "['a pl set, 'a pl] => bool" (infixl 50)
- "|=" :: "['a pl set, 'a pl] => bool" (infixl 50)
- eval2 :: "['a pl, 'a set] => bool"
- eval :: "['a set, 'a pl] => bool" ("_[_]" [100,0] 100)
- hyps :: "['a pl, 'a set] => 'a pl set"
-
-translations
- "H |- p" == "p : thms(H)"
-
-inductive "thms(H)"
- intrs
- H "p:H ==> H |- p"
- K "H |- p->q->p"
- S "H |- (p->q->r) -> (p->q) -> p->r"
- DN "H |- ((p->false) -> false) -> p"
- MP "[| H |- p->q; H |- p |] ==> H |- q"
-
-defs
- sat_def "H |= p == (!tt. (!q:H. tt[q]) --> tt[p])"
- eval_def "tt[p] == eval2(p,tt)"
-
-primrec eval2 pl
- eval2_false "eval2(false) = (%x.False)"
- eval2_var "eval2(#v) = (%tt.v:tt)"
- eval2_imp "eval2(p->q) = (%tt.eval2(p,tt)-->eval2(q,tt))"
-
-primrec hyps pl
- hyps_false "hyps(false) = (%tt.{})"
- hyps_var "hyps(#v) = (%tt.{if(v:tt, #v, #v->false)})"
- hyps_imp "hyps(p->q) = (%tt.hyps(p,tt) Un hyps(q,tt))"
-
-end
--- a/ex/Puzzle.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,58 +0,0 @@
-(* Title: HOL/ex/puzzle.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1993 TU Muenchen
-
-For puzzle.thy. A question from "Bundeswettbewerb Mathematik"
-
-Proof due to Herbert Ehler
-*)
-
-(*specialized form of induction needed below*)
-val prems = goal Nat.thy "[| P(0); !!n. P(Suc(n)) |] ==> !n.P(n)";
-by (EVERY1 [rtac (nat_induct RS allI), resolve_tac prems, resolve_tac prems]);
-qed "nat_exh";
-
-goal Puzzle.thy "! n. k=f(n) --> n <= f(n)";
-by (res_inst_tac [("n","k")] less_induct 1);
-by (rtac nat_exh 1);
-by (simp_tac nat_ss 1);
-by (rtac impI 1);
-by (rtac classical 1);
-by (dtac not_leE 1);
-by (subgoal_tac "f(na) <= f(f(na))" 1);
-by (best_tac (HOL_cs addIs [lessD,Puzzle.f_ax,le_less_trans,le_trans]) 1);
-by (fast_tac (HOL_cs addIs [Puzzle.f_ax]) 1);
-bind_thm("lemma", result() RS spec RS mp);
-
-goal Puzzle.thy "n <= f(n)";
-by (fast_tac (HOL_cs addIs [lemma]) 1);
-qed "lemma1";
-
-goal Puzzle.thy "f(n) < f(Suc(n))";
-by (fast_tac (HOL_cs addIs [Puzzle.f_ax,le_less_trans,lemma1]) 1);
-qed "lemma2";
-
-val prems = goal Puzzle.thy "(!!n.f(n) <= f(Suc(n))) ==> m<n --> f(m) <= f(n)";
-by (res_inst_tac[("n","n")]nat_induct 1);
-by (simp_tac nat_ss 1);
-by (simp_tac nat_ss 1);
-by (fast_tac (HOL_cs addIs (le_trans::prems)) 1);
-bind_thm("mono_lemma1", result() RS mp);
-
-val [p1,p2] = goal Puzzle.thy
- "[| !! n. f(n)<=f(Suc(n)); m<=n |] ==> f(m) <= f(n)";
-by (rtac (p2 RS le_imp_less_or_eq RS disjE) 1);
-by (etac (p1 RS mono_lemma1) 1);
-by (fast_tac (HOL_cs addIs [le_refl]) 1);
-qed "mono_lemma";
-
-val prems = goal Puzzle.thy "m <= n ==> f(m) <= f(n)";
-by (fast_tac (HOL_cs addIs ([mono_lemma,less_imp_le,lemma2]@prems)) 1);
-qed "f_mono";
-
-goal Puzzle.thy "f(n) = n";
-by (rtac le_anti_sym 1);
-by (rtac lemma1 2);
-by (fast_tac (HOL_cs addIs [Puzzle.f_ax,leI] addDs [leD,f_mono,lessD]) 1);
-result();
--- a/ex/Puzzle.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,12 +0,0 @@
-(* Title: HOL/ex/puzzle.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1993 TU Muenchen
-
-An question from "Bundeswettbewerb Mathematik"
-*)
-
-Puzzle = Nat +
-consts f :: "nat => nat"
-rules f_ax "f(f(n)) < f(Suc(n))"
-end
--- a/ex/Qsort.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,84 +0,0 @@
-(* Title: HOL/ex/qsort.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Two verifications of Quicksort
-*)
-
-val ss = sorting_ss addsimps ([Qsort.qsort_Nil,Qsort.qsort_Cons]@conj_comms);
-
-goal Qsort.thy "!x. mset(qsort(le,xs),x) = mset(xs,x)";
-by(res_inst_tac[("xs","xs"),("p","le")]Qsort.qsort_ind 1);
-by(ALLGOALS(asm_simp_tac (ss setloop (split_tac [expand_if]))));
-result();
-
-
-goal Qsort.thy "(Alls x:[x:xs.P(x)].Q(x)) = (Alls x:xs. P(x)-->Q(x))";
-by(list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (ss setloop (split_tac [expand_if]))));
-val ss = ss addsimps [result()];
-
-goal Qsort.thy
- "((Alls x:xs.P(x)) & (Alls x:xs.Q(x))) = (Alls x:xs. P(x)&Q(x))";
-by(list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac ss));
-val ss = ss addsimps [result()];
-
-goal HOL.thy "((~P --> Q) & (P --> Q)) = Q";
-by(fast_tac HOL_cs 1);
-qed "lemma";
-
-goal Qsort.thy "(Alls x:qsort(le,xs).P(x)) = (Alls x:xs.P(x))";
-by(res_inst_tac[("xs","xs"),("p","le")]Qsort.qsort_ind 1);
-by(ALLGOALS(asm_simp_tac (ss addsimps [lemma])));
-val ss = ss addsimps [result()];
-
-goal Qsort.thy
- "sorted(le,xs@ys) = (sorted(le,xs) & sorted(le,ys) & \
-\ (Alls x:xs. Alls y:ys. le(x,y)))";
-by(list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac ss));
-val ss = ss addsimps [result()];
-
-goal Qsort.thy
- "!!le. [| total(le); transf(le) |] ==> sorted(le,qsort(le,xs))";
-by(res_inst_tac[("xs","xs"),("p","le")]Qsort.qsort_ind 1);
-by(ALLGOALS(asm_full_simp_tac (ss addsimps [list_all_mem_conv]) ));
-by(rewrite_goals_tac [Sorting.total_def,Sorting.transf_def]);
-by(fast_tac HOL_cs 1);
-result();
-
-
-(* A verification based on predicate calculus rather than combinators *)
-
-val sorted_Cons =
- rewrite_rule [list_all_mem_conv RS eq_reflection] Sorting.sorted_Cons;
-
-val ss = list_ss addsimps
- [Sorting.sorted_Nil,sorted_Cons,
- Qsort.qsort_Nil,Qsort.qsort_Cons];
-
-
-goal Qsort.thy "x mem qsort(le,xs) = x mem xs";
-by(res_inst_tac[("xs","xs"),("p","le")]Qsort.qsort_ind 1);
-by(ALLGOALS(asm_simp_tac (ss setloop (split_tac [expand_if]))));
-by(fast_tac HOL_cs 1);
-val ss = ss addsimps [result()];
-
-goal Qsort.thy
- "sorted(le,xs@ys) = (sorted(le,xs) & sorted(le,ys) & \
-\ (!x. x mem xs --> (!y. y mem ys --> le(x,y))))";
-by(list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (ss setloop (split_tac [expand_if]))));
-by(fast_tac HOL_cs 1);
-val ss = ss addsimps [result()];
-
-goal Qsort.thy
- "!!xs. [| total(le); transf(le) |] ==> sorted(le,qsort(le,xs))";
-by(res_inst_tac[("xs","xs"),("p","le")]Qsort.qsort_ind 1);
-by(simp_tac ss 1);
-by(asm_full_simp_tac (ss setloop (split_tac [expand_if])) 1);
-by(rewrite_goals_tac [Sorting.total_def,Sorting.transf_def]);
-by(fast_tac HOL_cs 1);
-result();
--- a/ex/Qsort.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,27 +0,0 @@
-(* Title: HOL/ex/qsort.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Quicksort
-*)
-
-Qsort = Sorting +
-consts
- qsort :: "[['a,'a] => bool, 'a list] => 'a list"
-
-rules
-
-qsort_Nil "qsort(le,[]) = []"
-qsort_Cons "qsort(le,x#xs) = qsort(le,[y:xs . ~le(x,y)]) @
- (x# qsort(le,[y:xs . le(x,y)]))"
-
-(* computational induction.
- The dependence of p on x but not xs is intentional.
-*)
-qsort_ind
- "[| P([]);
- !!x xs. [| P([y:xs . ~p(x,y)]); P([y:xs . p(x,y)]) |] ==>
- P(x#xs) |]
- ==> P(xs)"
-end
--- a/ex/ROOT.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,34 +0,0 @@
-(* Title: Old_HOL/ex/ROOT.ML
- ID: $Id$
- Author: Tobias Nipkow, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-Executes miscellaneous examples for Higher-Order Logic.
-*)
-
-HOL_build_completed; (*Cause examples to fail if HOL did*)
-
-writeln"Root file for HOL examples";
-proof_timing := true;
-loadpath := ["ex"];
-time_use "ex/cla.ML";
-time_use "ex/meson.ML";
-time_use "ex/mesontest.ML";
-time_use_thy "String";
-time_use_thy "InSort";
-time_use_thy "Qsort";
-time_use_thy "LexProd";
-time_use_thy "Puzzle";
-time_use_thy "NatSum";
-time_use "ex/set.ML";
-time_use_thy "SList";
-time_use_thy "LList";
-time_use_thy "Acc";
-time_use_thy "PropLog";
-time_use_thy "Term";
-time_use_thy "Simult";
-time_use_thy "MT";
-
-make_chart (); (*make HTML chart*)
-
-writeln "END: Root file for HOL examples";
--- a/ex/Rec.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,5 +0,0 @@
-open Rec;
-
-goalw thy [mono_def,Domf_def] "mono(Domf(F))";
-by (DEPTH_SOLVE (slow_step_tac set_cs 1));
-qed "mono_Domf";
--- a/ex/Rec.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-Rec = Fixedpt +
-consts
-fix :: "('a=>'a) => 'a"
-Dom :: "(('a=>'b) => ('a=>'b)) => 'a set"
-Domf :: "(('a=>'b) => ('a=>'b)) => 'a set => 'a set"
-rules
-Domf_def "Domf(F,D) == {y . !f g. (!x:D. f(x)=g(x)) --> F(f,y)=F(g,y)}"
-Dom_def "Dom(F) == lfp(Domf(F))"
-end
--- a/ex/SList.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,397 +0,0 @@
-(* Title: HOL/ex/SList.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Definition of type 'a list by a least fixed point
-*)
-
-open SList;
-
-val list_con_defs = [NIL_def, CONS_def];
-
-goal SList.thy "list(A) = {Numb(0)} <+> (A <*> list(A))";
-let val rew = rewrite_rule list_con_defs in
-by (fast_tac (univ_cs addSIs (equalityI :: map rew list.intrs)
- addEs [rew list.elim]) 1)
-end;
-qed "list_unfold";
-
-(*This justifies using list in other recursive type definitions*)
-goalw SList.thy list.defs "!!A B. A<=B ==> list(A) <= list(B)";
-by (rtac lfp_mono 1);
-by (REPEAT (ares_tac basic_monos 1));
-qed "list_mono";
-
-(*Type checking -- list creates well-founded sets*)
-goalw SList.thy (list_con_defs @ list.defs) "list(sexp) <= sexp";
-by (rtac lfp_lowerbound 1);
-by (fast_tac (univ_cs addIs sexp.intrs@[sexp_In0I,sexp_In1I]) 1);
-qed "list_sexp";
-
-(* A <= sexp ==> list(A) <= sexp *)
-bind_thm ("list_subset_sexp", ([list_mono, list_sexp] MRS subset_trans));
-
-(*Induction for the type 'a list *)
-val prems = goalw SList.thy [Nil_def,Cons_def]
- "[| P(Nil); \
-\ !!x xs. P(xs) ==> P(x # xs) |] ==> P(l)";
-by (rtac (Rep_list_inverse RS subst) 1); (*types force good instantiation*)
-by (rtac (Rep_list RS list.induct) 1);
-by (REPEAT (ares_tac prems 1
- ORELSE eresolve_tac [rangeE, ssubst, Abs_list_inverse RS subst] 1));
-qed "list_induct";
-
-(*Perform induction on xs. *)
-fun list_ind_tac a M =
- EVERY [res_inst_tac [("l",a)] list_induct M,
- rename_last_tac a ["1"] (M+1)];
-
-(*** Isomorphisms ***)
-
-goal SList.thy "inj(Rep_list)";
-by (rtac inj_inverseI 1);
-by (rtac Rep_list_inverse 1);
-qed "inj_Rep_list";
-
-goal SList.thy "inj_onto(Abs_list,list(range(Leaf)))";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_list_inverse 1);
-qed "inj_onto_Abs_list";
-
-(** Distinctness of constructors **)
-
-goalw SList.thy list_con_defs "CONS(M,N) ~= NIL";
-by (rtac In1_not_In0 1);
-qed "CONS_not_NIL";
-bind_thm ("NIL_not_CONS", (CONS_not_NIL RS not_sym));
-
-bind_thm ("CONS_neq_NIL", (CONS_not_NIL RS notE));
-val NIL_neq_CONS = sym RS CONS_neq_NIL;
-
-goalw SList.thy [Nil_def,Cons_def] "x # xs ~= Nil";
-by (rtac (CONS_not_NIL RS (inj_onto_Abs_list RS inj_onto_contraD)) 1);
-by (REPEAT (resolve_tac (list.intrs @ [rangeI, Rep_list]) 1));
-qed "Cons_not_Nil";
-
-bind_thm ("Nil_not_Cons", (Cons_not_Nil RS not_sym));
-
-bind_thm ("Cons_neq_Nil", (Cons_not_Nil RS notE));
-val Nil_neq_Cons = sym RS Cons_neq_Nil;
-
-(** Injectiveness of CONS and Cons **)
-
-goalw SList.thy [CONS_def] "(CONS(K,M)=CONS(L,N)) = (K=L & M=N)";
-by (fast_tac (HOL_cs addSEs [Scons_inject, make_elim In1_inject]) 1);
-qed "CONS_CONS_eq";
-
-bind_thm ("CONS_inject", (CONS_CONS_eq RS iffD1 RS conjE));
-
-(*For reasoning about abstract list constructors*)
-val list_cs = set_cs addIs [Rep_list] @ list.intrs
- addSEs [CONS_neq_NIL,NIL_neq_CONS,CONS_inject]
- addSDs [inj_onto_Abs_list RS inj_ontoD,
- inj_Rep_list RS injD, Leaf_inject];
-
-goalw SList.thy [Cons_def] "(x#xs=y#ys) = (x=y & xs=ys)";
-by (fast_tac list_cs 1);
-qed "Cons_Cons_eq";
-bind_thm ("Cons_inject", (Cons_Cons_eq RS iffD1 RS conjE));
-
-val [major] = goal SList.thy "CONS(M,N): list(A) ==> M: A & N: list(A)";
-by (rtac (major RS setup_induction) 1);
-by (etac list.induct 1);
-by (ALLGOALS (fast_tac list_cs));
-qed "CONS_D";
-
-val prems = goalw SList.thy [CONS_def,In1_def]
- "CONS(M,N): sexp ==> M: sexp & N: sexp";
-by (cut_facts_tac prems 1);
-by (fast_tac (set_cs addSDs [Scons_D]) 1);
-qed "sexp_CONS_D";
-
-
-(*Basic ss with constructors and their freeness*)
-val list_free_simps = [Cons_not_Nil, Nil_not_Cons, Cons_Cons_eq,
- CONS_not_NIL, NIL_not_CONS, CONS_CONS_eq]
- @ list.intrs;
-val list_free_ss = HOL_ss addsimps list_free_simps;
-
-goal SList.thy "!!N. N: list(A) ==> !M. N ~= CONS(M,N)";
-by (etac list.induct 1);
-by (ALLGOALS (asm_simp_tac list_free_ss));
-qed "not_CONS_self";
-
-goal SList.thy "!x. l ~= x#l";
-by (list_ind_tac "l" 1);
-by (ALLGOALS (asm_simp_tac list_free_ss));
-qed "not_Cons_self";
-
-
-goal SList.thy "(xs ~= []) = (? y ys. xs = y#ys)";
-by(list_ind_tac "xs" 1);
-by(simp_tac list_free_ss 1);
-by(asm_simp_tac list_free_ss 1);
-by(REPEAT(resolve_tac [exI,refl,conjI] 1));
-qed "neq_Nil_conv";
-
-(** Conversion rules for List_case: case analysis operator **)
-
-goalw SList.thy [List_case_def,NIL_def] "List_case(c, h, NIL) = c";
-by (rtac Case_In0 1);
-qed "List_case_NIL";
-
-goalw SList.thy [List_case_def,CONS_def] "List_case(c, h, CONS(M,N)) = h(M,N)";
-by (simp_tac (HOL_ss addsimps [Split,Case_In1]) 1);
-qed "List_case_CONS";
-
-(*** List_rec -- by wf recursion on pred_sexp ***)
-
-(* The trancl(pred_sexp) is essential because pred_sexp_CONS_I1,2 would not
- hold if pred_sexp^+ were changed to pred_sexp. *)
-
-val List_rec_unfold = [List_rec_def, wf_pred_sexp RS wf_trancl] MRS def_wfrec
- |> standard;
-
-(** pred_sexp lemmas **)
-
-goalw SList.thy [CONS_def,In1_def]
- "!!M. [| M: sexp; N: sexp |] ==> <M, CONS(M,N)> : pred_sexp^+";
-by (asm_simp_tac pred_sexp_ss 1);
-qed "pred_sexp_CONS_I1";
-
-goalw SList.thy [CONS_def,In1_def]
- "!!M. [| M: sexp; N: sexp |] ==> <N, CONS(M,N)> : pred_sexp^+";
-by (asm_simp_tac pred_sexp_ss 1);
-qed "pred_sexp_CONS_I2";
-
-val [prem] = goal SList.thy
- "<CONS(M1,M2), N> : pred_sexp^+ ==> \
-\ <M1,N> : pred_sexp^+ & <M2,N> : pred_sexp^+";
-by (rtac (prem RS (pred_sexp_subset_Sigma RS trancl_subset_Sigma RS
- subsetD RS SigmaE2)) 1);
-by (etac (sexp_CONS_D RS conjE) 1);
-by (REPEAT (ares_tac [conjI, pred_sexp_CONS_I1, pred_sexp_CONS_I2,
- prem RSN (2, trans_trancl RS transD)] 1));
-qed "pred_sexp_CONS_D";
-
-(** Conversion rules for List_rec **)
-
-goal SList.thy "List_rec(NIL,c,h) = c";
-by (rtac (List_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps [List_case_NIL]) 1);
-qed "List_rec_NIL";
-
-goal SList.thy "!!M. [| M: sexp; N: sexp |] ==> \
-\ List_rec(CONS(M,N), c, h) = h(M, N, List_rec(N,c,h))";
-by (rtac (List_rec_unfold RS trans) 1);
-by (asm_simp_tac
- (HOL_ss addsimps [List_case_CONS, list.CONS_I, pred_sexp_CONS_I2,
- cut_apply])1);
-qed "List_rec_CONS";
-
-(*** list_rec -- by List_rec ***)
-
-val Rep_list_in_sexp =
- [range_Leaf_subset_sexp RS list_subset_sexp, Rep_list] MRS subsetD;
-
-local
- val list_rec_simps = list_free_simps @
- [List_rec_NIL, List_rec_CONS,
- Abs_list_inverse, Rep_list_inverse,
- Rep_list, rangeI, inj_Leaf, Inv_f_f,
- sexp.LeafI, Rep_list_in_sexp]
-in
- val list_rec_Nil = prove_goalw SList.thy [list_rec_def, Nil_def]
- "list_rec(Nil,c,h) = c"
- (fn _=> [simp_tac (HOL_ss addsimps list_rec_simps) 1]);
-
- val list_rec_Cons = prove_goalw SList.thy [list_rec_def, Cons_def]
- "list_rec(a#l, c, h) = h(a, l, list_rec(l,c,h))"
- (fn _=> [simp_tac (HOL_ss addsimps list_rec_simps) 1]);
-end;
-
-val list_simps = [List_rec_NIL, List_rec_CONS,
- list_rec_Nil, list_rec_Cons];
-val list_ss = list_free_ss addsimps list_simps;
-
-
-(*Type checking. Useful?*)
-val major::A_subset_sexp::prems = goal SList.thy
- "[| M: list(A); \
-\ A<=sexp; \
-\ c: C(NIL); \
-\ !!x y r. [| x: A; y: list(A); r: C(y) |] ==> h(x,y,r): C(CONS(x,y)) \
-\ |] ==> List_rec(M,c,h) : C(M :: 'a item)";
-val sexp_ListA_I = A_subset_sexp RS list_subset_sexp RS subsetD;
-val sexp_A_I = A_subset_sexp RS subsetD;
-by (rtac (major RS list.induct) 1);
-by (ALLGOALS(asm_simp_tac (list_ss addsimps ([sexp_A_I,sexp_ListA_I]@prems))));
-qed "List_rec_type";
-
-(** Generalized map functionals **)
-
-goalw SList.thy [Rep_map_def] "Rep_map(f,Nil) = NIL";
-by (rtac list_rec_Nil 1);
-qed "Rep_map_Nil";
-
-goalw SList.thy [Rep_map_def]
- "Rep_map(f, x#xs) = CONS(f(x), Rep_map(f,xs))";
-by (rtac list_rec_Cons 1);
-qed "Rep_map_Cons";
-
-goalw SList.thy [Rep_map_def] "!!f. (!!x. f(x): A) ==> Rep_map(f,xs): list(A)";
-by (rtac list_induct 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "Rep_map_type";
-
-goalw SList.thy [Abs_map_def] "Abs_map(g,NIL) = Nil";
-by (rtac List_rec_NIL 1);
-qed "Abs_map_NIL";
-
-val prems = goalw SList.thy [Abs_map_def]
- "[| M: sexp; N: sexp |] ==> \
-\ Abs_map(g, CONS(M,N)) = g(M) # Abs_map(g,N)";
-by (REPEAT (resolve_tac (List_rec_CONS::prems) 1));
-qed "Abs_map_CONS";
-
-(*These 2 rules ease the use of primitive recursion. NOTE USE OF == *)
-val [rew] = goal SList.thy
- "[| !!xs. f(xs) == list_rec(xs,c,h) |] ==> f([]) = c";
-by (rewtac rew);
-by (rtac list_rec_Nil 1);
-qed "def_list_rec_Nil";
-
-val [rew] = goal SList.thy
- "[| !!xs. f(xs) == list_rec(xs,c,h) |] ==> f(x#xs) = h(x,xs,f(xs))";
-by (rewtac rew);
-by (rtac list_rec_Cons 1);
-qed "def_list_rec_Cons";
-
-fun list_recs def =
- [standard (def RS def_list_rec_Nil),
- standard (def RS def_list_rec_Cons)];
-
-(*** Unfolding the basic combinators ***)
-
-val [null_Nil,null_Cons] = list_recs null_def;
-val [_,hd_Cons] = list_recs hd_def;
-val [_,tl_Cons] = list_recs tl_def;
-val [ttl_Nil,ttl_Cons] = list_recs ttl_def;
-val [append_Nil,append_Cons] = list_recs append_def;
-val [mem_Nil, mem_Cons] = list_recs mem_def;
-val [map_Nil,map_Cons] = list_recs map_def;
-val [list_case_Nil,list_case_Cons] = list_recs list_case_def;
-val [filter_Nil,filter_Cons] = list_recs filter_def;
-val [list_all_Nil,list_all_Cons] = list_recs list_all_def;
-
-val list_ss = arith_ss addsimps
- [Cons_not_Nil, Nil_not_Cons, Cons_Cons_eq,
- list_rec_Nil, list_rec_Cons,
- null_Nil, null_Cons, hd_Cons, tl_Cons, ttl_Nil, ttl_Cons,
- mem_Nil, mem_Cons,
- list_case_Nil, list_case_Cons,
- append_Nil, append_Cons,
- map_Nil, map_Cons,
- list_all_Nil, list_all_Cons,
- filter_Nil, filter_Cons];
-
-
-(** @ - append **)
-
-goal SList.thy "(xs@ys)@zs = xs@(ys@zs)";
-by(list_ind_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "append_assoc";
-
-goal SList.thy "xs @ [] = xs";
-by(list_ind_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "append_Nil2";
-
-(** mem **)
-
-goal SList.thy "x mem (xs@ys) = (x mem xs | x mem ys)";
-by(list_ind_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (list_ss setloop (split_tac [expand_if]))));
-qed "mem_append";
-
-goal SList.thy "x mem [x:xs.P(x)] = (x mem xs & P(x))";
-by(list_ind_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (list_ss setloop (split_tac [expand_if]))));
-qed "mem_filter";
-
-(** list_all **)
-
-goal SList.thy "(Alls x:xs.True) = True";
-by(list_ind_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "list_all_True";
-
-goal SList.thy "list_all(p,xs@ys) = (list_all(p,xs) & list_all(p,ys))";
-by(list_ind_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-qed "list_all_conj";
-
-goal SList.thy "(Alls x:xs.P(x)) = (!x. x mem xs --> P(x))";
-by(list_ind_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (list_ss setloop (split_tac [expand_if]))));
-by(fast_tac HOL_cs 1);
-qed "list_all_mem_conv";
-
-
-(** The functional "map" **)
-
-val map_simps = [Abs_map_NIL, Abs_map_CONS,
- Rep_map_Nil, Rep_map_Cons,
- map_Nil, map_Cons];
-val map_ss = list_free_ss addsimps map_simps;
-
-val [major,A_subset_sexp,minor] = goal SList.thy
- "[| M: list(A); A<=sexp; !!z. z: A ==> f(g(z)) = z |] \
-\ ==> Rep_map(f, Abs_map(g,M)) = M";
-by (rtac (major RS list.induct) 1);
-by (ALLGOALS (asm_simp_tac(map_ss addsimps [sexp_A_I,sexp_ListA_I,minor])));
-qed "Abs_map_inverse";
-
-(*Rep_map_inverse is obtained via Abs_Rep_map and map_ident*)
-
-(** list_case **)
-
-goal SList.thy
- "P(list_case(a,f,xs)) = ((xs=[] --> P(a)) & \
-\ (!y ys. xs=y#ys --> P(f(y,ys))))";
-by(list_ind_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac list_ss));
-by(fast_tac HOL_cs 1);
-qed "expand_list_case";
-
-
-(** Additional mapping lemmas **)
-
-goal SList.thy "map(%x.x, xs) = xs";
-by (list_ind_tac "xs" 1);
-by (ALLGOALS (asm_simp_tac map_ss));
-qed "map_ident";
-
-goal SList.thy "map(f, xs@ys) = map(f,xs) @ map(f,ys)";
-by (list_ind_tac "xs" 1);
-by (ALLGOALS (asm_simp_tac (map_ss addsimps [append_Nil,append_Cons])));
-qed "map_append";
-
-goalw SList.thy [o_def] "map(f o g, xs) = map(f, map(g, xs))";
-by (list_ind_tac "xs" 1);
-by (ALLGOALS (asm_simp_tac map_ss));
-qed "map_compose";
-
-goal SList.thy "!!f. (!!x. f(x): sexp) ==> \
-\ Abs_map(g, Rep_map(f,xs)) = map(%t. g(f(t)), xs)";
-by (list_ind_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac(map_ss addsimps
- [Rep_map_type,list_sexp RS subsetD])));
-qed "Abs_Rep_map";
-
-val list_ss = list_ss addsimps
- [mem_append, mem_filter, append_assoc, append_Nil2, map_ident,
- list_all_True, list_all_conj];
-
--- a/ex/SList.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,120 +0,0 @@
-(* Title: HOL/ex/SList.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Definition of type 'a list (strict lists) by a least fixed point
-
-We use list(A) == lfp(%Z. {NUMB(0)} <+> A <*> Z)
-and not list == lfp(%Z. {NUMB(0)} <+> range(Leaf) <*> Z)
-so that list can serve as a "functor" for defining other recursive types
-*)
-
-SList = Sexp +
-
-types
- 'a list
-
-arities
- list :: (term) term
-
-
-consts
-
- list :: "'a item set => 'a item set"
- Rep_list :: "'a list => 'a item"
- Abs_list :: "'a item => 'a list"
- NIL :: "'a item"
- CONS :: "['a item, 'a item] => 'a item"
- Nil :: "'a list"
- "#" :: "['a, 'a list] => 'a list" (infixr 65)
- List_case :: "['b, ['a item, 'a item]=>'b, 'a item] => 'b"
- List_rec :: "['a item, 'b, ['a item, 'a item, 'b]=>'b] => 'b"
- list_case :: "['b, ['a, 'a list]=>'b, 'a list] => 'b"
- list_rec :: "['a list, 'b, ['a, 'a list, 'b]=>'b] => 'b"
- Rep_map :: "('b => 'a item) => ('b list => 'a item)"
- Abs_map :: "('a item => 'b) => 'a item => 'b list"
- null :: "'a list => bool"
- hd :: "'a list => 'a"
- tl,ttl :: "'a list => 'a list"
- mem :: "['a, 'a list] => bool" (infixl 55)
- list_all :: "('a => bool) => ('a list => bool)"
- map :: "('a=>'b) => ('a list => 'b list)"
- "@" :: "['a list, 'a list] => 'a list" (infixr 65)
- filter :: "['a => bool, 'a list] => 'a list"
-
- (* list Enumeration *)
-
- "[]" :: "'a list" ("[]")
- "@list" :: "args => 'a list" ("[(_)]")
-
- (* Special syntax for list_all and filter *)
- "@Alls" :: "[idt, 'a list, bool] => bool" ("(2Alls _:_./ _)" 10)
- "@filter" :: "[idt, 'a list, bool] => 'a list" ("(1[_:_ ./ _])")
-
-translations
- "[x, xs]" == "x#[xs]"
- "[x]" == "x#[]"
- "[]" == "Nil"
-
- "case xs of Nil => a | y#ys => b" == "list_case(a, %y ys.b, xs)"
-
- "[x:xs . P]" == "filter(%x.P,xs)"
- "Alls x:xs.P" == "list_all(%x.P,xs)"
-
-defs
- (* Defining the Concrete Constructors *)
- NIL_def "NIL == In0(Numb(0))"
- CONS_def "CONS(M, N) == In1(M $ N)"
-
-inductive "list(A)"
- intrs
- NIL_I "NIL: list(A)"
- CONS_I "[| a: A; M: list(A) |] ==> CONS(a,M) : list(A)"
-
-rules
- (* Faking a Type Definition ... *)
- Rep_list "Rep_list(xs): list(range(Leaf))"
- Rep_list_inverse "Abs_list(Rep_list(xs)) = xs"
- Abs_list_inverse "M: list(range(Leaf)) ==> Rep_list(Abs_list(M)) = M"
-
-
-defs
- (* Defining the Abstract Constructors *)
- Nil_def "Nil == Abs_list(NIL)"
- Cons_def "x#xs == Abs_list(CONS(Leaf(x), Rep_list(xs)))"
-
- List_case_def "List_case(c, d) == Case(%x.c, Split(d))"
-
- (* list Recursion -- the trancl is Essential; see list.ML *)
-
- List_rec_def
- "List_rec(M, c, d) == wfrec(trancl(pred_sexp), M,
- List_case(%g.c, %x y g. d(x, y, g(y))))"
-
- list_rec_def
- "list_rec(l, c, d) ==
- List_rec(Rep_list(l), c, %x y r. d(Inv(Leaf, x), Abs_list(y), r))"
-
- (* Generalized Map Functionals *)
-
- Rep_map_def "Rep_map(f, xs) == list_rec(xs, NIL, %x l r. CONS(f(x), r))"
- Abs_map_def "Abs_map(g, M) == List_rec(M, Nil, %N L r. g(N)#r)"
-
- null_def "null(xs) == list_rec(xs, True, %x xs r.False)"
- hd_def "hd(xs) == list_rec(xs, @x.True, %x xs r.x)"
- tl_def "tl(xs) == list_rec(xs, @xs.True, %x xs r.xs)"
- (* a total version of tl: *)
- ttl_def "ttl(xs) == list_rec(xs, [], %x xs r.xs)"
-
- mem_def "x mem xs ==
- list_rec(xs, False, %y ys r. if(y=x, True, r))"
- list_all_def "list_all(P, xs) == list_rec(xs, True, %x l r. P(x) & r)"
- map_def "map(f, xs) == list_rec(xs, [], %x l r. f(x)#r)"
- append_def "xs@ys == list_rec(xs, ys, %x l r. x#r)"
- filter_def "filter(P,xs) ==
- list_rec(xs, [], %x xs r. if(P(x), x#r, r))"
-
- list_case_def "list_case(a, f, xs) == list_rec(xs, a, %x xs r.f(x, xs))"
-
-end
--- a/ex/Simult.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,287 +0,0 @@
-(* Title: HOL/ex/Simult.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-Primitives for simultaneous recursive type definitions
- includes worked example of trees & forests
-
-This is essentially the same data structure that on ex/term.ML, which is
-simpler because it uses list as a new type former. The approach in this
-file may be superior for other simultaneous recursions.
-*)
-
-open Simult;
-
-(*** Monotonicity and unfolding of the function ***)
-
-goal Simult.thy "mono(%Z. A <*> Part(Z,In1) \
-\ <+> ({Numb(0)} <+> Part(Z,In0) <*> Part(Z,In1)))";
-by (REPEAT (ares_tac [monoI, subset_refl, usum_mono, uprod_mono,
- Part_mono] 1));
-qed "TF_fun_mono";
-
-val TF_unfold = TF_fun_mono RS (TF_def RS def_lfp_Tarski);
-
-goalw Simult.thy [TF_def] "!!A B. A<=B ==> TF(A) <= TF(B)";
-by (REPEAT (ares_tac [lfp_mono, subset_refl, usum_mono, uprod_mono] 1));
-qed "TF_mono";
-
-goalw Simult.thy [TF_def] "TF(sexp) <= sexp";
-by (rtac lfp_lowerbound 1);
-by (fast_tac (univ_cs addIs sexp.intrs@[sexp_In0I, sexp_In1I]
- addSEs [PartE]) 1);
-qed "TF_sexp";
-
-(* A <= sexp ==> TF(A) <= sexp *)
-val TF_subset_sexp = standard
- (TF_mono RS (TF_sexp RSN (2,subset_trans)));
-
-
-(** Elimination -- structural induction on the set TF **)
-
-val TF_Rep_defs = [TCONS_def,FNIL_def,FCONS_def,NIL_def,CONS_def];
-
-val major::prems = goalw Simult.thy TF_Rep_defs
- "[| i: TF(A); \
-\ !!M N. [| M: A; N: Part(TF(A),In1); R(N) |] ==> R(TCONS(M,N)); \
-\ R(FNIL); \
-\ !!M N. [| M: Part(TF(A),In0); N: Part(TF(A),In1); R(M); R(N) \
-\ |] ==> R(FCONS(M,N)) \
-\ |] ==> R(i)";
-by (rtac ([TF_def, TF_fun_mono, major] MRS def_induct) 1);
-by (fast_tac (set_cs addIs (prems@[PartI])
- addEs [usumE, uprodE, PartE]) 1);
-qed "TF_induct";
-
-(*This lemma replaces a use of subgoal_tac to prove tree_forest_induct*)
-val prems = goalw Simult.thy [Part_def]
- "! M: TF(A). (M: Part(TF(A),In0) --> P(M)) & (M: Part(TF(A),In1) --> Q(M)) \
-\ ==> (! M: Part(TF(A),In0). P(M)) & (! M: Part(TF(A),In1). Q(M))";
-by (cfast_tac prems 1);
-qed "TF_induct_lemma";
-
-val uplus_cs = set_cs addSIs [PartI]
- addSDs [In0_inject, In1_inject]
- addSEs [In0_neq_In1, In1_neq_In0, PartE];
-
-(*Could prove ~ TCONS(M,N) : Part(TF(A),In1) etc. *)
-
-(*Induction on TF with separate predicates P, Q*)
-val prems = goalw Simult.thy TF_Rep_defs
- "[| !!M N. [| M: A; N: Part(TF(A),In1); Q(N) |] ==> P(TCONS(M,N)); \
-\ Q(FNIL); \
-\ !!M N. [| M: Part(TF(A),In0); N: Part(TF(A),In1); P(M); Q(N) \
-\ |] ==> Q(FCONS(M,N)) \
-\ |] ==> (! M: Part(TF(A),In0). P(M)) & (! N: Part(TF(A),In1). Q(N))";
-by (rtac (ballI RS TF_induct_lemma) 1);
-by (etac TF_induct 1);
-by (rewrite_goals_tac TF_Rep_defs);
-by (ALLGOALS (fast_tac (uplus_cs addIs prems)));
-(*29 secs??*)
-qed "Tree_Forest_induct";
-
-(*Induction for the abstract types 'a tree, 'a forest*)
-val prems = goalw Simult.thy [Tcons_def,Fnil_def,Fcons_def]
- "[| !!x ts. Q(ts) ==> P(Tcons(x,ts)); \
-\ Q(Fnil); \
-\ !!t ts. [| P(t); Q(ts) |] ==> Q(Fcons(t,ts)) \
-\ |] ==> (! t. P(t)) & (! ts. Q(ts))";
-by (res_inst_tac [("P1","%z.P(Abs_Tree(z))"),
- ("Q1","%z.Q(Abs_Forest(z))")]
- (Tree_Forest_induct RS conjE) 1);
-(*Instantiates ?A1 to range(Leaf). *)
-by (fast_tac (set_cs addSEs [Rep_Tree_inverse RS subst,
- Rep_Forest_inverse RS subst]
- addSIs [Rep_Tree,Rep_Forest]) 4);
-(*Cannot use simplifier: the rewrites work in the wrong direction!*)
-by (ALLGOALS (fast_tac (set_cs addSEs [Abs_Tree_inverse RS subst,
- Abs_Forest_inverse RS subst]
- addSIs prems)));
-qed "tree_forest_induct";
-
-
-
-(*** Isomorphisms ***)
-
-goal Simult.thy "inj(Rep_Tree)";
-by (rtac inj_inverseI 1);
-by (rtac Rep_Tree_inverse 1);
-qed "inj_Rep_Tree";
-
-goal Simult.thy "inj_onto(Abs_Tree,Part(TF(range(Leaf)),In0))";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_Tree_inverse 1);
-qed "inj_onto_Abs_Tree";
-
-goal Simult.thy "inj(Rep_Forest)";
-by (rtac inj_inverseI 1);
-by (rtac Rep_Forest_inverse 1);
-qed "inj_Rep_Forest";
-
-goal Simult.thy "inj_onto(Abs_Forest,Part(TF(range(Leaf)),In1))";
-by (rtac inj_onto_inverseI 1);
-by (etac Abs_Forest_inverse 1);
-qed "inj_onto_Abs_Forest";
-
-(** Introduction rules for constructors **)
-
-(* c : A <*> Part(TF(A),In1)
- <+> {Numb(0)} <+> Part(TF(A),In0) <*> Part(TF(A),In1) ==> c : TF(A) *)
-val TF_I = TF_unfold RS equalityD2 RS subsetD;
-
-(*For reasoning about the representation*)
-val TF_Rep_cs = uplus_cs addIs [TF_I, uprodI, usum_In0I, usum_In1I]
- addSEs [Scons_inject];
-
-val prems = goalw Simult.thy TF_Rep_defs
- "[| a: A; M: Part(TF(A),In1) |] ==> TCONS(a,M) : Part(TF(A),In0)";
-by (fast_tac (TF_Rep_cs addIs prems) 1);
-qed "TCONS_I";
-
-(* FNIL is a TF(A) -- this also justifies the type definition*)
-goalw Simult.thy TF_Rep_defs "FNIL: Part(TF(A),In1)";
-by (fast_tac TF_Rep_cs 1);
-qed "FNIL_I";
-
-val prems = goalw Simult.thy TF_Rep_defs
- "[| M: Part(TF(A),In0); N: Part(TF(A),In1) |] ==> \
-\ FCONS(M,N) : Part(TF(A),In1)";
-by (fast_tac (TF_Rep_cs addIs prems) 1);
-qed "FCONS_I";
-
-(** Injectiveness of TCONS and FCONS **)
-
-goalw Simult.thy TF_Rep_defs "(TCONS(K,M)=TCONS(L,N)) = (K=L & M=N)";
-by (fast_tac TF_Rep_cs 1);
-qed "TCONS_TCONS_eq";
-bind_thm ("TCONS_inject", (TCONS_TCONS_eq RS iffD1 RS conjE));
-
-goalw Simult.thy TF_Rep_defs "(FCONS(K,M)=FCONS(L,N)) = (K=L & M=N)";
-by (fast_tac TF_Rep_cs 1);
-qed "FCONS_FCONS_eq";
-bind_thm ("FCONS_inject", (FCONS_FCONS_eq RS iffD1 RS conjE));
-
-(** Distinctness of TCONS, FNIL and FCONS **)
-
-goalw Simult.thy TF_Rep_defs "TCONS(M,N) ~= FNIL";
-by (fast_tac TF_Rep_cs 1);
-qed "TCONS_not_FNIL";
-bind_thm ("FNIL_not_TCONS", (TCONS_not_FNIL RS not_sym));
-
-bind_thm ("TCONS_neq_FNIL", (TCONS_not_FNIL RS notE));
-val FNIL_neq_TCONS = sym RS TCONS_neq_FNIL;
-
-goalw Simult.thy TF_Rep_defs "FCONS(M,N) ~= FNIL";
-by (fast_tac TF_Rep_cs 1);
-qed "FCONS_not_FNIL";
-bind_thm ("FNIL_not_FCONS", (FCONS_not_FNIL RS not_sym));
-
-bind_thm ("FCONS_neq_FNIL", (FCONS_not_FNIL RS notE));
-val FNIL_neq_FCONS = sym RS FCONS_neq_FNIL;
-
-goalw Simult.thy TF_Rep_defs "TCONS(M,N) ~= FCONS(K,L)";
-by (fast_tac TF_Rep_cs 1);
-qed "TCONS_not_FCONS";
-bind_thm ("FCONS_not_TCONS", (TCONS_not_FCONS RS not_sym));
-
-bind_thm ("TCONS_neq_FCONS", (TCONS_not_FCONS RS notE));
-val FCONS_neq_TCONS = sym RS TCONS_neq_FCONS;
-
-(*???? Too many derived rules ????
- Automatically generate symmetric forms? Always expand TF_Rep_defs? *)
-
-(** Injectiveness of Tcons and Fcons **)
-
-(*For reasoning about abstract constructors*)
-val TF_cs = set_cs addSIs [Rep_Tree, Rep_Forest, TCONS_I, FNIL_I, FCONS_I]
- addSEs [TCONS_inject, FCONS_inject,
- TCONS_neq_FNIL, FNIL_neq_TCONS,
- FCONS_neq_FNIL, FNIL_neq_FCONS,
- TCONS_neq_FCONS, FCONS_neq_TCONS]
- addSDs [inj_onto_Abs_Tree RS inj_ontoD,
- inj_onto_Abs_Forest RS inj_ontoD,
- inj_Rep_Tree RS injD, inj_Rep_Forest RS injD,
- Leaf_inject];
-
-goalw Simult.thy [Tcons_def] "(Tcons(x,xs)=Tcons(y,ys)) = (x=y & xs=ys)";
-by (fast_tac TF_cs 1);
-qed "Tcons_Tcons_eq";
-bind_thm ("Tcons_inject", (Tcons_Tcons_eq RS iffD1 RS conjE));
-
-goalw Simult.thy [Fcons_def,Fnil_def] "Fcons(x,xs) ~= Fnil";
-by (fast_tac TF_cs 1);
-qed "Fcons_not_Fnil";
-
-bind_thm ("Fcons_neq_Fnil", Fcons_not_Fnil RS notE);
-val Fnil_neq_Fcons = sym RS Fcons_neq_Fnil;
-
-
-(** Injectiveness of Fcons **)
-
-goalw Simult.thy [Fcons_def] "(Fcons(x,xs)=Fcons(y,ys)) = (x=y & xs=ys)";
-by (fast_tac TF_cs 1);
-qed "Fcons_Fcons_eq";
-bind_thm ("Fcons_inject", Fcons_Fcons_eq RS iffD1 RS conjE);
-
-
-(*** TF_rec -- by wf recursion on pred_sexp ***)
-
-val TF_rec_unfold =
- wf_pred_sexp RS wf_trancl RS (TF_rec_def RS def_wfrec);
-
-(** conversion rules for TF_rec **)
-
-goalw Simult.thy [TCONS_def]
- "!!M N. [| M: sexp; N: sexp |] ==> \
-\ TF_rec(TCONS(M,N),b,c,d) = b(M, N, TF_rec(N,b,c,d))";
-by (rtac (TF_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps [Case_In0, Split]) 1);
-by (asm_simp_tac (pred_sexp_ss addsimps [In0_def]) 1);
-qed "TF_rec_TCONS";
-
-goalw Simult.thy [FNIL_def] "TF_rec(FNIL,b,c,d) = c";
-by (rtac (TF_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps [Case_In1, List_case_NIL]) 1);
-qed "TF_rec_FNIL";
-
-goalw Simult.thy [FCONS_def]
- "!!M N. [| M: sexp; N: sexp |] ==> \
-\ TF_rec(FCONS(M,N),b,c,d) = d(M, N, TF_rec(M,b,c,d), TF_rec(N,b,c,d))";
-by (rtac (TF_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps [Case_In1, List_case_CONS]) 1);
-by (asm_simp_tac (pred_sexp_ss addsimps [CONS_def,In1_def]) 1);
-qed "TF_rec_FCONS";
-
-
-(*** tree_rec, forest_rec -- by TF_rec ***)
-
-val Rep_Tree_in_sexp =
- [range_Leaf_subset_sexp RS TF_subset_sexp RS (Part_subset RS subset_trans),
- Rep_Tree] MRS subsetD;
-val Rep_Forest_in_sexp =
- [range_Leaf_subset_sexp RS TF_subset_sexp RS (Part_subset RS subset_trans),
- Rep_Forest] MRS subsetD;
-
-val tf_rec_simps = [TF_rec_TCONS, TF_rec_FNIL, TF_rec_FCONS,
- TCONS_I, FNIL_I, FCONS_I, Rep_Tree, Rep_Forest,
- Rep_Tree_inverse, Rep_Forest_inverse,
- Abs_Tree_inverse, Abs_Forest_inverse,
- inj_Leaf, Inv_f_f, sexp.LeafI, range_eqI,
- Rep_Tree_in_sexp, Rep_Forest_in_sexp];
-val tf_rec_ss = HOL_ss addsimps tf_rec_simps;
-
-goalw Simult.thy [tree_rec_def, forest_rec_def, Tcons_def]
- "tree_rec(Tcons(a,tf),b,c,d) = b(a,tf,forest_rec(tf,b,c,d))";
-by (simp_tac tf_rec_ss 1);
-qed "tree_rec_Tcons";
-
-goalw Simult.thy [forest_rec_def, Fnil_def] "forest_rec(Fnil,b,c,d) = c";
-by (simp_tac tf_rec_ss 1);
-qed "forest_rec_Fnil";
-
-goalw Simult.thy [tree_rec_def, forest_rec_def, Fcons_def]
- "forest_rec(Fcons(t,tf),b,c,d) = \
-\ d(t,tf,tree_rec(t,b,c,d), forest_rec(tf,b,c,d))";
-by (simp_tac tf_rec_ss 1);
-qed "forest_rec_Cons";
--- a/ex/Simult.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,82 +0,0 @@
-(* Title: HOL/ex/Simult
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1993 University of Cambridge
-
-A simultaneous recursive type definition: trees & forests
-
-This is essentially the same data structure that on ex/term.ML, which is
-simpler because it uses list as a new type former. The approach in this
-file may be superior for other simultaneous recursions.
-
-The inductive definition package does not help defining this sort of mutually
-recursive data structure because it uses Inl, Inr instead of In0, In1.
-*)
-
-Simult = SList +
-
-types 'a tree
- 'a forest
-
-arities tree,forest :: (term)term
-
-consts
- TF :: "'a item set => 'a item set"
- FNIL :: "'a item"
- TCONS,FCONS :: "['a item, 'a item] => 'a item"
- Rep_Tree :: "'a tree => 'a item"
- Abs_Tree :: "'a item => 'a tree"
- Rep_Forest :: "'a forest => 'a item"
- Abs_Forest :: "'a item => 'a forest"
- Tcons :: "['a, 'a forest] => 'a tree"
- Fcons :: "['a tree, 'a forest] => 'a forest"
- Fnil :: "'a forest"
- TF_rec :: "['a item, ['a item , 'a item, 'b]=>'b,
- 'b, ['a item , 'a item, 'b, 'b]=>'b] => 'b"
- tree_rec :: "['a tree, ['a, 'a forest, 'b]=>'b,
- 'b, ['a tree, 'a forest, 'b, 'b]=>'b] => 'b"
- forest_rec :: "['a forest, ['a, 'a forest, 'b]=>'b,
- 'b, ['a tree, 'a forest, 'b, 'b]=>'b] => 'b"
-
-defs
- (*the concrete constants*)
- TCONS_def "TCONS(M,N) == In0(M $ N)"
- FNIL_def "FNIL == In1(NIL)"
- FCONS_def "FCONS(M,N) == In1(CONS(M,N))"
- (*the abstract constants*)
- Tcons_def "Tcons(a,ts) == Abs_Tree(TCONS(Leaf(a), Rep_Forest(ts)))"
- Fnil_def "Fnil == Abs_Forest(FNIL)"
- Fcons_def "Fcons(t,ts) == Abs_Forest(FCONS(Rep_Tree(t), Rep_Forest(ts)))"
-
- TF_def "TF(A) == lfp(%Z. A <*> Part(Z,In1)
- <+> ({Numb(0)} <+> Part(Z,In0) <*> Part(Z,In1)))"
-
-rules
- (*faking a type definition for tree...*)
- Rep_Tree "Rep_Tree(n): Part(TF(range(Leaf)),In0)"
- Rep_Tree_inverse "Abs_Tree(Rep_Tree(t)) = t"
- Abs_Tree_inverse "z: Part(TF(range(Leaf)),In0) ==> Rep_Tree(Abs_Tree(z)) = z"
- (*faking a type definition for forest...*)
- Rep_Forest "Rep_Forest(n): Part(TF(range(Leaf)),In1)"
- Rep_Forest_inverse "Abs_Forest(Rep_Forest(ts)) = ts"
- Abs_Forest_inverse
- "z: Part(TF(range(Leaf)),In1) ==> Rep_Forest(Abs_Forest(z)) = z"
-
-
-defs
- (*recursion*)
- TF_rec_def
- "TF_rec(M,b,c,d) == wfrec(trancl(pred_sexp), M,
- Case(Split(%x y g. b(x,y,g(y))),
- List_case(%g.c, %x y g. d(x,y,g(x),g(y)))))"
-
- tree_rec_def
- "tree_rec(t,b,c,d) ==
- TF_rec(Rep_Tree(t), %x y r. b(Inv(Leaf,x), Abs_Forest(y), r),
- c, %x y rt rf. d(Abs_Tree(x), Abs_Forest(y), rt, rf))"
-
- forest_rec_def
- "forest_rec(tf,b,c,d) ==
- TF_rec(Rep_Forest(tf), %x y r. b(Inv(Leaf,x), Abs_Forest(y), r),
- c, %x y rt rf. d(Abs_Tree(x), Abs_Forest(y), rt, rf))"
-end
--- a/ex/Sorting.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,26 +0,0 @@
-(* Title: HOL/ex/sorting.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Some general lemmas
-*)
-
-val sorting_ss = list_ss addsimps
- [Sorting.mset_Nil,Sorting.mset_Cons,
- Sorting.sorted_Nil,Sorting.sorted_Cons,
- Sorting.sorted1_Nil,Sorting.sorted1_One,Sorting.sorted1_Cons];
-
-goal Sorting.thy "!x.mset(xs@ys,x) = mset(xs,x)+mset(ys,x)";
-by(list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (sorting_ss setloop (split_tac [expand_if]))));
-qed "mset_app_distr";
-
-goal Sorting.thy "!x. mset([x:xs. ~p(x)], x) + mset([x:xs.p(x)], x) = \
-\ mset(xs, x)";
-by(list.induct_tac "xs" 1);
-by(ALLGOALS(asm_simp_tac (sorting_ss setloop (split_tac [expand_if]))));
-qed "mset_compl_add";
-
-val sorting_ss = sorting_ss addsimps
- [mset_app_distr, mset_compl_add];
--- a/ex/Sorting.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,31 +0,0 @@
-(* Title: HOL/ex/sorting.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1994 TU Muenchen
-
-Specification of sorting
-*)
-
-Sorting = List +
-consts
- sorted1:: "[['a,'a] => bool, 'a list] => bool"
- sorted :: "[['a,'a] => bool, 'a list] => bool"
- mset :: "'a list => ('a => nat)"
- total :: "(['a,'a] => bool) => bool"
- transf :: "(['a,'a] => bool) => bool"
-
-rules
-
-sorted1_Nil "sorted1(f,[])"
-sorted1_One "sorted1(f,[x])"
-sorted1_Cons "sorted1(f,Cons(x,y#zs)) = (f(x,y) & sorted1(f,y#zs))"
-
-sorted_Nil "sorted(le,[])"
-sorted_Cons "sorted(le,x#xs) = ((Alls y:xs. le(x,y)) & sorted(le,xs))"
-
-mset_Nil "mset([],y) = 0"
-mset_Cons "mset(x#xs,y) = if(x=y, Suc(mset(xs,y)), mset(xs,y))"
-
-total_def "total(r) == (!x y. r(x,y) | r(y,x))"
-transf_def "transf(f) == (!x y z. f(x,y) & f(y,z) --> f(x,z))"
-end
--- a/ex/String.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,22 +0,0 @@
-val string_ss = list_ss addsimps (String.nibble.simps @ String.char.simps);
-
-goal String.thy "hd(''ABCD'') = CHR ''A''";
-by(simp_tac string_ss 1);
-result();
-
-goal String.thy "hd(''ABCD'') ~= CHR ''B''";
-by(simp_tac string_ss 1);
-result();
-
-goal String.thy "''ABCD'' ~= ''ABCX''";
-by(simp_tac string_ss 1);
-result();
-
-goal String.thy "''ABCD'' = ''ABCD''";
-by(simp_tac string_ss 1);
-result();
-
-goal String.thy
- "''ABCDEFGHIJKLMNOPQRSTUVWXYZ'' ~= ''ABCDEFGHIJKLMNOPQRSTUVWXY''";
-by(simp_tac string_ss 1);
-result();
--- a/ex/String.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,90 +0,0 @@
-(* Title: HOL/String.thy
- ID: $Id$
-
-Hex chars. Strings.
-*)
-
-String = List +
-
-datatype
- nibble = H00 | H01 | H02 | H03 | H04 | H05 | H06 | H07
- | H08 | H09 | H0A | H0B | H0C | H0D | H0E | H0F
-
-datatype
- char = Char (nibble, nibble)
-
-types
- string = "char list"
-
-syntax
- "_Char" :: "xstr => char" ("CHR _")
- "_String" :: "xstr => string" ("_")
-
-end
-
-
-ML
-
-local
- open Syntax;
-
- val ssquote = enclose "''" "''";
-
-
- (* chars *)
-
- val zero = ord "0";
- val ten = ord "A" - 10;
-
- fun mk_nib n =
- const ("H0" ^ chr (n + (if n <= 9 then zero else ten)));
-
- fun dest_nib (Const (c, _)) =
- (case explode c of
- ["H", "0", h] => ord h - (if h <= "9" then zero else ten)
- | _ => raise Match)
- | dest_nib _ = raise Match;
-
- fun dest_nibs t1 t2 = chr (dest_nib t1 * 16 + dest_nib t2);
-
-
- fun mk_char c =
- const "Char" $ mk_nib (ord c div 16) $ mk_nib (ord c mod 16);
-
- fun dest_char (Const ("Char", _) $ t1 $ t2) = dest_nibs t1 t2
- | dest_char _ = raise Match;
-
-
- fun char_tr (*"_Char"*) [Free (c, _)] =
- if size c = 1 then mk_char c
- else error ("Bad character: " ^ quote c)
- | char_tr (*"_Char"*) ts = raise_term "char_tr" ts;
-
- fun char_tr' (*"Char"*) [t1, t2] =
- const "_Char" $ free (ssquote (dest_nibs t1 t2))
- | char_tr' (*"Char"*) _ = raise Match;
-
-
- (* strings *)
-
- fun mk_string [] = const constrainC $ const "[]" $ const "string"
- | mk_string (t :: ts) = const "op #" $ t $ mk_string ts;
-
- fun dest_string (Const ("[]", _)) = []
- | dest_string (Const ("op #", _) $ c $ cs) = dest_char c :: dest_string cs
- | dest_string _ = raise Match;
-
-
- fun string_tr (*"_String"*) [Free (txt, _)] =
- mk_string (map mk_char (explode txt))
- | string_tr (*"_String"*) ts = raise_term "string_tr" ts;
-
- fun cons_tr' (*"op #"*) [c, cs] =
- const "_String" $ free (ssquote (implode (dest_char c :: dest_string cs)))
- | cons_tr' (*"op #"*) ts = raise Match;
-
-in
- val parse_translation = [("_Char", char_tr), ("_String", string_tr)];
- val print_translation = [("Char", char_tr'), ("op #", cons_tr')];
-end;
-
--- a/ex/Term.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,165 +0,0 @@
-(* Title: HOL/ex/Term
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-Terms over a given alphabet -- function applications; illustrates list functor
- (essentially the same type as in Trees & Forests)
-*)
-
-open Term;
-
-(*** Monotonicity and unfolding of the function ***)
-
-goal Term.thy "term(A) = A <*> list(term(A))";
-by (fast_tac (univ_cs addSIs (equalityI :: term.intrs)
- addEs [term.elim]) 1);
-qed "term_unfold";
-
-(*This justifies using term in other recursive type definitions*)
-goalw Term.thy term.defs "!!A B. A<=B ==> term(A) <= term(B)";
-by (REPEAT (ares_tac ([lfp_mono, list_mono] @ basic_monos) 1));
-qed "term_mono";
-
-(** Type checking -- term creates well-founded sets **)
-
-goalw Term.thy term.defs "term(sexp) <= sexp";
-by (rtac lfp_lowerbound 1);
-by (fast_tac (univ_cs addIs [sexp.SconsI, list_sexp RS subsetD]) 1);
-qed "term_sexp";
-
-(* A <= sexp ==> term(A) <= sexp *)
-bind_thm ("term_subset_sexp", ([term_mono, term_sexp] MRS subset_trans));
-
-
-(** Elimination -- structural induction on the set term(A) **)
-
-(*Induction for the set term(A) *)
-val [major,minor] = goal Term.thy
- "[| M: term(A); \
-\ !!x zs. [| x: A; zs: list(term(A)); zs: list({x.R(x)}) \
-\ |] ==> R(x$zs) \
-\ |] ==> R(M)";
-by (rtac (major RS term.induct) 1);
-by (REPEAT (eresolve_tac ([minor] @
- ([Int_lower1,Int_lower2] RL [list_mono RS subsetD])) 1));
-(*Proof could also use mono_Int RS subsetD RS IntE *)
-qed "Term_induct";
-
-(*Induction on term(A) followed by induction on list *)
-val major::prems = goal Term.thy
- "[| M: term(A); \
-\ !!x. [| x: A |] ==> R(x$NIL); \
-\ !!x z zs. [| x: A; z: term(A); zs: list(term(A)); R(x$zs) \
-\ |] ==> R(x $ CONS(z,zs)) \
-\ |] ==> R(M)";
-by (rtac (major RS Term_induct) 1);
-by (etac list.induct 1);
-by (REPEAT (ares_tac prems 1));
-qed "Term_induct2";
-
-(*** Structural Induction on the abstract type 'a term ***)
-
-val list_all_ss = map_ss addsimps [list_all_Nil, list_all_Cons];
-
-val Rep_term_in_sexp =
- Rep_term RS (range_Leaf_subset_sexp RS term_subset_sexp RS subsetD);
-
-(*Induction for the abstract type 'a term*)
-val prems = goalw Term.thy [App_def,Rep_Tlist_def,Abs_Tlist_def]
- "[| !!x ts. list_all(R,ts) ==> R(App(x,ts)) \
-\ |] ==> R(t)";
-by (rtac (Rep_term_inverse RS subst) 1); (*types force good instantiation*)
-by (res_inst_tac [("P","Rep_term(t) : sexp")] conjunct2 1);
-by (rtac (Rep_term RS Term_induct) 1);
-by (REPEAT (ares_tac [conjI, sexp.SconsI, term_subset_sexp RS
- list_subset_sexp, range_Leaf_subset_sexp] 1
- ORELSE etac rev_subsetD 1));
-by (eres_inst_tac [("A1","term(?u)"), ("f1","Rep_term"), ("g1","Abs_term")]
- (Abs_map_inverse RS subst) 1);
-by (rtac (range_Leaf_subset_sexp RS term_subset_sexp) 1);
-by (etac Abs_term_inverse 1);
-by (etac rangeE 1);
-by (hyp_subst_tac 1);
-by (resolve_tac prems 1);
-by (etac list.induct 1);
-by (etac CollectE 2);
-by (stac Abs_map_CONS 2);
-by (etac conjunct1 2);
-by (etac rev_subsetD 2);
-by (rtac list_subset_sexp 2);
-by (fast_tac set_cs 2);
-by (ALLGOALS (asm_simp_tac list_all_ss));
-qed "term_induct";
-
-(*Induction for the abstract type 'a term*)
-val prems = goal Term.thy
- "[| !!x. R(App(x,Nil)); \
-\ !!x t ts. R(App(x,ts)) ==> R(App(x, t#ts)) \
-\ |] ==> R(t)";
-by (rtac term_induct 1); (*types force good instantiation*)
-by (etac rev_mp 1);
-by (rtac list_induct 1); (*types force good instantiation*)
-by (ALLGOALS (asm_simp_tac (list_all_ss addsimps prems)));
-qed "term_induct2";
-
-(*Perform induction on xs. *)
-fun term_ind2_tac a i =
- EVERY [res_inst_tac [("t",a)] term_induct2 i,
- rename_last_tac a ["1","s"] (i+1)];
-
-
-
-(*** Term_rec -- by wf recursion on pred_sexp ***)
-
-val Term_rec_unfold =
- wf_pred_sexp RS wf_trancl RS (Term_rec_def RS def_wfrec);
-
-(** conversion rules **)
-
-val [prem] = goal Term.thy
- "N: list(term(A)) ==> \
-\ !M. <N,M>: pred_sexp^+ --> \
-\ Abs_map(cut(h, pred_sexp^+, M), N) = \
-\ Abs_map(h,N)";
-by (rtac (prem RS list.induct) 1);
-by (simp_tac list_all_ss 1);
-by (strip_tac 1);
-by (etac (pred_sexp_CONS_D RS conjE) 1);
-by (asm_simp_tac (list_all_ss addsimps [trancl_pred_sexpD1, cut_apply]) 1);
-qed "Abs_map_lemma";
-
-val [prem1,prem2,A_subset_sexp] = goal Term.thy
- "[| M: sexp; N: list(term(A)); A<=sexp |] ==> \
-\ Term_rec(M$N, d) = d(M, N, Abs_map(%Z. Term_rec(Z,d), N))";
-by (rtac (Term_rec_unfold RS trans) 1);
-by (simp_tac (HOL_ss addsimps
- [Split,
- prem2 RS Abs_map_lemma RS spec RS mp, pred_sexpI2 RS r_into_trancl,
- prem1, prem2 RS rev_subsetD, list_subset_sexp,
- term_subset_sexp, A_subset_sexp])1);
-qed "Term_rec";
-
-(*** term_rec -- by Term_rec ***)
-
-local
- val Rep_map_type1 = read_instantiate_sg (sign_of Term.thy)
- [("f","Rep_term")] Rep_map_type;
- val Rep_Tlist = Rep_term RS Rep_map_type1;
- val Rep_Term_rec = range_Leaf_subset_sexp RSN (2,Rep_Tlist RSN(2,Term_rec));
-
- (*Now avoids conditional rewriting with the premise N: list(term(A)),
- since A will be uninstantiated and will cause rewriting to fail. *)
- val term_rec_ss = HOL_ss
- addsimps [Rep_Tlist RS (rangeI RS term.APP_I RS Abs_term_inverse),
- Rep_term_in_sexp, Rep_Term_rec, Rep_term_inverse,
- inj_Leaf, Inv_f_f,
- Abs_Rep_map, map_ident, sexp.LeafI]
-in
-
-val term_rec = prove_goalw Term.thy
- [term_rec_def, App_def, Rep_Tlist_def, Abs_Tlist_def]
- "term_rec(App(f,ts), d) = d(f, ts, map (%t. term_rec(t,d), ts))"
- (fn _ => [simp_tac term_rec_ss 1])
-
-end;
--- a/ex/Term.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,55 +0,0 @@
-(* Title: HOL/ex/Term
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-Terms over a given alphabet -- function applications; illustrates list functor
- (essentially the same type as in Trees & Forests)
-
-There is no constructor APP because it is simply cons ($)
-*)
-
-Term = SList +
-
-types 'a term
-
-arities term :: (term)term
-
-consts
- term :: "'a item set => 'a item set"
- Rep_term :: "'a term => 'a item"
- Abs_term :: "'a item => 'a term"
- Rep_Tlist :: "'a term list => 'a item"
- Abs_Tlist :: "'a item => 'a term list"
- App :: "['a, ('a term)list] => 'a term"
- Term_rec :: "['a item, ['a item , 'a item, 'b list]=>'b] => 'b"
- term_rec :: "['a term, ['a ,'a term list, 'b list]=>'b] => 'b"
-
-inductive "term(A)"
- intrs
- APP_I "[| M: A; N : list(term(A)) |] ==> M$N : term(A)"
- monos "[list_mono]"
-
-defs
- (*defining abstraction/representation functions for term list...*)
- Rep_Tlist_def "Rep_Tlist == Rep_map(Rep_term)"
- Abs_Tlist_def "Abs_Tlist == Abs_map(Abs_term)"
-
- (*defining the abstract constants*)
- App_def "App(a,ts) == Abs_term(Leaf(a) $ Rep_Tlist(ts))"
-
- (*list recursion*)
- Term_rec_def
- "Term_rec(M,d) == wfrec(trancl(pred_sexp), M,
- Split(%x y g. d(x,y, Abs_map(g,y))))"
-
- term_rec_def
- "term_rec(t,d) ==
- Term_rec(Rep_term(t), %x y r. d(Inv(Leaf,x), Abs_Tlist(y), r))"
-
-rules
- (*faking a type definition for term...*)
- Rep_term "Rep_term(n): term(range(Leaf))"
- Rep_term_inverse "Abs_term(Rep_term(t)) = t"
- Abs_term_inverse "M: term(range(Leaf)) ==> Rep_term(Abs_term(M)) = M"
-end
--- a/ex/cla.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,455 +0,0 @@
-(* Title: HOL/ex/cla
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Higher-Order Logic: predicate calculus problems
-
-Taken from FOL/cla.ML; beware of precedence of = vs <->
-*)
-
-writeln"File HOL/ex/cla.";
-
-goal HOL.thy "(P --> Q | R) --> (P-->Q) | (P-->R)";
-by (fast_tac HOL_cs 1);
-result();
-
-(*If and only if*)
-
-goal HOL.thy "(P=Q) = (Q=P::bool)";
-by (fast_tac HOL_cs 1);
-result();
-
-goal HOL.thy "~ (P = (~P))";
-by (fast_tac HOL_cs 1);
-result();
-
-
-(*Sample problems from
- F. J. Pelletier,
- Seventy-Five Problems for Testing Automatic Theorem Provers,
- J. Automated Reasoning 2 (1986), 191-216.
- Errata, JAR 4 (1988), 236-236.
-
-The hardest problems -- judging by experience with several theorem provers,
-including matrix ones -- are 34 and 43.
-*)
-
-writeln"Pelletier's examples";
-(*1*)
-goal HOL.thy "(P-->Q) = (~Q --> ~P)";
-by (fast_tac HOL_cs 1);
-result();
-
-(*2*)
-goal HOL.thy "(~ ~ P) = P";
-by (fast_tac HOL_cs 1);
-result();
-
-(*3*)
-goal HOL.thy "~(P-->Q) --> (Q-->P)";
-by (fast_tac HOL_cs 1);
-result();
-
-(*4*)
-goal HOL.thy "(~P-->Q) = (~Q --> P)";
-by (fast_tac HOL_cs 1);
-result();
-
-(*5*)
-goal HOL.thy "((P|Q)-->(P|R)) --> (P|(Q-->R))";
-by (fast_tac HOL_cs 1);
-result();
-
-(*6*)
-goal HOL.thy "P | ~ P";
-by (fast_tac HOL_cs 1);
-result();
-
-(*7*)
-goal HOL.thy "P | ~ ~ ~ P";
-by (fast_tac HOL_cs 1);
-result();
-
-(*8. Peirce's law*)
-goal HOL.thy "((P-->Q) --> P) --> P";
-by (fast_tac HOL_cs 1);
-result();
-
-(*9*)
-goal HOL.thy "((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)";
-by (fast_tac HOL_cs 1);
-result();
-
-(*10*)
-goal HOL.thy "(Q-->R) & (R-->P&Q) & (P-->Q|R) --> (P=Q)";
-by (fast_tac HOL_cs 1);
-result();
-
-(*11. Proved in each direction (incorrectly, says Pelletier!!) *)
-goal HOL.thy "P=P::bool";
-by (fast_tac HOL_cs 1);
-result();
-
-(*12. "Dijkstra's law"*)
-goal HOL.thy "((P = Q) = R) = (P = (Q = R))";
-by (fast_tac HOL_cs 1);
-result();
-
-(*13. Distributive law*)
-goal HOL.thy "(P | (Q & R)) = ((P | Q) & (P | R))";
-by (fast_tac HOL_cs 1);
-result();
-
-(*14*)
-goal HOL.thy "(P = Q) = ((Q | ~P) & (~Q|P))";
-by (fast_tac HOL_cs 1);
-result();
-
-(*15*)
-goal HOL.thy "(P --> Q) = (~P | Q)";
-by (fast_tac HOL_cs 1);
-result();
-
-(*16*)
-goal HOL.thy "(P-->Q) | (Q-->P)";
-by (fast_tac HOL_cs 1);
-result();
-
-(*17*)
-goal HOL.thy "((P & (Q-->R))-->S) = ((~P | Q | S) & (~P | ~R | S))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Classical Logic: examples with quantifiers";
-
-goal HOL.thy "(! x. P(x) & Q(x)) = ((! x. P(x)) & (! x. Q(x)))";
-by (fast_tac HOL_cs 1);
-result();
-
-goal HOL.thy "(? x. P-->Q(x)) = (P --> (? x.Q(x)))";
-by (fast_tac HOL_cs 1);
-result();
-
-goal HOL.thy "(? x.P(x)-->Q) = ((! x.P(x)) --> Q)";
-by (fast_tac HOL_cs 1);
-result();
-
-goal HOL.thy "((! x.P(x)) | Q) = (! x. P(x) | Q)";
-by (fast_tac HOL_cs 1);
-result();
-
-(*From Wishnu Prasetya*)
-goal HOL.thy
- "(!s. q(s) --> r(s)) & ~r(s) & (!s. ~r(s) & ~q(s) --> p(t) | q(t)) \
-\ --> p(t) | r(t)";
-by (fast_tac HOL_cs 1);
-result();
-
-
-writeln"Problems requiring quantifier duplication";
-
-(*Needs multiple instantiation of the quantifier.*)
-goal HOL.thy "(! x. P(x)-->P(f(x))) & P(d)-->P(f(f(f(d))))";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-(*Needs double instantiation of the quantifier*)
-goal HOL.thy "? x. P(x) --> P(a) & P(b)";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-goal HOL.thy "? z. P(z) --> (! x. P(x))";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-goal HOL.thy "? x. (? y. P(y)) --> P(x)";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-writeln"Hard examples with quantifiers";
-
-writeln"Problem 18";
-goal HOL.thy "? y. ! x. P(y)-->P(x)";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-writeln"Problem 19";
-goal HOL.thy "? x. ! y z. (P(y)-->Q(z)) --> (P(x)-->Q(x))";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-writeln"Problem 20";
-goal HOL.thy "(! x y. ? z. ! w. (P(x)&Q(y)-->R(z)&S(w))) \
-\ --> (? x y. P(x) & Q(y)) --> (? z. R(z))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 21";
-goal HOL.thy "(? x. P-->Q(x)) & (? x. Q(x)-->P) --> (? x. P=Q(x))";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-writeln"Problem 22";
-goal HOL.thy "(! x. P = Q(x)) --> (P = (! x. Q(x)))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 23";
-goal HOL.thy "(! x. P | Q(x)) = (P | (! x. Q(x)))";
-by (best_tac HOL_cs 1);
-result();
-
-writeln"Problem 24";
-goal HOL.thy "~(? x. S(x)&Q(x)) & (! x. P(x) --> Q(x)|R(x)) & \
-\ ~(? x.P(x)) --> (? x.Q(x)) & (! x. Q(x)|R(x) --> S(x)) \
-\ --> (? x. P(x)&R(x))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 25";
-goal HOL.thy "(? x. P(x)) & \
-\ (! x. L(x) --> ~ (M(x) & R(x))) & \
-\ (! x. P(x) --> (M(x) & L(x))) & \
-\ ((! x. P(x)-->Q(x)) | (? x. P(x)&R(x))) \
-\ --> (? x. Q(x)&P(x))";
-by (best_tac HOL_cs 1);
-result();
-
-writeln"Problem 26";
-goal HOL.thy "((? x. p(x)) = (? x. q(x))) & \
-\ (! x. ! y. p(x) & q(y) --> (r(x) = s(y))) \
-\ --> ((! x. p(x)-->r(x)) = (! x. q(x)-->s(x)))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 27";
-goal HOL.thy "(? x. P(x) & ~Q(x)) & \
-\ (! x. P(x) --> R(x)) & \
-\ (! x. M(x) & L(x) --> P(x)) & \
-\ ((? x. R(x) & ~ Q(x)) --> (! x. L(x) --> ~ R(x))) \
-\ --> (! x. M(x) --> ~L(x))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 28. AMENDED";
-goal HOL.thy "(! x. P(x) --> (! x. Q(x))) & \
-\ ((! x. Q(x)|R(x)) --> (? x. Q(x)&S(x))) & \
-\ ((? x.S(x)) --> (! x. L(x) --> M(x))) \
-\ --> (! x. P(x) & L(x) --> M(x))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 29. Essentially the same as Principia Mathematica *11.71";
-goal HOL.thy "(? x. F(x)) & (? y. G(y)) \
-\ --> ( ((! x. F(x)-->H(x)) & (! y. G(y)-->J(y))) = \
-\ (! x y. F(x) & G(y) --> H(x) & J(y)))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 30";
-goal HOL.thy "(! x. P(x) | Q(x) --> ~ R(x)) & \
-\ (! x. (Q(x) --> ~ S(x)) --> P(x) & R(x)) \
-\ --> (! x. S(x))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 31";
-goal HOL.thy "~(? x.P(x) & (Q(x) | R(x))) & \
-\ (? x. L(x) & P(x)) & \
-\ (! x. ~ R(x) --> M(x)) \
-\ --> (? x. L(x) & M(x))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 32";
-goal HOL.thy "(! x. P(x) & (Q(x)|R(x))-->S(x)) & \
-\ (! x. S(x) & R(x) --> L(x)) & \
-\ (! x. M(x) --> R(x)) \
-\ --> (! x. P(x) & M(x) --> L(x))";
-by (best_tac HOL_cs 1);
-result();
-
-writeln"Problem 33";
-goal HOL.thy "(! x. P(a) & (P(x)-->P(b))-->P(c)) = \
-\ (! x. (~P(a) | P(x) | P(c)) & (~P(a) | ~P(b) | P(c)))";
-by (best_tac HOL_cs 1);
-result();
-
-writeln"Problem 34 AMENDED (TWICE!!) NOT PROVED AUTOMATICALLY";
-(*Andrews's challenge*)
-goal HOL.thy "((? x. ! y. p(x) = p(y)) = \
-\ ((? x. q(x)) = (! y. p(y)))) = \
-\ ((? x. ! y. q(x) = q(y)) = \
-\ ((? x. p(x)) = (! y. q(y))))";
-by (deepen_tac HOL_cs 3 1);
-(*slower with smaller bounds*)
-result();
-
-writeln"Problem 35";
-goal HOL.thy "? x y. P(x,y) --> (! u v. P(u,v))";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-writeln"Problem 36";
-goal HOL.thy "(! x. ? y. J(x,y)) & \
-\ (! x. ? y. G(x,y)) & \
-\ (! x y. J(x,y) | G(x,y) --> \
-\ (! z. J(y,z) | G(y,z) --> H(x,z))) \
-\ --> (! x. ? y. H(x,y))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 37";
-goal HOL.thy "(! z. ? w. ! x. ? y. \
-\ (P(x,z)-->P(y,w)) & P(y,z) & (P(y,w) --> (? u.Q(u,w)))) & \
-\ (! x z. ~P(x,z) --> (? y. Q(y,z))) & \
-\ ((? x y. Q(x,y)) --> (! x. R(x,x))) \
-\ --> (! x. ? y. R(x,y))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 38";
-goal HOL.thy
- "(! x. p(a) & (p(x) --> (? y. p(y) & r(x,y))) --> \
-\ (? z. ? w. p(z) & r(x,w) & r(w,z))) = \
-\ (! x. (~p(a) | p(x) | (? z. ? w. p(z) & r(x,w) & r(w,z))) & \
-\ (~p(a) | ~(? y. p(y) & r(x,y)) | \
-\ (? z. ? w. p(z) & r(x,w) & r(w,z))))";
-
-writeln"Problem 39";
-goal HOL.thy "~ (? x. ! y. F(y,x) = (~F(y,y)))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 40. AMENDED";
-goal HOL.thy "(? y. ! x. F(x,y) = F(x,x)) \
-\ --> ~ (! x. ? y. ! z. F(z,y) = (~F(z,x)))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 41";
-goal HOL.thy "(! z. ? y. ! x. f(x,y) = (f(x,z) & ~ f(x,x))) \
-\ --> ~ (? z. ! x. f(x,z))";
-by (best_tac HOL_cs 1);
-result();
-
-writeln"Problem 42";
-goal HOL.thy "~ (? y. ! x. p(x,y) = (~ (? z. p(x,z) & p(z,x))))";
-by (deepen_tac HOL_cs 3 1);
-result();
-
-writeln"Problem 43 NOT PROVED AUTOMATICALLY";
-goal HOL.thy
- "(! x::'a. ! y::'a. q(x,y) = (! z. p(z,x) = (p(z,y)::bool))) \
-\ --> (! x. (! y. q(x,y) = (q(y,x)::bool)))";
-
-
-writeln"Problem 44";
-goal HOL.thy "(! x. f(x) --> \
-\ (? y. g(y) & h(x,y) & (? y. g(y) & ~ h(x,y)))) & \
-\ (? x. j(x) & (! y. g(y) --> h(x,y))) \
-\ --> (? x. j(x) & ~f(x))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 45";
-goal HOL.thy
- "(! x. f(x) & (! y. g(y) & h(x,y) --> j(x,y)) \
-\ --> (! y. g(y) & h(x,y) --> k(y))) & \
-\ ~ (? y. l(y) & k(y)) & \
-\ (? x. f(x) & (! y. h(x,y) --> l(y)) \
-\ & (! y. g(y) & h(x,y) --> j(x,y))) \
-\ --> (? x. f(x) & ~ (? y. g(y) & h(x,y)))";
-by (best_tac HOL_cs 1);
-result();
-
-
-writeln"Problems (mainly) involving equality or functions";
-
-writeln"Problem 48";
-goal HOL.thy "(a=b | c=d) & (a=c | b=d) --> a=d | b=c";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 49 NOT PROVED AUTOMATICALLY";
-(*Hard because it involves substitution for Vars;
- the type constraint ensures that x,y,z have the same type as a,b,u. *)
-goal HOL.thy "(? x y::'a. ! z. z=x | z=y) & P(a) & P(b) & (~a=b) \
-\ --> (! u::'a.P(u))";
-by (Classical.safe_tac HOL_cs);
-by (res_inst_tac [("x","a")] allE 1);
-by (assume_tac 1);
-by (res_inst_tac [("x","b")] allE 1);
-by (assume_tac 1);
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 50";
-(*What has this to do with equality?*)
-goal HOL.thy "(! x. P(a,x) | (! y.P(x,y))) --> (? x. ! y.P(x,y))";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-writeln"Problem 51";
-goal HOL.thy
- "(? z w. ! x y. P(x,y) = (x=z & y=w)) --> \
-\ (? z. ! x. ? w. (! y. P(x,y) = (y=w)) = (x=z))";
-by (best_tac HOL_cs 1);
-result();
-
-writeln"Problem 52";
-(*Almost the same as 51. *)
-goal HOL.thy
- "(? z w. ! x y. P(x,y) = (x=z & y=w)) --> \
-\ (? w. ! y. ? z. (! x. P(x,y) = (x=z)) = (y=w))";
-by (best_tac HOL_cs 1);
-result();
-
-writeln"Problem 55";
-
-(*Non-equational version, from Manthey and Bry, CADE-9 (Springer, 1988).
- fast_tac DISCOVERS who killed Agatha. *)
-goal HOL.thy "lives(agatha) & lives(butler) & lives(charles) & \
-\ (killed(agatha,agatha) | killed(butler,agatha) | killed(charles,agatha)) & \
-\ (!x y. killed(x,y) --> hates(x,y) & ~richer(x,y)) & \
-\ (!x. hates(agatha,x) --> ~hates(charles,x)) & \
-\ (hates(agatha,agatha) & hates(agatha,charles)) & \
-\ (!x. lives(x) & ~richer(x,agatha) --> hates(butler,x)) & \
-\ (!x. hates(agatha,x) --> hates(butler,x)) & \
-\ (!x. ~hates(x,agatha) | ~hates(x,butler) | ~hates(x,charles)) --> \
-\ killed(?who,agatha)";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 56";
-goal HOL.thy
- "(! x. (? y. P(y) & x=f(y)) --> P(x)) = (! x. P(x) --> P(f(x)))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 57";
-goal HOL.thy
- "P(f(a,b), f(b,c)) & P(f(b,c), f(a,c)) & \
-\ (! x y z. P(x,y) & P(y,z) --> P(x,z)) --> P(f(a,b), f(a,c))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Problem 58 NOT PROVED AUTOMATICALLY";
-goal HOL.thy "(! x y. f(x)=g(y)) --> (! x y. f(f(x))=f(g(y)))";
-val f_cong = read_instantiate [("f","f")] arg_cong;
-by (fast_tac (HOL_cs addIs [f_cong]) 1);
-result();
-
-writeln"Problem 59";
-goal HOL.thy "(! x. P(x) = (~P(f(x)))) --> (? x. P(x) & ~P(f(x)))";
-by (deepen_tac HOL_cs 1 1);
-result();
-
-writeln"Problem 60";
-goal HOL.thy
- "! x. P(x,f(x)) = (? y. (! z. P(z,y) --> P(z,f(x))) & P(x,y))";
-by (fast_tac HOL_cs 1);
-result();
-
-writeln"Reached end of file.";
--- a/ex/meson.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,417 +0,0 @@
-(* Title: HOL/ex/meson
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-The MESON resolution proof procedure for HOL
-
-When making clauses, avoids using the rewriter -- instead uses RS recursively
-*)
-
-writeln"File HOL/ex/meson.";
-
-(*Prove theorems using fast_tac*)
-fun prove_fun s =
- prove_goal HOL.thy s
- (fn prems => [ cut_facts_tac prems 1, fast_tac HOL_cs 1 ]);
-
-(**** Negation Normal Form ****)
-
-(*** de Morgan laws ***)
-
-val not_conjD = prove_fun "~(P&Q) ==> ~P | ~Q";
-val not_disjD = prove_fun "~(P|Q) ==> ~P & ~Q";
-val not_notD = prove_fun "~~P ==> P";
-val not_allD = prove_fun "~(! x.P(x)) ==> ? x. ~P(x)";
-val not_exD = prove_fun "~(? x.P(x)) ==> ! x. ~P(x)";
-
-
-(*** Removal of --> and <-> (positive and negative occurrences) ***)
-
-val imp_to_disjD = prove_fun "P-->Q ==> ~P | Q";
-val not_impD = prove_fun "~(P-->Q) ==> P & ~Q";
-
-val iff_to_disjD = prove_fun "P=Q ==> (~P | Q) & (~Q | P)";
-
-(*Much more efficient than (P & ~Q) | (Q & ~P) for computing CNF*)
-val not_iffD = prove_fun "~(P=Q) ==> (P | Q) & (~P | ~Q)";
-
-
-(**** Pulling out the existential quantifiers ****)
-
-(*** Conjunction ***)
-
-val conj_exD1 = prove_fun "(? x.P(x)) & Q ==> ? x. P(x) & Q";
-val conj_exD2 = prove_fun "P & (? x.Q(x)) ==> ? x. P & Q(x)";
-
-(*** Disjunction ***)
-
-(*DO NOT USE with forall-Skolemization: makes fewer schematic variables!!
- With ex-Skolemization, makes fewer Skolem constants*)
-val disj_exD = prove_fun "(? x.P(x)) | (? x.Q(x)) ==> ? x. P(x) | Q(x)";
-
-val disj_exD1 = prove_fun "(? x.P(x)) | Q ==> ? x. P(x) | Q";
-val disj_exD2 = prove_fun "P | (? x.Q(x)) ==> ? x. P | Q(x)";
-
-
-(**** Skolemization -- pulling "?" over "!" ****)
-
-(*"Axiom" of Choice, proved using the description operator*)
-val [major] = goal HOL.thy
- "! x. ? y. Q(x,y) ==> ? f. ! x. Q(x,f(x))";
-by (cut_facts_tac [major] 1);
-by (fast_tac (HOL_cs addEs [selectI]) 1);
-qed "choice";
-
-
-(***** Generating clauses for the Meson Proof Procedure *****)
-
-(*** Disjunctions ***)
-
-val disj_assoc = prove_fun "(P|Q)|R ==> P|(Q|R)";
-
-val disj_comm = prove_fun "P|Q ==> Q|P";
-
-val disj_FalseD1 = prove_fun "False|P ==> P";
-val disj_FalseD2 = prove_fun "P|False ==> P";
-
-(*** Generation of contrapositives ***)
-
-(*Inserts negated disjunct after removing the negation; P is a literal*)
-val [major,minor] = goal HOL.thy "~P|Q ==> ((~P==>P) ==> Q)";
-by (rtac (major RS disjE) 1);
-by (rtac notE 1);
-by (etac minor 2);
-by (ALLGOALS assume_tac);
-qed "make_neg_rule";
-
-(*For Plaisted's "Postive refinement" of the MESON procedure*)
-val [major,minor] = goal HOL.thy "~P|Q ==> (P ==> Q)";
-by (rtac (major RS disjE) 1);
-by (rtac notE 1);
-by (rtac minor 2);
-by (ALLGOALS assume_tac);
-qed "make_refined_neg_rule";
-
-(*P should be a literal*)
-val [major,minor] = goal HOL.thy "P|Q ==> ((P==>~P) ==> Q)";
-by (rtac (major RS disjE) 1);
-by (rtac notE 1);
-by (etac minor 1);
-by (ALLGOALS assume_tac);
-qed "make_pos_rule";
-
-(*** Generation of a goal clause -- put away the final literal ***)
-
-val [major,minor] = goal HOL.thy "~P ==> ((~P==>P) ==> False)";
-by (rtac notE 1);
-by (rtac minor 2);
-by (ALLGOALS (rtac major));
-qed "make_neg_goal";
-
-val [major,minor] = goal HOL.thy "P ==> ((P==>~P) ==> False)";
-by (rtac notE 1);
-by (rtac minor 1);
-by (ALLGOALS (rtac major));
-qed "make_pos_goal";
-
-
-(**** Lemmas for forward proof (like congruence rules) ****)
-
-(*NOTE: could handle conjunctions (faster?) by
- nf(th RS conjunct2) RS (nf(th RS conjunct1) RS conjI) *)
-val major::prems = goal HOL.thy
- "[| P'&Q'; P' ==> P; Q' ==> Q |] ==> P&Q";
-by (rtac (major RS conjE) 1);
-by (rtac conjI 1);
-by (ALLGOALS (eresolve_tac prems));
-qed "conj_forward";
-
-val major::prems = goal HOL.thy
- "[| P'|Q'; P' ==> P; Q' ==> Q |] ==> P|Q";
-by (rtac (major RS disjE) 1);
-by (ALLGOALS (dresolve_tac prems));
-by (ALLGOALS (eresolve_tac [disjI1,disjI2]));
-qed "disj_forward";
-
-val major::prems = goal HOL.thy
- "[| ! x. P'(x); !!x. P'(x) ==> P(x) |] ==> ! x. P(x)";
-by (rtac allI 1);
-by (resolve_tac prems 1);
-by (rtac (major RS spec) 1);
-qed "all_forward";
-
-val major::prems = goal HOL.thy
- "[| ? x. P'(x); !!x. P'(x) ==> P(x) |] ==> ? x. P(x)";
-by (rtac (major RS exE) 1);
-by (rtac exI 1);
-by (eresolve_tac prems 1);
-qed "ex_forward";
-
-
-(**** Operators for forward proof ****)
-
-(*raises exception if no rules apply -- unlike RL*)
-fun tryres (th, rl::rls) = (th RS rl handle THM _ => tryres(th,rls))
- | tryres (th, []) = raise THM("tryres", 0, [th]);
-
-val prop_of = #prop o rep_thm;
-
-(*Permits forward proof from rules that discharge assumptions*)
-fun forward_res nf state =
- case Sequence.pull
- (tapply(ALLGOALS (METAHYPS (fn [prem] => rtac (nf prem) 1)),
- state))
- of Some(th,_) => th
- | None => raise THM("forward_res", 0, [state]);
-
-
-(*Negation Normal Form*)
-val nnf_rls = [imp_to_disjD, iff_to_disjD, not_conjD, not_disjD,
- not_impD, not_iffD, not_allD, not_exD, not_notD];
-fun make_nnf th = make_nnf (tryres(th, nnf_rls))
- handle THM _ =>
- forward_res make_nnf
- (tryres(th, [conj_forward,disj_forward,all_forward,ex_forward]))
- handle THM _ => th;
-
-
-(*Are any of the constants in "bs" present in the term?*)
-fun has_consts bs =
- let fun has (Const(a,_)) = a mem bs
- | has (f$u) = has f orelse has u
- | has (Abs(_,_,t)) = has t
- | has _ = false
- in has end;
-
-(*Pull existential quantifiers (Skolemization)*)
-fun skolemize th =
- if not (has_consts ["Ex"] (prop_of th)) then th
- else skolemize (tryres(th, [choice, conj_exD1, conj_exD2,
- disj_exD, disj_exD1, disj_exD2]))
- handle THM _ =>
- skolemize (forward_res skolemize
- (tryres (th, [conj_forward, disj_forward, all_forward])))
- handle THM _ => forward_res skolemize (th RS ex_forward);
-
-
-(**** Clause handling ****)
-
-fun literals (Const("Trueprop",_) $ P) = literals P
- | literals (Const("op |",_) $ P $ Q) = literals P @ literals Q
- | literals (Const("not",_) $ P) = [(false,P)]
- | literals P = [(true,P)];
-
-(*number of literals in a term*)
-val nliterals = length o literals;
-
-(*to delete tautologous clauses*)
-fun taut_lits [] = false
- | taut_lits ((flg,t)::ts) = (not flg,t) mem ts orelse taut_lits ts;
-
-val is_taut = taut_lits o literals o prop_of;
-
-
-(*Generation of unique names -- maxidx cannot be relied upon to increase!
- Cannot rely on "variant", since variables might coincide when literals
- are joined to make a clause...
- 19 chooses "U" as the first variable name*)
-val name_ref = ref 19;
-
-(*Replaces universally quantified variables by FREE variables -- because
- assumptions may not contain scheme variables. Later, call "generalize". *)
-fun freeze_spec th =
- let val sth = th RS spec
- val newname = (name_ref := !name_ref + 1;
- radixstring(26, "A", !name_ref))
- in read_instantiate [("x", newname)] sth end;
-
-fun resop nf [prem] = resolve_tac (nf prem) 1;
-
-(*Conjunctive normal form, detecting tautologies early.
- Strips universal quantifiers and breaks up conjunctions. *)
-fun cnf_aux seen (th,ths) =
- if taut_lits (literals(prop_of th) @ seen) then ths
- else if not (has_consts ["All","op &"] (prop_of th)) then th::ths
- else (*conjunction?*)
- cnf_aux seen (th RS conjunct1,
- cnf_aux seen (th RS conjunct2, ths))
- handle THM _ => (*universal quant?*)
- cnf_aux seen (freeze_spec th, ths)
- handle THM _ => (*disjunction?*)
- let val tac =
- (METAHYPS (resop (cnf_nil seen)) 1) THEN
- (STATE (fn st' =>
- METAHYPS (resop (cnf_nil (literals (concl_of st') @ seen))) 1))
- in Sequence.list_of_s (tapply(tac, th RS disj_forward)) @ ths
- end
-and cnf_nil seen th = cnf_aux seen (th,[]);
-
-(*Top-level call to cnf -- it's safe to reset name_ref*)
-fun cnf (th,ths) =
- (name_ref := 19; cnf (th RS conjunct1, cnf (th RS conjunct2, ths))
- handle THM _ => (*not a conjunction*) cnf_aux [] (th, ths));
-
-(**** Removal of duplicate literals ****)
-
-(*Version for removal of duplicate literals*)
-val major::prems = goal HOL.thy
- "[| P'|Q'; P' ==> P; [| Q'; P==>False |] ==> Q |] ==> P|Q";
-by (rtac (major RS disjE) 1);
-by (rtac disjI1 1);
-by (rtac (disjCI RS disj_comm) 2);
-by (ALLGOALS (eresolve_tac prems));
-by (etac notE 1);
-by (assume_tac 1);
-qed "disj_forward2";
-
-(*Forward proof, passing extra assumptions as theorems to the tactic*)
-fun forward_res2 nf hyps state =
- case Sequence.pull
- (tapply(REPEAT
- (METAHYPS (fn major::minors => rtac (nf (minors@hyps) major) 1) 1),
- state))
- of Some(th,_) => th
- | None => raise THM("forward_res2", 0, [state]);
-
-(*Remove duplicates in P|Q by assuming ~P in Q
- rls (initially []) accumulates assumptions of the form P==>False*)
-fun nodups_aux rls th = nodups_aux rls (th RS disj_assoc)
- handle THM _ => tryres(th,rls)
- handle THM _ => tryres(forward_res2 nodups_aux rls (th RS disj_forward2),
- [disj_FalseD1, disj_FalseD2, asm_rl])
- handle THM _ => th;
-
-(*Remove duplicate literals, if there are any*)
-fun nodups th =
- if null(findrep(literals(prop_of th))) then th
- else nodups_aux [] th;
-
-
-(**** Generation of contrapositives ****)
-
-(*Associate disjuctions to right -- make leftmost disjunct a LITERAL*)
-fun assoc_right th = assoc_right (th RS disj_assoc)
- handle THM _ => th;
-
-(*Must check for negative literal first!*)
-val clause_rules = [disj_assoc, make_neg_rule, make_pos_rule];
-val refined_clause_rules = [disj_assoc, make_refined_neg_rule, make_pos_rule];
-
-(*Create a goal or support clause, conclusing False*)
-fun make_goal th = (*Must check for negative literal first!*)
- make_goal (tryres(th, clause_rules))
- handle THM _ => tryres(th, [make_neg_goal, make_pos_goal]);
-
-(*Sort clauses by number of literals*)
-fun fewerlits(th1,th2) = nliterals(prop_of th1) < nliterals(prop_of th2);
-
-(*TAUTOLOGY CHECK SHOULD NOT BE NECESSARY!*)
-fun sort_clauses ths = sort fewerlits (filter (not o is_taut) ths);
-
-(*Convert all suitable free variables to schematic variables*)
-fun generalize th = forall_elim_vars 0 (forall_intr_frees th);
-
-(*make clauses from a list of theorems*)
-fun make_clauses ths =
- sort_clauses (map (generalize o nodups) (foldr cnf (ths,[])));
-
-(*Create a Horn clause*)
-fun make_horn crules th = make_horn crules (tryres(th,crules))
- handle THM _ => th;
-
-(*Generate Horn clauses for all contrapositives of a clause*)
-fun add_contras crules (th,hcs) =
- let fun rots (0,th) = hcs
- | rots (k,th) = zero_var_indexes (make_horn crules th) ::
- rots(k-1, assoc_right (th RS disj_comm))
- in case nliterals(prop_of th) of
- 1 => th::hcs
- | n => rots(n, assoc_right th)
- end;
-
-(*Convert a list of clauses to (contrapositive) Horn clauses*)
-fun make_horns ths = foldr (add_contras clause_rules) (ths,[]);
-
-(*Find an all-negative support clause*)
-fun is_negative th = forall (not o #1) (literals (prop_of th));
-
-val neg_clauses = filter is_negative;
-
-
-(***** MESON PROOF PROCEDURE *****)
-
-fun rhyps (Const("==>",_) $ (Const("Trueprop",_) $ A) $ phi,
- As) = rhyps(phi, A::As)
- | rhyps (_, As) = As;
-
-(** Detecting repeated assumptions in a subgoal **)
-
-(*The stringtree detects repeated assumptions.*)
-fun ins_term (net,t) = Net.insert_term((t,t), net, op aconv);
-
-(*detects repetitions in a list of terms*)
-fun has_reps [] = false
- | has_reps [_] = false
- | has_reps [t,u] = (t aconv u)
- | has_reps ts = (foldl ins_term (Net.empty, ts); false)
- handle INSERT => true;
-
-(*Loop checking: FAIL if trying to prove the same thing twice
- -- repeated literals*)
-val check_tac = SUBGOAL (fn (prem,_) =>
- if has_reps (rhyps(prem,[])) then no_tac else all_tac);
-
-(* net_resolve_tac actually made it slower... *)
-fun prolog_step_tac horns i =
- (assume_tac i APPEND resolve_tac horns i) THEN
- (ALLGOALS check_tac) THEN
- (TRYALL eq_assume_tac);
-
-
-(*Sums the sizes of the subgoals, ignoring hypotheses (ancestors)*)
-local fun addconcl(prem,sz) = size_of_term (Logic.strip_assums_concl prem) + sz
-in
-fun size_of_subgoals st = foldr addconcl (prems_of st, 0)
-end;
-
-(*Could simply use nprems_of, which would count remaining subgoals -- no
- discrimination as to their size! With BEST_FIRST, fails for problem 41.*)
-
-fun best_prolog_tac sizef horns =
- BEST_FIRST (has_fewer_prems 1, sizef) (prolog_step_tac horns 1);
-
-fun depth_prolog_tac horns =
- DEPTH_FIRST (has_fewer_prems 1) (prolog_step_tac horns 1);
-
-(*Return all negative clauses, as possible goal clauses*)
-fun gocls cls = map make_goal (neg_clauses cls);
-
-
-fun skolemize_tac prems =
- cut_facts_tac (map (skolemize o make_nnf) prems) THEN'
- REPEAT o (etac exE);
-
-fun MESON sko_tac = SELECT_GOAL
- (EVERY1 [rtac ccontr,
- METAHYPS (fn negs =>
- EVERY1 [skolemize_tac negs,
- METAHYPS (sko_tac o make_clauses)])]);
-
-fun best_meson_tac sizef =
- MESON (fn cls =>
- resolve_tac (gocls cls) 1
- THEN_BEST_FIRST
- (has_fewer_prems 1, sizef,
- prolog_step_tac (make_horns cls) 1));
-
-(*First, breaks the goal into independent units*)
-val safe_meson_tac =
- SELECT_GOAL (TRY (safe_tac HOL_cs) THEN
- TRYALL (best_meson_tac size_of_subgoals));
-
-val depth_meson_tac =
- MESON (fn cls => EVERY [resolve_tac (gocls cls) 1,
- depth_prolog_tac (make_horns cls)]);
-
-writeln"Reached end of file.";
--- a/ex/mesontest.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,496 +0,0 @@
-(* Title: HOL/ex/meson
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-Test data for the MESON proof procedure
- (Excludes the equality problems 51, 52, 56, 58)
-
-show_hyps:=false;
-
-by (rtac ccontr 1);
-val [prem] = gethyps 1;
-val nnf = make_nnf prem;
-val xsko = skolemize nnf;
-by (cut_facts_tac [xsko] 1 THEN REPEAT (etac exE 1));
-val [_,sko] = gethyps 1;
-val clauses = make_clauses [sko];
-val horns = make_horns clauses;
-val go::_ = neg_clauses clauses;
-
-goal HOL.thy "False";
-by (rtac (make_goal go) 1);
-by (prolog_step_tac horns 1);
-by (depth_prolog_tac horns);
-by (best_prolog_tac size_of_subgoals horns);
-*)
-
-writeln"File HOL/ex/meson-test.";
-
-(**** Interactive examples ****)
-
-(*Generate nice names for Skolem functions*)
-Logic.auto_rename := true; Logic.set_rename_prefix "a";
-
-
-writeln"Problem 25";
-goal HOL.thy "(? x. P(x)) & \
-\ (! x. L(x) --> ~ (M(x) & R(x))) & \
-\ (! x. P(x) --> (M(x) & L(x))) & \
-\ ((! x. P(x)-->Q(x)) | (? x. P(x)&R(x))) \
-\ --> (? x. Q(x)&P(x))";
-by (rtac ccontr 1);
-val [prem25] = gethyps 1;
-val nnf25 = make_nnf prem25;
-val xsko25 = skolemize nnf25;
-by (cut_facts_tac [xsko25] 1 THEN REPEAT (etac exE 1));
-val [_,sko25] = gethyps 1;
-val clauses25 = make_clauses [sko25]; (*7 clauses*)
-val horns25 = make_horns clauses25; (*16 Horn clauses*)
-val go25::_ = neg_clauses clauses25;
-
-goal HOL.thy "False";
-by (rtac (make_goal go25) 1);
-by (depth_prolog_tac horns25);
-
-
-writeln"Problem 26";
-goal HOL.thy "((? x. p(x)) = (? x. q(x))) & \
-\ (! x. ! y. p(x) & q(y) --> (r(x) = s(y))) \
-\ --> ((! x. p(x)-->r(x)) = (! x. q(x)-->s(x)))";
-by (rtac ccontr 1);
-val [prem26] = gethyps 1;
-val nnf26 = make_nnf prem26;
-val xsko26 = skolemize nnf26;
-by (cut_facts_tac [xsko26] 1 THEN REPEAT (etac exE 1));
-val [_,sko26] = gethyps 1;
-val clauses26 = make_clauses [sko26]; (*9 clauses*)
-val horns26 = make_horns clauses26; (*24 Horn clauses*)
-val go26::_ = neg_clauses clauses26;
-
-goal HOL.thy "False";
-by (rtac (make_goal go26) 1);
-by (depth_prolog_tac horns26); (*6 secs*)
-
-
-
-writeln"Problem 43 NOW PROVED AUTOMATICALLY!!";
-goal HOL.thy "(! x. ! y. q(x,y) = (! z. p(z,x) = (p(z,y)::bool))) \
-\ --> (! x. (! y. q(x,y) = (q(y,x)::bool)))";
-by (rtac ccontr 1);
-val [prem43] = gethyps 1;
-val nnf43 = make_nnf prem43;
-val xsko43 = skolemize nnf43;
-by (cut_facts_tac [xsko43] 1 THEN REPEAT (etac exE 1));
-val [_,sko43] = gethyps 1;
-val clauses43 = make_clauses [sko43]; (*6*)
-val horns43 = make_horns clauses43; (*16*)
-val go43::_ = neg_clauses clauses43;
-
-goal HOL.thy "False";
-by (rtac (make_goal go43) 1);
-by (best_prolog_tac size_of_subgoals horns43);
-(*8.7 secs*)
-
-
-(*Restore variable name preservation*)
-Logic.auto_rename := false;
-
-
-(**** Batch test data ****)
-
-(*Sample problems from
- F. J. Pelletier,
- Seventy-Five Problems for Testing Automatic Theorem Provers,
- J. Automated Reasoning 2 (1986), 191-216.
- Errata, JAR 4 (1988), 236-236.
-
-The hardest problems -- judging by experience with several theorem provers,
-including matrix ones -- are 34 and 43.
-*)
-
-writeln"Pelletier's examples";
-(*1*)
-goal HOL.thy "(P-->Q) = (~Q --> ~P)";
-by (safe_meson_tac 1);
-result();
-
-(*2*)
-goal HOL.thy "(~ ~ P) = P";
-by (safe_meson_tac 1);
-result();
-
-(*3*)
-goal HOL.thy "~(P-->Q) --> (Q-->P)";
-by (safe_meson_tac 1);
-result();
-
-(*4*)
-goal HOL.thy "(~P-->Q) = (~Q --> P)";
-by (safe_meson_tac 1);
-result();
-
-(*5*)
-goal HOL.thy "((P|Q)-->(P|R)) --> (P|(Q-->R))";
-by (safe_meson_tac 1);
-result();
-
-(*6*)
-goal HOL.thy "P | ~ P";
-by (safe_meson_tac 1);
-result();
-
-(*7*)
-goal HOL.thy "P | ~ ~ ~ P";
-by (safe_meson_tac 1);
-result();
-
-(*8. Peirce's law*)
-goal HOL.thy "((P-->Q) --> P) --> P";
-by (safe_meson_tac 1);
-result();
-
-(*9*)
-goal HOL.thy "((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)";
-by (safe_meson_tac 1);
-result();
-
-(*10*)
-goal HOL.thy "(Q-->R) & (R-->P&Q) & (P-->Q|R) --> (P=Q)";
-by (safe_meson_tac 1);
-result();
-
-(*11. Proved in each direction (incorrectly, says Pelletier!!) *)
-goal HOL.thy "P=(P::bool)";
-by (safe_meson_tac 1);
-result();
-
-(*12. "Dijkstra's law"*)
-goal HOL.thy "((P = Q) = R) = (P = (Q = R))";
-by (best_meson_tac size_of_subgoals 1);
-result();
-
-(*13. Distributive law*)
-goal HOL.thy "(P | (Q & R)) = ((P | Q) & (P | R))";
-by (safe_meson_tac 1);
-result();
-
-(*14*)
-goal HOL.thy "(P = Q) = ((Q | ~P) & (~Q|P))";
-by (safe_meson_tac 1);
-result();
-
-(*15*)
-goal HOL.thy "(P --> Q) = (~P | Q)";
-by (safe_meson_tac 1);
-result();
-
-(*16*)
-goal HOL.thy "(P-->Q) | (Q-->P)";
-by (safe_meson_tac 1);
-result();
-
-(*17*)
-goal HOL.thy "((P & (Q-->R))-->S) = ((~P | Q | S) & (~P | ~R | S))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Classical Logic: examples with quantifiers";
-
-goal HOL.thy "(! x. P(x) & Q(x)) = ((! x. P(x)) & (! x. Q(x)))";
-by (safe_meson_tac 1);
-result();
-
-goal HOL.thy "(? x. P-->Q(x)) = (P --> (? x.Q(x)))";
-by (safe_meson_tac 1);
-result();
-
-goal HOL.thy "(? x.P(x)-->Q) = ((! x.P(x)) --> Q)";
-by (safe_meson_tac 1);
-result();
-
-goal HOL.thy "((! x.P(x)) | Q) = (! x. P(x) | Q)";
-by (safe_meson_tac 1);
-result();
-
-writeln"Testing the complete tactic";
-
-(*Not provable by pc_tac: needs multiple instantiation of !.
- Could be proved trivially by a PROLOG interpreter*)
-goal HOL.thy "(! x. P(x)-->P(f(x))) & P(d)-->P(f(f(f(d))))";
-by (safe_meson_tac 1);
-result();
-
-(*Not provable by pc_tac: needs double instantiation of EXISTS*)
-goal HOL.thy "? x. P(x) --> P(a) & P(b)";
-by (safe_meson_tac 1);
-result();
-
-goal HOL.thy "? z. P(z) --> (! x. P(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Hard examples with quantifiers";
-
-writeln"Problem 18";
-goal HOL.thy "? y. ! x. P(y)-->P(x)";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 19";
-goal HOL.thy "? x. ! y z. (P(y)-->Q(z)) --> (P(x)-->Q(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 20";
-goal HOL.thy "(! x y. ? z. ! w. (P(x)&Q(y)-->R(z)&S(w))) \
-\ --> (? x y. P(x) & Q(y)) --> (? z. R(z))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 21";
-goal HOL.thy "(? x. P-->Q(x)) & (? x. Q(x)-->P) --> (? x. P=Q(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 22";
-goal HOL.thy "(! x. P = Q(x)) --> (P = (! x. Q(x)))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 23";
-goal HOL.thy "(! x. P | Q(x)) = (P | (! x. Q(x)))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 24";
-goal HOL.thy "~(? x. S(x)&Q(x)) & (! x. P(x) --> Q(x)|R(x)) & \
-\ ~(? x.P(x)) --> (? x.Q(x)) & (! x. Q(x)|R(x) --> S(x)) \
-\ --> (? x. P(x)&R(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 25";
-goal HOL.thy "(? x. P(x)) & \
-\ (! x. L(x) --> ~ (M(x) & R(x))) & \
-\ (! x. P(x) --> (M(x) & L(x))) & \
-\ ((! x. P(x)-->Q(x)) | (? x. P(x)&R(x))) \
-\ --> (? x. Q(x)&P(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 26";
-goal HOL.thy "((? x. p(x)) = (? x. q(x))) & \
-\ (! x. ! y. p(x) & q(y) --> (r(x) = s(y))) \
-\ --> ((! x. p(x)-->r(x)) = (! x. q(x)-->s(x)))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 27";
-goal HOL.thy "(? x. P(x) & ~Q(x)) & \
-\ (! x. P(x) --> R(x)) & \
-\ (! x. M(x) & L(x) --> P(x)) & \
-\ ((? x. R(x) & ~ Q(x)) --> (! x. L(x) --> ~ R(x))) \
-\ --> (! x. M(x) --> ~L(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 28. AMENDED";
-goal HOL.thy "(! x. P(x) --> (! x. Q(x))) & \
-\ ((! x. Q(x)|R(x)) --> (? x. Q(x)&S(x))) & \
-\ ((? x.S(x)) --> (! x. L(x) --> M(x))) \
-\ --> (! x. P(x) & L(x) --> M(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 29. Essentially the same as Principia Mathematica *11.71";
-goal HOL.thy "(? x. F(x)) & (? y. G(y)) \
-\ --> ( ((! x. F(x)-->H(x)) & (! y. G(y)-->J(y))) = \
-\ (! x y. F(x) & G(y) --> H(x) & J(y)))";
-by (safe_meson_tac 1); (*5 secs*)
-result();
-
-writeln"Problem 30";
-goal HOL.thy "(! x. P(x) | Q(x) --> ~ R(x)) & \
-\ (! x. (Q(x) --> ~ S(x)) --> P(x) & R(x)) \
-\ --> (! x. S(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 31";
-goal HOL.thy "~(? x.P(x) & (Q(x) | R(x))) & \
-\ (? x. L(x) & P(x)) & \
-\ (! x. ~ R(x) --> M(x)) \
-\ --> (? x. L(x) & M(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 32";
-goal HOL.thy "(! x. P(x) & (Q(x)|R(x))-->S(x)) & \
-\ (! x. S(x) & R(x) --> L(x)) & \
-\ (! x. M(x) --> R(x)) \
-\ --> (! x. P(x) & M(x) --> L(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 33";
-goal HOL.thy "(! x. P(a) & (P(x)-->P(b))-->P(c)) = \
-\ (! x. (~P(a) | P(x) | P(c)) & (~P(a) | ~P(b) | P(c)))";
-by (safe_meson_tac 1); (*5.6 secs*)
-result();
-
-writeln"Problem 34 AMENDED (TWICE!!)";
-(*Andrews's challenge*)
-goal HOL.thy "((? x. ! y. p(x) = p(y)) = \
-\ ((? x. q(x)) = (! y. p(y)))) = \
-\ ((? x. ! y. q(x) = q(y)) = \
-\ ((? x. p(x)) = (! y. q(y))))";
-by (safe_meson_tac 1); (*90 secs*)
-result();
-
-writeln"Problem 35";
-goal HOL.thy "? x y. P(x,y) --> (! u v. P(u,v))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 36";
-goal HOL.thy "(! x. ? y. J(x,y)) & \
-\ (! x. ? y. G(x,y)) & \
-\ (! x y. J(x,y) | G(x,y) --> \
-\ (! z. J(y,z) | G(y,z) --> H(x,z))) \
-\ --> (! x. ? y. H(x,y))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 37";
-goal HOL.thy "(! z. ? w. ! x. ? y. \
-\ (P(x,z)-->P(y,w)) & P(y,z) & (P(y,w) --> (? u.Q(u,w)))) & \
-\ (! x z. ~P(x,z) --> (? y. Q(y,z))) & \
-\ ((? x y. Q(x,y)) --> (! x. R(x,x))) \
-\ --> (! x. ? y. R(x,y))";
-by (safe_meson_tac 1); (*causes unification tracing messages*)
-result();
-
-writeln"Problem 38";
-goal HOL.thy
- "(! x. p(a) & (p(x) --> (? y. p(y) & r(x,y))) --> \
-\ (? z. ? w. p(z) & r(x,w) & r(w,z))) = \
-\ (! x. (~p(a) | p(x) | (? z. ? w. p(z) & r(x,w) & r(w,z))) & \
-\ (~p(a) | ~(? y. p(y) & r(x,y)) | \
-\ (? z. ? w. p(z) & r(x,w) & r(w,z))))";
-by (safe_meson_tac 1); (*62 secs*)
-result();
-
-writeln"Problem 39";
-goal HOL.thy "~ (? x. ! y. F(y,x) = (~F(y,y)))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 40. AMENDED";
-goal HOL.thy "(? y. ! x. F(x,y) = F(x,x)) \
-\ --> ~ (! x. ? y. ! z. F(z,y) = (~F(z,x)))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 41";
-goal HOL.thy "(! z. (? y. (! x. f(x,y) = (f(x,z) & ~ f(x,x))))) \
-\ --> ~ (? z. ! x. f(x,z))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 42";
-goal HOL.thy "~ (? y. ! x. p(x,y) = (~ (? z. p(x,z) & p(z,x))))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 43 NOW PROVED AUTOMATICALLY!!";
-goal HOL.thy "(! x. ! y. q(x,y) = (! z. p(z,x) = (p(z,y)::bool))) \
-\ --> (! x. (! y. q(x,y) = (q(y,x)::bool)))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 44";
-goal HOL.thy "(! x. f(x) --> \
-\ (? y. g(y) & h(x,y) & (? y. g(y) & ~ h(x,y)))) & \
-\ (? x. j(x) & (! y. g(y) --> h(x,y))) \
-\ --> (? x. j(x) & ~f(x))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 45";
-goal HOL.thy "(! x. f(x) & (! y. g(y) & h(x,y) --> j(x,y)) \
-\ --> (! y. g(y) & h(x,y) --> k(y))) & \
-\ ~ (? y. l(y) & k(y)) & \
-\ (? x. f(x) & (! y. h(x,y) --> l(y)) \
-\ & (! y. g(y) & h(x,y) --> j(x,y))) \
-\ --> (? x. f(x) & ~ (? y. g(y) & h(x,y)))";
-by (safe_meson_tac 1); (*11 secs*)
-result();
-
-writeln"Problem 46";
-goal HOL.thy
- "(! x. f(x) & (! y. f(y) & h(y,x) --> g(y)) --> g(x)) & \
-\ ((? x.f(x) & ~g(x)) --> \
-\ (? x. f(x) & ~g(x) & (! y. f(y) & ~g(y) --> j(x,y)))) & \
-\ (! x y. f(x) & f(y) & h(x,y) --> ~j(y,x)) \
-\ --> (! x. f(x) --> g(x))";
-by (safe_meson_tac 1); (*11 secs*)
-result();
-
-(* Example suggested by Johannes Schumann and credited to Pelletier *)
-goal HOL.thy "(!x y z. P(x,y) --> P(y,z) --> P(x,z)) --> \
-\ (!x y z. Q(x,y) --> Q(y,z) --> Q(x,z)) --> \
-\ (!x y.Q(x,y) --> Q(y,x)) --> (!x y. P(x,y) | Q(x,y)) --> \
-\ (!x y.P(x,y)) | (!x y.Q(x,y))";
-by (safe_meson_tac 1); (*32 secs*)
-result();
-
-writeln"Problem 50";
-(*What has this to do with equality?*)
-goal HOL.thy "(! x. P(a,x) | (! y.P(x,y))) --> (? x. ! y.P(x,y))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 55";
-
-(*Non-equational version, from Manthey and Bry, CADE-9 (Springer, 1988).
- meson_tac cannot report who killed Agatha. *)
-goal HOL.thy "lives(agatha) & lives(butler) & lives(charles) & \
-\ (killed(agatha,agatha) | killed(butler,agatha) | killed(charles,agatha)) & \
-\ (!x y. killed(x,y) --> hates(x,y) & ~richer(x,y)) & \
-\ (!x. hates(agatha,x) --> ~hates(charles,x)) & \
-\ (hates(agatha,agatha) & hates(agatha,charles)) & \
-\ (!x. lives(x) & ~richer(x,agatha) --> hates(butler,x)) & \
-\ (!x. hates(agatha,x) --> hates(butler,x)) & \
-\ (!x. ~hates(x,agatha) | ~hates(x,butler) | ~hates(x,charles)) --> \
-\ (? x. killed(x,agatha))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 57";
-goal HOL.thy
- "P(f(a,b), f(b,c)) & P(f(b,c), f(a,c)) & \
-\ (! x y z. P(x,y) & P(y,z) --> P(x,z)) --> P(f(a,b), f(a,c))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 58";
-(* Challenge found on info-hol *)
-goal HOL.thy
- "! P Q R x. ? v w. ! y z. P(x) & Q(y) --> (P(v) | R(w)) & (R(z) --> Q(v))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 59";
-goal HOL.thy "(! x. P(x) = (~P(f(x)))) --> (? x. P(x) & ~P(f(x)))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Problem 60";
-goal HOL.thy "! x. P(x,f(x)) = (? y. (! z. P(z,y) --> P(z,f(x))) & P(x,y))";
-by (safe_meson_tac 1);
-result();
-
-writeln"Reached end of file.";
-
-(*26 August 1992: loaded in 277 secs. New Jersey v 75*)
--- a/ex/rel.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,109 +0,0 @@
-(* Title: HOL/ex/rel
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-Domain, range of a relation or function -- NOT YET WORKING
-*)
-
-structure Rel =
-struct
-val thy = extend_theory Univ.thy "Rel"
-([], [], [], [],
- [
- (["domain"], "('a * 'b)set => 'a set"),
- (["range2"], "('a * 'b)set => 'b set"),
- (["field"], "('a * 'a)set => 'a set")
- ],
- None)
- [
- ("domain_def", "domain(r) == {a. ? b. <a,b> : r}" ),
- ("range2_def", "range2(r) == {b. ? a. <a,b> : r}" ),
- ("field_def", "field(r) == domain(r) Un range2(r)" )
- ];
-end;
-
-local val ax = get_axiom Rel.thy
-in
-val domain_def = ax"domain_def";
-val range2_def = ax"range2_def";
-val field_def = ax"field_def";
-end;
-
-
-(*** domain ***)
-
-val [prem] = goalw Rel.thy [domain_def,Pair_def] "<a,b>: r ==> a : domain(r)";
-by (fast_tac (set_cs addIs [prem]) 1);
-qed "domainI";
-
-val major::prems = goalw Rel.thy [domain_def]
- "[| a : domain(r); !!y. <a,y>: r ==> P |] ==> P";
-by (rtac (major RS CollectE) 1);
-by (etac exE 1);
-by (REPEAT (ares_tac prems 1));
-qed "domainE";
-
-
-(*** range2 ***)
-
-val [prem] = goalw Rel.thy [range2_def,Pair_def] "<a,b>: r ==> b : range2(r)";
-by (fast_tac (set_cs addIs [prem]) 1);
-qed "range2I";
-
-val major::prems = goalw Rel.thy [range2_def]
- "[| b : range2(r); !!x. <x,b>: r ==> P |] ==> P";
-by (rtac (major RS CollectE) 1);
-by (etac exE 1);
-by (REPEAT (ares_tac prems 1));
-qed "range2E";
-
-
-(*** field ***)
-
-val [prem] = goalw Rel.thy [field_def] "<a,b>: r ==> a : field(r)";
-by (rtac (prem RS domainI RS UnI1) 1);
-qed "fieldI1";
-
-val [prem] = goalw Rel.thy [field_def] "<a,b>: r ==> b : field(r)";
-by (rtac (prem RS range2I RS UnI2) 1);
-qed "fieldI2";
-
-val [prem] = goalw Rel.thy [field_def]
- "(~ <c,a>:r ==> <a,b>: r) ==> a : field(r)";
-by (rtac (prem RS domainI RS UnCI) 1);
-by (swap_res_tac [range2I] 1);
-by (etac notnotD 1);
-qed "fieldCI";
-
-val major::prems = goalw Rel.thy [field_def]
- "[| a : field(r); \
-\ !!x. <a,x>: r ==> P; \
-\ !!x. <x,a>: r ==> P |] ==> P";
-by (rtac (major RS UnE) 1);
-by (REPEAT (eresolve_tac (prems@[domainE,range2E]) 1));
-qed "fieldE";
-
-goalw Rel.thy [field_def] "domain(r) <= field(r)";
-by (rtac Un_upper1 1);
-qed "domain_in_field";
-
-goalw Rel.thy [field_def] "range2(r) <= field(r)";
-by (rtac Un_upper2 1);
-qed "range2_in_field";
-
-
-????????????????????????????????????????????????????????????????;
-
-(*If r allows well-founded induction then wf(r)*)
-val [prem1,prem2] = goalw Rel.thy [wf_def]
- "[| field(r)<=A; \
-\ !!P u. ! x:A. (! y. <y,x>: r --> P(y)) --> P(x) ==> P(u) |] \
-\ ==> wf(r)";
-by (rtac (prem1 RS wfI) 1);
-by (res_inst_tac [ ("B", "A-Z") ] (prem2 RS subsetCE) 1);
-by (fast_tac ZF_cs 3);
-by (fast_tac ZF_cs 2);
-by (fast_tac ZF_cs 1);
-qed "wfI2";
-
--- a/ex/set.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,132 +0,0 @@
-(* Title: HOL/ex/set.ML
- ID: $Id$
- Author: Tobias Nipkow, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-Cantor's Theorem; the Schroeder-Berstein Theorem.
-*)
-
-
-writeln"File HOL/ex/set.";
-
-(*** A unique fixpoint theorem --- fast/best/meson all fail ***)
-
-val [prem] = goal HOL.thy "?!x.f(g(x))=x ==> ?!y.g(f(y))=y";
-by(EVERY1[rtac (prem RS ex1E), rtac ex1I, etac arg_cong,
- rtac subst, atac, etac allE, rtac arg_cong, etac mp, etac arg_cong]);
-result();
-
-(*** Cantor's Theorem: There is no surjection from a set to its powerset. ***)
-
-goal Set.thy "~ (? f:: 'a=>'a set. ! S. ? x. f(x) = S)";
-(*requires best-first search because it is undirectional*)
-by (best_tac (set_cs addSEs [equalityCE]) 1);
-qed "cantor1";
-
-(*This form displays the diagonal term*)
-goal Set.thy "! f:: 'a=>'a set. ! x. f(x) ~= ?S(f)";
-by (best_tac (set_cs addSEs [equalityCE]) 1);
-uresult();
-
-(*This form exploits the set constructs*)
-goal Set.thy "?S ~: range(f :: 'a=>'a set)";
-by (rtac notI 1);
-by (etac rangeE 1);
-by (etac equalityCE 1);
-by (dtac CollectD 1);
-by (contr_tac 1);
-by (swap_res_tac [CollectI] 1);
-by (assume_tac 1);
-
-choplev 0;
-by (best_tac (set_cs addSEs [equalityCE]) 1);
-
-(*** The Schroder-Berstein Theorem ***)
-
-val prems = goalw Lfp.thy [image_def] "inj(f) ==> Inv(f)``(f``X) = X";
-by (cut_facts_tac prems 1);
-by (rtac equalityI 1);
-by (fast_tac (set_cs addEs [Inv_f_f RS ssubst]) 1);
-by (fast_tac (set_cs addEs [Inv_f_f RS ssubst]) 1);
-qed "inv_image_comp";
-
-val prems = goal Set.thy "f(a) ~: (f``X) ==> a~:X";
-by (cfast_tac prems 1);
-qed "contra_imageI";
-
-goal Lfp.thy "(a ~: Compl(X)) = (a:X)";
-by (fast_tac set_cs 1);
-qed "not_Compl";
-
-(*Lots of backtracking in this proof...*)
-val [compl,fg,Xa] = goal Lfp.thy
- "[| Compl(f``X) = g``Compl(X); f(a)=g(b); a:X |] ==> b:X";
-by (EVERY1 [rtac (not_Compl RS subst), rtac contra_imageI,
- rtac (compl RS subst), rtac (fg RS subst), stac not_Compl,
- rtac imageI, rtac Xa]);
-qed "disj_lemma";
-
-goal Lfp.thy "range(%z. if(z:X, f(z), g(z))) = f``X Un g``Compl(X)";
-by (rtac equalityI 1);
-by (rewtac range_def);
-by (fast_tac (set_cs addIs [if_P RS sym, if_not_P RS sym]) 2);
-by (rtac subsetI 1);
-by (etac CollectE 1);
-by (etac exE 1);
-by (etac ssubst 1);
-by (rtac (excluded_middle RS disjE) 1);
-by (EVERY' [rtac (if_P RS ssubst), atac, fast_tac set_cs] 2);
-by (EVERY' [rtac (if_not_P RS ssubst), atac, fast_tac set_cs] 1);
-qed "range_if_then_else";
-
-goal Lfp.thy "a : X Un Compl(X)";
-by (fast_tac set_cs 1);
-qed "X_Un_Compl";
-
-goalw Lfp.thy [surj_def] "surj(f) = (!a. a : range(f))";
-by (fast_tac (set_cs addEs [ssubst]) 1);
-qed "surj_iff_full_range";
-
-val [compl] = goal Lfp.thy
- "Compl(f``X) = g``Compl(X) ==> surj(%z. if(z:X, f(z), g(z)))";
-by (sstac [surj_iff_full_range, range_if_then_else, compl RS sym] 1);
-by (rtac (X_Un_Compl RS allI) 1);
-qed "surj_if_then_else";
-
-val [injf,injg,compl,bij] = goal Lfp.thy
- "[| inj_onto(f,X); inj_onto(g,Compl(X)); Compl(f``X) = g``Compl(X); \
-\ bij = (%z. if(z:X, f(z), g(z))) |] ==> \
-\ inj(bij) & surj(bij)";
-val f_eq_gE = make_elim (compl RS disj_lemma);
-by (rtac (bij RS ssubst) 1);
-by (rtac conjI 1);
-by (rtac (compl RS surj_if_then_else) 2);
-by (rewtac inj_def);
-by (cut_facts_tac [injf,injg] 1);
-by (EVERY1 [rtac allI, rtac allI, stac expand_if, rtac conjI, stac expand_if]);
-by (fast_tac (set_cs addEs [inj_ontoD, sym RS f_eq_gE]) 1);
-by (stac expand_if 1);
-by (fast_tac (set_cs addEs [inj_ontoD, f_eq_gE]) 1);
-qed "bij_if_then_else";
-
-goal Lfp.thy "? X. X = Compl(g``Compl((f:: 'a=>'b)``X))";
-by (rtac exI 1);
-by (rtac lfp_Tarski 1);
-by (REPEAT (ares_tac [monoI, image_mono, Compl_anti_mono] 1));
-qed "decomposition";
-
-val [injf,injg] = goal Lfp.thy
- "[| inj(f:: 'a=>'b); inj(g:: 'b=>'a) |] ==> \
-\ ? h:: 'a=>'b. inj(h) & surj(h)";
-by (rtac (decomposition RS exE) 1);
-by (rtac exI 1);
-by (rtac bij_if_then_else 1);
-by (EVERY [rtac refl 4, rtac (injf RS inj_imp) 1,
- rtac (injg RS inj_onto_Inv) 1]);
-by (EVERY1 [etac ssubst, stac double_complement, rtac subsetI,
- etac imageE, etac ssubst, rtac rangeI]);
-by (EVERY1 [etac ssubst, stac double_complement,
- rtac (injg RS inv_image_comp RS sym)]);
-qed "schroeder_bernstein";
-
-writeln"Reached end of file.";
--- a/ex/unsolved.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,70 +0,0 @@
-(* Title: HOL/ex/unsolved
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1992 University of Cambridge
-
-Problems that currently defeat the MESON procedure as well as best_tac
-*)
-
-(*from Vladimir Lifschitz, What Is the Inverse Method?, JAR 5 (1989), 1--23*)
-goal HOL.thy "? x x'. ! y. ? z z'. (~P(y,y) | P(x,x) | ~S(z,x)) & \
-\ (S(x,y) | ~S(y,z) | Q(z',z')) & \
-\ (Q(x',y) | ~Q(y,z') | S(x',x'))";
-
-
-writeln"Problem 47 Schubert's Steamroller";
-goal HOL.thy
- "(! x. P1(x) --> P0(x)) & (? x.P1(x)) & \
-\ (! x. P2(x) --> P0(x)) & (? x.P2(x)) & \
-\ (! x. P3(x) --> P0(x)) & (? x.P3(x)) & \
-\ (! x. P4(x) --> P0(x)) & (? x.P4(x)) & \
-\ (! x. P5(x) --> P0(x)) & (? x.P5(x)) & \
-\ (! x. Q1(x) --> Q0(x)) & (? x.Q1(x)) & \
-\ (! x. P0(x) --> ((! y.Q0(y)-->R(x,y)) | \
-\ (! y.P0(y) & S(y,x) & \
-\ (? z.Q0(z)&R(y,z)) --> R(x,y)))) & \
-\ (! x y. P3(y) & (P5(x)|P4(x)) --> S(x,y)) & \
-\ (! x y. P3(x) & P2(y) --> S(x,y)) & \
-\ (! x y. P2(x) & P1(y) --> S(x,y)) & \
-\ (! x y. P1(x) & (P2(y)|Q1(y)) --> ~R(x,y)) & \
-\ (! x y. P3(x) & P4(y) --> R(x,y)) & \
-\ (! x y. P3(x) & P5(y) --> ~R(x,y)) & \
-\ (! x. (P4(x)|P5(x)) --> (? y.Q0(y) & R(x,y))) \
-\ --> (? x y. P0(x) & P0(y) & (? z. Q1(z) & R(y,z) & R(x,y)))";
-
-
-writeln"Problem 55";
-
-(*Original, equational version by Len Schubert, via Pelletier *)
-goal HOL.thy
- "(? x. lives(x) & killed(x,agatha)) & \
-\ lives(agatha) & lives(butler) & lives(charles) & \
-\ (! x. lives(x) --> x=agatha | x=butler | x=charles) & \
-\ (! x y. killed(x,y) --> hates(x,y)) & \
-\ (! x y. killed(x,y) --> ~richer(x,y)) & \
-\ (! x. hates(agatha,x) --> ~hates(charles,x)) & \
-\ (! x. ~ x=butler --> hates(agatha,x)) & \
-\ (! x. ~richer(x,agatha) --> hates(butler,x)) & \
-\ (! x. hates(agatha,x) --> hates(butler,x)) & \
-\ (! x. ? y. ~hates(x,y)) & \
-\ ~ agatha=butler --> \
-\ killed(agatha,agatha)";
-
-(** Charles Morgan's problems **)
-
-val axa = "! x y. T(i(x, i(y,x)))";
-val axb = "! x y z. T(i(i(x, i(y,z)), i(i(x,y), i(x,z))))";
-val axc = "! x y. T(i(i(n(x), n(y)), i(y,x)))";
-val axd = "! x y. T(i(x,y)) & T(x) --> T(y)";
-
-fun axjoin ([], q) = q
- | axjoin(p::ps, q) = "(" ^ p ^ ") --> (" ^ axjoin(ps,q) ^ ")";
-
-goal HOL.thy (axjoin([axa,axb,axd], "! x. T(i(x,x))"));
-
-writeln"Problem 66";
-goal HOL.thy (axjoin([axa,axb,axc,axd], "! x. T(i(x, n(n(x))))"));
-
-writeln"Problem 67";
-goal HOL.thy (axjoin([axa,axb,axc,axd], "! x. T(i(n(n(x)), x))"));
-
--- a/hologic.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,86 +0,0 @@
-(* Title: HOL/hologic.ML
- ID: $Id$
- Author: Lawrence C Paulson and Markus Wenzel
-
-Abstract syntax operations for HOL.
-*)
-
-signature HOLOGIC =
-sig
- val termC: class
- val termS: sort
- val termTVar: typ
- val boolT: typ
- val mk_setT: typ -> typ
- val dest_setT: typ -> typ
- val mk_Trueprop: term -> term
- val dest_Trueprop: term -> term
- val conj: term
- val disj: term
- val imp: term
- val eq_const: typ -> term
- val all_const: typ -> term
- val exists_const: typ -> term
- val Collect_const: typ -> term
- val mk_eq: term * term -> term
- val mk_all: string * typ * term -> term
- val mk_exists: string * typ * term -> term
- val mk_Collect: string * typ * term -> term
- val mk_mem: term * term -> term
-end;
-
-structure HOLogic: HOLOGIC =
-struct
-
-(* classes *)
-
-val termC: class = "term";
-val termS: sort = [termC];
-
-
-(* types *)
-
-val termTVar = TVar (("'a", 0), termS);
-
-val boolT = Type ("bool", []);
-
-fun mk_setT T = Type ("set", [T]);
-
-fun dest_setT (Type ("set", [T])) = T
- | dest_setT T = raise_type "dest_setT: set type expected" [T] [];
-
-
-(* terms *)
-
-val Trueprop = Const ("Trueprop", boolT --> propT);
-
-fun mk_Trueprop P = Trueprop $ P;
-
-fun dest_Trueprop (Const ("Trueprop", _) $ P) = P
- | dest_Trueprop t = raise_term "dest_Trueprop" [t];
-
-
-val conj = Const ("op &", [boolT, boolT] ---> boolT)
-and disj = Const ("op |", [boolT, boolT] ---> boolT)
-and imp = Const ("op -->", [boolT, boolT] ---> boolT);
-
-fun eq_const T = Const ("op =", [T, T] ---> boolT);
-fun mk_eq (t, u) = eq_const (fastype_of t) $ t $ u;
-
-fun all_const T = Const ("All", [T --> boolT] ---> boolT);
-fun mk_all (x, T, P) = all_const T $ absfree (x, T, P);
-
-fun exists_const T = Const ("Ex", [T --> boolT] ---> boolT);
-fun mk_exists (x, T, P) = exists_const T $ absfree (x, T, P);
-
-fun Collect_const T = Const ("Collect", [T --> boolT] ---> mk_setT T);
-fun mk_Collect (a, T, t) = Collect_const T $ absfree (a, T, t);
-
-fun mk_mem (x, A) =
- let val setT = fastype_of A in
- Const ("op :", [dest_setT setT, setT] ---> boolT) $ x $ A
- end;
-
-
-end;
-
--- a/ind_syntax.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,124 +0,0 @@
-(* Title: HOL/ind_syntax.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Abstract Syntax functions for Inductive Definitions
-See also hologic.ML and ../Pure/section-utils.ML
-*)
-
-(*The structure protects these items from redeclaration (somewhat!). The
- datatype definitions in theory files refer to these items by name!
-*)
-structure Ind_Syntax =
-struct
-
-(** Abstract syntax definitions for HOL **)
-
-open HOLogic;
-
-fun Int_const T =
- let val sT = mk_setT T
- in Const("op Int", [sT,sT]--->sT) end;
-
-fun mk_exists (Free(x,T),P) = exists_const T $ (absfree (x,T,P));
-
-fun mk_all (Free(x,T),P) = all_const T $ (absfree (x,T,P));
-
-(*Creates All(%v.v:A --> P(v)) rather than Ball(A,P) *)
-fun mk_all_imp (A,P) =
- let val T = dest_setT (fastype_of A)
- in all_const T $ Abs("v", T, imp $ (mk_mem (Bound 0, A)) $ (P $ Bound 0))
- end;
-
-(** Cartesian product type **)
-
-val unitT = Type("unit",[]);
-
-fun mk_prod (T1,T2) = Type("*", [T1,T2]);
-
-(*Maps the type T1*...*Tn to [T1,...,Tn], if nested to the right*)
-fun factors (Type("*", [T1,T2])) = T1 :: factors T2
- | factors T = [T];
-
-(*Make a correctly typed ordered pair*)
-fun mk_Pair (t1,t2) =
- let val T1 = fastype_of t1
- and T2 = fastype_of t2
- in Const("Pair", [T1, T2] ---> mk_prod(T1,T2)) $ t1 $ t2 end;
-
-fun split_const(Ta,Tb,Tc) =
- Const("split", [[Ta,Tb]--->Tc, mk_prod(Ta,Tb)] ---> Tc);
-
-(*Given u expecting arguments of types [T1,...,Tn], create term of
- type T1*...*Tn => Tc using split. Here * associates to the LEFT*)
-fun ap_split_l Tc u [ ] = Abs("null", unitT, u)
- | ap_split_l Tc u [_] = u
- | ap_split_l Tc u (Ta::Tb::Ts) = ap_split_l Tc (split_const(Ta,Tb,Tc) $ u)
- (mk_prod(Ta,Tb) :: Ts);
-
-(*Given u expecting arguments of types [T1,...,Tn], create term of
- type T1*...*Tn => i using split. Here * associates to the RIGHT*)
-fun ap_split Tc u [ ] = Abs("null", unitT, u)
- | ap_split Tc u [_] = u
- | ap_split Tc u [Ta,Tb] = split_const(Ta,Tb,Tc) $ u
- | ap_split Tc u (Ta::Ts) =
- split_const(Ta, foldr1 mk_prod Ts, Tc) $
- (Abs("v", Ta, ap_split Tc (u $ Bound(length Ts - 2)) Ts));
-
-(** Disjoint sum type **)
-
-fun mk_sum (T1,T2) = Type("+", [T1,T2]);
-val Inl = Const("Inl", dummyT)
-and Inr = Const("Inr", dummyT); (*correct types added later!*)
-(*val elim = Const("case", [iT-->iT, iT-->iT, iT]--->iT)*)
-
-fun summands (Type("+", [T1,T2])) = summands T1 @ summands T2
- | summands T = [T];
-
-(*Given the destination type, fills in correct types of an Inl/Inr nest*)
-fun mend_sum_types (h,T) =
- (case (h,T) of
- (Const("Inl",_) $ h1, Type("+", [T1,T2])) =>
- Const("Inl", T1 --> T) $ (mend_sum_types (h1, T1))
- | (Const("Inr",_) $ h2, Type("+", [T1,T2])) =>
- Const("Inr", T2 --> T) $ (mend_sum_types (h2, T2))
- | _ => h);
-
-
-
-(*simple error-checking in the premises of an inductive definition*)
-fun chk_prem rec_hd (Const("op &",_) $ _ $ _) =
- error"Premises may not be conjuctive"
- | chk_prem rec_hd (Const("op :",_) $ t $ X) =
- deny (Logic.occs(rec_hd,t)) "Recursion term on left of member symbol"
- | chk_prem rec_hd t =
- deny (Logic.occs(rec_hd,t)) "Recursion term in side formula";
-
-(*Return the conclusion of a rule, of the form t:X*)
-fun rule_concl rl =
- let val Const("Trueprop",_) $ (Const("op :",_) $ t $ X) =
- Logic.strip_imp_concl rl
- in (t,X) end;
-
-(*As above, but return error message if bad*)
-fun rule_concl_msg sign rl = rule_concl rl
- handle Bind => error ("Ill-formed conclusion of introduction rule: " ^
- Sign.string_of_term sign rl);
-
-(*For simplifying the elimination rule*)
-val sumprod_free_SEs =
- Pair_inject ::
- map make_elim [(*Inl_neq_Inr, Inr_neq_Inl, Inl_inject, Inr_inject*)];
-
-(*For deriving cases rules.
- read_instantiate replaces a propositional variable by a formula variable*)
-val equals_CollectD =
- read_instantiate [("W","?Q")]
- (make_elim (equalityD1 RS subsetD RS CollectD));
-
-(*Delete needless equality assumptions*)
-val refl_thin = prove_goal HOL.thy "!!P. [| a=a; P |] ==> P"
- (fn _ => [assume_tac 1]);
-
-end;
--- a/indrule.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,184 +0,0 @@
-(* Title: HOL/indrule.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Induction rule module -- for Inductive/Coinductive Definitions
-
-Proves a strong induction rule and a mutual induction rule
-*)
-
-signature INDRULE =
- sig
- val induct : thm (*main induction rule*)
- val mutual_induct : thm (*mutual induction rule*)
- end;
-
-
-functor Indrule_Fun
- (structure Inductive: sig include INDUCTIVE_ARG INDUCTIVE_I end and
- Intr_elim: INTR_ELIM) : INDRULE =
-struct
-open Logic Ind_Syntax Inductive Intr_elim;
-
-val sign = sign_of thy;
-
-val (Const(_,recT),rec_params) = strip_comb (hd rec_tms);
-
-val elem_type = dest_setT (body_type recT);
-val domTs = summands(elem_type);
-val big_rec_name = space_implode "_" rec_names;
-val big_rec_tm = list_comb(Const(big_rec_name,recT), rec_params);
-
-val _ = writeln " Proving the induction rules...";
-
-(*** Prove the main induction rule ***)
-
-val pred_name = "P"; (*name for predicate variables*)
-
-val big_rec_def::part_rec_defs = Intr_elim.defs;
-
-(*Used to express induction rules: adds induction hypotheses.
- ind_alist = [(rec_tm1,pred1),...] -- associates predicates with rec ops
- prem is a premise of an intr rule*)
-fun add_induct_prem ind_alist (prem as Const("Trueprop",_) $
- (Const("op :",_)$t$X), iprems) =
- (case gen_assoc (op aconv) (ind_alist, X) of
- Some pred => prem :: mk_Trueprop (pred $ t) :: iprems
- | None => (*possibly membership in M(rec_tm), for M monotone*)
- let fun mk_sb (rec_tm,pred) =
- (case binder_types (fastype_of pred) of
- [T] => (rec_tm,
- Int_const T $ rec_tm $ (Collect_const T $ pred))
- | _ => error
- "Bug: add_induct_prem called with non-unary predicate")
- in subst_free (map mk_sb ind_alist) prem :: iprems end)
- | add_induct_prem ind_alist (prem,iprems) = prem :: iprems;
-
-(*Make a premise of the induction rule.*)
-fun induct_prem ind_alist intr =
- let val quantfrees = map dest_Free (term_frees intr \\ rec_params)
- val iprems = foldr (add_induct_prem ind_alist)
- (strip_imp_prems intr,[])
- val (t,X) = rule_concl intr
- val (Some pred) = gen_assoc (op aconv) (ind_alist, X)
- val concl = mk_Trueprop (pred $ t)
- in list_all_free (quantfrees, list_implies (iprems,concl)) end
- handle Bind => error"Recursion term not found in conclusion";
-
-(*Avoids backtracking by delivering the correct premise to each goal*)
-fun ind_tac [] 0 = all_tac
- | ind_tac(prem::prems) i =
- DEPTH_SOLVE_1 (ares_tac [Part_eqI, prem, refl] i) THEN
- ind_tac prems (i-1);
-
-val pred = Free(pred_name, elem_type --> boolT);
-
-val ind_prems = map (induct_prem (map (rpair pred) rec_tms)) intr_tms;
-
-val quant_induct =
- prove_goalw_cterm part_rec_defs
- (cterm_of sign (list_implies (ind_prems,
- mk_Trueprop (mk_all_imp(big_rec_tm,pred)))))
- (fn prems =>
- [rtac (impI RS allI) 1,
- etac raw_induct 1,
- REPEAT (FIRSTGOAL (eresolve_tac [IntE, CollectE, exE, conjE, disjE]
- ORELSE' hyp_subst_tac)),
- REPEAT (FIRSTGOAL (eresolve_tac [PartE, CollectE])),
- ind_tac (rev prems) (length prems)])
- handle e => print_sign_exn sign e;
-
-(*** Prove the simultaneous induction rule ***)
-
-(*Make distinct predicates for each inductive set.
- Splits cartesian products in domT, IF nested to the right! *)
-
-(*Given a recursive set and its domain, return the "split" predicate
- and a conclusion for the simultaneous induction rule*)
-fun mk_predpair (rec_tm,domT) =
- let val rec_name = (#1 o dest_Const o head_of) rec_tm
- val T = factors domT ---> boolT
- val pfree = Free(pred_name ^ "_" ^ rec_name, T)
- val frees = mk_frees "za" (binder_types T)
- val qconcl =
- foldr mk_all (frees,
- imp $ (mk_mem (foldr1 mk_Pair frees, rec_tm))
- $ (list_comb (pfree,frees)))
- in (ap_split boolT pfree (binder_types T),
- qconcl)
- end;
-
-val (preds,qconcls) = split_list (map mk_predpair (rec_tms~~domTs));
-
-(*Used to form simultaneous induction lemma*)
-fun mk_rec_imp (rec_tm,pred) =
- imp $ (mk_mem (Bound 0, rec_tm)) $ (pred $ Bound 0);
-
-(*To instantiate the main induction rule*)
-val induct_concl =
- mk_Trueprop(mk_all_imp(big_rec_tm,
- Abs("z", elem_type,
- fold_bal (app conj)
- (map mk_rec_imp (rec_tms~~preds)))))
-and mutual_induct_concl = mk_Trueprop(fold_bal (app conj) qconcls);
-
-val lemma = (*makes the link between the two induction rules*)
- prove_goalw_cterm part_rec_defs
- (cterm_of sign (mk_implies (induct_concl,mutual_induct_concl)))
- (fn prems =>
- [cut_facts_tac prems 1,
- REPEAT (eresolve_tac [asm_rl, conjE, PartE, mp] 1
- ORELSE resolve_tac [allI, impI, conjI, Part_eqI, refl] 1
- ORELSE dresolve_tac [spec, mp, splitD] 1)])
- handle e => print_sign_exn sign e;
-
-(*Mutual induction follows by freeness of Inl/Inr.*)
-
-(*Removes Collects caused by M-operators in the intro rules*)
-val cmonos = [subset_refl RS Int_Collect_mono] RL monos RLN (2,[rev_subsetD]);
-
-(*Avoids backtracking by delivering the correct premise to each goal*)
-fun mutual_ind_tac [] 0 = all_tac
- | mutual_ind_tac(prem::prems) i =
- DETERM
- (SELECT_GOAL
- ((*unpackage and use "prem" in the corresponding place*)
- REPEAT (FIRSTGOAL
- (etac conjE ORELSE' eq_mp_tac ORELSE'
- ares_tac [impI, conjI]))
- (*prem is not allowed in the REPEAT, lest it loop!*)
- THEN TRYALL (rtac prem)
- THEN REPEAT
- (FIRSTGOAL (ares_tac [impI] ORELSE'
- eresolve_tac (mp::cmonos)))
- (*prove remaining goals by contradiction*)
- THEN rewrite_goals_tac (con_defs@part_rec_defs)
- THEN DEPTH_SOLVE (eresolve_tac (PartE :: sumprod_free_SEs) 1))
- i)
- THEN mutual_ind_tac prems (i-1);
-
-val mutual_induct_split =
- prove_goalw_cterm []
- (cterm_of sign
- (list_implies (map (induct_prem (rec_tms~~preds)) intr_tms,
- mutual_induct_concl)))
- (fn prems =>
- [rtac (quant_induct RS lemma) 1,
- mutual_ind_tac (rev prems) (length prems)])
- handle e => print_sign_exn sign e;
-
-(*Attempts to remove all occurrences of split*)
-val split_tac =
- REPEAT (SOMEGOAL (FIRST' [rtac splitI,
- dtac splitD,
- etac splitE,
- bound_hyp_subst_tac]))
- THEN prune_params_tac;
-
-(*strip quantifier*)
-val induct = standard (quant_induct RS spec RSN (2,rev_mp));
-
-val mutual_induct = rule_by_tactic split_tac mutual_induct_split;
-
-end;
--- a/intr_elim.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,141 +0,0 @@
-(* Title: HOL/intr_elim.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-
-Introduction/elimination rule module -- for Inductive/Coinductive Definitions
-*)
-
-signature INDUCTIVE_ARG = (** Description of a (co)inductive def **)
- sig
- val thy : theory (*new theory with inductive defs*)
- val monos : thm list (*monotonicity of each M operator*)
- val con_defs : thm list (*definitions of the constructors*)
- end;
-
-(*internal items*)
-signature INDUCTIVE_I =
- sig
- val rec_tms : term list (*the recursive sets*)
- val intr_tms : term list (*terms for the introduction rules*)
- end;
-
-signature INTR_ELIM =
- sig
- val thy : theory (*copy of input theory*)
- val defs : thm list (*definitions made in thy*)
- val mono : thm (*monotonicity for the lfp definition*)
- val unfold : thm (*fixed-point equation*)
- val intrs : thm list (*introduction rules*)
- val elim : thm (*case analysis theorem*)
- val raw_induct : thm (*raw induction rule from Fp.induct*)
- val mk_cases : thm list -> string -> thm (*generates case theorems*)
- val rec_names : string list (*names of recursive sets*)
- end;
-
-(*prove intr/elim rules for a fixedpoint definition*)
-functor Intr_elim_Fun
- (structure Inductive: sig include INDUCTIVE_ARG INDUCTIVE_I end
- and Fp: FP) : INTR_ELIM =
-struct
-open Logic Inductive Ind_Syntax;
-
-val rec_names = map (#1 o dest_Const o head_of) rec_tms;
-val big_rec_name = space_implode "_" rec_names;
-
-val _ = deny (big_rec_name mem map ! (stamps_of_thy thy))
- ("Definition " ^ big_rec_name ^
- " would clash with the theory of the same name!");
-
-(*fetch fp definitions from the theory*)
-val big_rec_def::part_rec_defs =
- map (get_def thy)
- (case rec_names of [_] => rec_names | _ => big_rec_name::rec_names);
-
-
-val sign = sign_of thy;
-
-(********)
-val _ = writeln " Proving monotonicity...";
-
-val Const("==",_) $ _ $ (Const(_,fpT) $ fp_abs) =
- big_rec_def |> rep_thm |> #prop |> unvarify;
-
-(*For the type of the argument of mono*)
-val [monoT] = binder_types fpT;
-
-val mono =
- prove_goalw_cterm []
- (cterm_of sign (mk_Trueprop (Const("mono", monoT-->boolT) $ fp_abs)))
- (fn _ =>
- [rtac monoI 1,
- REPEAT (ares_tac (basic_monos @ monos) 1)]);
-
-val unfold = standard (mono RS (big_rec_def RS Fp.Tarski));
-
-(********)
-val _ = writeln " Proving the introduction rules...";
-
-fun intro_tacsf disjIn prems =
- [(*insert prems and underlying sets*)
- cut_facts_tac prems 1,
- rtac (unfold RS ssubst) 1,
- REPEAT (resolve_tac [Part_eqI,CollectI] 1),
- (*Now 1-2 subgoals: the disjunction, perhaps equality.*)
- rtac disjIn 1,
- (*Not ares_tac, since refl must be tried before any equality assumptions;
- backtracking may occur if the premises have extra variables!*)
- DEPTH_SOLVE_1 (resolve_tac [refl,exI,conjI] 1 ORELSE assume_tac 1)];
-
-(*combines disjI1 and disjI2 to access the corresponding nested disjunct...*)
-val mk_disj_rls =
- let fun f rl = rl RS disjI1
- and g rl = rl RS disjI2
- in accesses_bal(f, g, asm_rl) end;
-
-val intrs = map (uncurry (prove_goalw_cterm part_rec_defs))
- (map (cterm_of sign) intr_tms ~~
- map intro_tacsf (mk_disj_rls(length intr_tms)));
-
-(********)
-val _ = writeln " Proving the elimination rule...";
-
-(*Includes rules for Suc and Pair since they are common constructions*)
-val elim_rls = [asm_rl, FalseE, Suc_neq_Zero, Zero_neq_Suc,
- make_elim Suc_inject,
- refl_thin, conjE, exE, disjE];
-
-(*Breaks down logical connectives in the monotonic function*)
-val basic_elim_tac =
- REPEAT (SOMEGOAL (eresolve_tac (elim_rls@sumprod_free_SEs)
- ORELSE' bound_hyp_subst_tac))
- THEN prune_params_tac;
-
-val elim = rule_by_tactic basic_elim_tac (unfold RS equals_CollectD);
-
-(*Applies freeness of the given constructors, which *must* be unfolded by
- the given defs. Cannot simply use the local con_defs because con_defs=[]
- for inference systems.
-fun con_elim_tac defs =
- rewrite_goals_tac defs THEN basic_elim_tac THEN fold_tac defs;
- *)
-fun con_elim_tac simps =
- let val elim_tac = REPEAT o (eresolve_tac (elim_rls@sumprod_free_SEs))
- in ALLGOALS(EVERY'[elim_tac,
- asm_full_simp_tac (nat_ss addsimps simps),
- elim_tac,
- REPEAT o bound_hyp_subst_tac])
- THEN prune_params_tac
- end;
-
-
-(*String s should have the form t:Si where Si is an inductive set*)
-fun mk_cases defs s =
- rule_by_tactic (con_elim_tac defs)
- (assume_read thy s RS elim);
-
-val defs = big_rec_def::part_rec_defs;
-
-val raw_induct = standard ([big_rec_def, mono] MRS Fp.induct);
-end;
-
--- a/mono.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,123 +0,0 @@
-(* Title: HOL/mono
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-Monotonicity of various operations
-*)
-
-goal Set.thy "!!A B. A<=B ==> f``A <= f``B";
-by (fast_tac set_cs 1);
-qed "image_mono";
-
-goal Set.thy "!!A B. A<=B ==> Pow(A) <= Pow(B)";
-by (fast_tac set_cs 1);
-qed "Pow_mono";
-
-goal Set.thy "!!A B. A<=B ==> Union(A) <= Union(B)";
-by (fast_tac set_cs 1);
-qed "Union_mono";
-
-goal Set.thy "!!A B. B<=A ==> Inter(A) <= Inter(B)";
-by (fast_tac set_cs 1);
-qed "Inter_anti_mono";
-
-val prems = goal Set.thy
- "[| A<=B; !!x. x:A ==> f(x)<=g(x) |] ==> \
-\ (UN x:A. f(x)) <= (UN x:B. g(x))";
-by (fast_tac (set_cs addIs (prems RL [subsetD])) 1);
-qed "UN_mono";
-
-val [prem] = goal Set.thy
- "[| !!x. f(x)<=g(x) |] ==> (UN x. f(x)) <= (UN x. g(x))";
-by (fast_tac (set_cs addIs [prem RS subsetD]) 1);
-qed "UN1_mono";
-
-val prems = goal Set.thy
- "[| B<=A; !!x. x:A ==> f(x)<=g(x) |] ==> \
-\ (INT x:A. f(x)) <= (INT x:A. g(x))";
-by (fast_tac (set_cs addIs (prems RL [subsetD])) 1);
-qed "INT_anti_mono";
-
-(*The inclusion is POSITIVE! *)
-val [prem] = goal Set.thy
- "[| !!x. f(x)<=g(x) |] ==> (INT x. f(x)) <= (INT x. g(x))";
-by (fast_tac (set_cs addIs [prem RS subsetD]) 1);
-qed "INT1_mono";
-
-goal Set.thy "!!A B. [| A<=C; B<=D |] ==> A Un B <= C Un D";
-by (fast_tac set_cs 1);
-qed "Un_mono";
-
-goal Set.thy "!!A B. [| A<=C; B<=D |] ==> A Int B <= C Int D";
-by (fast_tac set_cs 1);
-qed "Int_mono";
-
-goal Set.thy "!!A::'a set. [| A<=C; D<=B |] ==> A-B <= C-D";
-by (fast_tac set_cs 1);
-qed "Diff_mono";
-
-goal Set.thy "!!A B. A<=B ==> Compl(B) <= Compl(A)";
-by (fast_tac set_cs 1);
-qed "Compl_anti_mono";
-
-val prems = goal Prod.thy
- "[| A<=C; !!x. x:A ==> B<=D |] ==> Sigma(A,%x.B) <= Sigma(C,%x.D)";
-by (cut_facts_tac prems 1);
-by (fast_tac (set_cs addIs (prems RL [subsetD])
- addSIs [SigmaI]
- addSEs [SigmaE]) 1);
-qed "Sigma_mono";
-
-
-(** Monotonicity of implications. For inductive definitions **)
-
-goal Set.thy "!!A B x. A<=B ==> x:A --> x:B";
-by (rtac impI 1);
-by (etac subsetD 1);
-by (assume_tac 1);
-qed "in_mono";
-
-goal HOL.thy "!!P1 P2 Q1 Q2. [| P1-->Q1; P2-->Q2 |] ==> (P1&P2) --> (Q1&Q2)";
-by (fast_tac HOL_cs 1);
-qed "conj_mono";
-
-goal HOL.thy "!!P1 P2 Q1 Q2. [| P1-->Q1; P2-->Q2 |] ==> (P1|P2) --> (Q1|Q2)";
-by (fast_tac HOL_cs 1);
-qed "disj_mono";
-
-goal HOL.thy "!!P1 P2 Q1 Q2.[| Q1-->P1; P2-->Q2 |] ==> (P1-->P2)-->(Q1-->Q2)";
-by (fast_tac HOL_cs 1);
-qed "imp_mono";
-
-goal HOL.thy "P-->P";
-by (rtac impI 1);
-by (assume_tac 1);
-qed "imp_refl";
-
-val [PQimp] = goal HOL.thy
- "[| !!x. P(x) --> Q(x) |] ==> (EX x.P(x)) --> (EX x.Q(x))";
-by (fast_tac (HOL_cs addIs [PQimp RS mp]) 1);
-qed "ex_mono";
-
-val [PQimp] = goal HOL.thy
- "[| !!x. P(x) --> Q(x) |] ==> (ALL x.P(x)) --> (ALL x.Q(x))";
-by (fast_tac (HOL_cs addIs [PQimp RS mp]) 1);
-qed "all_mono";
-
-val [PQimp] = goal Set.thy
- "[| !!x. P(x) --> Q(x) |] ==> Collect(P) <= Collect(Q)";
-by (fast_tac (set_cs addIs [PQimp RS mp]) 1);
-qed "Collect_mono";
-
-(*Used in indrule.ML*)
-val [subs,PQimp] = goal Set.thy
- "[| A<=B; !!x. x:A ==> P(x) --> Q(x) \
-\ |] ==> A Int Collect(P) <= B Int Collect(Q)";
-by (fast_tac (set_cs addIs [subs RS subsetD, PQimp RS mp]) 1);
-qed "Int_Collect_mono";
-
-(*Used in intr_elim.ML and in individual datatype definitions*)
-val basic_monos = [subset_refl, imp_refl, disj_mono, conj_mono,
- ex_mono, Collect_mono, Part_mono, in_mono];
-
--- a/mono.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,8 +0,0 @@
-(* Title: HOL/mono
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-*)
-
-mono = subset
--- a/simpdata.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,170 +0,0 @@
-(* Title: HOL/simpdata.ML
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 1991 University of Cambridge
-
-Instantiation of the generic simplifier
-*)
-
-open Simplifier;
-
-local
-
-fun prover s = prove_goal HOL.thy s (fn _ => [fast_tac HOL_cs 1]);
-
-val P_imp_P_iff_True = prover "P --> (P = True)" RS mp;
-val P_imp_P_eq_True = P_imp_P_iff_True RS eq_reflection;
-
-val not_P_imp_P_iff_F = prover "~P --> (P = False)" RS mp;
-val not_P_imp_P_eq_False = not_P_imp_P_iff_F RS eq_reflection;
-
-fun atomize pairs =
- let fun atoms th =
- (case concl_of th of
- Const("Trueprop",_) $ p =>
- (case head_of p of
- Const(a,_) =>
- (case assoc(pairs,a) of
- Some(rls) => flat (map atoms ([th] RL rls))
- | None => [th])
- | _ => [th])
- | _ => [th])
- in atoms end;
-
-fun mk_meta_eq r = case concl_of r of
- Const("==",_)$_$_ => r
- | _$(Const("op =",_)$_$_) => r RS eq_reflection
- | _$(Const("not",_)$_) => r RS not_P_imp_P_eq_False
- | _ => r RS P_imp_P_eq_True;
-(* last 2 lines requires all formulae to be of the from Trueprop(.) *)
-
-fun gen_all th = forall_elim_vars (#maxidx(rep_thm th)+1) th;
-
-val imp_cong = impI RSN
- (2, prove_goal HOL.thy "(P=P')--> (P'--> (Q=Q'))--> ((P-->Q) = (P'-->Q'))"
- (fn _=> [fast_tac HOL_cs 1]) RS mp RS mp);
-
-val o_apply = prove_goalw HOL.thy [o_def] "(f o g)(x) = f(g(x))"
- (fn _ => [rtac refl 1]);
-
-val simp_thms = map prover
- [ "(x=x) = True",
- "(~True) = False", "(~False) = True", "(~ ~ P) = P",
- "(~P) ~= P", "P ~= (~P)", "(P ~= Q) = (P = (~Q))",
- "(True=P) = P", "(P=True) = P",
- "(True --> P) = P", "(False --> P) = True",
- "(P --> True) = True", "(P --> P) = True",
- "(P --> False) = (~P)", "(P --> ~P) = (~P)",
- "(P & True) = P", "(True & P) = P",
- "(P & False) = False", "(False & P) = False", "(P & P) = P",
- "(P | True) = True", "(True | P) = True",
- "(P | False) = P", "(False | P) = P", "(P | P) = P",
- "(!x.P) = P", "(? x.P) = P", "? x. x=t", "(? x. x=t & P(x)) = P(t)",
- "(P|Q --> R) = ((P-->R)&(Q-->R))" ];
-
-in
-
-val meta_eq_to_obj_eq = prove_goal HOL.thy "x==y ==> x=y"
- (fn [prem] => [rewtac prem, rtac refl 1]);
-
-val eq_sym_conv = prover "(x=y) = (y=x)";
-
-val conj_assoc = prover "((P&Q)&R) = (P&(Q&R))";
-
-val if_True = prove_goalw HOL.thy [if_def] "if(True,x,y) = x"
- (fn _=>[fast_tac (HOL_cs addIs [select_equality]) 1]);
-
-val if_False = prove_goalw HOL.thy [if_def] "if(False,x,y) = y"
- (fn _=>[fast_tac (HOL_cs addIs [select_equality]) 1]);
-
-val if_P = prove_goal HOL.thy "P ==> if(P,x,y) = x"
- (fn [prem] => [ stac (prem RS eqTrueI) 1, rtac if_True 1 ]);
-
-val if_not_P = prove_goal HOL.thy "~P ==> if(P,x,y) = y"
- (fn [prem] => [ stac (prem RS not_P_imp_P_iff_F) 1, rtac if_False 1 ]);
-
-val expand_if = prove_goal HOL.thy
- "P(if(Q,x,y)) = ((Q --> P(x)) & (~Q --> P(y)))"
- (fn _=> [ (res_inst_tac [("Q","Q")] (excluded_middle RS disjE) 1),
- rtac (if_P RS ssubst) 2,
- rtac (if_not_P RS ssubst) 1,
- REPEAT(fast_tac HOL_cs 1) ]);
-
-val if_bool_eq = prove_goal HOL.thy "if(P,Q,R) = ((P-->Q) & (~P-->R))"
- (fn _ => [rtac expand_if 1]);
-
-(*Add congruence rules for = (instead of ==) *)
-infix 4 addcongs;
-fun ss addcongs congs = ss addeqcongs (congs RL [eq_reflection]);
-
-(*Add a simpset to a classical set!*)
-infix 4 addss;
-fun cs addss ss = cs addbefore asm_full_simp_tac ss 1;
-
-val mksimps_pairs =
- [("op -->", [mp]), ("op &", [conjunct1,conjunct2]),
- ("All", [spec]), ("True", []), ("False", []),
- ("if", [if_bool_eq RS iffD1])];
-
-fun mksimps pairs = map mk_meta_eq o atomize pairs o gen_all;
-
-val HOL_ss = empty_ss
- setmksimps (mksimps mksimps_pairs)
- setsolver (fn prems => resolve_tac (TrueI::refl::prems) ORELSE' atac
- ORELSE' etac FalseE)
- setsubgoaler asm_simp_tac
- addsimps ([if_True, if_False, o_apply, conj_assoc] @ simp_thms)
- addcongs [imp_cong];
-
-local val mktac = mk_case_split_tac (meta_eq_to_obj_eq RS iffD2)
-in
-fun split_tac splits = mktac (map mk_meta_eq splits)
-end;
-
-(* eliminiation of existential quantifiers in assumptions *)
-
-val ex_all_equiv =
- let val lemma1 = prove_goal HOL.thy
- "(? x. P(x) ==> PROP Q) ==> (!!x. P(x) ==> PROP Q)"
- (fn prems => [resolve_tac prems 1, etac exI 1]);
- val lemma2 = prove_goalw HOL.thy [Ex_def]
- "(!!x. P(x) ==> PROP Q) ==> (? x. P(x) ==> PROP Q)"
- (fn prems => [REPEAT(resolve_tac prems 1)])
- in equal_intr lemma1 lemma2 end;
-
-(* '&' congruence rule: not included by default!
- May slow rewrite proofs down by as much as 50% *)
-
-val conj_cong = impI RSN
- (2, prove_goal HOL.thy "(P=P')--> (P'--> (Q=Q'))--> ((P&Q) = (P'&Q'))"
- (fn _=> [fast_tac HOL_cs 1]) RS mp RS mp);
-
-(** 'if' congruence rules: neither included by default! *)
-
-(*Simplifies x assuming c and y assuming ~c*)
-val if_cong = prove_goal HOL.thy
- "[| b=c; c ==> x=u; ~c ==> y=v |] ==> if(b,x,y) = if(c,u,v)"
- (fn rew::prems =>
- [stac rew 1, stac expand_if 1, stac expand_if 1,
- fast_tac (HOL_cs addDs prems) 1]);
-
-(*Prevents simplification of x and y: much faster*)
-val if_weak_cong = prove_goal HOL.thy
- "b=c ==> if(b,x,y) = if(c,x,y)"
- (fn [prem] => [rtac (prem RS arg_cong) 1]);
-
-(*Prevents simplification of t: much faster*)
-val let_weak_cong = prove_goal HOL.thy
- "a = b ==> (let x=a in t(x)) = (let x=b in t(x))"
- (fn [prem] => [rtac (prem RS arg_cong) 1]);
-
-end;
-
-fun prove nm thm = qed_goal nm HOL.thy thm (fn _ => [fast_tac HOL_cs 1]);
-
-prove "conj_commute" "(P&Q) = (Q&P)";
-prove "conj_left_commute" "(P&(Q&R)) = (Q&(P&R))";
-val conj_comms = [conj_commute, conj_left_commute];
-
-prove "conj_disj_distribL" "(P&(Q|R)) = (P&Q | P&R)";
-prove "conj_disj_distribR" "((P|Q)&R) = (P&R | Q&R)";
--- a/subset.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,135 +0,0 @@
-(* Title: HOL/subset
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1991 University of Cambridge
-
-Derived rules involving subsets
-Union and Intersection as lattice operations
-*)
-
-(*** insert ***)
-
-qed_goal "subset_insertI" Set.thy "B <= insert(a,B)"
- (fn _=> [ (rtac subsetI 1), (etac insertI2 1) ]);
-
-(*** Big Union -- least upper bound of a set ***)
-
-val prems = goal Set.thy
- "B:A ==> B <= Union(A)";
-by (REPEAT (ares_tac (prems@[subsetI,UnionI]) 1));
-qed "Union_upper";
-
-val [prem] = goal Set.thy
- "[| !!X. X:A ==> X<=C |] ==> Union(A) <= C";
-br subsetI 1;
-by (REPEAT (eresolve_tac [asm_rl, UnionE, prem RS subsetD] 1));
-qed "Union_least";
-
-(** General union **)
-
-val prems = goal Set.thy
- "a:A ==> B(a) <= (UN x:A. B(x))";
-by (REPEAT (ares_tac (prems@[UN_I RS subsetI]) 1));
-qed "UN_upper";
-
-val [prem] = goal Set.thy
- "[| !!x. x:A ==> B(x)<=C |] ==> (UN x:A. B(x)) <= C";
-br subsetI 1;
-by (REPEAT (eresolve_tac [asm_rl, UN_E, prem RS subsetD] 1));
-qed "UN_least";
-
-goal Set.thy "B(a) <= (UN x. B(x))";
-by (REPEAT (ares_tac [UN1_I RS subsetI] 1));
-qed "UN1_upper";
-
-val [prem] = goal Set.thy "[| !!x. B(x)<=C |] ==> (UN x. B(x)) <= C";
-br subsetI 1;
-by (REPEAT (eresolve_tac [asm_rl, UN1_E, prem RS subsetD] 1));
-qed "UN1_least";
-
-
-(*** Big Intersection -- greatest lower bound of a set ***)
-
-val prems = goal Set.thy "B:A ==> Inter(A) <= B";
-br subsetI 1;
-by (REPEAT (resolve_tac prems 1 ORELSE etac InterD 1));
-qed "Inter_lower";
-
-val [prem] = goal Set.thy
- "[| !!X. X:A ==> C<=X |] ==> C <= Inter(A)";
-br (InterI RS subsetI) 1;
-by (REPEAT (eresolve_tac [asm_rl, prem RS subsetD] 1));
-qed "Inter_greatest";
-
-val prems = goal Set.thy "a:A ==> (INT x:A. B(x)) <= B(a)";
-br subsetI 1;
-by (REPEAT (resolve_tac prems 1 ORELSE etac INT_D 1));
-qed "INT_lower";
-
-val [prem] = goal Set.thy
- "[| !!x. x:A ==> C<=B(x) |] ==> C <= (INT x:A. B(x))";
-br (INT_I RS subsetI) 1;
-by (REPEAT (eresolve_tac [asm_rl, prem RS subsetD] 1));
-qed "INT_greatest";
-
-goal Set.thy "(INT x. B(x)) <= B(a)";
-br subsetI 1;
-by (REPEAT (resolve_tac prems 1 ORELSE etac INT1_D 1));
-qed "INT1_lower";
-
-val [prem] = goal Set.thy
- "[| !!x. C<=B(x) |] ==> C <= (INT x. B(x))";
-br (INT1_I RS subsetI) 1;
-by (REPEAT (eresolve_tac [asm_rl, prem RS subsetD] 1));
-qed "INT1_greatest";
-
-(*** Finite Union -- the least upper bound of 2 sets ***)
-
-goal Set.thy "A <= A Un B";
-by (REPEAT (ares_tac [subsetI,UnI1] 1));
-qed "Un_upper1";
-
-goal Set.thy "B <= A Un B";
-by (REPEAT (ares_tac [subsetI,UnI2] 1));
-qed "Un_upper2";
-
-val prems = goal Set.thy "[| A<=C; B<=C |] ==> A Un B <= C";
-by (cut_facts_tac prems 1);
-by (DEPTH_SOLVE (ares_tac [subsetI] 1
- ORELSE eresolve_tac [UnE,subsetD] 1));
-qed "Un_least";
-
-(*** Finite Intersection -- the greatest lower bound of 2 sets *)
-
-goal Set.thy "A Int B <= A";
-by (REPEAT (ares_tac [subsetI] 1 ORELSE etac IntE 1));
-qed "Int_lower1";
-
-goal Set.thy "A Int B <= B";
-by (REPEAT (ares_tac [subsetI] 1 ORELSE etac IntE 1));
-qed "Int_lower2";
-
-val prems = goal Set.thy "[| C<=A; C<=B |] ==> C <= A Int B";
-by (cut_facts_tac prems 1);
-by (REPEAT (ares_tac [subsetI,IntI] 1
- ORELSE etac subsetD 1));
-qed "Int_greatest";
-
-(*** Set difference ***)
-
-qed_goal "Diff_subset" Set.thy "A-B <= (A::'a set)"
- (fn _ => [ (REPEAT (ares_tac [subsetI] 1 ORELSE etac DiffE 1)) ]);
-
-(*** Monotonicity ***)
-
-val [prem] = goal Set.thy "mono(f) ==> f(A) Un f(B) <= f(A Un B)";
-by (rtac Un_least 1);
-by (rtac (Un_upper1 RS (prem RS monoD)) 1);
-by (rtac (Un_upper2 RS (prem RS monoD)) 1);
-qed "mono_Un";
-
-val [prem] = goal Set.thy "mono(f) ==> f(A Int B) <= f(A) Int f(B)";
-by (rtac Int_greatest 1);
-by (rtac (Int_lower1 RS (prem RS monoD)) 1);
-by (rtac (Int_lower2 RS (prem RS monoD)) 1);
-qed "mono_Int";
--- a/subset.thy Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,7 +0,0 @@
-(* Title: HOL/subset.thy
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1994 University of Cambridge
-*)
-
-subset = Fun
--- a/subtype.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,141 +0,0 @@
-(* Title: HOL/subtype.ML
- ID: $Id$
- Author: Markus Wenzel, TU Muenchen
-
-Internal interface for subtype definitions.
-*)
-
-signature SUBTYPE =
-sig
- val prove_nonempty: cterm -> thm list -> tactic option -> thm
- val add_subtype: string -> string * string list * mixfix ->
- string -> string list -> thm list -> tactic option -> theory -> theory
- val add_subtype_i: string -> string * string list * mixfix ->
- term -> string list -> thm list -> tactic option -> theory -> theory
-end;
-
-structure Subtype: SUBTYPE =
-struct
-
-open Syntax Logic HOLogic;
-
-
-(* prove non-emptyness of a set *) (*exception ERROR*)
-
-val is_def = is_equals o #prop o rep_thm;
-
-fun prove_nonempty cset thms usr_tac =
- let
- val {T = setT, t = set, maxidx, sign} = rep_cterm cset;
- val T = dest_setT setT;
- val goal =
- cterm_of sign (mk_Trueprop (mk_mem (Var (("x", maxidx + 1), T), set)));
- val tac =
- TRY (rewrite_goals_tac (filter is_def thms)) THEN
- TRY (REPEAT_FIRST (resolve_tac (filter_out is_def thms))) THEN
- if_none usr_tac (TRY (ALLGOALS (fast_tac set_cs)));
- in
- prove_goalw_cterm [] goal (K [tac])
- end
- handle ERROR =>
- error ("Failed to prove non-emptyness of " ^ quote (string_of_cterm cset));
-
-
-(* ext_subtype *)
-
-fun ext_subtype prep_term name (t, vs, mx) raw_set axms thms usr_tac thy =
- let
- val _ = require_thy thy "Set" "subtype definitions";
- val sign = sign_of thy;
-
- (*rhs*)
- val cset = prep_term sign raw_set;
- val {T = setT, t = set, ...} = rep_cterm cset;
- val rhs_tfrees = term_tfrees set;
- val oldT = dest_setT setT handle TYPE _ =>
- error ("Not a set type: " ^ quote (Sign.string_of_typ sign setT));
-
- (*lhs*)
- val lhs_tfrees =
- map (fn v => (v, if_none (assoc (rhs_tfrees, v)) termS)) vs;
-
- val tname = type_name t mx;
- val tlen = length vs;
- val newT = Type (tname, map TFree lhs_tfrees);
-
- val Rep_name = "Rep_" ^ name;
- val Abs_name = "Abs_" ^ name;
- val setC = Const (name, setT);
- val RepC = Const (Rep_name, newT --> oldT);
- val AbsC = Const (Abs_name, oldT --> newT);
- val x_new = Free ("x", newT);
- val y_old = Free ("y", oldT);
-
- (*axioms*)
- val rep_type = mk_Trueprop (mk_mem (RepC $ x_new, setC));
- val rep_type_inv = mk_Trueprop (mk_eq (AbsC $ (RepC $ x_new), x_new));
- val abs_type_inv = mk_implies (mk_Trueprop (mk_mem (y_old, setC)),
- mk_Trueprop (mk_eq (RepC $ (AbsC $ y_old), y_old)));
-
-
- (* errors *)
-
- val show_names = commas_quote o map fst;
-
- val illegal_vars =
- if null (term_vars set) andalso null (term_tvars set) then []
- else ["Illegal schematic variable(s) on rhs"];
-
- val dup_lhs_tfrees =
- (case duplicates lhs_tfrees of [] => []
- | dups => ["Duplicate type variables on lhs: " ^ show_names dups]);
-
- val extra_rhs_tfrees =
- (case gen_rems (op =) (rhs_tfrees, lhs_tfrees) of [] => []
- | extras => ["Extra type variables on rhs: " ^ show_names extras]);
-
- val illegal_frees =
- (case term_frees set of [] => []
- | xs => ["Illegal variables on rhs: " ^ show_names (map dest_Free xs)]);
-
- val errs = illegal_vars @ dup_lhs_tfrees @ extra_rhs_tfrees @ illegal_frees;
- in
- if null errs then ()
- else error (cat_lines errs);
-
- prove_nonempty cset (map (get_axiom thy) axms @ thms) usr_tac;
-
- thy
- |> add_types [(t, tlen, mx)]
- |> add_arities
- [(tname, replicate tlen logicS, logicS),
- (tname, replicate tlen termS, termS)]
- |> add_consts_i
- [(name, setT, NoSyn),
- (Rep_name, newT --> oldT, NoSyn),
- (Abs_name, oldT --> newT, NoSyn)]
- |> add_defs_i
- [(name ^ "_def", mk_equals (setC, set))]
- |> add_axioms_i
- [(Rep_name, rep_type),
- (Rep_name ^ "_inverse", rep_type_inv),
- (Abs_name ^ "_inverse", abs_type_inv)]
- end
- handle ERROR =>
- error ("The error(s) above occurred in subtype definition " ^ quote name);
-
-
-(* external interfaces *)
-
-fun cert_term sg tm =
- cterm_of sg tm handle TERM (msg, _) => error msg;
-
-fun read_term sg str =
- read_cterm sg (str, termTVar);
-
-val add_subtype = ext_subtype read_term;
-val add_subtype_i = ext_subtype cert_term;
-
-
-end;
-
--- a/thy_syntax.ML Tue Oct 24 14:59:17 1995 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,187 +0,0 @@
-(* Title: HOL/thy_syntax.ML
- ID: $Id$
- Author: Markus Wenzel and Lawrence C Paulson and Carsten Clasohm
-
-Additional theory file sections for HOL.
-
-TODO:
- move datatype / primrec stuff to pre_datatype.ML (?)
-*)
-
-(*the kind of distinctiveness axioms depends on number of constructors*)
-val dtK = 5; (* FIXME rename?, move? *)
-
-structure ThySynData: THY_SYN_DATA =
-struct
-
-open ThyParse;
-
-
-(** subtype **)
-
-fun mk_subtype_decl (((((opt_name, vs), t), mx), rhs), wt) =
- let
- val name' = if_none opt_name t;
- val name = strip_quotes name';
- in
- (cat_lines [name', mk_triple (t, mk_list vs, mx), rhs, wt],
- [name ^ "_def", "Rep_" ^ name, "Rep_" ^ name ^ "_inverse",
- "Abs_" ^ name ^ "_inverse"])
- end;
-
-val subtype_decl =
- optional ("(" $$-- name --$$ ")" >> Some) None --
- type_args -- name -- opt_infix --$$ "=" -- string -- opt_witness
- >> mk_subtype_decl;
-
-
-
-(** (co)inductive **)
-
-(*co is either "" or "Co"*)
-fun inductive_decl co =
- let
- fun mk_intr_name (s, _) = (*the "op" cancels any infix status*)
- if Syntax.is_identifier s then "op " ^ s else "_";
- fun mk_params (((recs, ipairs), monos), con_defs) =
- let val big_rec_name = space_implode "_" (map (scan_to_id o trim) recs)
- and srec_tms = mk_list recs
- and sintrs = mk_big_list (map snd ipairs)
- val stri_name = big_rec_name ^ "_Intrnl"
- in
- (";\n\n\
- \structure " ^ stri_name ^ " =\n\
- \ let open Ind_Syntax in\n\
- \ struct\n\
- \ val _ = writeln \"" ^ co ^
- "Inductive definition " ^ big_rec_name ^ "\"\n\
- \ val rec_tms\t= map (readtm (sign_of thy) termTVar) "
- ^ srec_tms ^ "\n\
- \ and intr_tms\t= map (readtm (sign_of thy) propT)\n"
- ^ sintrs ^ "\n\
- \ end\n\
- \ end;\n\n\
- \val thy = thy |> " ^ co ^ "Ind.add_fp_def_i \n (" ^
- stri_name ^ ".rec_tms, " ^
- stri_name ^ ".intr_tms)"
- ,
- "structure " ^ big_rec_name ^ " =\n\
- \ struct\n\
- \ structure Result = " ^ co ^ "Ind_section_Fun\n\
- \ (open " ^ stri_name ^ "\n\
- \ val thy\t\t= thy\n\
- \ val monos\t\t= " ^ monos ^ "\n\
- \ val con_defs\t\t= " ^ con_defs ^ ");\n\n\
- \ val " ^ mk_list (map mk_intr_name ipairs) ^ " = Result.intrs;\n\
- \ open Result\n\
- \ end\n"
- )
- end
- val ipairs = "intrs" $$-- repeat1 (ident -- !! string)
- fun optstring s = optional (s $$-- string) "\"[]\"" >> trim
- in
- repeat1 string -- ipairs -- optstring "monos" -- optstring "con_defs"
- >> mk_params
- end;
-
-
-
-(** datatype **)
-
-local
- (* FIXME err -> add_datatype *)
- fun mk_cons cs =
- (case duplicates (map (fst o fst) cs) of
- [] => map (fn ((s, ts), syn) => mk_triple (s, mk_list ts, syn)) cs
- | dups => error ("Duplicate constructors: " ^ commas_quote dups));
-
- (*generate names of distinctiveness axioms*)
- fun mk_distinct_rules cs tname =
- let
- val uqcs = map (fn ((s, _), _) => strip_quotes s) cs;
- (*combine all constructor names with all others w/o duplicates*)
- fun neg_one c = map (fn c2 => quote (c ^ "_not_" ^ c2));
- fun neg1 [] = []
- | neg1 (c1 :: cs) = neg_one c1 cs @ neg1 cs;
- in
- if length uqcs < dtK then neg1 uqcs
- else quote (tname ^ "_ord_distinct") ::
- map (fn c => quote (tname ^ "_ord_" ^ c)) uqcs
- end;
-
- fun mk_rules tname cons pre = " map (get_axiom thy) " ^
- mk_list (map (fn ((s, _), _) => quote (tname ^ pre ^ strip_quotes s)) cons);
-
- (*generate string for calling add_datatype*)
- fun mk_params ((ts, tname), cons) =
- ("val (thy, " ^ tname ^ "_add_primrec) = Datatype.add_datatype\n"
- ^ mk_triple (mk_list ts, quote tname, mk_list (mk_cons cons)) ^ " thy\n\
- \val thy = thy",
- "structure " ^ tname ^ " =\n\
- \struct\n\
- \ val inject = map (get_axiom thy) " ^
- mk_list (map (fn ((s, _), _) => quote ("inject_" ^ strip_quotes s))
- (filter_out (null o snd o fst) cons)) ^ ";\n\
- \ val distinct = " ^
- (if length cons < dtK then "let val distinct' = " else "") ^
- "map (get_axiom thy) " ^ mk_list (mk_distinct_rules cons tname) ^
- (if length cons < dtK then
- " in distinct' @ (map (fn t => sym COMP (t RS contrapos))\
- \ distinct') end"
- else "") ^ ";\n\
- \ val induct = get_axiom thy \"" ^ tname ^ "_induct\";\n\
- \ val cases =" ^ mk_rules tname cons "_case_" ^ ";\n\
- \ val recs =" ^ mk_rules tname cons "_rec_" ^ ";\n\
- \ val simps = inject @ distinct @ cases @ recs;\n\
- \ fun induct_tac a = res_inst_tac [(" ^ quote tname ^ ", a)] induct;\n\
- \end;\n");
-
- (*parsers*)
- val tvars = type_args >> map (cat "dtVar");
- val typ =
- tvars -- (ident>>quote) >> (cat "dtTyp" o mk_pair o apfst mk_list) ||
- type_var >> cat "dtVar";
- val opt_typs = optional ("(" $$-- list1 typ --$$ ")") [];
- val constructor = name -- opt_typs -- opt_mixfix;
-in
- val datatype_decl =
- (* FIXME tvars -> type_args *)
- tvars -- ident --$$ "=" -- enum1 "|" constructor >> mk_params;
-end;
-
-
-
-(** primrec **)
-
-fun mk_primrec_decl ((fname, tname), axms) =
- let
- fun mk_prove (name, eqn) =
- "val " ^ name ^ " = store_thm (" ^ quote name ^ ", prove_goalw thy [get_def thy "
- ^ fname ^ "] " ^ eqn ^ "\n\
- \ (fn _ => [simp_tac (HOL_ss addsimps " ^ tname ^ ".recs) 1]));";
- val axs = mk_list (map (fn (n, a) => mk_pair (quote n, a)) axms);
- in ("|> " ^ tname ^ "_add_primrec " ^ axs, cat_lines (map mk_prove axms)) end;
-
-val primrec_decl =
- name -- long_id -- repeat1 (ident -- string) >> mk_primrec_decl;
-
-
-
-(** sections **)
-
-val user_keywords = ["intrs", "monos", "con_defs", "|"];
-
-val user_sections =
- [axm_section "subtype" "|> Subtype.add_subtype" subtype_decl,
- ("inductive", inductive_decl ""),
- ("coinductive", inductive_decl "Co"),
- ("datatype", datatype_decl),
- ("primrec", primrec_decl)];
-
-
-end;
-
-
-structure ThySyn = ThySynFun(ThySynData);
-init_thy_reader ();
-