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