src/Provers/Arith/fast_lin_arith.ML
author nipkow
Wed Aug 07 05:54:44 2002 +0200 (2002-08-07)
changeset 13464 c98321b8d638
parent 13186 ef8ed6adcb38
child 13498 5330f1744817
permissions -rw-r--r--
Fixed two bugs
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
nipkow@6102
    14
    lin_arith_prover: Sign.sg -> thm list -> 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 neqE:             thm (* [| m ~= n; m < n ==> P; n < m ==> P |] ==> P *)
nipkow@6102
    29
  val notI:             thm (* (P ==> False) ==> ~ P *)
nipkow@6110
    30
  val not_lessD:        thm (* ~(m < n) ==> n <= m *)
nipkow@6128
    31
  val not_leD:          thm (* ~(m <= n) ==> n < m *)
nipkow@6102
    32
  val sym:		thm (* x = y ==> y = x *)
nipkow@6102
    33
  val mk_Eq: thm -> thm
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
nipkow@6128
    38
  val mk_nat_thm: Sign.sg -> 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:
nipkow@10691
    56
    Sign.sg -> term -> ((term*rat)list * rat * string * (term*rat)list * rat * bool)option
nipkow@10691
    57
  val number_of: 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@9420
    73
  val setup: (theory -> theory) list
nipkow@10691
    74
  val map_data: ({add_mono_thms: thm list, mult_mono_thms: (thm*cterm)list, inj_thms: thm list,
nipkow@10575
    75
                 lessD: thm list, simpset: Simplifier.simpset}
nipkow@10691
    76
                 -> {add_mono_thms: thm list, mult_mono_thms: (thm*cterm)list, inj_thms: thm list,
nipkow@10575
    77
                     lessD: thm list, simpset: Simplifier.simpset})
nipkow@10575
    78
                -> theory -> theory
paulson@9073
    79
  val trace           : bool ref
nipkow@6074
    80
  val lin_arith_prover: Sign.sg -> thm list -> term -> thm option
nipkow@6062
    81
  val     lin_arith_tac:             int -> tactic
nipkow@6062
    82
  val cut_lin_arith_tac: thm list -> int -> tactic
nipkow@6062
    83
end;
nipkow@6062
    84
nipkow@6102
    85
functor Fast_Lin_Arith(structure LA_Logic:LIN_ARITH_LOGIC 
nipkow@6102
    86
                       and       LA_Data:LIN_ARITH_DATA) : FAST_LIN_ARITH =
nipkow@5982
    87
struct
nipkow@5982
    88
wenzelm@9420
    89
wenzelm@9420
    90
(** theory data **)
wenzelm@9420
    91
wenzelm@9420
    92
(* data kind 'Provers/fast_lin_arith' *)
wenzelm@9420
    93
wenzelm@9420
    94
structure DataArgs =
wenzelm@9420
    95
struct
wenzelm@9420
    96
  val name = "Provers/fast_lin_arith";
nipkow@10691
    97
  type T = {add_mono_thms: thm list, mult_mono_thms: (thm*cterm)list, inj_thms: thm list,
nipkow@10575
    98
            lessD: thm list, simpset: Simplifier.simpset};
wenzelm@9420
    99
nipkow@10691
   100
  val empty = {add_mono_thms = [], mult_mono_thms = [], inj_thms = [],
nipkow@10575
   101
               lessD = [], simpset = Simplifier.empty_ss};
wenzelm@9420
   102
  val copy = I;
wenzelm@9420
   103
  val prep_ext = I;
wenzelm@9420
   104
nipkow@10691
   105
  fun merge ({add_mono_thms= add_mono_thms1, mult_mono_thms= mult_mono_thms1, inj_thms= inj_thms1,
nipkow@10575
   106
              lessD = lessD1, simpset = simpset1},
nipkow@10691
   107
             {add_mono_thms= add_mono_thms2, mult_mono_thms= mult_mono_thms2, inj_thms= inj_thms2,
nipkow@10575
   108
              lessD = lessD2, simpset = simpset2}) =
wenzelm@9420
   109
    {add_mono_thms = Drule.merge_rules (add_mono_thms1, add_mono_thms2),
wenzelm@13105
   110
     mult_mono_thms = gen_merge_lists' (Drule.eq_thm_prop o pairself fst)
wenzelm@13105
   111
       mult_mono_thms1 mult_mono_thms2,
nipkow@10575
   112
     inj_thms = Drule.merge_rules (inj_thms1, inj_thms2),
nipkow@10575
   113
     lessD = Drule.merge_rules (lessD1, lessD2),
nipkow@10575
   114
     simpset = Simplifier.merge_ss (simpset1, simpset2)};
wenzelm@9420
   115
wenzelm@9420
   116
  fun print _ _ = ();
wenzelm@9420
   117
end;
wenzelm@9420
   118
wenzelm@9420
   119
structure Data = TheoryDataFun(DataArgs);
wenzelm@9420
   120
val map_data = Data.map;
wenzelm@9420
   121
val setup = [Data.init];
wenzelm@9420
   122
wenzelm@9420
   123
wenzelm@9420
   124
nipkow@5982
   125
(*** A fast decision procedure ***)
nipkow@5982
   126
(*** Code ported from HOL Light ***)
nipkow@6056
   127
(* possible optimizations:
nipkow@6056
   128
   use (var,coeff) rep or vector rep  tp save space;
nipkow@6056
   129
   treat non-negative atoms separately rather than adding 0 <= atom
nipkow@6056
   130
*)
nipkow@5982
   131
paulson@9073
   132
val trace = ref false;
paulson@9073
   133
nipkow@5982
   134
datatype lineq_type = Eq | Le | Lt;
nipkow@5982
   135
nipkow@6056
   136
datatype injust = Asm of int
nipkow@6056
   137
                | Nat of int (* index of atom *)
nipkow@6128
   138
                | LessD of injust
nipkow@6128
   139
                | NotLessD of injust
nipkow@6128
   140
                | NotLeD of injust
nipkow@7551
   141
                | NotLeDD of injust
nipkow@5982
   142
                | Multiplied of int * injust
nipkow@10691
   143
                | Multiplied2 of int * injust
nipkow@5982
   144
                | Added of injust * injust;
nipkow@5982
   145
nipkow@5982
   146
datatype lineq = Lineq of int * lineq_type * int list * injust;
nipkow@5982
   147
nipkow@5982
   148
(* ------------------------------------------------------------------------- *)
nipkow@5982
   149
(* Calculate new (in)equality type after addition.                           *)
nipkow@5982
   150
(* ------------------------------------------------------------------------- *)
nipkow@5982
   151
nipkow@5982
   152
fun find_add_type(Eq,x) = x
nipkow@5982
   153
  | find_add_type(x,Eq) = x
nipkow@5982
   154
  | find_add_type(_,Lt) = Lt
nipkow@5982
   155
  | find_add_type(Lt,_) = Lt
nipkow@5982
   156
  | find_add_type(Le,Le) = Le;
nipkow@5982
   157
nipkow@5982
   158
(* ------------------------------------------------------------------------- *)
nipkow@5982
   159
(* Multiply out an (in)equation.                                             *)
nipkow@5982
   160
(* ------------------------------------------------------------------------- *)
nipkow@5982
   161
nipkow@5982
   162
fun multiply_ineq n (i as Lineq(k,ty,l,just)) =
nipkow@5982
   163
  if n = 1 then i
nipkow@5982
   164
  else if n = 0 andalso ty = Lt then sys_error "multiply_ineq"
nipkow@5982
   165
  else if n < 0 andalso (ty=Le orelse ty=Lt) then sys_error "multiply_ineq"
nipkow@5982
   166
  else Lineq(n * k,ty,map (apl(n,op * )) l,Multiplied(n,just));
nipkow@5982
   167
nipkow@5982
   168
(* ------------------------------------------------------------------------- *)
nipkow@5982
   169
(* Add together (in)equations.                                               *)
nipkow@5982
   170
(* ------------------------------------------------------------------------- *)
nipkow@5982
   171
nipkow@5982
   172
fun add_ineq (i1 as Lineq(k1,ty1,l1,just1)) (i2 as Lineq(k2,ty2,l2,just2)) =
nipkow@5982
   173
  let val l = map2 (op +) (l1,l2)
nipkow@5982
   174
  in Lineq(k1+k2,find_add_type(ty1,ty2),l,Added(just1,just2)) end;
nipkow@5982
   175
nipkow@5982
   176
(* ------------------------------------------------------------------------- *)
nipkow@5982
   177
(* Elimination of variable between a single pair of (in)equations.           *)
nipkow@5982
   178
(* If they're both inequalities, 1st coefficient must be +ve, 2nd -ve.       *)
nipkow@5982
   179
(* ------------------------------------------------------------------------- *)
nipkow@5982
   180
nipkow@5982
   181
fun el 0 (h::_) = h
nipkow@5982
   182
  | el n (_::t) = el (n - 1) t
nipkow@5982
   183
  | el _ _  = sys_error "el";
nipkow@5982
   184
nipkow@5982
   185
fun elim_var v (i1 as Lineq(k1,ty1,l1,just1)) (i2 as Lineq(k2,ty2,l2,just2)) =
nipkow@5982
   186
  let val c1 = el v l1 and c2 = el v l2
nipkow@10691
   187
      val m = lcm(abs c1,abs c2)
nipkow@5982
   188
      val m1 = m div (abs c1) and m2 = m div (abs c2)
nipkow@5982
   189
      val (n1,n2) =
nipkow@5982
   190
        if (c1 >= 0) = (c2 >= 0)
nipkow@5982
   191
        then if ty1 = Eq then (~m1,m2)
nipkow@5982
   192
             else if ty2 = Eq then (m1,~m2)
nipkow@5982
   193
                  else sys_error "elim_var"
nipkow@5982
   194
        else (m1,m2)
nipkow@5982
   195
      val (p1,p2) = if ty1=Eq andalso ty2=Eq andalso (n1 = ~1 orelse n2 = ~1)
nipkow@5982
   196
                    then (~n1,~n2) else (n1,n2)
nipkow@5982
   197
  in add_ineq (multiply_ineq n1 i1) (multiply_ineq n2 i2) end;
nipkow@5982
   198
nipkow@5982
   199
(* ------------------------------------------------------------------------- *)
nipkow@5982
   200
(* The main refutation-finding code.                                         *)
nipkow@5982
   201
(* ------------------------------------------------------------------------- *)
nipkow@5982
   202
nipkow@5982
   203
fun is_trivial (Lineq(_,_,l,_)) = forall (fn i => i=0) l;
nipkow@5982
   204
nipkow@5982
   205
fun is_answer (ans as Lineq(k,ty,l,_)) =
nipkow@5982
   206
  case ty  of Eq => k <> 0 | Le => k > 0 | Lt => k >= 0;
nipkow@5982
   207
nipkow@5982
   208
fun calc_blowup l =
nipkow@5982
   209
  let val (p,n) = partition (apl(0,op<)) (filter (apl(0,op<>)) l)
nipkow@5982
   210
  in (length p) * (length n) end;
nipkow@5982
   211
nipkow@5982
   212
(* ------------------------------------------------------------------------- *)
nipkow@5982
   213
(* Main elimination code:                                                    *)
nipkow@5982
   214
(*                                                                           *)
nipkow@5982
   215
(* (1) Looks for immediate solutions (false assertions with no variables).   *)
nipkow@5982
   216
(*                                                                           *)
nipkow@5982
   217
(* (2) If there are any equations, picks a variable with the lowest absolute *)
nipkow@5982
   218
(* coefficient in any of them, and uses it to eliminate.                     *)
nipkow@5982
   219
(*                                                                           *)
nipkow@5982
   220
(* (3) Otherwise, chooses a variable in the inequality to minimize the       *)
nipkow@5982
   221
(* blowup (number of consequences generated) and eliminates it.              *)
nipkow@5982
   222
(* ------------------------------------------------------------------------- *)
nipkow@5982
   223
nipkow@5982
   224
fun allpairs f xs ys =
nipkow@5982
   225
  flat(map (fn x => map (fn y => f x y) ys) xs);
nipkow@5982
   226
nipkow@5982
   227
fun extract_first p =
nipkow@5982
   228
  let fun extract xs (y::ys) = if p y then (Some y,xs@ys)
nipkow@5982
   229
                               else extract (y::xs) ys
nipkow@5982
   230
        | extract xs []      = (None,xs)
nipkow@5982
   231
  in extract [] end;
nipkow@5982
   232
nipkow@6056
   233
fun print_ineqs ineqs =
paulson@9073
   234
  if !trace then
wenzelm@12262
   235
     tracing(cat_lines(""::map (fn Lineq(c,t,l,_) =>
paulson@9073
   236
       string_of_int c ^
paulson@9073
   237
       (case t of Eq => " =  " | Lt=> " <  " | Le => " <= ") ^
paulson@9073
   238
       commas(map string_of_int l)) ineqs))
paulson@9073
   239
  else ();
nipkow@6056
   240
nipkow@5982
   241
fun elim ineqs =
paulson@9073
   242
  let val dummy = print_ineqs ineqs;
nipkow@6056
   243
      val (triv,nontriv) = partition is_trivial ineqs in
nipkow@5982
   244
  if not(null triv)
nipkow@13186
   245
  then case Library.find_first is_answer triv of
nipkow@5982
   246
         None => elim nontriv | some => some
nipkow@5982
   247
  else
nipkow@5982
   248
  if null nontriv then None else
nipkow@5982
   249
  let val (eqs,noneqs) = partition (fn (Lineq(_,ty,_,_)) => ty=Eq) nontriv in
nipkow@5982
   250
  if not(null eqs) then
nipkow@5982
   251
     let val clist = foldl (fn (cs,Lineq(_,_,l,_)) => l union cs) ([],eqs)
nipkow@5982
   252
         val sclist = sort (fn (x,y) => int_ord(abs(x),abs(y)))
nipkow@5982
   253
                           (filter (fn i => i<>0) clist)
nipkow@5982
   254
         val c = hd sclist
nipkow@5982
   255
         val (Some(eq as Lineq(_,_,ceq,_)),othereqs) =
nipkow@5982
   256
               extract_first (fn Lineq(_,_,l,_) => c mem l) eqs
nipkow@5982
   257
         val v = find_index (fn k => k=c) ceq
nipkow@5982
   258
         val (ioth,roth) = partition (fn (Lineq(_,_,l,_)) => el v l = 0)
nipkow@5982
   259
                                     (othereqs @ noneqs)
nipkow@5982
   260
         val others = map (elim_var v eq) roth @ ioth
nipkow@5982
   261
     in elim others end
nipkow@5982
   262
  else
nipkow@5982
   263
  let val lists = map (fn (Lineq(_,_,l,_)) => l) noneqs
nipkow@5982
   264
      val numlist = 0 upto (length(hd lists) - 1)
nipkow@5982
   265
      val coeffs = map (fn i => map (el i) lists) numlist
nipkow@5982
   266
      val blows = map calc_blowup coeffs
nipkow@5982
   267
      val iblows = blows ~~ numlist
nipkow@5982
   268
      val nziblows = filter (fn (i,_) => i<>0) iblows
nipkow@5982
   269
  in if null nziblows then None else
nipkow@5982
   270
     let val (c,v) = hd(sort (fn (x,y) => int_ord(fst(x),fst(y))) nziblows)
nipkow@5982
   271
         val (no,yes) = partition (fn (Lineq(_,_,l,_)) => el v l = 0) ineqs
nipkow@5982
   272
         val (pos,neg) = partition(fn (Lineq(_,_,l,_)) => el v l > 0) yes
nipkow@5982
   273
     in elim (no @ allpairs (elim_var v) pos neg) end
nipkow@5982
   274
  end
nipkow@5982
   275
  end
nipkow@5982
   276
  end;
nipkow@5982
   277
nipkow@5982
   278
(* ------------------------------------------------------------------------- *)
nipkow@5982
   279
(* Translate back a proof.                                                   *)
nipkow@5982
   280
(* ------------------------------------------------------------------------- *)
nipkow@5982
   281
paulson@9073
   282
fun trace_thm msg th = 
wenzelm@12262
   283
    if !trace then (tracing msg; tracing (Display.string_of_thm th); th) else th;
paulson@9073
   284
paulson@9073
   285
fun trace_msg msg = 
wenzelm@12262
   286
    if !trace then tracing msg else ();
paulson@9073
   287
nipkow@6056
   288
(* FIXME OPTIMIZE!!!!
nipkow@6056
   289
   Addition/Multiplication need i*t representation rather than t+t+...
nipkow@10691
   290
   Get rid of Mulitplied(2). For Nat LA_Data.number_of should return Suc^n
nipkow@10691
   291
   because Numerals are not known early enough.
nipkow@6056
   292
nipkow@6056
   293
Simplification may detect a contradiction 'prematurely' due to type
nipkow@6056
   294
information: n+1 <= 0 is simplified to False and does not need to be crossed
nipkow@6056
   295
with 0 <= n.
nipkow@6056
   296
*)
nipkow@6056
   297
local
nipkow@6056
   298
 exception FalseE of thm
nipkow@6056
   299
in
nipkow@6074
   300
fun mkthm sg asms just =
nipkow@10691
   301
  let val {add_mono_thms, mult_mono_thms, inj_thms, lessD, simpset} = Data.get_sg sg;
wenzelm@9420
   302
      val atoms = foldl (fn (ats,(lhs,_,_,rhs,_,_)) =>
nipkow@6056
   303
                            map fst lhs  union  (map fst rhs  union  ats))
nipkow@13464
   304
                        ([], mapfilter (fn thm => if Thm.no_prems thm
nipkow@13464
   305
                                        then LA_Data.decomp sg (concl_of thm)
nipkow@13464
   306
                                        else None) asms)
nipkow@6056
   307
nipkow@10575
   308
      fun add2 thm1 thm2 =
nipkow@6102
   309
        let val conj = thm1 RS (thm2 RS LA_Logic.conjI)
nipkow@10575
   310
        in get_first (fn th => Some(conj RS th) handle _ => None) add_mono_thms
nipkow@5982
   311
        end;
nipkow@5982
   312
nipkow@10575
   313
      fun try_add [] _ = None
nipkow@10575
   314
        | try_add (thm1::thm1s) thm2 = case add2 thm1 thm2 of
nipkow@10575
   315
             None => try_add thm1s thm2 | some => some;
nipkow@10575
   316
nipkow@10575
   317
      fun addthms thm1 thm2 =
nipkow@10575
   318
        case add2 thm1 thm2 of
nipkow@10575
   319
          None => (case try_add ([thm1] RL inj_thms) thm2 of
nipkow@10575
   320
                     None => the(try_add ([thm2] RL inj_thms) thm1)
nipkow@10575
   321
                   | Some thm => thm)
nipkow@10575
   322
        | Some thm => thm;
nipkow@10575
   323
nipkow@5982
   324
      fun multn(n,thm) =
nipkow@5982
   325
        let fun mul(i,th) = if i=1 then th else mul(i-1, addthms thm th)
nipkow@6102
   326
        in if n < 0 then mul(~n,thm) RS LA_Logic.sym else mul(n,thm) end;
nipkow@5982
   327
nipkow@10691
   328
      fun multn2(n,thm) =
nipkow@10691
   329
        let val Some(mth,cv) =
nipkow@10691
   330
              get_first (fn (th,cv) => Some(thm RS th,cv) handle _ => None) mult_mono_thms
nipkow@10691
   331
            val ct = cterm_of sg (LA_Data.number_of(n,#T(rep_cterm cv)))
nipkow@10691
   332
        in instantiate ([],[(cv,ct)]) mth end
nipkow@10691
   333
nipkow@6056
   334
      fun simp thm =
nipkow@12932
   335
        let val thm' = trace_thm "Simplified:" (full_simplify simpset thm)
nipkow@6102
   336
        in if LA_Logic.is_False thm' then raise FalseE thm' else thm' end
nipkow@6056
   337
paulson@9073
   338
      fun mk(Asm i) = trace_thm "Asm" (nth_elem(i,asms))
nipkow@13464
   339
        | mk(Nat i) = (trace_msg "Nat"; LA_Logic.mk_nat_thm sg (nth_elem(i,atoms)))
wenzelm@9420
   340
        | mk(LessD(j)) = trace_thm "L" (hd([mk j] RL lessD))
paulson@9073
   341
        | mk(NotLeD(j)) = trace_thm "NLe" (mk j RS LA_Logic.not_leD)
wenzelm@9420
   342
        | mk(NotLeDD(j)) = trace_thm "NLeD" (hd([mk j RS LA_Logic.not_leD] RL lessD))
paulson@9073
   343
        | mk(NotLessD(j)) = trace_thm "NL" (mk j RS LA_Logic.not_lessD)
paulson@9073
   344
        | mk(Added(j1,j2)) = simp (trace_thm "+" (addthms (mk j1) (mk j2)))
nipkow@10717
   345
        | mk(Multiplied(n,j)) = (trace_msg("*"^string_of_int n); trace_thm "*" (multn(n,mk j)))
nipkow@10717
   346
        | mk(Multiplied2(n,j)) = simp (trace_msg("**"^string_of_int n); trace_thm "**" (multn2(n,mk j)))
nipkow@5982
   347
paulson@9073
   348
  in trace_msg "mkthm";
nipkow@12932
   349
     let val thm = trace_thm "Final thm:" (mk just)
nipkow@12932
   350
     in let val fls = simplify simpset thm
nipkow@13186
   351
        in trace_thm "After simplification:" fls;
nipkow@13186
   352
           if LA_Logic.is_False fls then fls
nipkow@13186
   353
           else
nipkow@13186
   354
            (tracing "Assumptions:"; seq print_thm asms;
nipkow@13186
   355
             tracing "Proved:"; print_thm fls;
nipkow@13186
   356
             warning "Linear arithmetic should have refuted the assumptions.\n\
nipkow@13186
   357
                     \Please inform Tobias Nipkow (nipkow@in.tum.de).";
nipkow@13186
   358
             fls)
nipkow@12932
   359
        end
nipkow@12932
   360
     end handle FalseE thm => (trace_thm "False reached early:" thm; thm)
nipkow@12932
   361
  end
nipkow@6056
   362
end;
nipkow@5982
   363
nipkow@5982
   364
fun coeff poly atom = case assoc(poly,atom) of None => 0 | Some i => i;
nipkow@5982
   365
nipkow@10691
   366
fun lcms is = foldl lcm (1,is);
nipkow@10691
   367
nipkow@10691
   368
fun integ(rlhs,r,rel,rrhs,s,d) =
nipkow@10691
   369
let val (rn,rd) = rep_rat r and (sn,sd) = rep_rat s
nipkow@10691
   370
    val m = lcms(map (abs o snd o rep_rat) (r :: s :: map snd rlhs @ map snd rrhs))
nipkow@10691
   371
    fun mult(t,r) = let val (i,j) = rep_rat r in (t,i * (m div j)) end
nipkow@12932
   372
in (m,(map mult rlhs, rn*(m div rd), rel, map mult rrhs, sn*(m div sd), d)) end
nipkow@10691
   373
nipkow@5982
   374
fun mklineq atoms =
nipkow@5982
   375
  let val n = length atoms in
nipkow@10691
   376
    fn (item,k) =>
nipkow@10691
   377
    let val (m,(lhs,i,rel,rhs,j,discrete)) = integ item
nipkow@10691
   378
        val lhsa = map (coeff lhs) atoms
nipkow@5982
   379
        and rhsa = map (coeff rhs) atoms
nipkow@5982
   380
        val diff = map2 (op -) (rhsa,lhsa)
nipkow@5982
   381
        val c = i-j
nipkow@6056
   382
        val just = Asm k
nipkow@13186
   383
        fun lineq(c,le,cs,j) = Lineq(c,le,cs, if m=1 then j else Multiplied2(m,j))
nipkow@5982
   384
    in case rel of
nipkow@10691
   385
        "<="   => lineq(c,Le,diff,just)
nipkow@7551
   386
       | "~<=" => if discrete
nipkow@10691
   387
                  then lineq(1-c,Le,map (op ~) diff,NotLeDD(just))
nipkow@10691
   388
                  else lineq(~c,Lt,map (op ~) diff,NotLeD(just))
nipkow@7551
   389
       | "<"   => if discrete
nipkow@10691
   390
                  then lineq(c+1,Le,diff,LessD(just))
nipkow@10691
   391
                  else lineq(c,Lt,diff,just)
nipkow@10691
   392
       | "~<"  => lineq(~c,Le,map (op~) diff,NotLessD(just))
nipkow@10691
   393
       | "="   => lineq(c,Eq,diff,just)
nipkow@5982
   394
       | _     => sys_error("mklineq" ^ rel)   
nipkow@5982
   395
    end
nipkow@5982
   396
  end;
nipkow@5982
   397
nipkow@6056
   398
fun mknat pTs ixs (atom,i) =
nipkow@6128
   399
  if LA_Logic.is_nat(pTs,atom)
nipkow@6056
   400
  then let val l = map (fn j => if j=i then 1 else 0) ixs
nipkow@6056
   401
       in Some(Lineq(0,Le,l,Nat(i))) end
nipkow@6056
   402
  else None
nipkow@6056
   403
nipkow@13186
   404
(* This code is tricky. It takes a list of premises in the order they occur
nipkow@13186
   405
in the subgoal. Numerical premises are coded as Some(tuple), non-numerical
nipkow@13186
   406
ones as None. Going through the premises, each numeric one is converted into
nipkow@13186
   407
a Lineq. The tricky bit is to convert ~= which is split into two cases < and
nipkow@13186
   408
>. Thus mklineqss returns a list of equation systems. This may blow up if
nipkow@13186
   409
there are many ~=, but in practice it does not seem to happen. The really
nipkow@13186
   410
tricky bit is to arrange the order of the cases such that they coincide with
nipkow@13186
   411
the order in which the cases are in the end generated by the tactic that
nipkow@13186
   412
applies the generated refutation thms (see function 'refute_tac').
nipkow@13186
   413
nipkow@13186
   414
For variables n of type nat, a constraint 0 <= n is added.
nipkow@13186
   415
*)
nipkow@13464
   416
fun split_items(items) =
nipkow@13464
   417
  let fun elim_neq front _ [] = [rev front]
nipkow@13464
   418
        | elim_neq front n (None::ineqs) = elim_neq front (n+1) ineqs
nipkow@13464
   419
        | elim_neq front n (Some(ineq as (l,i,rel,r,j,d))::ineqs) =
nipkow@13464
   420
          if rel = "~=" then elim_neq front n (ineqs @ [Some(l,i,"<",r,j,d)]) @
nipkow@13464
   421
                             elim_neq front n (ineqs @ [Some(r,j,"<",l,i,d)])
nipkow@13464
   422
          else elim_neq ((ineq,n) :: front) (n+1) ineqs
nipkow@13464
   423
  in elim_neq [] 0 items end;
nipkow@13464
   424
nipkow@13464
   425
fun mklineqss(pTs,items) =
nipkow@13464
   426
let
nipkow@13464
   427
  fun mklineqs(ineqs) =
nipkow@13464
   428
  let
nipkow@13464
   429
    fun add(ats,((lhs,_,_,rhs,_,_),_)) =
nipkow@13464
   430
             (map fst lhs) union ((map fst rhs) union ats)
nipkow@13464
   431
    val atoms = foldl add ([],ineqs)
nipkow@13464
   432
    val mkleq = mklineq atoms
nipkow@13464
   433
    val ixs = 0 upto (length(atoms)-1)
nipkow@13464
   434
    val iatoms = atoms ~~ ixs
nipkow@13464
   435
    val natlineqs = mapfilter (mknat pTs ixs) iatoms
nipkow@13464
   436
  in map mkleq ineqs @ natlineqs end
nipkow@13464
   437
nipkow@13464
   438
in map mklineqs (split_items items) end;
nipkow@13464
   439
nipkow@13464
   440
(*
nipkow@13186
   441
fun mklineqss(pTs,items) =
nipkow@13186
   442
  let fun add(ats,None) = ats
nipkow@13186
   443
        | add(ats,Some(lhs,_,_,rhs,_,_)) =
nipkow@13186
   444
             (map fst lhs) union ((map fst rhs) union ats)
nipkow@13186
   445
      val atoms = foldl add ([],items)
nipkow@13186
   446
      val mkleq = mklineq atoms
nipkow@6056
   447
      val ixs = 0 upto (length(atoms)-1)
nipkow@6056
   448
      val iatoms = atoms ~~ ixs
nipkow@13186
   449
      val natlineqs = mapfilter (mknat pTs ixs) iatoms
nipkow@13186
   450
 
nipkow@13186
   451
      fun elim_neq front _ [] = [front]
nipkow@13186
   452
        | elim_neq front n (None::ineqs) = elim_neq front (n+1) ineqs
nipkow@13186
   453
        | elim_neq front n (Some(ineq as (l,i,rel,r,j,d))::ineqs) =
nipkow@13186
   454
          if rel = "~=" then elim_neq front n (ineqs @ [Some(l,i,"<",r,j,d)]) @
nipkow@13186
   455
                             elim_neq front n (ineqs @ [Some(r,j,"<",l,i,d)])
nipkow@13186
   456
          else elim_neq (mkleq(ineq,n) :: front) (n+1) ineqs
nipkow@5982
   457
nipkow@13186
   458
  in elim_neq natlineqs 0 items end;
nipkow@13464
   459
*)
nipkow@6074
   460
nipkow@13186
   461
fun elim_all (ineqs::ineqss) js =
nipkow@13464
   462
  (case elim ineqs of None => (trace_msg "No contradiction!"; None)
nipkow@13464
   463
   | Some(Lineq(_,_,_,j)) => (trace_msg "Contradiction!";
nipkow@13464
   464
                              elim_all ineqss (js@[j])))
nipkow@13186
   465
  | elim_all [] js = Some js
nipkow@13186
   466
nipkow@13186
   467
fun refute(pTsitems) = elim_all (mklineqss pTsitems) [];
nipkow@13186
   468
nipkow@13186
   469
fun refute_tac(i,justs) =
nipkow@6074
   470
  fn state =>
nipkow@6074
   471
    let val sg = #sign(rep_thm state)
nipkow@13186
   472
        fun just1 j = REPEAT_DETERM(etac LA_Logic.neqE i) THEN
nipkow@13186
   473
                      METAHYPS (fn asms => rtac (mkthm sg asms j) 1) i
nipkow@13186
   474
    in DETERM(resolve_tac [LA_Logic.notI,LA_Logic.ccontr] i) THEN
nipkow@13186
   475
       EVERY(map just1 justs)
nipkow@6074
   476
    end
nipkow@6074
   477
    state;
nipkow@6074
   478
wenzelm@9420
   479
fun prove sg (pTs,Hs,concl) =
nipkow@13186
   480
let val Hitems = map (LA_Data.decomp sg) Hs
wenzelm@9420
   481
in case LA_Data.decomp sg concl of
nipkow@13186
   482
     None => refute(pTs,Hitems@[None])
nipkow@7551
   483
   | Some(citem as (r,i,rel,l,j,d)) =>
nipkow@13186
   484
       let val neg::rel0 = explode rel
nipkow@13186
   485
           val nrel = if neg = "~" then implode rel0 else "~"^rel
nipkow@13186
   486
       in refute(pTs, Hitems @ [Some(r,i,nrel,l,j,d)]) end
nipkow@6074
   487
end;
nipkow@5982
   488
nipkow@5982
   489
(*
nipkow@5982
   490
Fast but very incomplete decider. Only premises and conclusions
nipkow@5982
   491
that are already (negated) (in)equations are taken into account.
nipkow@5982
   492
*)
nipkow@13186
   493
fun lin_arith_tac i st = SUBGOAL (fn (A,_) =>
nipkow@6056
   494
  let val pTs = rev(map snd (Logic.strip_params A))
nipkow@6056
   495
      val Hs = Logic.strip_assums_hyp A
nipkow@6074
   496
      val concl = Logic.strip_assums_concl A
nipkow@12932
   497
  in trace_thm ("Trying to refute subgoal " ^ string_of_int i) st;
nipkow@12932
   498
     case prove (Thm.sign_of_thm st) (pTs,Hs,concl) of
nipkow@13464
   499
       None => (trace_msg "Refutation failed."; no_tac)
nipkow@13464
   500
     | Some js => (trace_msg "Refutation succeeded."; refute_tac(i,js))
wenzelm@9420
   501
  end) i st;
nipkow@5982
   502
nipkow@5982
   503
fun cut_lin_arith_tac thms i = cut_facts_tac thms i THEN lin_arith_tac i;
nipkow@5982
   504
nipkow@13186
   505
(** Forward proof from theorems **)
nipkow@13186
   506
nipkow@13186
   507
(* More tricky code. Needs to arrange the proofs of the multiple cases (due
nipkow@13186
   508
to splits of ~= premises) such that it coincides with the order of the cases
nipkow@13186
   509
generated by function mklineqss. *)
nipkow@13186
   510
nipkow@13186
   511
datatype splittree = Tip of thm list
nipkow@13186
   512
                   | Spl of thm * cterm * splittree * cterm * splittree
nipkow@13186
   513
nipkow@13186
   514
fun extract imp =
nipkow@13186
   515
let val (Il,r) = Thm.dest_comb imp
nipkow@13186
   516
    val (_,imp1) = Thm.dest_comb Il
nipkow@13186
   517
    val (Ict1,_) = Thm.dest_comb imp1
nipkow@13186
   518
    val (_,ct1) = Thm.dest_comb Ict1
nipkow@13186
   519
    val (Ir,_) = Thm.dest_comb r
nipkow@13186
   520
    val (_,Ict2r) = Thm.dest_comb Ir
nipkow@13186
   521
    val (Ict2,_) = Thm.dest_comb Ict2r
nipkow@13186
   522
    val (_,ct2) = Thm.dest_comb Ict2
nipkow@13186
   523
in (ct1,ct2) end;
nipkow@6074
   524
nipkow@13186
   525
fun splitasms asms =
nipkow@13186
   526
let fun split(asms',[]) = Tip(rev asms')
nipkow@13186
   527
      | split(asms',asm::asms) =
nipkow@13186
   528
      let val spl = asm COMP LA_Logic.neqE
nipkow@13186
   529
          val (ct1,ct2) = extract(cprop_of spl)
nipkow@13186
   530
          val thm1 = assume ct1 and thm2 = assume ct2
nipkow@13186
   531
      in Spl(spl,ct1,split(asms',asms@[thm1]),ct2,split(asms',asms@[thm2])) end
nipkow@13186
   532
      handle THM _ => split(asm::asms', asms)
nipkow@13186
   533
in split([],asms) end;
nipkow@6074
   534
nipkow@13186
   535
fun fwdproof sg (Tip asms) (j::js) = (mkthm sg asms j, js)
nipkow@13186
   536
  | fwdproof sg (Spl(thm,ct1,tree1,ct2,tree2)) js =
nipkow@13186
   537
    let val (thm1,js1) = fwdproof sg tree1 js
nipkow@13186
   538
        val (thm2,js2) = fwdproof sg tree2 js1
nipkow@13186
   539
        val thm1' = implies_intr ct1 thm1
nipkow@13186
   540
        val thm2' = implies_intr ct2 thm2
nipkow@13186
   541
    in (thm2' COMP (thm1' COMP thm), js2) end;
nipkow@13186
   542
(* needs handle _ => None ? *)
nipkow@13186
   543
nipkow@13186
   544
fun prover sg thms Tconcl js pos =
nipkow@13186
   545
let val nTconcl = LA_Logic.neg_prop Tconcl
nipkow@13186
   546
    val cnTconcl = cterm_of sg nTconcl
nipkow@13186
   547
    val nTconclthm = assume cnTconcl
nipkow@13186
   548
    val tree = splitasms (thms @ [nTconclthm])
nipkow@13186
   549
    val (thm,_) = fwdproof sg tree js
nipkow@13186
   550
    val contr = if pos then LA_Logic.ccontr else LA_Logic.notI
nipkow@13186
   551
in Some(LA_Logic.mk_Eq((implies_intr cnTconcl thm) COMP contr)) end
nipkow@13186
   552
(* in case concl contains ?-var, which makes assume fail: *)
nipkow@13186
   553
handle THM _ => None;
nipkow@13186
   554
nipkow@13186
   555
(* PRE: concl is not negated!
nipkow@13186
   556
   This assumption is OK because
nipkow@13186
   557
   1. lin_arith_prover tries both to prove and disprove concl and
nipkow@13186
   558
   2. lin_arith_prover is applied by the simplifier which
nipkow@13186
   559
      dives into terms and will thus try the non-negated concl anyway.
nipkow@13186
   560
*)
nipkow@6074
   561
fun lin_arith_prover sg thms concl =
nipkow@6074
   562
let val Hs = map (#prop o rep_thm) thms
nipkow@6102
   563
    val Tconcl = LA_Logic.mk_Trueprop concl
nipkow@13186
   564
in case prove sg ([],Hs,Tconcl) of (* concl provable? *)
nipkow@13186
   565
     Some js => prover sg thms Tconcl js true
nipkow@13186
   566
   | None => let val nTconcl = LA_Logic.neg_prop Tconcl
nipkow@13186
   567
          in case prove sg ([],Hs,nTconcl) of (* ~concl provable? *)
nipkow@13186
   568
               Some js => prover sg thms nTconcl js false
nipkow@13186
   569
             | None => None
nipkow@6079
   570
          end
nipkow@5982
   571
end;
nipkow@6074
   572
nipkow@6074
   573
end;