| author | krauss |
| Tue, 07 Nov 2006 12:20:11 +0100 | |
| changeset 21212 | 547224bf9348 |
| parent 21104 | b6ab939147eb |
| child 21319 | cf814e36f788 |
| 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 |
|
| 21104 | 31 |
rtac (Drule.cterm_instantiate [(R', rel')] rule') 1 (* instantiate termination rule *) |
| 20873 | 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! *) |
|
| 21104 | 45 |
in Method.SIMPLE_METHOD (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 |
| 21104 | 48 |
[("auto_term", termination_meth, "proves termination using a user-specified wellfounded relation")]
|
|
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 |