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