% ----------------------------------------------------------------------
% $Id: gb.red,v 1.31 1999/04/15 07:08:01 dolzmann Exp $
% ----------------------------------------------------------------------
% Copyright (c) 1999 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% $Log: gb.red,v $
% Revision 1.31 1999/04/15 07:08:01 dolzmann
% Do not load rltools during compilation.
%
% Revision 1.30 1999/04/13 20:57:04 dolzmann
% Renamed switches to cgb...
% Removed !*gsugar.
% Sort the input system.
%
% Revision 1.29 1999/04/13 13:51:07 dolzmann
% gb_gb was called with three arguments instead of one argument.
%
% Revision 1.28 1999/04/11 11:30:55 dolzmann
% Added standard form interface gb_gbf. Added a procedure gb_gsys!$ for
% computing non-parametric Groebner systems.
%
% Revision 1.27 1999/04/11 09:50:40 dolzmann
% Completely rewritten the interface code for the AM.
% Moved the module vdp from dp.red into this file.
% Adappted the code to the dip_init procedure.
%
% Revision 1.26 1999/04/06 11:53:57 dolzmann
% Removed switches trgroeb, trgroebr, trgreobs, and related code.
%
% Revision 1.25 1999/04/04 16:46:19 sturm
% Added copyright and CVS fluids.
%
% Revision 1.24 1999/04/04 14:50:38 sturm
% Implemented switch tdusetorder.
%
% Revision 1.23 1999/04/04 14:09:33 sturm
% Moved dip_ilcomb and dip_ilcombr from cgb.red to dp.red.
% Created vdp_ilcomb and vdp_ilcombr for gb.red.
%
% Revision 1.22 1999/04/04 12:23:16 dolzmann
% Procedure gb_spolynomial expexts a critical pair instead of two polynomials.
%
% Revision 1.21 1999/04/03 13:38:37 sturm
% Adapted to new dip_init/dip_cleanup.
% Fixed bug in gb_strange!-reduction.
%
% Revision 1.20 1999/03/31 14:09:56 sturm
% Fixed numerous details encountered during CGB reimplementation.
%
% Revision 1.19 1999/03/30 11:29:00 dolzmann
% gb_a2s returns now a list of SF's.
% Reimplemented procedure gb_vars.
%
% Revision 1.18 1999/03/30 09:36:43 dolzmann
% Removed unused procedure gb_vdpvordopt3.
%
% Revision 1.17 1999/03/30 09:34:44 dolzmann
% Procedure gb_groebner1 binds all locally used fluids.
%
% Revision 1.16 1999/03/17 12:34:06 dolzmann
% Removed fluids !*vdpinteger, !*vdpmodular, !*grmod and their bindings.
% Use vdp_monp instead of vdp_length.
% Added the lost procedure min!# under the new name gb_min!#.
%
% Revision 1.15 1999/03/12 13:29:41 sturm
% Added a procedure gb_updbase. Currently used in the style of groebner.red
% incontrast to the Asir variant. Switch gbupdb.
%
% Revision 1.14 1999/03/12 10:58:47 dolzmann
% Introduced verbose output for the length of g.
% Use procedure ev_sdivp of package dp instead of gb_vevsdivp.
% Removed test for zero polynomials in gb_spolynomial.
% Moved procedure vdp_ilcomb1 and vdp_ilcomb1r into package dp and
% renamed the procedures accordingly.
%
% Revision 1.13 1999/03/12 08:57:59 dolzmann
% Introduced switch gbcheckg and related code.
% All statistics code is guarded by the respective switches.
% Replaced all calls of vdp_putprop and vdp_getprop by access functions
% for the properties of the dp package.
%
% Revision 1.12 1999/03/05 10:35:41 dolzmann
% Adapted to newly created dp package.
%
% Revision 1.11 1999/03/02 15:52:11 dolzmann
% Added switch gbcounthf for counting reducible H-polynomials with groebstat.
%
% Revision 1.10 1999/03/02 15:20:02 dolzmann
% Use private gb_vdpilcomb1 and gb_vdpilcomb1r. Only slightly faster.
%
% Revision 1.9 1999/02/25 16:04:56 sturm
% Added switch gbverbose: output pairs left, and frequency of heuristic
% content reduction when altered.
% Added switch gbcontred and fluid gb_mincontred!*.
% Switch groebstat works independently from trgroeb.
% Use ioto for printing statistics.
%
% Revision 1.8 1999/02/25 09:24:36 sturm
% Fixed memq to member in gb_tr2crit.
%
% Revision 1.7 1999/02/25 08:27:45 sturm
% Initialize gb_strangecount!* and spac in groebner2.
%
% Revision 1.6 1999/02/25 06:11:21 dolzmann
% Fixed a bug in gb_tr3crit. gb is as fast as grobener on p6_sc wrt.
% revgradlex and only 10 times slower as groebner wrt. lex.
%
% Revision 1.5 1999/02/24 10:48:43 sturm
% Added switch and fluid declarations and binding. In particular
% !*groebfullreduction, !*gtraverso!-sloppy, !*ezgcd, !*groebdivide.
% gb is faster than groebner on p6_sc now.
%
% Revision 1.4 1999/02/24 08:44:28 sturm
% Added gb_searchinlist. Successfully computes gb({x*y+1,x*z+1}).
%
% Revision 1.3 1999/02/24 08:36:13 sturm
% Added gb_vdpvordopt including patch code. Fixed calls to tt.
%
% Revision 1.2 1999/02/23 16:43:27 sturm
% Checked and corrected by AD. Compiles now.
%
% Revision 1.1 1999/02/23 16:41:38 sturm
% Initial check-in. Obtained from REDUCE 3.6 Groebner by selecting and
% reformatting.
%
% ----------------------------------------------------------------------
lisp <<
fluid '(gb_rcsid!* gb_copyright!*);
gb_rcsid!* := "$Id: gb.red,v 1.31 1999/04/15 07:08:01 dolzmann Exp $";
gb_copyright!* := "Copyright (c) 1999 by A. Dolzmann and T. Sturm"
>>;
module gb;
%load!-package 'dp;
load!-package 'ezgcd;
remflag('(load!-package),'eval); % for bootstrapping
load!-package 'rltools;
flag('(load!-package),'eval);
switch gbltbasis,groebopt,cgbstat,cgbfullred,cgbverbose,cgbcontred,
cgbcounthf,cgbcheckg;
fluid '(!*gltbasis !*groebopt !*cgbstat !*cgbfullred !*cgbverbose
!*cgbcontred !*cgbcounthf !*cgbcheckg !*cgbsloppy);
off1 'cgbstat;
on1 'cgbfullred;
off1 'cgbverbose;
off1 'cgbcontred;
off1 'cgbcounthf;
off1 'cgbcheckg;
!*cgbsloppy := T;
switch cgbupdb;
fluid '(cgb_updbcount!* cgb_updbcountp!* cgb_updbcalls!* !*cgbupdb);
off1 'cgbupdb;
fluid '(intvdpvars!*);
fluid '(!*gcd !*ezgcd !*factor !*exp dmode!* depl!* !*backtrace);
fluid '(secondvalue!* thirdvalue!*);
fluid '(dip_vars!* vdp_pcount!*);
fluid '(cgb_hcount!* cgb_hzerocount!* cgb_tr1count!* cgb_tr2count!*
cgb_tr3count!* cgb_b4count!* cgb_strangecount!* cgb_paircount!*
cgb_hfaccount!* cgb_gcount!* cgb_gstat!* cgb_gbcount!*);
global '(gvarslast gltb);
gltb := {'list};
fluid '(cgb_contcount!* cgb_mincontred!*);
cgb_mincontred!* := 20; % originally 10
put('gb,'psopfn,'gb_gb!$);
smacro procedure gb_tt(s1,s2);
% lcm of leading terms of s1 and s2
ev_lcm(vdp_evlmon s1,vdp_evlmon s2);
procedure gb_gb!$(u);
% Groebner bases GB computation for the AM. [u] is a list of length
% 1 and [car u] evaluates to an AMPSYS. Returns an AMPSYS. Computes
% a GB of the ideal generated by all polynomials in [u] wrt. to the
% current polynomial ring.
begin scalar w,v,odipenv;
if length u neq 1 then
rederr {"gb called with",length u,"arguments instead of 1 argument"};
gb_domainchk();
u := gb_a2s!-psys reval car u;
v := gb_vars(u,td_vars());
gvarslast := 'list . car v;
odipenv := vdp_init(car v,td_sortmode(),td_sortextension());
w := errorset({'gb_gb1!$,mkquote u,mkquote car v,mkquote cdr v},
T,!*backtrace);
vdp_cleanup odipenv;
if errorp w then
rederr "Error during gb computation";
return car w
end;
procedure gb_gb1!$(u,m,p);
% Groebner bases GB computation for the AM subroutine. [u] is a
% list of SF's; [m] and [p] are list of variables. Returns an
% AMPSYS. Computes a GB of the ideal generated by all polynomials
% in [u] wrt. to the current polynomial ring. [m] is the list of
% the main variables and [p] is the list of parameters.
begin scalar w;
u := for each x in u collect vdp_f2vdp x;
w := gb_gb u;
if !*gltbasis then
gltb := gb_gb2gltb w;
return gb_s2a!-gb w
end;
procedure gb_gsys!$(u);
% Groebner bases Groebner system computation for the AM. [u] is a
% list of length 1 and [car u] evaluates to an AMPSYS. Returns an
% AMPSYS. Computes a Groebner system of the ideal generated by all
% polynomials in [u] wrt. to the current polynomial ring.
begin scalar w,v,odipenv;
if length u neq 1 then
rederr {"gsys called with",length u,"arguments instead of 1 argument"};
gb_domainchk();
u := gb_a2s!-psys reval car u;
v := gb_vars(u,td_vars());
gvarslast := 'list . car v;
odipenv := vdp_init(car v,td_sortmode(),td_sortextension());
w := errorset({'gb_gsys1!$,mkquote u,mkquote car v,mkquote cdr v},
T,!*backtrace);
vdp_cleanup odipenv;
if errorp w then
rederr "Error during gb computation";
return car w
end;
procedure gb_gsys1!$(u,m,p);
<<
u := for each x in u collect vdp_f2vdp x;
{'list,{'list,rl_mk!*fof 'true,gb_s2a!-gb gb_gb u}}
>>;
procedure gb_gbf(u,m,sm,sx);
% Groebner bases GB computation for forms. [u] is a list of SF's;
% [m] and [p] are list of variables, [sm] is a term order and [sx]
% is a list of additional arguments to [sm]. Returns a list of
% SF's.
begin scalar w,v,odipenv;
v := gb_vars(u,m);
odipenv := vdp_init(car v,sm,sx);
w := errorset({'gb_gbf1,mkquote u,mkquote car v,mkquote cdr v},
T,!*backtrace);
vdp_cleanup odipenv;
if errorp w then
rederr "Error during gb computation";
return car w
end;
procedure gb_gbf1(u,m,p);
% Groebner bases GB computation form subroutine. [u] is a list of
% SF's; [m] and [p] are list of variables. Returns a list of SF's.
<<
u := for each x in u collect vdp_f2vdp x;
gb_gb!-sfl gb_gb u
>>;
procedure gb_gb!-sfl(u);
% Groebner bases GB to SF list. [u] is a list of CGP's. Returns a
% list of SF's.
for each p in u collect vdp_2f p;
procedure gb_a2s!-psys(l);
% Groebner bases algebraic mode to symbolic mode polynomial system.
% [l] is an AMPSYS. Returns an FPSYS.
begin scalar w,resl;
for each j in getrlist l do <<
w := numr simp j;
if w and not(w member resl) then
resl := w . resl
>>;
return sort(resl,'ordp)
end;
procedure gb_s2a!-gb(u);
% Groebner bases symbolic mode to algebraic mode GB. [u] is a list
% of CGP's. Returns an AMPSYS.
'list . for each x in u collect vdp_2a x;
procedure gb_domainchk();
% Groebner bases domain check. No argument. Return value not
% defined. Raises an error if the current domain is not valid for
% GB computations.
if not memq(dmode!*,'(nil)) then
rederr bldmsg("gb does not support domain: %w",get(dmode!*,'dname));
procedure gb_vars(l,vl); %DROPPED: depend,rules,zero divisors.
% Groebner bases variables. [l] is a list of SF's; [vl] is the list
% of main variables. Returns a pair $(m . p)$ where $m$ and $p$ are
% list of variables. $m$ is the list of used main variables and $p$
% is the list of used parameters. An emty [vl] means use all
% variables as main variables.
begin scalar w,m,p;
for each f in l do
w := union(w,kernels f);
if vl then <<
m := gb_intersection(vl,w);
p := setdiff(w,vl)
>> else
m := w;
return gb_varsopt(l,m) . p
end;
procedure gb_intersection(a,b);
% Groebner bases intersection. [a] and [b] are lists. Returns a
% list. The returned list contains all elements occuring in [a] and
% in [b]. The order of the elements is the same as in [a].
for each x in a join
if x member b then
{x};
procedure gb_varsopt(l,vl);
% Groebner bases variables optimize. [l] is a list of SF's; [vl] is
% the list of main variables. Returns a possibly reorderd list of
% main variables.
if !*groebopt and td_sortmode() memq '(lex gradlex revgradlex) then
gb_vdpvordopt(l,vl)
else
vl;
procedure gb_gb2gltb(base);
'list . for each j in base collect
vdp_2a vdp_fmon(bc_a2bc 1,vdp_evlmon j);
procedure gb_gb(p);
begin scalar spac,p1,savetime,!*factor,!*exp,intvdpvars!*,!*gcd,!*ezgcd,
dip_vars!*,secondvalue!*,thirdvalue!*,cgb_gstat!*;
integer vdp_pcount!*,cgb_contcount!*,cgb_hcount!*,cgb_hzerocount!*,
cgb_tr1count!*,cgb_tr2count!*,cgb_tr3count!*,cgb_b4count!*,
cgb_strangecount!*,cgb_paircount!*,cgb_hfaccount!*,cgb_gcount!*,
cgb_gbcount!*,cgb_updbcount!*,cgb_updbcountp!*,cgb_updbcalls!*;
!*exp := !*gcd := !*ezgcd := T;
if !*cgbstat then
savetime := time();
if !*cgbcheckg then
cgb_gstat!* := nil;
cgb_contcount!* := cgb_mincontred!*;
if !*cgbstat then
spac := gctime();
p1 := if !*cgbupdb then
gb_traverso!-sturm!-experimental p
else
gb_traverso p;
if !*cgbstat then <<
ioto_tprin2t "Statistics for GB computation:";
ioto_prin2t {"Time: ",time() - savetime," ms plus GC time: ",
gctime() - spac," ms"};
ioto_prin2t {"H-polynomials total: ",cgb_hcount!*};
ioto_prin2t {"H-polynomials zero: ",cgb_hzerocount!*};
if !*cgbcounthf then
ioto_prin2t {"H-polynomials reducible: ",cgb_hfaccount!*};
if !*cgbcheckg then
ioto_prin2t {"H-polynomials gaussible: ",cgb_gcount!*,
" ",cgb_gstat!*};
ioto_prin2t {"Crit Tr1 hits: ",cgb_tr1count!*};
ioto_prin2t {"Crit B4 hits: ",cgb_b4count!*," (Buchberger 1)"};
ioto_prin2t {"Crit Tr2 hits: ",cgb_tr2count!*};
ioto_prin2t {"Crit Tr3 hits: ",cgb_tr3count!*};
if !*cgbupdb then
ioto_prin2t {"updbase: calls ",cgb_updbcalls!*,", del ",
cgb_updbcountp!*,"/",cgb_updbcount!*};
ioto_prin2t {"Strange reductions: ",cgb_strangecount!*}
>>;
return p1
end;
procedure gb_traverso!-sturm!-experimental(g0);
begin scalar gall,g,d,s,h,p;
g0 := for each fj in g0 join
if not vdp_zero!? fj then
{vdp_setsugar(vdp_enumerate vdp_simpcont fj,vdp_tdeg fj)};
for each h in g0 do << % create initial critical pairs
p := {nil,h,h};
h := gb_enumerate h;
d := gb_traverso!-pairlist(h,g,d);
g := nconc(g,{h});
gall := nconc(gall,{h});
>>;
while d do << % critical pairs left
if !*cgbverbose then <<
ioto_prin2 {"[",cgb_paircount!*,"] "};
cgb_paircount!* := cgb_paircount!* #- 1
>>;
p := car d;
d := cdr d;
s := gb_spolynomial(p);
h := gb_simpcontnormalform gb_normalform(s,gall);
cgb_hcount!* := cgb_hcount!* #+ 1;
if vdp_zero!? h then <<
cgb_hzerocount!* := cgb_hzerocount!* #+ 1;
>> else if ev_zero!? vdp_evlmon h then << % base 1 found
h := gb_enumerate h;
d := nil;
g := {h}
>> else <<
if !*cgbcounthf then
if cddr fctrf vdp_2f h then
cgb_hfaccount!* := cgb_hfaccount!* #+ 1;
h := gb_enumerate h;
d := gb_traverso!-pairlist(h,g,d);
gall := gb_updbase(gall,h);
g := nconc(g,{h})
>>
>>;
return gb_traverso!-final g
end;
procedure gb_traverso(g0);
begin scalar g,d,s,h,p,gstat;
g0 := for each fj in g0 join
if not vdp_zero!? fj then
{vdp_setsugar(vdp_enumerate vdp_simpcont fj,vdp_tdeg fj)};
for each h in g0 do << % create initial critical pairs
p := {nil,h,h};
h := gb_enumerate h;
d := gb_traverso!-pairlist(h,g,d);
g := nconc(g,{h})
>>;
if !*cgbverbose then
cgb_gbcount!* := length g;
while d do << % critical pairs left
if !*cgbverbose then <<
ioto_prin2 {"[",cgb_paircount!*,"] "};
cgb_paircount!* := cgb_paircount!* #- 1
>>;
p := car d;
d := cdr d;
s := gb_spolynomial(p);
h := gb_simpcontnormalform gb_normalform(s,g);
if !*cgbstat then
cgb_hcount!* := cgb_hcount!* #+ 1;
if vdp_zero!? h then
(if !*cgbstat then
cgb_hzerocount!* := cgb_hzerocount!* #+ 1)
else if vdp_unit!? h then <<
h := gb_enumerate h;
d := nil;
g := {h}
>> else <<
if !*cgbcounthf then
if cddr fctrf vdp_2f h then
cgb_hfaccount!* := cgb_hfaccount!* #+ 1;
if !*cgbcheckg then <<
gstat := gb_chkgauss vdp_poly h;
if 1 member gstat then <<
cgb_gcount!* := cgb_gcount!* #+ 1;
cgb_gstat!* := gb_chkgauss!-stat2vl gstat . cgb_gstat!*
>>
>>;
h := gb_enumerate h;
d := gb_traverso!-pairlist(h,g,d);
g := nconc(g,{h});
if !*cgbverbose then
cgb_gbcount!* := cgb_gbcount!* #+ 1
>>
>>;
return gb_traverso!-final g
end;
procedure gb_updbase(g,h);
begin scalar hev,oc;
if !*cgbstat then
oc := cgb_updbcountp!*;
hev := vdp_evlmon h;
g := for each p in g join
if not ev_divides!?(hev,vdp_evlmon p) then
{p}
else <<
if !*cgbverbose then
ioto_prin2 "#";
if !*cgbstat then
cgb_updbcountp!* := cgb_updbcountp!* #+ 1;
nil
>>;
if !*cgbstat then <<
if not (oc #= cgb_updbcountp!*) then
cgb_updbcount!* := cgb_updbcount!* #+ 1;
cgb_updbcalls!* := cgb_updbcalls!* + 1
>>;
return nconc(g,{h})
end;
procedure gb_chkgauss(p);
% [p] is a dipoly.
begin scalar stat;
stat := for each x in dip_vars!* collect 0;
while p do <<
stat := gb_chkgauss1(dip_evlmon p,stat);
p := dip_mred p
>>;
return stat
end;
procedure gb_chkgauss1(ev,stat);
begin scalar nstat,e,s,td;
td := ev_tdeg ev;
if td = 0 then
return stat;
td := if td #= 1 then 1 else -1;
while ev do <<
e := car ev;
ev := cdr ev;
s := car stat;
stat := cdr stat;
if e #=0 then
nstat := s . nstat
else if e #> 1 or s #= -1 then
nstat := (-1) . nstat
else if e #= 1 and s #= 0 then
nstat := td . nstat
else if s #=0 and e #=0 then
nstat := 0 . nstat
else
rederr "ich sehe es anders"
>>;
return reversip nstat
end;
procedure gb_chkgauss!-stat2vl(gstat);
begin scalar scdv,r;
scdv := dip_vars!*;
while gstat do <<
if eqcar(gstat,1) then
r := car scdv . r;
gstat := cdr gstat;
scdv := cdr scdv
>>;
return reversip r
end;
procedure gb_enumerate(f);
% f is a temporary result. Prepare it for medium range storage, and
% assign a number.
if vdp_zero!? f then
f
else <<
vdp_condense f;
if vdp_number f #= 0 then
f := vdp_setnumber(f,vdp_pcount!* := vdp_pcount!* #+ 1);
f
>>;
procedure gb_traverso!-pairlist(gk,g,d);
% gk: new polynomial, g: current basis, d: old pair list.
begin scalar ev,r,n;
d := gb_traverso!-pairs!-discard1(gk,d);
% build new pair list:
ev := vdp_evlmon gk;
for each p in g do
if not gb_buchcrit4t(ev,vdp_evlmon p) then <<
if !*cgbstat then
cgb_b4count!* := cgb_b4count!* #+ 1;
r := ev_lcm(ev,vdp_evlmon p) . r
>> else
n := gb_makepair(p,gk) . n;
n := gb_tr2crit(n,r);
n := gb_cplistsort(n,!*cgbsloppy);
n := gb_tr3crit n;
if !*cgbverbose and n then <<
cgb_paircount!* := cgb_paircount!* #+ length n;
ioto_cterpri();
ioto_prin2 {"(",cgb_gbcount!*,") "}
>>;
return gb_cplistmerge(d,reversip n)
end;
procedure gb_tr2crit(n,r);
% delete equivalents to coprime lcm
for each p in n join
if ev_member(car p,r) then <<
if !*cgbstat then
cgb_tr2count!* := cgb_tr2count!* #+ 1;
nil
>> else
{p};
procedure gb_tr3crit(n);
begin scalar newn,scannewn,q;
for each p in n do <<
scannewn := newn;
q := nil;
while scannewn do
if ev_divides!?(caar scannewn,car p) then <<
q := t;
scannewn := nil;
if !*cgbstat then
cgb_tr3count!* := cgb_tr3count!* #+ 1
>> else
scannewn := cdr scannewn;
if not q then
newn := gb_cplistsortin(p,newn,nil)
>>;
return newn
end;
procedure gb_traverso!-pairs!-discard1(gk,d);
% crit B. Delete triange relations.
for each pij in d join
if gb_traverso!-trianglep(cadr pij,caddr pij,gk,car pij) then <<
if !*cgbstat then
cgb_tr1count!* := cgb_tr1count!* #+ 1;
if !*cgbverbose then
cgb_paircount!* := cgb_paircount!* #- 1;
nil
>> else
{pij};
procedure gb_traverso!-trianglep(gi,gj,gk,tij);
ev_sdivp(gb_tt(gi,gk),tij) and ev_sdivp(gb_tt(gj,gk),tij);
procedure gb_traverso!-final(g);
% Final reduction and sorting.
for each rg on vdp_lsort g join
if not gb_searchinlist(vdp_evlmon car rg,cdr rg) then
{gb_simpcontnormalform gb_normalform(car rg,cdr rg)};
procedure gb_buchcrit4t(e1,e2);
% nonconstructive test of lcm(e1,e2) = e1 + e2 equivalent: no
% matches of nonzero elements.
not ev_disjointp(e1,e2);
procedure gb_cplistsort(g,sloppy);
begin scalar gg;
for each p in g do
gg := gb_cplistsortin(p,gg,sloppy);
return gg
end;
procedure gb_cplistsortin(p,pl,sloppy);
% 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
{p}
else <<
gb_cplistsortin1(p,pl,sloppy);
pl
>>;
procedure gb_cplistsortin1(p,pl,sloppy);
% Destructive insert of p into nonnull pl.
if not gb_cpcompless!?(car pl,p,sloppy) then <<
rplacd(pl,car pl . cdr pl);
rplaca(pl,p)
>> else if null cdr pl then
rplacd(pl,{p})
else
gb_cplistsortin1(p,cdr pl,sloppy);
procedure gb_cpcompless!?(p1,p2,sloppy);
% Compare 2 pairs wrt. their sugar (=cadddr) or their lcm (=car).
if sloppy then
ev_compless!?(car p1,car p2)
else
gb_cpcompless!?s(p1,p2,cadddr p1 #- cadddr p2,ev_comp(car p1,car p2));
procedure gb_cpcompless!?s(p1,p2,d,q);
if d neq 0 then
d #< 0
else if q neq 0 then
q < 0
else
vdp_number(caddr p1) #< vdp_number(caddr p2);
procedure gb_cplistmerge(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;
if null pl1 then
return pl2;
if null pl2 then
return pl1;
cpl1 := car pl1;
cpl2 := car pl2;
return if gb_cpcompless!?(cpl1,cpl2,nil) then
cpl1 . gb_cplistmerge(cdr pl1,pl2)
else
cpl2 . gb_cplistmerge(pl1,cdr pl2)
end;
procedure gb_makepair(f,h);
% Construct a pair from polynomials f and h.
begin scalar ttt,sf,sh;
ttt := gb_tt(f,h);
sf := vdp_sugar(f) #+ ev_tdeg ev_dif(ttt,vdp_evlmon f);
sh := vdp_sugar(h) #+ ev_tdeg ev_dif(ttt,vdp_evlmon h);
return {ttt,f,h,ev_max!#(sf,sh)}
end;
procedure gb_spolynomial(pr);
begin scalar p1,p2,s;
p1 := cadr pr;
p2 := caddr pr;
s := gb_spolynomial1(p1,p2); % TODO: Switch for strange reduction
if vdp_zero!? s or vdp_unit!? s then
return s;
% return vdp_setsugar(gb_strange!-reduction(s,p1,p2),cadddr pr)
return gb_strange!-reduction(s,p1,p2) % TODO: normal suger for
% special cases.
end;
procedure gb_spolynomial1(p1,p2);
begin scalar ep1,ep2,ep,rp1,rp2,db1,db2,x;
ep1 := vdp_evlmon p1;
ep2 := vdp_evlmon p2;
ep := ev_lcm(ep1,ep2);
rp1 := vdp_mred p1;
rp2 := vdp_mred p2;
if vdp_zero!? rp1 and vdp_zero!? rp2 then
return rp1;
if vdp_zero!? rp1 then
return vdp_prod(rp2,vdp_fmon(bc_a2bc 1,ev_dif(ep,ep2)));
if vdp_zero!? rp2 then
return vdp_prod(rp1,vdp_fmon(bc_a2bc 1,ev_dif(ep,ep1)));
db1 := vdp_lbc p1;
db2 := vdp_lbc p2;
x := bc_gcd(db1,db2);
if not bc_one!? x then <<
db1 := bc_quot(db1,x);
db2 := bc_quot(db2,x)
>>;
return vdp_ilcomb(rp2,db1,ev_dif(ep,ep2),rp1,bc_neg db2,ev_dif(ep,ep1))
end;
procedure gb_strange!-reduction(s,p1,p2);
% Subtracts multiples of p2 from the s-polynomial such that head
% terms are eliminated early.
begin scalar tp1,tp2,ts,c,saves;
saves := s;
tp1 := vdp_evlmon p1;
tp2 := vdp_evlmon p2;
c := T; while c and not vdp_zero!? s do <<
ts := vdp_evlmon s;
if gb_buch!-ev_divides!?(tp2,ts) then
s := gb_reduceonestepint(s,vdp_zero(),vdp_lbc s,ts,p2)
else if gb_buch!-ev_divides!?(tp1,ts) then
s := gb_reduceonestepint(s,vdp_zero(),vdp_lbc s,ts,p1)
else
c := nil
>>;
if !*cgbstat and not (s eq saves) then
cgb_strangecount!* := cgb_strangecount!* #+ 1;
return s
end;
procedure gb_buch!-ev_divides!?(vev1,vev2);
% Test if vev1 divides vev2 for exponent vectors vev1 and vev2.
ev_mtest!?(vev2,vev1);
procedure gb_normalform(f,g);
% General procedure for the reduction of one polynomial modulo a
% set. f is a polynomial, g is a set of polynomials. Procedure
% behaves like type='list. f is reduced modulo g.
begin scalar f1,c,vev,divisor,tai,fold; integer n;
fold := f;
f1 := vdp_setsugar(vdp_zero(),vdp_sugar f);
while not vdp_zero!? f do <<
vev := vdp_evlmon f;
c := vdp_lbc f;
divisor := gb_searchinlist(vev,g);
if divisor then <<
tai := T;
if vdp_monp divisor then
f := vdp_cancelmev(f,vdp_evlmon divisor)
else <<
f := gb_reduceonestepint(f,f1,c,vev,divisor);
f1 := secondvalue!*;
if !*cgbcontred then <<
f := gb_adtssimpcont(f,f1,n);
f1 := secondvalue!*;
n := thirdvalue!*
>>
>>
>> else if !*cgbfullred then <<
f := gb_shift(f,f1);
f1 := secondvalue!*
>> else <<
f1 := vdp_sum(f1,f);
f := vdp_zero()
>>
>>;
return if tai then f1 else fold
end;
procedure gb_searchinlist(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 gb_buch!-ev_divides!?(vdp_evlmon car g, vev) then
car g
else
gb_searchinlist(vev,cdr g);
procedure gb_adtssimpcont(f,f1,n);
begin scalar f0;
if vdp_zero!? f then <<
secondvalue!* := f1;
thirdvalue!* := 0;
return f
>>;
n := n + 1;
if n #> cgb_contcount!* then <<
f0 := f;
f := gb_simpcont2(f,f1);
f1 := secondvalue!*;
gb_contentcontrol(f neq f0);
n := 0
>>;
secondvalue!* := f1;
thirdvalue!* := n;
return f
end;
procedure gb_simpcont2(f,f1);
% Simplify two polynomials with the gcd of their contents. [f] is
% not zero.
begin scalar c,s1,s2;
c := vdp_content f;
if bc_one!? bc_abs c then <<
secondvalue!* := f1;
return f
>>;
s1 := vdp_sugar f;
s2 := vdp_sugar f1;
if not vdp_zero!? f1 then <<
c := vdp_content1(f1,c);
if bc_one!? bc_abs c then <<
secondvalue!* := f1;
return f
>>;
f1 := vdp_bcquot(f1,c)
>>;
f := vdp_bcquot(f,c);
vdp_setsugar(f,s1);
vdp_setsugar(f1,s2);
secondvalue!* := f1;
return f
end;
procedure gb_contentcontrol(u);
% u indicates, that a substantial content reduction was done;
% update content reduction limit from u.
<<
cgb_contcount!* := if u then
ev_max!#(0,cgb_contcount!* #- 1)
else
gb_min!#(cgb_mincontred!*,cgb_contcount!* #+ 1);
if !*cgbverbose then
ioto_prin2 {"<",cgb_contcount!*,"> "}
>>;
procedure gb_min!#(a,b);
if a #< b then a else b;
procedure gb_shift(f,f1);
begin scalar s,s1;
s := vdp_sugar f;
s1 := vdp_sugar f1;
f1 := vdp_nconcmon(f1,vdp_lbc f,vdp_evlmon f);
f := vdp_mred f;
vdp_setsugar(f,s);
vdp_setsugar(f1,ev_max!#(s1,s));
secondvalue!* := f1;
return f
end;
procedure gb_reduceonestepint(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 vevcof,a,b,cg,x,rg1;
rg1 := vdp_mred g1;
if vdp_zero!? rg1 then << % g1 is monomial
f := vdp_mred f;
secondvalue!* := f1;
return f
>>;
vevcof := ev_dif(vev,vdp_evlmon g1); % nix lcm
cg := vdp_lbc g1;
x := bc_gcd(c,cg);
a := bc_quot(cg,x);
b := bc_quot(c,x);
% multiply relevant parts of f and f1 by a (vbc)
if not vdp_zero!? f1 then
f1 := vdp_bcprod(f1,a);
f := vdp_ilcombr(vdp_mred f,a,rg1,bc_neg b,vevcof);
secondvalue!*:= f1;
return f
end;
procedure gb_simpcontnormalform(h);
% simpCont version preserving the property SUGAR.
if vdp_zero!? h then
h
else
vdp_setsugar(vdp_simpcont h,vdp_sugar h);
procedure gb_vdpvordopt(w,vars);
% w : list of polynomials (standard forms)
% vars: list of variables
% return vars
begin scalar c;
vars := sort(vars,'ordop);
c := for each x in vars collect x . 0 . 0;
for each poly in w do
gb_vdpvordopt1(poly,vars,c);
c := sort(c,function gb_vdpvordopt2);
intvdpvars!* := for each v in c collect car v;
vars := gb_vdpvordopt31 intvdpvars!*;
return vars
end;
procedure gb_vdpvordopt31(u);
begin scalar v,y;
if null u then
return nil;
v := for each x in u join <<
y := assoc(x,depl!*);
if null y or null xnp(cdr y,u) then
{x}
>>;
return nconc(gb_vdpvordopt31 setdiff(u,v),v)
end;
procedure gb_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
gb_vdpvordopt1(p,cdr vl,c)
else begin scalar var,pow,slot; integer n;
n := gb_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 #+ gb_vdpvordopt1 (red p,vl,c)
end;
procedure gb_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
>>;
endmodule; % gb
module vdp;
procedure vdp_lbc(u);
caddr u;
procedure vdp_evlmon(u);
cadr u;
procedure vdp_poly(u);
car cdddr u;
procedure vdp_zero!?(u);
null vdp_poly u;
procedure vdp_plist(u);
cadr cdddr u;
procedure vdp_number(f);
vdp_getprop(f,'number) or 0;
procedure vdp_sugar(f);
if vdp_zero!? f then 0 else vdp_getprop(f,'sugar); % 0 notwendig?
procedure vdp_unit!?(p);
not vdp_zero!? p and ev_zero!? vdp_evlmon p;
procedure vdp_make(vbc,vev,form);
{'vdp,vev,vbc,form,nil};
procedure vdp_monp(u);
dip_monp vdp_poly u;
procedure vdp_tdeg(u);
dip_tdeg vdp_poly u;
procedure vdp_fdip(u);
if null u then
vdp_zero()
else
vdp_make(dip_lbc u,dip_evlmon u,u);
procedure vdp_appendmon(vdp,coef,vev);
% Add a monomial to the end of a vdp (vev remains unchanged).
if vdp_zero!? vdp then
vdp_fmon(coef,vev)
else if bc_zero!? coef then
vdp
else
vdp_make(vdp_lbc vdp,vdp_evlmon vdp,dip_appendmon(vdp_poly vdp,coef,vev));
procedure vdp_nconcmon(vdp,coef,vev);
% Add a monomial to the end of a vdp (vev remains unchanged).
if vdp_zero!? vdp then
vdp_fmon(coef,vev)
else if bc_zero!? coef then
vdp
else
vdp_make(vdp_lbc vdp,vdp_evlmon vdp,dip_nconcmon(vdp_poly vdp,coef,vev));
procedure vdp_bcquot(p,c);
begin scalar r;
r := vdp_fdip dip_bcquot(vdp_poly p,c);
vdp_setsugar(r,vdp_sugar p);
return r
end;
procedure vdp_content(p);
dip_contenti vdp_poly p;
procedure vdp_content1(d,c);
dip_contenti1(vdp_poly d,c);
procedure vdp_length(f);
dip_length vdp_poly f;
procedure vdp_bcprod(p,b);
begin scalar r;
r := vdp_fdip dip_bcprod(vdp_poly p,b);
vdp_setsugar(r,vdp_sugar p);
return r
end;
procedure vdp_cancelmev(p,vev);
begin scalar r;
r := vdp_fdip dip_cancelmev(vdp_poly p,vev);
vdp_setsugar(r,vdp_sugar p);
return r
end;
procedure vdp_sum(d1,d2);
begin scalar r;
r := vdp_fdip dip_sum(vdp_poly d1,vdp_poly d2);
vdp_setsugar(r,ev_max!#(vdp_sugar d1,vdp_sugar d2));
return r
end;
procedure vdp_prod(d1,d2);
begin scalar r;
r := vdp_fdip dip_prod(vdp_poly d1,vdp_poly d2);
vdp_setsugar(r,vdp_sugar d1 #+ vdp_sugar d2);
return r
end;
procedure vdp_zero();
vdp_make('invalid,'invalid,nil);
procedure vdp_mred(u);
begin scalar r;
r := dip_mred vdp_poly u;
if null r then
return vdp_zero();
r := vdp_make(dip_lbc r,dip_evlmon r,r);
vdp_setsugar(r,vdp_sugar(u));
return r
end;
procedure vdp_condense(f);
dip_condense vdp_poly f;
procedure vdp_setsugar(p,s);
vdp_putprop(p,'sugar,s);
procedure vdp_setnumber(p,n);
vdp_putprop(p,'number,n);
procedure vdp_putprop(poly,prop,val);
begin scalar c,p;
c := cdr cdddr poly;
p := atsoc(prop,car c);
if p then
rplacd(p,val)
else
rplaca(c,(prop . val) . car c);
return poly
end;
procedure vdp_getprop(poly,prop);
(if p then cdr p else nil) where p=atsoc(prop,vdp_plist poly);
procedure vdp_fmon(coef,vev);
begin scalar r;
r := vdp_make(coef,vev,dip_fmon(coef,vev));
vdp_setsugar(r,ev_tdeg vev);
return r
end;
procedure vdp_2a(u);
dip_2a vdp_poly u;
procedure vdp_2f(u);
dip_2f vdp_poly u;
procedure vdp_init(vars,sm,sx);
% Initializing vdp-dip polynomial package.
dip_init(vars,sm,sx);
procedure vdp_cleanup(l);
dip_cleanup(l);
procedure vdp_f2vdp(u);
begin scalar dip;
dip := dip_f2dip u;
if null dip then
return vdp_zero();
return vdp_make(dip_lbc dip,dip_evlmon dip,dip)
end;
procedure vdp_enumerate(f);
% f is a temporary result. Prepare it for medium range storage and
% assign a number.
if vdp_zero!? f or vdp_getprop(f,'number) then
f
else
vdp_putprop(f,'number,(vdp_pcount!* := vdp_pcount!* #+ 1));
procedure vdp_simpcont(p);
begin scalar q;
q := vdp_poly p;
if null q then
return p;
return vdp_fdip dip_simpcont q
end;
procedure vdp_lsort(pl);
% Distributive polynomial list sort. pl is a list of distributive
% polynomials. vdplsort(pl) returns the sorted distributive
% polynomial list of pl.
sort(pl,function vdp_evlcomp);
procedure vdp_evlcomp(p1,p2); % nicht auf das HM?
dip_evlcomp(vdp_poly p1,vdp_poly p2);
procedure vdp_ilcomb(v1,c1,t1,v2,c2,t2);
begin scalar r;
r := vdp_fdip dip_ilcomb(vdp_poly v1,c1,t1,vdp_poly v2,c2,t2);
vdp_setsugar(r,ev_max!#(
vdp_sugar v1 #+ ev_tdeg t1,vdp_sugar v2 #+ ev_tdeg t2));
return r
end;
procedure vdp_ilcombr(v1,c1,v2,c2,t2);
begin scalar r;
r := vdp_fdip dip_ilcombr(vdp_poly v1,c1,vdp_poly v2,c2,t2);
vdp_setsugar(r,ev_max!#(vdp_sugar v1,vdp_sugar v2 #+ ev_tdeg t2));
return r
end;
endmodule; % vdp
end; % of file