src/HOL/Tools/function_package/auto_term.ML
author krauss
Tue, 07 Nov 2006 12:20:11 +0100
changeset 21212 547224bf9348
parent 21104 b6ab939147eb
child 21319 cf814e36f788
permissions -rw-r--r--
Added a (stub of a) function tutorial
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
     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
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    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
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    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
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    22
fun auto_term_tac ctxt rule rel wf_rules ss =
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    23
  let
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    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
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    26
    val rel' = cert (singleton (Variable.polymorphic ctxt) rel)
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    27
    val rule' = rule |> Thm.incr_indexes (#maxidx (Thm.rep_cterm rel') + 1)
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    28
    val prem = #1 (Logic.dest_implies (Thm.prop_of rule'))
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    29
    val R' = cert (Var (the_single (Term.add_vars prem [])))
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    30
  in
21104
b6ab939147eb removed free "x" from termination goal...
krauss
parents: 20873
diff changeset
    31
    rtac (Drule.cterm_instantiate [(R', rel')] rule') 1  (* instantiate termination rule *)
20873
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    32
    THEN (ALLGOALS
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    33
      (fn 1 => REPEAT (ares_tac wf_rules 1)    (* Solve wellfoundedness *)
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    34
        | i => asm_simp_tac ss i))             (* Simplify termination conditions *)
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    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
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    38
fun termination_meth src = Method.syntax Args.term src #> (fn (ctxt, rel) =>
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    39
  let
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    40
    val {simps, congs, wfs} = RecdefPackage.get_hints (Context.Proof ctxt)
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    41
    val ss = local_simpset_of ctxt addsimps simps
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    42
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    43
    val intro_rule = ProofContext.get_thm ctxt (Name "termination")
4066ee15b278 tuned method syntax: polymorhic term argument;
wenzelm
parents: 20295
diff changeset
    44
    (* FIXME avoid internal name lookup -- dynamic scoping! *)
21104
b6ab939147eb removed free "x" from termination goal...
krauss
parents: 20873
diff changeset
    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
8b3e97502fd9 use proper RecdefPackage.get_hints;
wenzelm
parents: 19770
diff changeset
    47
val setup = Method.add_methods
21104
b6ab939147eb removed free "x" from termination goal...
krauss
parents: 20873
diff changeset
    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