Artifact ee754e4fcfa0f3e75d075cee340cd87b2058e21cb35d4a9b555b671e81cd0a71:
- Executable file
r37/packages/groebner/groebfac.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: 4315) [annotate] [blame] [check-ins using] [more...]
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;