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