pfacmult.red 3.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104
  1. module pfacmult; % multivariate modular factorization.
  2. % Author: Herbert Melenk.
  3. % Reduction of multivariate modular factorization to univariate
  4. % factorization by Kroneckers map.
  5. % See Kaltofen: Factorization of Polynomials, in: Buchberger,
  6. % Collins, Loos: Computer Algebra, Springer, 1982.
  7. % This module should be removed as soon as a multivariate modular
  8. % factorizer based on Hensel lifting has been written.
  9. fluid '(!*trfac);
  10. symbolic procedure fctrfkronm f;
  11. begin scalar sub,tra,k,x,xx,x0,y,z,r,q,f0,fl,fs,dmode!*;
  12. integer d,d0;
  13. k:=kernels f;
  14. dmode!*:='!:mod!:;
  15. for each z in decomposedegr(f,for each x in k collect (x. 0))
  16. do if cdr z >d then d:=cdr z;
  17. d:=d+1; d0:=d; x0:=car k;
  18. for each x in cdr k do
  19. <<sub:=(x . {'expt,x0,d0}).sub; tra:=(x.d0).tra; d0:=d0*d>>;
  20. fs:=numr subf(f,sub);
  21. if !*trfac then
  22. <<writepri("Kronecker mapped form:",'first);
  23. writepri(mkquote prepf fs,'last)>>;
  24. fl:=decomposefctrf fs;
  25. if null cdr fl then return {1,f.1};
  26. f0:=numr resimp (f ./ 1);
  27. for each fc in fl do if not domainp f0 then
  28. <<y:=fctrfmk1(fc,tra);
  29. y:=numr resimp(y ./ 1);
  30. x := fctrfmk3 y;
  31. if x then y:= quotf(y, x);
  32. if !*trfac then
  33. <<writepri("test next candidate ",'first);
  34. writepri(mkquote prepf y,'last)>>;
  35. if (q:=quotf(f0,y)) then
  36. <<f0:=q; if(z:=assoc(y,r)) then cdr z:=cdr z+1
  37. else r:=(y. 1).r>>>>;
  38. if null r then return {1,f. 1};
  39. if domainp f0 then return (f0 .r);
  40. if !*trfac then
  41. <<writepri("descend in recursion with",'only);
  42. writepri(mkquote prepf f0, 'only)>>;
  43. fl := fctrfkronm f0;
  44. if !*trfac then
  45. <<writepri("return from recursion; numeric factor ",'first);
  46. writepri(mkquote prepf car fl, 'last);
  47. for each fc in cdr fl do
  48. <<writepri("polynomial factor: ",'first);
  49. writepri(mkquote prepf car fc, nil);
  50. writepri(" multiplicity ", nil);
  51. writepri(mkquote prepf cdr fc, 'last)>> >>;
  52. x := car fl; xx := cdr fl;
  53. if null cdr xx and cdar xx = 1 and fctrfmk4 x then
  54. <<y := fctrfmk3 car xx;
  55. if y then
  56. <<x := y;
  57. xx := list(quotf(caar xx, x) . 1);
  58. if !*trfac then
  59. <<writepri("number correction; numeric factor ",'first);
  60. writepri(mkquote x,'last);
  61. writepri("polynomial factor ",'first);
  62. writepri(mkquote prepf caar xx,'last)>> >> >>;
  63. for each fc in xx do
  64. <<y:=numr resimp(car fc ./ 1);
  65. if !*trfac then
  66. <<writepri("next division: ",'first);
  67. writepri(mkquote prepf y,'last)>>;
  68. f0:=quotf(f0,y);
  69. if(z:=assoc(y,r)) then cdr z:=cdr z+cdr fc
  70. else r:=(y. cdr fc).r>>;
  71. x := quotf(x, f0);
  72. return x . r
  73. end;
  74. symbolic procedure fctrfmk1(f,tra);
  75. % Kronecker backtransform.
  76. if domainp f then f else
  77. addf(multf(lc f,fctrfmk2(mvar f,ldeg f,tra)),fctrfmk1(red f,tra));
  78. symbolic procedure fctrfmk2(x,n,tra);
  79. if n=0 then 1 else
  80. if null tra then x.**n .* 1 .+ nil else
  81. if n>=cdar tra then multf(caar tra .** (n/cdar tra) .* 1 .+nil,
  82. fctrfmk2(x,remainder(n,cdar tra),cdr tra))
  83. else fctrfmk2(x,n,cdr tra);
  84. symbolic procedure fctrfmk3 f;
  85. % Extract the leading coefficient.
  86. if domainp f then (if fctrfmk4 f then nil else f) else fctrfmk3 lc f;
  87. symbolic procedure fctrfmk4 u;
  88. % Test u=1 in modular mode;
  89. numberp u and u = 1 or
  90. not atom u and car u = '!:mod!: and modonep!: u;
  91. endmodule;
  92. end;