src/Provers/Arith/fast_lin_arith.ML
author paulson
Fri Jun 16 13:13:55 2000 +0200 (2000-06-16)
changeset 9073 40d8dfac96b8
parent 8263 699d4ad2ced3
child 9420 d4e9f60fe25a
permissions -rw-r--r--
tracing flag for arith_tac
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 add_mono_thms:    thm list ref
nipkow@5982
    56
                            (* [| i rel1 j; m rel2 n |] ==> i + m rel3 j + n *)
nipkow@6128
    57
  val lessD:            thm list ref (* m < n ==> m+1 <= n *)
nipkow@6128
    58
  val decomp:
nipkow@7582
    59
    term -> ((term*int)list * int * string * (term*int)list * int * bool)option
nipkow@7582
    60
  val ss_ref: simpset ref
nipkow@5982
    61
end;
nipkow@5982
    62
(*
nipkow@7551
    63
decomp(`x Rel y') should yield (p,i,Rel,q,j,d)
nipkow@5982
    64
   where Rel is one of "<", "~<", "<=", "~<=" and "=" and
nipkow@5982
    65
         p/q is the decomposition of the sum terms x/y into a list
nipkow@7551
    66
         of summand * multiplicity pairs and a constant summand and
nipkow@7551
    67
         d indicates if the domain is discrete.
nipkow@5982
    68
nipkow@7582
    69
ss_ref must reduce contradictory <= to False.
nipkow@5982
    70
   It should also cancel common summands to keep <= reduced;
nipkow@5982
    71
   otherwise <= can grow to massive proportions.
nipkow@5982
    72
*)
nipkow@5982
    73
nipkow@6062
    74
signature FAST_LIN_ARITH =
nipkow@6062
    75
sig
paulson@9073
    76
  val trace           : bool ref
nipkow@6074
    77
  val lin_arith_prover: Sign.sg -> thm list -> term -> thm option
nipkow@6062
    78
  val     lin_arith_tac:             int -> tactic
nipkow@6062
    79
  val cut_lin_arith_tac: thm list -> int -> tactic
nipkow@6062
    80
end;
nipkow@6062
    81
nipkow@6102
    82
functor Fast_Lin_Arith(structure LA_Logic:LIN_ARITH_LOGIC 
nipkow@6102
    83
                       and       LA_Data:LIN_ARITH_DATA) : FAST_LIN_ARITH =
nipkow@5982
    84
struct
nipkow@5982
    85
nipkow@5982
    86
(*** A fast decision procedure ***)
nipkow@5982
    87
(*** Code ported from HOL Light ***)
nipkow@6056
    88
(* possible optimizations:
nipkow@6056
    89
   use (var,coeff) rep or vector rep  tp save space;
nipkow@6056
    90
   treat non-negative atoms separately rather than adding 0 <= atom
nipkow@6056
    91
*)
nipkow@5982
    92
paulson@9073
    93
val trace = ref false;
paulson@9073
    94
nipkow@5982
    95
datatype lineq_type = Eq | Le | Lt;
nipkow@5982
    96
nipkow@6056
    97
datatype injust = Asm of int
nipkow@6056
    98
                | Nat of int (* index of atom *)
nipkow@6128
    99
                | LessD of injust
nipkow@6128
   100
                | NotLessD of injust
nipkow@6128
   101
                | NotLeD of injust
nipkow@7551
   102
                | NotLeDD of injust
nipkow@5982
   103
                | Multiplied of int * injust
nipkow@5982
   104
                | Added of injust * injust;
nipkow@5982
   105
nipkow@5982
   106
datatype lineq = Lineq of int * lineq_type * int list * injust;
nipkow@5982
   107
nipkow@5982
   108
(* ------------------------------------------------------------------------- *)
nipkow@5982
   109
(* Calculate new (in)equality type after addition.                           *)
nipkow@5982
   110
(* ------------------------------------------------------------------------- *)
nipkow@5982
   111
nipkow@5982
   112
fun find_add_type(Eq,x) = x
nipkow@5982
   113
  | find_add_type(x,Eq) = x
nipkow@5982
   114
  | find_add_type(_,Lt) = Lt
nipkow@5982
   115
  | find_add_type(Lt,_) = Lt
nipkow@5982
   116
  | find_add_type(Le,Le) = Le;
nipkow@5982
   117
nipkow@5982
   118
(* ------------------------------------------------------------------------- *)
nipkow@5982
   119
(* Multiply out an (in)equation.                                             *)
nipkow@5982
   120
(* ------------------------------------------------------------------------- *)
nipkow@5982
   121
nipkow@5982
   122
fun multiply_ineq n (i as Lineq(k,ty,l,just)) =
nipkow@5982
   123
  if n = 1 then i
nipkow@5982
   124
  else if n = 0 andalso ty = Lt then sys_error "multiply_ineq"
nipkow@5982
   125
  else if n < 0 andalso (ty=Le orelse ty=Lt) then sys_error "multiply_ineq"
nipkow@5982
   126
  else Lineq(n * k,ty,map (apl(n,op * )) l,Multiplied(n,just));
nipkow@5982
   127
nipkow@5982
   128
(* ------------------------------------------------------------------------- *)
nipkow@5982
   129
(* Add together (in)equations.                                               *)
nipkow@5982
   130
(* ------------------------------------------------------------------------- *)
nipkow@5982
   131
nipkow@5982
   132
fun add_ineq (i1 as Lineq(k1,ty1,l1,just1)) (i2 as Lineq(k2,ty2,l2,just2)) =
nipkow@5982
   133
  let val l = map2 (op +) (l1,l2)
nipkow@5982
   134
  in Lineq(k1+k2,find_add_type(ty1,ty2),l,Added(just1,just2)) end;
nipkow@5982
   135
nipkow@5982
   136
(* ------------------------------------------------------------------------- *)
nipkow@5982
   137
(* Elimination of variable between a single pair of (in)equations.           *)
nipkow@5982
   138
(* If they're both inequalities, 1st coefficient must be +ve, 2nd -ve.       *)
nipkow@5982
   139
(* ------------------------------------------------------------------------- *)
nipkow@5982
   140
nipkow@5982
   141
fun gcd x y =
nipkow@5982
   142
  let fun gxd x y =
nipkow@5982
   143
    if y = 0 then x else gxd y (x mod y)
nipkow@5982
   144
  in if x < y then gxd y x else gxd x y end;
nipkow@5982
   145
nipkow@5982
   146
fun lcm x y = (x * y) div gcd x y;
nipkow@5982
   147
nipkow@5982
   148
fun el 0 (h::_) = h
nipkow@5982
   149
  | el n (_::t) = el (n - 1) t
nipkow@5982
   150
  | el _ _  = sys_error "el";
nipkow@5982
   151
nipkow@5982
   152
fun elim_var v (i1 as Lineq(k1,ty1,l1,just1)) (i2 as Lineq(k2,ty2,l2,just2)) =
nipkow@5982
   153
  let val c1 = el v l1 and c2 = el v l2
nipkow@5982
   154
      val m = lcm (abs c1) (abs c2)
nipkow@5982
   155
      val m1 = m div (abs c1) and m2 = m div (abs c2)
nipkow@5982
   156
      val (n1,n2) =
nipkow@5982
   157
        if (c1 >= 0) = (c2 >= 0)
nipkow@5982
   158
        then if ty1 = Eq then (~m1,m2)
nipkow@5982
   159
             else if ty2 = Eq then (m1,~m2)
nipkow@5982
   160
                  else sys_error "elim_var"
nipkow@5982
   161
        else (m1,m2)
nipkow@5982
   162
      val (p1,p2) = if ty1=Eq andalso ty2=Eq andalso (n1 = ~1 orelse n2 = ~1)
nipkow@5982
   163
                    then (~n1,~n2) else (n1,n2)
nipkow@5982
   164
  in add_ineq (multiply_ineq n1 i1) (multiply_ineq n2 i2) end;
nipkow@5982
   165
nipkow@5982
   166
(* ------------------------------------------------------------------------- *)
nipkow@5982
   167
(* The main refutation-finding code.                                         *)
nipkow@5982
   168
(* ------------------------------------------------------------------------- *)
nipkow@5982
   169
nipkow@5982
   170
fun is_trivial (Lineq(_,_,l,_)) = forall (fn i => i=0) l;
nipkow@5982
   171
nipkow@5982
   172
fun is_answer (ans as Lineq(k,ty,l,_)) =
nipkow@5982
   173
  case ty  of Eq => k <> 0 | Le => k > 0 | Lt => k >= 0;
nipkow@5982
   174
nipkow@5982
   175
fun calc_blowup l =
nipkow@5982
   176
  let val (p,n) = partition (apl(0,op<)) (filter (apl(0,op<>)) l)
nipkow@5982
   177
  in (length p) * (length n) end;
nipkow@5982
   178
nipkow@5982
   179
(* ------------------------------------------------------------------------- *)
nipkow@5982
   180
(* Main elimination code:                                                    *)
nipkow@5982
   181
(*                                                                           *)
nipkow@5982
   182
(* (1) Looks for immediate solutions (false assertions with no variables).   *)
nipkow@5982
   183
(*                                                                           *)
nipkow@5982
   184
(* (2) If there are any equations, picks a variable with the lowest absolute *)
nipkow@5982
   185
(* coefficient in any of them, and uses it to eliminate.                     *)
nipkow@5982
   186
(*                                                                           *)
nipkow@5982
   187
(* (3) Otherwise, chooses a variable in the inequality to minimize the       *)
nipkow@5982
   188
(* blowup (number of consequences generated) and eliminates it.              *)
nipkow@5982
   189
(* ------------------------------------------------------------------------- *)
nipkow@5982
   190
nipkow@5982
   191
fun allpairs f xs ys =
nipkow@5982
   192
  flat(map (fn x => map (fn y => f x y) ys) xs);
nipkow@5982
   193
nipkow@5982
   194
fun extract_first p =
nipkow@5982
   195
  let fun extract xs (y::ys) = if p y then (Some y,xs@ys)
nipkow@5982
   196
                               else extract (y::xs) ys
nipkow@5982
   197
        | extract xs []      = (None,xs)
nipkow@5982
   198
  in extract [] end;
nipkow@5982
   199
nipkow@6056
   200
fun print_ineqs ineqs =
paulson@9073
   201
  if !trace then
paulson@9073
   202
     writeln(cat_lines(""::map (fn Lineq(c,t,l,_) =>
paulson@9073
   203
       string_of_int c ^
paulson@9073
   204
       (case t of Eq => " =  " | Lt=> " <  " | Le => " <= ") ^
paulson@9073
   205
       commas(map string_of_int l)) ineqs))
paulson@9073
   206
  else ();
nipkow@6056
   207
nipkow@5982
   208
fun elim ineqs =
paulson@9073
   209
  let val dummy = print_ineqs ineqs;
nipkow@6056
   210
      val (triv,nontriv) = partition is_trivial ineqs in
nipkow@5982
   211
  if not(null triv)
nipkow@5982
   212
  then case find_first is_answer triv of
nipkow@5982
   213
         None => elim nontriv | some => some
nipkow@5982
   214
  else
nipkow@5982
   215
  if null nontriv then None else
nipkow@5982
   216
  let val (eqs,noneqs) = partition (fn (Lineq(_,ty,_,_)) => ty=Eq) nontriv in
nipkow@5982
   217
  if not(null eqs) then
nipkow@5982
   218
     let val clist = foldl (fn (cs,Lineq(_,_,l,_)) => l union cs) ([],eqs)
nipkow@5982
   219
         val sclist = sort (fn (x,y) => int_ord(abs(x),abs(y)))
nipkow@5982
   220
                           (filter (fn i => i<>0) clist)
nipkow@5982
   221
         val c = hd sclist
nipkow@5982
   222
         val (Some(eq as Lineq(_,_,ceq,_)),othereqs) =
nipkow@5982
   223
               extract_first (fn Lineq(_,_,l,_) => c mem l) eqs
nipkow@5982
   224
         val v = find_index (fn k => k=c) ceq
nipkow@5982
   225
         val (ioth,roth) = partition (fn (Lineq(_,_,l,_)) => el v l = 0)
nipkow@5982
   226
                                     (othereqs @ noneqs)
nipkow@5982
   227
         val others = map (elim_var v eq) roth @ ioth
nipkow@5982
   228
     in elim others end
nipkow@5982
   229
  else
nipkow@5982
   230
  let val lists = map (fn (Lineq(_,_,l,_)) => l) noneqs
nipkow@5982
   231
      val numlist = 0 upto (length(hd lists) - 1)
nipkow@5982
   232
      val coeffs = map (fn i => map (el i) lists) numlist
nipkow@5982
   233
      val blows = map calc_blowup coeffs
nipkow@5982
   234
      val iblows = blows ~~ numlist
nipkow@5982
   235
      val nziblows = filter (fn (i,_) => i<>0) iblows
nipkow@5982
   236
  in if null nziblows then None else
nipkow@5982
   237
     let val (c,v) = hd(sort (fn (x,y) => int_ord(fst(x),fst(y))) nziblows)
nipkow@5982
   238
         val (no,yes) = partition (fn (Lineq(_,_,l,_)) => el v l = 0) ineqs
nipkow@5982
   239
         val (pos,neg) = partition(fn (Lineq(_,_,l,_)) => el v l > 0) yes
nipkow@5982
   240
     in elim (no @ allpairs (elim_var v) pos neg) end
nipkow@5982
   241
  end
nipkow@5982
   242
  end
nipkow@5982
   243
  end;
nipkow@5982
   244
nipkow@5982
   245
(* ------------------------------------------------------------------------- *)
nipkow@5982
   246
(* Translate back a proof.                                                   *)
nipkow@5982
   247
(* ------------------------------------------------------------------------- *)
nipkow@5982
   248
paulson@9073
   249
fun trace_thm msg th = 
paulson@9073
   250
    if !trace then (writeln msg; prth th) else th;
paulson@9073
   251
paulson@9073
   252
fun trace_msg msg = 
paulson@9073
   253
    if !trace then writeln msg else ();
paulson@9073
   254
nipkow@6056
   255
(* FIXME OPTIMIZE!!!!
nipkow@6056
   256
   Addition/Multiplication need i*t representation rather than t+t+...
nipkow@6056
   257
nipkow@6056
   258
Simplification may detect a contradiction 'prematurely' due to type
nipkow@6056
   259
information: n+1 <= 0 is simplified to False and does not need to be crossed
nipkow@6056
   260
with 0 <= n.
nipkow@6056
   261
*)
nipkow@6056
   262
local
nipkow@6056
   263
 exception FalseE of thm
nipkow@6056
   264
in
nipkow@6074
   265
fun mkthm sg asms just =
nipkow@7551
   266
  let val atoms = foldl (fn (ats,(lhs,_,_,rhs,_,_)) =>
nipkow@6056
   267
                            map fst lhs  union  (map fst rhs  union  ats))
nipkow@7551
   268
                        ([], mapfilter (LA_Data.decomp o concl_of) asms)
nipkow@6056
   269
nipkow@6056
   270
      fun addthms thm1 thm2 =
nipkow@6102
   271
        let val conj = thm1 RS (thm2 RS LA_Logic.conjI)
nipkow@5982
   272
        in the(get_first (fn th => Some(conj RS th) handle _ => None)
nipkow@6128
   273
                         (!LA_Data.add_mono_thms))
nipkow@5982
   274
        end;
nipkow@5982
   275
nipkow@5982
   276
      fun multn(n,thm) =
nipkow@5982
   277
        let fun mul(i,th) = if i=1 then th else mul(i-1, addthms thm th)
nipkow@6102
   278
        in if n < 0 then mul(~n,thm) RS LA_Logic.sym else mul(n,thm) end;
nipkow@5982
   279
nipkow@6056
   280
      fun simp thm =
nipkow@7582
   281
        let val thm' = simplify (!LA_Data.ss_ref) thm
nipkow@6102
   282
        in if LA_Logic.is_False thm' then raise FalseE thm' else thm' end
nipkow@6056
   283
paulson@9073
   284
      fun mk(Asm i) = trace_thm "Asm" (nth_elem(i,asms))
paulson@9073
   285
        | mk(Nat(i)) = (trace_msg "Nat";
paulson@9073
   286
			LA_Logic.mk_nat_thm sg (nth_elem(i,atoms)))
paulson@9073
   287
        | mk(LessD(j)) = trace_thm "L" (hd([mk j] RL !LA_Data.lessD))
paulson@9073
   288
        | mk(NotLeD(j)) = trace_thm "NLe" (mk j RS LA_Logic.not_leD)
paulson@9073
   289
        | mk(NotLeDD(j)) = trace_thm "NLeD" (hd([mk j RS LA_Logic.not_leD] RL 
paulson@9073
   290
						!LA_Data.lessD))
paulson@9073
   291
        | mk(NotLessD(j)) = trace_thm "NL" (mk j RS LA_Logic.not_lessD)
paulson@9073
   292
        | mk(Added(j1,j2)) = simp (trace_thm "+" (addthms (mk j1) (mk j2)))
paulson@9073
   293
        | mk(Multiplied(n,j)) = (trace_msg "*"; multn(n,mk j))
nipkow@5982
   294
paulson@9073
   295
  in trace_msg "mkthm";
nipkow@7582
   296
     simplify (!LA_Data.ss_ref) (mk just) handle FalseE thm => thm end
nipkow@6056
   297
end;
nipkow@5982
   298
nipkow@5982
   299
fun coeff poly atom = case assoc(poly,atom) of None => 0 | Some i => i;
nipkow@5982
   300
nipkow@5982
   301
fun mklineq atoms =
nipkow@5982
   302
  let val n = length atoms in
nipkow@7551
   303
    fn ((lhs,i,rel,rhs,j,discrete),k) =>
nipkow@5982
   304
    let val lhsa = map (coeff lhs) atoms
nipkow@5982
   305
        and rhsa = map (coeff rhs) atoms
nipkow@5982
   306
        val diff = map2 (op -) (rhsa,lhsa)
nipkow@5982
   307
        val c = i-j
nipkow@6056
   308
        val just = Asm k
nipkow@5982
   309
    in case rel of
nipkow@5982
   310
        "<="   => Some(Lineq(c,Le,diff,just))
nipkow@7551
   311
       | "~<=" => if discrete
nipkow@7551
   312
                  then Some(Lineq(1-c,Le,map (op ~) diff,NotLeDD(just)))
nipkow@7551
   313
                  else Some(Lineq(~c,Lt,map (op ~) diff,NotLeD(just)))
nipkow@7551
   314
       | "<"   => if discrete
nipkow@7551
   315
                  then Some(Lineq(c+1,Le,diff,LessD(just)))
nipkow@7551
   316
                  else Some(Lineq(c,Lt,diff,just))
nipkow@6128
   317
       | "~<"  => Some(Lineq(~c,Le,map (op~) diff,NotLessD(just)))
nipkow@5982
   318
       | "="   => Some(Lineq(c,Eq,diff,just))
nipkow@5982
   319
       | "~="  => None
nipkow@5982
   320
       | _     => sys_error("mklineq" ^ rel)   
nipkow@5982
   321
    end
nipkow@5982
   322
  end;
nipkow@5982
   323
nipkow@6056
   324
fun mknat pTs ixs (atom,i) =
nipkow@6128
   325
  if LA_Logic.is_nat(pTs,atom)
nipkow@6056
   326
  then let val l = map (fn j => if j=i then 1 else 0) ixs
nipkow@6056
   327
       in Some(Lineq(0,Le,l,Nat(i))) end
nipkow@6056
   328
  else None
nipkow@6056
   329
nipkow@6056
   330
fun abstract pTs items =
nipkow@7551
   331
  let val atoms = foldl (fn (ats,((lhs,_,_,rhs,_,_),_)) =>
nipkow@5982
   332
                            (map fst lhs) union ((map fst rhs) union ats))
nipkow@5982
   333
                        ([],items)
nipkow@6056
   334
      val ixs = 0 upto (length(atoms)-1)
nipkow@6056
   335
      val iatoms = atoms ~~ ixs
nipkow@6056
   336
  in mapfilter (mklineq atoms) items @ mapfilter (mknat pTs ixs) iatoms end;
nipkow@5982
   337
nipkow@5982
   338
(* Ordinary refutation *)
nipkow@6074
   339
fun refute1(pTs,items) =
nipkow@6074
   340
  (case elim (abstract pTs items) of
nipkow@6074
   341
       None => []
nipkow@6074
   342
     | Some(Lineq(_,_,_,j)) => [j]);
nipkow@6074
   343
nipkow@6074
   344
fun refute1_tac(i,just) =
nipkow@6074
   345
  fn state =>
nipkow@6074
   346
    let val sg = #sign(rep_thm state)
nipkow@6102
   347
    in resolve_tac [LA_Logic.notI,LA_Logic.ccontr] i THEN
nipkow@6074
   348
       METAHYPS (fn asms => rtac (mkthm sg asms just) 1) i
nipkow@6074
   349
    end
nipkow@6074
   350
    state;
nipkow@5982
   351
nipkow@5982
   352
(* Double refutation caused by equality in conclusion *)
nipkow@7551
   353
fun refute2(pTs,items, (rhs,i,_,lhs,j,d), nHs) =
nipkow@7551
   354
  (case elim (abstract pTs (items@[((rhs,i,"<",lhs,j,d),nHs)])) of
nipkow@6074
   355
    None => []
nipkow@5982
   356
  | Some(Lineq(_,_,_,j1)) =>
nipkow@7551
   357
      (case elim (abstract pTs (items@[((lhs,j,"<",rhs,i,d),nHs)])) of
nipkow@6074
   358
        None => []
nipkow@6074
   359
      | Some(Lineq(_,_,_,j2)) => [j1,j2]));
nipkow@6074
   360
nipkow@6074
   361
fun refute2_tac(i,just1,just2) =
nipkow@6074
   362
  fn state => 
nipkow@6074
   363
    let val sg = #sign(rep_thm state)
nipkow@6102
   364
    in rtac LA_Logic.ccontr i THEN rotate_tac ~1 i THEN etac LA_Logic.neqE i THEN
nipkow@6074
   365
       METAHYPS (fn asms => rtac (mkthm sg asms just1) 1) i THEN
nipkow@6074
   366
       METAHYPS (fn asms => rtac (mkthm sg asms just2) 1) i
nipkow@6074
   367
    end
nipkow@6074
   368
    state;
nipkow@6074
   369
nipkow@6074
   370
fun prove(pTs,Hs,concl) =
nipkow@6074
   371
let val nHs = length Hs
nipkow@6074
   372
    val ixHs = Hs ~~ (0 upto (nHs-1))
nipkow@7551
   373
    val Hitems = mapfilter (fn (h,i) => case LA_Data.decomp h of
nipkow@6074
   374
                                 None => None | Some(it) => Some(it,i)) ixHs
nipkow@7551
   375
in case LA_Data.decomp concl of
nipkow@6074
   376
     None => if null Hitems then [] else refute1(pTs,Hitems)
nipkow@7551
   377
   | Some(citem as (r,i,rel,l,j,d)) =>
nipkow@6074
   378
       if rel = "="
nipkow@6074
   379
       then refute2(pTs,Hitems,citem,nHs)
nipkow@6074
   380
       else let val neg::rel0 = explode rel
nipkow@6074
   381
                val nrel = if neg = "~" then implode rel0 else "~"^rel
nipkow@7551
   382
            in refute1(pTs, Hitems@[((r,i,nrel,l,j,d),nHs)]) end
nipkow@6074
   383
end;
nipkow@5982
   384
nipkow@5982
   385
(*
nipkow@5982
   386
Fast but very incomplete decider. Only premises and conclusions
nipkow@5982
   387
that are already (negated) (in)equations are taken into account.
nipkow@5982
   388
*)
nipkow@5982
   389
val lin_arith_tac = SUBGOAL (fn (A,n) =>
nipkow@6056
   390
  let val pTs = rev(map snd (Logic.strip_params A))
nipkow@6056
   391
      val Hs = Logic.strip_assums_hyp A
nipkow@6074
   392
      val concl = Logic.strip_assums_concl A
nipkow@6074
   393
  in case prove(pTs,Hs,concl) of
nipkow@6074
   394
       [j] => refute1_tac(n,j)
nipkow@6074
   395
     | [j1,j2] => refute2_tac(n,j1,j2)
nipkow@6074
   396
     | _ => no_tac
nipkow@5982
   397
  end);
nipkow@5982
   398
nipkow@5982
   399
fun cut_lin_arith_tac thms i = cut_facts_tac thms i THEN lin_arith_tac i;
nipkow@5982
   400
nipkow@6079
   401
fun prover1(just,sg,thms,concl,pos) =
nipkow@6102
   402
let val nconcl = LA_Logic.neg_prop concl
nipkow@6074
   403
    val cnconcl = cterm_of sg nconcl
nipkow@6074
   404
    val Fthm = mkthm sg (thms @ [assume cnconcl]) just
nipkow@6102
   405
    val contr = if pos then LA_Logic.ccontr else LA_Logic.notI
nipkow@6102
   406
in Some(LA_Logic.mk_Eq ((implies_intr cnconcl Fthm) COMP contr)) end
nipkow@6074
   407
handle _ => None;
nipkow@6074
   408
nipkow@6074
   409
(* handle thm with equality conclusion *)
nipkow@6074
   410
fun prover2(just1,just2,sg,thms,concl) =
nipkow@6102
   411
let val nconcl = LA_Logic.neg_prop concl (* m ~= n *)
nipkow@6074
   412
    val cnconcl = cterm_of sg nconcl
nipkow@6074
   413
    val neqthm = assume cnconcl
nipkow@6102
   414
    val casethm = neqthm COMP LA_Logic.neqE (* [|m<n ==> R; n<m ==> R|] ==> R *)
nipkow@6074
   415
    val [lessimp1,lessimp2] = prems_of casethm
nipkow@6074
   416
    val less1 = fst(Logic.dest_implies lessimp1) (* m<n *)
nipkow@6074
   417
    and less2 = fst(Logic.dest_implies lessimp2) (* n<m *)
nipkow@6074
   418
    val cless1 = cterm_of sg less1 and cless2 = cterm_of sg less2
nipkow@6074
   419
    val thm1 = mkthm sg (thms @ [assume cless1]) just1
nipkow@6074
   420
    and thm2 = mkthm sg (thms @ [assume cless2]) just2
nipkow@6074
   421
    val dthm1 = implies_intr cless1 thm1 and dthm2 = implies_intr cless2 thm2
nipkow@6074
   422
    val thm = dthm2 COMP (dthm1 COMP casethm)
nipkow@6102
   423
in Some(LA_Logic.mk_Eq ((implies_intr cnconcl thm) COMP LA_Logic.ccontr)) end
nipkow@6074
   424
handle _ => None;
nipkow@6074
   425
nipkow@6079
   426
(* PRE: concl is not negated! *)
nipkow@6074
   427
fun lin_arith_prover sg thms concl =
nipkow@6074
   428
let val Hs = map (#prop o rep_thm) thms
nipkow@6102
   429
    val Tconcl = LA_Logic.mk_Trueprop concl
nipkow@6074
   430
in case prove([],Hs,Tconcl) of
nipkow@6079
   431
     [j] => prover1(j,sg,thms,Tconcl,true)
nipkow@6074
   432
   | [j1,j2] => prover2(j1,j2,sg,thms,Tconcl)
nipkow@6102
   433
   | _ => let val nTconcl = LA_Logic.neg_prop Tconcl
nipkow@6079
   434
          in case prove([],Hs,nTconcl) of
nipkow@6079
   435
               [j] => prover1(j,sg,thms,nTconcl,false)
nipkow@6079
   436
               (* [_,_] impossible because of negation *)
nipkow@6079
   437
             | _ => None
nipkow@6079
   438
          end
nipkow@5982
   439
end;
nipkow@6074
   440
nipkow@6074
   441
end;