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