File r37/packages/groebner/groebcri.red from the latest check-in

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;