src/HOL/Decision_Procs/cooper_tac.ML
author paulson <lp15@cam.ac.uk>
Tue Nov 17 12:32:08 2015 +0000 (2015-11-17)
changeset 61694 6571c78c9667
parent 60754 02924903a6fd
child 62348 9a5f43dac883
permissions -rw-r--r--
Removed some legacy theorems; minor adjustments to simplification rules; new material on homotopic paths
hoelzl@30439
     1
(*  Title:      HOL/Decision_Procs/cooper_tac.ML
haftmann@29788
     2
    Author:     Amine Chaieb, TU Muenchen
haftmann@29788
     3
*)
haftmann@29788
     4
wenzelm@31240
     5
signature COOPER_TAC =
wenzelm@31240
     6
sig
wenzelm@31240
     7
  val linz_tac: Proof.context -> bool -> int -> tactic
wenzelm@31240
     8
end
wenzelm@31240
     9
wenzelm@31240
    10
structure Cooper_Tac: COOPER_TAC =
chaieb@23274
    11
struct
chaieb@23274
    12
wenzelm@51717
    13
val cooper_ss = simpset_of @{context};
chaieb@23274
    14
wenzelm@31240
    15
fun prepare_for_linz q fm =
chaieb@23274
    16
  let
chaieb@23274
    17
    val ps = Logic.strip_params fm
chaieb@23274
    18
    val hs = map HOLogic.dest_Trueprop (Logic.strip_assums_hyp fm)
chaieb@23274
    19
    val c = HOLogic.dest_Trueprop (Logic.strip_assums_concl fm)
chaieb@23274
    20
    fun mk_all ((s, T), (P,n)) =
wenzelm@42083
    21
      if Term.is_dependent P then
chaieb@23274
    22
        (HOLogic.all_const T $ Abs (s, T, P), n)
chaieb@23274
    23
      else (incr_boundvars ~1 P, n-1)
chaieb@23274
    24
    fun mk_all2 (v, t) = HOLogic.all_const (fastype_of v) $ lambda v t;
haftmann@27651
    25
    val rhs = hs
chaieb@23274
    26
    val np = length ps
wenzelm@33004
    27
    val (fm',np) = List.foldr (fn ((x, T), (fm,n)) => mk_all ((x, T), (fm,n)))
wenzelm@33004
    28
      (List.foldr HOLogic.mk_imp c rhs, np) ps
wenzelm@55987
    29
    val (vs, _) = List.partition (fn t => q orelse (type_of t) = @{typ nat})
wenzelm@44121
    30
      (Misc_Legacy.term_frees fm' @ Misc_Legacy.term_vars fm');
wenzelm@33004
    31
    val fm2 = List.foldr mk_all2 fm' vs
chaieb@23274
    32
  in (fm2, np + length vs, length rhs) end;
chaieb@23274
    33
chaieb@23274
    34
(*Object quantifier to meta --*)
wenzelm@55987
    35
fun spec_step n th = if n = 0 then th else (spec_step (n - 1) th) RS spec;
chaieb@23274
    36
chaieb@23274
    37
(* object implication to meta---*)
wenzelm@55987
    38
fun mp_step n th = if n = 0 then th else (mp_step (n - 1) th) RS mp;
chaieb@23274
    39
chaieb@23274
    40
wenzelm@54742
    41
fun linz_tac ctxt q = Object_Logic.atomize_prems_tac ctxt THEN' SUBGOAL (fn (g, i) =>
chaieb@23274
    42
  let
chaieb@23274
    43
    (* Transform the term*)
wenzelm@55987
    44
    val (t, np, nh) = prepare_for_linz q g;
chaieb@23274
    45
    (* Some simpsets for dealing with mod div abs and nat*)
wenzelm@51717
    46
    val mod_div_simpset =
wenzelm@51717
    47
      put_simpset HOL_basic_ss ctxt
wenzelm@55987
    48
      addsimps @{thms refl mod_add_eq [symmetric] mod_add_left_eq [symmetric]
wenzelm@55987
    49
          mod_add_right_eq [symmetric]
wenzelm@55987
    50
          div_add1_eq [symmetric] zdiv_zadd1_eq [symmetric]
wenzelm@55987
    51
          mod_self
wenzelm@55987
    52
          div_by_0 mod_by_0 div_0 mod_0
wenzelm@55987
    53
          div_by_1 mod_by_1 div_1 mod_1
wenzelm@55987
    54
          Suc_eq_plus1}
haftmann@57514
    55
      addsimps @{thms ac_simps}
wenzelm@43594
    56
      addsimprocs [@{simproc cancel_div_mod_nat}, @{simproc cancel_div_mod_int}]
wenzelm@51717
    57
    val simpset0 =
wenzelm@51717
    58
      put_simpset HOL_basic_ss ctxt
wenzelm@55987
    59
      addsimps @{thms mod_div_equality' Suc_eq_plus1 simp_thms}
wenzelm@55987
    60
      |> fold Splitter.add_split @{thms split_zdiv split_zmod split_div' split_min split_max}
chaieb@23274
    61
    (* Simp rules for changing (n::int) to int n *)
wenzelm@51717
    62
    val simpset1 =
wenzelm@51717
    63
      put_simpset HOL_basic_ss ctxt
lp15@61694
    64
      addsimps @{thms zdvd_int} @ [@{thm "of_nat_add"}, @{thm "of_nat_mult"}] @
lp15@61694
    65
        map (fn r => r RS sym) @{thms int_numeral int_int_eq zle_int zless_int}
wenzelm@55987
    66
      |> Splitter.add_split @{thm zdiff_int_split}
chaieb@23274
    67
    (*simp rules for elimination of int n*)
chaieb@23274
    68
wenzelm@51717
    69
    val simpset2 =
wenzelm@51717
    70
      put_simpset HOL_basic_ss ctxt
huffman@47108
    71
      addsimps [@{thm nat_0_le}, @{thm all_nat}, @{thm ex_nat}, @{thm zero_le_numeral}, @{thm order_refl}(* FIXME: necessary? *), @{thm int_0}, @{thm int_1}]
wenzelm@55987
    72
      |> fold Simplifier.add_cong @{thms conj_le_cong imp_le_cong}
chaieb@23274
    73
    (* simp rules for elimination of abs *)
wenzelm@51717
    74
    val simpset3 = put_simpset HOL_basic_ss ctxt |> Splitter.add_split @{thm abs_split}
wenzelm@59629
    75
    val ct = Thm.cterm_of ctxt (HOLogic.mk_Trueprop t)
chaieb@23274
    76
    (* Theorem for the nat --> int transformation *)
chaieb@23274
    77
    val pre_thm = Seq.hd (EVERY
chaieb@23274
    78
      [simp_tac mod_div_simpset 1, simp_tac simpset0 1,
chaieb@23274
    79
       TRY (simp_tac simpset1 1), TRY (simp_tac simpset2 1),
wenzelm@51717
    80
       TRY (simp_tac simpset3 1), TRY (simp_tac (put_simpset cooper_ss ctxt) 1)]
wenzelm@36945
    81
      (Thm.trivial ct))
wenzelm@58963
    82
    fun assm_tac i = REPEAT_DETERM_N nh (assume_tac ctxt i)
chaieb@23274
    83
    (* The result of the quantifier elimination *)
wenzelm@55987
    84
    val (th, tac) =
wenzelm@59582
    85
      (case Thm.prop_of pre_thm of
wenzelm@56245
    86
        Const (@{const_name Pure.imp}, _) $ (Const (@{const_name Trueprop}, _) $ t1) $ _ =>
wenzelm@55987
    87
          let
wenzelm@60325
    88
            val pth = linzqe_oracle (ctxt, Envir.eta_long [] t1)
wenzelm@55987
    89
          in
wenzelm@55987
    90
            ((pth RS iffD2) RS pre_thm,
wenzelm@60754
    91
              assm_tac (i + 1) THEN (if q then I else TRY) (resolve_tac ctxt [TrueI] i))
wenzelm@55987
    92
          end
wenzelm@55987
    93
      | _ => (pre_thm, assm_tac i))
wenzelm@60754
    94
  in resolve_tac ctxt [mp_step nh (spec_step np th)] i THEN tac end);
chaieb@23274
    95
wenzelm@23590
    96
end