225 (* naming *) |
225 (* naming *) |
226 |
226 |
227 fun gen_names j len name = |
227 fun gen_names j len name = |
228 map (fn i => name ^ "_" ^ string_of_int i) (j+1 upto j+len); |
228 map (fn i => name ^ "_" ^ string_of_int i) (j+1 upto j+len); |
229 |
229 |
230 fun name_thm name [x] = [Thm.name_thm (name, x)]; |
|
231 fun name_multi name xs = gen_names 0 (length xs) name ~~ xs; |
230 fun name_multi name xs = gen_names 0 (length xs) name ~~ xs; |
232 fun name_thms name xs = map Thm.name_thm (name_multi name xs); |
231 |
233 fun name_thmss name = snd o foldl_map (fn (i, (ys, z)) => (i + length ys, |
232 fun name_thms name [x] = [Thm.name_thm (name, x)] |
234 (map Thm.name_thm (gen_names i (length ys) name ~~ ys), z))) o pair 0; |
233 | name_thms name xs = map Thm.name_thm (name_multi name xs); |
|
234 |
|
235 fun name_thmss name xs = (case filter_out (null o fst) xs of |
|
236 [([x], z)] => [([Thm.name_thm (name, x)], z)] |
|
237 | _ => snd (foldl_map (fn (i, (ys, z)) => (i + length ys, |
|
238 (map Thm.name_thm (gen_names i (length ys) name ~~ ys), z))) (0, xs))); |
235 |
239 |
236 |
240 |
237 (* enter_thms *) |
241 (* enter_thms *) |
238 |
242 |
239 fun warn_overwrite name = warning ("Replaced old copy of theorems " ^ quote name); |
243 fun warn_overwrite name = warning ("Replaced old copy of theorems " ^ quote name); |
265 end; |
269 end; |
266 |
270 |
267 |
271 |
268 (* add_thms(s) *) |
272 (* add_thms(s) *) |
269 |
273 |
270 fun add_thms' app_name ((bname, thms), atts) thy = |
274 fun add_thms_atts pre_name ((bname, thms), atts) thy = |
271 enter_thms (Theory.sign_of thy) app_name app_name |
275 enter_thms (Theory.sign_of thy) pre_name name_thms |
272 (Thm.applys_attributes o rpair atts) thy (bname, thms); |
276 (Thm.applys_attributes o rpair atts) thy (bname, thms); |
273 |
277 |
274 fun add_thms args theory = |
278 fun gen_add_thmss pre_name args theory = |
275 (theory, args) |
279 foldl_map (fn (thy, arg) => add_thms_atts pre_name arg thy) (theory, args); |
276 |> foldl_map (fn (thy, ((bname, thm), atts)) => add_thms' name_thm |
280 |
277 ((bname, [thm]), atts) thy) |
281 fun gen_add_thms pre_name args = |
278 |> apsnd (map hd); |
282 apsnd (map hd) o gen_add_thmss pre_name (map (apfst (apsnd single)) args); |
279 |
283 |
280 fun add_thmss args theory = |
284 val add_thmss = gen_add_thmss name_thms; |
281 (theory, args) |
285 val add_thms = gen_add_thms name_thms; |
282 |> foldl_map (fn (thy, arg) => add_thms' name_thms arg thy); |
|
283 |
286 |
284 |
287 |
285 (* have_thmss *) |
288 (* have_thmss *) |
286 |
289 |
287 local |
290 local |
299 |
302 |
300 |
303 |
301 (* store_thm *) |
304 (* store_thm *) |
302 |
305 |
303 fun store_thm ((bname, thm), atts) thy = |
306 fun store_thm ((bname, thm), atts) thy = |
304 let val (thy', [th']) = add_thms' name_thm ((bname, [thm]), atts) thy |
307 let val (thy', [th']) = add_thms_atts name_thms ((bname, [thm]), atts) thy |
305 in (thy', th') end; |
308 in (thy', th') end; |
306 |
309 |
307 |
310 |
308 (* smart_store_thms *) |
311 (* smart_store_thms *) |
309 |
312 |
310 fun gen_smart_store_thms _ _ (name, []) = |
313 fun gen_smart_store_thms _ (name, []) = |
311 error ("Cannot store empty list of theorems: " ^ quote name) |
314 error ("Cannot store empty list of theorems: " ^ quote name) |
312 | gen_smart_store_thms name_thm _ (name, [thm]) = |
315 | gen_smart_store_thms name_thm (name, [thm]) = |
313 snd (enter_thms (Thm.sign_of_thm thm) name_thm name_thm I () (name, [thm])) |
316 snd (enter_thms (Thm.sign_of_thm thm) name_thm name_thm I () (name, [thm])) |
314 | gen_smart_store_thms _ name_thm (name, thms) = |
317 | gen_smart_store_thms name_thm (name, thms) = |
315 let |
318 let |
316 val merge_sg = Sign.merge_refs o apsnd (Sign.self_ref o Thm.sign_of_thm); |
319 val merge_sg = Sign.merge_refs o apsnd (Sign.self_ref o Thm.sign_of_thm); |
317 val sg_ref = foldl merge_sg (Sign.self_ref (Thm.sign_of_thm (hd thms)), tl thms); |
320 val sg_ref = foldl merge_sg (Sign.self_ref (Thm.sign_of_thm (hd thms)), tl thms); |
318 in snd (enter_thms (Sign.deref sg_ref) name_thm name_thm I () (name, thms)) end; |
321 in snd (enter_thms (Sign.deref sg_ref) name_thm name_thm I () (name, thms)) end; |
319 |
322 |
320 val smart_store_thms = gen_smart_store_thms name_thm name_thms; |
323 val smart_store_thms = gen_smart_store_thms name_thms; |
321 val smart_store_thms_open = gen_smart_store_thms (K I) (K I); |
324 val smart_store_thms_open = gen_smart_store_thms (K I); |
322 |
325 |
323 |
326 |
324 (* forall_elim_vars (belongs to drule.ML) *) |
327 (* forall_elim_vars (belongs to drule.ML) *) |
325 |
328 |
326 (*Replace outermost quantified variable by Var of given index. |
329 (*Replace outermost quantified variable by Var of given index. |
348 fun add_single add (thy, ((name, ax), atts)) = |
351 fun add_single add (thy, ((name, ax), atts)) = |
349 let |
352 let |
350 val named_ax = [(name, ax)]; |
353 val named_ax = [(name, ax)]; |
351 val thy' = add named_ax thy; |
354 val thy' = add named_ax thy; |
352 val thm = hd (get_axs thy' named_ax); |
355 val thm = hd (get_axs thy' named_ax); |
353 in apsnd hd (add_thms [((name, thm), atts)] thy') end; |
356 in apsnd hd (gen_add_thms (K I) [((name, thm), atts)] thy') end; |
354 |
357 |
355 fun add_multi add (thy, ((name, axs), atts)) = |
358 fun add_multi add (thy, ((name, axs), atts)) = |
356 let |
359 let |
357 val named_axs = name_multi name axs; |
360 val named_axs = name_multi name axs; |
358 val thy' = add named_axs thy; |
361 val thy' = add named_axs thy; |
359 val thms = get_axs thy' named_axs; |
362 val thms = get_axs thy' named_axs; |
360 in apsnd hd (add_thmss [((name, thms), atts)] thy') end; |
363 in apsnd hd (gen_add_thmss (K I) [((name, thms), atts)] thy') end; |
361 |
364 |
362 fun add_singles add args thy = foldl_map (add_single add) (thy, args); |
365 fun add_singles add args thy = foldl_map (add_single add) (thy, args); |
363 fun add_multis add args thy = foldl_map (add_multi add) (thy, args); |
366 fun add_multis add args thy = foldl_map (add_multi add) (thy, args); |
364 in |
367 in |
365 val add_axioms = add_singles Theory.add_axioms; |
368 val add_axioms = add_singles Theory.add_axioms; |