author  wenzelm 
Sun, 15 Oct 2000 19:50:35 +0200  
changeset 10220  2a726de6e124 
parent 9420  d4e9f60fe25a 
child 10575  c78d26d5c3c1 
permissions  rwrr 
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  6 
A generic linear arithmetic package. 
6102  7 
It provides two tactics 
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  11 

12 
and a simplification procedure 

13 

14 
lin_arith_prover: Sign.sg > thm list > term > thm option 

15 

16 
Only take premises and conclusions into account that are already (negated) 

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  20 
(* Debugging: set Fast_Arith.trace *) 
7582  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  24 
signature LIN_ARITH_LOGIC = 
25 
sig 

26 
val conjI: thm 

27 
val ccontr: thm (* (~ P ==> False) ==> P *) 

28 
val neqE: thm (* [ m ~= n; m < n ==> P; n < m ==> P ] ==> P *) 

29 
val notI: thm (* (P ==> False) ==> ~ P *) 

6110  30 
val not_lessD: thm (* ~(m < n) ==> n <= m *) 
6128  31 
val not_leD: thm (* ~(m <= n) ==> n < m *) 
6102  32 
val sym: thm (* x = y ==> y = x *) 
33 
val mk_Eq: thm > thm 

34 
val mk_Trueprop: term > term 

35 
val neg_prop: term > term 

36 
val is_False: thm > bool 

6128  37 
val is_nat: typ list * term > bool 
38 
val mk_nat_thm: Sign.sg > term > thm 

6102  39 
end; 
40 
(* 

41 
mk_Eq(~in) = `in == False' 

42 
mk_Eq(in) = `in == True' 

43 
where `in' is an (in)equality. 

44 

45 
neg_prop(t) = neg if t is wrapped up in Trueprop and 

46 
nt is the (logically) negated version of t, where the negation 

47 
of a negative term is the term itself (no double negation!); 

6128  48 

49 
is_nat(parametertypes,t) = t:nat 

50 
mk_nat_thm(t) = "0 <= t" 

6102  51 
*) 
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  55 
val decomp: 
9420  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 nondistrete 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 nondistrete types.
nipkow
parents:
6128
diff
changeset

62 
of summand * multiplicity pairs and a constant summand and 
8e934d1a9ac6
Now distinguishes discrete from nondistrete 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  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  70 
signature FAST_LIN_ARITH = 
71 
sig 

9420  72 
val setup: (theory > theory) list 
73 
val map_data: ({add_mono_thms: thm list, lessD: thm list, simpset: Simplifier.simpset} 

74 
> {add_mono_thms: thm list, lessD: thm list, simpset: Simplifier.simpset}) 

75 
> theory > theory 

9073  76 
val trace : bool ref 
6074  77 
val lin_arith_prover: Sign.sg > thm list > term > thm option 
6062  78 
val lin_arith_tac: int > tactic 
79 
val cut_lin_arith_tac: thm list > int > tactic 

80 
end; 

81 

6102  82 
functor Fast_Lin_Arith(structure LA_Logic:LIN_ARITH_LOGIC 
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  86 

87 
(** theory data **) 

88 

89 
(* data kind 'Provers/fast_lin_arith' *) 

90 

91 
structure DataArgs = 

92 
struct 

93 
val name = "Provers/fast_lin_arith"; 

94 
type T = {add_mono_thms: thm list, lessD: thm list, simpset: Simplifier.simpset}; 

95 

96 
val empty = {add_mono_thms = [], lessD = [], simpset = Simplifier.empty_ss}; 

97 
val copy = I; 

98 
val prep_ext = I; 

99 

100 
fun merge ({add_mono_thms = add_mono_thms1, lessD = lessD1, simpset = simpset1}, 

101 
{add_mono_thms = add_mono_thms2, lessD = lessD2, simpset = simpset2}) = 

102 
{add_mono_thms = Drule.merge_rules (add_mono_thms1, add_mono_thms2), 

103 
lessD = Drule.merge_rules (lessD1, lessD2), 

104 
simpset = Simplifier.merge_ss (simpset1, simpset2)}; 

105 

106 
fun print _ _ = (); 

107 
end; 

108 

109 
structure Data = TheoryDataFun(DataArgs); 

110 
val map_data = Data.map; 

111 
val setup = [Data.init]; 

112 

113 

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  117 
(* possible optimizations: 
118 
use (var,coeff) rep or vector rep tp save space; 

119 
treat nonnegative atoms separately rather than adding 0 <= atom 

120 
*) 

5982
aeb97860d352
Replaced the puny nat_transitive.ML by the general fast_lin_arith.ML.
nipkow
parents:
diff
changeset

121 

9073  122 
val trace = ref false; 
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  126 
datatype injust = Asm of int 
127 
 Nat of int (* index of atom *) 

6128  128 
 LessD of injust 
129 
 NotLessD of injust 

130 
 NotLeD of injust 

7551
8e934d1a9ac6
Now distinguishes discrete from nondistrete 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 refutationfinding 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  229 
fun print_ineqs ineqs = 
9073  230 
if !trace then 
231 
writeln(cat_lines(""::map (fn Lineq(c,t,l,_) => 

232 
string_of_int c ^ 

233 
(case t of Eq => " = "  Lt=> " < "  Le => " <= ") ^ 

234 
commas(map string_of_int l)) ineqs)) 

235 
else (); 

6056  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  238 
let val dummy = print_ineqs ineqs; 
6056  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  278 
fun trace_thm msg th = 
279 
if !trace then (writeln msg; prth th) else th; 

280 

281 
fun trace_msg msg = 

282 
if !trace then writeln msg else (); 

283 

6056  284 
(* FIXME OPTIMIZE!!!! 
285 
Addition/Multiplication need i*t representation rather than t+t+... 

286 

287 
Simplification may detect a contradiction 'prematurely' due to type 

288 
information: n+1 <= 0 is simplified to False and does not need to be crossed 

289 
with 0 <= n. 

290 
*) 

291 
local 

292 
exception FalseE of thm 

293 
in 

6074  294 
fun mkthm sg asms just = 
9420  295 
let val {add_mono_thms, lessD, simpset} = Data.get_sg sg; 
296 
val atoms = foldl (fn (ats,(lhs,_,_,rhs,_,_)) => 

6056  297 
map fst lhs union (map fst rhs union ats)) 
9420  298 
([], mapfilter (LA_Data.decomp sg o concl_of) asms) 
6056  299 

300 
fun addthms thm1 thm2 = 

6102  301 
let val conj = thm1 RS (thm2 RS LA_Logic.conjI) 
9420  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(i1, addthms thm th) 
6102  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  309 
fun simp thm = 
9420  310 
let val thm' = simplify simpset thm 
6102  311 
in if LA_Logic.is_False thm' then raise FalseE thm' else thm' end 
6056  312 

9073  313 
fun mk(Asm i) = trace_thm "Asm" (nth_elem(i,asms)) 
314 
 mk(Nat(i)) = (trace_msg "Nat"; 

315 
LA_Logic.mk_nat_thm sg (nth_elem(i,atoms))) 

9420  316 
 mk(LessD(j)) = trace_thm "L" (hd([mk j] RL lessD)) 
9073  317 
 mk(NotLeD(j)) = trace_thm "NLe" (mk j RS LA_Logic.not_leD) 
9420  318 
 mk(NotLeDD(j)) = trace_thm "NLeD" (hd([mk j RS LA_Logic.not_leD] RL lessD)) 
9073  319 
 mk(NotLessD(j)) = trace_thm "NL" (mk j RS LA_Logic.not_lessD) 
320 
 mk(Added(j1,j2)) = simp (trace_thm "+" (addthms (mk j1) (mk j2))) 

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  323 
in trace_msg "mkthm"; 
9420  324 
simplify simpset (mk just) handle FalseE thm => thm end 
6056  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 nondistrete 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 = ij 
6056  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 nondistrete types.
nipkow
parents:
6128
diff
changeset

339 
 "~<=" => if discrete 
8e934d1a9ac6
Now distinguishes discrete from nondistrete types.
nipkow
parents:
6128
diff
changeset

340 
then Some(Lineq(1c,Le,map (op ~) diff,NotLeDD(just))) 
8e934d1a9ac6
Now distinguishes discrete from nondistrete types.
nipkow
parents:
6128
diff
changeset

341 
else Some(Lineq(~c,Lt,map (op ~) diff,NotLeD(just))) 
8e934d1a9ac6
Now distinguishes discrete from nondistrete types.
nipkow
parents:
6128
diff
changeset

342 
 "<" => if discrete 
8e934d1a9ac6
Now distinguishes discrete from nondistrete types.
nipkow
parents:
6128
diff
changeset

343 
then Some(Lineq(c+1,Le,diff,LessD(just))) 
8e934d1a9ac6
Now distinguishes discrete from nondistrete types.
nipkow
parents:
6128
diff
changeset

344 
else Some(Lineq(c,Lt,diff,just)) 
6128  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  352 
fun mknat pTs ixs (atom,i) = 
6128  353 
if LA_Logic.is_nat(pTs,atom) 
6056  354 
then let val l = map (fn j => if j=i then 1 else 0) ixs 
355 
in Some(Lineq(0,Le,l,Nat(i))) end 

356 
else None 

357 

358 
fun abstract pTs items = 

7551
8e934d1a9ac6
Now distinguishes discrete from nondistrete 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  362 
val ixs = 0 upto (length(atoms)1) 
363 
val iatoms = atoms ~~ ixs 

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  367 
fun refute1(pTs,items) = 
368 
(case elim (abstract pTs items) of 

369 
None => [] 

370 
 Some(Lineq(_,_,_,j)) => [j]); 

371 

372 
fun refute1_tac(i,just) = 

373 
fn state => 

374 
let val sg = #sign(rep_thm state) 

6102  375 
in resolve_tac [LA_Logic.notI,LA_Logic.ccontr] i THEN 
6074  376 
METAHYPS (fn asms => rtac (mkthm sg asms just) 1) i 
377 
end 

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 nondistrete types.
nipkow
parents:
6128
diff
changeset

381 
fun refute2(pTs,items, (rhs,i,_,lhs,j,d), nHs) = 
8e934d1a9ac6
Now distinguishes discrete from nondistrete types.
nipkow
parents:
6128
diff
changeset

382 
(case elim (abstract pTs (items@[((rhs,i,"<",lhs,j,d),nHs)])) of 
6074  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 nondistrete types.
nipkow
parents:
6128
diff
changeset

385 
(case elim (abstract pTs (items@[((lhs,j,"<",rhs,i,d),nHs)])) of 
6074  386 
None => [] 
387 
 Some(Lineq(_,_,_,j2)) => [j1,j2])); 

388 

389 
fun refute2_tac(i,just1,just2) = 

390 
fn state => 

391 
let val sg = #sign(rep_thm state) 

6102  392 
in rtac LA_Logic.ccontr i THEN rotate_tac ~1 i THEN etac LA_Logic.neqE i THEN 
6074  393 
METAHYPS (fn asms => rtac (mkthm sg asms just1) 1) i THEN 
394 
METAHYPS (fn asms => rtac (mkthm sg asms just2) 1) i 

395 
end 

396 
state; 

397 

9420  398 
fun prove sg (pTs,Hs,concl) = 
6074  399 
let val nHs = length Hs 
400 
val ixHs = Hs ~~ (0 upto (nHs1)) 

9420  401 
val Hitems = mapfilter (fn (h,i) => case LA_Data.decomp sg h of 
6074  402 
None => None  Some(it) => Some(it,i)) ixHs 
9420  403 
in case LA_Data.decomp sg concl of 
6074  404 
None => if null Hitems then [] else refute1(pTs,Hitems) 
7551
8e934d1a9ac6
Now distinguishes discrete from nondistrete types.
nipkow
parents:
6128
diff
changeset

405 
 Some(citem as (r,i,rel,l,j,d)) => 
6074  406 
if rel = "=" 
407 
then refute2(pTs,Hitems,citem,nHs) 

408 
else let val neg::rel0 = explode rel 

409 
val nrel = if neg = "~" then implode rel0 else "~"^rel 

7551
8e934d1a9ac6
Now distinguishes discrete from nondistrete types.
nipkow
parents:
6128
diff
changeset

410 
in refute1(pTs, Hitems@[((r,i,nrel,l,j,d),nHs)]) end 
6074  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  417 
fun lin_arith_tac i st = SUBGOAL (fn (A,n) => 
6056  418 
let val pTs = rev(map snd (Logic.strip_params A)) 
419 
val Hs = Logic.strip_assums_hyp A 

6074  420 
val concl = Logic.strip_assums_concl A 
9420  421 
in case prove (Thm.sign_of_thm st) (pTs,Hs,concl) of 
6074  422 
[j] => refute1_tac(n,j) 
423 
 [j1,j2] => refute2_tac(n,j1,j2) 

424 
 _ => no_tac 

9420  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  429 
fun prover1(just,sg,thms,concl,pos) = 
6102  430 
let val nconcl = LA_Logic.neg_prop concl 
6074  431 
val cnconcl = cterm_of sg nconcl 
432 
val Fthm = mkthm sg (thms @ [assume cnconcl]) just 

6102  433 
val contr = if pos then LA_Logic.ccontr else LA_Logic.notI 
434 
in Some(LA_Logic.mk_Eq ((implies_intr cnconcl Fthm) COMP contr)) end 

6074  435 
handle _ => None; 
436 

437 
(* handle thm with equality conclusion *) 

438 
fun prover2(just1,just2,sg,thms,concl) = 

6102  439 
let val nconcl = LA_Logic.neg_prop concl (* m ~= n *) 
6074  440 
val cnconcl = cterm_of sg nconcl 
441 
val neqthm = assume cnconcl 

6102  442 
val casethm = neqthm COMP LA_Logic.neqE (* [m<n ==> R; n<m ==> R] ==> R *) 
6074  443 
val [lessimp1,lessimp2] = prems_of casethm 
444 
val less1 = fst(Logic.dest_implies lessimp1) (* m<n *) 

445 
and less2 = fst(Logic.dest_implies lessimp2) (* n<m *) 

446 
val cless1 = cterm_of sg less1 and cless2 = cterm_of sg less2 

447 
val thm1 = mkthm sg (thms @ [assume cless1]) just1 

448 
and thm2 = mkthm sg (thms @ [assume cless2]) just2 

449 
val dthm1 = implies_intr cless1 thm1 and dthm2 = implies_intr cless2 thm2 

450 
val thm = dthm2 COMP (dthm1 COMP casethm) 

6102  451 
in Some(LA_Logic.mk_Eq ((implies_intr cnconcl thm) COMP LA_Logic.ccontr)) end 
6074  452 
handle _ => None; 
453 

6079  454 
(* PRE: concl is not negated! *) 
6074  455 
fun lin_arith_prover sg thms concl = 
456 
let val Hs = map (#prop o rep_thm) thms 

6102  457 
val Tconcl = LA_Logic.mk_Trueprop concl 
9420  458 
in case prove sg ([],Hs,Tconcl) of 
6079  459 
[j] => prover1(j,sg,thms,Tconcl,true) 
6074  460 
 [j1,j2] => prover2(j1,j2,sg,thms,Tconcl) 
6102  461 
 _ => let val nTconcl = LA_Logic.neg_prop Tconcl 
9420  462 
in case prove sg ([],Hs,nTconcl) of 
6079  463 
[j] => prover1(j,sg,thms,nTconcl,false) 
464 
(* [_,_] impossible because of negation *) 

465 
 _ => None 

466 
end 

5982
aeb97860d352
Replaced the puny nat_transitive.ML by the general fast_lin_arith.ML.
nipkow
parents:
diff
changeset

467 
end; 
6074  468 

469 
end; 