reduce-historical/r38/packages/groebner/grinterf.red

module grinterf;% Interface of Groebner package to reduce.
% Entry points to the main module and general interface support.
 
flag('(groebrestriction gvarslast groebprotfile gltb glterms gmodule),'share);
 
switch groebopt,trgroeb,gltbasis,gsugar;
 
vdpsortmode!*:='lex;% Initial mode .

gltb:='(list);    % Initially empty .

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%    Interface functions .
 
symbolic procedure groebnereval u;
% Non factorizing Groebner calculation .
begin scalar n,!*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 scalar n,!*groebfac,!*groebrm,!*factor,!*exp,!*ezgcd,
 s,r,q;!*exp:=t;
 !*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 scalar n,!*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);

symbolic procedure saturationeval u;
begin scalar a,b,c,!*factor,!*exp;!*exp:=t;
 if length u=2 then go to aa;
 rerror(groebner,19,"saturation called with wrong number of arguments");
aa:a:=reval car u;
 if car a='list then go to bb;
 rerror(groebner,20,"saturation, first parameter must be a list");
bb:a:='list.for each aa in cdr a collect
  if eqexpr aa then reval !*eqn2a aa else aa;
 c:=reval cadr u;
 if car c='list then
  rerror(groebner,25,"saturation, second parameter must no be a list");
 if eqexpr c then c:=reval !*eqn2a c;
 while not(b=a)do<<if b then a:=b;b:=groebidq(a,c,nil)>>;return b end;

put('saturation,'psopfn,'saturationeval);
  
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 go to 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};
 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;
 
% Hier
    
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 scalar n,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 polynomial 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;