author | wenzelm |
Sat, 07 Oct 2006 01:31:01 +0200 | |
changeset 20873 | 4066ee15b278 |
parent 20295 | 8b3e97502fd9 |
child 21104 | b6ab939147eb |
permissions | -rw-r--r-- |
19564
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
1 |
(* Title: HOL/Tools/function_package/auto_term.ML |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
2 |
ID: $Id$ |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
3 |
Author: Alexander Krauss, TU Muenchen |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
4 |
|
20873 | 5 |
A package for general recursive function definitions. |
19564
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
6 |
The auto_term method. |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
7 |
*) |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
8 |
|
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
9 |
|
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
10 |
signature FUNDEF_AUTO_TERM = |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
11 |
sig |
20873 | 12 |
val setup: theory -> theory |
19564
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
13 |
end |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
14 |
|
20873 | 15 |
structure FundefAutoTerm : FUNDEF_AUTO_TERM = |
19564
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
16 |
struct |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
17 |
|
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
18 |
open FundefCommon |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
19 |
open FundefAbbrev |
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
20 |
|
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
21 |
|
20873 | 22 |
fun auto_term_tac ctxt rule rel wf_rules ss = |
23 |
let |
|
24 |
val cert = Thm.cterm_of (ProofContext.theory_of ctxt) |
|
19564
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
25 |
|
20873 | 26 |
val rel' = cert (singleton (Variable.polymorphic ctxt) rel) |
27 |
val rule' = rule |> Thm.incr_indexes (#maxidx (Thm.rep_cterm rel') + 1) |
|
28 |
val prem = #1 (Logic.dest_implies (Thm.prop_of rule')) |
|
29 |
val R' = cert (Var (the_single (Term.add_vars prem []))) |
|
30 |
in |
|
31 |
resolve_tac [Drule.cterm_instantiate [(R', rel')] rule'] 1 (* produce the usual goals *) |
|
32 |
THEN (ALLGOALS |
|
33 |
(fn 1 => REPEAT (ares_tac wf_rules 1) (* Solve wellfoundedness *) |
|
34 |
| i => asm_simp_tac ss i)) (* Simplify termination conditions *) |
|
35 |
end |
|
19564
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
36 |
|
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
37 |
|
20873 | 38 |
fun termination_meth src = Method.syntax Args.term src #> (fn (ctxt, rel) => |
39 |
let |
|
40 |
val {simps, congs, wfs} = RecdefPackage.get_hints (Context.Proof ctxt) |
|
41 |
val ss = local_simpset_of ctxt addsimps simps |
|
42 |
||
43 |
val intro_rule = ProofContext.get_thm ctxt (Name "termination") |
|
44 |
(* FIXME avoid internal name lookup -- dynamic scoping! *) |
|
45 |
in Method.RAW_METHOD (K (auto_term_tac ctxt intro_rule rel wfs ss)) end) |
|
19564
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
46 |
|
20295 | 47 |
val setup = Method.add_methods |
20873 | 48 |
[("auto_term", termination_meth, "termination prover for recdef compatibility")] |
19564
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
49 |
|
d3e2f532459a
First usable version of the new function definition package (HOL/function_packake/...).
krauss
parents:
diff
changeset
|
50 |
end |