src/Provers/Arith/fast_lin_arith.ML
author wenzelm
Sun Feb 18 15:05:21 2018 +0100 (18 months ago)
changeset 67649 1e1782c1aedf
parent 66035 de6cd60b1226
permissions -rw-r--r--
tuned signature;
nipkow@5982
     1
(*  Title:      Provers/Arith/fast_lin_arith.ML
boehmes@31510
     2
    Author:     Tobias Nipkow and Tjark Weber and Sascha Boehme
nipkow@6102
     3
wenzelm@46709
     4
A generic linear arithmetic package.
nipkow@6102
     5
wenzelm@24076
     6
Only take premises and conclusions into account that are already
wenzelm@24076
     7
(negated) (in)equations. lin_arith_simproc tries to prove or disprove
wenzelm@24076
     8
the term.
nipkow@5982
     9
*)
nipkow@5982
    10
nipkow@5982
    11
(*** Data needed for setting up the linear arithmetic package ***)
nipkow@5982
    12
nipkow@6102
    13
signature LIN_ARITH_LOGIC =
nipkow@6102
    14
sig
webertj@20276
    15
  val conjI       : thm  (* P ==> Q ==> P & Q *)
webertj@20276
    16
  val ccontr      : thm  (* (~ P ==> False) ==> P *)
webertj@20276
    17
  val notI        : thm  (* (P ==> False) ==> ~ P *)
webertj@20276
    18
  val not_lessD   : thm  (* ~(m < n) ==> n <= m *)
webertj@20276
    19
  val not_leD     : thm  (* ~(m <= n) ==> n < m *)
webertj@20276
    20
  val sym         : thm  (* x = y ==> y = x *)
boehmes@31510
    21
  val trueI       : thm  (* True *)
webertj@20276
    22
  val mk_Eq       : thm -> thm
webertj@20276
    23
  val atomize     : thm -> thm list
webertj@20276
    24
  val mk_Trueprop : term -> term
webertj@20276
    25
  val neg_prop    : term -> term
webertj@20276
    26
  val is_False    : thm -> bool
webertj@20276
    27
  val is_nat      : typ list * term -> bool
webertj@20276
    28
  val mk_nat_thm  : theory -> term -> thm
nipkow@6102
    29
end;
nipkow@6102
    30
(*
nipkow@6102
    31
mk_Eq(~in) = `in == False'
nipkow@6102
    32
mk_Eq(in) = `in == True'
nipkow@6102
    33
where `in' is an (in)equality.
nipkow@6102
    34
webertj@23190
    35
neg_prop(t) = neg  if t is wrapped up in Trueprop and neg is the
webertj@23190
    36
  (logically) negated version of t (again wrapped up in Trueprop),
webertj@23190
    37
  where the negation of a negative term is the term itself (no
webertj@23190
    38
  double negation!); raises TERM ("neg_prop", [t]) if t is not of
webertj@23190
    39
  the form 'Trueprop $ _'
nipkow@6128
    40
nipkow@6128
    41
is_nat(parameter-types,t) =  t:nat
nipkow@6128
    42
mk_nat_thm(t) = "0 <= t"
nipkow@6102
    43
*)
nipkow@6102
    44
nipkow@5982
    45
signature LIN_ARITH_DATA =
nipkow@5982
    46
sig
wenzelm@24076
    47
  (*internal representation of linear (in-)equations:*)
wenzelm@26945
    48
  type decomp = (term * Rat.rat) list * Rat.rat * string * (term * Rat.rat) list * Rat.rat * bool
wenzelm@26945
    49
  val decomp: Proof.context -> term -> decomp option
wenzelm@24076
    50
  val domain_is_nat: term -> bool
wenzelm@24076
    51
boehmes@66035
    52
  (*abstraction for proof replay*)
boehmes@66035
    53
  val abstract_arith: term -> (term * term) list * Proof.context ->
boehmes@66035
    54
    term * ((term * term) list * Proof.context)
boehmes@66035
    55
  val abstract: term -> (term * term) list * Proof.context ->
boehmes@66035
    56
    term * ((term * term) list * Proof.context)
boehmes@66035
    57
wenzelm@24076
    58
  (*preprocessing, performed on a representation of subgoals as list of premises:*)
wenzelm@24076
    59
  val pre_decomp: Proof.context -> typ list * term list -> (typ list * term list) list
wenzelm@24076
    60
wenzelm@24076
    61
  (*preprocessing, performed on the goal -- must do the same as 'pre_decomp':*)
wenzelm@51717
    62
  val pre_tac: Proof.context -> int -> tactic
wenzelm@24076
    63
wenzelm@24076
    64
  (*the limit on the number of ~= allowed; because each ~= is split
wenzelm@24076
    65
    into two cases, this can lead to an explosion*)
wenzelm@44654
    66
  val neq_limit: int Config.T
boehmes@43607
    67
wenzelm@44654
    68
  val trace: bool Config.T
nipkow@5982
    69
end;
nipkow@5982
    70
(*
nipkow@7551
    71
decomp(`x Rel y') should yield (p,i,Rel,q,j,d)
nipkow@5982
    72
   where Rel is one of "<", "~<", "<=", "~<=" and "=" and
webertj@20217
    73
         p (q, respectively) is the decomposition of the sum term x
webertj@20217
    74
         (y, respectively) into a list of summand * multiplicity
webertj@20217
    75
         pairs and a constant summand and d indicates if the domain
webertj@20217
    76
         is discrete.
webertj@20217
    77
webertj@20276
    78
domain_is_nat(`x Rel y') t should yield true iff x is of type "nat".
webertj@20276
    79
webertj@20217
    80
The relationship between pre_decomp and pre_tac is somewhat tricky.  The
webertj@20217
    81
internal representation of a subgoal and the corresponding theorem must
webertj@20217
    82
be modified by pre_decomp (pre_tac, resp.) in a corresponding way.  See
webertj@20217
    83
the comment for split_items below.  (This is even necessary for eta- and
webertj@20217
    84
beta-equivalent modifications, as some of the lin. arith. code is not
webertj@20217
    85
insensitive to them.)
nipkow@5982
    86
wenzelm@51717
    87
Simpset must reduce contradictory <= to False.
nipkow@5982
    88
   It should also cancel common summands to keep <= reduced;
nipkow@5982
    89
   otherwise <= can grow to massive proportions.
nipkow@5982
    90
*)
nipkow@5982
    91
nipkow@6062
    92
signature FAST_LIN_ARITH =
nipkow@6062
    93
sig
wenzelm@51717
    94
  val prems_lin_arith_tac: Proof.context -> int -> tactic
wenzelm@59656
    95
  val lin_arith_tac: Proof.context -> int -> tactic
wenzelm@61144
    96
  val lin_arith_simproc: Proof.context -> cterm -> thm option
wenzelm@38763
    97
  val map_data:
wenzelm@38763
    98
    ({add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list,
wenzelm@51717
    99
      lessD: thm list, neqE: thm list, simpset: simpset,
wenzelm@59996
   100
      number_of: (Proof.context -> typ -> int -> cterm) option} ->
wenzelm@38763
   101
     {add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list,
wenzelm@51717
   102
      lessD: thm list, neqE: thm list, simpset: simpset,
wenzelm@59996
   103
      number_of: (Proof.context -> typ -> int -> cterm) option}) ->
wenzelm@38763
   104
      Context.generic -> Context.generic
wenzelm@38762
   105
  val add_inj_thms: thm list -> Context.generic -> Context.generic
wenzelm@38762
   106
  val add_lessD: thm -> Context.generic -> Context.generic
wenzelm@38762
   107
  val add_simps: thm list -> Context.generic -> Context.generic
wenzelm@38762
   108
  val add_simprocs: simproc list -> Context.generic -> Context.generic
wenzelm@59996
   109
  val set_number_of: (Proof.context -> typ -> int -> cterm) -> Context.generic -> Context.generic
nipkow@6062
   110
end;
nipkow@6062
   111
wenzelm@24076
   112
functor Fast_Lin_Arith
wenzelm@24076
   113
  (structure LA_Logic: LIN_ARITH_LOGIC and LA_Data: LIN_ARITH_DATA): FAST_LIN_ARITH =
nipkow@5982
   114
struct
nipkow@5982
   115
wenzelm@9420
   116
wenzelm@9420
   117
(** theory data **)
wenzelm@9420
   118
wenzelm@33519
   119
structure Data = Generic_Data
wenzelm@22846
   120
(
wenzelm@24076
   121
  type T =
wenzelm@24076
   122
   {add_mono_thms: thm list,
wenzelm@24076
   123
    mult_mono_thms: thm list,
wenzelm@24076
   124
    inj_thms: thm list,
wenzelm@24076
   125
    lessD: thm list,
wenzelm@24076
   126
    neqE: thm list,
wenzelm@51717
   127
    simpset: simpset,
wenzelm@59996
   128
    number_of: (Proof.context -> typ -> int -> cterm) option};
wenzelm@9420
   129
wenzelm@38763
   130
  val empty : T =
wenzelm@38763
   131
   {add_mono_thms = [], mult_mono_thms = [], inj_thms = [],
wenzelm@51717
   132
    lessD = [], neqE = [], simpset = empty_ss,
wenzelm@38763
   133
    number_of = NONE};
wenzelm@16458
   134
  val extend = I;
wenzelm@33519
   135
  fun merge
wenzelm@38763
   136
    ({add_mono_thms = add_mono_thms1, mult_mono_thms = mult_mono_thms1, inj_thms = inj_thms1,
wenzelm@38763
   137
      lessD = lessD1, neqE = neqE1, simpset = simpset1, number_of = number_of1},
wenzelm@38763
   138
     {add_mono_thms = add_mono_thms2, mult_mono_thms = mult_mono_thms2, inj_thms = inj_thms2,
wenzelm@38763
   139
      lessD = lessD2, neqE = neqE2, simpset = simpset2, number_of = number_of2}) : T =
wenzelm@24039
   140
    {add_mono_thms = Thm.merge_thms (add_mono_thms1, add_mono_thms2),
wenzelm@24039
   141
     mult_mono_thms = Thm.merge_thms (mult_mono_thms1, mult_mono_thms2),
wenzelm@24039
   142
     inj_thms = Thm.merge_thms (inj_thms1, inj_thms2),
wenzelm@24039
   143
     lessD = Thm.merge_thms (lessD1, lessD2),
wenzelm@24039
   144
     neqE = Thm.merge_thms (neqE1, neqE2),
wenzelm@51717
   145
     simpset = merge_ss (simpset1, simpset2),
wenzelm@41493
   146
     number_of = merge_options (number_of1, number_of2)};
wenzelm@22846
   147
);
wenzelm@9420
   148
wenzelm@9420
   149
val map_data = Data.map;
wenzelm@24076
   150
val get_data = Data.get o Context.Proof;
wenzelm@9420
   151
wenzelm@67649
   152
fun get_neqE ctxt = map (Thm.transfer' ctxt) (#neqE (get_data ctxt));
wenzelm@61097
   153
wenzelm@38762
   154
fun map_inj_thms f {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset, number_of} =
wenzelm@38762
   155
  {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = f inj_thms,
wenzelm@38762
   156
    lessD = lessD, neqE = neqE, simpset = simpset, number_of = number_of};
wenzelm@38762
   157
wenzelm@38762
   158
fun map_lessD f {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset, number_of} =
wenzelm@38762
   159
  {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = inj_thms,
wenzelm@38762
   160
    lessD = f lessD, neqE = neqE, simpset = simpset, number_of = number_of};
wenzelm@38762
   161
wenzelm@51717
   162
fun map_simpset f context =
wenzelm@51717
   163
  map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset, number_of} =>
wenzelm@51717
   164
    {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = inj_thms,
wenzelm@51717
   165
      lessD = lessD, neqE = neqE, simpset = simpset_map (Context.proof_of context) f simpset,
wenzelm@51717
   166
      number_of = number_of}) context;
wenzelm@38762
   167
wenzelm@61097
   168
fun add_inj_thms thms = map_data (map_inj_thms (append (map Thm.trim_context thms)));
wenzelm@61097
   169
fun add_lessD thm = map_data (map_lessD (fn thms => thms @ [Thm.trim_context thm]));
wenzelm@51717
   170
fun add_simps thms = map_simpset (fn ctxt => ctxt addsimps thms);
wenzelm@51717
   171
fun add_simprocs procs = map_simpset (fn ctxt => ctxt addsimprocs procs);
wenzelm@38762
   172
wenzelm@38763
   173
fun set_number_of f =
wenzelm@38763
   174
  map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset, ...} =>
wenzelm@38763
   175
   {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = inj_thms,
wenzelm@38763
   176
    lessD = lessD, neqE = neqE, simpset = simpset, number_of = SOME f});
wenzelm@38763
   177
wenzelm@38763
   178
fun number_of ctxt =
wenzelm@61097
   179
  (case get_data ctxt of
wenzelm@59996
   180
    {number_of = SOME f, ...} => f ctxt
wenzelm@38763
   181
  | _ => fn _ => fn _ => raise CTERM ("number_of", []));
wenzelm@38763
   182
wenzelm@9420
   183
wenzelm@9420
   184
nipkow@5982
   185
(*** A fast decision procedure ***)
nipkow@5982
   186
(*** Code ported from HOL Light ***)
nipkow@6056
   187
(* possible optimizations:
nipkow@6056
   188
   use (var,coeff) rep or vector rep  tp save space;
nipkow@6056
   189
   treat non-negative atoms separately rather than adding 0 <= atom
nipkow@6056
   190
*)
nipkow@5982
   191
nipkow@5982
   192
datatype lineq_type = Eq | Le | Lt;
nipkow@5982
   193
nipkow@6056
   194
datatype injust = Asm of int
nipkow@6056
   195
                | Nat of int (* index of atom *)
nipkow@6128
   196
                | LessD of injust
nipkow@6128
   197
                | NotLessD of injust
nipkow@6128
   198
                | NotLeD of injust
nipkow@7551
   199
                | NotLeDD of injust
wenzelm@24630
   200
                | Multiplied of int * injust
nipkow@5982
   201
                | Added of injust * injust;
nipkow@5982
   202
wenzelm@24630
   203
datatype lineq = Lineq of int * lineq_type * int list * injust;
nipkow@5982
   204
nipkow@13498
   205
(* ------------------------------------------------------------------------- *)
nipkow@13498
   206
(* Finding a (counter) example from the trace of a failed elimination        *)
nipkow@13498
   207
(* ------------------------------------------------------------------------- *)
nipkow@13498
   208
(* Examples are represented as rational numbers,                             *)
nipkow@13498
   209
(* Dont blame John Harrison for this code - it is entirely mine. TN          *)
nipkow@13498
   210
nipkow@13498
   211
exception NoEx;
nipkow@13498
   212
nipkow@14372
   213
(* Coding: (i,true,cs) means i <= cs and (i,false,cs) means i < cs.
nipkow@14372
   214
   In general, true means the bound is included, false means it is excluded.
nipkow@14372
   215
   Need to know if it is a lower or upper bound for unambiguous interpretation!
nipkow@14372
   216
*)
nipkow@14372
   217
nipkow@13498
   218
(* ------------------------------------------------------------------------- *)
webertj@23197
   219
(* End of counterexample finder. The actual decision procedure starts here.  *)
nipkow@13498
   220
(* ------------------------------------------------------------------------- *)
nipkow@13498
   221
nipkow@5982
   222
(* ------------------------------------------------------------------------- *)
nipkow@5982
   223
(* Calculate new (in)equality type after addition.                           *)
nipkow@5982
   224
(* ------------------------------------------------------------------------- *)
nipkow@5982
   225
nipkow@5982
   226
fun find_add_type(Eq,x) = x
nipkow@5982
   227
  | find_add_type(x,Eq) = x
nipkow@5982
   228
  | find_add_type(_,Lt) = Lt
nipkow@5982
   229
  | find_add_type(Lt,_) = Lt
nipkow@5982
   230
  | find_add_type(Le,Le) = Le;
nipkow@5982
   231
nipkow@5982
   232
(* ------------------------------------------------------------------------- *)
nipkow@5982
   233
(* Multiply out an (in)equation.                                             *)
nipkow@5982
   234
(* ------------------------------------------------------------------------- *)
nipkow@5982
   235
nipkow@5982
   236
fun multiply_ineq n (i as Lineq(k,ty,l,just)) =
nipkow@5982
   237
  if n = 1 then i
wenzelm@40316
   238
  else if n = 0 andalso ty = Lt then raise Fail "multiply_ineq"
wenzelm@40316
   239
  else if n < 0 andalso (ty=Le orelse ty=Lt) then raise Fail "multiply_ineq"
wenzelm@33002
   240
  else Lineq (n * k, ty, map (Integer.mult n) l, Multiplied (n, just));
nipkow@5982
   241
nipkow@5982
   242
(* ------------------------------------------------------------------------- *)
nipkow@5982
   243
(* Add together (in)equations.                                               *)
nipkow@5982
   244
(* ------------------------------------------------------------------------- *)
nipkow@5982
   245
haftmann@38052
   246
fun add_ineq (Lineq (k1,ty1,l1,just1)) (Lineq (k2,ty2,l2,just2)) =
wenzelm@33002
   247
  let val l = map2 Integer.add l1 l2
nipkow@5982
   248
  in Lineq(k1+k2,find_add_type(ty1,ty2),l,Added(just1,just2)) end;
nipkow@5982
   249
nipkow@5982
   250
(* ------------------------------------------------------------------------- *)
nipkow@5982
   251
(* Elimination of variable between a single pair of (in)equations.           *)
nipkow@5982
   252
(* If they're both inequalities, 1st coefficient must be +ve, 2nd -ve.       *)
nipkow@5982
   253
(* ------------------------------------------------------------------------- *)
nipkow@5982
   254
haftmann@49387
   255
fun elim_var v (i1 as Lineq(_,ty1,l1,_)) (i2 as Lineq(_,ty2,l2,_)) =
haftmann@23063
   256
  let val c1 = nth l1 v and c2 = nth l2 v
wenzelm@63227
   257
      val m = Integer.lcm c1 c2
nipkow@5982
   258
      val m1 = m div (abs c1) and m2 = m div (abs c2)
nipkow@5982
   259
      val (n1,n2) =
nipkow@5982
   260
        if (c1 >= 0) = (c2 >= 0)
nipkow@5982
   261
        then if ty1 = Eq then (~m1,m2)
nipkow@5982
   262
             else if ty2 = Eq then (m1,~m2)
wenzelm@40316
   263
                  else raise Fail "elim_var"
nipkow@5982
   264
        else (m1,m2)
nipkow@5982
   265
      val (p1,p2) = if ty1=Eq andalso ty2=Eq andalso (n1 = ~1 orelse n2 = ~1)
nipkow@5982
   266
                    then (~n1,~n2) else (n1,n2)
boehmes@31510
   267
  in add_ineq (multiply_ineq p1 i1) (multiply_ineq p2 i2) end;
nipkow@5982
   268
nipkow@5982
   269
(* ------------------------------------------------------------------------- *)
nipkow@5982
   270
(* The main refutation-finding code.                                         *)
nipkow@5982
   271
(* ------------------------------------------------------------------------- *)
nipkow@5982
   272
nipkow@5982
   273
fun is_trivial (Lineq(_,_,l,_)) = forall (fn i => i=0) l;
nipkow@5982
   274
haftmann@38052
   275
fun is_contradictory (Lineq(k,ty,_,_)) =
nipkow@5982
   276
  case ty  of Eq => k <> 0 | Le => k > 0 | Lt => k >= 0;
nipkow@5982
   277
wenzelm@24630
   278
fun calc_blowup l =
wenzelm@33317
   279
  let val (p,n) = List.partition (curry (op <) 0) (filter (curry (op <>) 0) l)
wenzelm@24630
   280
  in length p * length n end;
nipkow@5982
   281
nipkow@5982
   282
(* ------------------------------------------------------------------------- *)
nipkow@5982
   283
(* Main elimination code:                                                    *)
nipkow@5982
   284
(*                                                                           *)
nipkow@5982
   285
(* (1) Looks for immediate solutions (false assertions with no variables).   *)
nipkow@5982
   286
(*                                                                           *)
nipkow@5982
   287
(* (2) If there are any equations, picks a variable with the lowest absolute *)
nipkow@5982
   288
(* coefficient in any of them, and uses it to eliminate.                     *)
nipkow@5982
   289
(*                                                                           *)
nipkow@5982
   290
(* (3) Otherwise, chooses a variable in the inequality to minimize the       *)
nipkow@5982
   291
(* blowup (number of consequences generated) and eliminates it.              *)
nipkow@5982
   292
(* ------------------------------------------------------------------------- *)
nipkow@5982
   293
nipkow@5982
   294
fun extract_first p =
boehmes@31510
   295
  let
boehmes@31510
   296
    fun extract xs (y::ys) = if p y then (y, xs @ ys) else extract (y::xs) ys
boehmes@66035
   297
      | extract _ [] = raise List.Empty
nipkow@5982
   298
  in extract [] end;
nipkow@5982
   299
wenzelm@44654
   300
fun print_ineqs ctxt ineqs =
wenzelm@44654
   301
  if Config.get ctxt LA_Data.trace then
wenzelm@12262
   302
     tracing(cat_lines(""::map (fn Lineq(c,t,l,_) =>
wenzelm@24630
   303
       string_of_int c ^
paulson@9073
   304
       (case t of Eq => " =  " | Lt=> " <  " | Le => " <= ") ^
wenzelm@24630
   305
       commas(map string_of_int l)) ineqs))
paulson@9073
   306
  else ();
nipkow@6056
   307
nipkow@13498
   308
type history = (int * lineq list) list;
nipkow@13498
   309
datatype result = Success of injust | Failure of history;
nipkow@13498
   310
wenzelm@44654
   311
fun elim ctxt (ineqs, hist) =
wenzelm@44654
   312
  let val _ = print_ineqs ctxt ineqs
webertj@20217
   313
      val (triv, nontriv) = List.partition is_trivial ineqs in
webertj@20217
   314
  if not (null triv)
wenzelm@59584
   315
  then case find_first is_contradictory triv of
wenzelm@44654
   316
         NONE => elim ctxt (nontriv, hist)
skalberg@15531
   317
       | SOME(Lineq(_,_,_,j)) => Success j
nipkow@5982
   318
  else
webertj@20217
   319
  if null nontriv then Failure hist
nipkow@13498
   320
  else
webertj@20217
   321
  let val (eqs, noneqs) = List.partition (fn (Lineq(_,ty,_,_)) => ty=Eq) nontriv in
webertj@20217
   322
  if not (null eqs) then
boehmes@31510
   323
     let val c =
haftmann@33042
   324
           fold (fn Lineq(_,_,l,_) => fn cs => union (op =) l cs) eqs []
boehmes@31510
   325
           |> filter (fn i => i <> 0)
wenzelm@59058
   326
           |> sort (int_ord o apply2 abs)
boehmes@31510
   327
           |> hd
boehmes@31510
   328
         val (eq as Lineq(_,_,ceq,_),othereqs) =
haftmann@36692
   329
               extract_first (fn Lineq(_,_,l,_) => member (op =) l c) eqs
haftmann@31986
   330
         val v = find_index (fn v => v = c) ceq
haftmann@23063
   331
         val (ioth,roth) = List.partition (fn (Lineq(_,_,l,_)) => nth l v = 0)
nipkow@5982
   332
                                     (othereqs @ noneqs)
nipkow@5982
   333
         val others = map (elim_var v eq) roth @ ioth
wenzelm@44654
   334
     in elim ctxt (others,(v,nontriv)::hist) end
nipkow@5982
   335
  else
nipkow@5982
   336
  let val lists = map (fn (Lineq(_,_,l,_)) => l) noneqs
haftmann@23063
   337
      val numlist = 0 upto (length (hd lists) - 1)
haftmann@23063
   338
      val coeffs = map (fn i => map (fn xs => nth xs i) lists) numlist
nipkow@5982
   339
      val blows = map calc_blowup coeffs
nipkow@5982
   340
      val iblows = blows ~~ numlist
haftmann@23063
   341
      val nziblows = filter_out (fn (i, _) => i = 0) iblows
nipkow@13498
   342
  in if null nziblows then Failure((~1,nontriv)::hist)
nipkow@13498
   343
     else
haftmann@60348
   344
     let val (_,v) = hd(sort (fn (x,y) => int_ord(fst(x),fst(y))) nziblows)
haftmann@23063
   345
         val (no,yes) = List.partition (fn (Lineq(_,_,l,_)) => nth l v = 0) ineqs
haftmann@23063
   346
         val (pos,neg) = List.partition(fn (Lineq(_,_,l,_)) => nth l v > 0) yes
wenzelm@44654
   347
     in elim ctxt (no @ map_product (elim_var v) pos neg, (v,nontriv)::hist) end
nipkow@5982
   348
  end
nipkow@5982
   349
  end
nipkow@5982
   350
  end;
nipkow@5982
   351
nipkow@5982
   352
(* ------------------------------------------------------------------------- *)
nipkow@5982
   353
(* Translate back a proof.                                                   *)
nipkow@5982
   354
(* ------------------------------------------------------------------------- *)
nipkow@5982
   355
wenzelm@44654
   356
fun trace_thm ctxt msgs th =
wenzelm@44654
   357
 (if Config.get ctxt LA_Data.trace
wenzelm@61268
   358
  then tracing (cat_lines (msgs @ [Thm.string_of_thm ctxt th]))
wenzelm@44654
   359
  else (); th);
paulson@9073
   360
wenzelm@44654
   361
fun trace_term ctxt msgs t =
wenzelm@44654
   362
 (if Config.get ctxt LA_Data.trace
wenzelm@44654
   363
  then tracing (cat_lines (msgs @ [Syntax.string_of_term ctxt t]))
wenzelm@44654
   364
  else (); t);
wenzelm@24076
   365
wenzelm@44654
   366
fun trace_msg ctxt msg =
wenzelm@44654
   367
  if Config.get ctxt LA_Data.trace then tracing msg else ();
paulson@9073
   368
wenzelm@52131
   369
val union_term = union Envir.aeconv;
berghofe@26835
   370
boehmes@31510
   371
fun add_atoms (lhs, _, _, rhs, _, _) =
boehmes@31510
   372
  union_term (map fst lhs) o union_term (map fst rhs);
nipkow@6056
   373
boehmes@31510
   374
fun atoms_of ds = fold add_atoms ds [];
boehmes@31510
   375
boehmes@31510
   376
(*
nipkow@6056
   377
Simplification may detect a contradiction 'prematurely' due to type
nipkow@6056
   378
information: n+1 <= 0 is simplified to False and does not need to be crossed
nipkow@6056
   379
with 0 <= n.
nipkow@6056
   380
*)
nipkow@6056
   381
local
boehmes@66035
   382
  exception FalseE of thm * (int * cterm) list * Proof.context
nipkow@6056
   383
in
wenzelm@27020
   384
wenzelm@51717
   385
fun mkthm ctxt asms (just: injust) =
wenzelm@24076
   386
  let
wenzelm@42361
   387
    val thy = Proof_Context.theory_of ctxt;
wenzelm@61097
   388
    val {add_mono_thms = add_mono_thms0, mult_mono_thms = mult_mono_thms0,
wenzelm@61097
   389
      inj_thms = inj_thms0, lessD = lessD0, simpset, ...} = get_data ctxt;
wenzelm@61097
   390
    val add_mono_thms = map (Thm.transfer thy) add_mono_thms0;
wenzelm@61097
   391
    val mult_mono_thms = map (Thm.transfer thy) mult_mono_thms0;
wenzelm@61097
   392
    val inj_thms = map (Thm.transfer thy) inj_thms0;
wenzelm@61097
   393
    val lessD = map (Thm.transfer thy) lessD0;
wenzelm@61097
   394
wenzelm@38763
   395
    val number_of = number_of ctxt;
wenzelm@51717
   396
    val simpset_ctxt = put_simpset simpset ctxt;
boehmes@31510
   397
    fun only_concl f thm =
boehmes@31510
   398
      if Thm.no_prems thm then f (Thm.concl_of thm) else NONE;
boehmes@31510
   399
    val atoms = atoms_of (map_filter (only_concl (LA_Data.decomp ctxt)) asms);
boehmes@31510
   400
boehmes@31510
   401
    fun use_first rules thm =
boehmes@31510
   402
      get_first (fn th => SOME (thm RS th) handle THM _ => NONE) rules
boehmes@31510
   403
boehmes@31510
   404
    fun add2 thm1 thm2 =
boehmes@31510
   405
      use_first add_mono_thms (thm1 RS (thm2 RS LA_Logic.conjI));
boehmes@31510
   406
    fun try_add thms thm = get_first (fn th => add2 th thm) thms;
nipkow@6056
   407
boehmes@31510
   408
    fun add_thms thm1 thm2 =
boehmes@31510
   409
      (case add2 thm1 thm2 of
boehmes@31510
   410
        NONE =>
boehmes@31510
   411
          (case try_add ([thm1] RL inj_thms) thm2 of
boehmes@31510
   412
            NONE =>
boehmes@31510
   413
              (the (try_add ([thm2] RL inj_thms) thm1)
wenzelm@51930
   414
                handle Option.Option =>
wenzelm@44654
   415
                  (trace_thm ctxt [] thm1; trace_thm ctxt [] thm2;
wenzelm@40316
   416
                   raise Fail "Linear arithmetic: failed to add thms"))
boehmes@31510
   417
          | SOME thm => thm)
boehmes@31510
   418
      | SOME thm => thm);
boehmes@31510
   419
boehmes@31510
   420
    fun mult_by_add n thm =
boehmes@31510
   421
      let fun mul i th = if i = 1 then th else mul (i - 1) (add_thms thm th)
boehmes@31510
   422
      in mul n thm end;
nipkow@10575
   423
wenzelm@51717
   424
    val rewr = Simplifier.rewrite simpset_ctxt;
boehmes@31510
   425
    val rewrite_concl = Conv.fconv_rule (Conv.concl_conv ~1 (Conv.arg_conv
boehmes@31510
   426
      (Conv.binop_conv rewr)));
boehmes@31510
   427
    fun discharge_prem thm = if Thm.nprems_of thm = 0 then thm else
boehmes@31510
   428
      let val cv = Conv.arg1_conv (Conv.arg_conv rewr)
boehmes@31510
   429
      in Thm.implies_elim (Conv.fconv_rule cv thm) LA_Logic.trueI end
webertj@20217
   430
boehmes@31510
   431
    fun mult n thm =
boehmes@31510
   432
      (case use_first mult_mono_thms thm of
boehmes@31510
   433
        NONE => mult_by_add n thm
boehmes@31510
   434
      | SOME mth =>
boehmes@31510
   435
          let
boehmes@31510
   436
            val cv = mth |> Thm.cprop_of |> Drule.strip_imp_concl
boehmes@31510
   437
              |> Thm.dest_arg |> Thm.dest_arg1 |> Thm.dest_arg1
wenzelm@59586
   438
            val T = Thm.typ_of_cterm cv
boehmes@31510
   439
          in
boehmes@31510
   440
            mth
wenzelm@60642
   441
            |> Thm.instantiate ([], [(dest_Var (Thm.term_of cv), number_of T n)])
boehmes@31510
   442
            |> rewrite_concl
boehmes@31510
   443
            |> discharge_prem
boehmes@31510
   444
            handle CTERM _ => mult_by_add n thm
boehmes@31510
   445
                 | THM _ => mult_by_add n thm
boehmes@31510
   446
          end);
nipkow@10691
   447
boehmes@66035
   448
    fun mult_thm n thm =
boehmes@31510
   449
      if n = ~1 then thm RS LA_Logic.sym
boehmes@31510
   450
      else if n < 0 then mult (~n) thm RS LA_Logic.sym
boehmes@31510
   451
      else mult n thm;
boehmes@31510
   452
boehmes@66035
   453
    fun simp thm (cx as (_, hyps, ctxt')) =
wenzelm@51717
   454
      let val thm' = trace_thm ctxt ["Simplified:"] (full_simplify simpset_ctxt thm)
boehmes@66035
   455
      in if LA_Logic.is_False thm' then raise FalseE (thm', hyps, ctxt') else (thm', cx) end;
boehmes@66035
   456
boehmes@66035
   457
    fun abs_thm i (cx as (terms, hyps, ctxt)) =
boehmes@66035
   458
      (case AList.lookup (op =) hyps i of
boehmes@66035
   459
        SOME ct => (Thm.assume ct, cx)
boehmes@66035
   460
      | NONE =>
boehmes@66035
   461
          let
boehmes@66035
   462
            val thm = nth asms i
boehmes@66035
   463
            val (t, (terms', ctxt')) = LA_Data.abstract (Thm.prop_of thm) (terms, ctxt)
boehmes@66035
   464
            val ct = Thm.cterm_of ctxt' t
boehmes@66035
   465
          in (Thm.assume ct, (terms', (i, ct) :: hyps, ctxt')) end);
boehmes@66035
   466
boehmes@66035
   467
    fun nat_thm t (terms, hyps, ctxt) =
boehmes@66035
   468
      let val (t', (terms', ctxt')) = LA_Data.abstract_arith t (terms, ctxt)
boehmes@66035
   469
      in (LA_Logic.mk_nat_thm thy t', (terms', hyps, ctxt')) end;
nipkow@6056
   470
boehmes@66035
   471
    fun step0 msg (thm, cx) = (trace_thm ctxt [msg] thm, cx)
boehmes@66035
   472
    fun step1 msg j f cx = mk j cx |>> f |>> trace_thm ctxt [msg]
boehmes@66035
   473
    and step2 msg j1 j2 f cx = mk j1 cx ||>> mk j2 |>> f |>> trace_thm ctxt [msg]
nipkow@5982
   474
boehmes@66035
   475
    and mk (Asm i) cx = step0 ("Asm " ^ string_of_int i) (abs_thm i cx)
boehmes@66035
   476
      | mk (Nat i) cx = step0 ("Nat " ^ string_of_int i) (nat_thm (nth atoms i) cx)
boehmes@66035
   477
      | mk (LessD j) cx = step1 "L" j (fn thm => hd ([thm] RL lessD)) cx
boehmes@66035
   478
      | mk (NotLeD j) cx = step1 "NLe" j (fn thm => thm RS LA_Logic.not_leD) cx
boehmes@66035
   479
      | mk (NotLeDD j) cx = step1 "NLeD" j (fn thm => hd ([thm RS LA_Logic.not_leD] RL lessD)) cx
boehmes@66035
   480
      | mk (NotLessD j) cx = step1 "NL" j (fn thm => thm RS LA_Logic.not_lessD) cx
boehmes@66035
   481
      | mk (Added (j1, j2)) cx = step2 "+" j1 j2 (uncurry add_thms) cx |-> simp
boehmes@66035
   482
      | mk (Multiplied (n, j)) cx =
boehmes@66035
   483
          (trace_msg ctxt ("*" ^ string_of_int n); step1 "*" j (mult_thm n) cx)
boehmes@66035
   484
boehmes@66035
   485
    fun finish ctxt' hyps thm =
boehmes@66035
   486
      thm
boehmes@66035
   487
      |> fold_rev (Thm.implies_intr o snd) hyps
boehmes@66035
   488
      |> singleton (Variable.export ctxt' ctxt)
boehmes@66035
   489
      |> fold (fn (i, _) => fn thm => nth asms i RS thm) hyps
wenzelm@27020
   490
  in
wenzelm@27020
   491
    let
wenzelm@44654
   492
      val _ = trace_msg ctxt "mkthm";
boehmes@66035
   493
      val (thm, (_, hyps, ctxt')) = mk just ([], [], ctxt);
boehmes@66035
   494
      val _ = trace_thm ctxt ["Final thm:"] thm;
wenzelm@51717
   495
      val fls = simplify simpset_ctxt thm;
wenzelm@44654
   496
      val _ = trace_thm ctxt ["After simplification:"] fls;
wenzelm@27020
   497
      val _ =
wenzelm@27020
   498
        if LA_Logic.is_False fls then ()
wenzelm@27020
   499
        else
boehmes@35872
   500
         (tracing (cat_lines
wenzelm@61268
   501
           (["Assumptions:"] @ map (Thm.string_of_thm ctxt) asms @ [""] @
wenzelm@61268
   502
            ["Proved:", Thm.string_of_thm ctxt fls, ""]));
boehmes@35872
   503
          warning "Linear arithmetic should have refuted the assumptions.\n\
boehmes@35872
   504
            \Please inform Tobias Nipkow.")
boehmes@66035
   505
    in finish ctxt' hyps fls end
boehmes@66035
   506
    handle FalseE (thm, hyps, ctxt') =>
boehmes@66035
   507
      trace_thm ctxt ["False reached early:"] (finish ctxt' hyps thm)
wenzelm@27020
   508
  end;
wenzelm@27020
   509
nipkow@6056
   510
end;
nipkow@5982
   511
haftmann@23261
   512
fun coeff poly atom =
wenzelm@52131
   513
  AList.lookup Envir.aeconv poly atom |> the_default 0;
nipkow@10691
   514
nipkow@10691
   515
fun integ(rlhs,r,rel,rrhs,s,d) =
wenzelm@63201
   516
let val (rn,rd) = Rat.dest r and (sn,sd) = Rat.dest s
wenzelm@63227
   517
    val m = Integer.lcms(map (snd o Rat.dest) (r :: s :: map snd rlhs @ map snd rrhs))
wenzelm@22846
   518
    fun mult(t,r) =
wenzelm@63201
   519
        let val (i,j) = Rat.dest r
paulson@15965
   520
        in (t,i * (m div j)) end
nipkow@12932
   521
in (m,(map mult rlhs, rn*(m div rd), rel, map mult rrhs, sn*(m div sd), d)) end
nipkow@10691
   522
haftmann@38052
   523
fun mklineq atoms =
webertj@20217
   524
  fn (item, k) =>
webertj@20217
   525
  let val (m, (lhs,i,rel,rhs,j,discrete)) = integ item
nipkow@13498
   526
      val lhsa = map (coeff lhs) atoms
nipkow@13498
   527
      and rhsa = map (coeff rhs) atoms
haftmann@18330
   528
      val diff = map2 (curry (op -)) rhsa lhsa
nipkow@13498
   529
      val c = i-j
nipkow@13498
   530
      val just = Asm k
boehmes@31511
   531
      fun lineq(c,le,cs,j) = Lineq(c,le,cs, if m=1 then j else Multiplied(m,j))
nipkow@13498
   532
  in case rel of
nipkow@13498
   533
      "<="   => lineq(c,Le,diff,just)
nipkow@13498
   534
     | "~<=" => if discrete
nipkow@13498
   535
                then lineq(1-c,Le,map (op ~) diff,NotLeDD(just))
nipkow@13498
   536
                else lineq(~c,Lt,map (op ~) diff,NotLeD(just))
nipkow@13498
   537
     | "<"   => if discrete
nipkow@13498
   538
                then lineq(c+1,Le,diff,LessD(just))
nipkow@13498
   539
                else lineq(c,Lt,diff,just)
nipkow@13498
   540
     | "~<"  => lineq(~c,Le,map (op~) diff,NotLessD(just))
nipkow@13498
   541
     | "="   => lineq(c,Eq,diff,just)
wenzelm@40316
   542
     | _     => raise Fail ("mklineq" ^ rel)
nipkow@5982
   543
  end;
nipkow@5982
   544
nipkow@13498
   545
(* ------------------------------------------------------------------------- *)
nipkow@13498
   546
(* Print (counter) example                                                   *)
nipkow@13498
   547
(* ------------------------------------------------------------------------- *)
nipkow@13498
   548
webertj@20217
   549
(* ------------------------------------------------------------------------- *)
webertj@20217
   550
webertj@20268
   551
fun mknat (pTs : typ list) (ixs : int list) (atom : term, i : int) : lineq option =
webertj@20217
   552
  if LA_Logic.is_nat (pTs, atom)
nipkow@6056
   553
  then let val l = map (fn j => if j=i then 1 else 0) ixs
webertj@20217
   554
       in SOME (Lineq (0, Le, l, Nat i)) end
webertj@20217
   555
  else NONE;
nipkow@6056
   556
nipkow@13186
   557
(* This code is tricky. It takes a list of premises in the order they occur
skalberg@15531
   558
in the subgoal. Numerical premises are coded as SOME(tuple), non-numerical
skalberg@15531
   559
ones as NONE. Going through the premises, each numeric one is converted into
nipkow@13186
   560
a Lineq. The tricky bit is to convert ~= which is split into two cases < and
nipkow@13498
   561
>. Thus split_items returns a list of equation systems. This may blow up if
nipkow@13186
   562
there are many ~=, but in practice it does not seem to happen. The really
nipkow@13186
   563
tricky bit is to arrange the order of the cases such that they coincide with
nipkow@13186
   564
the order in which the cases are in the end generated by the tactic that
nipkow@13186
   565
applies the generated refutation thms (see function 'refute_tac').
nipkow@13186
   566
nipkow@13186
   567
For variables n of type nat, a constraint 0 <= n is added.
nipkow@13186
   568
*)
webertj@20217
   569
webertj@20217
   570
(* FIXME: To optimize, the splitting of cases and the search for refutations *)
webertj@20276
   571
(*        could be intertwined: separate the first (fully split) case,       *)
webertj@20217
   572
(*        refute it, continue with splitting and refuting.  Terminate with   *)
webertj@20217
   573
(*        failure as soon as a case could not be refuted; i.e. delay further *)
webertj@20217
   574
(*        splitting until after a refutation for other cases has been found. *)
webertj@20217
   575
webertj@30406
   576
fun split_items ctxt do_pre split_neq (Ts, terms) : (typ list * (LA_Data.decomp * int) list) list =
webertj@20276
   577
let
webertj@20276
   578
  (* splits inequalities '~=' into '<' and '>'; this corresponds to *)
webertj@20276
   579
  (* 'REPEAT_DETERM (eresolve_tac neqE i)' at the theorem/tactic    *)
webertj@20276
   580
  (* level                                                          *)
webertj@20276
   581
  (* FIXME: this is currently sensitive to the order of theorems in *)
webertj@20276
   582
  (*        neqE:  The theorem for type "nat" must come first.  A   *)
webertj@20276
   583
  (*        better (i.e. less likely to break when neqE changes)    *)
webertj@20276
   584
  (*        implementation should *test* which theorem from neqE    *)
webertj@20276
   585
  (*        can be applied, and split the premise accordingly.      *)
wenzelm@26945
   586
  fun elim_neq (ineqs : (LA_Data.decomp option * bool) list) :
wenzelm@26945
   587
               (LA_Data.decomp option * bool) list list =
webertj@20276
   588
  let
boehmes@66035
   589
    fun elim_neq' _ ([] : (LA_Data.decomp option * bool) list) :
wenzelm@26945
   590
                  (LA_Data.decomp option * bool) list list =
webertj@20276
   591
          [[]]
webertj@20276
   592
      | elim_neq' nat_only ((NONE, is_nat) :: ineqs) =
webertj@20276
   593
          map (cons (NONE, is_nat)) (elim_neq' nat_only ineqs)
webertj@20276
   594
      | elim_neq' nat_only ((ineq as (SOME (l, i, rel, r, j, d), is_nat)) :: ineqs) =
webertj@20276
   595
          if rel = "~=" andalso (not nat_only orelse is_nat) then
webertj@20276
   596
            (* [| ?l ~= ?r; ?l < ?r ==> ?R; ?r < ?l ==> ?R |] ==> ?R *)
webertj@20276
   597
            elim_neq' nat_only (ineqs @ [(SOME (l, i, "<", r, j, d), is_nat)]) @
webertj@20276
   598
            elim_neq' nat_only (ineqs @ [(SOME (r, j, "<", l, i, d), is_nat)])
webertj@20276
   599
          else
webertj@20276
   600
            map (cons ineq) (elim_neq' nat_only ineqs)
webertj@20276
   601
  in
webertj@20276
   602
    ineqs |> elim_neq' true
wenzelm@26945
   603
          |> maps (elim_neq' false)
webertj@20276
   604
  end
nipkow@13464
   605
webertj@30406
   606
  fun ignore_neq (NONE, bool) = (NONE, bool)
webertj@30406
   607
    | ignore_neq (ineq as SOME (_, _, rel, _, _, _), bool) =
webertj@30406
   608
      if rel = "~=" then (NONE, bool) else (ineq, bool)
webertj@30406
   609
webertj@20276
   610
  fun number_hyps _ []             = []
webertj@20276
   611
    | number_hyps n (NONE::xs)     = number_hyps (n+1) xs
webertj@20276
   612
    | number_hyps n ((SOME x)::xs) = (x, n) :: number_hyps (n+1) xs
webertj@20276
   613
webertj@20276
   614
  val result = (Ts, terms)
webertj@20276
   615
    |> (* user-defined preprocessing of the subgoal *)
wenzelm@24076
   616
       (if do_pre then LA_Data.pre_decomp ctxt else Library.single)
wenzelm@44654
   617
    |> tap (fn subgoals => trace_msg ctxt ("Preprocessing yields " ^
webertj@23195
   618
         string_of_int (length subgoals) ^ " subgoal(s) total."))
wenzelm@22846
   619
    |> (* produce the internal encoding of (in-)equalities *)
wenzelm@24076
   620
       map (apsnd (map (fn t => (LA_Data.decomp ctxt t, LA_Data.domain_is_nat t))))
webertj@20276
   621
    |> (* splitting of inequalities *)
webertj@30406
   622
       map (apsnd (if split_neq then elim_neq else
webertj@30406
   623
                     Library.single o map ignore_neq))
wenzelm@22846
   624
    |> maps (fn (Ts, subgoals) => map (pair Ts o map fst) subgoals)
webertj@20276
   625
    |> (* numbering of hypotheses, ignoring irrelevant ones *)
webertj@20276
   626
       map (apsnd (number_hyps 0))
webertj@23195
   627
in
wenzelm@44654
   628
  trace_msg ctxt ("Splitting of inequalities yields " ^
webertj@23195
   629
    string_of_int (length result) ^ " subgoal(s) total.");
webertj@23195
   630
  result
webertj@23195
   631
end;
nipkow@13464
   632
wenzelm@59656
   633
fun refutes ctxt :
wenzelm@26945
   634
    (typ list * (LA_Data.decomp * int) list) list -> injust list -> injust list option =
wenzelm@26945
   635
  let
wenzelm@26945
   636
    fun refute ((Ts, initems : (LA_Data.decomp * int) list) :: initemss) (js: injust list) =
wenzelm@26945
   637
          let
boehmes@31510
   638
            val atoms = atoms_of (map fst initems)
wenzelm@26945
   639
            val n = length atoms
haftmann@38052
   640
            val mkleq = mklineq atoms
wenzelm@26945
   641
            val ixs = 0 upto (n - 1)
wenzelm@26945
   642
            val iatoms = atoms ~~ ixs
wenzelm@32952
   643
            val natlineqs = map_filter (mknat Ts ixs) iatoms
wenzelm@26945
   644
            val ineqs = map mkleq initems @ natlineqs
wenzelm@59656
   645
          in
wenzelm@59656
   646
            (case elim ctxt (ineqs, []) of
wenzelm@26945
   647
               Success j =>
wenzelm@44654
   648
                 (trace_msg ctxt ("Contradiction! (" ^ string_of_int (length js + 1) ^ ")");
wenzelm@26945
   649
                  refute initemss (js @ [j]))
wenzelm@59656
   650
             | Failure _ => NONE)
wenzelm@26945
   651
          end
wenzelm@26945
   652
      | refute [] js = SOME js
wenzelm@26945
   653
  in refute end;
nipkow@5982
   654
wenzelm@59656
   655
fun refute ctxt params do_pre split_neq terms : injust list option =
wenzelm@59656
   656
  refutes ctxt (split_items ctxt do_pre split_neq (map snd params, terms)) [];
webertj@20254
   657
haftmann@22950
   658
fun count P xs = length (filter P xs);
webertj@20254
   659
wenzelm@59656
   660
fun prove ctxt params do_pre Hs concl : bool * injust list option =
webertj@20254
   661
  let
wenzelm@44654
   662
    val _ = trace_msg ctxt "prove:"
webertj@20254
   663
    (* append the negated conclusion to 'Hs' -- this corresponds to     *)
webertj@20254
   664
    (* 'DETERM (resolve_tac [LA_Logic.notI, LA_Logic.ccontr] i)' at the *)
webertj@20254
   665
    (* theorem/tactic level                                             *)
webertj@20254
   666
    val Hs' = Hs @ [LA_Logic.neg_prop concl]
webertj@20254
   667
    fun is_neq NONE                 = false
webertj@20254
   668
      | is_neq (SOME (_,_,r,_,_,_)) = (r = "~=")
wenzelm@44654
   669
    val neq_limit = Config.get ctxt LA_Data.neq_limit
webertj@30406
   670
    val split_neq = count is_neq (map (LA_Data.decomp ctxt) Hs') <= neq_limit
webertj@20254
   671
  in
webertj@30406
   672
    if split_neq then ()
wenzelm@24076
   673
    else
wenzelm@44654
   674
      trace_msg ctxt ("neq_limit exceeded (current value is " ^
webertj@30406
   675
        string_of_int neq_limit ^ "), ignoring all inequalities");
wenzelm@59656
   676
    (split_neq, refute ctxt params do_pre split_neq Hs')
webertj@23190
   677
  end handle TERM ("neg_prop", _) =>
webertj@23190
   678
    (* since no meta-logic negation is available, we can only fail if   *)
webertj@23190
   679
    (* the conclusion is not of the form 'Trueprop $ _' (simply         *)
webertj@23190
   680
    (* dropping the conclusion doesn't work either, because even        *)
webertj@23190
   681
    (* 'False' does not imply arbitrary 'concl::prop')                  *)
wenzelm@44654
   682
    (trace_msg ctxt "prove failed (cannot negate conclusion).";
webertj@30406
   683
      (false, NONE));
webertj@20217
   684
wenzelm@51717
   685
fun refute_tac ctxt (i, split_neq, justs) =
nipkow@6074
   686
  fn state =>
wenzelm@24076
   687
    let
wenzelm@32091
   688
      val _ = trace_thm ctxt
wenzelm@44654
   689
        ["refute_tac (on subgoal " ^ string_of_int i ^ ", with " ^
wenzelm@44654
   690
          string_of_int (length justs) ^ " justification(s)):"] state
wenzelm@61097
   691
      val neqE = get_neqE ctxt;
wenzelm@24076
   692
      fun just1 j =
wenzelm@24076
   693
        (* eliminate inequalities *)
webertj@30406
   694
        (if split_neq then
wenzelm@59498
   695
          REPEAT_DETERM (eresolve_tac ctxt neqE i)
webertj@30406
   696
        else
webertj@30406
   697
          all_tac) THEN
wenzelm@44654
   698
          PRIMITIVE (trace_thm ctxt ["State after neqE:"]) THEN
wenzelm@24076
   699
          (* use theorems generated from the actual justifications *)
wenzelm@59498
   700
          Subgoal.FOCUS (fn {prems, ...} => resolve_tac ctxt [mkthm ctxt prems j] 1) ctxt i
wenzelm@24076
   701
    in
wenzelm@24076
   702
      (* rewrite "[| A1; ...; An |] ==> B" to "[| A1; ...; An; ~B |] ==> False" *)
wenzelm@59498
   703
      DETERM (resolve_tac ctxt [LA_Logic.notI, LA_Logic.ccontr] i) THEN
wenzelm@24076
   704
      (* user-defined preprocessing of the subgoal *)
wenzelm@51717
   705
      DETERM (LA_Data.pre_tac ctxt i) THEN
wenzelm@44654
   706
      PRIMITIVE (trace_thm ctxt ["State after pre_tac:"]) THEN
wenzelm@24076
   707
      (* prove every resulting subgoal, using its justification *)
wenzelm@24076
   708
      EVERY (map just1 justs)
webertj@20217
   709
    end  state;
nipkow@6074
   710
nipkow@5982
   711
(*
nipkow@5982
   712
Fast but very incomplete decider. Only premises and conclusions
nipkow@5982
   713
that are already (negated) (in)equations are taken into account.
nipkow@5982
   714
*)
wenzelm@59656
   715
fun simpset_lin_arith_tac ctxt = SUBGOAL (fn (A, i) =>
wenzelm@24076
   716
  let
wenzelm@24076
   717
    val params = rev (Logic.strip_params A)
wenzelm@24076
   718
    val Hs = Logic.strip_assums_hyp A
wenzelm@24076
   719
    val concl = Logic.strip_assums_concl A
wenzelm@44654
   720
    val _ = trace_term ctxt ["Trying to refute subgoal " ^ string_of_int i] A
wenzelm@24076
   721
  in
wenzelm@59656
   722
    case prove ctxt params true Hs concl of
wenzelm@44654
   723
      (_, NONE) => (trace_msg ctxt "Refutation failed."; no_tac)
wenzelm@44654
   724
    | (split_neq, SOME js) => (trace_msg ctxt "Refutation succeeded.";
wenzelm@51717
   725
                               refute_tac ctxt (i, split_neq, js))
wenzelm@24076
   726
  end);
nipkow@5982
   727
wenzelm@51717
   728
fun prems_lin_arith_tac ctxt =
wenzelm@61841
   729
  Method.insert_tac ctxt (Simplifier.prems_of ctxt) THEN'
wenzelm@59656
   730
  simpset_lin_arith_tac ctxt;
wenzelm@17613
   731
wenzelm@24076
   732
fun lin_arith_tac ctxt =
wenzelm@51717
   733
  simpset_lin_arith_tac (empty_simpset ctxt);
wenzelm@24076
   734
wenzelm@24076
   735
nipkow@5982
   736
nipkow@13186
   737
(** Forward proof from theorems **)
nipkow@13186
   738
webertj@20433
   739
(* More tricky code. Needs to arrange the proofs of the multiple cases (due
webertj@20433
   740
to splits of ~= premises) such that it coincides with the order of the cases
webertj@20433
   741
generated by function split_items. *)
webertj@20433
   742
webertj@20433
   743
datatype splittree = Tip of thm list
webertj@20433
   744
                   | Spl of thm * cterm * splittree * cterm * splittree;
webertj@20433
   745
webertj@20433
   746
(* "(ct1 ==> ?R) ==> (ct2 ==> ?R) ==> ?R" is taken to (ct1, ct2) *)
webertj@20433
   747
webertj@20433
   748
fun extract (imp : cterm) : cterm * cterm =
webertj@20433
   749
let val (Il, r)    = Thm.dest_comb imp
webertj@20433
   750
    val (_, imp1)  = Thm.dest_comb Il
webertj@20433
   751
    val (Ict1, _)  = Thm.dest_comb imp1
webertj@20433
   752
    val (_, ct1)   = Thm.dest_comb Ict1
webertj@20433
   753
    val (Ir, _)    = Thm.dest_comb r
webertj@20433
   754
    val (_, Ict2r) = Thm.dest_comb Ir
webertj@20433
   755
    val (Ict2, _)  = Thm.dest_comb Ict2r
webertj@20433
   756
    val (_, ct2)   = Thm.dest_comb Ict2
webertj@20433
   757
in (ct1, ct2) end;
webertj@20433
   758
wenzelm@24076
   759
fun splitasms ctxt (asms : thm list) : splittree =
wenzelm@61097
   760
let val neqE = get_neqE ctxt
hoelzl@35693
   761
    fun elim_neq [] (asms', []) = Tip (rev asms')
hoelzl@35693
   762
      | elim_neq [] (asms', asms) = Tip (rev asms' @ asms)
haftmann@49387
   763
      | elim_neq (_ :: neqs) (asms', []) = elim_neq neqs ([],rev asms')
hoelzl@35693
   764
      | elim_neq (neqs as (neq :: _)) (asms', asm::asms) =
hoelzl@35693
   765
      (case get_first (fn th => SOME (asm COMP th) handle THM _ => NONE) [neq] of
webertj@20433
   766
        SOME spl =>
wenzelm@59582
   767
          let val (ct1, ct2) = extract (Thm.cprop_of spl)
wenzelm@36945
   768
              val thm1 = Thm.assume ct1
wenzelm@36945
   769
              val thm2 = Thm.assume ct2
hoelzl@35693
   770
          in Spl (spl, ct1, elim_neq neqs (asms', asms@[thm1]),
hoelzl@35693
   771
            ct2, elim_neq neqs (asms', asms@[thm2]))
webertj@20433
   772
          end
hoelzl@35693
   773
      | NONE => elim_neq neqs (asm::asms', asms))
hoelzl@35693
   774
in elim_neq neqE ([], asms) end;
webertj@20433
   775
wenzelm@51717
   776
fun fwdproof ctxt (Tip asms : splittree) (j::js : injust list) = (mkthm ctxt asms j, js)
wenzelm@51717
   777
  | fwdproof ctxt (Spl (thm, ct1, tree1, ct2, tree2)) js =
wenzelm@24076
   778
      let
wenzelm@51717
   779
        val (thm1, js1) = fwdproof ctxt tree1 js
wenzelm@51717
   780
        val (thm2, js2) = fwdproof ctxt tree2 js1
wenzelm@36945
   781
        val thm1' = Thm.implies_intr ct1 thm1
wenzelm@36945
   782
        val thm2' = Thm.implies_intr ct2 thm2
wenzelm@24076
   783
      in (thm2' COMP (thm1' COMP thm), js2) end;
wenzelm@24076
   784
      (* FIXME needs handle THM _ => NONE ? *)
webertj@20433
   785
wenzelm@51717
   786
fun prover ctxt thms Tconcl (js : injust list) split_neq pos : thm option =
wenzelm@24076
   787
  let
wenzelm@24076
   788
    val nTconcl = LA_Logic.neg_prop Tconcl
wenzelm@59642
   789
    val cnTconcl = Thm.cterm_of ctxt nTconcl
wenzelm@36945
   790
    val nTconclthm = Thm.assume cnTconcl
webertj@30406
   791
    val tree = (if split_neq then splitasms ctxt else Tip) (thms @ [nTconclthm])
wenzelm@51717
   792
    val (Falsethm, _) = fwdproof ctxt tree js
wenzelm@24076
   793
    val contr = if pos then LA_Logic.ccontr else LA_Logic.notI
wenzelm@36945
   794
    val concl = Thm.implies_intr cnTconcl Falsethm COMP contr
wenzelm@44654
   795
  in SOME (trace_thm ctxt ["Proved by lin. arith. prover:"] (LA_Logic.mk_Eq concl)) end
wenzelm@24076
   796
  (*in case concl contains ?-var, which makes assume fail:*)   (* FIXME Variable.import_terms *)
wenzelm@24076
   797
  handle THM _ => NONE;
nipkow@13186
   798
nipkow@13186
   799
(* PRE: concl is not negated!
nipkow@13186
   800
   This assumption is OK because
wenzelm@24076
   801
   1. lin_arith_simproc tries both to prove and disprove concl and
wenzelm@24076
   802
   2. lin_arith_simproc is applied by the Simplifier which
nipkow@13186
   803
      dives into terms and will thus try the non-negated concl anyway.
nipkow@13186
   804
*)
wenzelm@51717
   805
fun lin_arith_simproc ctxt concl =
wenzelm@24076
   806
  let
wenzelm@51717
   807
    val thms = maps LA_Logic.atomize (Simplifier.prems_of ctxt)
wenzelm@24076
   808
    val Hs = map Thm.prop_of thms
wenzelm@61144
   809
    val Tconcl = LA_Logic.mk_Trueprop (Thm.term_of concl)
wenzelm@24076
   810
  in
wenzelm@59656
   811
    case prove ctxt [] false Hs Tconcl of (* concl provable? *)
wenzelm@51717
   812
      (split_neq, SOME js) => prover ctxt thms Tconcl js split_neq true
webertj@30406
   813
    | (_, NONE) =>
wenzelm@24076
   814
        let val nTconcl = LA_Logic.neg_prop Tconcl in
wenzelm@59656
   815
          case prove ctxt [] false Hs nTconcl of (* ~concl provable? *)
wenzelm@51717
   816
            (split_neq, SOME js) => prover ctxt thms nTconcl js split_neq false
webertj@30406
   817
          | (_, NONE) => NONE
wenzelm@24076
   818
        end
wenzelm@24076
   819
  end;
nipkow@6074
   820
nipkow@6074
   821
end;