Artifact 20644b64481a252f9c91c9de9ecf68db1f5db9b65a3b7684f4f3bdd405f066d3:


module groebner;

% Author: Herbert Melenk
% in cooperation with Winfried Neun, Michael Moeller.

% module structure:
%
%     GROEBNER  package + GROEBNR2 package
%        polynomial arithmetic:
%         VDP2DIP package included in DIPOLY package
%        factorization:
%         GROEBFAC package is also included here, but could be loaded
%         on demand.

% Modifications:
%
% 17-Sep-1994 (HM):  The ideal variables are now declared in the TORDER
% statement.  The calling conventions can be still used, but are removed
% from the documents.

fluid '(currentvdpmodule!*);

currentvdpmodule!* := 'vdp2dip;

imports vdp2dip;

create!-package('(groebner grinterf grinter2 buchbg groebcri
         groesolv groebopt groebsea groebsor groebspa groebfac
         groebidq kredelw traverso),
         '(contrib groebner));

put('groebner,'version,2.9);

% Other packages needed.

load!-package 'dipoly;

if(null v or v<3.7) where v=get('dipoly,'version)
  then rederr "wrong dipoly module";

smacro procedure tt(s1,s2);
  % lcm of leading terms of s1 and s2
       vevlcm(vdpevlmon s1,vdpevlmon s2);

endmodule;


module grinterf;  % Interface of Groebner package to REDUCE.
                  % Entry points to the main module and general
                  % interface support.


fluid '(!*factor !*complex !*exp asymplis!* current!-modulus);

global '(!*match powlis!* largest!-small!-modulus);

fluid '(                           % switches from the user interface
        !*groebopt !*groebfac !*groebres !*trgroeb !*trgroebs !*groebrm
        !*trgroeb1 !*trgroebr !*groebprereduce groebrestriction!*
        !*fullreduction !*groebstat !*groebprot !*gltbasis
        !*groebsubs

        !*grmod!*                  % indicating modular coefficients
        !*vdpinteger !*vdpmodular  % indicating type of algorithm
        vdpsortmode!*              % term ordering mode
        secondvalue!* thirdvalue!* % auxiliary: multiple return values
        fourthvalue!*
        factortime!*               % computing time spent in factoring
        factorlvevel!*             % bookkeeping of factor tree
        pairsdone!*                % list of pairs already calculated
        probcount!*                % counting subproblems
        vbccurrentmode!*           % current domain for base coeffs.
        vbcmodule!*                % for modular calculation:
                                   %     current prime
        bczerodivl!*               % coefficient zero divisors (list of
                                   % standard forms)
        gmodule                    % external module basis
        gmodule!*                  % internal module basis
        global!-dipvars!*          % predefined variable list
        !*gsugar                   % enable sugar strategy
       );

global '(groebrestriction          % interface: name of function
         groebresmax               % maximum number of internal results
         gvarslast                 % output: variable list
         groebprotfile
         gltb
         glterms                   % list for lterms collection
        );

flag ('(groebrestriction groebresmax gvarslast groebprotfile
        gltb glterms gmodule),'share);

switch groebopt,groebres,trgroeb,trgroebs,trgroeb1,
       trgroebr,groebstat,gltbasis,gsugar;

% variables for counting and numbering
fluid '(hcount!* pcount!* mcount!* fcount!* bcount!* b4count!*
        basecount!* hzerocount!*);

% control of the polynomial arithmetic actually loaded
fluid '(currentvdpmodule!*);

vdpsortmode!* := 'lex;     % initial mode
gltb := '(list);           % initially empty

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%    interface functions

symbolic procedure groebnereval u;
  % non factorizing Groebner calculation
   begin integer n; scalar !*groebfac,!*groebrm,!*factor,
                !*exp; !*exp := t;
      n := length u;
      if n=1 then return cadr groebner1(reval car u,nil,nil)
       else if n neq 2
        then rerror(groebner,1,
                    "GROEBNER called with wrong number of arguments");
       u:= groebner1(reval car u,reval cadr u,nil);
       if !*gltbasis then gltb := cadr gltb;
       return cadr u;
      end;

put('groebner,'psopfn,'groebnereval);

symbolic procedure groebnerfeval u;
  % non factorizing Groebner calculation
   begin integer n; scalar !*groebfac,!*groebrm,!*factor,
         !*exp,!*ezgcd,s,r,q; !*exp := t;
      if null getd 'groebfactorize then load!-package 'groebfac;
      !*groebrm := !*groebfac := t;
      groebrestriction!* := reval groebrestriction;
      if null dmode!* then !*ezgcd:=t;
      n := length u;
      r:=  if n=1 then groebner1(reval car u,nil,nil) else
           if n=2 then groebner1(reval car u,reval cadr u,nil) else
           if n neq 3
        then rerror(groebner,2,
                    "GROEBNER called with wrong number of arguments")
             else  groebner1(reval car u,reval cadr u,reval caddr u);
      q := r;
       % remove duplicates.
      while q do <<s := car q; q := cdr q;
                    if member(s,q) then r := delete(s,r)>>;
      return r;
    end;

put('groebnerf,'psopfn,'groebnerfeval);

symbolic procedure idquotienteval u;
   begin integer n; scalar !*factor,!*exp; !*exp := t;
      n := length u;
      if n=2 then return groebidq(reval car u,reval cadr u,nil)
       else if n neq 3
        then rerror(groebner,3,
                    "IDQUOTIENT called with wrong number of arguments")
       else return groebidq(reval car u,reval cadr u,reval caddr u)
      end;

put('idealquotient,'psopfn,'idquotienteval);

smacro procedure vdpnumber f;
     vdpgetprop(f,'number) ;


symbolic procedure groebner1(u,v,r);
%    Buchberger algorithm system driver. u is a list of expressions
%    and v a list of variables or NIL in which case the variables in u
%    are used.
   begin scalar vars,w,np,oldorder,!*grmod!*;
         integer pcount!*;
      w := for each j in groerevlist u
              collect if eqexpr j then !*eqn2a j else j;
      if null w then rerror(groebner,4,"Empty list in Groebner");
      vars := groebnervars(w,v);
      if r then r := groerevlist r;
      groedomainmode();
      if vars then goto notempty;
      u:=0; for each p in w do if p neq 0 then u:=1;
      return {'list,{'list,u}};
   notempty:
      if dmode!* eq '!:mod!: and null setdiff(gvarlis w,vars)
         and current!-modulus < largest!-small!-modulus
        then !*grmod!* := t;
      oldorder := vdpinit vars;
                  % cancel common denominators
      w := for each j in w collect reorder numr simp j;
                  % optimize variable sequence if desired.
      if !*groebopt and vdpsortmode!* memq '(lex gradlex revgradlex)
        then  << w:=vdpvordopt (w,vars); vars := cdr w;
                 w := car w; vdpinit vars>>;
      w := for each j in w collect f2vdp j;
      if not !*vdpinteger then
      <<np := t;
        for each p in w do
          np := if np then vdpcoeffcientsfromdomain!? p else nil;
        if not np then <<!*vdpmodular:= nil; !*vdpinteger := t>>;
      >>;
      if !*groebprot then
          <<groebprotfile := list 'list>>;
      if r then r := for each p in r collect
           vdpsimpcont f2vdp numr simp p;
      w := groebner2(w,r);

      if cdr w then  % Remove redundant partial bases.
      begin scalar !*gsugar;
        for each b in w do
         for each c in w do
          if b and b neq c then
           <<v:=t; for each p in c do
               v:=v and vdpzero!? groebnormalform(p,b,'list);
             if v then <<w:=delete(b,w); b:=nil>>;
           >>;
      end;
      if !*gltbasis then
        gltb :=
           'list . for each base in w collect
                   'list . for each j in base collect
                      vdp2a vdpfmon(a2vbc 1,vdpevlmon j);
      w := 'list . for each base in w collect
                   'list . for each j in base collect vdp2a j;
      vdpcleanup();
      gvarslast := 'list . vars;
      return w;
   end;

symbolic procedure groebnervars(w,v);
    begin scalar z,dv,gdv,vars;
      if v='(list) then v:=nil;
      v:=v or (gdv:=cdr global!-dipvars!*) and global!-dipvars!*;
      vars :=
       if null v then
                for each j in gvarlis w collect !*a2k j
          else                      % test, if vars are really used
             << z := gvarlis w;
                groebnerzerobc setdiff(z,v:= groerevlist v);
                for each j in v do
                    if member(j,z) then dv := !*a2k j . dv;
                dv := reversip dv;
                if not (length v = length dv) and !*trgroeb then
                      << prin2 " Groebner: ";
                         prin2 (length v - length dv);
                         prin2t " of the variables not used";
                         terpri () >>;
                dv>>;
       return gdv or vars;
    end;

symbolic procedure groebnerzerobc u;
% u is the list of parameters in a Groebner job. Extract the
% corresponding rules from !*match and powlis!*.
 if u then
  begin scalar w,m,p;
    bczerodivl!* := nil;
    m:=!*match; !*match:=nil;
    p:=powlis!*; powlis!*:=nil;
    for each r in m do if cadr r='(nil . t) then
    <<w:=(numr simp {'difference,'times.for each q in car r collect
{'expt,car q,cdr q}
                    ,caddr r});
      for each x in kernels w do if not member(x,u) then w:=nil;
      if w then bczerodivl!* := w . bczerodivl!*;
    >>;
    for each r in p do if member(car r,u) and caddr r='(nil . t) then
    <<w:=(numr simp {'difference, {'expt,car r,cadr r} ,cadddr r});
      bczerodivl!* := w . bczerodivl!*;
    >>;
    for each r in asymplis!* do if member(car r,u) then
      bczerodivl!* := (r .*1 .+nil) . bczerodivl!*;
    !*match:=m; powlis!*:=p;
  end;

% symbolic procedure maklist pl;
% make list of polynomials. pl is a list of polynomials.
% maklist pl returns a list of distributive polynomials.
%  for each p in pl collect f2vdp car p;

symbolic procedure gvarlis u;
   % Finds variables (kernels) in the list of expressions u.
   sort(gvarlis1(u,nil),function ordop);

symbolic procedure gvarlis1(u,v);
   if null u then v
    else union(gvar1(car u,v),gvarlis1(cdr u,v));

symbolic procedure gvar1(u,v);
   if null u or numberp u or (u eq 'i and !*complex) then v
    else if atom u then if u member v then v else u . v
    else if get(car u,'dname) then v
    else if car u memq '(plus times expt difference minus)
     then gvarlis1(cdr u,v)
    else if car u eq 'quotient then gvar1(cadr u,v)
    else if u member v then v
    else u . v;

symbolic procedure groebidq(u,f,v);
%  Ideal quotient. u is a list of expressions (Gbasis), f a polynomial
%  and v a list of variables or NIL
   begin scalar vars,w,np,oldorder,!*factor,!*exp;
         integer pcount!*; !*exp := t;
      w := for each j in groerevlist u
              collect if eqexpr j then !*eqn2a j else j;
      if null w then rerror(groebner,5,"Empty list in IDEALQUOTIENT");
      if eqexpr f then f := !*eqn2a f;
      vars := groebnervars(w,v);
      groedomainmode();
      if null vars then vdperr 'idealquotient;
      oldorder := vdpinit vars;
                  % cancel common denominators
      w := for each j in w collect numr simp j;
      f :=  numr simp f;
      w := for each j in w collect f2vdp j;
      f := f2vdp f; % now do the conversions
      if not !*vdpinteger then
      <<np := t;
        for each p in f.w do
          np := if np then vdpcoeffcientsfromdomain!? p
                else nil;
        if not np then <<!*vdpmodular:= nil; !*vdpinteger := t>>;
      >>;
      w := groebidq2 (w,f);
      w := 'list . for each j in w collect vdp2a j;
      setkorder oldorder;
      return w;
   end;

fluid '(!*backtrace);

symbolic procedure vdperr name;
  % case that no variables were found
    <<prin2 "**** Groebner illegal parmeter in "; prin2 name;
      if !*backtrace then backtrace();
      rerror(groebner,6," ,e.g. no relevant variables found")>>;

symbolic procedure groeparams(u,nmin,nmax);
   % u is a list of psopfn-parameters; they are given to REVAL and
   % the number of parameters is controlled to be between nmin, nmax
   % result is the list of evaluated parameters padded with NILs
     begin integer n; scalar w; n:= length u;
       if n<nmin or n>nmax then rerror(groebner,7,
         "Illegal number of parameters in call to Groebner package");
       u:= for each v in u collect
         <<w := reval v;
           if eqcar(w,'list) then 'list . groerevlist w else w>>;
       while length u < nmax do u := append(u,'(nil));
       return u;
     end;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% initialization of the distributive plynomial arithmetic
%

symbolic procedure vdpinit (vars);
     begin scalar r,gm;
          % Eventually set up module basis.
        if eqcar(gmodule,'list) and cdr gmodule then
         gm := for each y in cdr gmodule collect
          <<y := reval y;
            if not member(y,vars) then vars:=append(vars,{y});
            y >>;
        r:=vdpinit2(vars);
          % convert an eventual module basis.
        gmodule!* := if gm then vdpevlmon a2vdp ('times . gm);
        return r;
    end;

symbolic procedure groedomainmode();
     <<!*vdpinteger := !*vdpmodular := nil;
      if not flagp(dmode!*,'field) then !*vdpinteger := t
           else
      if !*modular then !*vdpmodular := t>>;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% some lisp functions which are not member of standard lisp
%

symbolic procedure groedeletip(a,b);
   begin scalar q;
       while b and  a= car b do b:= cdr b;
       if null b then return nil;
       q := b;
       while cdr b do if a=cadr b then cdr b := cddr b else b:= cdr b;
       return q;
   end;

symbolic procedure groerevlist u;
      <<if idp u then u := reval u;
       for each p in getrlist u collect reval p>>;

endmodule;


module grinter2;  % Interface of Groebner package to REDUCE:
                  % autoloadint entry points to operators of groebnr2;


symbolic procedure groebnr2entry(fn,u);
       <<groebnr2load();
         apply(get(fn,'psopfn),list u)>>;

symbolic procedure groebnr2load();
       load!-package 'groebnr2;

put('gsort,'psopfn,
      '(lambda(u)(groebnr2entry 'gsort u)));

put('gsplit,'psopfn,
     '(lambda(u)(groebnr2entry 'gsplit u)));


put('gspoly,'psopfn,
     '(lambda(u)(groebnr2entry 'gspoly u)));

put('gvars,'psopfn,
     '(lambda(u)(groebnr2entry 'gvars u)));

put('greduce,'psopfn,
     '(lambda(u)(groebnr2entry 'greduce u)));

put('preduce,'psopfn,
     '(lambda(u)(groebnr2entry 'preduce u)));

put('groebnert,'psopfn,
     '(lambda(u)(groebnr2entry 'groebnert u)));

put('preducet,'psopfn,
     '(lambda(u)(groebnr2entry 'preducet u)));

put('groebnerm,'psopfn,
     '(lambda(u)(groebnr2entry 'groebnerm u)));

put('glexconvert,'psopfn,
     '(lambda(u)(groebnr2entry 'glexconvert u)));

put('hilbertpolynomial,'psopfn,
     '(lambda(u)(groebnr2entry 'hilbertpolynomial u)));

put('gzerodim!?,'psopfn,
     '(lambda(u)(groebnr2entry 'gzerodim!? u)));

put('dd_groebner,'psopfn,
     '(lambda(u)(groebnr2entry 'dd_groebner u)));

put('trgroeb,'simpfg,'((t (groebnr2load))));
put('trgroebs,'simpfg,'((t (groebnr2load)(setq !*trgroeb t))
                        (nil (setq !*trgroeb nil))));
put('trgroebr,'simpfg,'((t (groebnr2load))));
put('groebstat,'simpfg,'((t ( groebnr2load))));
put('groebweak,'simpfg,'((t (groebnr2load))));
put('groebres,'simpfg,'((t (groebnr2load))));

symbolic procedure groebtestrestriction (a1,a2);
   <<groebnr2load(); apply('groebtestrestriction,list(a1,a2))>>;
endmodule;


module buchbg;  % Central Groebner base code: Buchberger algorithm.

%   Authors:   H. Melenk, H.M. Moeller,  W. Neun
%   ZIB Berlin
%   July 1988

fluid '(!*gcd);

fluid '(                           % switches from the user interface
        !*groebopt !*groebfac !*groebres !*trgroeb !*trgroebs !*groebrm
        !*trgroeb1 !*trgroebr !*groebprereduce groebrestriction!*
        !*groebfullreduction !*groebstat !*groebdivide !*groebprot
        !*groebheufact !*groebweak !*groelterms

        vdpvars!*                  % external names of the variables
        !*vdpinteger !*vdpmodular  % indicating type of algorithm
        vdpsortmode!*              % term ordering mode
        secondvalue!* thirdvalue!* % auxiliary: multiple return values
        fourthvalue!*
        groebdomain!*              % domain mode if selected explicitly
        factortime!*               % computing time spent in factoring
        factorlevel!*              % bookkeeping of factor tree
        groefeedback!*             % sideeffect factorization
        groesfactors!*             % data structure for act. fact.
        pairsdone!*                % list of pairs already calculated
        probcount!*                % counting subproblems
        vbccurrentmode!*           % current domain for base coeffs.
        vbcmodule!*                % for modular calculation:
                                   % current prime
        groetime!*
        !*gsugar                   % enable Traverso's sugar technique
        groecontcount!*            % control of content reduction
        gmodule!*                  % internal module basis
        groebabort!*               % input abort conditions
       );

global '(groebrestriction          % interface:
                                   %  name of restriction function
         groebresmax            % maximum number of internal results
         gvarslast                 % output: variable list
         groebmonfac               % minimum exponent for reduction of
                                   % monomial factors
         groebprotfile             % reduction protocol
         glterms                   % list for lterms collection
        );

flag ('(groebrestriction groebresmax gvarslast groebmonfac
         groebprotfile glterms), 'share);

groebrestriction := nil;
groebresmax := 300;
groebmonfac := 1;
groecontcount!* := 10;
!*groebfullreduction := t;
!*gsugar := t;
!*groelterms := t;

switch groebopt,groebres,trgroeb,trgroebs,trgroeb1,
       trgroebr,groebfullreduction,groebstat,groebprot;

% variables for counting and numbering
fluid '(hcount!* pcount!* mcount!* fcount!* bcount!* b4count!*
        basecount!* hzerocount!*);

%      option ' groebopt'    "optimizes" the given input
%                            polynomial set ( variable
%                            ordering )
%      option ' trgroeb'     prints intermediate
%                            results on the output file
%      option ' trgroeb1'    prints internal representation
%                            of critical pair list d
%      option ' trgroebs '   prints S - polynomials
%                            on the output file
%      option   trgroebr     prints (intermediate) results and
%                            computation statistics
% groebstat  the statistics are printed
% groebres   the H- polynomials are optimised using resultant
%            and factorisation method
%
% groebrm    multiplicities of factors in h-polynomials are reduced
%            to simple factors.
%
% groebdivide
%            the algorithm avoids all divisions (only for modular
%            calculation) , if this switch is set off;
%
% groebprot  Write a protocol to the variable "groebprotfile";

!*groebfullreduction := t;
%!*groebPreReduce := T;
!*groebdivide := t;


% the code for checkpointing is factored out
% This version: NO CHECKPOINT FACILITY

smacro procedure groebcheckpoint1(); list nil;
smacro procedure groebcheckpoint2(); list nil;
smacro procedure groebcheckpoint2a(); list nil;
smacro procedure groebcheckpoint3(); list nil;
smacro procedure groebcheckpoint4(); list nil;
smacro procedure groebcheckpoint5(); list nil;


symbolic procedure buch!-vevdivides!? (vev1,vev2);
    % test: vev1 divides vev2 ? for exponent vectors vev1,vev2
    vevmtest!? (vev2,vev1) and
     (null gmodule!* or gevcompatible1(vev1,vev2,gmodule!*));

symbolic procedure gevcompatible1(v1,v2,g);
  % test whether v1 and v2 belong to the same vector column.
   if null g then t
   else if null v1 then (null v2 or gevcompatible1('(0),v2,g))
   else if null v2 then gevcompatible1(v1,'(0),g) else
    (car g = 0 or car v1 = car v2) and
         gevcompatible1(cdr v1,cdr v2,cdr g);

symbolic procedure gcompatible(f,h);
   null gmodule!* or
     gevcompatible1(vdpevlmon f,vdpevlmon h,gmodule!*);

symbolic procedure groebmakepair(f,h);
     % construct a pair from polynomials f and h
   begin scalar ttt,sf,sh;
      ttt:=tt(f,h);
      return if !*gsugar then
      <<sf:=gsugar(f) #+ vevtdeg vevdif(ttt,vdpevlmon f);
        sh:=gsugar(h) #+ vevtdeg vevdif(ttt,vdpevlmon h);
        list(ttt,f,h,max(sf,sh))>>
       else list(ttt,f,h);
   end;

% the 1-polynomial will be constructed at run time
% because the length of the vev is not known in advance
fluid '(vdpone!*);

symbolic procedure vdponepol;
    % construct the polynomial=1
    vdpone!* := vdpfmon(a2vbc 1,vevzero());

symbolic procedure groebner2(p,r);
  % setup all global variables for the Buchberger algorithm
  % printing of statistics
 begin scalar groetime!*,tim1,spac,spac1,p1,factortime!*,
              pairsdone!*,factorlevel!*,groesfactors!*,!*gcd;
       factortime!* := 0;
       groetime!*   := time();
       vdponepol(); % we construct dynamically
       hcount!* := 0; mcount!* := 0; fcount!* := 0;
       bcount!* := 0; b4count!* := 0; hzerocount!* := 0;
       basecount!* := 0; !*gcd := t; glterms := list('list);
       groecontcount!* := 10;
       if !*trgroeb then
       << prin2 "Groebner Calculation starting ";
          terprit 2;
          prin2 " groebopt: "; print !*groebopt;
       >>;
       spac := gctime();

       p1:= if !*groebfac or null !*gsugar
          then groebbasein (p,!*groebfac,!*groebres,r)
                 where !*gsugar=nil
            else gtraverso(p,nil,nil,nil);

       if !*trgroeb or !*trgroebr or !*groebstat then
       <<
          spac1 := gctime() - spac;
          terpri();
          prin2t "statistics for GROEBNER calculation";
          prin2t "===================================";
          prin2 " total computing time (including gc): ";
          prin2((tim1 := time()) - groetime!*);
          prin2t "          milliseconds  ";
       if factortime!* neq 0 then
        <<prin2 " (time spent in FACTOR (excl. gc):    ";
          prin2 factortime!*;
          prin2t "          milliseconds)";
        >>;
          prin2 " (time spent for garbage collection:  ";
          prin2 spac1;
          prin2t "          milliseconds)";
          terprit 1;
          prin2  "H-polynomials total: "; prin2t hcount!*;
          prin2  "H-polynomials zero : "; prin2t hzerocount!*;
          prin2  "Crit M hits: "; prin2t mcount!*;
          prin2  "Crit F hits: "; prin2t fcount!*;
          prin2  "Crit B hits: "; prin2t bcount!*;
          prin2  "Crit B4 hits: "; prin2t b4count!*;
       >>;
       return p1;
 end;


smacro procedure testabort h;
     vdpmember (h,abort1) or
      'cancel = (abort2 := groebtestabort(h,abort2));

symbolic procedure groebenumerate f;
  % f is a temporary result. Prepare it for medium range storage
  % and ssign a number
  if vdpzero!? f then f else
   << vdpcondense f;
      if not vdpgetprop(f,'number) then
      <<f := vdpputprop(f,'number,(pcount!* := pcount!* #+ 1));
        if !*groebprot then
          << groebprotsetq(mkid('poly,pcount!*),'candidate);
             vdpputprop(f,'groebprot,mkid('poly,pcount!*));
          >>;
      >>;
     f>>;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Buchberger's Algorithm
%
% INPUT :   G0 = { f1, ... , fr}  set of nonzero polynomials
% OUTPUT:   groebner basis (list of nonzero polynomials)
%
% internal variables:
%
%    problems  list of problems to be processed. problems is non nil,
%              if the inital problem was split by a successful factoring
%    results   collection of results from problems
%    G         basis under construction
%    G1        local pointer to G
%    D         list of critical pairs during algorithm
%    D1,D2     local lists of pairs during update of D
%    f,fj      polynomials
%    p,p1,p2   pairs
%    s,h       polynomials in the central part of the algorithm
%              (the "s-poly" and the "h-poly" selon Buchberger
%    G99       set of polynomials used for reduction. Held as
%              a search tree
%    abort1    list of polynomials in factorization context.
%              a calculation branch can be cancelled if one of
%              these polys is detected
%    abort2    list of sets of polynomials. If a new h polynomial
%              is calculated, it should be removed from the sets.
%              if one set becomes null, the set restriction is
%              fulfilled and the branch can be cancelled

symbolic procedure groebbasein (g0,fact,groebres,abort1);
   begin scalar problems, results, abort2,x,
                g,g1,d,d1,d2,p,p1,s,h,g99,hlist,lv,lasth;
         integer gvbc;
         integer lastcheckpoint,probcount!*;

         groebabort!* := abort1;
         lv := length vdpvars!*;

         groebcheckpoint1();

         for each p in g0 do
            if vdpzero!? p then g0 := delete(p,g0);

          if !*groebprereduce then g0 := groebprereduce g0;

          x := for each fj in g0 collect
          <<groebsavelterm fj;
            gsetsugar(vdpenumerate vdpsimpcont fj,nil)>>;

          if !*groebprot then
           for each f in x do
           << groebprotsetq(mkid('poly,h:= vdpnumber f), vdp2a f);
              vdpputprop(f,'groebprot,mkid('poly,h))>>;

          g0 := x;

                                       % establish the initial problem
        problems := list (list (nil,nil,nil,g0,abort1,nil,nil,
                          vbccurrentmode!*, nil,nil) );

        !*trgroeb and groebmess1(g,d);
        goto macroloop;


% RESTART:
        groebcheckpoint2();

macroloop:

  while problems and gvbc < groebresmax do
  begin
     groebcheckpoint2a();
                                       % pick up next problem
     x := car problems;
     groebcheckpoint3();
     d := car x;
     g := cadr x;
     g99 := groebstreereconstruct caddr x;
     g0 := cadddr x;
     abort1 := nth(x,5);
     abort2 := nth(x,6);
     pairsdone!* := nth(x,7);
     h := nth(x,8);                     % vbcCurrentMode!*
     factorlevel!* := nth(x,9);
     groesfactors!* := nth(x,10);
     groebcheckpoint4();
     problems := cdr problems;
     g0 := % sort G0, but keep factor in first position
       if factorlevel!* and  g0 and cdr g0 then car g0 . vdplsort cdr g0
        else vdplsort g0;
     x := nil;
     lasth := nil;

                !*trgroeb and groebmess23 (g0,abort1,abort2);

% ITERATION :
      while d or g0 do
       begin
          if groebfasttest(g0,g,d,g99) then goto stop;
                 !*trgroeb and groebmess50(g);
          if g0 then
          <<          % take next poly from input
               h := car g0;
               g0 := cdr g0;
               gsetsugar(h,nil);
               groebsavelterm h;
               p := list(nil,h,h);
          >>
             else
          <<          % take next poly from pairs
               p := car d;
               d := delete (p,d);
               s := groebspolynom (cadr p, caddr p);
               if fact then
                    pairsdone!* := (vdpnumber cadr p
                                      . vdpnumber caddr p)
                              . pairsdone!*;
                           !*trgroeb and groebmess3 (p,s);

               h:=groebnormalform(s,g99,'tree);
               groebsavelterm h;
               h:=groebsimpcontnormalform h;
                 if vdpzero!? h then !*trgroeb and groebmess4(p,d);

                                      % test for possible chains
               if not vdpzero!? h then  % only for real h's
                   << s := groebchain (h,cadr p,g99);
                      if s = h then
                        h := groebchain (h,caddr p,g99);
                        if secondvalue!* then
                            g := delete(secondvalue!*,g)>>;
          >>;

          if vdpzero!? h then goto bott;

          if vevzero!? vdpevlmon h then % base 1 found
                  <<   !*trgroeb and groebmess5(p,h);
                   goto stop>>;

          if testabort(h) then
                  <<   !*trgroeb and groebmess19(h,abort1,abort2);
                   goto stop>>;

          s:= nil;

                    % look for implicit or explicit factorization
          hlist := nil;
          if groebrestriction!* then
                    hlist := groebtestrestriction(h,abort1);
          if not hlist and fact then
                    hlist := groebfactorize(h,abort1,g,g99);
          if hlist = 'zero then goto bott;
          if groefeedback!* then g0 := append(groefeedback!*,g0);
          groefeedback!* := nil;
                   % factorisation found but only one factor survived
          if hlist and length hlist = 2 then
                   <<h := car cadr hlist; hlist := nil>>;
          if not hlist and groebres then
             <<hlist := groebtestresultant(lasth,h,lv);
               if hlist then groebres := nil>>;
          if hlist then
                <<if hlist neq 'cancel then
                   problems:=
                    groebencapsulate(hlist,d,g0,g,g99,
                           abort1,abort2,problems,fact);
                  go stop;
                >>;

                  % h polynomial is accepted now
               h := groebenumerate h; !*trgroeb and groebmess5(p,h);

                              % construct new critical pairs
               d1 := nil;

                   !*trgroeb and groebmess50(g);

              for each f in g do
                  if(car p or % that means "not an input polynomial"
                     not member (vdpnumber h . vdpnumber f, pairsdone!*)
                    ) and gcompatible(f,h)
                   then
                    <<d1 := groebcplistsortin(groebmakepair(f,h),d1);
                      if tt(f,h) = vdpevlmon(f) then
                              <<g := delete (f,g);
                                !*trgroeb and groebmess2 f>>;
                      >>;
                  !*trgroeb and groebmess51(d1);
               d2 := nil;
               while d1 do
                  <<d1 := groebinvokecritf d1;
                    p1 := car d1; d1 := cdr d1;
                    d2 := groebinvokecritbuch4 (p1,d2);
                    d1 := groebinvokecritm (p1,d1);
                  >>;

                 d := groebinvokecritb (h,d);
                 d := groebcplistmerge(d,d2);

                         % monomials and binomials
                 if vdplength h < 3 and car p then
                   <<g := groebsecondaryreduction (h,g,g99,d,nil,t);
                     if g = 'abort then goto stop;
                     g99 := secondvalue!*;
                     d := thirdvalue!*>>;
                 g := h . g;
                 lasth := h;
                 g99 := groebstreeadd(h, g99);
                            !*trgroeb and groebmess8(g,d);
                 goto bott;

    stop:        d := g := g0 := nil;

    bott:
         groebcheckpoint5();
   end;      %  ITERATION

   g := vdplsort g;       % such that T descending

% FINALREDUCTION:
   x := groebbasein2(g,g99,problems,abort1,abort2,fact);
   g1 := car x; problems := cdr x;
   if g1 then <<results := g1 . results; gvbc := gvbc+1>>;
   !*trgroeb and groebmess13(g1,problems);

  end;     % MACROLOOP

  if gvbc  >= groebresmax then
      lpriw("########","warning: GROEBRESMAX limit reached");

  return groebbasein3 results;
end;

symbolic procedure groebfasttest(g0,g,d,g99); nil;
           % a hook for special techniques

symbolic procedure groebbasein2(g,g99,problems,abort1,abort2,fact);
  % final reduction for a base G: reduce each polynomial with the
  % other members; here again support of factorization
  begin scalar !*groebfullreduction,!*groebheufact;     % saving value
   scalar g1,f,h,hlist,x,!*gsugar; integer cnt;
   !*groebfullreduction := t;
   g1 := nil;
   while g do
      <<h := car g;
        g := cdr g;
        if !*groebprot then
          groebprotsetq('candidate,mkid('poly,vdpnumber h));
        h := groebnormalform (h,g,'sort);
        f := groebsimpcontnormalform h;
                           !*trgroeb and groebmess26(h,f);
        if !*groebprot then
          groebprotsetq({'gb,cnt:=cnt+1},'candidate);
        if vdpone!? f then <<g1 := g := nil>>;  % base {1} found
                                                % very late now
        if fact and not vdpzero!? f then
            << hlist := groebfactorize (f,abort1,nil,nil);
               if not null hlist then
                 <<          % lift structure
                  hlist := for each x in cdr hlist collect car x;
                             % discard superfluous factors
                  for each h in hlist do
                       if vdpmember(h,abort1) then
                           <<hlist := delete(h,hlist);
                               !*trgroeb and
                               groebmess19(h,abort1,abort2)>>;
                                       % generate new subproblems
                  x := 0;
                  for each h in hlist do
                    <<hlist := delete(h,hlist);
                      h := groebenumerate h;
                      problems:=
                         list(nil,                 % null D
                              append(g1,g),        % base
                              g99,                 % G99
                              list h,              % G0
                              append(hlist,abort1),
                              abort2,
                              pairsdone!*,
                              vbccurrentmode!*,
                              (x := x+1) . factorlevel!*,
                              groesfactors!*
                             ) . problems;
                    >>;
                  g := g1 := nil;     % cancel actual final reduction
                  f := nil;
                >>
              >>;
        if f and vdpevlmon h neq vdpevlmon f then
        <<g:= vdplsort append(g,f . g1); g1 := nil>> else
        if f and not vdpzero!? f then g1 := append (g1 ,list f);
        >>;
     return g1.problems;
   end;

symbolic procedure groebbasein3 results;
 % final postprocessing : remove multiple bases from the result
 begin scalar x,g,f,p1,p2;
  x := nil; g := results; p1 := p2 := 0;
  while results do
      <<if vdpone!? car car results      % exclude multiple {1}
              then p1 := p1 + 1              % count ones
          else
      <<f := for each p in car results     % delete props for member
                     collect vdpremallprops p;
        if  member (f,x)                     % each base only once
              then p2 := p2 + 1              % count multiples
        else if not groeb!-abort!-id(f,groebabort!*)
           then x := f . x;
         results := cdr results>> >>;
  results := if null x then list list vdpone!* else x;
  return results;
end;

fluid '( !*vbccompress);


symbolic procedure groebchain(h,f,g99);
    % test if a chain from h-plynomials can be computed from the h
   begin scalar h1,h2,h3,count,found;
         secondvalue!* := nil;
       return h; % erst einmal
         if not buch!-vevdivides!? (vdpevlmon h, vdpevlmon f)
              then return h;
         h2 := h;
         h1 := f;
         found := t;
         count := 0;
         while found do
                  <<h3 := groebspolynom(h1,h2);
                    h3 := groebnormalform(h3,g99,'tree);
                    h3 := vdpsimpcont h3;
                    if vdpzero!? h3 then
                           <<found := nil;
                            prin2t "chain---------------------------";
                             vdpprint h1;
                             vdpprint h2;
                             vdpprint h3;
                             secondvalue!* := f;
                             count := 9999>>
                      else
                   if vdpone!? h3 then
                           <<found := nil;
                            prin2t "chain---------------------------";
                             vdpprint h1;
                             vdpprint h2;
                             vdpprint h3;
                             h2 := h3;
                             count := 9999>>

                      else
                    if buch!-vevdivides!?(vdpevlmon h3, vdpevlmon h2)
                      then <<found := t;
                             prin2t "chain---------------------------";
                             vdpprint h1;
                             vdpprint h2;
                             vdpprint h3;
                             h1 := h2;
                             h2 := h3;
                             count := count+1>>
                      else
                           found := nil;
                  >>;
       return if count > 0 then
             << prin2 "CHAIN :"; prin2t count; h2>>
            else h;
    end;


symbolic procedure groebencapsulate(hlist,d,g0,g,g99,
                   abort1,abort2,problems,fact);
% hlist is a factorized h poly. This procedure has the job to
% form new problems from hlist and to add them to problems.
% Result is problems.
% Standard procedure: only creation of subproblems
    begin scalar factl,      % list of factorizations under way
                 u,y,z;
          integer fc;
      if length vdpvars!*>10 or car hlist neq 'factor then
          return groebencapsulatehardcase(hlist,d,g0,g,g99,
                   abort1,abort2,problems,fact);
                            % encapsulate for each factor
      factl := groebrecfactl list hlist;;
                   !*trgroeb and groebmess22 (factl,abort1,abort2);
      for each x in reverse factl do
           <<y := append (car x, g0);
             z := vdpunion (cadr x,abort1);
             u := append(caddr x,abort2);
                  problems :=  list(
                            d,
                            g,
                            g,                       % future G99
                            y,                       % as new problem
                            z,                       % abort1
                            u,                       % abort2
                            pairsdone!*,             % pairsdone!*
                            vbccurrentmode!*,
                            (fc:= fc+1) . factorlevel!*,
                            groesfactors!*
                           ) . problems;
            >>;
        return problems;
end;




symbolic procedure groebencapsulatehardcase(hlist,d,g0,g,g99,
                   abort1,abort2,problems,fact);
% hlist is a factorized h poly. This procedure has the job to
% form new problems from hlist and to add them to problems.
% Result is problems.
% First the procedure tries to compute new h-polynomials from the
% remaining pairs which are not affected by the factors in hlist.
% purpose is to find further factorizations and to do calculations
% in common for all factors in order to shorten the separate later
% branches;
    begin scalar factl,      % list of factorizations under way
                 factr,      % variables under factorization
                 u,h,d1,d2,p1,y,z,p,s,f,gc,pd,break,fl1;
          integer fc;
      factl := list hlist;
      factr := vdpspace car cadr hlist;
      for each x in cdr hlist do
         for each p in x do
             factr := vevunion(factr,vdpspace p);

% ITER:
                                 % now process additional pairs
      while d or g0 do
        begin
          break := nil;
          if g0 then
          <<               % next poly from input
               s := car g0; g0 := cdr g0; p := list(nil,s,s);
          >>
             else
          <<               % next poly fropm pairs
               p := car d; d := delete (p,d);
               if not vdporthspacep(car p,factr) then
                 s:= nil else
               <<s := groebspolynom (cadr p, caddr p);
                        !*trgroeb and groebmess3 (p,s);>>;
          >>;

          if null s or not vdporthspacep(vdpevlmon s,factr) then
              <<                     % throw away s polynomial
                 f := cadr p;
                 if not vdpmember3(f,g0,g,gc)
                      then gc := f . gc;
                 f := caddr p;
                 if car p and not vdpmember3 (f,g0,g,gc)
                      then gc := f . gc;
                  goto bott>>;

          h := groebnormalform(s,g99,'tree);
                  if vdpzero!? h and car p then
                               !*trgroeb and groebmess4(p,d);

          if not vdporthspacep(vdpevlmon h,factr) then
              <<                     % throw away h polynomial
                 f := cadr p;
                 if not vdpmember3(f,g0,g,gc)
                      then gc := f . gc;
                 f := caddr p;
                 if car p and not vdpmember3 (f,g0,g,gc)
                      then gc := f . gc;
                 goto bott>>;

 %%%         if car p then
 %%%               pairsdone!* := (vdpnumber cadr p . vdpnumber caddr p)
 %%%                             . pairsdone!*;

          if vdpzero!? h then goto bott;

          if vevzero!? vdpevlmon h then     % base 1 found
                   goto stop;

          h := groebsimpcontnormalform h;   %  coefficients normalized

          if testabort h then
                 <<!*trgroeb and groebmess19(h,abort1,abort2);
                   goto stop>>;

          s:= nil;

          hlist := nil;
          if groebrestriction!* then
                    hlist := groebtestrestriction(h,abort1);
          if hlist = 'cancel then goto stop;

          if not hlist and fact then
                  hlist := groebfactorize(h,abort1,g,g99);
          if groefeedback!* then g0 := append(groefeedback!*,g0);
          groefeedback!* := nil;
          if hlist and length hlist = 2 then
                   <<h := car cadr hlist; hlist := nil>>;
          if hlist then
                << for each x in cdr hlist do
                      for each h in x do
                           factr := vevunion(factr,vdpspace h);
                  factl := hlist . factl; % add to factors
                  goto bott>>;

          h := groebenumerate h;             % ready now

                        !*trgroeb and groebmess5(p,h);

                              % construct new critical pairs
          d1 := nil;


          for each f in g do
             if tt(f,h) = vdpevlmon(f) and gcompatible(f,h) then
              <<g := delete (f,g);
                d1 := groebcplistsortin( groebmakepair(f,h) , d1);
                             !*trgroeb and   groebmess2 f;
              >>;
                     !*trgroeb and groebmess51(d1);
          d2 := nil;
          while d1 do
                  <<d1 := groebinvokecritf d1;
                    p1 := car d1; d1 := cdr d1;
                    d2 := groebinvokecritbuch4 (p1,d2);
                    d1 := groebinvokecritm (p1,d1);
                  >>;

          d := groebinvokecritb (h,d);
          d := groebcplistmerge(d,d2);

          if vdplength h < 3 then
                    <<g := groebsecondaryreduction (h,g,g99,d,gc,t);
                      if g = 'abort then goto stop;
                      g99 := secondvalue!*;
                      d := thirdvalue!*;
                      gc := fourthvalue!*>>;
          g := h . g;
          g99 := groebstreeadd(h, g99);

                            !*trgroeb and groebmess8(g,d);
          goto bott;

  stop:
         d := g := g0 := gc := factl := nil;
  bott:
         end;     %ITER

                            % now collect all relvevant polys
        g0 := vdpunion(g0,vdpunion(g,gc));

                            % encapsulate for each factor
        if factl then
           << factl := groebrecfactl factl;
              !*trgroeb and groebmess22 (factl,abort1,abort2);
           >>;
        for each x in reverse factl do
           <<fl1 := (fc := fc+1) . factorlevel!*;
             break:= nil;
             y := append (car x, g0);
             z := vdpunion (cadr x,abort1);
             u := append(caddr x,abort2);
             if vdpmember(vdpone!*,y) then break:=vdpone!*;

                        % inspect the unreduced list first
             if not break then for each p in z do
                  if vdpmember(p,y) then break := p;

                        % now prepare the reduced list
            if not break then
            <<y := append (car x,groebreducefromfactors(g0,car x));
              pd := secondvalue!*;
              if vdpmember(vdpone!*,y) then break := vdpone!* else
                 for each p in z do if vdpmember(p,y) then break := p;
              pd := subla(pd,pairsdone!*);
            >>;

            if not break then
                  problems :=  list(
                            nil,                     % new D
                            nil,                     % new G
                            nil,                     % future G99
                            y,                       % as new problem
                            z,                       % abort1
                            u,                       % abort2
                            nil,                     % pairsdone!*
                            vbccurrentmode!*,
                            fl1,                     % factorlevel!*,
                            groesfactors!*           % factor db
                           ) . problems
                else !*trgroeb and groebmess19a(break,fl1);
            >>;
        return problems;
end;

symbolic procedure groebrecfactl (factl);
% factl is a list of factorizations:a list of lists of vdps
% generate calculation pathes from them
   begin scalar rf,res,type;
     if null factl then return list list(nil,nil,nil);
     rf := groebrecfactl (cdr factl);
     factl := car factl;
     type := car factl;   % FACTOR or RESTRICT
     factl := cdr factl;
     while factl do
        <<for each y in rf do
           if vdpdisjoint!?(car factl,cadr y) then
             res := list( vdpunion(car factl,car y),
                     (if type = 'factor then
                         append (for each x in cdr factl collect car x,
                                                                cadr y)
                        else
                      if type = 'resultant then
                         append (for each x in cdr factl collect cadr x,
                                                                cadr y)
                        else cadr y),
                     (if type neq 'factor and type neq 'resultant then
                         append(cdr factl,caddr y)
                        else caddr y)
                    ) . res;
          factl := cdr factl>>;
     return res;
   end;


symbolic procedure groebtestabort (h,abort2);
   % tests if h is member of one of the sets in abort2.
   % if yes, it is deleted. If one wet becomes null, the message
   % "CANCEL is returned, otherwise the updated abort2.
    begin scalar x,break,res;
              % car test the occurence
       x := abort2;
       while x and not break do
        << if vdpmember(h,car x) then break := t;
           x := cdr x>>;
       if not break then return abort2;  % not relvevant
       break := nil;
       while abort2 and not break do
        <<x := vdpdeletemember(h,car abort2);
          if null x then break := t;
          res := x . res;
          abort2 := cdr abort2;
        >>;
       !*trgroeb and groebmess25(h,res);
       if break then return 'cancel;
       return res;
    end;




%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%    Reduction of polynomials
%

symbolic procedure groebnormalform(f,g,type);
     % general procedure for reduction of one polynomial from a set
     %  f is a polynomial, G is a Set of polynomials either in
     %     a search tree or in a sorted list
     % type describes the ordering of the set G:
     %    'TREE     G is a search tree
     %    'SORT     G is a sorted list
     %    'LIST     G is a list, but not sorted
     %  f has to be reduced modulo G
  begin scalar f0,f1,c,vev,divisor,break,done,fold,a;
        integer n,s1,s2;
      if !*groebweak and !*vdpinteger
            and groebweakzerotest(f,g,type) then return f2vdp nil;
      fold := f; f1 := vdpzero(); a:= vbcfi 1;
      gsetsugar(f1,gsugar f);
      while not vdpzero!? f do
          begin
            vev:=vdpevlmon f; c:=vdplbc f;

            if not !*groebfullreduction and not vdpzero!? f1 then
                    g := nil;                 % cut off

            if type = 'sort then
                 while g and vevcompless!?(vev,vdpevlmon car g)
                            do g := cdr g;
            if null g then
                  <<f1:=vdpsum (f1,f); f:=vdpzero();
                    break := t; divisor := nil; goto ready>>;

            divisor :=
               if type = 'tree then groebsearchinstree(vev,g)
                               else groebsearchinlist (vev,g);

            if divisor then done := t;    % true action indicator

            if divisor and !*trgroebs then
                       << prin2 "//-";
                          prin2 vdpnumber divisor;
                          >>;
            if divisor then
                      if vdplength divisor = 1 then
                            f := vdpcancelmvev(f,vdpevlmon divisor)
                          else
                      if !*vdpinteger or not !*groebdivide then
                       << f:=groebreduceonestepint(f,f1,c,vev,divisor);
                          f1 := secondvalue!*; n := n+1;
                          if  not vdpzero!? f and
                              n #> groecontcount!* then
                          <<f0 := f;
                            f:=groebsimpcont2(f,f1);
                            groecontentcontrol(f neq f0);
                            f1 := secondvalue!*; n := 0 >>;
                       >>
                       else
                        f := groebreduceonesteprat(f,nil,c,vev,divisor)
               else
                  <<!*gsugar and <<s1:=gsugar(f);s2:=gsugar(f1)>>;
                    f1 := vdpappendmon (f1,vdplbc f,vdpevlmon f);
                    f := vdpred f;
                    !*gsugar and <<gsetsugar(f,s1);
                                   gsetsugar(f1,max(s2,s1))>>;
                    >>;
            ready:
          end;
      if !*groebprot then groebreductionprotocolborder();
      if not done then f1 := fold;
      return f1;
   end;

symbolic procedure groecontentcontrol u;
   % u indicates, that a substantial content reduction was done;
   % update content reduction limit from u.
  groecontcount!*:= if not numberp groecontcount!* then 10 else
                    if u then max(0,groecontcount!*-1)
                         else min(10,groecontcount!*+1);

symbolic procedure groebvbcbig!? a;
    % test if a is a "big" coefficient
     (if numberp x then (x > 1000000000000 or x < -1000000000000)
                   else t)
             where x=vbcnumber a;

symbolic procedure groebsimpcontnormalform h;
  % simpCont version preserving the property SUGAR
     if vdpzero!? h then h else
     begin scalar sugar,c;
         sugar :=gsugar h; c:=vdplbc h;
         h := vdpsimpcont h;
         gsetsugar(h,sugar);
         if !*groebprot and not(c=vdplbc h)then
          groebreductionprotocol2
             reval list('quotient,vbc2a vdplbc h,vbc2a c);
         return h;
     end;

symbolic procedure groebsimpcont2(f,f1);
  % simplify two polynomials with the gcd of their contents;
    begin scalar c,s1,s2;
         s1:=gsugar f; s2:=gsugar f1;
         c := vdpcontent f;
         if vbcone!? vbcabs c then goto ready;
         if not vdpzero!? f1 then
         << c := vdpcontent1(f1,c);
            if vbcone!? vbcabs c then goto ready;
            f1 :=  vdpdivmon(f1,c,nil)>>;
         f := vdpdivmon(f,c,nil);
                 !*trgroeb and groebmess28 c;
         groebsaveltermbc c;
         gsetsugar(f,s1); gsetsugar(f1,s2);
      ready:
         secondvalue!* := f1; return f;
    end;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  special case reductions
%

symbolic procedure groebprereduce g;
% reduce the polynomials in g with themselves.
% the reduction is continued until headterms are stable
% is possible;
  begin scalar res,work,oldvev,f,oldf,!*groebweak,!*groebfullreduction;
        integer count;
     if !*trgroebs then
     <<  g := for each p in g collect vdpenumerate p;
         for each p in g do vdpprint p>>;
     res := nil; % delete zero polynomials from G
     for each f in g do if not vdpzero!? f then res := f . res;
     work := g := res := reversip res;
     while work do
      << g := vdplsort res;   % sort prvevious result
         if !*trgroebs then prin2t "Starting cycle in prereduction.";
         res := nil;
         count := count + 1;
         work := nil;
         while g do
         << oldf := f:= car g; g := cdr g;
            oldvev := vdpevlmon f;
            f := vdpsimpcont groebnormalform (f,g,'sort);
            if (!*trgroebs or !*groebprot) and not vdpequal(f,oldf) then
            <<f := vdpenumerate f;
              if !*groebprot then
                if not vdpzero!? f then
                 groebprotsetq(mkid('poly,vdpnumber f), vdp2a f)
                 else groebprotval 0;
              if !*trgroebs then
                 <<prin2t "reducing"; vdpprint oldf; prin2t "to";
                                                    vdpprint f>>;
            >>;
            if not vdpzero!? f then
            <<if oldvev neq vdpevlmon f then work := t;
              res := f . res>>;
         >>;
      >>;
     return for each f in res collect vdpsimpcont f;
     end;

symbolic procedure groebreducefromfactors (g,facts);
% reduce the polynomials in G from those in facts.
   begin scalar new,gnew,f,nold,nnew,numbers;
     if !*trgroebs then <<
                  prin2t "replacing from factors:";
                  for each x in facts do vdpprin2t x
                        >>;
     while g do
          <<f := car g;
            g := cdr g;
            nold := vdpnumber(f);
            new :=  groebnormalform(f,facts,'list);
            if vdpzero!? new then
               << if !*trgroebs then <<prin2 "vanishes ";
                                       prin2 vdpnumber f
                                     >>;
               >>
            else
            if vevzero!? vdpevlmon new then
               << if !*trgroebs then <<prin2 "ONEPOL ";
                                       prin2 vdpnumber f
                                     >>;
                 g := nil;
                 gnew := list vdpone!*;
               >>
            else
            <<
              if new neq f then
               <<new := vdpenumerate vdpsimpcont new;
                 nnew := vdpnumber new;
                 numbers := (nold . nnew) . numbers;
                 if !*trgroebs then <<prin2 "replacing ";
                                      prin2 vdpnumber f;
                                      prin2 " by ";
                                      prin2t vdpnumber new
                                      >>;
               >>;
              gnew := new . gnew;
            >>;
          >>;
    secondvalue!* := numbers;
    return gnew;
    end;

 % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  support for Reduction by "simple" polynomials

symbolic procedure groebnormalform1(f,p);
    % short version; reduce f by p
    % special case: p is a nomomial
     if vdplength p = 1 then vdpcancelmvev(f,vdpevlmon p)
            else groebnormalform(f,list p,nil);

symbolic procedure groebprofitsfromvev(p,vev);
    % tests, if at least one monomial from p would be reduced by vev
    if vdpzero!? p then nil
        else
    if buch!-vevdivides!?(vev, vdpevlmon p) then t
        else
            groebprofitsfromvev(vdpred p,vev);


% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  special reduction procedures



symbolic procedure groebreduceonestepint(f,f1,c,vev,g1);
      % reduction step for integer case:
      % calculate f= a*f - b*g a,b such that leading term vanishes
      %                        (vev of lvbc g divides vev of lvbc f)
      %
      % and  calculate f1 = a*f1
      % return value=f, secondvalue=f1
 begin scalar vevlcm,a,b,cg,x,rg1;
            % trivial case: g1 single monomial
      if vdpzero!? (rg1:= vdpred g1)
          then return <<f := vdpred f; secondvalue!* := f1; f>>;
      vevlcm := vevdif(vev,vdpevlmon g1);
      cg := vdplbc g1;
            % calculate coefficient factors
      x := if not !*groebdivide then vbcfi 1 else vbcgcd(c,cg);
      a := vbcquot(cg,x);
      b := vbcquot(c,x);
            % multiply relvevant parts from f and f1 by a (vbc)
      if f1 and not vdpzero!? f1 then f1 := vdpvbcprod(f1,a);
      if !*groebprot then groebreductionprotocol(a,vbcneg b,vevlcm,g1);
      f:= vdpilcomb1 (vdpred f, a, vevzero(),
                     rg1,vbcneg b, vevlcm);
            % return with f and f1
      secondvalue!*:= f1;
      thirdvalue!* := a;
      return f;
 end;


symbolic procedure groebreduceonesteprat(f,dummy,c,vev,g1);
      % reduction step for rational case:
      % calculate f= f - g/vdpLbc(f)
      %
 begin scalar x,rg1,vevlcm;
            % trivial case: g1 single monomial
      if vdpzero!? (rg1 := vdpred g1) then return vdpred f ;
            % calculate coefficient factors
      x := vbcneg vbcquot(c,vdplbc g1);
      vevlcm := vevdif(vev,vdpevlmon g1);
      if !*groebprot then
         groebreductionprotocol(a2vbc 1,x,vevlcm,g1);
      return vdpilcomb1(vdpred f,a2vbc 1,vevzero(),
                            rg1,x,vevlcm);
 end;


symbolic procedure groebreductionprotocol(a,b,vevlcm,g1);
    if !*groebprot then
        groebprotfile :=
        if not vbcone!? a then
         append(groebprotfile,
                list(
                   list('equal,
                        'candidate,
                         list('times,'candidate,vbc2a a)),
                   list('equal,
                        'candidate,
                        list('plus,
                             'candidate,
                             list('times,
                                  vdp2a vdpfmon(b,vevlcm),
                                  mkid('poly,vdpnumber g1) )))
               )    )
        else
        append(groebprotfile,
                list(
                   list('equal,
                        'candidate,
                        list('plus,
                             'candidate,
                             list('times,
                                  vdp2a vdpfmon(b,vevlcm),
                                  mkid('poly,vdpnumber g1) )))

               )    ) ;

symbolic procedure groebreductionprotocol2 a;
      if !*groebprot then
        groebprotfile :=
        if not(a=1) then
         append(groebprotfile,
                list(
                   list('equal,
                        'candidate,
                         list('times,'candidate,a))));

symbolic procedure groebreductionprotocolborder();
        append(groebprotfile,'!+!+!+!+!+!+!+!+!+!+!+!+!+!+!+!+ . nil);



symbolic procedure groebprotsetq(a,b);
    groebprotfile :=
      append (groebprotfile,
              list (list ('equal,a,b)));

symbolic procedure groebprotval a;
    groebprotfile :=
      append (groebprotfile,
              list (list ('equal,'intermediateresult,a)));



symbolic procedure subset!?(s1,s2);
    % tests if s1 is a subset of s2
       if null s1 then t
          else
       if member(car s1,s2) then subset!?(cdr s1,s2)
          else
            nil;

symbolic procedure vevsplit (vev);
      % split vev such that each exponent vector has only one 1
      begin scalar n,vp,e;
        n := 0;
        for each x in vev do
            <<n := n+1;
              if x neq 0 then
                <<e := append (vdpevlmon vdpone!*,nil);
                  rplaca(pnth(e,n),1);
                  vp := e . vp;
                >>;
            >>;
        return vp;
     end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%   calculation of an S-polynomial
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%general strategy:
%
%  groebSpolynom4 calculates the traditional s-Polynomial from p1,p2
%    (linear combination such that the highest term vanishes).
%  groebSpolynom2 subtracts multiples of p2 from the s-polynomial such
%    that head terms are eliminated early.

symbolic procedure groebspolynom (p1,p2);
     groebspolynom2(p1,p2);


symbolic procedure groebspolynom2 (p1,p2);
     if vdpzero!? p1 then p2 else if vdpzero!? p2 then p1 else
   begin scalar s,tp1,tp2,ts,cand;
     s := groebspolynom3(p1,p2);
     if vdpzero!? s or vdpone!? s or !*groebprot then return s;
     tp1 := vdpevlmon p1; tp2 := vdpevlmon p2;
     while not vdpzero!? s
       and ((buch!-vevdivides!?(tp2,(ts := vdpevlmon s))
                and (cand := p2))
           or
           (buch!-vevdivides!?(tp1,(ts := vdpevlmon s))
                and (cand := p1)))
        do << if !*vdpinteger then
                    s := % vdpsimpcont
                          groebreduceonestepint(s,nil,vdplbc s,ts,cand)
                       else
                          % rational, float and modular case
                        s := groebreduceonesteprat
                                  (s,nil,vdplbc s,ts,cand);
           >>;
     return s;
   end;

symbolic procedure groebspolynom3(p,q);
   begin scalar r;
     r:=groebspolynom4(p,q);
     groebsavelterm r;
     return r;
   end;

symbolic procedure groebspolynom4 (p1,p2);
  begin scalar ep1,ep2,ep,rp1,rp2,db1,db2,x,r;
    ep1 := vdpevlmon p1; ep2 := vdpevlmon p2;
    ep := vevlcm(ep1, ep2);
    rp1 := vdpred p1; rp2 := vdpred p2;
    gsetsugar(rp1,gsugar p1); gsetsugar(rp2,gsugar p2);
    r:=     ( if vdpzero!? rp1 and vdpzero!? rp2 then rp1
              else ( if vdpzero!? rp1 then
                      <<db2:=a2vbc 0;
                        vdpprod(rp2,
                                vdpfmon(db1:=a2vbc 1,
                                       vevdif(ep, ep2) ) )
                      >>
                     else if vdpzero!? rp2 then
                      <<db1:=a2vbc 0;
                        vdpprod(rp1,
                                vdpfmon(db2:=a2vbc 1,
                                        vevdif(ep, ep1) ) )
                      >>
                          else
                             <<db1 := vdplbc p1;
                               db2 := vdplbc p2;
                               if !*vdpinteger then
                                  << x:= vbcgcd (db1,db2);
                                     if not vbcone!? x then
                                     << db1 := vbcquot (db1,x);
                                        db2 := vbcquot (db2,x);
                                  >> >>;
                                vdpilcomb1 (rp2,db1,vevdif(ep,ep2),
                                          rp1,vbcneg db2,vevdif(ep,ep1))
                             >>
                   )
            );
     if !*groebprot then
        groebprotsetq('candidate,
         {'difference,
           {'times,vdp2a vdpfmon(db2,vevdif(ep,ep2)),
                   mkid('poly,vdpnumber p1)},
           {'times,vdp2a vdpfmon(db1,vevdif(ep,ep1)),
                      mkid('poly,vdpnumber p2)}} );

     return r;
end;

symbolic procedure groebsavelterm r;
     if !*groelterms and not vdpzero!? r then
        groebsaveltermbc vdplbc r;

symbolic procedure groebsaveltermbc r;
     <<r:=vbc2a r;
       if not numberp r and not constant_exprp r then
         for each p in cdr fctrf numr simp r do
         <<p:=prepf car p;
           if not member(p,glterms) then nconc(glterms,list p);
      >> >>;

symbolic procedure sfcont f;
   % Calculate the integer content of standard form f.
      if domainp f then f else
      gcdf(sfcont lc f, sfcont red f);

symbolic procedure vdplmon u; vdpfmon (vdplbc u,vdplbc u);

symbolic procedure vdpmember3(p,g1,g2,g3);
     % test membership of p in one of then lists g1,g2,g3
       vdpmember(p,g1) or vdpmember(p,g2) or vdpmember(p,g3);

symbolic procedure groeb!-abort!-id(base,abort1);
   % Test whether one of the elements in abort1 is
   % member of the ideal described by base. Definite
   % test here.
  if null abort1 then nil else
   vdpzero!?(groebnormalform(car abort1,base,'list))
     or groeb!-abort!-id(base,cdr abort1);

endmodule;


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;


module groesolv; % Tools for solving systems of polynomials (and poly-
%               % nomial equations) based on Groebner basis techniques.

%   Authors:     H.Melenk (ZIB Berlin)
%                H.M Moeller (Fernunversitaet Hagen)
%                W.Neun (ZIB Berlin)
%
%    Aug 1992:   accepting external solutions for univariate pols.
%
%    March 1994: access to roots/multroot.
%
%    Feb 1995: assumptions, requirements added.

% operators:
%
%      GROESOLVE      does the whole job of solving a nonlinear
%                     set of expressions and / or equations
%
%      GROEPOSTPROC   expects that its car parameter is a
%                     lexical groebner base already


fluid '(groesolvelvevel!* !*groebprereduce);
fluid '(groesoldb!* groesoldmode!* !*groebnumval !*groebcomplex
        !*groebopt !*groebprot !*groesolrecurs
        !*groesolgarbage denominators!* variables!*
        groebroots!*    % a-list for predefined root expressions
        depl!*          % the reduce dependency list
        !*vdpinteger    % coefficient mode
        !*compxroots    % switch for multroot
        gmodule
        !*arbvars
       );

fluid '(!*convert !*ezgcd !*msg !*precise dmode!* !*varopt);
global '(groebprotfile gvarslast !*trgroesolv glterms assumptions
         requirements);

groesolvelvevel!* := 0;

symbolic procedure groesolveeval u;
    begin scalar !*ezgcd,gblist,oldtorder,res,!*groebopt,!*precise,
            y,fail,problems,denominators!*,variables!*,gmodule,at;
      if null dmode!* then !*ezgcd := t;
      !*groebopt := !*varopt; gvarslast :='(list);
      oldtorder := apply1('torder,'(lex));
      groesoldmode!* := get(dmode!*,'dname);
      !*groebcomplex := !*complex;
      groesetdmode(groesoldmode!*,nil);
      problems:={u};
      while problems and not fail do
      <<u:=car problems; problems:=cdr problems;
        gblist := cdr groebnerfeval u;
        at := union(at,cdr glterms);
        !*groebopt := nil;    % 29.8.88
        groesetdmode(groesoldmode!*,t);
        if null variables!* then variables!*:=gvarslast;
        if not(gblist = '((list 1))) then
         for each gb in gblist do
         <<if !*trgroesolv then
             <<writepri("starting from basis",'first);
               writepri(mkquote gb,'last)>>;
           for each r in res do if gb
                % do not compare with the mother problem;
             and not subsetp(car r,car u)
              then
           if groesolvidsubset!?(gb,car r,variables!*) then
              res:=delete(r,res) else
           if groesolvidsubset!?(car r,gb,variables!*) then
              <<gb:=nil;
                if !*trgroesolv then writepri("redundant",'only)
              >>;
           if gb then
           <<y:=groesolvearb(groesolve0(gb,variables!*),variables!*);
             if y neq 'failed then res:=(gb.y).res else fail:=t;
             if !*trgroesolv then
             <<writepri("partial result:",'first);
               writepri(mkquote('list.cdar res),'last)
             >>;
             for each d in denominators!* do
              problems:={append(gb,{d}),variables!*}.problems;
             denominators!*:=nil;
           >>;
          >>;
        >>;
      apply1('torder,{oldtorder});
      problems:=nil; if fail then res:=nil;
      if null res then requirements:=append(requirements,at)
        else assumptions := append(assumptions,at);
      for each r in res do problems:=union(cdr r,problems);
      return 'list . groesolve!-redun2 problems
     end;

symbolic procedure groesolve!-redun2 sol;
  % Sol is a list of solutions; remove redundancies, now not
  % by ideal theory but by simple substitution.
 begin scalar b;
   for each s in sol do
     if s memq sol then
     <<b:=nil;
       for each r in sol do
         if not(r eq s) then
           if not b and groesolve!-redun2a(r,s) then b:=r;
       if b then sol:=delete(s,sol);
     >>;
   return sol;
 end;

symbolic procedure groesolve!-redun2a(r,s);
  % redundancy test: if sub(s,r)=> trivial then t because s
  % is a special case of r.
    if smemq('root_of,s) then nil else
  begin scalar q,!*evallhseqp,!*protfg;
    !*evallhseqp:=t; !*protfg:=t;
    q:=errorset({'subeval,mkquote {s,r}},nil,nil);
    if errorp q then <<erfg!*:=nil;return nil>>;
    q:=cdar q;
    while q and 0=reval{'difference,cadar q,caddar q} do q:=cdr q;
    return null q;
  end;

symbolic procedure groesolvidsubset!?(b1,b2,vars);
   % test if ideal(b1) is a subset of ideal(b2)
   % (b2 is a specialization of b1 wrt zeros).
  null b1 or (car b1='list or 0=preduceeval{car b1,b2,vars}) and
      groesolvidsubset!?(cdr b1,b2,vars);

symbolic procedure groesolvearb(r,vars);
 % Cover unmentioned variables.
  if atom r or not !*arbvars then r else
  for each s in r collect
   <<for each x in cdr vars do
       if not smember(x,s) then
            s:=append(s,{{'equal,x,prepf makearbcomplex()}});
     s>>;

%------------------- driver for the postprocessor ----------------

symbolic procedure groesolve0(a,vars);
  begin scalar r,ids,newvars,newa;
    if(r:=groepostnumsolve(a,vars))then return r;
    if(r:=groepostfastsolve(a,vars))then return r;
    r:=groepostsolveeval{a,vars};
    if r neq 'failed then return cdr r;
    ids:=cdr gindependent_seteval{a,vars};
    if null ids then goto nullerr;
    ids:=car ids;
    newvars:='list.for each x in cdr vars join
                 if not(x memq ids) then {x};
    newa:=groebnereval{a,newvars};
    denominators!*:=cdr glterms;
    if newa='(list 1) then rerror(groebner,24,
        "recomputation for dim=0 failed");
    r:=groepostfastsolve(newa,newvars);
    if r then return r;
    r:=groepostsolveeval{a,vars};
    if r neq 'failed then return cdr r;
nullerr:
    rerror(groebner,23,
        "Moeller ideal decomposition failed with 0 dim ideal");
    end;

symbolic procedure groepostnumsolve(gb,vars);
  if not errorp errorset('(load!-package 'roots2),nil,nil)
  and getd 'multroot0
  and get(dmode!*,'dname) member '(rounded complex!-rounded)
  and length gb = length vars and groepostnumsolve1(gb,vars)
  then (cdr reval multroot0(precision 0,gb)) where !*compxroots=t;

symbolic procedure groepostnumsolve1(gb,vars);
  if null gb then t else
  groepostnumsolve1(cdr gb,cdr vars) and
  <<for each x in kernels numr simp car gb do q:=q and x member vars;
    q>> where q=t;

symbolic procedure groepostfastsolve(gb,vars);
   % try to find a fast solution.
  begin scalar u,p1,p2,fail,kl,res;
    if !*trgroesolv then prin2t "fast solve attempt";
    groesoldmode!* := get(dmode!*,'dname);
    !*groebnumval := member(groesoldmode!* ,
                  '(rounded complex!-rounded));
    groesetdmode(groesoldmode!*,'nil);
    u:=kl:=for each p in cdr gb collect
         <<p:=numr simp p;
           intersection(vars,kernels p).p>>;
    if u='((nil)) then goto trivial;
    while u and cdr u do
    <<p1:=car u; p2:=cadr u; u:= cdr u;
      car p1:=setdiff(car p1,car p2);
      fail:=fail or null car p1>>;
    if fail then goto exit;
    res:= for each r in groepostfastsolve1(reverse kl,nil,0)
        collect 'list.reverse r;
    goto exit;
  trivial:
    res:= {'list.for each x in cdr vars collect
                {'equal,x,mvar makearbcomplex()}};
  exit:
    groesetdmode(groesoldmode!*,t);
    return res;
   end;

fluid '(f);

symbolic procedure groepostfastsolve1(fl,sub,n);
   if null fl then '(nil) else
   begin scalar u,f,v,sub1;
     n:=n+1;
     f:=car fl; v:=car f;  f:=numr subf(cdr f,sub);
     if null f then return groepostfastsolve1(cdr fl,sub,n);
     % v:=car sort(v,function(lambda(x,y);degr(f,x)>degr(f,y)));
     v := car v;
     (f:=reorder f) where kord!*={v};
     if not domainp lc f then groepostcollectden reorder lc f;
     u:=groesolvepolyv(prepf f,v);
     return for each s in u join
     <<sub1:=if smemq('root_of,s) then sub else
         (v . caddar s) . sub;
       for each q in groepostfastsolve1(cdr fl,sub1,n) collect
         car s.q
     >>;
   end;

unfluid '(f);

symbolic procedure groepostcollectden d;
  % d is a non trivial denominator (standard form);
  % collect its factors.
 for each p in cdr fctrf d do
  if not member(p:=prepf car p,denominators!*) then
      denominators!*:=p.denominators!*;

put('groesolve,'psopfn,'groesolveeval);

symbolic procedure groepostsolveeval u;
    begin scalar a,b,vars,oldorder;
          scalar groesoldb!*;
          scalar !*groebprereduce,!*groebopt,!*groesolgarbage;
        groesoldmode!* := get(dmode!*,'dname);
        groesetdmode(groesoldmode!*,'nil);
        !*groebnumval := member(groesoldmode!* ,
                          '(rounded complex!-rounded));
        if vdpsortmode!* = 'lex then t else
          rerror(groebner,8,
                 "Groepostproc, illegal torder; (only LEX allowed)");
        a := groerevlist reval car u;
        vars := cdr u and groerevlist cadr u or groebnervars(a,nil);
        oldorder := setkorder vars;
        b :=  groesolve1(a,a,vars);
        a := nil;
        if b eq 'failed then a:=b else
        <<for each sol in b do % delete multiplicities
            if not member(sol,a) then a := sol . a;
          a := 'list . for each sol in a collect 'list . sol;
        >>;
        setkorder oldorder;
        groesetdmode(groesoldmode!*,t);
        return a;
    end;

put('groepostproc ,'psopfn,'groepostsolveeval);


% DATA structure:
%
%  all polynomials are held in prefix form (expressions)
%  transformation to standard quotients/ standard forms is done locally
%  only; distributive form is not used here.
%
%  a zero is a set of equations, if possible with a variable on the
%  lhs each
%       e.g. {y=17,z=b+8};
%        internally: ((equal y 17)(equal z (plus b 8)))
%  a zeroset is a list of zeros
%       elgl {{y=17,z=b+8},{y=17,z=b-8}}
%  internally the sets (lists) are kept untagged as lists; the
%  tag 'list is only added to the results and to those lists which
%  are parameters to algebraic operators not in this package.

symbolic procedure groesolve1 (a,fulla,vars);
 %  A        lex Groebner basis or tail of lex Groebner basis
 %  fullA    the complete lex Groebner basis to A
 %  vars     the list of variables
  if null a or a='(1) then nil else
  <<begin scalar f1,a1,res,q,gi,ng1,ng2,ngq,qg,mv,test;
      res := assoc (a,groesoldb!*); if res then return cdr res;
      groesolvelvevel!* := groesolvelvevel!* + 1;
      %%tr prin2t  "=================================================";
      %%tr prin2l list( " groesolvelvevel!*: ",groesolvelvevel!*);
      %%tr           prin2t " Problem:";
      %%tr                   writepri (mkquote ('list . a),'only);;
      if member(a,!*groesolrecurs) then return 'failed;
%        <<vars := append(cdr vars,{car vars});
%          if member(vars,!*groesolrecurs) then
%          <<!*groesolgarbage := T;
%            return list for each p in A collect list('EQUAL,p,0) >>;
%          !*groesolrecurs := vars . !*groesolrecurs;
%          A := cdr Groebnereval{'list.A,'list . vars};
%        >>;
      !*groesolrecurs := a . !*groesolrecurs;
      if length a = 1 then
       << %%tr print  "single polynomial; solve it";
          res := groesolvepoly car a; goto ready>>;
         % step 1
      f1 := car a;
      a1 := cdr a;
      test := nil;
      mv := intersection(vars,ltermvariables f1);    % test Buchcrit 4
      for each p in a1 do
         if intersection (mv,ltermvariables p) then test := t;
      if not test then
      << %%tr print "f1 has unique main variable";
         ngq := groesolve1(a1,a1,vars);
         if ngq eq 'failed then <<res:='failed;goto ready>>;
         res := zerosetintersection(ngq,f1,vars);
         goto ready>>;
%     Q := cdr GroebIdq('list . A1,f1,'list . vars);    % A1:f1
      q := groesolvidq(a1,f1,vars);
        %%tr print "A1:f1"; %%tr writepri (mkquote ('list . Q),'only);;
      if q='(1) then     % f1 already member of A1; skip it
        <<%%tr print "f1 already in A1; ignore";
          res:= groesolve1(a1,fulla,vars);
          goto ready>>;
      ngq := groesolve1(q,q,vars);
      if ngq eq 'failed then <<res:='failed;goto ready>>;
      ng1 := zerosetintersection (ngq,f1,vars);
         % step 4
      if groesolvidqtest(a1,f1,vars) then
      << while q do
         << gi := car q; q := cdr q;
            gi := preduceeval list (gi , 'list . a, 'list . vars);
            if gi = 0 then q:= nil else
               a := cdr groebidq('list . a ,gi,'list . vars);
         >>;
         ng2 := groesolve1(a,a,vars);
         if ng2 eq 'failed then <<res:='failed;goto ready>>;
      >> else
      <<ng2 := ();
         if length q = 1 then
         << gi := preduceeval list (car q, 'list . fulla, 'list . vars);
           if gi neq 0 then
           << qg := cdr groebidq('list . fulla,gi,'list . vars); % A1:gi
              ng2 := groesolve1(qg,qg,vars);
              if ng2 eq 'failed then <<res:='failed;goto ready>>;
         >> >>
         else
            <<ng2 := groesolve2(a1,q,vars);
              if ng2 eq 'failed then <<res:='failed;goto ready>>
            >>
      >>;
      res:= zerosetunion (ng1,ng2);
    ready:
      %%tr print list( "Result, level!*: ",groesolvelvevel!*);
      %%tr writeres res;
      %%tr print "...................................................";
      groesolvelvevel!* := groesolvelvevel!* -1;
      groesoldb!* := (a . res) . groesoldb!*;
      return res;
   end
   >> where !*groesolrecurs = !*groesolrecurs; % recursive fluid!

symbolic procedure groesolvidqtest(a1,f1,vars);
      not(deg(f1,car vars) eq deg(car a1,car vars));

symbolic procedure groesolvidq(a1,f1,vars);
      begin scalar x,temp;
         x := car  vars;
         if not groesolvidqtest(a1,f1,vars)
             then return cdr groebidq('list . a1,f1,'list . vars);
         temp :=
           for each p in a1 collect
             reval car reverse coeffeval list(p,x);
         return cdr groebnereval list ('list . temp,'list . vars);
       end;

symbolic procedure groesolve2(a,q,vars);
  % Calculation of the zeroset A1:(g1,g2,,,,gs),
  % the gi given as members of Q.
     groesolvetree (a,q,q,vars);

symbolic procedure groesolvetree(a,t1,phi,vars);
   begin scalar q,ngtemp,ngall,t2,h,g,a2,phi2;
      %%tr prin2t ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>";
      %%tr prin2t "groesolvetree; A:";
      %%tr writepri(mkquote ('list . a),'only);
      %%tr writepri( "T1 :",'car);
      %%tr writepri(mkquote ('list . T1) ,'last);
      %%tr writepri( "phi:",'car);
      %%tr writepri(mkquote ('list .  phi),'last);
       if null phi then return nil else
       if null t1 then
          <<q := cdr groebidq('list.a, 'times.phi,'list.vars);
            %%tr prin2t "<< << << << << << << << << << << << << <<<";
            return if car q = 1 then nil
                                else groesolve1(q,q,vars) >>;
       for each g in t1 do
       <<h:=preduceeval list(g,'list.a,'list.vars);
         phi := delete(g,phi);
         if not(h=0) then <<t2:=h.t2; phi:=h.phi>>;
       >>;
       if null phi then return nil;  % 29.8.88
       t1 := t2;
       q := cdr groebidq('list.a, 'times.phi,'list.vars);
        %%tr writepri( "PHI :",'car);
        %%tr writepri(mkquote ('TIMES.phi) ,'last);
        %%tr writepri( "A:PHI :",'car);
        %%tr  writepri(mkquote ('LIST.Q) ,'last);
       if not(car q = 1) then
       << ngall := groesolve1(q,q,vars);
          if ngall eq 'failed then return 'failed;
       >>;
       if !*groesolgarbage then
               return groesolverestruct(q,phi,vars,ngall);
        while t1 do
          <<g:=car t1; t1:=cdr t1;
            phi2 := delete(g,phi);
            if phi2 then
            <<a2 := cdr groebnereval list('list . g . a,'list . vars);
              if not(car a2 =1) then
               <<ngtemp := groesolvetree(a2,t1,phi2,vars);
                 ngall := zerosetunion(ngtemp,ngall)>>;
           >>>>;
       %%tr prin2t "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<";
       return ngall;
   end;

symbolic procedure groesolverestruct(a,phi,vars,ngall);
     % there was a problem with an embedded solution in phi such that
     % A:phi = A
     % we try a heuristic by making one variable a formal parameter
    begin scalar newa,newvars,mv,oldorder,solu;
        mv := ltermvariables ('times.phi);
        mv := car mv;
         %%tr prin2 "groesolverestruct:taking variable ";prin2t mv;
        newvars := delete(mv,vars);
        oldorder := setkorder newvars;
        newa := cdr groebnereval list('list . a,'list . newvars);
         %%tr    prin2t "new Groebner basis:";
         %%tr    writepri(mkquote ('LIST . newA),'ONLY);
        !*groesolgarbage := nil;
        solu := groesolve1(newa,newa,newvars);
         %%tr if !*groesolgarbage then prin2t "Heuristics failed"
         %%tr                     else prin2t "better result";
        setkorder oldorder;
        return if !*groesolgarbage then ngall else solu;
    end;



%%tr symbolic procedure writeres r;
%%tr writepri (mkquote ('list.for each x in r collect 'list.x),'ONLY);

symbolic procedure ltermvariables u;
  % extract variables of leading term in u
    begin scalar v;
      u := numr simp u;
      while not domainp u do
      <<v := mvar u . v;
        u := lc u>>;
      return reversip v;
    end;

symbolic procedure zerosetintersection (ng,poly,vars);
     % NG is a zeroset
     % poly is a polynomial
     % the routine maps the zeros in NG by the polynomial:
     %   each zero is substituted into the polynomial;
     %   that gives a univariate
     %   solved by SOLVE or numerical techniques.
     % the result is the solution NG, including the solutions of the
     % polynomial.
   begin scalar res,ns,testpoly,ppoly,sol,s,var,dom;
      %%tr print "Intersection ";
      %%tr writepri (mkquote ('list . NG),'only);
      %%tr         print " with ";
       %%tr writepri(mkquote poly,'only);
      res := ();
      poly := simp poly;
      var:=if not domainp numr poly then groesolmvar(numr poly,vars)
             else 'constant;
    loop:
      if ng=() then goto finish;
      ns := car ng; ng := cdr ng;
      testpoly := poly;
      dom := groesoldmode!* or 'rational;
      groesetdmode(dom,t);
      testpoly := simp prepsq testpoly;
      for each u in ns do
       if idp lhs u and not smemq('root_of,rhs u) then
       <<s := rhs u;
         testpoly := subsq(testpoly,list (lhs u . s));
       >>;
      groesetdmode(dom,nil);
      ppoly := prepf numr testpoly;
      sol := groesolvepolyv(ppoly,var);
      res := append(res , for each r in sol collect append(r,ns) ) ;
      goto loop;
    finish:
      %%tr print  "Schnittresultat: ";
      %%tr writeres res;
      return res;
   end;

symbolic procedure groesolmvar(poly,vars);
  % select main variable wrt vars sequence.
   <<while vars and not smember(car vars,poly) do
      vars:=cdr vars;
     if null vars then rerror('groebner,27,"illegal poly");
     car vars>>;


% solving a single polynomial with respect to its main variable

symbolic procedure groesolvepoly p; groesolvepolyv(p,mainvar p);

symbolic procedure groesolvepolyv(p,var);
   % find the zeros for one polynomial p in the
   % variable "var".
   % current dmode is NIL.
  (begin scalar res,u,!*convert,y,z;
      if (u:=assoc(var,depl!*)) then depl!*:=delete(u,depl!*);
      if !*trgroesolv then
      <<writepri("   solving univariate with respect to ",'first);
        writepri(mkquote var,'last);
        writepri(mkquote p,'only);
      >>;
      for each s in groebroots!* do
       if 0=reval{'difference,p,car s} then res:=cdr s;
      if res then return res;
      groesetdmode(groesoldmode!*,t);
      u := numr simp p;
      res := if !*groebnumval and univariatepolynomial!? u
               then groeroots(p,var)
              else (solveeval list (p,var))
                where kord!*=nil,
                alglist!* = nil . nil;
      res := cdr res;
       % Collect nontrivial denominator factors.
       % Reorder for different local order during solveeval.
      for each x in res do
      <<y:=prepf (z:=reorder denr simp caddr x);
        if dependsl(y,variables!*) then groepostcollectden z;
      >>;
      res := for each x in res collect list x;
      groesetdmode(groesoldmode!*,nil);
      return res;
  end) where depl!*=depl!*;

symbolic procedure univariatepolynomial!? fm;
      domainp fm or univariatepolynomial!?1 (fm,mvar fm);

symbolic procedure univariatepolynomial!?1 (fm,v);
       domainp fm or
         domainp lc fm and v = mvar fm and
                           univariatepolynomial!?1(red fm,v);

symbolic procedure predecessor (r,l);
  % looks for the  predecessor of r in l
   if not pairp l or not pairp cdr l or r = car l
          then rerror(groebner,9,"No predecessor available") else
   if r = cadr l then car l else predecessor (r,cdr l);

symbolic procedure zerosetunion(ng1,ng2);
     <<%print list( "union von ",ng1,ng2;
       ng1 := zerosetunion1(ng1,ng2);
     % print list( "-->",ng1);
       ng1>>;

symbolic procedure zerosetunion1(ng1,ng2);
    % Vereinigung von Nullstellengebilden
      if ng1 = () then ng2
            else
      if zerosetmember(car ng1,ng2) then zerosetunion1(cdr ng1,ng2)
            else
      car ng1 . zerosetunion1(cdr ng1,ng2);

symbolic procedure zerosetmember (ns,ng);
      if ng = () then nil else
      if zeroequal(ns,car ng) then ng else
         zerosetmember (ns,cdr ng);

symbolic procedure zeroequal(ns1,ns2);
      if zerosubset(ns1,ns2) then zerosubset(ns2,ns1) else nil;

symbolic procedure zerosubset(ns1,ns2);
      if null ns1 then t else
      if member(car ns1,ns2) then zerosubset(cdr ns1,ns2)
         else nil;

symbolic procedure groesetdmode(dmode,dir);
  % Interface for switching an arbitrary domain on/off.
  % Preserve complex mode. Turn on EZGCD whenever possible.
   if null dmode then nil else
   begin scalar !*msg,x,y;
   if null dir then
   << if !*complex then y:=setdmode('complex,nil);
      !*complex := nil;
      if dmode!* = '!:rd!: then !*rounded :=nil;
      if dmode!* then y:=setdmode(get(dmode!*,'dname),nil);
      if !*groebcomplex then
      <<setdmode('complex,t); !*complex:=t>>;
   >>
   else
   << if memq(dmode,'(complex complex!-rounded complex!-rational))
        then <<!*complex := t; y:=setdmode('complex,t);
                 if (x:=atsoc(dmode,'((complex!-rounded . rounded)
                           (complex!-rational . rational)) ))
                 then y:=setdmode(cdr x,t)>>
           else y:=setdmode(dmode,t);
      if memq(dmode,'(rounded complex!-rounded)) then !*rounded :=t;
    >>;
    !*ezgcd := null dmode!*;
    return y;
  end;

symbolic procedure preduceeval pars;
%  Polynomial reduction driver. u is an expression and v a list of
% expressions. Preduce calculates the polynomial u reduced wrt the list
% of expressions v.
% parameters:
%     1      expression to be reduced
%     2      polynomials or equations; base for reduction
%     3      optional: list of variables
   begin scalar vars,x,u,v,w,oldorder;
         scalar !*factor,!*exp,!*gsugar,!*vdpinteger;
         integer n,pcount!*; !*exp := t;
      if !*groebprot then groebprotfile := list 'list;
      n := length pars;
      x := reval car pars;
      u := reval cadr pars;
      v := if n>2 then reval caddr pars else nil;
      w := for each j in groerevlist u
              collect if eqexpr j then !*eqn2a j else j;
      if null w then rerror(groebnr2,3,"Empty list in Preduce");
      vars := groebnervars(w,v);
      if not vars then vdperr 'preduce;
      oldorder := vdpinit vars;
      w := for each j in w collect a2vdp j;
      x := a2vdp x;
      if !*groebprot then
          <<w := for each j in w collect vdpenumerate j;
            groebprotsetq('candidate,vdp2a x);
            for each j in w do groebprotsetq(mkid('poly,vdpnumber j),
                                             vdp2a j)>>;
      w := groebnormalform(x,w, 'sort);
      w := vdp2a w;

      setkorder oldorder;
      return if w then w else 0;
   end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% the following code is the interface to Stan's rootfinder
%

symbolic procedure groeroots(p,x);
   begin scalar r;
      r := reval{'roots,p};
         % re-evaluate rhs in order to get prefix form
      r := for each e in cdr r collect
            list('equal,cadr e,reval caddr e);
      return 'list . r;
   end;

endmodule;


module groebopt;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%   optimization of the sequence of variables
%

% Optimization of variable sequence;
% the theoretical background can be found
% in  Boege/Gebauer/Kredel , J.Symb.Comp(1986)I,83-98
% Techniques modfied to the following algorithm
%
% x > y if
%  x appears in a higher power than y
%       or
%  the highest powers are equal, but x appears more often with
% that power.
%
% An explicit dependency DEPENDS X,Y will supersede the optimality.

fluid '(vdpvars!*     % list of intersting variables (and korder)
        intvdpvars!*
        !*trgroeb     % control of print messages
       );

symbolic procedure vdpvordopt (w,vars);
  % w : list of polynomials (standard forms)
  % vars: list of variables
  % returns (w . vars), both reorderdered
  begin; scalar c;
        vars := sort(vars,'ordop);
        c := for each x in vars collect x . 0 . 0;
        for each poly in w do vdpvordopt1 (poly,vars,c);
        c := sort(c,function vdpvordopt2);
        intvdpvars!* := for each v in c collect car v;
        vars := sort(intvdpvars!*,function vdpvordopt3);
        if !*trgroeb then
        <<prin2 "optimized sequence of kernels: "; prin2t vars>>;
        return (for each poly in w collect reorder poly) . vars;
  end;


symbolic procedure vdpvordopt1 (p,vl,c);
   if null p then 0
      else
   if domainp p or null vl then 1
      else
   if mvar p neq car vl then vdpvordopt1(p,cdr vl,c)
      else
   begin scalar var,pow,slot; integer n;
      n := vdpvordopt1 (lc p,cdr vl,c);
      var := mvar p;
      pow := ldeg p;
      slot := assoc(var,c);
      if pow #> cadr slot then
          <<rplaca(cdr slot,pow); rplacd(cdr slot,n)>>
        else
          rplacd(cdr slot,n #+ cddr slot);
      return n #+ vdpvordopt1 (red p,vl,c);
   end;

symbolic procedure vdpvordopt2(sl1,sl2);
  % compare two slots from the power table
    <<sl1 := cdr sl1;
      sl2 := cdr sl2;
      car sl1 #< car sl2 or car sl1 = car sl2 and cdr sl1 #< cdr sl2
    >>;

symbolic procedure vdpvordopt3(x,y);
  % two level compare: 1. dependency, 2. optimal order.
     depends(x,y) or member(y,member(x,intvdpvars!*));

endmodule;


module groebsea;

% support of search for reduction polynomials

fluid '(thirdvalue!* fourthvalue!* hcount!* !*groebweak);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  search for reduction candidates in a list

symbolic procedure groebsearchinlist (vev,g);
  % search for a polynomial in the list G, such that the lcm divides
  % vev; G is expected to be sorted in descending sequence
    if null g then nil
    else if buch!-vevdivides!?(vdpevlmon car g, vev) then car g
    else groebsearchinlist (vev,cdr g);



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  search tree for polynomials
%  simple variant: mapped to search list
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure groebstreeadd (poly,stru);
% add one polynomial to the tree
% if this is a simple polynomial (mono or bino), reform
% the tree
   if hcount!* #< 5000 then vdplsortin(poly,stru)
     else vdplsortinreplacing(poly,stru);

symbolic procedure groebsearchinstree (vev,stru);
% search a polynomial corresponding to the exponent vector vev
     groebsearchinlist (vev,stru);

symbolic procedure groebstreeextract stru;
% gives a linear list of all polynomials in the tree
                 stru;

symbolic procedure groebstreereconstruct u;
% reconstructs a tree from a linear list of polynomials
               vdplsort u;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
% reforming G, D and G99 when a very simple polynomial was
% found (e.g. a monomial, a binomial)

symbolic procedure groebsecondaryreduction(poly,g,g99,d,gc,mode);
    % if poly is a simple polynomial, the polynomials in G and G99
    % are reduced in a second pass. Result is G, secondvalue is G99.
    % mode says, that G99 has to be modified in place.
  begin scalar vev,p,pl,x,rep,first,rpoly,break;   % y;
    secondvalue!* := g99; thirdvalue!* := d; fourthvalue!* := gc;
    vev := vdpevlmon poly; rpoly := vdpred poly;
        % cancel redundant elements in G99
    for each p in g99 do if buch!-vevdivides!?(vev,vdpevlmon p)
                  then g99:=delete(p,g99);
    if vdplength poly > 2 or  vevzero!? vev then return g;
    if !*groebweak and not vdpzero!? rpoly
       and (groebweaktestbranch!=1(poly,g,d)) then return 'abort;
        !*trgroeb and groebmess50 g;
    pl := union(g,g99);
    first := t;

    while pl and not break do
      << p:= car pl; pl := cdr pl;
         if groebprofitsfromvev(p,vev) then
                          % replace by simplified version
            <<x := groebnormalform1(p,poly);
              x := groebsimpcontnormalform x;
              x := vdpenumerate x;
                 if first then !*trgroeb and groebmess20(poly);
                      first := nil;
                      !*trgroeb and groebmess21(p,x);
                  rep := (p . x) . rep;
              if not vdpzero!? x and
                 vevzero!? vdpevlmon x then break := t; % 1 found
             >> >>;

    if break then return 'abort;

                           % reform G99
    g99 := for each p in g99 collect groebsecondaryreplace(p,rep);
    secondvalue!* :=  groebsecondaryremovemultiples g99;
                           % reform D
 %  thirdvalue!* := nil;
 %  for each p in D do
 %  <<x := groebSecondaryReplace(cadr p,rep);
 %    y := groebSecondaryReplace(caddr p,rep);
 %    thirdvalue!*:=groebcplistSortIn(groebmakepair(x,y),thirdvalue!*);
 %  >>;
    thirdvalue!* := d;
                          % reform Gc
    fourthvalue!* :=
      groebsecondaryremovemultiples
        for each y in gc collect groebsecondaryreplace(y,rep);

    g:=for each y in g collect groebsecondaryreplace(y,rep);
         !*trgroeb and groebmess50 g;
      % print('groebSecondaryReduction .
      %          for each p in g collect vdpnumber p);
    return groebsecondaryremovemultiples g;
  end;

symbolic procedure groebsecondaryremovemultiples g;
    if null g then nil else
    if vdpzero!? car g or member(car g,cdr g) then
                groebsecondaryremovemultiples cdr g else
    car g  . groebsecondaryremovemultiples cdr g;

symbolic procedure groebsecondaryreplace(x,rep);
   (if y then cdr y else x) where y = atsoc(x,rep);

endmodule;


module groebsor;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  maintenance of lists of critical pairs (sorting etc.)
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure groebcplistsortin (p,pl);
% Distributive polynomial critical pair list sort. pl is a
% special list for Groebner calculation, p is a pair.
% returns the updated list pl (p sorted into);
% if null pl then list p
%   else
% if vevcompless!? (car car pl, car p)
%     then car pl  . groebcplistsortin (p, cdr pl)
%   else
%      p . pl;
%  non copying version:
  if null pl then list p
    else
  <<groebcplistsortin1 (p,pl); pl>>;

symbolic procedure groebcplistsortin1(p,pl);
% destructive insert of p into nonnull pl
   if not groebcpcompless!?(car pl, p)
        then <<rplacd(pl,car pl . cdr pl); rplaca(pl,p)>>
      else
   if null cdr pl then rplacd(pl,list p)
      else
        groebcplistsortin1(p,cdr pl);


symbolic procedure groebcplistsort g;
  <<for each p in g do gg:=groebcplistsortin(p,gg); gg>>
      where gg=nil;

symbolic procedure groebcplistmerge(pl1,pl2);
% Distributive polynomial critical pair list merge. pl1 and pl2
% are critical pair lists used in the Groebner calculation.
% groebcplistmerge(pl1,pl2) returns the merged list.
begin scalar cpl1,cpl2,sl;
      if null pl1 then return pl2;
      if null pl2 then return pl1;
      cpl1 := car pl1; cpl2 := car pl2;
      sl := groebcpcompless!?(cpl1, cpl2);
      return
           (if sl then cpl1 . groebcplistmerge(cdr pl1,pl2)
                  else cpl2 . groebcplistmerge(pl1,cdr pl2) )
end;

symbolic procedure groebcpcompless!?(p1,p2);
% compare 2 pairs srt their sugar(=cadddr) or their lcm (=car).
    if !*gsugar then
         (if not(d=0) then d<0 else
          if not(q=0) then q<0 else
            vdpnumber(caddr p1)<vdpnumber(caddr p2)
         )  where d= cadddr p1 - cadddr p2, q=vevcomp(car p1,car p2)
       else vevcompless!?(car p1,car p2);

endmodule;


module groebspa;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
% manipulation of subspaces.
% A subspace among the variables is described by an exponent vector
%  with only zeroes and ones. It terminates with the last
% one. It may be null (nil);

expr procedure vevunion(e1,e2);
    begin scalar x,y;
       y := vevunion1(e1,e2);
       x := reverse y;
       if car x = 1 then return y;
       while x and car x = 0 do x := cdr x;
       return reversip x;
    end;

expr procedure vevunion1(e1,e2);
    if vdpsubspacep(e1,e2) then e2
       else
    if vdpsubspacep(e2,e1) then e1
       else
    if car e1 neq 0 or car e2 neq 0 then 1 . vevunion1(cdr e1,cdr e2)
       else
          0 . vevunion1(cdr e1,cdr e2);

expr procedure vdpsubspacep(e1,e2);
% test if e1 describes a subspace from e2
    if null e1 then t
      else
    if null e2 then vdpspacenullp(e1)
      else
    if car e1 > car e2 then nil
      else
    if e1 = e2 then t
      else
         vdpsubspacep(cdr e1,cdr e2);

expr procedure vdporthspacep(e1,e2);
% test if e1 and e2 describe orthogonal spaces(no intersection);
    if null e1 or null e2 then t
       else
    if car e2 = 0 or car e1 = 0
          then vdporthspacep(cdr e1,cdr e2)
       else nil;


expr procedure vdpspacenullp(e1);
% test if e1 describes an null space
     if null e1 then t
        else
     if car e1 = 0 then vdpspacenullp(cdr e1)
        else nil;


expr procedure vdpspace(p);
  % determine the variables of the polynomial.
    begin scalar x,y;
        if vdpzero!? p then return nil;
        x := vdpgetprop(p,'subroom);
        if x then return x;
        x := vevunion(nil,vdpevlmon p);
        y := vdpred p;
        while not vdpzero!? y do
         <<x := vevunion(x,vdpevlmon y);
           y := vdpred y>>;
        vdpputprop (p,'subroom,x);
        return x;
    end;

symbolic procedure vdpunivariate!?(p);
    if vdpgetprop(p,'univariate) then t
     else begin scalar ev; integer n;
         ev := vdpevlmon p;
         for each x in ev do
           if not(x=0) then n := n#+1;
         if not(n=1) then return nil;
         ev := vdpspace(p);
         for each x in ev do
           if not(x=0) then n := n#+1;
         if not(n=1) then return nil;
         vdpputprop(p,'univariate,t);
         return t;
     end;

endmodule;


module groebfac; % Factorization of polynomials during Groebner calc'n.

% create!-package('(groebfac),'(contrib groebner));

% Other packages needed.

% load!-package 'vdp2dip;

imports groebner,vdp2dip,factor;

fluid '(groebactualg99!* groebactualg!* factortime!* !*vdpmodular
          vdpone!* groebfabort!* !*factor !*groebrm current!-modulus
          !*trgroeb !*gsugar);

symbolic procedure groebfactorize (h,abort1,g,g99);
  begin scalar r,tim,gctim,h1,groebactualg99!*,groebfabort!*,test;
    scalar s;
    s:=!*gsugar and gsugar h;
    groebactualg99!* := g99; groebactualg!* := g;
    groebfabort!* := abort1;
    if vdpgetprop(h,'irreducible) then return groebfactorize3 h;
    tim := time();
    gctim := gctime();
         !*trgroeb and groebmess7 h;
    r := if r := vdpgetprop(h,'factors) then r
     else if !*groebrm then groebfactorize1 h
     else if not !*vdpmodular then groebfactorize2 h
     else nil;
    factortime!* := factortime!* + time() - tim -(gctime()-gctim);
    if null r then <<vdpputprop(h,'irreducible,t);
                     return groebfactorize3 h>>;
               if cdr r then !*trgroeb and groebmess14 (h,r);
    vdpputprop(h,'factors,r);
    for each p in r do
       if vdpmember(car p,g) then test:= car p;
    if test then
       <<!*trgroeb and groebmess27a(h,test); return 'zero>>;
    h1 := car r;
    for each p in r do
       if vdpmember(car p,abort1) then
            <<r := delete(p,r); !*trgroeb and groebmess27 car p >>
       else vdpputprop(car p,'irreducible,t);
    if null r then r := list h1;     % at least one
    if null cdr r then groebfactorize3 caar r;
       % inherit sugar if no substantial factor.
    if !*gsugar then
     if null cdr r then gsetsugar(caar r,s) else
       for each p in r do gsetsugar(car p,vdptdeg car p);
    return 'factor . r;
  end;


symbolic procedure groebfactorize1 h;
  % factorize: separate monomial factors which were detected already;
   begin scalar monf,vp,n,e,h1,h2,vp2;
        monf := vdpgetprop(h,'monfac);
        if null monf then
             return if not !*vdpmodular then groebfactorize2 h
                                       else nil;     % no factor
        h2 := vdpdivmon (h,vbcfi 1,monf);

       if groebmonfac neq 0 then
       <<                                 % now build a polynomial from
        n := 0;                           % each variable in MONFAC
        for each x in monf do
            <<n := n#+1;
              if x neq 0 then
                <<e := list x;
                  for i:=2:n do e := 0 . e; % prefix with n-1 zeros.
                  vp := vdpfmon(a2vbc 1,e) . vp;
                >>;
            >>;
       >>
        else
        !*trgroeb and groebmess15 monf;
                  % append body of orig. poly, factorized
        if not vdpzero!? h2 and
           not vevzero!? vdpevlmon h2 then
               <<if not !*vdpmodular then vp2 := groebfactorize2 h2;
                 vp2 := if not vp2 then list h2
                     else for each v in vp2 collect car v;
                 vp := nconc(vp,vp2)>>;
                   % ascending sorting
    %   if length vp = 1 then return nil;
        h1 := vp;
        return
               reverse  for each x in h1 collect list vdpenumerate x;
   end;

symbolic procedure groebfactorize2 h;
  % tries to factorize a h-polynomial via REDUCE factorizer
   begin scalar h1,h2,!*factor; !*factor := t;
%       h1 := vdp2a vdprectoint (h,vdplcm h);
%       h1 := fctrf !*q2f simp h1;   % factorf
        h1 := groefctrf vdp2f h;
        if null cdr h1 then return nil;
        if null cddr h1      % only one element in factorization list
           and cdr cadr h1 = 1     % and multiplicity = 1
                then return nil;
        h2 := for each l in cdr h1 join
            for i:=1:cdr l collect car l;
        h2 := vdplsort for each p in h2 collect vdpsimpcont f2vdp p;
        return for each x in h2 collect list vdpenumerate x;
   end;

symbolic procedure groefctrf p;
   (fctrf p) where !*factor=t,current!-modulus = current!-modulus;

symbolic procedure groebfactorize3 h;
  % additional efforts to factor something.
       nil;

endmodule;


module groebidq;

% calculation of ideal quotient using a modified Buchberger algorithm.

%   Authors:   H. Melenk, H.M. Moeller,  W. Neun
%              July 1988

fluid '(                           % switches from the user interface
        !*groebopt !*groebfac !*groebres !*trgroeb !*trgroebs !*groebrm
        !*trgroeb1 !*trgroebr !*groebprereduce groebrestriction!*
        !*groebstat !*groebdivide !*groebprot
        !*groebidqbasis

        vdpvars!*                  % external names of the variables
        !*vdpinteger !*vdpmodular  % indicating type of algorithm
        vdpsortmode!*              % term ordering mode
        secondvalue!* thirdvalue!* % auxiliary: multiple return values
        fourthvalue!*
        factortime!*               % computing time spent in factoring
        factorlvevel!*              % bookkeeping of factor tree
        pairsdone!*                % list of pairs already calculated
        probcount!*                % counting subproblems
        vbccurrentmode!*            % current domain for base coeffs.
        groetime!*
        !*gsugar

       );


switch groebopt,groebfac,groebrm,groebres,trgroeb,trgroebs,trgroeb1,
       trgroebr,groebstat,groebprot;
!*groebidqbasis := t;              %default: basis from idq

% variables for counting and numbering
fluid '(hcount!* pcount!* mcount!* fcount!* bcount!* b4count!*
        basecount!* hzerocount!*);


symbolic procedure groebidq2 (p,f);
  % setup all global variables for the Buchberger algorithm
  % printing of statistics
 begin scalar groetime!*,tim1,spac,spac1,p1,factortime!*,
       pairsdone!*, factorlvevel!*,!*gsugar;
       factortime!* := 0;
       groetime!* := time();
       vdponepol(); % we construct dynamically
       hcount!* := 0;
       pcount!* := 0;
       mcount!* := 0;
       fcount!* := 0;
       bcount!* := 0;
       b4count!* := 0;
       hzerocount!* := 0;
       basecount!* := 0;
       if !*trgroeb then
       <<
          prin2 "IDQ Calculation starting ";
          terprit 2;
       >>;
       spac := gctime();

       p1:=  groebidq3 (p, f);

       if !*trgroeb or !*trgroebr or !*groebstat then
       <<
          spac1 := gctime() - spac;
          terpri();
          prin2t "statistics for IDQ calculation";
          prin2t "==============================";
          prin2 " total computing time (including gc): ";
          prin2((tim1 := time()) - groetime!*);
          prin2t "          milliseconds  ";
          prin2 " (time spent for garbage collection:  ";
          prin2 spac1;
          prin2t "          milliseconds)";
          terprit 1;
          prin2  "H-polynomials total: "; prin2t hcount!*;
          prin2  "H-polynomials zero : "; prin2t hzerocount!*;
          prin2  "Crit M hits: "; prin2t mcount!*;
          prin2  "Crit F hits: "; prin2t fcount!*;
          prin2  "Crit B hits: "; prin2t bcount!*;
          prin2  "Crit B4 hits: "; prin2t b4count!*;
       >>;
       return if !*groebidqbasis then car groebner2(p1,nil) else p1;
 end;


symbolic procedure groebidq3 (g0,fff);
   begin scalar result,x,g,d,d1,d2,p,p1,s,h,g99,one,gi;
         gi := g0;
         fff := vdpsimpcont fff;
         vdpputprop(fff,'number,0);         % assign number 0
         vdpputprop(fff,'cofact,a2vdp 1);   % assign cofactor 1
         x := for each fj in g0 collect
           << fj:=vdpenumerate vdpsimpcont fj;
              vdpputprop(fj,'cofact,a2vdp 0);   % assign cofactor 0
              fj>>;
         g0 := list fff;
         for each fj in x do g0 := vdplsortin(fj,g0);

% ITERATION :
      while (d or g0) and not one do
       begin
          if g0 then
          <<          % take next poly from input
               h := car g0;
               g0 := cdr g0;
               p := list(nil,h,h);
          >>
             else
          <<          % take next poly from pairs
               p := car d;
               d := delete (p,d);
               s := idqspolynom (cadr p, caddr p);
                          idqmess3(p,s);
               h := idqsimpcont idqnormalform(s,g99,'tree);
               if vdpzero!? h then
               <<      !*trgroeb and groebmess4(p,d);
                 x := vdpgetprop(h,'cofact);
                 if not vdpzero!? x then
                    if vevzero!? vdpevlmon x then one:= t else
                     << result := idqtoresult(x , result);
                        idqmess0 x>>;
               >>
          >>;
          if vdpzero!? h then goto bott;
          if vevzero!? vdpevlmon h then % base 1 found
                  <<          idqmess5(p,h);
                 result:=gi; d:=g0:=nil;
                 goto bott;>>;
          s:= nil;
                  % h polynomial is accepted now
               h := vdpenumerate h;
                        idqmess5(p,h);
                              % construct new critical pairs
               d1 := nil;
               for each f in g do
                    <<d1 := groebcplistsortin( list(tt(f,h),f,h) , d1);
                      if tt(f,h) = vdpevlmon(f) then
                             <<g := delete (f,g);
                               !*trgroeb and groebmess2 f>>;
                      >>;
                  !*trgroeb and groebmess51(d1);
               d2 := nil;
               while d1 do
                  <<d1 := groebinvokecritf d1;
                    p1 := car d1;
                    d1 := cdr d1;
                    if groebbuchcrit4t(cadr p1,caddr p1)
                       then d2 := append (d2, list p1)
                           else
                    <<x := idqdirectelement(cadr p1,caddr p1);
                      if not vdpzero!? x then
                         if vevzero!? vdpevlmon x then one:= t else
                              <<idqmess1 (x,cadr p1,caddr p1);
                                result := idqtoresult(x,result);
                                >> >>;

                    d1 := groebinvokecritm (p1,d1);
                  >>;
             %   D := groebInvokeCritB (h,D);
                 d := groebcplistmerge(d,d2);
                 g := h . g;
                 g99 := groebstreeadd(h, g99);
                            !*trgroeb and groebmess8(g,d);
    bott:
   end;      %  ITERATION
                      % now calculate groebner base from quotient base
   if one then result := list vdpfmon(a2vbc 1,vevzero());
        idqmess2 result;
   return result;
end;     % MACROLOOP

symbolic procedure idqtoresult(x,r);
    % x is a new element for the quotient r;
    % is is reduced by r and then added.
      <<x := groebsimpcontnormalform groebnormalform(x,r,'sort);
        if vdpzero!? x then r else vdplsortin(x,r)>>;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%    Reduction of polynomials
%

symbolic procedure idqnormalform(f,g,type);
     % general procedure for reduction of one polynomial from a set
     %  f is a polynomial, G is a Set of polynomials either in
     %     a search tree or in a sorted list
     % type describes the ordering of the set G:
     %    'TREE     G is a search tree
     %    'SORT     G is a sorted list
     %    'LIST     G is a list, but not sorted
     %  f has to be reduced modulo G
     % version for idealQuotient: doing side effect calculations for
     % the cofactors; only headterm reduction
  begin scalar c,vev,divisor,done,fold;
      fold := f;
      while not vdpzero!? f and g do
          begin
            vev:=vdpevlmon f; c:=vdplbc f;
            if type = 'sort then
                 while g
                       and vevcompless!? (vev,vdpevlmon (car g))
                            do g := cdr g;
            divisor :=
               if type = 'tree then groebsearchinstree (vev,g)
                               else groebsearchinlist (vev,g);
            if divisor then done := t;    % true action indicator
            if divisor and !*trgroebs then
                       << prin2 "//-";
                          prin2 vdpnumber divisor;
                          >>;
            if divisor then
                      if !*vdpinteger  then
                          f := idqreduceonestepint(f,nil,c,vev,divisor)
                       else
                          f := idqreduceonesteprat(f,nil,c,vev,divisor)
               else
                  g := nil;
          end;
      return if done then f else fold; %in order to preserve history
   end;



% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  special reduction procedures



symbolic procedure idqreduceonestepint(f,dummy,c,vev,g1);
      % reduction step for integer case:
      % calculate f= a*f - b*g a,b such that leading term vanishes
      %                        (vev of lvbc g divides vev of lvbc f)
      %
      % and  calculate f1 = a*f1
      % return value=f, secondvalue=f1
 begin scalar vevlcm,a,b,cg,x,fcofa,gcofa;
      fcofa := vdpgetprop(f,'cofact);
      gcofa := vdpgetprop(g1,'cofact);
      vevlcm := vevdif(vev,vdpevlmon g1);
      cg := vdplbc g1;
            % calculate coefficient factors
      x := vbcgcd(c,cg);
      a := vbcquot(cg,x);
      b := vbcquot(c,x);
      f:= vdpilcomb1 (vdpred f, a, vevzero(),
                      vdpred g1,vbcneg b, vevlcm);
      x := vdpilcomb1 (fcofa, a, vevzero(),
                       gcofa ,vbcneg b, vevlcm);
      vdpputprop(f,'cofact,x);
      return f;
 end;


symbolic procedure idqreduceonesteprat(f,dummy,c,vev,g1);
      % reduction step for rational case:
      % calculate f= f - g/vdpLbc(f)
      %
 begin scalar x,fcofa,gcofa,vev;
      fcofa := vdpgetprop(f,'cofact);
      gcofa := vdpgetprop(g1,'cofact);
      vev := vevdif(vev,vdpevlmon g1);
      x := vbcneg vbcquot(c,vdplbc g1);
      f := vdpilcomb1(vdpred f,a2vbc 1,vevzero(),
                      vdpred g1,x,vev);
      x := vdpilcomb1 (fcofa,a2vbc 1 , vevzero(),
                       gcofa,x,vev);
      vdpputprop(f,'cofact,x);
      return f;
 end;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%   calculation of an S-polynomial and related things
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure idqspolynom (p1,p2);
  begin scalar s,ep1,ep2,ep,rp1,rp2,db1,db2,x,cofac1,cofac2;
    if vdpzero!? p1  then return p1; if vdpzero!? p2  then return p2;
    cofac1 := vdpgetprop(p1,'cofact); cofac2 := vdpgetprop(p2,'cofact);
    ep1 := vdpevlmon p1;             ep2 := vdpevlmon p2;
    ep := vevlcm(ep1, ep2);
    rp1 := vdpred p1;               rp2 := vdpred p2;
    db1 := vdplbc p1;                db2 := vdplbc p2;
    if !*vdpinteger then
     <<x:=vbcgcd(db1,db2); db1:=vbcquot(db1,x); db2:=vbcquot(db2,x)>>;
    ep1 := vevdif(ep,ep1); ep2 := vevdif(ep,ep2); db2 := vbcneg db2;
    s := vdpilcomb1 (rp2,db1,ep2,rp1,db2,ep1);
    x := vdpilcomb1 (cofac2,db1,ep2,cofac1,db2,ep1);
    vdpputprop(s,'cofact,x);
    return s;
   end;


symbolic procedure idqdirectelement(p1,p2);
  % the s-Polynomial is reducable to zero because of
  % buchcrit 4. So we can calculate the corresponing cofactor
  % directly
    (if vdpzero!? c1 and vdpzero!? c2 then c1
     else vdpdif(vdpprod(p1,c2),vdpprod(p2,c1))
                        )  where c1 = vdpgetprop(p1,'cofact),
                                 c2 = vdpgetprop(p2,'cofact);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%   Normailsation with cofactors taken into account
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


symbolic procedure idqsimpcont(p);
    if !*vdpinteger then idqsimpconti p else idqsimpcontr p;

% routines for integer coefficient case:
% calculation of contents and dividing all coefficients by it

symbolic procedure idqsimpconti (p);
%   calculate the contents of p and divide all coefficients by it
  begin scalar res,num,cofac;
    if vdpzero!?  p then return p;
    cofac := vdpgetprop(p,'cofact);
    num := car vdpcontenti p;
    if not vdpzero!? cofac then num:=vbcgcd(num,car vdpcontenti cofac);
    if not vbcplus!? num then num := vbcneg num;
    if not vbcplus!? vdplbc p then num:=vbcneg num;
    if vbcone!? num then return p;
    res := vdpreduceconti (p,num,nil);
    if not vdpzero!? cofac then cofac:=vdpreduceconti(cofac,num,nil);
    res := vdpputprop(res,'cofact,cofac);
    return res;
    end;


% routines for rational coefficient case:
% calculation of contents and dividing all coefficients by it

symbolic procedure idqsimpcontr (p);
%   calculate the contents of p and divide all coefficients by it
  begin scalar res,cofac;
    cofac := vdpgetprop(p,'cofact);
    if vdpzero!?  p then return p;
    if vbcone!? vdplbc p then return p;
    res := vdpreduceconti (p,vdplbc p,nil);
    if not vdpzero!? cofac then
                 cofac:=vdpreduceconti(cofac,vdplbc p,nil);
    res := vdpputprop(res,'cofact,cofac);
    return res;
    end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  trace messages
%

symbolic procedure idqmess0 x;
    if !*trgroeb then
    <<prin2t "adding member to intermediate quotient basis:";
      vdpprint x;
      terpri()>>;

symbolic procedure idqmess1 (x,p1,p2);
    if !*trgroeb then
    <<prin2 "pair ("; prin2 vdpnumber p1; prin2 ",";
      prin2 vdpnumber p2;
      prin2t ") adding member to intermediate quotient basis:";
      vdpprint x;
      terpri()>>;

symbolic procedure idqmess2 b;
    if !*trgroeb then
    <<prin2t "---------------------------------------------------";
      prin2 "the full intermediate base of the ideal quotient is:";
      for each x in b do vdpprin3t x;
      prin2t "---------------------------------------------------";
      terpri()>>;


symbolic procedure idqmess5(p,h);
   if car p then                  % print for true h-Polys
  << hcount!* := hcount!* + 1;
     if !*trgroeb then <<
                       terpri();
                       prin2  "H-polynomial ";
                       prin2 pcount!*;
                       groebmessff(" from pair (",cadr p,nil);
                       groebmessff(",", caddr p,")");
                       vdpprint h;
                       prin2t "with cofactor";
                       vdpprint vdpgetprop(h,'cofact);
                       groetimeprint() >> >>
     else
     if !*trgroeb then <<          % print for input polys
                       prin2t "candidate from input:";
                       vdpprint h;
                       groetimeprint() >>;



symbolic procedure idqmess3(p,s);
     if !*trgroebs then <<
                       prin2 "S-polynomial  ";
                       prin2 " from ";
                       groebpairprint p;
                       vdpprint s;
                       prin2t "with cofactor";
                       vdpprint vdpgetprop(s,'cofact);
                            groetimeprint();
                            terprit 3 >>;

endmodule;


module kredelw; % Kredel Weispfenning algorithm.

%   Author:     H.Melenk (ZIB Berlin)


fluid '(vdpsortmode!* !*groebopt !*gsugar);

symbolic procedure gdimension_eval u;
  begin integer n,m;
   for each s in cdr gindependent_seteval u
    do if (m:=length cdr s)>n then n:=m;
   return n;
  end;

put('gdimension,'psopfn,'gdimension_eval);

symbolic procedure gindependent_seteval pars;
% Independent set algorithm (Kredel/Weispfenning).
% parameters:
%     1      Groebner basis
%     2      optional: list of variables
   begin scalar vars,u,v,w,oldorder,!*factor,!*exp,!*gsugar,
            !*groebopt;
      !*exp := t;
      u := reval car pars;
      v := if cdr pars then reval cadr pars else nil;
      w := for each j in groerevlist u
              collect if eqexpr j then !*eqn2a j else j;
      if null w then rerror(groebnr2,3,"Empty list");
      vars :=  if null v then
                for each j in gvarlis w collect !*a2k j
            else  groerevlist v;
      if not vars then return '(list);
      oldorder := vdpinit vars;
      w:=for each j in w collect vdpevlmon a2vdp j;
      vars:=for each y in vars collect y.vdpevlmon a2vdp y;
      w:=groebkwprec(vars,nil,w,nil);
      return 'list. for each s in w collect
         'list. reversip for each x in s collect car x;
   end;

put('gindependent_sets,'psopfn,'gindependent_seteval);

symbolic procedure groebkwprec(vars,s,lt,m);
  % recursive Kredel Weispfennig algorithm.
  % vars: unprocessed variables,
  % s:    current subset of s,
  % lt:   leading term basis,
  % m:    collection of independent sets so far.
  % returns: updated m.
  begin scalar x,s1,bool;
    s1:=for each y in s collect cdr y;
    while vars do
    <<x:=car vars; vars:= cdr vars;
      if groebkwprec1(cdr x.s1,lt) then
         m:=groebkwprec(vars,x.s,lt,m);
    >>;
    bool:=t;
    for each y in m do % bool and not subsetp(s,y);
        bool:=bool and not(length s=length intersection(s,y));
    return if bool then s.m else m;
  end;

symbolic procedure groebkwprec1(s,lt);
  % t if intersection of T(s) and lt is empty.
   if null lt then t else
   groebkwprec2(s,car lt) and groebkwprec1(s,cdr lt);

symbolic procedure groebkwprec2(s,mon);
  % t if monomial not in T(s).
 <<for each m in s do mon:=vevcan0(m,mon);
   not vevzero!? mon>>;

symbolic procedure vevcan0(m,mon);
  % divide multiples of m1 out of mon.
  if vevzero!? m then mon else
  if vevzero!? mon then nil else
  (if car m neq 0 then 0 else car mon).vevcan0(cdr m,cdr mon);

endmodule;


module traverso;

% Buchberger algorithm base on "sugar" strategy
%  see Giovini-Mora-Niesi-Robbiano-Traverso:
%   One sugar gube, please. ISSAC 91 proceddings, pp 49-54

fluid '(!*gtraverso!-sloppy !*gsugar);

!*gtraverso!-sloppy := t;

symbolic procedure gtraverso (g0,fact,groebres,abort1);
  begin scalar g,d,s,h,p,!*gsugar;

    !*gsugar := t;

    g0:=for each fj in g0 join
          if not vdpzero!? fj then
          <<groebsavelterm fj;
               {gsetsugar(vdpenumerate vdpsimpcont fj,nil)}>>;

  main_loop:
    if null g0 and null d then return gtraverso!-final g;

    if g0 then
         <<h:=car g0;g0:=cdr g0;
           p := list(nil,h,h)
         >>
       else
         <<p := car d;
           d := cdr d;
           s := groebspolynom (cadr p, caddr p);
                  !*trgroeb and groebmess3 (p,s);
           h:=groebsimpcontnormalform groebnormalform(s,g,'list);
           if vdpzero!? h then
           <<!*trgroeb and groebmess4(p,d); goto main_loop>>;

            if vevzero!? vdpevlmon h then % base 1 found
                  <<   !*trgroeb and groebmess5(p,h);
                       d:=g:=g0:=nil;
                  >>;
         >>;

         h := groebenumerate h; !*trgroeb and groebmess5(p,h);
         groebsavelterm h;

          % new pair list
         d := gtraverso!-pairlist(h,g,d);

          % new basis
         g := nconc(g,{h});
         goto main_loop;
   end;

symbolic procedure gtraverso!-pairlist(gk,g,d);
  % gk: new polynomial,
  % g:  current basis,
  % d:  old pair list.
  begin scalar ev,r,n,nn,q;
     % delete triange relations from old pair list.
    d := gtraverso!-pairs!-discard1(gk,d);

     % build new pair list.
    ev := vdpevlmon gk;
    for each p in g do
     if not groebbuchcrit4t(ev,vdpevlmon p)
       then r := vevlcm(ev,vdpevlmon p).r
       else n := groebmakepair(p,gk) . n;

     % delete from new pairs equivalents to coprime lcm.
    for each q in r do
     for each p in n do
      if car p=q then n:=delete(p,n);

     % discard multiples: collect survivers in n
    if !*gtraverso!-sloppy then !*gsugar:=nil;
    n := groebcplistsort(n);
    !*gsugar := t;

    nn := n; n:=nil;
    for each p in nn do
    <<q:=nil;
      for each r in n do
        q:=q or vevdivides!?(car r,car p);
      if not q then n:=groebcplistsortin(p,n);
    >>;

    return groebcplistmerge(d,reversip n);
  end;

symbolic procedure gtraverso!-pairs!-discard1(gk,d);
  % crit B
  begin scalar gi,gj,tij,evk;
   evk:=vdpevlmon gk;
   for each pij in d do
   <<tij := car pij; gi:=cadr pij; gj:=caddr pij;
    if vevstrictlydivides!?(tt(gi,gk),tij)
       and vevstrictlydivides!?(tt(gj,gk),tij)
      then d:=delete(pij,d);
   >>;
   return d;
  end;

symbolic procedure vevstrictlydivides!?(ev1,ev2);
   not(ev1=ev2) and vevdivides!?(ev1,ev2);

symbolic procedure gtraverso!-final g;
  % final reduction and sorting;
  begin scalar r,p,!*gsugar;
   g:=vdplsort g; % descending
   while g do
   <<p:=car g; g:=cdr g;
     if not groebsearchinlist(vdpevlmon p,g) then
       r := groebsimpcontnormalform groebnormalform(p,g,'list) . r;
   >>;
   return list reversip r;
  end;

% copyd('groebbasein,'traverso);

endmodule;


end;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]