221 |
221 |
222 (** store theorems **) (*DESTRUCTIVE*) |
222 (** store theorems **) (*DESTRUCTIVE*) |
223 |
223 |
224 (* naming *) |
224 (* naming *) |
225 |
225 |
226 fun gen_names len name = |
226 fun gen_names j len name = |
227 map (fn i => name ^ ":" ^ string_of_int i) (1 upto len); |
227 map (fn i => name ^ "_" ^ string_of_int i) (j+1 upto j+len); |
228 |
228 |
229 fun name_single name x = [(name, x)]; |
229 fun name_thm name [x] = [Thm.name_thm (name, x)]; |
230 fun name_multi name xs = gen_names (length xs) name ~~ xs; |
230 fun name_multi name xs = gen_names 0 (length xs) name ~~ xs; |
231 |
231 fun name_thms name xs = map Thm.name_thm (name_multi name xs); |
232 |
232 fun name_thmss name = snd o foldl_map (fn (i, (ys, z)) => (i + length ys, |
233 (* enter_thmx *) |
233 (map Thm.name_thm (gen_names i (length ys) name ~~ ys), z))) o pair 0; |
|
234 |
|
235 |
|
236 (* enter_thms *) |
234 |
237 |
235 fun warn_overwrite name = warning ("Replaced old copy of theorems " ^ quote name); |
238 fun warn_overwrite name = warning ("Replaced old copy of theorems " ^ quote name); |
236 fun warn_same name = warning ("Theorem database already contains a copy of " ^ quote name); |
239 fun warn_same name = warning ("Theorem database already contains a copy of " ^ quote name); |
237 |
240 |
238 fun enter_thmx _ _ app_name ("", thmx) = map snd (app_name "" thmx) |
241 fun enter_thms _ _ _ app_att thy ("", thms) = app_att (thy, thms) |
239 | enter_thmx sg name_thm app_name (bname, thmx) = |
242 | enter_thms sg pre_name post_name app_att thy (bname, thms) = |
240 let |
243 let |
241 val name = Sign.full_name sg bname; |
244 val name = Sign.full_name sg bname; |
242 val named_thms = map name_thm (app_name name thmx); |
245 val (thy', thms') = app_att (thy, pre_name name thms); |
|
246 val named_thms = post_name name thms'; |
243 |
247 |
244 val r as ref {space, thms_tab, const_idx} = get_theorems_sg sg; |
248 val r as ref {space, thms_tab, const_idx} = get_theorems_sg sg; |
245 |
249 |
246 val overwrite = |
250 val overwrite = |
247 (case Symtab.lookup (thms_tab, name) of |
251 (case Symtab.lookup (thms_tab, name) of |
253 val space' = NameSpace.extend (space, [name]); |
257 val space' = NameSpace.extend (space, [name]); |
254 val thms_tab' = Symtab.update ((name, named_thms), thms_tab); |
258 val thms_tab' = Symtab.update ((name, named_thms), thms_tab); |
255 val const_idx' = |
259 val const_idx' = |
256 if overwrite then make_const_idx thms_tab' |
260 if overwrite then make_const_idx thms_tab' |
257 else foldl add_const_idx (const_idx, named_thms); |
261 else foldl add_const_idx (const_idx, named_thms); |
258 in r := {space = space', thms_tab = thms_tab', const_idx = const_idx'}; named_thms end; |
262 in r := {space = space', thms_tab = thms_tab', const_idx = const_idx'}; |
|
263 (thy', named_thms) |
|
264 end; |
259 |
265 |
260 |
266 |
261 (* add_thms(s) *) |
267 (* add_thms(s) *) |
262 |
268 |
263 fun add_thmx app_name app_att ((bname, thmx), atts) thy = |
269 fun add_thms' app_name ((bname, thms), atts) thy = |
264 let |
270 enter_thms (Theory.sign_of thy) app_name app_name |
265 val (thy', thmx') = app_att ((thy, thmx), atts); |
271 (Thm.applys_attributes o rpair atts) thy (bname, thms); |
266 val thms'' = enter_thmx (Theory.sign_of thy') Thm.name_thm app_name (bname, thmx'); |
|
267 in (thy', thms'') end; |
|
268 |
272 |
269 fun add_thms args theory = |
273 fun add_thms args theory = |
270 (theory, args) |
274 (theory, args) |
271 |> foldl_map (fn (thy, arg) => add_thmx name_single Thm.apply_attributes arg thy) |
275 |> foldl_map (fn (thy, ((bname, thm), atts)) => add_thms' name_thm |
|
276 ((bname, [thm]), atts) thy) |
272 |> apsnd (map hd); |
277 |> apsnd (map hd); |
273 |
278 |
274 fun add_thmss args theory = |
279 fun add_thmss args theory = |
275 (theory, args) |
280 (theory, args) |
276 |> foldl_map (fn (thy, arg) => add_thmx name_multi Thm.applys_attributes arg thy); |
281 |> foldl_map (fn (thy, arg) => add_thms' name_thms arg thy); |
277 |
282 |
278 |
283 |
279 (* have_thmss *) |
284 (* have_thmss *) |
280 |
285 |
281 local |
286 local |
282 fun have_thss kind_atts (thy, ((bname, more_atts), ths_atts)) = |
287 fun have_thss kind_atts (thy, ((bname, more_atts), ths_atts)) = |
283 let |
288 let |
284 fun app (x, (ths, atts)) = Thm.applys_attributes ((x, ths), atts); |
289 fun app (x, (ths, atts)) = Thm.applys_attributes ((x, ths), atts); |
285 val (thy', thmss') = |
290 val (thy', thms) = enter_thms (Theory.sign_of thy) |
286 foldl_map app (thy, map (fn (ths, atts) => (ths, atts @ more_atts @ kind_atts)) ths_atts); |
291 name_thmss name_thms (apsnd flat o foldl_map app) thy |
287 val thms' = flat thmss'; |
292 (bname, map (fn (ths, atts) => |
288 val thms'' = enter_thmx (Theory.sign_of thy') Thm.name_thm name_multi (bname, thms'); |
293 (ths, atts @ more_atts @ kind_atts)) ths_atts); |
289 in (thy', (bname, thms'')) end; |
294 in (thy', (bname, thms)) end; |
290 in |
295 in |
291 fun have_thmss kind_atts args thy = foldl_map (have_thss kind_atts) (thy, args); |
296 fun have_thmss kind_atts args thy = foldl_map (have_thss kind_atts) (thy, args); |
292 end; |
297 end; |
293 |
298 |
294 |
299 |
295 (* store_thm *) |
300 (* store_thm *) |
296 |
301 |
297 fun store_thm th_atts thy = |
302 fun store_thm ((bname, thm), atts) thy = |
298 let val (thy', [th']) = add_thmx name_single Thm.apply_attributes th_atts thy |
303 let val (thy', [th']) = add_thms' name_thm ((bname, [thm]), atts) thy |
299 in (thy', th') end; |
304 in (thy', th') end; |
300 |
305 |
301 |
306 |
302 (* smart_store_thms *) |
307 (* smart_store_thms *) |
303 |
308 |
304 fun gen_smart_store_thms _ (name, []) = |
309 fun gen_smart_store_thms _ _ (name, []) = |
305 error ("Cannot store empty list of theorems: " ^ quote name) |
310 error ("Cannot store empty list of theorems: " ^ quote name) |
306 | gen_smart_store_thms name_thm (name, [thm]) = |
311 | gen_smart_store_thms name_thm _ (name, [thm]) = |
307 enter_thmx (Thm.sign_of_thm thm) name_thm name_single (name, thm) |
312 snd (enter_thms (Thm.sign_of_thm thm) name_thm name_thm I () (name, [thm])) |
308 | gen_smart_store_thms name_thm (name, thms) = |
313 | gen_smart_store_thms _ name_thm (name, thms) = |
309 let |
314 let |
310 val merge_sg = Sign.merge_refs o apsnd (Sign.self_ref o Thm.sign_of_thm); |
315 val merge_sg = Sign.merge_refs o apsnd (Sign.self_ref o Thm.sign_of_thm); |
311 val sg_ref = foldl merge_sg (Sign.self_ref (Thm.sign_of_thm (hd thms)), tl thms); |
316 val sg_ref = foldl merge_sg (Sign.self_ref (Thm.sign_of_thm (hd thms)), tl thms); |
312 in enter_thmx (Sign.deref sg_ref) name_thm name_multi (name, thms) end; |
317 in snd (enter_thms (Sign.deref sg_ref) name_thm name_thm I () (name, thms)) end; |
313 |
318 |
314 val smart_store_thms = gen_smart_store_thms Thm.name_thm; |
319 val smart_store_thms = gen_smart_store_thms name_thm name_thms; |
315 val open_smart_store_thms = gen_smart_store_thms snd; |
320 val open_smart_store_thms = gen_smart_store_thms (K I) (K I); |
316 |
321 |
317 |
322 |
318 (* forall_elim_vars (belongs to drule.ML) *) |
323 (* forall_elim_vars (belongs to drule.ML) *) |
319 |
324 |
320 (*Replace outermost quantified variable by Var of given index. |
325 (*Replace outermost quantified variable by Var of given index. |
339 fun get_axs thy named_axs = |
344 fun get_axs thy named_axs = |
340 map (forall_elim_vars 0 o Thm.get_axiom thy o fst) named_axs; |
345 map (forall_elim_vars 0 o Thm.get_axiom thy o fst) named_axs; |
341 |
346 |
342 fun add_single add (thy, ((name, ax), atts)) = |
347 fun add_single add (thy, ((name, ax), atts)) = |
343 let |
348 let |
344 val named_ax = name_single name ax; |
349 val named_ax = [(name, ax)]; |
345 val thy' = add named_ax thy; |
350 val thy' = add named_ax thy; |
346 val thm = hd (get_axs thy' named_ax); |
351 val thm = hd (get_axs thy' named_ax); |
347 in apsnd hd (add_thms [((name, thm), atts)] thy') end; |
352 in apsnd hd (add_thms [((name, thm), atts)] thy') end; |
348 |
353 |
349 fun add_multi add (thy, ((name, axs), atts)) = |
354 fun add_multi add (thy, ((name, axs), atts)) = |