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 powlis!*);
global '(!*match 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;
end;