18 (* FIXME: LocalTheory.note should return theorems with proper names! *) |
18 (* FIXME: LocalTheory.note should return theorems with proper names! *) |
19 fun name_of_thm thm = |
19 fun name_of_thm thm = |
20 (case Symtab.dest (Proofterm.thms_of_proof' (proof_of thm) Symtab.empty) of |
20 (case Symtab.dest (Proofterm.thms_of_proof' (proof_of thm) Symtab.empty) of |
21 [(name, _)] => name |
21 [(name, _)] => name |
22 | _ => error ("name_of_thm: bad proof of theorem\n" ^ string_of_thm thm)); |
22 | _ => error ("name_of_thm: bad proof of theorem\n" ^ string_of_thm thm)); |
23 |
|
24 (* infer order of variables in intro rules from order of quantifiers in elim rule *) |
|
25 fun infer_intro_vars elim arity intros = |
|
26 let |
|
27 val thy = theory_of_thm elim; |
|
28 val _ :: cases = prems_of elim; |
|
29 val used = map (fst o fst) (Term.add_vars (prop_of elim) []); |
|
30 fun mtch (t, u) = |
|
31 let |
|
32 val params = Logic.strip_params t; |
|
33 val vars = map (Var o apfst (rpair 0)) |
|
34 (Name.variant_list used (map fst params) ~~ map snd params); |
|
35 val ts = map (curry subst_bounds (rev vars)) |
|
36 (List.drop (Logic.strip_assums_hyp t, arity)); |
|
37 val us = Logic.strip_imp_prems u; |
|
38 val tab = fold (Pattern.first_order_match thy) (ts ~~ us) |
|
39 (Vartab.empty, Vartab.empty); |
|
40 in |
|
41 map (Envir.subst_vars tab) vars |
|
42 end |
|
43 in |
|
44 map (mtch o apsnd prop_of) (cases ~~ intros) |
|
45 end; |
|
46 |
|
47 (* read off arities of inductive predicates from raw induction rule *) |
|
48 fun arities_of induct = |
|
49 map (fn (_ $ t $ u) => |
|
50 (fst (dest_Const (head_of t)), length (snd (strip_comb u)))) |
|
51 (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct))); |
|
52 |
|
53 (* read off parameters of inductive predicate from raw induction rule *) |
|
54 fun params_of induct = |
|
55 let |
|
56 val (_ $ t $ u :: _) = |
|
57 HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)); |
|
58 val (_, ts) = strip_comb t; |
|
59 val (_, us) = strip_comb u |
|
60 in |
|
61 List.take (ts, length ts - length us) |
|
62 end; |
|
63 |
23 |
64 val all_simps = map (symmetric o mk_meta_eq) (thms "HOL.all_simps"); |
24 val all_simps = map (symmetric o mk_meta_eq) (thms "HOL.all_simps"); |
65 |
25 |
66 fun prf_of thm = |
26 fun prf_of thm = |
67 let val {thy, prop, der = (_, prf), ...} = rep_thm thm |
27 let val {thy, prop, der = (_, prf), ...} = rep_thm thm |
309 foldr (uncurry lambda) rt vs1, |
269 foldr (uncurry lambda) rt vs1, |
310 ProofRewriteRules.un_hhf_proof rlz' rlz'' |
270 ProofRewriteRules.un_hhf_proof rlz' rlz'' |
311 (foldr forall_intr_prf (prf_of rrule) (vs2 @ rs)))) |
271 (foldr forall_intr_prf (prf_of rrule) (vs2 @ rs)))) |
312 end; |
272 end; |
313 |
273 |
314 fun partition_rules induct intrs = |
|
315 let |
|
316 fun name_of t = fst (dest_Const (head_of t)); |
|
317 val ts = HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)); |
|
318 val sets = map (name_of o fst o HOLogic.dest_imp) ts; |
|
319 in |
|
320 map (fn s => (s, filter |
|
321 (equal s o name_of o HOLogic.dest_Trueprop o concl_of) intrs)) sets |
|
322 end; |
|
323 |
|
324 fun add_ind_realizer rsets intrs induct raw_induct elims (thy, vs) = |
274 fun add_ind_realizer rsets intrs induct raw_induct elims (thy, vs) = |
325 let |
275 let |
326 val qualifier = NameSpace.qualifier (name_of_thm induct); |
276 val qualifier = NameSpace.qualifier (name_of_thm induct); |
327 val inducts = PureThy.get_thms thy (Name |
277 val inducts = PureThy.get_thms thy (Name |
328 (NameSpace.qualified qualifier "inducts")); |
278 (NameSpace.qualified qualifier "inducts")); |
329 val iTs = term_tvars (prop_of (hd intrs)); |
279 val iTs = term_tvars (prop_of (hd intrs)); |
330 val ar = length vs + length iTs; |
280 val ar = length vs + length iTs; |
331 val params = params_of raw_induct; |
281 val params = InductivePackage.params_of raw_induct; |
332 val arities = arities_of raw_induct; |
282 val arities = InductivePackage.arities_of raw_induct; |
333 val nparms = length params; |
283 val nparms = length params; |
334 val params' = map dest_Var params; |
284 val params' = map dest_Var params; |
335 val rss = partition_rules raw_induct intrs; |
285 val rss = InductivePackage.partition_rules raw_induct intrs; |
336 val rss' = map (fn (((s, rs), (_, arity)), elim) => |
286 val rss' = map (fn (((s, rs), (_, arity)), elim) => |
337 (s, (infer_intro_vars elim arity rs ~~ rs))) (rss ~~ arities ~~ elims); |
287 (s, (InductivePackage.infer_intro_vars elim arity rs ~~ rs))) |
|
288 (rss ~~ arities ~~ elims); |
338 val (prfx, _) = split_last (NameSpace.explode (fst (hd rss))); |
289 val (prfx, _) = split_last (NameSpace.explode (fst (hd rss))); |
339 val tnames = map (fn s => space_implode "_" (s ^ "T" :: vs)) rsets; |
290 val tnames = map (fn s => space_implode "_" (s ^ "T" :: vs)) rsets; |
340 |
291 |
341 val thy1 = thy |> |
292 val thy1 = thy |> |
342 Theory.root_path |> |
293 Theory.root_path |> |