# HG changeset patch # User clasohm # Date 822050862 -3600 # Node ID a4dc62a46ee43012867b47676bdb1ef6fd449639 # Parent f04b33ce250f77c9a18c59f73fb71921cf54995e Old_HOL removed from the distribution diff -r f04b33ce250f -r a4dc62a46ee4 Arith.ML --- 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 [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+(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 m - n < m"; -by (subgoal_tac "0 ~ m 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] " : pred_nat^+ = (m 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 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 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 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 (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 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 0 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. 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 (? 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 ? 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 m 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 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"; diff -r f04b33ce250f -r a4dc62a46ee4 Arith.thy --- 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(jn. - Also, nat_rec(m, 0, %z w.z) is pred(m). *) - diff -r f04b33ce250f -r a4dc62a46ee4 Finite.ML --- 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"; diff -r f04b33ce250f -r a4dc62a46ee4 Finite.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Fun.ML --- 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); diff -r f04b33ce250f -r a4dc62a46ee4 Fun.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Gfp.ML --- 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"; diff -r f04b33ce250f -r a4dc62a46ee4 Gfp.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 HOL.ML --- 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); diff -r f04b33ce250f -r a4dc62a46ee4 HOL.thy --- 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")]; - diff -r f04b33ce250f -r a4dc62a46ee4 IMP/Denotation.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 IMP/Equiv.ML --- 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-> 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-> 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-> 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-> 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-> 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"; diff -r f04b33ce250f -r a4dc62a46ee4 IMP/Equiv.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 IMP/Properties.ML --- 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-> m & -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-> v & -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) - [" -c-> t", " -c-> t", " -c-> t", - " -c-> t", " -c-> t"]; - -(* evaluation of com is deterministic *) -goal Com.thy "!!c. -c-> t ==> !u. -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(); diff -r f04b33ce250f -r a4dc62a46ee4 IMP/Properties.thy --- 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" diff -r f04b33ce250f -r a4dc62a46ee4 IMP/ROOT.ML --- 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*) - diff -r f04b33ce250f -r a4dc62a46ee4 IOA/ROOT.ML --- 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*) diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Action.ML --- 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; diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Action.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Channels.ML --- 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; diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Channels.thy --- 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 == " - -rsch_asig_def "rsch_asig == " - -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 == " -rsch_ioa_def "rsch_ioa == " - -end diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Correctness.ML --- 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(); diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Correctness.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Impl.ML --- 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); - diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Impl.thy --- 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)),) - + count(srch(s),) - <= count(rsent(rec(s)),~sbit(sen(s))))" - -(* Lemma 5.4 *) - inv4_def "inv4(s) == rbit(rec(s)) = (~sbit(sen(s))) --> sq(sen(s)) ~= []" - -end diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Lemmas.ML --- 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 = 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 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 (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 (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"; diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Lemmas.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Multiset.ML --- 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 0 0 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"; diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Multiset.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Packet.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Read_me --- 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 - mesg = 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 - - - -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 = - 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 ~= [] - diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Receiver.ML --- 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]; - - diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Receiver.thy --- 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 == - " - -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),) & - 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_trans>" - -end diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Sender.ML --- 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]; diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Sender.thy --- 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_trans>" - -end diff -r f04b33ce250f -r a4dc62a46ee4 IOA/example/Spec.thy --- 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 == " - -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 == " - -end diff -r f04b33ce250f -r a4dc62a46ee4 IOA/meta_theory/Asig.ML --- 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]; diff -r f04b33ce250f -r a4dc62a46ee4 IOA/meta_theory/Asig.thy --- 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) == " - - -end diff -r f04b33ce250f -r a4dc62a46ee4 IOA/meta_theory/IOA.ML --- 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 & starts_of() = y & trans_of() = 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); :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); : 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")] 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)|] ==> : 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) --> :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 -" : 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)), :trans_of(A), fst(t)=fst(s)) & \ -\ if(a:actions(asig_of(B)), :trans_of(B), \ -\ fst(snd(t))=fst(snd(s))) & \ -\ if(a:actions(asig_of(C)), \ -\ :trans_of(C), \ -\ fst(snd(snd(t)))=fst(snd(snd(s)))) & \ -\ if(a:actions(asig_of(D)), \ -\ :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"; diff -r f04b33ce250f -r a4dc62a46ee4 IOA/meta_theory/IOA.thy --- 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. :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) --> :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) & ? :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) == - :trans_of(ioa1), - fst(t) = fst(s)) - & - if(a:actions(asig_of(ioa2)), - :trans_of(ioa2), - snd(t) = snd(s))}>" - - -restrict_asig_def - "restrict_asig(asig,actns) == - " - - -restrict_def - "restrict(ioa,actns) == - " - - -ioa_implements_def - "ioa_implements(ioa1,ioa2) == - (externals(asig_of(ioa1)) = externals(asig_of(ioa2)) & - behaviours(ioa1) <= behaviours(ioa2))" - -end diff -r f04b33ce250f -r a4dc62a46ee4 IOA/meta_theory/Option.ML --- 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)); diff -r f04b33ce250f -r a4dc62a46ee4 IOA/meta_theory/Option.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 IOA/meta_theory/Solve.ML --- 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","")] 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"; diff -r f04b33ce250f -r a4dc62a46ee4 IOA/meta_theory/Solve.thy --- 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) & - :trans_of(C) - --> if(a:externals(asig_of(C)), - :trans_of(A), - f(s)=f(t)))" - -end diff -r f04b33ce250f -r a4dc62a46ee4 Inductive.ML --- 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); diff -r f04b33ce250f -r a4dc62a46ee4 Inductive.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Integ/Equiv.ML --- 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. : r --> : 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); : 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); : 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 |] ==> : 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 |] ==> : 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}) |] ==> : 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) ==> (: 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}) = (: 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) |] ==> :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; : r |] ==> b(y,w) = b(z,w); \ -\ !! y z w. [| w: A; : 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; : 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"; - diff -r f04b33ce250f -r a4dc62a46ee4 Integ/Equiv.thy --- 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. : r)" - sym_def "sym(r) == ALL x y. : r --> : 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. :r --> b(y)=b(z)" - congruent2_def "congruent2(r,b) == ALL y1 z1 y2 z2. - :r --> :r --> b(y1,y2) = b(z1,z2)" -end diff -r f04b33ce250f -r a4dc62a46ee4 Integ/Integ.ML --- 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|] ==> \ -\ <,>: 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+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+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 "<,>: intrel = (x1+y2 = x2+y1)"; -by (fast_tac intrel_cs 1); -qed "intrel_iff"; - -goal Integ.thy ": 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^^{}: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^^{},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^^{}) = Abs_Integ(intrel ^^ {})"; -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^^{}) ==> 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^^{})) = \ -\ 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^^{},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^^{}) + Abs_Integ(intrel^^{}) = \ -\ Abs_Integ(intrel^^{})"; -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^^{}, 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^^{})) * Abs_Integ((intrel^^{})) = \ -\ Abs_Integ(intrel ^^ {})"; -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 ? 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 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 ~w R *) -bind_thm ("zless_asym", (zless_not_sym RS notE)); - -goal Integ.thy "!!z::int. ~ z R *) -bind_thm ("zless_anti_refl", (zless_not_refl RS notE)); - -goal Integ.thy "!!w. z 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 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 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"; diff -r f04b33ce250f -r a4dc62a46ee4 Integ/Integ.thy --- 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+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 ^^ {})" - - zminus_def - "$~ Z == Abs_Integ(UN p:Rep_Integ(Z). split(%x y. intrel^^{},p))" - - znegative_def - "znegative(Z) == EX x y. x: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^^{},p2),p1))" - - zdiff_def "Z1 - Z2 == Z1 + zminus(Z2)" - - zless_def "Z1},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 diff -r f04b33ce250f -r a4dc62a46ee4 Integ/ROOT.ML --- 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*) diff -r f04b33ce250f -r a4dc62a46ee4 Integ/Relation.ML --- 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. :r ==> :converse(r)"; -by (simp_tac prod_ss 1); -by (fast_tac set_cs 1); -qed "converseI"; - -goalw Relation.thy [converse_def] "!!a b r. : converse(r) ==> : r"; -by (fast_tac comp_cs 1); -qed "converseD"; - -qed_goalw "converseE" Relation.thy [converse_def] - "[| yx : converse(r); \ -\ !!x y. [| yx=; :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. : r)" - (fn _=> [ (fast_tac comp_cs 1) ]); - -qed_goal "DomainI" Relation.thy "!!a b r. : r ==> a: Domain(r)" - (fn _ => [ (etac (exI RS (Domain_iff RS iffD2)) 1) ]); - -qed_goal "DomainE" Relation.thy - "[| a : Domain(r); !!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.: r ==> b : Range(r)" - (fn _ => [ (etac (converseI RS DomainI) 1) ]); - -qed_goalw "RangeE" Relation.thy [Range_def] - "[| b : Range(r); !!x. : 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. :r)" - (fn _ => [ fast_tac (comp_cs addIs [RangeI]) 1 ]); - -qed_goal "Image_singleton_iff" Relation.thy - "(b : r^^{a}) = (:r)" - (fn _ => [ rtac (Image_iff RS trans) 1, - fast_tac comp_cs 1 ]); - -qed_goalw "ImageI" Relation.thy [Image_def] - "!!a b r. [| : 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.[| : 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]; - diff -r f04b33ce250f -r a4dc62a46ee4 Integ/Relation.thy --- 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= & z=)}" - Domain_def "Domain(r) == {z. ! x. (z=x --> (? y. :r))}" - Range_def "Range(r) == Domain(converse(r))" - Image_def "r ^^ s == {y. y:Range(r) & (? x:s. :r)}" - -end diff -r f04b33ce250f -r a4dc62a46ee4 Lfp.ML --- 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"; diff -r f04b33ce250f -r a4dc62a46ee4 Lfp.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 List.ML --- 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]; - diff -r f04b33ce250f -r a4dc62a46ee4 List.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Makefile --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Nat.ML --- 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 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] " : 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 = |] ==> 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 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 i ~ m<(n::nat)"; -by(fast_tac (HOL_cs addIs ([wf_pred_nat, wf_trancl RS wf_asym]@prems))1); -qed "less_not_sym"; - -(* [| 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 R *) -bind_thm ("less_anti_refl", (less_not_refl RS notE)); - -goal Nat.thy "!!m. n 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 P; !!j. [| i 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 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 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 Suc(m) < Suc(n)"; -by (subgoal_tac "m 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 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<=(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 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]; diff -r f04b33ce250f -r a4dc62a46ee4 Nat.thy --- 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 = }" - - less_def "m:trancl(pred_nat)" - - le_def "m<=(n::nat) == ~(n 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"; - diff -r f04b33ce250f -r a4dc62a46ee4 Ord.thy --- 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 - diff -r f04b33ce250f -r a4dc62a46ee4 Prod.ML --- 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=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=a' & b=b')"; -by (fast_tac (set_cs addIs [Pair_inject]) 1); -qed "Pair_eq"; - -goalw Prod.thy [fst_def] "fst() = a"; -by (fast_tac (set_cs addIs [select_equality] addSEs [Pair_inject]) 1); -qed "fst_conv"; - -goalw Prod.thy [snd_def] "snd() = b"; -by (fast_tac (set_cs addIs [select_equality] addSEs [Pair_inject]) 1); -qed "snd_conv"; - -goalw Prod.thy [Pair_def] "? x y. p = "; -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 = ==> 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, ) = 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 = "; -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., 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 = --> 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, )"; -by (asm_simp_tac prod_ss 1); -qed "splitI"; - -val prems = goalw Prod.thy [split_def] - "[| split(c,p); !!x y. [| p = ; c(x,y) |] ==> Q |] ==> Q"; -by (REPEAT (resolve_tac (prems@[surjective_pairing]) 1)); -qed "splitE"; - -goal Prod.thy "!!R a b. split(R,) ==> R(a,b)"; -by (etac (split RS iffD1) 1); -qed "splitD"; - -goal Prod.thy "!!a b c. z: c(a,b) ==> z: split(c, )"; -by (asm_simp_tac prod_ss 1); -qed "mem_splitI"; - -val prems = goalw Prod.thy [split_def] - "[| z: split(c,p); !!x y. [| p = ; 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,) = "; -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 ":r ==> : 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=; :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) |] ==> : 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= |] ==> 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 -- introduces no eigenvariables **) -qed_goal "SigmaD1" Prod.thy " : 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 " : 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 - "[| : 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] " : 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.[| : 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] " : 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.[| : 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]; diff -r f04b33ce250f -r a4dc62a46ee4 Prod.thy --- 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 - "" == ">" - "" == "Pair(x, y)" - "" => "x" - -defs - Pair_def "Pair(a, b) == Abs_Prod(Pair_Rep(a, b))" - fst_def "fst(p) == @a. ? b. p = " - snd_def "snd(p) == @b. ? a. p = " - split_def "split(c, p) == c(fst(p), snd(p))" - prod_fun_def "prod_fun(f, g) == split(%x y.)" - Sigma_def "Sigma(A, B) == UN x:A. UN y:B(x). {}" - - - -(** Unit **) - -subtype (Unit) - unit = "{p. p = True}" - -consts - Unity :: "unit" ("<>") - -defs - Unity_def "Unity == Abs_Unit(True)" - -end diff -r f04b33ce250f -r a4dc62a46ee4 README --- 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) diff -r f04b33ce250f -r a4dc62a46ee4 ROOT.ML --- 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*) diff -r f04b33ce250f -r a4dc62a46ee4 Set.ML --- 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) *) diff -r f04b33ce250f -r a4dc62a46ee4 Set.thy --- 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; - diff -r f04b33ce250f -r a4dc62a46ee4 Sexp.ML --- 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"; - -(* : 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 |] ==> : 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 |] ==> : 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 :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: sexp; N: sexp |] ==> R; \ -\ !!M N. [| p = ; 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"; diff -r f04b33ce250f -r a4dc62a46ee4 Sexp.thy --- 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. {, }" - - 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 diff -r f04b33ce250f -r a4dc62a46ee4 Subst/AList.ML --- 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(#al,c,d) = d(a,b,al,alist_rec(al,c,d))", - "assoc(v,d,[]) = d", - "assoc(v,d,#al) = if(v=a,b,assoc(v,d,al))"] end; - -val prems = goal AList.thy - "[| P([]); \ -\ !!x y xs. P(xs) ==> P(#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)]; diff -r f04b33ce250f -r a4dc62a46ee4 Subst/AList.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Subst/ROOT.ML --- 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*) diff -r f04b33ce250f -r a4dc62a46ee4 Subst/Setplus.ML --- 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; diff -r f04b33ce250f -r a4dc62a46ee4 Subst/Setplus.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Subst/Subst.ML --- 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", - "#al <> bl = # (al <> bl)", - "sdom([]) = {}", - "sdom(#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 <| #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 <| #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 <| #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 <| #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 "#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); diff -r f04b33ce250f -r a4dc62a46ee4 Subst/Subst.thy --- 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.#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 diff -r f04b33ce250f -r a4dc62a46ee4 Subst/UTLemmas.ML --- 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"; diff -r f04b33ce250f -r a4dc62a46ee4 Subst/UTLemmas.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Subst/UTerm.ML --- 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]; - diff -r f04b33ce250f -r a4dc62a46ee4 Subst/UTerm.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Subst/Unifier.ML --- 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(#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([],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([])"; -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<> #s) = \ -\ vars_of(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<> #s) = \ -\ vars_of(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 #Nil *) -(* | unify Comb(t,u) Const(n) = Fail *) -(* | unify Comb(t,u) Var(v) = if Var(v) <: Comb(t,u) then Fail *) -(* else #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([],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"; diff -r f04b33ce250f -r a4dc62a46ee4 Subst/Unifier.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Sum.ML --- 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"; - diff -r f04b33ce250f -r a4dc62a46ee4 Sum.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 Trancl.ML --- 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. [| :r; :r |] ==> :r) ==> trans(r)"; -by (REPEAT (ares_tac (prems@[allI,impI]) 1)); -qed "transI"; - -val major::prems = goalw Trancl.thy [trans_def] - "[| trans(r); :r; :r |] ==> :r"; -by (cut_facts_tac [major] 1); -by (fast_tac (HOL_cs addIs prems) 1); -qed "transD"; - -(** Identity relation **) - -goalw Trancl.thy [id_def] " : 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 = |] ==> P \ -\ |] ==> P"; -by (rtac (major RS CollectE) 1); -by (etac exE 1); -by (eresolve_tac prems 1); -qed "idE"; - -goalw Trancl.thy [id_def] ":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] - "[| :s; :r |] ==> : 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 = ; :s; :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 - "[| : r O s; \ -\ !!y. [| :s; :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 " : 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 - "[| : r^*; : r |] ==> : 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 "[| : r |] ==> : 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 - "[| : r^*; \ -\ !!x. P(); \ -\ !!x y z.[| P(); : r^*; : r |] ==> P() |] \ -\ ==> P()"; -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 - "[| : r^*; \ -\ P(a); \ -\ !!y z.[| : r^*; : r; P(y) |] ==> P(z) |] \ -\ ==> P(b)"; -(*by induction on this formula*) -by (subgoal_tac "! 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 - "[| : r^*; (a = b) ==> P; \ -\ !!y.[| : r^*; : r |] ==> P \ -\ |] ==> P"; -by (subgoal_tac "(a::'a) = b | (? y. : r^* & : 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] - " : r^+ ==> : 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] - "[| : r |] ==> : 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] - "[| : r^*; : r |] ==> : r^+"; -by (REPEAT (resolve_tac ([compI]@prems) 1)); -qed "rtrancl_into_trancl1"; - -(*intro rule from r and rtrancl*) -val prems = goal Trancl.thy - "[| : r; : r^* |] ==> : 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 - "[| : r^+; \ -\ : r ==> P; \ -\ !!y.[| : r^+; : r |] ==> P \ -\ |] ==> P"; -by (subgoal_tac " : r | (? y. : r^+ & : 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 - "[| : r; : r^+ |] ==> : 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 - "[| : 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]; diff -r f04b33ce250f -r a4dc62a46ee4 Trancl.thy --- 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. :r --> :r --> :r)" -comp_def (*composition of relations*) - "r O s == {xz. ? x y z. xz = & :s & :r}" -id_def (*the identity relation*) - "id == {p. ? x. p = }" -rtrancl_def "r^* == lfp(%s. id Un (r O s))" -trancl_def "r^+ == r O rtrancl(r)" -end diff -r f04b33ce250f -r a4dc62a46ee4 Univ.ML --- 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 ~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,) = "; -by (rtac split 1); -qed "apfst_conv"; - -val [major,minor] = goal Univ.thy - "[| q = apfst(f,p); !!x y. [| p = ; q = |] ==> 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 |] ==> : 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 = |] ==> 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. [| :r; :s |] ==> : 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'. [| : r; : s; c = |] ==> 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. :r ==> : r<++>s"; -by (fast_tac prod_cs 1); -qed "dsum_In0I"; - -goalw Univ.thy [dsum_def] "!!r. :s ==> : r<++>s"; -by (fast_tac prod_cs 1); -qed "dsum_In1I"; - -val major::prems = goalw Univ.thy [dsum_def] - "[| w : r<++>s; \ -\ !!x x'. [| : r; w = |] ==> P; \ -\ !!y y'. [| : s; w = |] ==> 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; diff -r f04b33ce250f -r a4dc62a46ee4 Univ.thy --- 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 = 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 ~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. ))" - 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)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. {}" - - dprod_def "r<**>s == UN u:r. split(%x x'. - UN v:s. split(%y y'. {}, v), u)" - - dsum_def "r<++>s == (UN u:r. split(%x x'. {}, u)) Un - (UN v:s. split(%y y'. {}, v))" - -end diff -r f04b33ce250f -r a4dc62a46ee4 WF.ML --- 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. : 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. : 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); :r; :r |] ==> P"; -by (subgoal_tac "! x. :r --> :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); : 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. :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. :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); ~:r |] ==> f(b) = (@z.True)"; -by (etac ssubst 1); -by(asm_simp_tac HOL_ss 1); -qed "is_recfun_undef"; - -(*eresolve_tac transD solves :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) |] ==> \ - \ :r --> :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); :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); :r; :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); :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"; diff -r f04b33ce250f -r a4dc62a46ee4 WF.thy --- 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. :r --> P(y)) --> P(x)) --> (!x.P(x)))" - - cut_def "cut(f,r,x) == (%y. if(: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 diff -r f04b33ce250f -r a4dc62a46ee4 add_ind_def.ML --- 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; - - - - diff -r f04b33ce250f -r a4dc62a46ee4 datatype.ML --- 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 - 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. -*) diff -r f04b33ce250f -r a4dc62a46ee4 equalities.ML --- 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]; diff -r f04b33ce250f -r a4dc62a46ee4 equalities.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/Acc.ML --- 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. :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); : 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. :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. : r | :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"; diff -r f04b33ce250f -r a4dc62a46ee4 ex/Acc.thy --- 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. :r}" - -inductive "acc(r)" - intrs - pred "pred(a,r): Pow(acc(r)) ==> a: acc(r)" - monos "[Pow_mono]" - -end diff -r f04b33ce250f -r a4dc62a46ee4 ex/InSort.ML --- 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(); diff -r f04b33ce250f -r a4dc62a46ee4 ex/InSort.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/LList.ML --- 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()), 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. : 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] " : 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; :s |] ==> : 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) ==> : 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. [| : 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. )")] 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())"; -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())"; -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) |] ==> \ -\ : \ -\ LListD_Fun(diag(A), (%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. ) = \ -\ 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] - "[| : r; r <= llistD_Fun(r Un range(%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] " : 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] - ":r ==> : 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. : llistD_Fun(r Un range(%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. : \ -\ llistD_Fun(range(%u. ) Un range(%v. )) \ -\ |] ==> f(l) = (g(l :: 'a llist) :: 'b llist)"; -by (res_inst_tac [("r", "range(%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.)")] - 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 {} - 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. )")] - 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.)")] - 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.)")] - 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"; diff -r f04b33ce250f -r a4dc62a46ee4 ex/LList.thy --- 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) == - {} Un - (UN x. (split(%l1 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 " : LListD(r)" - CONS_I "[| : r; : LListD(r) - |] ==> : 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 = | - (? M N a b. z = & - : r & : 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()), 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()))" - - lmap_def - "lmap(f,l) == llist_corec(l, llist_case(Inl(Unity), %y z. Inr()))" - - iterates_def "iterates(f,a) == llist_corec(a, %x. Inr())" - -(*Append generates its result by applying f, where - f() = Inl(Unity) - f() = Inr() - f() = Inr() -*) - - Lappend_def - "Lappend(M,N) == LList_corec(, - split(List_case(List_case(Inl(Unity), %N1 N2. Inr(>)), - %M1 M2 N. Inr(>))))" - - lappend_def - "lappend(l,n) == llist_corec(, - split(llist_case(llist_case(Inl(Unity), %n1 n2. Inr(>)), - %l1 l2 n. Inr(>))))" - -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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/LexProd.ML --- 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() ==> !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"; diff -r f04b33ce250f -r a4dc62a46ee4 ex/LexProd.thy --- 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 = <,> & ( : ra | a=a' & : rb)}" -end - diff -r f04b33ce250f -r a4dc62a46ee4 ex/MT.ML --- 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(),snd())"; -by (simp_tac (prod_ss addsimps prems) 1); -qed "infsys_p1"; - -val prems = goal MT.thy "!!a b. P(fst(),snd()) ==> 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(<,c>)),snd(fst(<,c>)),snd(<,c>))"; -by (simp_tac (prod_ss addsimps prems) 1); -qed "infsys_pp1"; - -goal MT.thy - "!!a.P(fst(fst(<,c>)),snd(fst(<,c>)),snd(<,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(<,v_const(c)>); \ -\ !!ev ve. ev:ve_dom(ve) ==> P(<,ve_app(ve,ev)>); \ -\ !!ev ve e. P(< e>,v_clos(<|ev,e,ve|>)>); \ -\ !!ev1 ev2 ve cl e. \ -\ cl = <| ev1, e, ve + {ev2 |-> v_clos(cl)} |> ==> \ -\ P(<,v_clos(cl)>); \ -\ !!ve c1 c2 e1 e2. \ -\ [| P(<,v_const(c1)>); P(<,v_const(c2)>) |] ==> \ -\ P(<,v_const(c_app(c1,c2))>); \ -\ !!ve vem xm e1 e2 em v v2. \ -\ [| P(<,v_clos(<|xm,em,vem|>)>); \ -\ P(<,v2>); \ -\ P(< v2},em>,v>) \ -\ |] ==> \ -\ P(<,v>) \ -\ |] ==> \ -\ P(<,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(<,t>); \ -\ !!te x. x:te_dom(te) ==> P(<,te_app(te,x)>); \ -\ !!te x e t1 t2. \ -\ [| te + {x |=> t1} |- e ===> t2; P(< t1},e>,t2>) |] ==> \ -\ P(< e>,t1->t2>); \ -\ !!te f x e t1 t2. \ -\ [| te + {f |=> t1->t2} + {x |=> t1} |- e ===> t2; \ -\ P(< t1->t2} + {x |=> t1},e>,t2>) \ -\ |] ==> \ -\ P(<,t1->t2>); \ -\ !!te e1 e2 t1 t2. \ -\ [| te |- e1 ===> t1->t2; P(<,t1->t2>); \ -\ te |- e2 ===> t1; P(<,t1>) \ -\ |] ==> \ -\ P(<,t2>) \ -\ |] ==> \ -\ P(<,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(<,t>); \ -\ !!te x. x:te_dom(te) ==> P(<,te_app(te,x)>); \ -\ !!te x e t1 t2. \ -\ te + {x |=> t1} |- e ===> t2 ==> P(< e>,t1->t2>); \ -\ !!te f x e t1 t2. \ -\ te + {f |=> t1->t2} + {x |=> t1} |- e ===> t2 ==> \ -\ P(<,t1->t2>); \ -\ !!te e1 e2 t1 t2. \ -\ [| te |- e1 ===> t1->t2; te |- e2 ===> t1 |] ==> \ -\ P(<,t2>) \ -\ |] ==> \ -\ P(<,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 ==> : 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) --> \ -\ : {),t>} Un hasty_rel \ -\ |] ==> \ -\ ),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(); \ -\ !! te ev e t ve. \ -\ [| te |- fn ev => e ===> t; \ -\ ve_dom(ve) = te_dom(te); \ -\ !ev1.ev1:ve_dom(ve) --> : hasty_rel \ -\ |] ==> P(),t>); \ -\ : hasty_rel \ -\ |] ==> P()"; -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 - " [| : 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) --> : 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"; - - diff -r f04b33ce250f -r a4dc62a46ee4 ex/MT.thy --- 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=<,v_const(c)>) | - (? ve x. pp=<,ve_app(ve,x)> & x:ve_dom(ve)) | - (? ve e x. pp=< e>,v_clos(<|x,e,ve|>)>)| - ( ? ve e x f cl. - pp=<,v_clos(cl)> & - cl=<|x, e, ve+{f |-> v_clos(cl)} |> - ) | - ( ? ve e1 e2 c1 c2. - pp=<,v_const(c_app(c1,c2))> & - <,v_const(c1)>:s & <,v_const(c2)>:s - ) | - ( ? ve vem e1 e2 em xm v v2. - pp=<,v> & - <,v_clos(<|xm,em,vem|>)>:s & - <,v2>:s & - < v2},em>,v>:s - ) - }" - - eval_rel_def "eval_rel == lfp(eval_fun)" - eval_def "ve |- e ---> v == <,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=<,t> & c isof t) | - (? te x. pp=<,te_app(te,x)> & x:te_dom(te)) | - (? te x e t1 t2. pp=< e>,t1->t2> & < t1},e>,t2>:s) | - (? te f x e t1 t2. - pp=<,t1->t2> & < t1->t2}+{x |=> t1},e>,t2>:s - ) | - (? te e1 e2 t1 t2. - pp=<,t2> & <,t1->t2>:s & <,t1>:s - ) - }" - - elab_rel_def "elab_rel == lfp(elab_fun)" - elab_def "te |- e ===> t == <,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 = & c isof t) | - ( ? ev e ve t te. - p = ),t> & - te |- fn ev => e ===> t & - ve_dom(ve) = te_dom(te) & - (! ev1.ev1:ve_dom(ve) --> : r) - ) - } - " - - hasty_rel_def "hasty_rel == gfp(hasty_fun)" - hasty_def "v hasty 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/NatSum.ML --- 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"; - diff -r f04b33ce250f -r a4dc62a46ee4 ex/NatSum.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/PropLog.ML --- 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."; diff -r f04b33ce250f -r a4dc62a46ee4 ex/PropLog.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/Puzzle.ML --- 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 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(); diff -r f04b33ce250f -r a4dc62a46ee4 ex/Puzzle.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/Qsort.ML --- 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(); diff -r f04b33ce250f -r a4dc62a46ee4 ex/Qsort.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/ROOT.ML --- 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"; diff -r f04b33ce250f -r a4dc62a46ee4 ex/Rec.ML --- 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"; diff -r f04b33ce250f -r a4dc62a46ee4 ex/Rec.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/SList.ML --- 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 |] ==> : 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 |] ==> : pred_sexp^+"; -by (asm_simp_tac pred_sexp_ss 1); -qed "pred_sexp_CONS_I2"; - -val [prem] = goal SList.thy - " : pred_sexp^+ ==> \ -\ : pred_sexp^+ & : 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]; - diff -r f04b33ce250f -r a4dc62a46ee4 ex/SList.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/Simult.ML --- 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"; diff -r f04b33ce250f -r a4dc62a46ee4 ex/Simult.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/Sorting.ML --- 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]; diff -r f04b33ce250f -r a4dc62a46ee4 ex/Sorting.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/String.ML --- 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(); diff -r f04b33ce250f -r a4dc62a46ee4 ex/String.thy --- 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; - diff -r f04b33ce250f -r a4dc62a46ee4 ex/Term.ML --- 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. : 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; diff -r f04b33ce250f -r a4dc62a46ee4 ex/Term.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 ex/cla.ML --- 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."; diff -r f04b33ce250f -r a4dc62a46ee4 ex/meson.ML --- 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."; diff -r f04b33ce250f -r a4dc62a46ee4 ex/mesontest.ML --- 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*) diff -r f04b33ce250f -r a4dc62a46ee4 ex/rel.ML --- 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. : r}" ), - ("range2_def", "range2(r) == {b. ? a. : 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] ": 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. : 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] ": 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. : 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] ": r ==> a : field(r)"; -by (rtac (prem RS domainI RS UnI1) 1); -qed "fieldI1"; - -val [prem] = goalw Rel.thy [field_def] ": r ==> b : field(r)"; -by (rtac (prem RS range2I RS UnI2) 1); -qed "fieldI2"; - -val [prem] = goalw Rel.thy [field_def] - "(~ :r ==> : 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. : r ==> P; \ -\ !!x. : 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. : 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"; - diff -r f04b33ce250f -r a4dc62a46ee4 ex/set.ML --- 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."; diff -r f04b33ce250f -r a4dc62a46ee4 ex/unsolved.ML --- 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))")); - diff -r f04b33ce250f -r a4dc62a46ee4 hologic.ML --- 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; - diff -r f04b33ce250f -r a4dc62a46ee4 ind_syntax.ML --- 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; diff -r f04b33ce250f -r a4dc62a46ee4 indrule.ML --- 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; diff -r f04b33ce250f -r a4dc62a46ee4 intr_elim.ML --- 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; - diff -r f04b33ce250f -r a4dc62a46ee4 mono.ML --- 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]; - diff -r f04b33ce250f -r a4dc62a46ee4 mono.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 simpdata.ML --- 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)"; diff -r f04b33ce250f -r a4dc62a46ee4 subset.ML --- 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"; diff -r f04b33ce250f -r a4dc62a46ee4 subset.thy --- 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 diff -r f04b33ce250f -r a4dc62a46ee4 subtype.ML --- 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; - diff -r f04b33ce250f -r a4dc62a46ee4 thy_syntax.ML --- 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 (); -