sqrtf.red 3.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990
  1. module sqrtf; % Square root of standard forms.
  2. % Authors: Mary Ann Moore and Arthur C. Norman.
  3. fluid '(!*noextend zlist);
  4. exports nrootn,domainp,minusf; % minusdfp,sqrtdf
  5. imports contentsmv,gcdf,interr,!*multf,partialdiff,printdf,quotf,
  6. simpsqrt2,vp2;
  7. % symbolic procedure minusdfp a;
  8. % % Test sign of leading coedd of d.f.
  9. % if null a then interr "Minusdfp 0 illegal"
  10. % else minusf numr lc a;
  11. % symbolic procedure sqrtdf l;
  12. % % Takes square root of distributive form. "Failed" usually means
  13. % % that the square root is not among already existing objects.
  14. % if null l then nil
  15. % else begin scalar c;
  16. % if lpow l=vp2 zlist then go to ok;
  17. % c:=sqrtsq df2q l;
  18. % if numr c eq 'failed
  19. % then return 'failed;
  20. % if denr c eq 'failed
  21. % then return 'failed;
  22. % return for each u in f2df numr c
  23. % collect (car u).!*multsq(cdr u,1 ./ denr c);
  24. % ok: c:=sqrtsq lc l;
  25. % if numr c eq 'failed or
  26. % denr c eq 'failed
  27. % then return 'failed
  28. % else return (lpow l .* c) .+nil
  29. % end;
  30. % symbolic procedure sqrtsq a;
  31. % sqrtf numr a ./ sqrtf denr a;
  32. symbolic procedure sqrtf p;
  33. begin scalar ip,qp;
  34. if null p then return nil;
  35. ip:=sqrtf1 p;
  36. qp:=cdr ip;
  37. ip:=car ip; %respectable and nasty parts of the sqrt.
  38. if qp=1 then return ip; %exact root found.
  39. if !*noextend then return 'failed;
  40. % We cannot add new square roots in this case, since it is
  41. % then impossible to determine if one square root depends
  42. % on another if new ones are being added all the time.
  43. if zlistp qp then return 'failed;
  44. % Liouville's theorem tells you that you never need to add
  45. % new algebraics depending on the variable of integration.
  46. qp:=simpsqrt2 qp;
  47. return !*multf(ip,qp)
  48. end;
  49. symbolic procedure zlistp qp;
  50. if atom qp then member(qp,zlist)
  51. else or(member(mvar qp,zlist),zlistp lc qp,zlistp red qp);
  52. symbolic procedure sqrtf1 p;
  53. % Returns a . b with p=a**2*b.
  54. if domainp p
  55. then if fixp p then nrootn(p,2)
  56. else !*q2f simpsqrt list prepf p . 1
  57. else begin scalar co,pp,g,pg;
  58. co:=contentsmv(p,mvar p,nil); %contents of p.
  59. pp:=quotf(p,co); %primitive part.
  60. co:=sqrtf1(co); %process contents via recursion.
  61. g:=gcdf(pp,partialdiff(pp,mvar pp));
  62. pg:=quotf(pp,g);
  63. g:=gcdf(g,pg); %a repeated factor of pp.
  64. if g=1 then pg:=1 . pp
  65. else <<
  66. pg:= quotf(pp,!*multf(g,g)); %what is still left.
  67. pg:=sqrtf1(pg); %split that up.
  68. rplaca(pg,!*multf(car pg,g))>>;
  69. %put in the thing found here.
  70. rplaca(pg, !*multf(car pg,car co));
  71. rplacd(pg, !*multf(cdr pg,cdr co));
  72. return pg
  73. end;
  74. % NROOTN removed as in REDUCE base.
  75. endmodule;
  76. end;