src/HOL/Tools/Function/relation.ML
author haftmann
Tue, 08 Jun 2010 16:37:19 +0200
changeset 37387 3581483cca6c
parent 36636 7dded80a953f
child 40057 b237f757b215
permissions -rw-r--r--
qualified types "+" and nat; qualified constants Ball, Bex, Suc, curry; modernized some specifications
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
33100
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
     1
(*  Title:      HOL/Tools/Function/relation.ML
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
     2
    Author:     Alexander Krauss, TU Muenchen
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
     3
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
     4
A package for general recursive function definitions.
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
     5
Method "relation" to commence a termination proof using a user-specified relation.
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
     6
*)
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
     7
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
     8
signature FUNCTION_RELATION =
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
     9
sig
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    10
  val relation_tac: Proof.context -> term -> int -> tactic
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    11
  val setup: theory -> theory
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    12
end
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    13
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    14
structure Function_Relation : FUNCTION_RELATION =
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    15
struct
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    16
36636
7dded80a953f avoid exception Empty on malformed goal
krauss
parents: 34232
diff changeset
    17
fun inst_state_tac ctxt rel st =
34232
36a2a3029fd3 new year's resolution: reindented code in function package
krauss
parents: 33100
diff changeset
    18
  let
36a2a3029fd3 new year's resolution: reindented code in function package
krauss
parents: 33100
diff changeset
    19
    val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
36a2a3029fd3 new year's resolution: reindented code in function package
krauss
parents: 33100
diff changeset
    20
    val rel' = cert (singleton (Variable.polymorphic ctxt) rel)
36a2a3029fd3 new year's resolution: reindented code in function package
krauss
parents: 33100
diff changeset
    21
    val st' = Thm.incr_indexes (#maxidx (Thm.rep_cterm rel') + 1) st
36636
7dded80a953f avoid exception Empty on malformed goal
krauss
parents: 34232
diff changeset
    22
  in case Term.add_vars (prop_of st') [] of
7dded80a953f avoid exception Empty on malformed goal
krauss
parents: 34232
diff changeset
    23
       [v] => 
7dded80a953f avoid exception Empty on malformed goal
krauss
parents: 34232
diff changeset
    24
         PRIMITIVE (Drule.cterm_instantiate [(cert (Var v), rel')]) st'
7dded80a953f avoid exception Empty on malformed goal
krauss
parents: 34232
diff changeset
    25
     | _ => Seq.empty
34232
36a2a3029fd3 new year's resolution: reindented code in function package
krauss
parents: 33100
diff changeset
    26
  end
33100
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    27
34232
36a2a3029fd3 new year's resolution: reindented code in function package
krauss
parents: 33100
diff changeset
    28
fun relation_tac ctxt rel i =
36a2a3029fd3 new year's resolution: reindented code in function package
krauss
parents: 33100
diff changeset
    29
  TRY (Function_Common.apply_termination_rule ctxt i)
36636
7dded80a953f avoid exception Empty on malformed goal
krauss
parents: 34232
diff changeset
    30
  THEN inst_state_tac ctxt rel
33100
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    31
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    32
val setup =
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    33
  Method.setup @{binding relation}
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    34
    (Args.term >> (fn rel => fn ctxt => SIMPLE_METHOD' (relation_tac ctxt rel)))
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    35
    "proves termination using a user-specified wellfounded relation"
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    36
acc2bd3934ba renamed auto_term.ML -> relation.ML
krauss
parents:
diff changeset
    37
end