author | wenzelm |
Tue, 23 Aug 1994 19:33:33 +0200 | |
changeset 574 | 810da101bad2 |
parent 564 | eec3a9222b50 |
child 622 | bf9821f58781 |
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 |
|
250 | 6 |
The abstract types "theory" and "thm". |
7 |
Also "cterm" / "ctyp" (certified terms / typs under a signature). |
|
0 | 8 |
*) |
9 |
||
250 | 10 |
signature THM = |
11 |
sig |
|
0 | 12 |
structure Envir : ENVIR |
13 |
structure Sequence : SEQUENCE |
|
14 |
structure Sign : SIGN |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
15 |
type ctyp |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
16 |
type cterm |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
17 |
type thm |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
18 |
type theory |
0 | 19 |
type meta_simpset |
20 |
exception THM of string * int * thm list |
|
21 |
exception THEORY of string * theory list |
|
22 |
exception SIMPLIFIER of string * thm |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
23 |
(*certified terms/types; previously in sign.ML*) |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
24 |
val cterm_of: Sign.sg -> term -> cterm |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
25 |
val ctyp_of: Sign.sg -> typ -> ctyp |
250 | 26 |
val read_ctyp: Sign.sg -> string -> ctyp |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
27 |
val read_cterm: Sign.sg -> string * typ -> cterm |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
28 |
val rep_cterm: cterm -> {T: typ, t: term, sign: Sign.sg, maxidx: int} |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
29 |
val rep_ctyp: ctyp -> {T: typ, sign: Sign.sg} |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
30 |
val term_of: cterm -> term |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
31 |
val typ_of: ctyp -> typ |
250 | 32 |
val cterm_fun: (term -> term) -> (cterm -> cterm) |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
33 |
(*end of cterm/ctyp functions*) |
564 | 34 |
local open Sign.Syntax in |
35 |
val add_classes: (class * class list) list -> theory -> theory |
|
421 | 36 |
val add_classrel: (class * class) list -> theory -> theory |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
37 |
val add_defsort: sort -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
38 |
val add_types: (string * int * mixfix) list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
39 |
val add_tyabbrs: (string * string list * string * mixfix) list |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
40 |
-> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
41 |
val add_tyabbrs_i: (string * string list * typ * mixfix) list |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
42 |
-> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
43 |
val add_arities: (string * sort list * sort) list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
44 |
val add_consts: (string * string * mixfix) list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
45 |
val add_consts_i: (string * typ * mixfix) list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
46 |
val add_syntax: (string * string * mixfix) list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
47 |
val add_syntax_i: (string * typ * mixfix) list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
48 |
val add_trfuns: |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
49 |
(string * (ast list -> ast)) list * |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
50 |
(string * (term list -> term)) list * |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
51 |
(string * (term list -> term)) list * |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
52 |
(string * (ast list -> ast)) list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
53 |
val add_trrules: xrule list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
54 |
val add_axioms: (string * string) list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
55 |
val add_axioms_i: (string * term) list -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
56 |
val add_thyname: string -> theory -> theory |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
57 |
end |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
58 |
val cert_axm: Sign.sg -> string * term -> string * term |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
59 |
val read_axm: Sign.sg -> string * string -> string * term |
564 | 60 |
val inferT_axm: Sign.sg -> string * term -> string * term |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
61 |
val abstract_rule: string -> cterm -> thm -> thm |
0 | 62 |
val add_congs: meta_simpset * thm list -> meta_simpset |
63 |
val add_prems: meta_simpset * thm list -> meta_simpset |
|
64 |
val add_simps: meta_simpset * thm list -> meta_simpset |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
65 |
val assume: cterm -> thm |
250 | 66 |
val assumption: int -> thm -> thm Sequence.seq |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
67 |
val axioms_of: theory -> (string * term) list |
250 | 68 |
val beta_conversion: cterm -> thm |
69 |
val bicompose: bool -> bool * thm * int -> int -> thm -> thm Sequence.seq |
|
70 |
val biresolution: bool -> (bool*thm)list -> int -> thm -> thm Sequence.seq |
|
71 |
val combination: thm -> thm -> thm |
|
72 |
val concl_of: thm -> term |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
73 |
val cprop_of: thm -> cterm |
87 | 74 |
val del_simps: meta_simpset * thm list -> meta_simpset |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
75 |
val dest_cimplies: cterm -> cterm*cterm |
0 | 76 |
val dest_state: thm * int -> (term*term)list * term list * term * term |
77 |
val empty_mss: meta_simpset |
|
250 | 78 |
val eq_assumption: int -> thm -> thm |
0 | 79 |
val equal_intr: thm -> thm -> thm |
80 |
val equal_elim: thm -> thm -> thm |
|
250 | 81 |
val extensional: thm -> thm |
82 |
val flexflex_rule: thm -> thm Sequence.seq |
|
83 |
val flexpair_def: thm |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
84 |
val forall_elim: cterm -> thm -> thm |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
85 |
val forall_intr: cterm -> thm -> thm |
0 | 86 |
val freezeT: thm -> thm |
87 |
val get_axiom: theory -> string -> thm |
|
88 |
val implies_elim: thm -> thm -> thm |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
89 |
val implies_intr: cterm -> thm -> thm |
0 | 90 |
val implies_intr_hyps: thm -> thm |
250 | 91 |
val instantiate: (indexname*ctyp)list * (cterm*cterm)list |
0 | 92 |
-> thm -> thm |
93 |
val lift_rule: (thm * int) -> thm -> thm |
|
94 |
val merge_theories: theory * theory -> theory |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
95 |
val merge_thy_list: bool -> theory list -> theory |
0 | 96 |
val mk_rews_of_mss: meta_simpset -> thm -> thm list |
97 |
val mss_of: thm list -> meta_simpset |
|
98 |
val nprems_of: thm -> int |
|
99 |
val parents_of: theory -> theory list |
|
100 |
val prems_of: thm -> term list |
|
101 |
val prems_of_mss: meta_simpset -> thm list |
|
102 |
val pure_thy: theory |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
103 |
val read_def_cterm : |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
104 |
Sign.sg * (indexname -> typ option) * (indexname -> sort option) -> |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
105 |
string * typ -> cterm * (indexname * typ) list |
250 | 106 |
val reflexive: cterm -> thm |
0 | 107 |
val rename_params_rule: string list * int -> thm -> thm |
108 |
val rep_thm: thm -> {prop: term, hyps: term list, maxidx: int, sign: Sign.sg} |
|
214
ed6a3e2b1a33
added new parameter to the simplification tactics which indicates if
nipkow
parents:
209
diff
changeset
|
109 |
val rewrite_cterm: |
ed6a3e2b1a33
added new parameter to the simplification tactics which indicates if
nipkow
parents:
209
diff
changeset
|
110 |
bool*bool -> meta_simpset -> (meta_simpset -> thm -> thm option) |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
111 |
-> cterm -> thm |
0 | 112 |
val set_mk_rews: meta_simpset * (thm -> thm list) -> meta_simpset |
421 | 113 |
val rep_theory: theory -> {sign: Sign.sg, new_axioms: term Sign.Symtab.table, |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
114 |
parents: theory list} |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
115 |
val subthy: theory * theory -> bool |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
116 |
val eq_thy: theory * theory -> bool |
250 | 117 |
val sign_of: theory -> Sign.sg |
0 | 118 |
val syn_of: theory -> Sign.Syntax.syntax |
119 |
val stamps_of_thm: thm -> string ref list |
|
120 |
val stamps_of_thy: theory -> string ref list |
|
250 | 121 |
val symmetric: thm -> thm |
0 | 122 |
val tpairs_of: thm -> (term*term)list |
123 |
val trace_simp: bool ref |
|
124 |
val transitive: thm -> thm -> thm |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
125 |
val trivial: cterm -> thm |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
126 |
val class_triv: theory -> class -> thm |
0 | 127 |
val varifyT: thm -> thm |
250 | 128 |
end; |
0 | 129 |
|
250 | 130 |
functor ThmFun (structure Logic: LOGIC and Unify: UNIFY and Pattern: PATTERN |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
131 |
and Net:NET sharing type Pattern.type_sig = Unify.Sign.Type.type_sig): THM = |
0 | 132 |
struct |
250 | 133 |
|
0 | 134 |
structure Sequence = Unify.Sequence; |
135 |
structure Envir = Unify.Envir; |
|
136 |
structure Sign = Unify.Sign; |
|
137 |
structure Type = Sign.Type; |
|
138 |
structure Syntax = Sign.Syntax; |
|
139 |
structure Symtab = Sign.Symtab; |
|
140 |
||
141 |
||
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
142 |
(*** Certified terms and types ***) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
143 |
|
250 | 144 |
(** certified types **) |
145 |
||
146 |
(*certified typs under a signature*) |
|
147 |
||
148 |
datatype ctyp = Ctyp of {sign: Sign.sg, T: typ}; |
|
149 |
||
150 |
fun rep_ctyp (Ctyp args) = args; |
|
151 |
fun typ_of (Ctyp {T, ...}) = T; |
|
152 |
||
153 |
fun ctyp_of sign T = |
|
154 |
Ctyp {sign = sign, T = Sign.certify_typ sign T}; |
|
155 |
||
156 |
fun read_ctyp sign s = |
|
157 |
Ctyp {sign = 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
|
158 |
|
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
159 |
|
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
160 |
|
250 | 161 |
(** certified terms **) |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
162 |
|
250 | 163 |
(*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
|
164 |
|
250 | 165 |
datatype cterm = Cterm of {sign: Sign.sg, 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
|
166 |
|
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
167 |
fun rep_cterm (Cterm args) = args; |
250 | 168 |
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
|
169 |
|
250 | 170 |
(*create a cterm by checking a "raw" term with respect to a signature*) |
171 |
fun cterm_of sign tm = |
|
172 |
let val (t, T, maxidx) = Sign.certify_term sign tm |
|
173 |
in Cterm {sign = sign, t = t, T = T, maxidx = maxidx} |
|
174 |
end handle TYPE (msg, _, _) |
|
175 |
=> raise TERM ("Term not in signature\n" ^ msg, [tm]); |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
176 |
|
250 | 177 |
fun cterm_fun f (Cterm {sign, t, ...}) = cterm_of sign (f t); |
178 |
||
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
179 |
|
250 | 180 |
(*dest_implies for cterms. Note T=prop below*) |
181 |
fun dest_cimplies (Cterm{sign, T, maxidx, t=Const("==>", _) $ A $ B}) = |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
182 |
(Cterm{sign=sign, T=T, maxidx=maxidx, t=A}, |
250 | 183 |
Cterm{sign=sign, T=T, maxidx=maxidx, t=B}) |
184 |
| dest_cimplies ct = raise TERM ("dest_cimplies", [term_of ct]); |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
185 |
|
250 | 186 |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
187 |
|
574 | 188 |
(** read cterms **) (*exception ERROR*) |
250 | 189 |
|
190 |
(*read term, infer types, certify term*) |
|
191 |
fun read_def_cterm (sign, types, sorts) (a, T) = |
|
192 |
let |
|
574 | 193 |
val T' = Sign.certify_typ sign T |
194 |
handle TYPE (msg, _, _) => error msg; |
|
195 |
val t = Syntax.read (#syn (Sign.rep_sg sign)) T' a; |
|
196 |
val (t', tye) = Sign.infer_types sign types sorts (t, T'); |
|
197 |
val ct = cterm_of sign t' |
|
198 |
handle TERM (msg, _) => error msg; |
|
250 | 199 |
in (ct, tye) end; |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
200 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
201 |
fun read_cterm sign = #1 o read_def_cterm (sign, K None, K None); |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
202 |
|
250 | 203 |
|
204 |
||
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
205 |
(*** Meta theorems ***) |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
206 |
|
0 | 207 |
datatype thm = Thm of |
250 | 208 |
{sign: Sign.sg, maxidx: int, hyps: term list, prop: term}; |
0 | 209 |
|
250 | 210 |
fun rep_thm (Thm args) = args; |
0 | 211 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
212 |
(*errors involving theorems*) |
0 | 213 |
exception THM of string * int * thm list; |
214 |
||
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
215 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
216 |
val sign_of_thm = #sign o rep_thm; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
217 |
val stamps_of_thm = #stamps o Sign.rep_sg o sign_of_thm; |
0 | 218 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
219 |
(*merge signatures of two theorems; raise exception if incompatible*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
220 |
fun merge_thm_sgs (th1, th2) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
221 |
Sign.merge (pairself sign_of_thm (th1, th2)) |
574 | 222 |
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
|
223 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
224 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
225 |
(*maps object-rule to tpairs*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
226 |
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
|
227 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
228 |
(*maps object-rule to premises*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
229 |
fun prems_of (Thm {prop, ...}) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
230 |
Logic.strip_imp_prems (Logic.skip_flexpairs prop); |
0 | 231 |
|
232 |
(*counts premises in a rule*) |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
233 |
fun nprems_of (Thm {prop, ...}) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
234 |
Logic.count_prems (Logic.skip_flexpairs prop, 0); |
0 | 235 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
236 |
(*maps object-rule to conclusion*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
237 |
fun concl_of (Thm {prop, ...}) = Logic.strip_imp_concl prop; |
0 | 238 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
239 |
(*the statement of any thm is a cterm*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
240 |
fun cprop_of (Thm {sign, maxidx, hyps, prop}) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
241 |
Cterm {sign = sign, 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
|
242 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
243 |
|
0 | 244 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
245 |
(*** Theories ***) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
246 |
|
0 | 247 |
datatype theory = |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
248 |
Theory of { |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
249 |
sign: Sign.sg, |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
250 |
new_axioms: term Symtab.table, |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
251 |
parents: theory list}; |
0 | 252 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
253 |
fun rep_theory (Theory args) = args; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
254 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
255 |
(*errors involving theories*) |
0 | 256 |
exception THEORY of string * theory list; |
257 |
||
258 |
||
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
259 |
val sign_of = #sign o rep_theory; |
0 | 260 |
val syn_of = #syn o Sign.rep_sg o sign_of; |
261 |
||
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
262 |
(*stamps associated with a theory*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
263 |
val stamps_of_thy = #stamps o Sign.rep_sg o sign_of; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
264 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
265 |
(*return additional axioms of this theory node*) |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
266 |
val axioms_of = Symtab.dest o #new_axioms o rep_theory; |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
267 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
268 |
(*return the immediate ancestors*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
269 |
val parents_of = #parents o rep_theory; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
270 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
271 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
272 |
(*compare theories*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
273 |
val subthy = Sign.subsig o pairself sign_of; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
274 |
val eq_thy = Sign.eq_sg o pairself sign_of; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
275 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
276 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
277 |
(*look up the named axiom in the theory*) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
278 |
fun get_axiom theory name = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
279 |
let |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
280 |
fun get_ax [] = raise Match |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
281 |
| get_ax (Theory {sign, new_axioms, parents} :: thys) = |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
282 |
(case Symtab.lookup (new_axioms, name) of |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
283 |
Some t => |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
284 |
Thm {sign = sign, maxidx = maxidx_of_term t, hyps = [], prop = t} |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
285 |
| None => get_ax parents handle Match => get_ax thys); |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
286 |
in |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
287 |
get_ax [theory] handle Match |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
288 |
=> raise THEORY ("get_axiom: no axiom " ^ quote name, [theory]) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
289 |
end; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
290 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
291 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
292 |
(* the Pure theory *) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
293 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
294 |
val pure_thy = |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
295 |
Theory {sign = Sign.pure, new_axioms = Symtab.null, parents = []}; |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
296 |
|
0 | 297 |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
298 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
299 |
(** extend theory **) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
300 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
301 |
fun err_dup_axms names = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
302 |
error ("Duplicate axiom name(s) " ^ commas_quote names); |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
303 |
|
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
304 |
fun ext_thy (thy as Theory {sign, new_axioms, parents}) sign1 new_axms = |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
305 |
let |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
306 |
val draft = Sign.is_draft sign; |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
307 |
val new_axioms1 = |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
308 |
Symtab.extend_new (if draft then new_axioms else Symtab.null, new_axms) |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
309 |
handle Symtab.DUPS names => err_dup_axms names; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
310 |
val parents1 = if draft then parents else [thy]; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
311 |
in |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
312 |
Theory {sign = sign1, new_axioms = new_axioms1, parents = parents1} |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
313 |
end; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
314 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
315 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
316 |
(* extend signature of a theory *) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
317 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
318 |
fun ext_sg extfun decls (thy as Theory {sign, ...}) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
319 |
ext_thy thy (extfun decls sign) []; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
320 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
321 |
val add_classes = ext_sg Sign.add_classes; |
421 | 322 |
val add_classrel = ext_sg Sign.add_classrel; |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
323 |
val add_defsort = ext_sg Sign.add_defsort; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
324 |
val add_types = ext_sg Sign.add_types; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
325 |
val add_tyabbrs = ext_sg Sign.add_tyabbrs; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
326 |
val add_tyabbrs_i = ext_sg Sign.add_tyabbrs_i; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
327 |
val add_arities = ext_sg Sign.add_arities; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
328 |
val add_consts = ext_sg Sign.add_consts; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
329 |
val add_consts_i = ext_sg Sign.add_consts_i; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
330 |
val add_syntax = ext_sg Sign.add_syntax; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
331 |
val add_syntax_i = ext_sg Sign.add_syntax_i; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
332 |
val add_trfuns = ext_sg Sign.add_trfuns; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
333 |
val add_trrules = ext_sg Sign.add_trrules; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
334 |
val add_thyname = ext_sg Sign.add_name; |
0 | 335 |
|
336 |
||
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
337 |
(* prepare axioms *) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
338 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
339 |
fun err_in_axm name = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
340 |
error ("The error(s) above occurred in axiom " ^ quote name); |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
341 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
342 |
fun no_vars tm = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
343 |
if null (term_vars tm) andalso null (term_tvars tm) then tm |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
344 |
else error "Illegal schematic variable(s) in term"; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
345 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
346 |
fun cert_axm sg (name, raw_tm) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
347 |
let |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
348 |
val Cterm {t, T, ...} = cterm_of sg raw_tm |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
349 |
handle TERM (msg, _) => error msg; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
350 |
in |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
351 |
assert (T = propT) "Term not of type prop"; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
352 |
(name, no_vars t) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
353 |
end |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
354 |
handle ERROR => err_in_axm name; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
355 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
356 |
fun read_axm sg (name, str) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
357 |
(name, no_vars (term_of (read_cterm sg (str, propT)))) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
358 |
handle ERROR => err_in_axm name; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
359 |
|
564 | 360 |
fun inferT_axm sg (name, pre_tm) = |
361 |
(name, no_vars (#1 (Sign.infer_types sg (K None) (K None) (pre_tm, propT)))) |
|
362 |
handle ERROR => err_in_axm name; |
|
363 |
||
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
364 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
365 |
(* extend axioms of a theory *) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
366 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
367 |
fun ext_axms prep_axm axms (thy as Theory {sign, ...}) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
368 |
let |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
369 |
val sign1 = Sign.make_draft sign; |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
370 |
val axioms = map (apsnd Logic.varify o prep_axm sign) axms; |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
371 |
in |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
372 |
ext_thy thy sign1 axioms |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
373 |
end; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
374 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
375 |
val add_axioms = ext_axms read_axm; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
376 |
val add_axioms_i = ext_axms cert_axm; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
377 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
378 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
379 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
380 |
(** merge theories **) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
381 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
382 |
fun merge_thy_list mk_draft thys = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
383 |
let |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
384 |
fun is_union thy = forall (fn t => subthy (t, thy)) thys; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
385 |
val is_draft = Sign.is_draft o sign_of; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
386 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
387 |
fun add_sign (sg, Theory {sign, ...}) = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
388 |
Sign.merge (sg, sign) handle TERM (msg, _) => error msg; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
389 |
in |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
390 |
(case (find_first is_union thys, exists is_draft thys) of |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
391 |
(Some thy, _) => thy |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
392 |
| (None, true) => raise THEORY ("Illegal merge of draft theories", thys) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
393 |
| (None, false) => Theory { |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
394 |
sign = |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
395 |
(if mk_draft then Sign.make_draft else I) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
396 |
(foldl add_sign (Sign.pure, thys)), |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
397 |
new_axioms = Symtab.null, |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
398 |
parents = thys}) |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
399 |
end; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
400 |
|
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
401 |
fun merge_theories (thy1, thy2) = merge_thy_list false [thy1, thy2]; |
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
402 |
|
0 | 403 |
|
404 |
||
405 |
(**** Primitive rules ****) |
|
406 |
||
407 |
(* discharge all assumptions t from ts *) |
|
408 |
val disch = gen_rem (op aconv); |
|
409 |
||
410 |
(*The assumption rule A|-A in a theory *) |
|
250 | 411 |
fun assume ct : thm = |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
412 |
let val {sign, t=prop, T, maxidx} = rep_cterm ct |
250 | 413 |
in if T<>propT then |
414 |
raise THM("assume: assumptions must have type prop", 0, []) |
|
0 | 415 |
else if maxidx <> ~1 then |
250 | 416 |
raise THM("assume: assumptions may not contain scheme variables", |
417 |
maxidx, []) |
|
0 | 418 |
else Thm{sign = sign, maxidx = ~1, hyps = [prop], prop = prop} |
419 |
end; |
|
420 |
||
250 | 421 |
(* Implication introduction |
422 |
A |- B |
|
423 |
------- |
|
424 |
A ==> B *) |
|
0 | 425 |
fun implies_intr cA (thB as Thm{sign,maxidx,hyps,prop}) : thm = |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
426 |
let val {sign=signA, t=A, T, maxidx=maxidxA} = rep_cterm cA |
0 | 427 |
in if T<>propT then |
250 | 428 |
raise THM("implies_intr: assumptions must have type prop", 0, [thB]) |
429 |
else Thm{sign= Sign.merge (sign,signA), maxidx= max[maxidxA, maxidx], |
|
430 |
hyps= disch(hyps,A), prop= implies$A$prop} |
|
0 | 431 |
handle TERM _ => |
432 |
raise THM("implies_intr: incompatible signatures", 0, [thB]) |
|
433 |
end; |
|
434 |
||
435 |
(* Implication elimination |
|
250 | 436 |
A ==> B A |
437 |
--------------- |
|
438 |
B *) |
|
0 | 439 |
fun implies_elim thAB thA : thm = |
440 |
let val Thm{maxidx=maxA, hyps=hypsA, prop=propA,...} = thA |
|
250 | 441 |
and Thm{sign, maxidx, hyps, prop,...} = thAB; |
442 |
fun err(a) = raise THM("implies_elim: "^a, 0, [thAB,thA]) |
|
0 | 443 |
in case prop of |
250 | 444 |
imp$A$B => |
445 |
if imp=implies andalso A aconv propA |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
446 |
then Thm{sign= merge_thm_sgs(thAB,thA), |
250 | 447 |
maxidx= max[maxA,maxidx], |
448 |
hyps= hypsA union hyps, (*dups suppressed*) |
|
449 |
prop= B} |
|
450 |
else err("major premise") |
|
451 |
| _ => err("major premise") |
|
0 | 452 |
end; |
250 | 453 |
|
0 | 454 |
(* Forall introduction. The Free or Var x must not be free in the hypotheses. |
455 |
A |
|
456 |
------ |
|
457 |
!!x.A *) |
|
458 |
fun forall_intr cx (th as Thm{sign,maxidx,hyps,prop}) = |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
459 |
let val x = term_of cx; |
0 | 460 |
fun result(a,T) = Thm{sign= sign, maxidx= maxidx, hyps= hyps, |
250 | 461 |
prop= all(T) $ Abs(a, T, abstract_over (x,prop))} |
0 | 462 |
in case x of |
250 | 463 |
Free(a,T) => |
464 |
if exists (apl(x, Logic.occs)) hyps |
|
465 |
then raise THM("forall_intr: variable free in assumptions", 0, [th]) |
|
466 |
else result(a,T) |
|
0 | 467 |
| Var((a,_),T) => result(a,T) |
468 |
| _ => raise THM("forall_intr: not a variable", 0, [th]) |
|
469 |
end; |
|
470 |
||
471 |
(* Forall elimination |
|
250 | 472 |
!!x.A |
473 |
-------- |
|
474 |
A[t/x] *) |
|
0 | 475 |
fun forall_elim ct (th as Thm{sign,maxidx,hyps,prop}) : thm = |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
476 |
let val {sign=signt, t, T, maxidx=maxt} = rep_cterm ct |
0 | 477 |
in case prop of |
250 | 478 |
Const("all",Type("fun",[Type("fun",[qary,_]),_])) $ A => |
479 |
if T<>qary then |
|
480 |
raise THM("forall_elim: type mismatch", 0, [th]) |
|
481 |
else Thm{sign= Sign.merge(sign,signt), |
|
482 |
maxidx= max[maxidx, maxt], |
|
483 |
hyps= hyps, prop= betapply(A,t)} |
|
484 |
| _ => raise THM("forall_elim: not quantified", 0, [th]) |
|
0 | 485 |
end |
486 |
handle TERM _ => |
|
250 | 487 |
raise THM("forall_elim: incompatible signatures", 0, [th]); |
0 | 488 |
|
489 |
||
490 |
(*** Equality ***) |
|
491 |
||
492 |
(*Definition of the relation =?= *) |
|
493 |
val flexpair_def = |
|
250 | 494 |
Thm{sign= Sign.pure, hyps= [], maxidx= 0, |
495 |
prop= term_of |
|
496 |
(read_cterm Sign.pure |
|
497 |
("(?t =?= ?u) == (?t == ?u::?'a::{})", propT))}; |
|
0 | 498 |
|
499 |
(*The reflexivity rule: maps t to the theorem t==t *) |
|
250 | 500 |
fun reflexive ct = |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
501 |
let val {sign, t, T, maxidx} = rep_cterm ct |
0 | 502 |
in Thm{sign= sign, hyps= [], maxidx= maxidx, prop= Logic.mk_equals(t,t)} |
503 |
end; |
|
504 |
||
505 |
(*The symmetry rule |
|
506 |
t==u |
|
507 |
---- |
|
508 |
u==t *) |
|
509 |
fun symmetric (th as Thm{sign,hyps,prop,maxidx}) = |
|
510 |
case prop of |
|
511 |
(eq as Const("==",_)) $ t $ u => |
|
250 | 512 |
Thm{sign=sign, hyps=hyps, maxidx=maxidx, prop= eq$u$t} |
0 | 513 |
| _ => raise THM("symmetric", 0, [th]); |
514 |
||
515 |
(*The transitive rule |
|
516 |
t1==u u==t2 |
|
517 |
------------ |
|
518 |
t1==t2 *) |
|
519 |
fun transitive th1 th2 = |
|
520 |
let val Thm{maxidx=max1, hyps=hyps1, prop=prop1,...} = th1 |
|
521 |
and Thm{maxidx=max2, hyps=hyps2, prop=prop2,...} = th2; |
|
522 |
fun err(msg) = raise THM("transitive: "^msg, 0, [th1,th2]) |
|
523 |
in case (prop1,prop2) of |
|
524 |
((eq as Const("==",_)) $ t1 $ u, Const("==",_) $ u' $ t2) => |
|
250 | 525 |
if not (u aconv u') then err"middle term" else |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
526 |
Thm{sign= merge_thm_sgs(th1,th2), hyps= hyps1 union hyps2, |
250 | 527 |
maxidx= max[max1,max2], prop= eq$t1$t2} |
0 | 528 |
| _ => err"premises" |
529 |
end; |
|
530 |
||
531 |
(*Beta-conversion: maps (%(x)t)(u) to the theorem (%(x)t)(u) == t[u/x] *) |
|
250 | 532 |
fun beta_conversion ct = |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
533 |
let val {sign, t, T, maxidx} = rep_cterm ct |
0 | 534 |
in case t of |
250 | 535 |
Abs(_,_,bodt) $ u => |
536 |
Thm{sign= sign, hyps= [], |
|
537 |
maxidx= maxidx_of_term t, |
|
538 |
prop= Logic.mk_equals(t, subst_bounds([u],bodt))} |
|
539 |
| _ => raise THM("beta_conversion: not a redex", 0, []) |
|
0 | 540 |
end; |
541 |
||
542 |
(*The extensionality rule (proviso: x not free in f, g, or hypotheses) |
|
543 |
f(x) == g(x) |
|
544 |
------------ |
|
545 |
f == g *) |
|
546 |
fun extensional (th as Thm{sign,maxidx,hyps,prop}) = |
|
547 |
case prop of |
|
548 |
(Const("==",_)) $ (f$x) $ (g$y) => |
|
250 | 549 |
let fun err(msg) = raise THM("extensional: "^msg, 0, [th]) |
0 | 550 |
in (if x<>y then err"different variables" else |
551 |
case y of |
|
250 | 552 |
Free _ => |
553 |
if exists (apl(y, Logic.occs)) (f::g::hyps) |
|
554 |
then err"variable free in hyps or functions" else () |
|
555 |
| Var _ => |
|
556 |
if Logic.occs(y,f) orelse Logic.occs(y,g) |
|
557 |
then err"variable free in functions" else () |
|
558 |
| _ => err"not a variable"); |
|
559 |
Thm{sign=sign, hyps=hyps, maxidx=maxidx, |
|
560 |
prop= Logic.mk_equals(f,g)} |
|
0 | 561 |
end |
562 |
| _ => raise THM("extensional: premise", 0, [th]); |
|
563 |
||
564 |
(*The abstraction rule. The Free or Var x must not be free in the hypotheses. |
|
565 |
The bound variable will be named "a" (since x will be something like x320) |
|
566 |
t == u |
|
567 |
---------------- |
|
568 |
%(x)t == %(x)u *) |
|
569 |
fun abstract_rule a cx (th as Thm{sign,maxidx,hyps,prop}) = |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
570 |
let val x = term_of cx; |
250 | 571 |
val (t,u) = Logic.dest_equals prop |
572 |
handle TERM _ => |
|
573 |
raise THM("abstract_rule: premise not an equality", 0, [th]) |
|
0 | 574 |
fun result T = |
575 |
Thm{sign= sign, maxidx= maxidx, hyps= hyps, |
|
250 | 576 |
prop= Logic.mk_equals(Abs(a, T, abstract_over (x,t)), |
577 |
Abs(a, T, abstract_over (x,u)))} |
|
0 | 578 |
in case x of |
250 | 579 |
Free(_,T) => |
580 |
if exists (apl(x, Logic.occs)) hyps |
|
581 |
then raise THM("abstract_rule: variable free in assumptions", 0, [th]) |
|
582 |
else result T |
|
0 | 583 |
| Var(_,T) => result T |
584 |
| _ => raise THM("abstract_rule: not a variable", 0, [th]) |
|
585 |
end; |
|
586 |
||
587 |
(*The combination rule |
|
588 |
f==g t==u |
|
589 |
------------ |
|
590 |
f(t)==g(u) *) |
|
591 |
fun combination th1 th2 = |
|
592 |
let val Thm{maxidx=max1, hyps=hyps1, prop=prop1,...} = th1 |
|
593 |
and Thm{maxidx=max2, hyps=hyps2, prop=prop2,...} = th2 |
|
594 |
in case (prop1,prop2) of |
|
595 |
(Const("==",_) $ f $ g, Const("==",_) $ t $ u) => |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
596 |
Thm{sign= merge_thm_sgs(th1,th2), hyps= hyps1 union hyps2, |
250 | 597 |
maxidx= max[max1,max2], prop= Logic.mk_equals(f$t, g$u)} |
0 | 598 |
| _ => raise THM("combination: premises", 0, [th1,th2]) |
599 |
end; |
|
600 |
||
601 |
||
602 |
(*The equal propositions rule |
|
603 |
A==B A |
|
604 |
--------- |
|
605 |
B *) |
|
606 |
fun equal_elim th1 th2 = |
|
607 |
let val Thm{maxidx=max1, hyps=hyps1, prop=prop1,...} = th1 |
|
608 |
and Thm{maxidx=max2, hyps=hyps2, prop=prop2,...} = th2; |
|
609 |
fun err(msg) = raise THM("equal_elim: "^msg, 0, [th1,th2]) |
|
610 |
in case prop1 of |
|
611 |
Const("==",_) $ A $ B => |
|
250 | 612 |
if not (prop2 aconv A) then err"not equal" else |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
613 |
Thm{sign= merge_thm_sgs(th1,th2), hyps= hyps1 union hyps2, |
250 | 614 |
maxidx= max[max1,max2], prop= B} |
0 | 615 |
| _ => err"major premise" |
616 |
end; |
|
617 |
||
618 |
||
619 |
(* Equality introduction |
|
620 |
A==>B B==>A |
|
621 |
------------- |
|
622 |
A==B *) |
|
623 |
fun equal_intr th1 th2 = |
|
624 |
let val Thm{maxidx=max1, hyps=hyps1, prop=prop1,...} = th1 |
|
625 |
and Thm{maxidx=max2, hyps=hyps2, prop=prop2,...} = th2; |
|
626 |
fun err(msg) = raise THM("equal_intr: "^msg, 0, [th1,th2]) |
|
627 |
in case (prop1,prop2) of |
|
628 |
(Const("==>",_) $ A $ B, Const("==>",_) $ B' $ A') => |
|
250 | 629 |
if A aconv A' andalso B aconv B' |
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
630 |
then Thm{sign= merge_thm_sgs(th1,th2), hyps= hyps1 union hyps2, |
250 | 631 |
maxidx= max[max1,max2], prop= Logic.mk_equals(A,B)} |
632 |
else err"not equal" |
|
0 | 633 |
| _ => err"premises" |
634 |
end; |
|
635 |
||
636 |
(**** Derived rules ****) |
|
637 |
||
638 |
(*Discharge all hypotheses (need not verify cterms) |
|
639 |
Repeated hypotheses are discharged only once; fold cannot do this*) |
|
640 |
fun implies_intr_hyps (Thm{sign, maxidx, hyps=A::As, prop}) = |
|
641 |
implies_intr_hyps |
|
250 | 642 |
(Thm{sign=sign, maxidx=maxidx, |
643 |
hyps= disch(As,A), prop= implies$A$prop}) |
|
0 | 644 |
| implies_intr_hyps th = th; |
645 |
||
646 |
(*Smash" unifies the list of term pairs leaving no flex-flex pairs. |
|
250 | 647 |
Instantiates the theorem and deletes trivial tpairs. |
0 | 648 |
Resulting sequence may contain multiple elements if the tpairs are |
649 |
not all flex-flex. *) |
|
650 |
fun flexflex_rule (Thm{sign,maxidx,hyps,prop}) = |
|
250 | 651 |
let fun newthm env = |
652 |
let val (tpairs,horn) = |
|
653 |
Logic.strip_flexpairs (Envir.norm_term env prop) |
|
654 |
(*Remove trivial tpairs, of the form t=t*) |
|
655 |
val distpairs = filter (not o op aconv) tpairs |
|
656 |
val newprop = Logic.list_flexpairs(distpairs, horn) |
|
657 |
in Thm{sign= sign, hyps= hyps, |
|
658 |
maxidx= maxidx_of_term newprop, prop= newprop} |
|
659 |
end; |
|
0 | 660 |
val (tpairs,_) = Logic.strip_flexpairs prop |
661 |
in Sequence.maps newthm |
|
250 | 662 |
(Unify.smash_unifiers(sign, Envir.empty maxidx, tpairs)) |
0 | 663 |
end; |
664 |
||
665 |
(*Instantiation of Vars |
|
250 | 666 |
A |
667 |
-------------------- |
|
668 |
A[t1/v1,....,tn/vn] *) |
|
0 | 669 |
|
670 |
(*Check that all the terms are Vars and are distinct*) |
|
671 |
fun instl_ok ts = forall is_Var ts andalso null(findrep ts); |
|
672 |
||
673 |
(*For instantiate: process pair of cterms, merge theories*) |
|
674 |
fun add_ctpair ((ct,cu), (sign,tpairs)) = |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
675 |
let val {sign=signt, t=t, T= T, ...} = rep_cterm ct |
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
676 |
and {sign=signu, t=u, T= U, ...} = rep_cterm cu |
0 | 677 |
in if T=U then (Sign.merge(sign, Sign.merge(signt, signu)), (t,u)::tpairs) |
678 |
else raise TYPE("add_ctpair", [T,U], [t,u]) |
|
679 |
end; |
|
680 |
||
681 |
fun add_ctyp ((v,ctyp), (sign',vTs)) = |
|
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
682 |
let val {T,sign} = rep_ctyp ctyp |
0 | 683 |
in (Sign.merge(sign,sign'), (v,T)::vTs) end; |
684 |
||
685 |
(*Left-to-right replacements: ctpairs = [...,(vi,ti),...]. |
|
686 |
Instantiates distinct Vars by terms of same type. |
|
687 |
Normalizes the new theorem! *) |
|
250 | 688 |
fun instantiate (vcTs,ctpairs) (th as Thm{sign,maxidx,hyps,prop}) = |
0 | 689 |
let val (newsign,tpairs) = foldr add_ctpair (ctpairs, (sign,[])); |
690 |
val (newsign,vTs) = foldr add_ctyp (vcTs, (newsign,[])); |
|
250 | 691 |
val newprop = |
692 |
Envir.norm_term (Envir.empty 0) |
|
693 |
(subst_atomic tpairs |
|
694 |
(Type.inst_term_tvars(#tsig(Sign.rep_sg newsign),vTs) prop)) |
|
0 | 695 |
val newth = Thm{sign= newsign, hyps= hyps, |
250 | 696 |
maxidx= maxidx_of_term newprop, prop= newprop} |
697 |
in if not(instl_ok(map #1 tpairs)) |
|
193 | 698 |
then raise THM("instantiate: variables not distinct", 0, [th]) |
699 |
else if not(null(findrep(map #1 vTs))) |
|
700 |
then raise THM("instantiate: type variables not distinct", 0, [th]) |
|
701 |
else (*Check types of Vars for agreement*) |
|
702 |
case findrep (map (#1 o dest_Var) (term_vars newprop)) of |
|
250 | 703 |
ix::_ => raise THM("instantiate: conflicting types for variable " ^ |
704 |
Syntax.string_of_vname ix ^ "\n", 0, [newth]) |
|
705 |
| [] => |
|
706 |
case findrep (map #1 (term_tvars newprop)) of |
|
707 |
ix::_ => raise THM |
|
708 |
("instantiate: conflicting sorts for type variable " ^ |
|
709 |
Syntax.string_of_vname ix ^ "\n", 0, [newth]) |
|
193 | 710 |
| [] => newth |
0 | 711 |
end |
250 | 712 |
handle TERM _ => |
0 | 713 |
raise THM("instantiate: incompatible signatures",0,[th]) |
193 | 714 |
| TYPE _ => raise THM("instantiate: type conflict", 0, [th]); |
0 | 715 |
|
716 |
(*The trivial implication A==>A, justified by assume and forall rules. |
|
717 |
A can contain Vars, not so for assume! *) |
|
250 | 718 |
fun trivial ct : thm = |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
719 |
let val {sign, t=A, T, maxidx} = rep_cterm ct |
250 | 720 |
in if T<>propT then |
721 |
raise THM("trivial: the term must have type prop", 0, []) |
|
0 | 722 |
else Thm{sign= sign, maxidx= maxidx, hyps= [], prop= implies$A$A} |
723 |
end; |
|
724 |
||
480 | 725 |
(*Axiom-scheme reflecting signature contents: "OFCLASS(?'a::c, c_class)". |
399
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
726 |
Is weaker than some definition of c_class, e.g. "c_class == %x.T"; |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
727 |
may be interpreted as an instance of A==>A.*) |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
728 |
fun class_triv thy c = |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
729 |
let |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
730 |
val sign = sign_of thy; |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
731 |
val Cterm {t, maxidx, ...} = |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
732 |
cterm_of sign (Logic.mk_inclass (TVar (("'a", 0), [c]), c)) |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
733 |
handle TERM (msg, _) => raise THM ("class_triv: " ^ msg, 0, []); |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
734 |
in |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
735 |
Thm {sign = sign, maxidx = maxidx, hyps = [], prop = t} |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
736 |
end; |
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
737 |
|
86cc2b98f9e0
added class_triv: theory -> class -> thm (for axclasses);
wenzelm
parents:
387
diff
changeset
|
738 |
|
0 | 739 |
(* Replace all TFrees not in the hyps by new TVars *) |
740 |
fun varifyT(Thm{sign,maxidx,hyps,prop}) = |
|
741 |
let val tfrees = foldr add_term_tfree_names (hyps,[]) |
|
742 |
in Thm{sign=sign, maxidx=max[0,maxidx], hyps=hyps, |
|
250 | 743 |
prop= Type.varify(prop,tfrees)} |
0 | 744 |
end; |
745 |
||
746 |
(* Replace all TVars by new TFrees *) |
|
747 |
fun freezeT(Thm{sign,maxidx,hyps,prop}) = |
|
748 |
let val prop' = Type.freeze (K true) prop |
|
749 |
in Thm{sign=sign, maxidx=maxidx_of_term prop', hyps=hyps, prop=prop'} end; |
|
750 |
||
751 |
||
752 |
(*** Inference rules for tactics ***) |
|
753 |
||
754 |
(*Destruct proof state into constraints, other goals, goal(i), rest *) |
|
755 |
fun dest_state (state as Thm{prop,...}, i) = |
|
756 |
let val (tpairs,horn) = Logic.strip_flexpairs prop |
|
757 |
in case Logic.strip_prems(i, [], horn) of |
|
758 |
(B::rBs, C) => (tpairs, rev rBs, B, C) |
|
759 |
| _ => raise THM("dest_state", i, [state]) |
|
760 |
end |
|
761 |
handle TERM _ => raise THM("dest_state", i, [state]); |
|
762 |
||
309 | 763 |
(*Increment variables and parameters of orule as required for |
0 | 764 |
resolution with goal i of state. *) |
765 |
fun lift_rule (state, i) orule = |
|
766 |
let val Thm{prop=sprop,maxidx=smax,...} = state; |
|
767 |
val (Bi::_, _) = Logic.strip_prems(i, [], Logic.skip_flexpairs sprop) |
|
250 | 768 |
handle TERM _ => raise THM("lift_rule", i, [orule,state]); |
0 | 769 |
val (lift_abs,lift_all) = Logic.lift_fns(Bi,smax+1); |
770 |
val (Thm{sign,maxidx,hyps,prop}) = orule |
|
771 |
val (tpairs,As,B) = Logic.strip_horn prop |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
772 |
in Thm{hyps=hyps, sign= merge_thm_sgs(state,orule), |
250 | 773 |
maxidx= maxidx+smax+1, |
774 |
prop= Logic.rule_of(map (pairself lift_abs) tpairs, |
|
775 |
map lift_all As, lift_all B)} |
|
0 | 776 |
end; |
777 |
||
778 |
(*Solve subgoal Bi of proof state B1...Bn/C by assumption. *) |
|
779 |
fun assumption i state = |
|
780 |
let val Thm{sign,maxidx,hyps,prop} = state; |
|
781 |
val (tpairs, Bs, Bi, C) = dest_state(state,i) |
|
250 | 782 |
fun newth (env as Envir.Envir{maxidx, ...}, tpairs) = |
783 |
Thm{sign=sign, hyps=hyps, maxidx=maxidx, prop= |
|
784 |
if Envir.is_empty env then (*avoid wasted normalizations*) |
|
785 |
Logic.rule_of (tpairs, Bs, C) |
|
786 |
else (*normalize the new rule fully*) |
|
787 |
Envir.norm_term env (Logic.rule_of (tpairs, Bs, C))}; |
|
0 | 788 |
fun addprfs [] = Sequence.null |
789 |
| addprfs ((t,u)::apairs) = Sequence.seqof (fn()=> Sequence.pull |
|
790 |
(Sequence.mapp newth |
|
250 | 791 |
(Unify.unifiers(sign,Envir.empty maxidx, (t,u)::tpairs)) |
792 |
(addprfs apairs))) |
|
0 | 793 |
in addprfs (Logic.assum_pairs Bi) end; |
794 |
||
250 | 795 |
(*Solve subgoal Bi of proof state B1...Bn/C by assumption. |
0 | 796 |
Checks if Bi's conclusion is alpha-convertible to one of its assumptions*) |
797 |
fun eq_assumption i state = |
|
798 |
let val Thm{sign,maxidx,hyps,prop} = state; |
|
799 |
val (tpairs, Bs, Bi, C) = dest_state(state,i) |
|
800 |
in if exists (op aconv) (Logic.assum_pairs Bi) |
|
250 | 801 |
then Thm{sign=sign, hyps=hyps, maxidx=maxidx, |
802 |
prop=Logic.rule_of(tpairs, Bs, C)} |
|
0 | 803 |
else raise THM("eq_assumption", 0, [state]) |
804 |
end; |
|
805 |
||
806 |
||
807 |
(** User renaming of parameters in a subgoal **) |
|
808 |
||
809 |
(*Calls error rather than raising an exception because it is intended |
|
810 |
for top-level use -- exception handling would not make sense here. |
|
811 |
The names in cs, if distinct, are used for the innermost parameters; |
|
812 |
preceding parameters may be renamed to make all params distinct.*) |
|
813 |
fun rename_params_rule (cs, i) state = |
|
814 |
let val Thm{sign,maxidx,hyps,prop} = state |
|
815 |
val (tpairs, Bs, Bi, C) = dest_state(state,i) |
|
816 |
val iparams = map #1 (Logic.strip_params Bi) |
|
817 |
val short = length iparams - length cs |
|
250 | 818 |
val newnames = |
819 |
if short<0 then error"More names than abstractions!" |
|
820 |
else variantlist(take (short,iparams), cs) @ cs |
|
0 | 821 |
val freenames = map (#1 o dest_Free) (term_frees prop) |
822 |
val newBi = Logic.list_rename_params (newnames, Bi) |
|
250 | 823 |
in |
0 | 824 |
case findrep cs of |
825 |
c::_ => error ("Bound variables not distinct: " ^ c) |
|
826 |
| [] => (case cs inter freenames of |
|
827 |
a::_ => error ("Bound/Free variable clash: " ^ a) |
|
828 |
| [] => Thm{sign=sign, hyps=hyps, maxidx=maxidx, prop= |
|
250 | 829 |
Logic.rule_of(tpairs, Bs@[newBi], C)}) |
0 | 830 |
end; |
831 |
||
832 |
(*** Preservation of bound variable names ***) |
|
833 |
||
250 | 834 |
(*Scan a pair of terms; while they are similar, |
0 | 835 |
accumulate corresponding bound vars in "al"*) |
836 |
fun match_bvs(Abs(x,_,s),Abs(y,_,t), al) = match_bvs(s,t,(x,y)::al) |
|
837 |
| match_bvs(f$s, g$t, al) = match_bvs(f,g,match_bvs(s,t,al)) |
|
838 |
| match_bvs(_,_,al) = al; |
|
839 |
||
840 |
(* strip abstractions created by parameters *) |
|
841 |
fun match_bvars((s,t),al) = match_bvs(strip_abs_body s, strip_abs_body t, al); |
|
842 |
||
843 |
||
250 | 844 |
(* strip_apply f A(,B) strips off all assumptions/parameters from A |
0 | 845 |
introduced by lifting over B, and applies f to remaining part of A*) |
846 |
fun strip_apply f = |
|
847 |
let fun strip(Const("==>",_)$ A1 $ B1, |
|
250 | 848 |
Const("==>",_)$ _ $ B2) = implies $ A1 $ strip(B1,B2) |
849 |
| strip((c as Const("all",_)) $ Abs(a,T,t1), |
|
850 |
Const("all",_) $ Abs(_,_,t2)) = c$Abs(a,T,strip(t1,t2)) |
|
851 |
| strip(A,_) = f A |
|
0 | 852 |
in strip end; |
853 |
||
854 |
(*Use the alist to rename all bound variables and some unknowns in a term |
|
855 |
dpairs = current disagreement pairs; tpairs = permanent ones (flexflex); |
|
856 |
Preserves unknowns in tpairs and on lhs of dpairs. *) |
|
857 |
fun rename_bvs([],_,_,_) = I |
|
858 |
| rename_bvs(al,dpairs,tpairs,B) = |
|
250 | 859 |
let val vars = foldr add_term_vars |
860 |
(map fst dpairs @ map fst tpairs @ map snd tpairs, []) |
|
861 |
(*unknowns appearing elsewhere be preserved!*) |
|
862 |
val vids = map (#1 o #1 o dest_Var) vars; |
|
863 |
fun rename(t as Var((x,i),T)) = |
|
864 |
(case assoc(al,x) of |
|
865 |
Some(y) => if x mem vids orelse y mem vids then t |
|
866 |
else Var((y,i),T) |
|
867 |
| None=> t) |
|
0 | 868 |
| rename(Abs(x,T,t)) = |
250 | 869 |
Abs(case assoc(al,x) of Some(y) => y | None => x, |
870 |
T, rename t) |
|
0 | 871 |
| rename(f$t) = rename f $ rename t |
872 |
| rename(t) = t; |
|
250 | 873 |
fun strip_ren Ai = strip_apply rename (Ai,B) |
0 | 874 |
in strip_ren end; |
875 |
||
876 |
(*Function to rename bounds/unknowns in the argument, lifted over B*) |
|
877 |
fun rename_bvars(dpairs, tpairs, B) = |
|
250 | 878 |
rename_bvs(foldr match_bvars (dpairs,[]), dpairs, tpairs, B); |
0 | 879 |
|
880 |
||
881 |
(*** RESOLUTION ***) |
|
882 |
||
883 |
(*strip off pairs of assumptions/parameters in parallel -- they are |
|
884 |
identical because of lifting*) |
|
250 | 885 |
fun strip_assums2 (Const("==>", _) $ _ $ B1, |
886 |
Const("==>", _) $ _ $ B2) = strip_assums2 (B1,B2) |
|
0 | 887 |
| strip_assums2 (Const("all",_)$Abs(a,T,t1), |
250 | 888 |
Const("all",_)$Abs(_,_,t2)) = |
0 | 889 |
let val (B1,B2) = strip_assums2 (t1,t2) |
890 |
in (Abs(a,T,B1), Abs(a,T,B2)) end |
|
891 |
| strip_assums2 BB = BB; |
|
892 |
||
893 |
||
894 |
(*Composition of object rule r=(A1...Am/B) with proof state s=(B1...Bn/C) |
|
250 | 895 |
Unifies B with Bi, replacing subgoal i (1 <= i <= n) |
0 | 896 |
If match then forbid instantiations in proof state |
897 |
If lifted then shorten the dpair using strip_assums2. |
|
898 |
If eres_flg then simultaneously proves A1 by assumption. |
|
250 | 899 |
nsubgoal is the number of new subgoals (written m above). |
0 | 900 |
Curried so that resolution calls dest_state only once. |
901 |
*) |
|
902 |
local open Sequence; exception Bicompose |
|
903 |
in |
|
250 | 904 |
fun bicompose_aux match (state, (stpairs, Bs, Bi, C), lifted) |
0 | 905 |
(eres_flg, orule, nsubgoal) = |
906 |
let val Thm{maxidx=smax, hyps=shyps, ...} = state |
|
907 |
and Thm{maxidx=rmax, hyps=rhyps, prop=rprop,...} = orule; |
|
387
69f4356d915d
new datatype theory, supports 'draft theories' and incremental extension:
wenzelm
parents:
309
diff
changeset
|
908 |
val sign = merge_thm_sgs(state,orule); |
0 | 909 |
(** Add new theorem with prop = '[| Bs; As |] ==> C' to thq **) |
250 | 910 |
fun addth As ((env as Envir.Envir {maxidx, ...}, tpairs), thq) = |
911 |
let val normt = Envir.norm_term env; |
|
912 |
(*perform minimal copying here by examining env*) |
|
913 |
val normp = |
|
914 |
if Envir.is_empty env then (tpairs, Bs @ As, C) |
|
915 |
else |
|
916 |
let val ntps = map (pairself normt) tpairs |
|
917 |
in if the (Envir.minidx env) > smax then (*no assignments in state*) |
|
918 |
(ntps, Bs @ map normt As, C) |
|
919 |
else if match then raise Bicompose |
|
920 |
else (*normalize the new rule fully*) |
|
921 |
(ntps, map normt (Bs @ As), normt C) |
|
922 |
end |
|
923 |
val th = Thm{sign=sign, hyps=rhyps union shyps, maxidx=maxidx, |
|
924 |
prop= Logic.rule_of normp} |
|
0 | 925 |
in cons(th, thq) end handle Bicompose => thq |
926 |
val (rtpairs,rhorn) = Logic.strip_flexpairs(rprop); |
|
927 |
val (rAs,B) = Logic.strip_prems(nsubgoal, [], rhorn) |
|
928 |
handle TERM _ => raise THM("bicompose: rule", 0, [orule,state]); |
|
929 |
(*Modify assumptions, deleting n-th if n>0 for e-resolution*) |
|
930 |
fun newAs(As0, n, dpairs, tpairs) = |
|
931 |
let val As1 = if !Logic.auto_rename orelse not lifted then As0 |
|
250 | 932 |
else map (rename_bvars(dpairs,tpairs,B)) As0 |
0 | 933 |
in (map (Logic.flatten_params n) As1) |
250 | 934 |
handle TERM _ => |
935 |
raise THM("bicompose: 1st premise", 0, [orule]) |
|
0 | 936 |
end; |
937 |
val env = Envir.empty(max[rmax,smax]); |
|
938 |
val BBi = if lifted then strip_assums2(B,Bi) else (B,Bi); |
|
939 |
val dpairs = BBi :: (rtpairs@stpairs); |
|
940 |
(*elim-resolution: try each assumption in turn. Initially n=1*) |
|
941 |
fun tryasms (_, _, []) = null |
|
942 |
| tryasms (As, n, (t,u)::apairs) = |
|
250 | 943 |
(case pull(Unify.unifiers(sign, env, (t,u)::dpairs)) of |
944 |
None => tryasms (As, n+1, apairs) |
|
945 |
| cell as Some((_,tpairs),_) => |
|
946 |
its_right (addth (newAs(As, n, [BBi,(u,t)], tpairs))) |
|
947 |
(seqof (fn()=> cell), |
|
948 |
seqof (fn()=> pull (tryasms (As, n+1, apairs))))); |
|
0 | 949 |
fun eres [] = raise THM("bicompose: no premises", 0, [orule,state]) |
950 |
| eres (A1::As) = tryasms (As, 1, Logic.assum_pairs A1); |
|
951 |
(*ordinary resolution*) |
|
952 |
fun res(None) = null |
|
250 | 953 |
| res(cell as Some((_,tpairs),_)) = |
954 |
its_right (addth(newAs(rev rAs, 0, [BBi], tpairs))) |
|
955 |
(seqof (fn()=> cell), null) |
|
0 | 956 |
in if eres_flg then eres(rev rAs) |
957 |
else res(pull(Unify.unifiers(sign, env, dpairs))) |
|
958 |
end; |
|
959 |
end; (*open Sequence*) |
|
960 |
||
961 |
||
962 |
fun bicompose match arg i state = |
|
963 |
bicompose_aux match (state, dest_state(state,i), false) arg; |
|
964 |
||
965 |
(*Quick test whether rule is resolvable with the subgoal with hyps Hs |
|
966 |
and conclusion B. If eres_flg then checks 1st premise of rule also*) |
|
967 |
fun could_bires (Hs, B, eres_flg, rule) = |
|
968 |
let fun could_reshyp (A1::_) = exists (apl(A1,could_unify)) Hs |
|
250 | 969 |
| could_reshyp [] = false; (*no premise -- illegal*) |
970 |
in could_unify(concl_of rule, B) andalso |
|
971 |
(not eres_flg orelse could_reshyp (prems_of rule)) |
|
0 | 972 |
end; |
973 |
||
974 |
(*Bi-resolution of a state with a list of (flag,rule) pairs. |
|
975 |
Puts the rule above: rule/state. Renames vars in the rules. *) |
|
250 | 976 |
fun biresolution match brules i state = |
0 | 977 |
let val lift = lift_rule(state, i); |
250 | 978 |
val (stpairs, Bs, Bi, C) = dest_state(state,i) |
979 |
val B = Logic.strip_assums_concl Bi; |
|
980 |
val Hs = Logic.strip_assums_hyp Bi; |
|
981 |
val comp = bicompose_aux match (state, (stpairs, Bs, Bi, C), true); |
|
982 |
fun res [] = Sequence.null |
|
983 |
| res ((eres_flg, rule)::brules) = |
|
984 |
if could_bires (Hs, B, eres_flg, rule) |
|
985 |
then Sequence.seqof (*delay processing remainder til needed*) |
|
986 |
(fn()=> Some(comp (eres_flg, lift rule, nprems_of rule), |
|
987 |
res brules)) |
|
988 |
else res brules |
|
0 | 989 |
in Sequence.flats (res brules) end; |
990 |
||
991 |
||
992 |
||
993 |
(*** Meta simp sets ***) |
|
994 |
||
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
995 |
type rrule = {thm:thm, lhs:term, perm:bool}; |
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
996 |
type cong = {thm:thm, lhs:term}; |
0 | 997 |
datatype meta_simpset = |
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
998 |
Mss of {net:rrule Net.net, congs:(string * cong)list, bounds:string list, |
0 | 999 |
prems: thm list, mk_rews: thm -> thm list}; |
1000 |
||
1001 |
(*A "mss" contains data needed during conversion: |
|
1002 |
net: discrimination net of rewrite rules |
|
1003 |
congs: association list of congruence rules |
|
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1004 |
bounds: names of bound variables already used; |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1005 |
for generating new names when rewriting under lambda abstractions |
0 | 1006 |
mk_rews: used when local assumptions are added |
1007 |
*) |
|
1008 |
||
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1009 |
val empty_mss = Mss{net= Net.empty, congs= [], bounds=[], prems= [], |
0 | 1010 |
mk_rews = K[]}; |
1011 |
||
1012 |
exception SIMPLIFIER of string * thm; |
|
1013 |
||
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
1014 |
fun prtm a sign t = (writeln a; writeln(Sign.string_of_term sign t)); |
0 | 1015 |
|
209 | 1016 |
val trace_simp = ref false; |
1017 |
||
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
1018 |
fun trace_term a sign t = if !trace_simp then prtm a sign t else (); |
209 | 1019 |
|
1020 |
fun trace_thm a (Thm{sign,prop,...}) = trace_term a sign prop; |
|
1021 |
||
427
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1022 |
fun vperm(Var _, Var _) = true |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1023 |
| vperm(Abs(_,_,s), Abs(_,_,t)) = vperm(s,t) |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1024 |
| vperm(t1$t2, u1$u2) = vperm(t1,u1) andalso vperm(t2,u2) |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1025 |
| vperm(t,u) = (t=u); |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1026 |
|
427
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1027 |
fun var_perm(t,u) = vperm(t,u) andalso |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1028 |
eq_set(add_term_vars(t,[]), add_term_vars(u,[])) |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1029 |
|
0 | 1030 |
(*simple test for looping rewrite*) |
1031 |
fun loops sign prems (lhs,rhs) = |
|
427
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1032 |
is_Var(lhs) orelse |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1033 |
(null(prems) andalso |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1034 |
Pattern.eta_matches (#tsig(Sign.rep_sg sign)) (lhs,rhs)); |
0 | 1035 |
|
1036 |
fun mk_rrule (thm as Thm{hyps,sign,prop,maxidx,...}) = |
|
1037 |
let val prems = Logic.strip_imp_prems prop |
|
1038 |
val concl = Pattern.eta_contract (Logic.strip_imp_concl prop) |
|
1039 |
val (lhs,rhs) = Logic.dest_equals concl handle TERM _ => |
|
1040 |
raise SIMPLIFIER("Rewrite rule not a meta-equality",thm) |
|
427
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1041 |
val perm = var_perm(lhs,rhs) andalso not(lhs=rhs orelse is_Var(lhs)) |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1042 |
in if not perm andalso loops sign prems (lhs,rhs) |
0 | 1043 |
then (prtm "Warning: ignoring looping rewrite rule" sign prop; None) |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1044 |
else Some{thm=thm,lhs=lhs,perm=perm} |
0 | 1045 |
end; |
1046 |
||
87 | 1047 |
local |
1048 |
fun eq({thm=Thm{prop=p1,...},...}:rrule, |
|
1049 |
{thm=Thm{prop=p2,...},...}:rrule) = p1 aconv p2 |
|
1050 |
in |
|
1051 |
||
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1052 |
fun add_simp(mss as Mss{net,congs,bounds,prems,mk_rews}, |
0 | 1053 |
thm as Thm{sign,prop,...}) = |
87 | 1054 |
case mk_rrule thm of |
1055 |
None => mss |
|
1056 |
| Some(rrule as {lhs,...}) => |
|
209 | 1057 |
(trace_thm "Adding rewrite rule:" thm; |
1058 |
Mss{net= (Net.insert_term((lhs,rrule),net,eq) |
|
1059 |
handle Net.INSERT => |
|
87 | 1060 |
(prtm "Warning: ignoring duplicate rewrite rule" sign prop; |
1061 |
net)), |
|
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1062 |
congs=congs, bounds=bounds, prems=prems,mk_rews=mk_rews}); |
87 | 1063 |
|
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1064 |
fun del_simp(mss as Mss{net,congs,bounds,prems,mk_rews}, |
87 | 1065 |
thm as Thm{sign,prop,...}) = |
1066 |
case mk_rrule thm of |
|
1067 |
None => mss |
|
1068 |
| Some(rrule as {lhs,...}) => |
|
1069 |
Mss{net= (Net.delete_term((lhs,rrule),net,eq) |
|
1070 |
handle Net.INSERT => |
|
1071 |
(prtm "Warning: rewrite rule not in simpset" sign prop; |
|
1072 |
net)), |
|
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1073 |
congs=congs, bounds=bounds, prems=prems,mk_rews=mk_rews} |
87 | 1074 |
|
1075 |
end; |
|
0 | 1076 |
|
1077 |
val add_simps = foldl add_simp; |
|
87 | 1078 |
val del_simps = foldl del_simp; |
0 | 1079 |
|
1080 |
fun mss_of thms = add_simps(empty_mss,thms); |
|
1081 |
||
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1082 |
fun add_cong(Mss{net,congs,bounds,prems,mk_rews},thm) = |
0 | 1083 |
let val (lhs,_) = Logic.dest_equals(concl_of thm) handle TERM _ => |
1084 |
raise SIMPLIFIER("Congruence not a meta-equality",thm) |
|
1085 |
val lhs = Pattern.eta_contract lhs |
|
1086 |
val (a,_) = dest_Const (head_of lhs) handle TERM _ => |
|
1087 |
raise SIMPLIFIER("Congruence must start with a constant",thm) |
|
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1088 |
in Mss{net=net, congs=(a,{lhs=lhs,thm=thm})::congs, bounds=bounds, |
0 | 1089 |
prems=prems, mk_rews=mk_rews} |
1090 |
end; |
|
1091 |
||
1092 |
val (op add_congs) = foldl add_cong; |
|
1093 |
||
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1094 |
fun add_prems(Mss{net,congs,bounds,prems,mk_rews},thms) = |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1095 |
Mss{net=net, congs=congs, bounds=bounds, prems=thms@prems, mk_rews=mk_rews}; |
0 | 1096 |
|
1097 |
fun prems_of_mss(Mss{prems,...}) = prems; |
|
1098 |
||
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1099 |
fun set_mk_rews(Mss{net,congs,bounds,prems,...},mk_rews) = |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1100 |
Mss{net=net, congs=congs, bounds=bounds, prems=prems, mk_rews=mk_rews}; |
0 | 1101 |
fun mk_rews_of_mss(Mss{mk_rews,...}) = mk_rews; |
1102 |
||
1103 |
||
250 | 1104 |
(*** Meta-level rewriting |
0 | 1105 |
uses conversions, omitting proofs for efficiency. See |
250 | 1106 |
L C Paulson, A higher-order implementation of rewriting, |
1107 |
Science of Computer Programming 3 (1983), pages 119-149. ***) |
|
0 | 1108 |
|
1109 |
type prover = meta_simpset -> thm -> thm option; |
|
1110 |
type termrec = (Sign.sg * term list) * term; |
|
1111 |
type conv = meta_simpset -> termrec -> termrec; |
|
1112 |
||
305
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1113 |
datatype order = LESS | EQUAL | GREATER; |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1114 |
|
305
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1115 |
fun stringord(a,b:string) = if a<b then LESS else |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1116 |
if a=b then EQUAL else GREATER; |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1117 |
|
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1118 |
fun intord(i,j:int) = if i<j then LESS else |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1119 |
if i=j then EQUAL else GREATER; |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1120 |
|
427
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1121 |
(* NB: non-linearity of the ordering is not a soundness problem *) |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1122 |
|
305
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1123 |
(* FIXME: "***ABSTRACTION***" is a hack and makes the ordering non-linear *) |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1124 |
fun string_of_hd(Const(a,_)) = a |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1125 |
| string_of_hd(Free(a,_)) = a |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1126 |
| string_of_hd(Var(v,_)) = Syntax.string_of_vname v |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1127 |
| string_of_hd(Bound i) = string_of_int i |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1128 |
| string_of_hd(Abs _) = "***ABSTRACTION***"; |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1129 |
|
305
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1130 |
(* a strict (not reflexive) linear well-founded AC-compatible ordering |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1131 |
* for terms: |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1132 |
* s < t <=> 1. size(s) < size(t) or |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1133 |
2. size(s) = size(t) and s=f(...) and t = g(...) and f<g or |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1134 |
3. size(s) = size(t) and s=f(s1..sn) and t=f(t1..tn) and |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1135 |
(s1..sn) < (t1..tn) (lexicographically) |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1136 |
*) |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1137 |
|
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1138 |
(* FIXME: should really take types into account as well. |
427
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1139 |
* Otherwise non-linear *) |
305
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1140 |
fun termord(t,u) = |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1141 |
(case intord(size_of_term t,size_of_term u) of |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1142 |
EQUAL => let val (f,ts) = strip_comb t and (g,us) = strip_comb u |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1143 |
in case stringord(string_of_hd f, string_of_hd g) of |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1144 |
EQUAL => lextermord(ts,us) |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1145 |
| ord => ord |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1146 |
end |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1147 |
| ord => ord) |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1148 |
and lextermord(t::ts,u::us) = |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1149 |
(case termord(t,u) of |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1150 |
EQUAL => lextermord(ts,us) |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1151 |
| ord => ord) |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1152 |
| lextermord([],[]) = EQUAL |
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1153 |
| lextermord _ = error("lextermord"); |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1154 |
|
305
4c2bbb5de471
Changed term ordering for permutative rewrites to be AC-compatible.
nipkow
parents:
288
diff
changeset
|
1155 |
fun termless tu = (termord tu = LESS); |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1156 |
|
432 | 1157 |
fun check_conv(thm as Thm{hyps,prop,sign,...}, prop0) = |
1158 |
let fun err() = (trace_thm "Proved wrong thm (Check subgoaler?)" thm; |
|
1159 |
trace_term "Should have proved" sign prop0; |
|
1160 |
None) |
|
0 | 1161 |
val (lhs0,_) = Logic.dest_equals(Logic.strip_imp_concl prop0) |
1162 |
in case prop of |
|
1163 |
Const("==",_) $ lhs $ rhs => |
|
1164 |
if (lhs = lhs0) orelse |
|
427
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1165 |
(lhs aconv Envir.norm_term (Envir.empty 0) lhs0) |
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1166 |
then (trace_thm "SUCCEEDED" thm; Some(hyps,rhs)) |
0 | 1167 |
else err() |
1168 |
| _ => err() |
|
1169 |
end; |
|
1170 |
||
1171 |
(*Conversion to apply the meta simpset to a term*) |
|
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1172 |
fun rewritec (prover,signt) (mss as Mss{net,...}) (hypst,t) = |
225
76f60e6400e8
optimized net for matching of abstractions to speed up simplifier
nipkow
parents:
222
diff
changeset
|
1173 |
let val t = Pattern.eta_contract t; |
288
b00ce6a1fe27
Implemented "ordered rewriting": rules which merely permute variables, such
nipkow
parents:
274
diff
changeset
|
1174 |
fun rew {thm as Thm{sign,hyps,maxidx,prop,...}, lhs, perm} = |
250 | 1175 |
let val unit = if Sign.subsig(sign,signt) then () |
446
3ee5c9314efe
rewritec now uses trace_thm for it's "rewrite rule from different theory"
clasohm
parents:
432
diff
changeset
|
1176 |
else (trace_thm"Warning: rewrite rule from different theory" |
3ee5c9314efe
rewritec now uses trace_thm for it's "rewrite rule from different theory"
clasohm
parents:
432
diff
changeset
|
1177 |
thm; |
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1178 |
raise Pattern.MATCH) |
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1179 |
val insts = Pattern.match (#tsig(Sign.rep_sg signt)) (lhs,t) |
0 | 1180 |
val prop' = subst_vars insts prop; |
1181 |
val hyps' = hyps union hypst; |
|
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1182 |
val thm' = Thm{sign=signt, hyps=hyps', prop=prop', maxidx=maxidx} |
427
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1183 |
val (lhs',rhs') = Logic.dest_equals(Logic.strip_imp_concl prop') |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1184 |
in if perm andalso not(termless(rhs',lhs')) then None else |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1185 |
if Logic.count_prems(prop',0) = 0 |
4ce2ce940faf
ordered rewriting applies to conditional rules as well now
nipkow
parents:
421
diff
changeset
|
1186 |
then (trace_thm "Rewriting:" thm'; Some(hyps',rhs')) |
0 | 1187 |
else (trace_thm "Trying to rewrite:" thm'; |
1188 |
case prover mss thm' of |
|
1189 |
None => (trace_thm "FAILED" thm'; None) |
|
112
009ae5c85ae9
Changed the simplifier: if the subgoaler proves an unexpected thm, chances
nipkow
parents:
87
diff
changeset
|
1190 |
| Some(thm2) => check_conv(thm2,prop')) |
0 | 1191 |
end |
1192 |
||
225
76f60e6400e8
optimized net for matching of abstractions to speed up simplifier
nipkow
parents:
222
diff
changeset
|
1193 |
fun rews [] = None |
76f60e6400e8
optimized net for matching of abstractions to speed up simplifier
nipkow
parents:
222
diff
changeset
|
1194 |
| rews (rrule::rrules) = |
76f60e6400e8
optimized net for matching of abstractions to speed up simplifier
nipkow
parents:
222
diff
changeset
|
1195 |
let val opt = rew rrule handle Pattern.MATCH => None |
76f60e6400e8
optimized net for matching of abstractions to speed up simplifier
nipkow
parents:
222
diff
changeset
|
1196 |
in case opt of None => rews rrules | some => some end; |
0 | 1197 |
|
1198 |
in case t of |
|
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1199 |
Abs(_,_,body) $ u => Some(hypst,subst_bounds([u], body)) |
225
76f60e6400e8
optimized net for matching of abstractions to speed up simplifier
nipkow
parents:
222
diff
changeset
|
1200 |
| _ => rews(Net.match_term net t) |
0 | 1201 |
end; |
1202 |
||
1203 |
(*Conversion to apply a congruence rule to a term*) |
|
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1204 |
fun congc (prover,signt) {thm=cong,lhs=lhs} (hypst,t) = |
0 | 1205 |
let val Thm{sign,hyps,maxidx,prop,...} = cong |
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1206 |
val unit = if Sign.subsig(sign,signt) then () |
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1207 |
else error("Congruence rule from different theory") |
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1208 |
val tsig = #tsig(Sign.rep_sg signt) |
0 | 1209 |
val insts = Pattern.match tsig (lhs,t) handle Pattern.MATCH => |
1210 |
error("Congruence rule did not match") |
|
1211 |
val prop' = subst_vars insts prop; |
|
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1212 |
val thm' = Thm{sign=signt, hyps=hyps union hypst, |
0 | 1213 |
prop=prop', maxidx=maxidx} |
1214 |
val unit = trace_thm "Applying congruence rule" thm'; |
|
112
009ae5c85ae9
Changed the simplifier: if the subgoaler proves an unexpected thm, chances
nipkow
parents:
87
diff
changeset
|
1215 |
fun err() = error("Failed congruence proof!") |
0 | 1216 |
|
1217 |
in case prover thm' of |
|
112
009ae5c85ae9
Changed the simplifier: if the subgoaler proves an unexpected thm, chances
nipkow
parents:
87
diff
changeset
|
1218 |
None => err() |
009ae5c85ae9
Changed the simplifier: if the subgoaler proves an unexpected thm, chances
nipkow
parents:
87
diff
changeset
|
1219 |
| Some(thm2) => (case check_conv(thm2,prop') of |
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1220 |
None => err() | some => some) |
0 | 1221 |
end; |
1222 |
||
1223 |
||
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1224 |
|
214
ed6a3e2b1a33
added new parameter to the simplification tactics which indicates if
nipkow
parents:
209
diff
changeset
|
1225 |
fun bottomc ((simprem,useprem),prover,sign) = |
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1226 |
let fun botc fail mss trec = |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1227 |
(case subc mss trec of |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1228 |
some as Some(trec1) => |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1229 |
(case rewritec (prover,sign) mss trec1 of |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1230 |
Some(trec2) => botc false mss trec2 |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1231 |
| None => some) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1232 |
| None => |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1233 |
(case rewritec (prover,sign) mss trec of |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1234 |
Some(trec2) => botc false mss trec2 |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1235 |
| None => if fail then None else Some(trec))) |
0 | 1236 |
|
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1237 |
and try_botc mss trec = (case botc true mss trec of |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1238 |
Some(trec1) => trec1 |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1239 |
| None => trec) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1240 |
|
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1241 |
and subc (mss as Mss{net,congs,bounds,prems,mk_rews}) |
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1242 |
(trec as (hyps,t)) = |
0 | 1243 |
(case t of |
1244 |
Abs(a,T,t) => |
|
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1245 |
let val b = variant bounds a |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1246 |
val v = Free("." ^ b,T) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1247 |
val mss' = Mss{net=net, congs=congs, bounds=b::bounds, |
0 | 1248 |
prems=prems,mk_rews=mk_rews} |
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1249 |
in case botc true mss' (hyps,subst_bounds([v],t)) of |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1250 |
Some(hyps',t') => |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1251 |
Some(hyps', Abs(a, T, abstract_over(v,t'))) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1252 |
| None => None |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1253 |
end |
0 | 1254 |
| t$u => (case t of |
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1255 |
Const("==>",_)$s => Some(impc(hyps,s,u,mss)) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1256 |
| Abs(_,_,body) => |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1257 |
let val trec = (hyps,subst_bounds([u], body)) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1258 |
in case subc mss trec of |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1259 |
None => Some(trec) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1260 |
| trec => trec |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1261 |
end |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1262 |
| _ => |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1263 |
let fun appc() = |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1264 |
(case botc true mss (hyps,t) of |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1265 |
Some(hyps1,t1) => |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1266 |
(case botc true mss (hyps1,u) of |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1267 |
Some(hyps2,u1) => Some(hyps2,t1$u1) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1268 |
| None => Some(hyps1,t1$u)) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1269 |
| None => |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1270 |
(case botc true mss (hyps,u) of |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1271 |
Some(hyps1,u1) => Some(hyps1,t$u1) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1272 |
| None => None)) |
0 | 1273 |
val (h,ts) = strip_comb t |
1274 |
in case h of |
|
1275 |
Const(a,_) => |
|
1276 |
(case assoc(congs,a) of |
|
1277 |
None => appc() |
|
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1278 |
| Some(cong) => congc (prover mss,sign) cong trec) |
0 | 1279 |
| _ => appc() |
1280 |
end) |
|
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1281 |
| _ => None) |
0 | 1282 |
|
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1283 |
and impc(hyps,s,u,mss as Mss{mk_rews,...}) = |
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1284 |
let val (hyps1,s1) = if simprem then try_botc mss (hyps,s) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1285 |
else (hyps,s) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1286 |
val mss1 = |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1287 |
if not useprem orelse maxidx_of_term s1 <> ~1 then mss |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1288 |
else let val thm = Thm{sign=sign,hyps=[s1],prop=s1,maxidx= ~1} |
214
ed6a3e2b1a33
added new parameter to the simplification tactics which indicates if
nipkow
parents:
209
diff
changeset
|
1289 |
in add_simps(add_prems(mss,[thm]), mk_rews thm) end |
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1290 |
val (hyps2,u1) = try_botc mss1 (hyps1,u) |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1291 |
val hyps3 = if s1 mem hyps1 then hyps2 else hyps2\s1 |
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1292 |
in (hyps3, Logic.mk_implies(s1,u1)) end |
0 | 1293 |
|
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1294 |
in try_botc end; |
0 | 1295 |
|
1296 |
||
1297 |
(*** Meta-rewriting: rewrites t to u and returns the theorem t==u ***) |
|
1298 |
(* Parameters: |
|
250 | 1299 |
mode = (simplify A, use A in simplifying B) when simplifying A ==> B |
0 | 1300 |
mss: contains equality theorems of the form [|p1,...|] ==> t==u |
1301 |
prover: how to solve premises in conditional rewrites and congruences |
|
1302 |
*) |
|
1303 |
||
405
c97514f63633
Internale optimization of the simplifier: in case a subterm stays unchanged,
nipkow
parents:
399
diff
changeset
|
1304 |
(*** FIXME: check that #bounds(mss) does not "occur" in ct alread ***) |
214
ed6a3e2b1a33
added new parameter to the simplification tactics which indicates if
nipkow
parents:
209
diff
changeset
|
1305 |
fun rewrite_cterm mode mss prover ct = |
229
4002c4cd450c
Pure: MAJOR CHANGE. Moved ML types ctyp and cterm and their associated
lcp
parents:
225
diff
changeset
|
1306 |
let val {sign, t, T, maxidx} = rep_cterm ct; |
214
ed6a3e2b1a33
added new parameter to the simplification tactics which indicates if
nipkow
parents:
209
diff
changeset
|
1307 |
val (hyps,u) = bottomc (mode,prover,sign) mss ([],t); |
0 | 1308 |
val prop = Logic.mk_equals(t,u) |
208
342f88d2e8ab
optimized simplifier - signature of rewritten term stays constant
nipkow
parents:
200
diff
changeset
|
1309 |
in Thm{sign= sign, hyps= hyps, maxidx= maxidx_of_term prop, prop= prop} |
0 | 1310 |
end |
1311 |
||
1312 |
end; |
|
250 | 1313 |