Artifact 20644b64481a252f9c91c9de9ecf68db1f5db9b65a3b7684f4f3bdd405f066d3:
- Executable file
r36/src/groebner.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 130120) [annotate] [blame] [check-ins using] [more...]
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;