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.
<<h := nil; nil>>;
endmodule;
end;