author | wenzelm |
Sat, 05 Jun 1999 20:30:29 +0200 | |
changeset 6786 | 0af1797d5315 |
parent 6539 | 2e7d2fba9f6c |
child 6899 | 020314dadebd |
permissions | -rw-r--r-- |
250 | 1 |
(* Title: Pure/thm.ML |
0 | 2 |
ID: $Id$ |
250 | 3 |
Author: Lawrence C Paulson, Cambridge University Computer Laboratory |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
4 |
Copyright 1994 University of Cambridge |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
5 |
|
1160 | 6 |
The core of Isabelle's Meta Logic: certified types and terms, meta |
1529 | 7 |
theorems, meta rules (including resolution and simplification). |
0 | 8 |
*) |
9 |
||
6089 | 10 |
signature BASIC_THM = |
1503 | 11 |
sig |
1160 | 12 |
(*certified types*) |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
13 |
type ctyp |
1238 | 14 |
val rep_ctyp : ctyp -> {sign: Sign.sg, T: typ} |
15 |
val typ_of : ctyp -> typ |
|
16 |
val ctyp_of : Sign.sg -> typ -> ctyp |
|
17 |
val read_ctyp : Sign.sg -> string -> ctyp |
|
1160 | 18 |
|
19 |
(*certified terms*) |
|
20 |
type cterm |
|
1493
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
21 |
exception CTERM of string |
4270 | 22 |
val rep_cterm : cterm -> {sign: Sign.sg, t: term, T: typ, maxidx: int} |
4288 | 23 |
val crep_cterm : cterm -> {sign: Sign.sg, t: term, T: ctyp, maxidx: int} |
1238 | 24 |
val term_of : cterm -> term |
25 |
val cterm_of : Sign.sg -> term -> cterm |
|
2671 | 26 |
val ctyp_of_term : cterm -> ctyp |
1238 | 27 |
val read_cterm : Sign.sg -> string * typ -> cterm |
28 |
val cterm_fun : (term -> term) -> (cterm -> cterm) |
|
1493
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
29 |
val dest_comb : cterm -> cterm * cterm |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
30 |
val dest_abs : cterm -> cterm * cterm |
1703
e22ad43bab5f
moved dest_cimplies to drule.ML; added adjust_maxidx
clasohm
parents:
1659
diff
changeset
|
31 |
val adjust_maxidx : cterm -> cterm |
1516
96286c4e32de
removed mk_prop; added capply; simplified dest_abs
clasohm
parents:
1503
diff
changeset
|
32 |
val capply : cterm -> cterm -> cterm |
1517 | 33 |
val cabs : cterm -> cterm -> cterm |
1238 | 34 |
val read_def_cterm : |
1160 | 35 |
Sign.sg * (indexname -> typ option) * (indexname -> sort option) -> |
36 |
string list -> bool -> string * typ -> cterm * (indexname * typ) list |
|
4281
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
37 |
val read_def_cterms : |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
38 |
Sign.sg * (indexname -> typ option) * (indexname -> sort option) -> |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
39 |
string list -> bool -> (string * typ)list |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
40 |
-> cterm list * (indexname * typ)list |
1160 | 41 |
|
2671 | 42 |
(*proof terms [must DUPLICATE declaration as a specification]*) |
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
43 |
datatype deriv_kind = MinDeriv | ThmDeriv | FullDeriv; |
6089 | 44 |
type tag (* = string * string list *) |
2386 | 45 |
val keep_derivs : deriv_kind ref |
1529 | 46 |
datatype rule = |
2386 | 47 |
MinProof |
4999 | 48 |
| Oracle of string * Sign.sg * Object.T |
6089 | 49 |
| Axiom of string * tag list |
50 |
| Theorem of string * tag list |
|
2671 | 51 |
| Assume of cterm |
52 |
| Implies_intr of cterm |
|
1529 | 53 |
| Implies_intr_shyps |
54 |
| Implies_intr_hyps |
|
55 |
| Implies_elim |
|
2671 | 56 |
| Forall_intr of cterm |
57 |
| Forall_elim of cterm |
|
58 |
| Reflexive of cterm |
|
1529 | 59 |
| Symmetric |
60 |
| Transitive |
|
2671 | 61 |
| Beta_conversion of cterm |
1529 | 62 |
| Extensional |
2671 | 63 |
| Abstract_rule of string * cterm |
1529 | 64 |
| Combination |
65 |
| Equal_intr |
|
66 |
| Equal_elim |
|
2671 | 67 |
| Trivial of cterm |
68 |
| Lift_rule of cterm * int |
|
69 |
| Assumption of int * Envir.env option |
|
70 |
| Rotate_rule of int * int |
|
71 |
| Instantiate of (indexname * ctyp) list * (cterm * cterm) list |
|
72 |
| Bicompose of bool * bool * int * int * Envir.env |
|
73 |
| Flexflex_rule of Envir.env |
|
4182 | 74 |
| Class_triv of class |
6786 | 75 |
| VarifyT of string list |
1529 | 76 |
| FreezeT |
2671 | 77 |
| RewriteC of cterm |
78 |
| CongC of cterm |
|
79 |
| Rewrite_cterm of cterm |
|
80 |
| Rename_params_rule of string list * int; |
|
6089 | 81 |
type deriv (* = rule mtree *) |
1529 | 82 |
|
1160 | 83 |
(*meta theorems*) |
84 |
type thm |
|
1529 | 85 |
val rep_thm : thm -> {sign: Sign.sg, der: deriv, maxidx: int, |
2386 | 86 |
shyps: sort list, hyps: term list, |
87 |
prop: term} |
|
1529 | 88 |
val crep_thm : thm -> {sign: Sign.sg, der: deriv, maxidx: int, |
2386 | 89 |
shyps: sort list, hyps: cterm list, |
90 |
prop: cterm} |
|
6089 | 91 |
exception THM of string * int * thm list |
92 |
type 'a attribute (* = 'a * thm -> 'a * thm *) |
|
3994 | 93 |
val eq_thm : thm * thm -> bool |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
94 |
val sign_of_thm : thm -> Sign.sg |
4254 | 95 |
val transfer_sg : Sign.sg -> thm -> thm |
3895 | 96 |
val transfer : theory -> thm -> thm |
1238 | 97 |
val tpairs_of : thm -> (term * term) list |
98 |
val prems_of : thm -> term list |
|
99 |
val nprems_of : thm -> int |
|
100 |
val concl_of : thm -> term |
|
101 |
val cprop_of : thm -> cterm |
|
102 |
val extra_shyps : thm -> sort list |
|
3061 | 103 |
val force_strip_shyps : bool ref (* FIXME tmp (since 1995/08/01) *) |
1238 | 104 |
val strip_shyps : thm -> thm |
105 |
val implies_intr_shyps: thm -> thm |
|
3812 | 106 |
val get_axiom : theory -> xstring -> thm |
6368 | 107 |
val def_name : string -> string |
4847 | 108 |
val get_def : theory -> xstring -> thm |
1238 | 109 |
val axioms_of : theory -> (string * thm) list |
1160 | 110 |
|
111 |
(*meta rules*) |
|
1238 | 112 |
val assume : cterm -> thm |
1416 | 113 |
val compress : thm -> thm |
1238 | 114 |
val implies_intr : cterm -> thm -> thm |
115 |
val implies_elim : thm -> thm -> thm |
|
116 |
val forall_intr : cterm -> thm -> thm |
|
117 |
val forall_elim : cterm -> thm -> thm |
|
118 |
val reflexive : cterm -> thm |
|
119 |
val symmetric : thm -> thm |
|
120 |
val transitive : thm -> thm -> thm |
|
121 |
val beta_conversion : cterm -> thm |
|
122 |
val extensional : thm -> thm |
|
123 |
val abstract_rule : string -> cterm -> thm -> thm |
|
124 |
val combination : thm -> thm -> thm |
|
125 |
val equal_intr : thm -> thm -> thm |
|
126 |
val equal_elim : thm -> thm -> thm |
|
127 |
val implies_intr_hyps : thm -> thm |
|
4270 | 128 |
val flexflex_rule : thm -> thm Seq.seq |
1238 | 129 |
val instantiate : |
1160 | 130 |
(indexname * ctyp) list * (cterm * cterm) list -> thm -> thm |
1238 | 131 |
val trivial : cterm -> thm |
6368 | 132 |
val class_triv : Sign.sg -> class -> thm |
1238 | 133 |
val varifyT : thm -> thm |
6786 | 134 |
val varifyT' : string list -> thm -> thm |
1238 | 135 |
val freezeT : thm -> thm |
136 |
val dest_state : thm * int -> |
|
1160 | 137 |
(term * term) list * term list * term * term |
1238 | 138 |
val lift_rule : (thm * int) -> thm -> thm |
4270 | 139 |
val assumption : int -> thm -> thm Seq.seq |
1238 | 140 |
val eq_assumption : int -> thm -> thm |
2671 | 141 |
val rotate_rule : int -> int -> thm -> thm |
1160 | 142 |
val rename_params_rule: string list * int -> thm -> thm |
1238 | 143 |
val bicompose : bool -> bool * thm * int -> |
4270 | 144 |
int -> thm -> thm Seq.seq |
1238 | 145 |
val biresolution : bool -> (bool * thm) list -> |
4270 | 146 |
int -> thm -> thm Seq.seq |
1160 | 147 |
|
148 |
(*meta simplification*) |
|
3550 | 149 |
exception SIMPLIFIER of string * thm |
1160 | 150 |
type meta_simpset |
3550 | 151 |
val dest_mss : meta_simpset -> |
152 |
{simps: thm list, congs: thm list, procs: (string * cterm list) list} |
|
1238 | 153 |
val empty_mss : meta_simpset |
3550 | 154 |
val merge_mss : meta_simpset * meta_simpset -> meta_simpset |
1238 | 155 |
val add_simps : meta_simpset * thm list -> meta_simpset |
156 |
val del_simps : meta_simpset * thm list -> meta_simpset |
|
157 |
val mss_of : thm list -> meta_simpset |
|
158 |
val add_congs : meta_simpset * thm list -> meta_simpset |
|
2626 | 159 |
val del_congs : meta_simpset * thm list -> meta_simpset |
2509 | 160 |
val add_simprocs : meta_simpset * |
3577
9715b6e3ec5f
added prems argument to simplification procedures;
wenzelm
parents:
3565
diff
changeset
|
161 |
(string * cterm list * (Sign.sg -> thm list -> term -> thm option) * stamp) list |
9715b6e3ec5f
added prems argument to simplification procedures;
wenzelm
parents:
3565
diff
changeset
|
162 |
-> meta_simpset |
2509 | 163 |
val del_simprocs : meta_simpset * |
3577
9715b6e3ec5f
added prems argument to simplification procedures;
wenzelm
parents:
3565
diff
changeset
|
164 |
(string * cterm list * (Sign.sg -> thm list -> term -> thm option) * stamp) list |
9715b6e3ec5f
added prems argument to simplification procedures;
wenzelm
parents:
3565
diff
changeset
|
165 |
-> meta_simpset |
1238 | 166 |
val add_prems : meta_simpset * thm list -> meta_simpset |
167 |
val prems_of_mss : meta_simpset -> thm list |
|
168 |
val set_mk_rews : meta_simpset * (thm -> thm list) -> meta_simpset |
|
4679 | 169 |
val set_mk_sym : meta_simpset * (thm -> thm option) -> meta_simpset |
170 |
val set_mk_eq_True : meta_simpset * (thm -> thm option) -> meta_simpset |
|
2509 | 171 |
val set_termless : meta_simpset * (term * term -> bool) -> meta_simpset |
1238 | 172 |
val trace_simp : bool ref |
4713 | 173 |
val rewrite_cterm : bool * bool * bool -> meta_simpset -> |
1529 | 174 |
(meta_simpset -> thm -> thm option) -> cterm -> thm |
1539 | 175 |
|
4999 | 176 |
val invoke_oracle : theory -> xstring -> Sign.sg * Object.T -> thm |
250 | 177 |
end; |
0 | 178 |
|
6089 | 179 |
signature THM = |
180 |
sig |
|
181 |
include BASIC_THM |
|
182 |
val no_attributes : 'a -> 'a * 'b attribute list |
|
183 |
val apply_attributes : ('a * thm) * 'a attribute list -> ('a * thm) |
|
184 |
val applys_attributes : ('a * thm list) * 'a attribute list -> ('a * thm list) |
|
185 |
val get_name_tags : thm -> string * tag list |
|
186 |
val put_name_tags : string * tag list -> thm -> thm |
|
187 |
val name_of_thm : thm -> string |
|
188 |
val tags_of_thm : thm -> tag list |
|
189 |
val name_thm : string * thm -> thm |
|
190 |
end; |
|
191 |
||
3550 | 192 |
structure Thm: THM = |
0 | 193 |
struct |
250 | 194 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
195 |
(*** Certified terms and types ***) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
196 |
|
250 | 197 |
(** certified types **) |
198 |
||
199 |
(*certified typs under a signature*) |
|
200 |
||
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
201 |
datatype ctyp = Ctyp of {sign_ref: Sign.sg_ref, T: typ}; |
250 | 202 |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
203 |
fun rep_ctyp (Ctyp {sign_ref, T}) = {sign = Sign.deref sign_ref, T = T}; |
250 | 204 |
fun typ_of (Ctyp {T, ...}) = T; |
205 |
||
206 |
fun ctyp_of sign T = |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
207 |
Ctyp {sign_ref = Sign.self_ref sign, T = Sign.certify_typ sign T}; |
250 | 208 |
|
209 |
fun read_ctyp sign s = |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
210 |
Ctyp {sign_ref = Sign.self_ref sign, T = Sign.read_typ (sign, K None) s}; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
211 |
|
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
212 |
|
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
213 |
|
250 | 214 |
(** certified terms **) |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
215 |
|
250 | 216 |
(*certified terms under a signature, with checked typ and maxidx of Vars*) |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
217 |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
218 |
datatype cterm = Cterm of {sign_ref: Sign.sg_ref, t: term, T: typ, maxidx: int}; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
219 |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
220 |
fun rep_cterm (Cterm {sign_ref, t, T, maxidx}) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
221 |
{sign = Sign.deref sign_ref, t = t, T = T, maxidx = maxidx}; |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
222 |
|
4288 | 223 |
fun crep_cterm (Cterm {sign_ref, t, T, maxidx}) = |
224 |
{sign = Sign.deref sign_ref, t = t, T = Ctyp {sign_ref = sign_ref, T = T}, |
|
225 |
maxidx = maxidx}; |
|
226 |
||
250 | 227 |
fun term_of (Cterm {t, ...}) = t; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
228 |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
229 |
fun ctyp_of_term (Cterm {sign_ref, T, ...}) = Ctyp {sign_ref = sign_ref, T = T}; |
2671 | 230 |
|
250 | 231 |
(*create a cterm by checking a "raw" term with respect to a signature*) |
232 |
fun cterm_of sign tm = |
|
233 |
let val (t, T, maxidx) = Sign.certify_term sign tm |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
234 |
in Cterm {sign_ref = Sign.self_ref sign, t = t, T = T, maxidx = maxidx} |
1394
a1d2735f5ade
New function read_cterms is a combination of read_def_cterm and
paulson
parents:
1258
diff
changeset
|
235 |
end; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
236 |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
237 |
fun cterm_fun f (Cterm {sign_ref, t, ...}) = cterm_of (Sign.deref sign_ref) (f t); |
250 | 238 |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
239 |
|
1493
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
240 |
exception CTERM of string; |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
241 |
|
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
242 |
(*Destruct application in cterms*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
243 |
fun dest_comb (Cterm {sign_ref, T, maxidx, t = A $ B}) = |
1493
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
244 |
let val typeA = fastype_of A; |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
245 |
val typeB = |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
246 |
case typeA of Type("fun",[S,T]) => S |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
247 |
| _ => error "Function type expected in dest_comb"; |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
248 |
in |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
249 |
(Cterm {sign_ref=sign_ref, maxidx=maxidx, t=A, T=typeA}, |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
250 |
Cterm {sign_ref=sign_ref, maxidx=maxidx, t=B, T=typeB}) |
1493
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
251 |
end |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
252 |
| dest_comb _ = raise CTERM "dest_comb"; |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
253 |
|
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
254 |
(*Destruct abstraction in cterms*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
255 |
fun dest_abs (Cterm {sign_ref, T as Type("fun",[_,S]), maxidx, t=Abs(x,ty,M)}) = |
1516
96286c4e32de
removed mk_prop; added capply; simplified dest_abs
clasohm
parents:
1503
diff
changeset
|
256 |
let val (y,N) = variant_abs (x,ty,M) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
257 |
in (Cterm {sign_ref = sign_ref, T = ty, maxidx = 0, t = Free(y,ty)}, |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
258 |
Cterm {sign_ref = sign_ref, T = S, maxidx = maxidx, t = N}) |
1493
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
259 |
end |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
260 |
| dest_abs _ = raise CTERM "dest_abs"; |
e936723cb94d
added dest_comb, dest_abs and mk_prop for manipulating cterms
clasohm
parents:
1460
diff
changeset
|
261 |
|
2147 | 262 |
(*Makes maxidx precise: it is often too big*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
263 |
fun adjust_maxidx (ct as Cterm {sign_ref, T, t, maxidx, ...}) = |
2147 | 264 |
if maxidx = ~1 then ct |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
265 |
else Cterm {sign_ref = sign_ref, T = T, maxidx = maxidx_of_term t, t = t}; |
1703
e22ad43bab5f
moved dest_cimplies to drule.ML; added adjust_maxidx
clasohm
parents:
1659
diff
changeset
|
266 |
|
1516
96286c4e32de
removed mk_prop; added capply; simplified dest_abs
clasohm
parents:
1503
diff
changeset
|
267 |
(*Form cterm out of a function and an argument*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
268 |
fun capply (Cterm {t=f, sign_ref=sign_ref1, T=Type("fun",[dty,rty]), maxidx=maxidx1}) |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
269 |
(Cterm {t=x, sign_ref=sign_ref2, T, maxidx=maxidx2}) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
270 |
if T = dty then Cterm{t=f$x, sign_ref=Sign.merge_refs(sign_ref1,sign_ref2), T=rty, |
2147 | 271 |
maxidx=Int.max(maxidx1, maxidx2)} |
1516
96286c4e32de
removed mk_prop; added capply; simplified dest_abs
clasohm
parents:
1503
diff
changeset
|
272 |
else raise CTERM "capply: types don't agree" |
96286c4e32de
removed mk_prop; added capply; simplified dest_abs
clasohm
parents:
1503
diff
changeset
|
273 |
| capply _ _ = raise CTERM "capply: first arg is not a function" |
250 | 274 |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
275 |
fun cabs (Cterm {t=Free(a,ty), sign_ref=sign_ref1, T=T1, maxidx=maxidx1}) |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
276 |
(Cterm {t=t2, sign_ref=sign_ref2, T=T2, maxidx=maxidx2}) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
277 |
Cterm {t=absfree(a,ty,t2), sign_ref=Sign.merge_refs(sign_ref1,sign_ref2), |
2147 | 278 |
T = ty --> T2, maxidx=Int.max(maxidx1, maxidx2)} |
1517 | 279 |
| cabs _ _ = raise CTERM "cabs: first arg is not a free variable"; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
280 |
|
2509 | 281 |
|
282 |
||
574 | 283 |
(** read cterms **) (*exception ERROR*) |
250 | 284 |
|
4281
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
285 |
(*read terms, infer types, certify terms*) |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
286 |
fun read_def_cterms (sign, types, sorts) used freeze sTs = |
250 | 287 |
let |
4281
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
288 |
val syn = #syn (Sign.rep_sg sign) |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
289 |
fun read(s,T) = |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
290 |
let val T' = Sign.certify_typ sign T |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
291 |
handle TYPE (msg, _, _) => error msg |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
292 |
in (Syntax.read syn T' s, T') end |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
293 |
val tsTs = map read sTs |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
294 |
val (ts',tye) = Sign.infer_types_simult sign types sorts used freeze tsTs; |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
295 |
val cts = map (cterm_of sign) ts' |
2979 | 296 |
handle TYPE (msg, _, _) => error msg |
2386 | 297 |
| TERM (msg, _) => error msg; |
4281
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
298 |
in (cts, tye) end; |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
299 |
|
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
300 |
(*read term, infer types, certify term*) |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
301 |
fun read_def_cterm args used freeze aT = |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
302 |
let val ([ct],tye) = read_def_cterms args used freeze [aT] |
6c6073b13600
Added read_def_cterms for simultaneous reading/typing of terms under
nipkow
parents:
4270
diff
changeset
|
303 |
in (ct,tye) end; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
304 |
|
949
83c588d6fee9
Changed treatment of during type inference internally generated type
nipkow
parents:
922
diff
changeset
|
305 |
fun read_cterm sign = #1 o read_def_cterm (sign, K None, K None) [] true; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
306 |
|
250 | 307 |
|
308 |
||
1529 | 309 |
(*** Derivations ***) |
310 |
||
6089 | 311 |
(*tags provide additional comment, apart from the axiom/theorem name*) |
312 |
type tag = string * string list; |
|
313 |
||
1529 | 314 |
(*Names of rules in derivations. Includes logically trivial rules, if |
315 |
executed in ML.*) |
|
316 |
datatype rule = |
|
2386 | 317 |
MinProof (*for building minimal proof terms*) |
4999 | 318 |
| Oracle of string * Sign.sg * Object.T (*oracles*) |
1529 | 319 |
(*Axioms/theorems*) |
6089 | 320 |
| Axiom of string * tag list |
321 |
| Theorem of string * tag list |
|
1529 | 322 |
(*primitive inferences and compound versions of them*) |
2386 | 323 |
| Assume of cterm |
324 |
| Implies_intr of cterm |
|
1529 | 325 |
| Implies_intr_shyps |
326 |
| Implies_intr_hyps |
|
327 |
| Implies_elim |
|
2386 | 328 |
| Forall_intr of cterm |
329 |
| Forall_elim of cterm |
|
330 |
| Reflexive of cterm |
|
1529 | 331 |
| Symmetric |
332 |
| Transitive |
|
2386 | 333 |
| Beta_conversion of cterm |
1529 | 334 |
| Extensional |
2386 | 335 |
| Abstract_rule of string * cterm |
1529 | 336 |
| Combination |
337 |
| Equal_intr |
|
338 |
| Equal_elim |
|
339 |
(*derived rules for tactical proof*) |
|
2386 | 340 |
| Trivial of cterm |
341 |
(*For lift_rule, the proof state is not a premise. |
|
342 |
Use cterm instead of thm to avoid mutual recursion.*) |
|
343 |
| Lift_rule of cterm * int |
|
344 |
| Assumption of int * Envir.env option (*includes eq_assumption*) |
|
2671 | 345 |
| Rotate_rule of int * int |
2386 | 346 |
| Instantiate of (indexname * ctyp) list * (cterm * cterm) list |
347 |
| Bicompose of bool * bool * int * int * Envir.env |
|
348 |
| Flexflex_rule of Envir.env (*identifies unifier chosen*) |
|
1529 | 349 |
(*other derived rules*) |
4182 | 350 |
| Class_triv of class |
6786 | 351 |
| VarifyT of string list |
1529 | 352 |
| FreezeT |
353 |
(*for the simplifier*) |
|
2386 | 354 |
| RewriteC of cterm |
355 |
| CongC of cterm |
|
356 |
| Rewrite_cterm of cterm |
|
1529 | 357 |
(*Logical identities, recorded since they are part of the proof process*) |
2386 | 358 |
| Rename_params_rule of string list * int; |
1529 | 359 |
|
360 |
||
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
361 |
type deriv = rule mtree; |
1529 | 362 |
|
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
363 |
datatype deriv_kind = MinDeriv | ThmDeriv | FullDeriv; |
1529 | 364 |
|
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
365 |
val keep_derivs = ref MinDeriv; |
1529 | 366 |
|
367 |
||
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
368 |
(*Build a minimal derivation. Keep oracles; suppress atomic inferences; |
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
369 |
retain Theorems or their underlying links; keep anything else*) |
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
370 |
fun squash_derivs [] = [] |
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
371 |
| squash_derivs (der::ders) = |
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
372 |
(case der of |
2386 | 373 |
Join (Oracle _, _) => der :: squash_derivs ders |
374 |
| Join (Theorem _, [der']) => if !keep_derivs=ThmDeriv |
|
375 |
then der :: squash_derivs ders |
|
376 |
else squash_derivs (der'::ders) |
|
377 |
| Join (Axiom _, _) => if !keep_derivs=ThmDeriv |
|
378 |
then der :: squash_derivs ders |
|
379 |
else squash_derivs ders |
|
380 |
| Join (_, []) => squash_derivs ders |
|
381 |
| _ => der :: squash_derivs ders); |
|
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
382 |
|
1529 | 383 |
|
384 |
(*Ensure sharing of the most likely derivation, the empty one!*) |
|
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
385 |
val min_infer = Join (MinProof, []); |
1529 | 386 |
|
387 |
(*Make a minimal inference*) |
|
388 |
fun make_min_infer [] = min_infer |
|
389 |
| make_min_infer [der] = der |
|
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
390 |
| make_min_infer ders = Join (MinProof, ders); |
1529 | 391 |
|
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
392 |
fun infer_derivs (rl, []) = Join (rl, []) |
1529 | 393 |
| infer_derivs (rl, ders) = |
1597
54ece585bf62
name_thm no longer takes a theory argument, as the
paulson
parents:
1580
diff
changeset
|
394 |
if !keep_derivs=FullDeriv then Join (rl, ders) |
1529 | 395 |
else make_min_infer (squash_derivs ders); |
396 |
||
397 |
||
2509 | 398 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
399 |
(*** Meta theorems ***) |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
400 |
|
0 | 401 |
datatype thm = Thm of |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
402 |
{sign_ref: Sign.sg_ref, (*mutable reference to signature*) |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
403 |
der: deriv, (*derivation*) |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
404 |
maxidx: int, (*maximum index of any Var or TVar*) |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
405 |
shyps: sort list, (*sort hypotheses*) |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
406 |
hyps: term list, (*hypotheses*) |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
407 |
prop: term}; (*conclusion*) |
0 | 408 |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
409 |
fun rep_thm (Thm {sign_ref, der, maxidx, shyps, hyps, prop}) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
410 |
{sign = Sign.deref sign_ref, der = der, maxidx = maxidx, |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
411 |
shyps = shyps, hyps = hyps, prop = prop}; |
0 | 412 |
|
1529 | 413 |
(*Version of rep_thm returning cterms instead of terms*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
414 |
fun crep_thm (Thm {sign_ref, der, maxidx, shyps, hyps, prop}) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
415 |
let fun ctermf max t = Cterm{sign_ref=sign_ref, t=t, T=propT, maxidx=max}; |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
416 |
in {sign = Sign.deref sign_ref, der = der, maxidx = maxidx, shyps = shyps, |
1529 | 417 |
hyps = map (ctermf ~1) hyps, |
418 |
prop = ctermf maxidx prop} |
|
1517 | 419 |
end; |
420 |
||
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
421 |
(*errors involving theorems*) |
0 | 422 |
exception THM of string * int * thm list; |
423 |
||
6089 | 424 |
(*attributes subsume any kind of rules or addXXXs modifiers*) |
425 |
type 'a attribute = 'a * thm -> 'a * thm; |
|
426 |
||
427 |
fun no_attributes x = (x, []); |
|
428 |
fun apply_attributes (x_th, atts) = Library.apply atts x_th; |
|
429 |
fun applys_attributes (x_ths, atts) = foldl_map (Library.apply atts) x_ths; |
|
430 |
||
3994 | 431 |
(*equality of theorems uses equality of signatures and the |
432 |
a-convertible test for terms*) |
|
433 |
fun eq_thm (th1, th2) = |
|
434 |
let |
|
435 |
val {sign = sg1, shyps = shyps1, hyps = hyps1, prop = prop1, ...} = rep_thm th1; |
|
436 |
val {sign = sg2, shyps = shyps2, hyps = hyps2, prop = prop2, ...} = rep_thm th2; |
|
437 |
in |
|
438 |
Sign.eq_sg (sg1, sg2) andalso |
|
439 |
eq_set_sort (shyps1, shyps2) andalso |
|
440 |
aconvs (hyps1, hyps2) andalso |
|
441 |
prop1 aconv prop2 |
|
442 |
end; |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
443 |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
444 |
fun sign_of_thm (Thm {sign_ref, ...}) = Sign.deref sign_ref; |
0 | 445 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
446 |
(*merge signatures of two theorems; raise exception if incompatible*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
447 |
fun merge_thm_sgs |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
448 |
(th1 as Thm {sign_ref = sgr1, ...}, th2 as Thm {sign_ref = sgr2, ...}) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
449 |
Sign.merge_refs (sgr1, sgr2) handle TERM (msg, _) => raise THM (msg, 0, [th1, th2]); |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
450 |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
451 |
(*transfer thm to super theory (non-destructive)*) |
4254 | 452 |
fun transfer_sg sign' thm = |
3895 | 453 |
let |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
454 |
val Thm {sign_ref, der, maxidx, shyps, hyps, prop} = thm; |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
455 |
val sign = Sign.deref sign_ref; |
3895 | 456 |
in |
4254 | 457 |
if Sign.eq_sg (sign, sign') then thm |
458 |
else if Sign.subsig (sign, sign') then |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
459 |
Thm {sign_ref = Sign.self_ref sign', der = der, maxidx = maxidx, |
3895 | 460 |
shyps = shyps, hyps = hyps, prop = prop} |
461 |
else raise THM ("transfer: not a super theory", 0, [thm]) |
|
462 |
end; |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
463 |
|
6390 | 464 |
val transfer = transfer_sg o Theory.sign_of; |
4254 | 465 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
466 |
(*maps object-rule to tpairs*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
467 |
fun tpairs_of (Thm {prop, ...}) = #1 (Logic.strip_flexpairs prop); |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
468 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
469 |
(*maps object-rule to premises*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
470 |
fun prems_of (Thm {prop, ...}) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
471 |
Logic.strip_imp_prems (Logic.skip_flexpairs prop); |
0 | 472 |
|
473 |
(*counts premises in a rule*) |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
474 |
fun nprems_of (Thm {prop, ...}) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
475 |
Logic.count_prems (Logic.skip_flexpairs prop, 0); |
0 | 476 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
477 |
(*maps object-rule to conclusion*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
478 |
fun concl_of (Thm {prop, ...}) = Logic.strip_imp_concl prop; |
0 | 479 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
480 |
(*the statement of any thm is a cterm*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
481 |
fun cprop_of (Thm {sign_ref, maxidx, prop, ...}) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
482 |
Cterm {sign_ref = sign_ref, maxidx = maxidx, T = propT, t = prop}; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
483 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
484 |
|
0 | 485 |
|
1238 | 486 |
(** sort contexts of theorems **) |
487 |
||
488 |
(* basic utils *) |
|
489 |
||
2163 | 490 |
(*accumulate sorts suppressing duplicates; these are coded low levelly |
1238 | 491 |
to improve efficiency a bit*) |
492 |
||
493 |
fun add_typ_sorts (Type (_, Ts), Ss) = add_typs_sorts (Ts, Ss) |
|
2177
8b365a3a6ed1
Changed some mem, ins and union calls to be monomorphic
paulson
parents:
2163
diff
changeset
|
494 |
| add_typ_sorts (TFree (_, S), Ss) = ins_sort(S,Ss) |
8b365a3a6ed1
Changed some mem, ins and union calls to be monomorphic
paulson
parents:
2163
diff
changeset
|
495 |
| add_typ_sorts (TVar (_, S), Ss) = ins_sort(S,Ss) |
1238 | 496 |
and add_typs_sorts ([], Ss) = Ss |
497 |
| add_typs_sorts (T :: Ts, Ss) = add_typs_sorts (Ts, add_typ_sorts (T, Ss)); |
|
498 |
||
499 |
fun add_term_sorts (Const (_, T), Ss) = add_typ_sorts (T, Ss) |
|
500 |
| add_term_sorts (Free (_, T), Ss) = add_typ_sorts (T, Ss) |
|
501 |
| add_term_sorts (Var (_, T), Ss) = add_typ_sorts (T, Ss) |
|
502 |
| add_term_sorts (Bound _, Ss) = Ss |
|
2177
8b365a3a6ed1
Changed some mem, ins and union calls to be monomorphic
paulson
parents:
2163
diff
changeset
|
503 |
| add_term_sorts (Abs (_,T,t), Ss) = add_term_sorts (t, add_typ_sorts (T,Ss)) |
1238 | 504 |
| add_term_sorts (t $ u, Ss) = add_term_sorts (t, add_term_sorts (u, Ss)); |
505 |
||
506 |
fun add_terms_sorts ([], Ss) = Ss |
|
2177
8b365a3a6ed1
Changed some mem, ins and union calls to be monomorphic
paulson
parents:
2163
diff
changeset
|
507 |
| add_terms_sorts (t::ts, Ss) = add_terms_sorts (ts, add_term_sorts (t,Ss)); |
1238 | 508 |
|
1258 | 509 |
fun env_codT (Envir.Envir {iTs, ...}) = map snd iTs; |
510 |
||
511 |
fun add_env_sorts (env, Ss) = |
|
512 |
add_terms_sorts (map snd (Envir.alist_of env), |
|
513 |
add_typs_sorts (env_codT env, Ss)); |
|
514 |
||
1238 | 515 |
fun add_thm_sorts (Thm {hyps, prop, ...}, Ss) = |
516 |
add_terms_sorts (hyps, add_term_sorts (prop, Ss)); |
|
517 |
||
518 |
fun add_thms_shyps ([], Ss) = Ss |
|
519 |
| add_thms_shyps (Thm {shyps, ...} :: ths, Ss) = |
|
2177
8b365a3a6ed1
Changed some mem, ins and union calls to be monomorphic
paulson
parents:
2163
diff
changeset
|
520 |
add_thms_shyps (ths, union_sort(shyps,Ss)); |
1238 | 521 |
|
522 |
||
523 |
(*get 'dangling' sort constraints of a thm*) |
|
524 |
fun extra_shyps (th as Thm {shyps, ...}) = |
|
525 |
shyps \\ add_thm_sorts (th, []); |
|
526 |
||
527 |
||
528 |
(* fix_shyps *) |
|
529 |
||
530 |
(*preserve sort contexts of rule premises and substituted types*) |
|
531 |
fun fix_shyps thms Ts thm = |
|
532 |
let |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
533 |
val Thm {sign_ref, der, maxidx, hyps, prop, ...} = thm; |
1238 | 534 |
val shyps = |
535 |
add_thm_sorts (thm, add_typs_sorts (Ts, add_thms_shyps (thms, []))); |
|
536 |
in |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
537 |
Thm {sign_ref = sign_ref, |
2386 | 538 |
der = der, (*No new derivation, as other rules call this*) |
539 |
maxidx = maxidx, |
|
540 |
shyps = shyps, hyps = hyps, prop = prop} |
|
1238 | 541 |
end; |
542 |
||
543 |
||
544 |
(* strip_shyps *) (* FIXME improve? (e.g. only minimal extra sorts) *) |
|
545 |
||
3061 | 546 |
val force_strip_shyps = ref true; (* FIXME tmp (since 1995/08/01) *) |
1238 | 547 |
|
548 |
(*remove extra sorts that are known to be syntactically non-empty*) |
|
549 |
fun strip_shyps thm = |
|
550 |
let |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
551 |
val Thm {sign_ref, der, maxidx, shyps, hyps, prop} = thm; |
1238 | 552 |
val sorts = add_thm_sorts (thm, []); |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
553 |
val maybe_empty = not o Sign.nonempty_sort (Sign.deref sign_ref) sorts; |
2177
8b365a3a6ed1
Changed some mem, ins and union calls to be monomorphic
paulson
parents:
2163
diff
changeset
|
554 |
val shyps' = filter (fn S => mem_sort(S,sorts) orelse maybe_empty S) shyps; |
1238 | 555 |
in |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
556 |
Thm {sign_ref = sign_ref, der = der, maxidx = maxidx, |
2386 | 557 |
shyps = |
558 |
(if eq_set_sort (shyps',sorts) orelse |
|
559 |
not (!force_strip_shyps) then shyps' |
|
3061 | 560 |
else (* FIXME tmp (since 1995/08/01) *) |
2386 | 561 |
(warning ("Removed sort hypotheses: " ^ |
2962 | 562 |
commas (map Sorts.str_of_sort (shyps' \\ sorts))); |
2386 | 563 |
warning "Let's hope these sorts are non-empty!"; |
1238 | 564 |
sorts)), |
1529 | 565 |
hyps = hyps, |
566 |
prop = prop} |
|
1238 | 567 |
end; |
568 |
||
569 |
||
570 |
(* implies_intr_shyps *) |
|
571 |
||
572 |
(*discharge all extra sort hypotheses*) |
|
573 |
fun implies_intr_shyps thm = |
|
574 |
(case extra_shyps thm of |
|
575 |
[] => thm |
|
576 |
| xshyps => |
|
577 |
let |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
578 |
val Thm {sign_ref, der, maxidx, shyps, hyps, prop} = thm; |
2182
29e56f003599
Removal of polymorphic equality via mem, subset, eq_set, etc
paulson
parents:
2177
diff
changeset
|
579 |
val shyps' = ins_sort (logicS, shyps \\ xshyps); |
1238 | 580 |
val used_names = foldr add_term_tfree_names (prop :: hyps, []); |
581 |
val names = |
|
582 |
tl (variantlist (replicate (length xshyps + 1) "'", used_names)); |
|
583 |
val tfrees = map (TFree o rpair logicS) names; |
|
584 |
||
585 |
fun mk_insort (T, S) = map (Logic.mk_inclass o pair T) S; |
|
2671 | 586 |
val sort_hyps = List.concat (map2 mk_insort (tfrees, xshyps)); |
1238 | 587 |
in |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
588 |
Thm {sign_ref = sign_ref, |
2386 | 589 |
der = infer_derivs (Implies_intr_shyps, [der]), |
590 |
maxidx = maxidx, |
|
591 |
shyps = shyps', |
|
592 |
hyps = hyps, |
|
593 |
prop = Logic.list_implies (sort_hyps, prop)} |
|
1238 | 594 |
end); |
595 |
||
596 |
||
1529 | 597 |
(** Axioms **) |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
598 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
599 |
(*look up the named axiom in the theory*) |
3812 | 600 |
fun get_axiom theory raw_name = |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
601 |
let |
4847 | 602 |
val name = Sign.intern (Theory.sign_of theory) Theory.axiomK raw_name; |
603 |
||
604 |
fun get_ax [] = None |
|
1529 | 605 |
| get_ax (thy :: thys) = |
4847 | 606 |
let val {sign, axioms, ...} = Theory.rep_theory thy in |
607 |
(case Symtab.lookup (axioms, name) of |
|
608 |
Some t => |
|
609 |
Some (fix_shyps [] [] |
|
610 |
(Thm {sign_ref = Sign.self_ref sign, |
|
6089 | 611 |
der = infer_derivs (Axiom (name, []), []), |
4847 | 612 |
maxidx = maxidx_of_term t, |
613 |
shyps = [], |
|
614 |
hyps = [], |
|
615 |
prop = t})) |
|
616 |
| None => get_ax thys) |
|
1529 | 617 |
end; |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
618 |
in |
4847 | 619 |
(case get_ax (theory :: Theory.ancestors_of theory) of |
620 |
Some thm => thm |
|
621 |
| None => raise THEORY ("No axiom " ^ quote name, [theory])) |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
622 |
end; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
623 |
|
6368 | 624 |
fun def_name name = name ^ "_def"; |
625 |
fun get_def thy = get_axiom thy o def_name; |
|
4847 | 626 |
|
1529 | 627 |
|
776
df8f91c0e57c
improved axioms_of: returns thms as the manual says;
wenzelm
parents:
721
diff
changeset
|
628 |
(*return additional axioms of this theory node*) |
df8f91c0e57c
improved axioms_of: returns thms as the manual says;
wenzelm
parents:
721
diff
changeset
|
629 |
fun axioms_of thy = |
df8f91c0e57c
improved axioms_of: returns thms as the manual says;
wenzelm
parents:
721
diff
changeset
|
630 |
map (fn (s, _) => (s, get_axiom thy s)) |
6390 | 631 |
(Symtab.dest (#axioms (Theory.rep_theory thy))); |
776
df8f91c0e57c
improved axioms_of: returns thms as the manual says;
wenzelm
parents:
721
diff
changeset
|
632 |
|
6089 | 633 |
|
634 |
(* name and tags -- make proof objects more readable *) |
|
635 |
||
636 |
fun get_name_tags (Thm {der, ...}) = |
|
4018 | 637 |
(case der of |
6089 | 638 |
Join (Theorem x, _) => x |
639 |
| Join (Axiom x, _) => x |
|
640 |
| _ => ("", [])); |
|
4018 | 641 |
|
6089 | 642 |
fun put_name_tags x (Thm {sign_ref, der, maxidx, shyps, hyps, prop}) = |
643 |
let |
|
644 |
val der' = |
|
645 |
(case der of |
|
646 |
Join (Theorem _, ds) => Join (Theorem x, ds) |
|
647 |
| Join (Axiom _, ds) => Join (Axiom x, ds) |
|
648 |
| _ => Join (Theorem x, [der])); |
|
649 |
in |
|
650 |
Thm {sign_ref = sign_ref, der = der', maxidx = maxidx, |
|
651 |
shyps = shyps, hyps = hyps, prop = prop} |
|
652 |
end; |
|
653 |
||
654 |
val name_of_thm = #1 o get_name_tags; |
|
655 |
val tags_of_thm = #2 o get_name_tags; |
|
656 |
||
657 |
fun name_thm (name, thm) = put_name_tags (name, tags_of_thm thm) thm; |
|
0 | 658 |
|
659 |
||
1529 | 660 |
(*Compression of theorems -- a separate rule, not integrated with the others, |
661 |
as it could be slow.*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
662 |
fun compress (Thm {sign_ref, der, maxidx, shyps, hyps, prop}) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
663 |
Thm {sign_ref = sign_ref, |
2386 | 664 |
der = der, (*No derivation recorded!*) |
665 |
maxidx = maxidx, |
|
666 |
shyps = shyps, |
|
667 |
hyps = map Term.compress_term hyps, |
|
668 |
prop = Term.compress_term prop}; |
|
564 | 669 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
670 |
|
2509 | 671 |
|
1529 | 672 |
(*** Meta rules ***) |
0 | 673 |
|
2147 | 674 |
(*Check that term does not contain same var with different typing/sorting. |
675 |
If this check must be made, recalculate maxidx in hope of preventing its |
|
676 |
recurrence.*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
677 |
fun nodup_Vars (thm as Thm{sign_ref, der, maxidx, shyps, hyps, prop}) s = |
2147 | 678 |
(Sign.nodup_Vars prop; |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
679 |
Thm {sign_ref = sign_ref, |
2386 | 680 |
der = der, |
681 |
maxidx = maxidx_of_term prop, |
|
682 |
shyps = shyps, |
|
683 |
hyps = hyps, |
|
684 |
prop = prop}) |
|
2147 | 685 |
handle TYPE(msg,Ts,ts) => raise TYPE(s^": "^msg,Ts,ts); |
1495
b8b54847c77f
Added check for duplicate vars with distinct types/sorts (nodup_Vars)
nipkow
parents:
1493
diff
changeset
|
686 |
|
1220 | 687 |
(** 'primitive' rules **) |
688 |
||
689 |
(*discharge all assumptions t from ts*) |
|
0 | 690 |
val disch = gen_rem (op aconv); |
691 |
||
1220 | 692 |
(*The assumption rule A|-A in a theory*) |
5344 | 693 |
fun assume raw_ct : thm = |
694 |
let val ct as Cterm {sign_ref, t=prop, T, maxidx} = adjust_maxidx raw_ct |
|
250 | 695 |
in if T<>propT then |
696 |
raise THM("assume: assumptions must have type prop", 0, []) |
|
0 | 697 |
else if maxidx <> ~1 then |
250 | 698 |
raise THM("assume: assumptions may not contain scheme variables", |
699 |
maxidx, []) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
700 |
else Thm{sign_ref = sign_ref, |
5344 | 701 |
der = infer_derivs (Assume ct, []), |
2386 | 702 |
maxidx = ~1, |
703 |
shyps = add_term_sorts(prop,[]), |
|
704 |
hyps = [prop], |
|
705 |
prop = prop} |
|
0 | 706 |
end; |
707 |
||
1220 | 708 |
(*Implication introduction |
3529 | 709 |
[A] |
710 |
: |
|
711 |
B |
|
1220 | 712 |
------- |
713 |
A ==> B |
|
714 |
*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
715 |
fun implies_intr cA (thB as Thm{sign_ref,der,maxidx,hyps,prop,...}) : thm = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
716 |
let val Cterm {sign_ref=sign_refA, t=A, T, maxidx=maxidxA} = cA |
0 | 717 |
in if T<>propT then |
250 | 718 |
raise THM("implies_intr: assumptions must have type prop", 0, [thB]) |
1238 | 719 |
else fix_shyps [thB] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
720 |
(Thm{sign_ref = Sign.merge_refs (sign_ref,sign_refA), |
2386 | 721 |
der = infer_derivs (Implies_intr cA, [der]), |
722 |
maxidx = Int.max(maxidxA, maxidx), |
|
723 |
shyps = [], |
|
724 |
hyps = disch(hyps,A), |
|
725 |
prop = implies$A$prop}) |
|
0 | 726 |
handle TERM _ => |
727 |
raise THM("implies_intr: incompatible signatures", 0, [thB]) |
|
728 |
end; |
|
729 |
||
1529 | 730 |
|
1220 | 731 |
(*Implication elimination |
732 |
A ==> B A |
|
733 |
------------ |
|
734 |
B |
|
735 |
*) |
|
0 | 736 |
fun implies_elim thAB thA : thm = |
1529 | 737 |
let val Thm{maxidx=maxA, der=derA, hyps=hypsA, prop=propA,...} = thA |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
738 |
and Thm{sign_ref, der, maxidx, hyps, prop,...} = thAB; |
250 | 739 |
fun err(a) = raise THM("implies_elim: "^a, 0, [thAB,thA]) |
0 | 740 |
in case prop of |
250 | 741 |
imp$A$B => |
742 |
if imp=implies andalso A aconv propA |
|
1220 | 743 |
then fix_shyps [thAB, thA] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
744 |
(Thm{sign_ref= merge_thm_sgs(thAB,thA), |
2386 | 745 |
der = infer_derivs (Implies_elim, [der,derA]), |
746 |
maxidx = Int.max(maxA,maxidx), |
|
747 |
shyps = [], |
|
748 |
hyps = union_term(hypsA,hyps), (*dups suppressed*) |
|
749 |
prop = B}) |
|
250 | 750 |
else err("major premise") |
751 |
| _ => err("major premise") |
|
0 | 752 |
end; |
250 | 753 |
|
1220 | 754 |
(*Forall introduction. The Free or Var x must not be free in the hypotheses. |
755 |
A |
|
756 |
----- |
|
757 |
!!x.A |
|
758 |
*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
759 |
fun forall_intr cx (th as Thm{sign_ref,der,maxidx,hyps,prop,...}) = |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
760 |
let val x = term_of cx; |
1238 | 761 |
fun result(a,T) = fix_shyps [th] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
762 |
(Thm{sign_ref = sign_ref, |
2386 | 763 |
der = infer_derivs (Forall_intr cx, [der]), |
764 |
maxidx = maxidx, |
|
765 |
shyps = [], |
|
766 |
hyps = hyps, |
|
767 |
prop = all(T) $ Abs(a, T, abstract_over (x,prop))}) |
|
0 | 768 |
in case x of |
250 | 769 |
Free(a,T) => |
770 |
if exists (apl(x, Logic.occs)) hyps |
|
771 |
then raise THM("forall_intr: variable free in assumptions", 0, [th]) |
|
772 |
else result(a,T) |
|
0 | 773 |
| Var((a,_),T) => result(a,T) |
774 |
| _ => raise THM("forall_intr: not a variable", 0, [th]) |
|
775 |
end; |
|
776 |
||
1220 | 777 |
(*Forall elimination |
778 |
!!x.A |
|
779 |
------ |
|
780 |
A[t/x] |
|
781 |
*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
782 |
fun forall_elim ct (th as Thm{sign_ref,der,maxidx,hyps,prop,...}) : thm = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
783 |
let val Cterm {sign_ref=sign_reft, t, T, maxidx=maxt} = ct |
0 | 784 |
in case prop of |
2386 | 785 |
Const("all",Type("fun",[Type("fun",[qary,_]),_])) $ A => |
786 |
if T<>qary then |
|
787 |
raise THM("forall_elim: type mismatch", 0, [th]) |
|
788 |
else let val thm = fix_shyps [th] [] |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
789 |
(Thm{sign_ref= Sign.merge_refs(sign_ref,sign_reft), |
2386 | 790 |
der = infer_derivs (Forall_elim ct, [der]), |
791 |
maxidx = Int.max(maxidx, maxt), |
|
792 |
shyps = [], |
|
793 |
hyps = hyps, |
|
794 |
prop = betapply(A,t)}) |
|
795 |
in if maxt >= 0 andalso maxidx >= 0 |
|
796 |
then nodup_Vars thm "forall_elim" |
|
797 |
else thm (*no new Vars: no expensive check!*) |
|
798 |
end |
|
2147 | 799 |
| _ => raise THM("forall_elim: not quantified", 0, [th]) |
0 | 800 |
end |
801 |
handle TERM _ => |
|
250 | 802 |
raise THM("forall_elim: incompatible signatures", 0, [th]); |
0 | 803 |
|
804 |
||
1220 | 805 |
(* Equality *) |
0 | 806 |
|
807 |
(*The reflexivity rule: maps t to the theorem t==t *) |
|
250 | 808 |
fun reflexive ct = |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
809 |
let val Cterm {sign_ref, t, T, maxidx} = ct |
1238 | 810 |
in fix_shyps [] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
811 |
(Thm{sign_ref= sign_ref, |
2386 | 812 |
der = infer_derivs (Reflexive ct, []), |
813 |
shyps = [], |
|
814 |
hyps = [], |
|
815 |
maxidx = maxidx, |
|
816 |
prop = Logic.mk_equals(t,t)}) |
|
0 | 817 |
end; |
818 |
||
819 |
(*The symmetry rule |
|
1220 | 820 |
t==u |
821 |
---- |
|
822 |
u==t |
|
823 |
*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
824 |
fun symmetric (th as Thm{sign_ref,der,maxidx,shyps,hyps,prop}) = |
0 | 825 |
case prop of |
826 |
(eq as Const("==",_)) $ t $ u => |
|
1238 | 827 |
(*no fix_shyps*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
828 |
Thm{sign_ref = sign_ref, |
2386 | 829 |
der = infer_derivs (Symmetric, [der]), |
830 |
maxidx = maxidx, |
|
831 |
shyps = shyps, |
|
832 |
hyps = hyps, |
|
833 |
prop = eq$u$t} |
|
0 | 834 |
| _ => raise THM("symmetric", 0, [th]); |
835 |
||
836 |
(*The transitive rule |
|
1220 | 837 |
t1==u u==t2 |
838 |
-------------- |
|
839 |
t1==t2 |
|
840 |
*) |
|
0 | 841 |
fun transitive th1 th2 = |
1529 | 842 |
let val Thm{der=der1, maxidx=max1, hyps=hyps1, prop=prop1,...} = th1 |
843 |
and Thm{der=der2, maxidx=max2, hyps=hyps2, prop=prop2,...} = th2; |
|
0 | 844 |
fun err(msg) = raise THM("transitive: "^msg, 0, [th1,th2]) |
845 |
in case (prop1,prop2) of |
|
846 |
((eq as Const("==",_)) $ t1 $ u, Const("==",_) $ u' $ t2) => |
|
1634 | 847 |
if not (u aconv u') then err"middle term" |
848 |
else let val thm = |
|
1220 | 849 |
fix_shyps [th1, th2] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
850 |
(Thm{sign_ref= merge_thm_sgs(th1,th2), |
2386 | 851 |
der = infer_derivs (Transitive, [der1, der2]), |
2147 | 852 |
maxidx = Int.max(max1,max2), |
2386 | 853 |
shyps = [], |
854 |
hyps = union_term(hyps1,hyps2), |
|
855 |
prop = eq$t1$t2}) |
|
2139
2c59b204b540
Only calls nodup_Vars if really necessary. We get a speedup of nearly 6%
paulson
parents:
2047
diff
changeset
|
856 |
in if max1 >= 0 andalso max2 >= 0 |
2147 | 857 |
then nodup_Vars thm "transitive" |
858 |
else thm (*no new Vars: no expensive check!*) |
|
2139
2c59b204b540
Only calls nodup_Vars if really necessary. We get a speedup of nearly 6%
paulson
parents:
2047
diff
changeset
|
859 |
end |
0 | 860 |
| _ => err"premises" |
861 |
end; |
|
862 |
||
1160 | 863 |
(*Beta-conversion: maps (%x.t)(u) to the theorem (%x.t)(u) == t[u/x] *) |
250 | 864 |
fun beta_conversion ct = |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
865 |
let val Cterm {sign_ref, t, T, maxidx} = ct |
0 | 866 |
in case t of |
1238 | 867 |
Abs(_,_,bodt) $ u => fix_shyps [] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
868 |
(Thm{sign_ref = sign_ref, |
2386 | 869 |
der = infer_derivs (Beta_conversion ct, []), |
870 |
maxidx = maxidx, |
|
871 |
shyps = [], |
|
872 |
hyps = [], |
|
873 |
prop = Logic.mk_equals(t, subst_bound (u,bodt))}) |
|
250 | 874 |
| _ => raise THM("beta_conversion: not a redex", 0, []) |
0 | 875 |
end; |
876 |
||
877 |
(*The extensionality rule (proviso: x not free in f, g, or hypotheses) |
|
1220 | 878 |
f(x) == g(x) |
879 |
------------ |
|
880 |
f == g |
|
881 |
*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
882 |
fun extensional (th as Thm{sign_ref, der, maxidx,shyps,hyps,prop}) = |
0 | 883 |
case prop of |
884 |
(Const("==",_)) $ (f$x) $ (g$y) => |
|
250 | 885 |
let fun err(msg) = raise THM("extensional: "^msg, 0, [th]) |
0 | 886 |
in (if x<>y then err"different variables" else |
887 |
case y of |
|
250 | 888 |
Free _ => |
889 |
if exists (apl(y, Logic.occs)) (f::g::hyps) |
|
890 |
then err"variable free in hyps or functions" else () |
|
891 |
| Var _ => |
|
892 |
if Logic.occs(y,f) orelse Logic.occs(y,g) |
|
893 |
then err"variable free in functions" else () |
|
894 |
| _ => err"not a variable"); |
|
1238 | 895 |
(*no fix_shyps*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
896 |
Thm{sign_ref = sign_ref, |
2386 | 897 |
der = infer_derivs (Extensional, [der]), |
898 |
maxidx = maxidx, |
|
899 |
shyps = shyps, |
|
900 |
hyps = hyps, |
|
1529 | 901 |
prop = Logic.mk_equals(f,g)} |
0 | 902 |
end |
903 |
| _ => raise THM("extensional: premise", 0, [th]); |
|
904 |
||
905 |
(*The abstraction rule. The Free or Var x must not be free in the hypotheses. |
|
906 |
The bound variable will be named "a" (since x will be something like x320) |
|
1220 | 907 |
t == u |
908 |
------------ |
|
909 |
%x.t == %x.u |
|
910 |
*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
911 |
fun abstract_rule a cx (th as Thm{sign_ref,der,maxidx,hyps,prop,...}) = |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
912 |
let val x = term_of cx; |
250 | 913 |
val (t,u) = Logic.dest_equals prop |
914 |
handle TERM _ => |
|
915 |
raise THM("abstract_rule: premise not an equality", 0, [th]) |
|
1238 | 916 |
fun result T = fix_shyps [th] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
917 |
(Thm{sign_ref = sign_ref, |
2386 | 918 |
der = infer_derivs (Abstract_rule (a,cx), [der]), |
919 |
maxidx = maxidx, |
|
920 |
shyps = [], |
|
921 |
hyps = hyps, |
|
922 |
prop = Logic.mk_equals(Abs(a, T, abstract_over (x,t)), |
|
923 |
Abs(a, T, abstract_over (x,u)))}) |
|
0 | 924 |
in case x of |
250 | 925 |
Free(_,T) => |
926 |
if exists (apl(x, Logic.occs)) hyps |
|
927 |
then raise THM("abstract_rule: variable free in assumptions", 0, [th]) |
|
928 |
else result T |
|
0 | 929 |
| Var(_,T) => result T |
930 |
| _ => raise THM("abstract_rule: not a variable", 0, [th]) |
|
931 |
end; |
|
932 |
||
933 |
(*The combination rule |
|
3529 | 934 |
f == g t == u |
935 |
-------------- |
|
936 |
f(t) == g(u) |
|
1220 | 937 |
*) |
0 | 938 |
fun combination th1 th2 = |
1529 | 939 |
let val Thm{der=der1, maxidx=max1, shyps=shyps1, hyps=hyps1, |
2386 | 940 |
prop=prop1,...} = th1 |
1529 | 941 |
and Thm{der=der2, maxidx=max2, shyps=shyps2, hyps=hyps2, |
2386 | 942 |
prop=prop2,...} = th2 |
1836
861e29c7cada
Added type-checking to rule "combination". This corrects a fault
paulson
parents:
1802
diff
changeset
|
943 |
fun chktypes (f,t) = |
2386 | 944 |
(case fastype_of f of |
945 |
Type("fun",[T1,T2]) => |
|
946 |
if T1 <> fastype_of t then |
|
947 |
raise THM("combination: types", 0, [th1,th2]) |
|
948 |
else () |
|
949 |
| _ => raise THM("combination: not function type", 0, |
|
950 |
[th1,th2])) |
|
1495
b8b54847c77f
Added check for duplicate vars with distinct types/sorts (nodup_Vars)
nipkow
parents:
1493
diff
changeset
|
951 |
in case (prop1,prop2) of |
0 | 952 |
(Const("==",_) $ f $ g, Const("==",_) $ t $ u) => |
1836
861e29c7cada
Added type-checking to rule "combination". This corrects a fault
paulson
parents:
1802
diff
changeset
|
953 |
let val _ = chktypes (f,t) |
2386 | 954 |
val thm = (*no fix_shyps*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
955 |
Thm{sign_ref = merge_thm_sgs(th1,th2), |
2386 | 956 |
der = infer_derivs (Combination, [der1, der2]), |
957 |
maxidx = Int.max(max1,max2), |
|
958 |
shyps = union_sort(shyps1,shyps2), |
|
959 |
hyps = union_term(hyps1,hyps2), |
|
960 |
prop = Logic.mk_equals(f$t, g$u)} |
|
2139
2c59b204b540
Only calls nodup_Vars if really necessary. We get a speedup of nearly 6%
paulson
parents:
2047
diff
changeset
|
961 |
in if max1 >= 0 andalso max2 >= 0 |
2c59b204b540
Only calls nodup_Vars if really necessary. We get a speedup of nearly 6%
paulson
parents:
2047
diff
changeset
|
962 |
then nodup_Vars thm "combination" |
2386 | 963 |
else thm (*no new Vars: no expensive check!*) |
2139
2c59b204b540
Only calls nodup_Vars if really necessary. We get a speedup of nearly 6%
paulson
parents:
2047
diff
changeset
|
964 |
end |
0 | 965 |
| _ => raise THM("combination: premises", 0, [th1,th2]) |
966 |
end; |
|
967 |
||
968 |
||
969 |
(* Equality introduction |
|
3529 | 970 |
A ==> B B ==> A |
971 |
---------------- |
|
972 |
A == B |
|
1220 | 973 |
*) |
0 | 974 |
fun equal_intr th1 th2 = |
1529 | 975 |
let val Thm{der=der1,maxidx=max1, shyps=shyps1, hyps=hyps1, |
2386 | 976 |
prop=prop1,...} = th1 |
1529 | 977 |
and Thm{der=der2, maxidx=max2, shyps=shyps2, hyps=hyps2, |
2386 | 978 |
prop=prop2,...} = th2; |
1529 | 979 |
fun err(msg) = raise THM("equal_intr: "^msg, 0, [th1,th2]) |
980 |
in case (prop1,prop2) of |
|
981 |
(Const("==>",_) $ A $ B, Const("==>",_) $ B' $ A') => |
|
2386 | 982 |
if A aconv A' andalso B aconv B' |
983 |
then |
|
984 |
(*no fix_shyps*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
985 |
Thm{sign_ref = merge_thm_sgs(th1,th2), |
2386 | 986 |
der = infer_derivs (Equal_intr, [der1, der2]), |
987 |
maxidx = Int.max(max1,max2), |
|
988 |
shyps = union_sort(shyps1,shyps2), |
|
989 |
hyps = union_term(hyps1,hyps2), |
|
990 |
prop = Logic.mk_equals(A,B)} |
|
991 |
else err"not equal" |
|
1529 | 992 |
| _ => err"premises" |
993 |
end; |
|
994 |
||
995 |
||
996 |
(*The equal propositions rule |
|
3529 | 997 |
A == B A |
1529 | 998 |
--------- |
999 |
B |
|
1000 |
*) |
|
1001 |
fun equal_elim th1 th2 = |
|
1002 |
let val Thm{der=der1, maxidx=max1, hyps=hyps1, prop=prop1,...} = th1 |
|
1003 |
and Thm{der=der2, maxidx=max2, hyps=hyps2, prop=prop2,...} = th2; |
|
1004 |
fun err(msg) = raise THM("equal_elim: "^msg, 0, [th1,th2]) |
|
1005 |
in case prop1 of |
|
1006 |
Const("==",_) $ A $ B => |
|
1007 |
if not (prop2 aconv A) then err"not equal" else |
|
1008 |
fix_shyps [th1, th2] [] |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1009 |
(Thm{sign_ref= merge_thm_sgs(th1,th2), |
2386 | 1010 |
der = infer_derivs (Equal_elim, [der1, der2]), |
1011 |
maxidx = Int.max(max1,max2), |
|
1012 |
shyps = [], |
|
1013 |
hyps = union_term(hyps1,hyps2), |
|
1014 |
prop = B}) |
|
1529 | 1015 |
| _ => err"major premise" |
1016 |
end; |
|
0 | 1017 |
|
1220 | 1018 |
|
1019 |
||
0 | 1020 |
(**** Derived rules ****) |
1021 |
||
1503 | 1022 |
(*Discharge all hypotheses. Need not verify cterms or call fix_shyps. |
0 | 1023 |
Repeated hypotheses are discharged only once; fold cannot do this*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1024 |
fun implies_intr_hyps (Thm{sign_ref, der, maxidx, shyps, hyps=A::As, prop}) = |
1238 | 1025 |
implies_intr_hyps (*no fix_shyps*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1026 |
(Thm{sign_ref = sign_ref, |
2386 | 1027 |
der = infer_derivs (Implies_intr_hyps, [der]), |
1028 |
maxidx = maxidx, |
|
1029 |
shyps = shyps, |
|
1529 | 1030 |
hyps = disch(As,A), |
2386 | 1031 |
prop = implies$A$prop}) |
0 | 1032 |
| implies_intr_hyps th = th; |
1033 |
||
1034 |
(*Smash" unifies the list of term pairs leaving no flex-flex pairs. |
|
250 | 1035 |
Instantiates the theorem and deletes trivial tpairs. |
0 | 1036 |
Resulting sequence may contain multiple elements if the tpairs are |
1037 |
not all flex-flex. *) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1038 |
fun flexflex_rule (th as Thm{sign_ref, der, maxidx, hyps, prop,...}) = |
250 | 1039 |
let fun newthm env = |
1529 | 1040 |
if Envir.is_empty env then th |
1041 |
else |
|
250 | 1042 |
let val (tpairs,horn) = |
1043 |
Logic.strip_flexpairs (Envir.norm_term env prop) |
|
1044 |
(*Remove trivial tpairs, of the form t=t*) |
|
1045 |
val distpairs = filter (not o op aconv) tpairs |
|
1046 |
val newprop = Logic.list_flexpairs(distpairs, horn) |
|
1220 | 1047 |
in fix_shyps [th] (env_codT env) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1048 |
(Thm{sign_ref = sign_ref, |
2386 | 1049 |
der = infer_derivs (Flexflex_rule env, [der]), |
1050 |
maxidx = maxidx_of_term newprop, |
|
1051 |
shyps = [], |
|
1052 |
hyps = hyps, |
|
1053 |
prop = newprop}) |
|
250 | 1054 |
end; |
0 | 1055 |
val (tpairs,_) = Logic.strip_flexpairs prop |
4270 | 1056 |
in Seq.map newthm |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1057 |
(Unify.smash_unifiers(Sign.deref sign_ref, Envir.empty maxidx, tpairs)) |
0 | 1058 |
end; |
1059 |
||
1060 |
(*Instantiation of Vars |
|
1220 | 1061 |
A |
1062 |
------------------- |
|
1063 |
A[t1/v1,....,tn/vn] |
|
1064 |
*) |
|
0 | 1065 |
|
1066 |
(*Check that all the terms are Vars and are distinct*) |
|
1067 |
fun instl_ok ts = forall is_Var ts andalso null(findrep ts); |
|
1068 |
||
1069 |
(*For instantiate: process pair of cterms, merge theories*) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1070 |
fun add_ctpair ((ct,cu), (sign_ref,tpairs)) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1071 |
let val Cterm {sign_ref=sign_reft, t=t, T= T, ...} = ct |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1072 |
and Cterm {sign_ref=sign_refu, t=u, T= U, ...} = cu |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1073 |
in |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1074 |
if T=U then |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1075 |
(Sign.merge_refs (sign_ref, Sign.merge_refs (sign_reft, sign_refu)), (t,u)::tpairs) |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1076 |
else raise TYPE("add_ctpair", [T,U], [t,u]) |
0 | 1077 |
end; |
1078 |
||
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1079 |
fun add_ctyp ((v,ctyp), (sign_ref',vTs)) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1080 |
let val Ctyp {T,sign_ref} = ctyp |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1081 |
in (Sign.merge_refs(sign_ref,sign_ref'), (v,T)::vTs) end; |
0 | 1082 |
|
1083 |
(*Left-to-right replacements: ctpairs = [...,(vi,ti),...]. |
|
1084 |
Instantiates distinct Vars by terms of same type. |
|
1085 |
Normalizes the new theorem! *) |
|
1529 | 1086 |
fun instantiate ([], []) th = th |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1087 |
| instantiate (vcTs,ctpairs) (th as Thm{sign_ref,der,maxidx,hyps,prop,...}) = |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1088 |
let val (newsign_ref,tpairs) = foldr add_ctpair (ctpairs, (sign_ref,[])); |
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1089 |
val (newsign_ref,vTs) = foldr add_ctyp (vcTs, (newsign_ref,[])); |
250 | 1090 |
val newprop = |
1091 |
Envir.norm_term (Envir.empty 0) |
|
1092 |
(subst_atomic tpairs |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1093 |
(Type.inst_term_tvars(Sign.tsig_of (Sign.deref newsign_ref),vTs) prop)) |
1220 | 1094 |
val newth = |
1095 |
fix_shyps [th] (map snd vTs) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1096 |
(Thm{sign_ref = newsign_ref, |
2386 | 1097 |
der = infer_derivs (Instantiate(vcTs,ctpairs), [der]), |
1098 |
maxidx = maxidx_of_term newprop, |
|
1099 |
shyps = [], |
|
1100 |
hyps = hyps, |
|
1101 |
prop = newprop}) |
|
250 | 1102 |
in if not(instl_ok(map #1 tpairs)) |
193 | 1103 |
then raise THM("instantiate: variables not distinct", 0, [th]) |
1104 |
else if not(null(findrep(map #1 vTs))) |
|
1105 |
then raise THM("instantiate: type variables not distinct", 0, [th]) |
|
2147 | 1106 |
else nodup_Vars newth "instantiate" |
0 | 1107 |
end |
250 | 1108 |
handle TERM _ => |
0 | 1109 |
raise THM("instantiate: incompatible signatures",0,[th]) |
2671 | 1110 |
| TYPE (msg,_,_) => raise THM("instantiate: type conflict: " ^ msg, |
1111 |
0, [th]); |
|
0 | 1112 |
|
1113 |
(*The trivial implication A==>A, justified by assume and forall rules. |
|
1114 |
A can contain Vars, not so for assume! *) |
|
250 | 1115 |
fun trivial ct : thm = |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1116 |
let val Cterm {sign_ref, t=A, T, maxidx} = ct |
250 | 1117 |
in if T<>propT then |
1118 |
raise THM("trivial: the term must have type prop", 0, []) |
|
1238 | 1119 |
else fix_shyps [] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1120 |
(Thm{sign_ref = sign_ref, |
2386 | 1121 |
der = infer_derivs (Trivial ct, []), |
1122 |
maxidx = maxidx, |
|
1123 |
shyps = [], |
|
1124 |
hyps = [], |
|
1125 |
prop = implies$A$A}) |
|
0 | 1126 |
end; |
1127 |
||
1503 | 1128 |
(*Axiom-scheme reflecting signature contents: "OFCLASS(?'a::c, c_class)" *) |
6368 | 1129 |
fun class_triv sign c = |
1130 |
let val Cterm {sign_ref, t, maxidx, ...} = |
|
1131 |
cterm_of sign (Logic.mk_inclass (TVar (("'a", 0), [c]), c)) |
|
1132 |
handle TERM (msg, _) => raise THM ("class_triv: " ^ msg, 0, []); |
|
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
1133 |
in |
1238 | 1134 |
fix_shyps [] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1135 |
(Thm {sign_ref = sign_ref, |
4182 | 1136 |
der = infer_derivs (Class_triv c, []), |
2386 | 1137 |
maxidx = maxidx, |
1138 |
shyps = [], |
|
1139 |
hyps = [], |
|
1140 |
prop = t}) |
|
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
1141 |
end; |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
1142 |
|
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
1143 |
|
6786 | 1144 |
(* Replace all TFrees not fixed or in the hyps by new TVars *) |
1145 |
fun varifyT' fixed (Thm{sign_ref,der,maxidx,shyps,hyps,prop}) = |
|
1146 |
let val tfrees = foldr add_term_tfree_names (hyps,fixed) |
|
1634 | 1147 |
in let val thm = (*no fix_shyps*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1148 |
Thm{sign_ref = sign_ref, |
6786 | 1149 |
der = infer_derivs (VarifyT fixed, [der]), |
2386 | 1150 |
maxidx = Int.max(0,maxidx), |
1151 |
shyps = shyps, |
|
1152 |
hyps = hyps, |
|
1529 | 1153 |
prop = Type.varify(prop,tfrees)} |
2147 | 1154 |
in nodup_Vars thm "varifyT" end |
1634 | 1155 |
(* this nodup_Vars check can be removed if thms are guaranteed not to contain |
1156 |
duplicate TVars with differnt sorts *) |
|
0 | 1157 |
end; |
1158 |
||
6786 | 1159 |
val varifyT = varifyT' []; |
1160 |
||
0 | 1161 |
(* Replace all TVars by new TFrees *) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1162 |
fun freezeT(Thm{sign_ref,der,maxidx,shyps,hyps,prop}) = |
3410 | 1163 |
let val (prop',_) = Type.freeze_thaw prop |
1238 | 1164 |
in (*no fix_shyps*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1165 |
Thm{sign_ref = sign_ref, |
2386 | 1166 |
der = infer_derivs (FreezeT, [der]), |
1167 |
maxidx = maxidx_of_term prop', |
|
1168 |
shyps = shyps, |
|
1169 |
hyps = hyps, |
|
1529 | 1170 |
prop = prop'} |
1220 | 1171 |
end; |
0 | 1172 |
|
1173 |
||
1174 |
(*** Inference rules for tactics ***) |
|
1175 |
||
1176 |
(*Destruct proof state into constraints, other goals, goal(i), rest *) |
|
1177 |
fun dest_state (state as Thm{prop,...}, i) = |
|
1178 |
let val (tpairs,horn) = Logic.strip_flexpairs prop |
|
1179 |
in case Logic.strip_prems(i, [], horn) of |
|
1180 |
(B::rBs, C) => (tpairs, rev rBs, B, C) |
|
1181 |
| _ => raise THM("dest_state", i, [state]) |
|
1182 |
end |
|
1183 |
handle TERM _ => raise THM("dest_state", i, [state]); |
|
1184 |
||
309 | 1185 |
(*Increment variables and parameters of orule as required for |
0 | 1186 |
resolution with goal i of state. *) |
1187 |
fun lift_rule (state, i) orule = |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1188 |
let val Thm{shyps=sshyps, prop=sprop, maxidx=smax, sign_ref=ssign_ref,...} = state |
0 | 1189 |
val (Bi::_, _) = Logic.strip_prems(i, [], Logic.skip_flexpairs sprop) |
1529 | 1190 |
handle TERM _ => raise THM("lift_rule", i, [orule,state]) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1191 |
val ct_Bi = Cterm {sign_ref=ssign_ref, maxidx=smax, T=propT, t=Bi} |
1529 | 1192 |
val (lift_abs,lift_all) = Logic.lift_fns(Bi,smax+1) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1193 |
val (Thm{sign_ref, der, maxidx,shyps,hyps,prop}) = orule |
0 | 1194 |
val (tpairs,As,B) = Logic.strip_horn prop |
1238 | 1195 |
in (*no fix_shyps*) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1196 |
Thm{sign_ref = merge_thm_sgs(state,orule), |
2386 | 1197 |
der = infer_derivs (Lift_rule(ct_Bi, i), [der]), |
1198 |
maxidx = maxidx+smax+1, |
|
2177
8b365a3a6ed1
Changed some mem, ins and union calls to be monomorphic
paulson
parents:
2163
diff
changeset
|
1199 |
shyps=union_sort(sshyps,shyps), |
2386 | 1200 |
hyps=hyps, |
1529 | 1201 |
prop = Logic.rule_of (map (pairself lift_abs) tpairs, |
2386 | 1202 |
map lift_all As, |
1203 |
lift_all B)} |
|
0 | 1204 |
end; |
1205 |
||
1206 |
(*Solve subgoal Bi of proof state B1...Bn/C by assumption. *) |
|
1207 |
fun assumption i state = |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1208 |
let val Thm{sign_ref,der,maxidx,hyps,prop,...} = state; |
0 | 1209 |
val (tpairs, Bs, Bi, C) = dest_state(state,i) |
250 | 1210 |
fun newth (env as Envir.Envir{maxidx, ...}, tpairs) = |
1220 | 1211 |
fix_shyps [state] (env_codT env) |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1212 |
(Thm{sign_ref = sign_ref, |
2386 | 1213 |
der = infer_derivs (Assumption (i, Some env), [der]), |
1214 |
maxidx = maxidx, |
|
1215 |
shyps = [], |
|
1216 |
hyps = hyps, |
|
1217 |
prop = |
|
1218 |
if Envir.is_empty env then (*avoid wasted normalizations*) |
|
1219 |
Logic.rule_of (tpairs, Bs, C) |
|
1220 |
else (*normalize the new rule fully*) |
|
1221 |
Envir.norm_term env (Logic.rule_of (tpairs, Bs, C))}); |
|
4270 | 1222 |
fun addprfs [] = Seq.empty |
1223 |
| addprfs ((t,u)::apairs) = Seq.make (fn()=> Seq.pull |
|
1224 |
(Seq.mapp newth |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1225 |
(Unify.unifiers(Sign.deref sign_ref,Envir.empty maxidx, (t,u)::tpairs)) |
250 | 1226 |
(addprfs apairs))) |
0 | 1227 |
in addprfs (Logic.assum_pairs Bi) end; |
1228 |
||
250 | 1229 |
(*Solve subgoal Bi of proof state B1...Bn/C by assumption. |
0 | 1230 |
Checks if Bi's conclusion is alpha-convertible to one of its assumptions*) |
1231 |
fun eq_assumption i state = |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1232 |
let val Thm{sign_ref,der,maxidx,hyps,prop,...} = state; |
0 | 1233 |
val (tpairs, Bs, Bi, C) = dest_state(state,i) |
1234 |
in if exists (op aconv) (Logic.assum_pairs Bi) |
|
1220 | 1235 |
then fix_shyps [state] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1236 |
(Thm{sign_ref = sign_ref, |
2386 | 1237 |
der = infer_derivs (Assumption (i,None), [der]), |
1238 |
maxidx = maxidx, |
|
1239 |
shyps = [], |
|
1240 |
hyps = hyps, |
|
1241 |
prop = Logic.rule_of(tpairs, Bs, C)}) |
|
0 | 1242 |
else raise THM("eq_assumption", 0, [state]) |
1243 |
end; |
|
1244 |
||
1245 |
||
2671 | 1246 |
(*For rotate_tac: fast rotation of assumptions of subgoal i*) |
1247 |
fun rotate_rule k i state = |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1248 |
let val Thm{sign_ref,der,maxidx,hyps,prop,shyps} = state; |
2671 | 1249 |
val (tpairs, Bs, Bi, C) = dest_state(state,i) |
1250 |
val params = Logic.strip_params Bi |
|
1251 |
and asms = Logic.strip_assums_hyp Bi |
|
1252 |
and concl = Logic.strip_assums_concl Bi |
|
1253 |
val n = length asms |
|
1254 |
fun rot m = if 0=m orelse m=n then Bi |
|
1255 |
else if 0<m andalso m<n |
|
1256 |
then list_all |
|
1257 |
(params, |
|
1258 |
Logic.list_implies(List.drop(asms, m) @ |
|
1259 |
List.take(asms, m), |
|
1260 |
concl)) |
|
1261 |
else raise THM("rotate_rule", m, [state]) |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1262 |
in Thm{sign_ref = sign_ref, |
2671 | 1263 |
der = infer_derivs (Rotate_rule (k,i), [der]), |
1264 |
maxidx = maxidx, |
|
1265 |
shyps = shyps, |
|
1266 |
hyps = hyps, |
|
1267 |
prop = Logic.rule_of(tpairs, Bs@[rot (if k<0 then n+k else k)], C)} |
|
1268 |
end; |
|
1269 |
||
1270 |
||
0 | 1271 |
(** User renaming of parameters in a subgoal **) |
1272 |
||
1273 |
(*Calls error rather than raising an exception because it is intended |
|
1274 |
for top-level use -- exception handling would not make sense here. |
|
1275 |
The names in cs, if distinct, are used for the innermost parameters; |
|
1276 |
preceding parameters may be renamed to make all params distinct.*) |
|
1277 |
fun rename_params_rule (cs, i) state = |
|
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1278 |
let val Thm{sign_ref,der,maxidx,hyps,...} = state |
0 | 1279 |
val (tpairs, Bs, Bi, C) = dest_state(state,i) |
1280 |
val iparams = map #1 (Logic.strip_params Bi) |
|
1281 |
val short = length iparams - length cs |
|
250 | 1282 |
val newnames = |
1283 |
if short<0 then error"More names than abstractions!" |
|
1284 |
else variantlist(take (short,iparams), cs) @ cs |
|
3037
99ed078e6ae7
rename_params_rule used to check if the new name clashed with a free name in
nipkow
parents:
3012
diff
changeset
|
1285 |
val freenames = map (#1 o dest_Free) (term_frees Bi) |
0 | 1286 |
val newBi = Logic.list_rename_params (newnames, Bi) |
250 | 1287 |
in |
0 | 1288 |
case findrep cs of |
3565
c64410e701fb
Now rename_params_rule merely issues warnings--and does nothing--if the
paulson
parents:
3558
diff
changeset
|
1289 |
c::_ => (warning ("Can't rename. Bound variables not distinct: " ^ c); |
c64410e701fb
Now rename_params_rule merely issues warnings--and does nothing--if the
paulson
parents:
3558
diff
changeset
|
1290 |
state) |
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1569
diff
changeset
|
1291 |
| [] => (case cs inter_string freenames of |
3565
c64410e701fb
Now rename_params_rule merely issues warnings--and does nothing--if the
paulson
parents:
3558
diff
changeset
|
1292 |
a::_ => (warning ("Can't rename. Bound/Free variable clash: " ^ a); |
c64410e701fb
Now rename_params_rule merely issues warnings--and does nothing--if the
paulson
parents:
3558
diff
changeset
|
1293 |
state) |
1220 | 1294 |
| [] => fix_shyps [state] [] |
3967
edd5ff9371f8
sg_ref: automatic adjustment of thms of draft theories;
wenzelm
parents:
3895
diff
changeset
|
1295 |
(Thm{sign_ref = sign_ref, |
2386 | 1296 |
der = infer_derivs (Rename_params_rule(cs,i), [der]), |
1297 |
maxidx = maxidx, |
|
1298 |
shyps = [], |
|
1299 |
hyps = hyps, |
|
1300 |
prop = Logic.rule_of(tpairs, Bs@[newBi], C)})) |
|
0 | 1301 |
end; |
1302 |
||
1303 |
(*** Preservation of bound variable names ***) |
|
1304 |
||
250 | 1305 |
(*Scan a pair of terms; while they are similar, |
0 | 1306 |
accumulate corresponding bound vars in "al"*) |
1238 | 1307 |
fun match_bvs(Abs(x,_,s),Abs(y,_,t), al) = |
1195
686e3eb613b9
match_bvs no longer puts a name in the alist if it is null ("")
lcp
parents:
1160
diff
changeset
|
1308 |
match_bvs(s, t, if x="" orelse y="" then al |
1238 | 1309 |
else (x,y)::al) |
0 | 1310 |
| match_bvs(f$s, g$t, al) = match_bvs(f,g,match_bvs(s,t,al)) |
1311 |
| match_bvs(_,_,al) = al; |
|
1312 |
||
1313 |
(* strip abstractions created by parameters *) |
|
1314 |
fun match_bvars((s,t),al) = match_bvs(strip_abs_body s, strip_abs_body t, al); |
|
1315 |
||
1316 |
||
250 | 1317 |
(* strip_apply f A(,B) strips off all assumptions/parameters from A |
0 | 1318 |
introduced by lifting over B, and applies f to remaining part of A*) |
1319 |
fun strip_apply f = |
|
1320 |
let fun strip(Const("==>",_)$ A1 $ B1, |
|
250 | 1321 |
Const("==>",_)$ _ $ B2) = implies $ A1 $ strip(B1,B2) |
1322 |
| strip((c as Const("all",_)) $ Abs(a,T,t1), |
|
1323 |
Const("all",_) $ Abs(_,_,t2)) = c$Abs(a,T,strip(t1,t2)) |
|
1324 |
| strip(A,_) = f A |
|
0 | 1325 |
in strip end; |
1326 |
||
1327 |
(*Use the alist to rename all bound variables and some unknowns in a term |
|
1328 |
dpairs = current disagreement pairs; tpairs = permanent ones (flexflex); |
|
1329 |
Preserves unknowns in tpairs and on lhs of dpairs. *) |
|
1330 |
fun rename_bvs([],_,_,_) = I |
|
1331 |
| rename_bvs(al,dpairs,tpairs,B) = |
|
250 | 1332 |
let val vars = foldr add_term_vars |
1333 |
(map fst dpairs @ map fst tpairs @ map snd tpairs, []) |
|
1334 |
(*unknowns appearing elsewhere be preserved!*) |
|
1335 |
val vids = map (#1 o #1 o dest_Var) vars; |
|
1336 |
fun rename(t as Var((x,i),T)) = |
|
1337 |
(case assoc(al,x) of |
|
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1569
diff
changeset
|
1338 |
Some(y) => if x mem_string vids orelse y mem_string vids then t |
250 | 1339 |
else Var((y,i),T) |
1340 |
| None=> t) |
|
0 | 1341 |
| rename(Abs(x,T,t)) = |
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1569
diff
changeset
|
1342 |
Abs(case assoc_string(al,x) of Some(y) => y | None => x, |
250 | 1343 |
T, rename t) |
0 | 1344 |
| rename(f$t) = rename f $ rename t |
1345 |
| rename(t) = t; |
|
250 | 1346 |
fun strip_ren Ai = strip_apply rename (Ai,B) |
0 | 1347 |
in strip_ren end; |
1348 |
||
1349 |
(*Function to rename bounds/unknowns in the argument, lifted over B*) |
|
1350 |
fun rename_bvars(dpairs, tpairs, B) = |
|
250 | 1351 |
rename_bvs(foldr match_bvars (dpairs,[]), dpairs, tpairs, B); |
0 | 1352 |
|
1353 |
||
1354 |
(*** RESOLUTION ***) |
|
1355 |
||
721
479832ff2d29
Pure/thm/norm_term_skip: new, for skipping normalization of the context
lcp
parents:
678
diff
changeset
|
1356 |
(** Lifting optimizations **) |
479832ff2d29
Pure/thm/norm_term_skip: new, for skipping normalization of the context
lcp
parents:
678
diff
changeset
|
1357 |
|
0 | 1358 |
(*strip off pairs of assumptions/parameters in parallel -- they are |
1359 |
identical because of lifting*) |
|
250 | 1360 |
fun strip_assums2 (Const("==>", _) $ _ $ B1, |