module groebcri;
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% criteria for the Buchberger algorithm
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
fluid '(Bcount!* B4count!* Mcount!* Fcount!*);
smacro procedure tt(s1,s2);
% lcm of leading terms of s1 and s2
vevlcm(vdpevlmon s1,vdpevlmon s2);
smacro procedure atleast2elementsin (u);
% test if u has at least a cadr element
u and cdr u;
symbolic procedure groebbuchcrit4(p1,p2,e);
% Buchberger criterion 4. p1 and p2 are distributive
% polynomials. e is the least common multiple of
% the leading exponent vectors of the distributive
% polynomials p1 and p2. groebBuchcrit4(p1,p2,e) returns a
% boolean expression. True if the reduction of the
% distributive polynomials p1 and p2 is necessary
% else false.
% orig:
% e neq vevsum( vdpevlmon p1, vdpevlmon p2);
groebbuchcrit4t(vdpevlmon p1,vdpevlmon p2);
symbolic procedure groebbuchcrit4t(e1,e2);
% nonconstructive test of lcm(e1,e2) = e1 + e2
% equivalent: no matches of nonzero elements.
if null e1 or null e2 then nil
else
if (car e1 neq 0) and (car e2 neq 0) then t
else groebbuchcrit4t(cdr e1,cdr e2);
symbolic procedure groebinvokecritbuch4 (p,d2);
% Buchberger's criterion 4 is tested on the pair p and the list
% D2 of critical pairs is updated with respect to that crit.
% Result is the updated D2;
begin scalar p1,p2,vev1,vev2,f1,f2,fd,b4;
p1 := cadr p;
p2 := caddr p;
vev1 := vdpevlmon p1;
vev2 := vdpevlmon p2;
f1 := vdpGetProp(p1,'monfac);
f2 := vdpGetProp(p2,'monfac);
% discard known common factors first
if f1 and f2 then
<<fd := vevmin (f1,f2);
b4 := groebbuchcrit4t(vevdif(vev1,fd),vevdif(vev2,fd));
if b4 and % is the body itself a common factor?
vevdif(vev1,f1) = vevdif(vev2,f2)
% test if the polys reduced by their monom.
% factor are equal
and groebbuchcrit4compatible(p1,f1,p2,f2)
then b4 := nil;
>>
else
b4 := groebbuchcrit4t(vev1,vev2);
if b4 then
d2 := append (d2, list p)
else
b4count!* := b4count!* + 1;
return d2;
end;
symbolic procedure groebbuchcrit4compatible (p1,f1,p2,f2);
% p1,p2 polys, f1,f2 exponent vectors (monomials), which are known to
% be factors of their f;
% tests, if p1/f1 = p2/f2
if vdpzero!? p1 then vdpzero!? p2
else
if vdplbc p1 = vdplbc p2 and
groebbuchcrit4compatiblevev(vdpevlmon p1,f1,vdpevlmon p2,f2)
then groebbuchcrit4compatible (vdpred p1,f1,vdpred p2,f2)
else nil;
symbolic procedure groebbuchcrit4compatiblevev (vev1,f1,vev2,f2);
if null vev1 then null vev2 else
if (if f1 then car vev1 - car f1 else car vev1)
=
(if f2 then car vev2 - car f2 else car vev2)
then
groebbuchcrit4compatiblevev (cdr vev1,
if f1 then cdr f1 else nil,
cdr vev2,
if f2 then cdr f2 else nil)
else nil;
symbolic procedure groebinvokecritf d1;
% groebInvokeCritF tests a list D1 of critical pairs. It cancels all
% critical pairs but one in D1 having the same lcm (i.e. car
% component) as car(D1). This only one is chosen, if possible,
% such that it doesn't satisfy groebBuchcrit4.
% Version: moeller upgraded 5.7.87
begin scalar tp1,p2,active;
tp1 := car(car(d1));
active := atLeast2elementsin d1;
while active do
<< p2 := cadr d1;
if car(p2) = tp1 then
<< fcount!* := fcount!* +1;
if not groebbuchcrit4t(cadr p2, caddr p2)
then d1 := cdr(d1)
else d1 := groedeletip(p2,d1);
active := atleast2elementsin d1 >>
else active := nil >>;
return d1;
end;
symbolic procedure groebinvokecritm (p1,d1);
% D1 is a list of critical pairs, p1 is a critical pair.
% crit M tests, if the lcm of p1 divides one of the lcm's in D1.
% If so, this object is eliminated.
% Result is the updated D1;
<< for each p3 in d1 do
if buch!-vevdivides!?(car(p1), car(p3)) then
<<mcount!* := mcount!*+1;
d1 := groedeletip (p3,d1)>>; % Criterion M
d1>>;
symbolic procedure groebinvokecritb (fj,d);
% D is a list of critical pairs, fj is a polynomial.
% Crit B allows to eliminate a pair from D, if the leading monomial
% of fj divides the lcm of the pair, but the lcm of fj with each of
% the members of the pair is not the lcm of the pair itself
% Result is the updated D;
<< for each p in d do
if buch!-vevdivides!?(vdpevlmon(fj), car(p)) and
tt(fj,cadr(p)) neq car(p) and % Criterion B
tt(fj,caddr(p)) neq car(p) then
<<bcount!* := bcount!* +1;
d:= delete (p,d)>>;
d>>;
endmodule;
end;