src/Tools/induction.ML
author wenzelm
Mon Apr 06 13:28:54 2015 +0200 (2015-04-06)
changeset 59931 5ec4f97dd6d4
parent 59582 0fbed69ff081
child 59940 087d81f5213e
permissions -rw-r--r--
proper header;
misc tuning;
wenzelm@59931
     1
(*  Title:      Tools/induction.ML
wenzelm@59931
     2
    Author:     Tobias Nipkow, TU Muenchen
wenzelm@59931
     3
wenzelm@59931
     4
Alternative proof method "induction" that gives induction hypotheses the
wenzelm@59931
     5
name "IH".
wenzelm@59931
     6
*)
wenzelm@59931
     7
nipkow@45014
     8
signature INDUCTION =
nipkow@45014
     9
sig
wenzelm@59931
    10
  val induction_tac: Proof.context -> bool ->
wenzelm@59931
    11
    (binding option * (term * bool)) option list list ->
nipkow@45014
    12
    (string * typ) list list -> term option list -> thm list option ->
nipkow@45014
    13
    thm list -> int -> cases_tactic
nipkow@45014
    14
end
nipkow@45014
    15
nipkow@45014
    16
structure Induction: INDUCTION =
nipkow@45014
    17
struct
nipkow@45014
    18
nipkow@45014
    19
val ind_hypsN = "IH";
nipkow@45014
    20
nipkow@45014
    21
fun preds_of t =
wenzelm@59931
    22
  (case strip_comb t of
nipkow@45014
    23
    (p as Var _, _) => [p]
nipkow@45014
    24
  | (p as Free _, _) => [p]
wenzelm@59931
    25
  | (_, ts) => maps preds_of ts);
nipkow@45014
    26
wenzelm@56506
    27
fun name_hyps (arg as ((cases, consumes), th)) =
wenzelm@59931
    28
  if not (forall (null o #2 o #1) cases) then arg
nipkow@45014
    29
  else
nipkow@45014
    30
    let
wenzelm@59582
    31
      val (prems, concl) = Logic.strip_horn (Thm.prop_of th);
nipkow@45014
    32
      val prems' = drop consumes prems;
nipkow@45014
    33
      val ps = preds_of concl;
nipkow@45014
    34
nipkow@45014
    35
      fun hname_of t =
wenzelm@59931
    36
        if exists_subterm (member (op aconv) ps) t
wenzelm@59931
    37
        then ind_hypsN else Rule_Cases.case_hypsN;
nipkow@45014
    38
wenzelm@59931
    39
      val hnamess = map (map hname_of o Logic.strip_assums_hyp) prems';
wenzelm@59931
    40
      val n = Int.min (length hnamess, length cases);
wenzelm@59931
    41
      val cases' =
wenzelm@59931
    42
        map (fn (((cn, _), concls), hns) => ((cn, hns), concls))
wenzelm@59931
    43
          (take n cases ~~ take n hnamess);
wenzelm@59931
    44
    in ((cases', consumes), th) end;
nipkow@45014
    45
wenzelm@59931
    46
val induction_tac = Induct.gen_induct_tac (K name_hyps);
nipkow@45014
    47
wenzelm@59931
    48
val _ = Theory.setup (Induct.gen_induct_setup @{binding induction} induction_tac);
nipkow@45014
    49
nipkow@45014
    50
end