home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / rat3d.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  16.9 KB  |  536 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module rat3d)
  13.  
  14. (DECLARE-top (GENPREFIX A_4))
  15.  
  16.  
  17. (LOAD-MACSYMA-MACROS RATMAC)
  18.  
  19.  
  20. ;    THIS IS THE NEW RATIONAL FUNCTION PACKAGE PART 4.
  21. ;    IT INCLUDES THE POLYNOMIAL FACTORING ROUTINES.
  22.  
  23. (DECLARE-top (SPECIAL *MIN* *MX* *ODR* NN* SCANMAPP *CHECKAGAIN ADN*))
  24.  
  25. (declare-top (special $factorflag $intfaclim $dontfactor $algebraic $ratfac)
  26.      (special errrjfflag)
  27.      )
  28.  
  29. ;There really do seem to be two such variables...
  30. (declare-top (special alpha *alpha)
  31.      (special gauss genvar minpoly*))
  32.  
  33. (DEFMVAR *IRREDS NIL)
  34. (DEFMVAR ALGFAC* NIL)
  35. (DEFMVAR LOW* NIL)
  36.  
  37. (DEFMVAR $INTFACLIM 1000.)
  38. (DEFMVAR $BERLEFACT T)
  39.  
  40.  
  41. ;; Do not remove the following function -- it is needed for non-PDP10 Macsymas
  42. ;; On PDP10s, the function is hand coded in RAT;RATLAP >.
  43.  
  44. #-PDP10
  45. (DEFMFUN CFACTOR (X)
  46.   (PROG (DIVISOR TT ANS K)
  47.     (COND ((NULL $FACTORFLAG) (RETURN (LIST X 1)))
  48.           ((FLOATP X)
  49.            (ERRRJF "FACTOR given floating arg"))
  50.           ((PZEROP X) (RETURN (LIST (PZERO) 1)))
  51.           ((EQN X -1) (RETURN (LIST -1 1)))
  52.           ((MINUSP X)
  53.            (RETURN (CONS -1 (CONS 1 (CFACTOR (MINUS X))))))
  54.           ((LESSP X 2) (RETURN (LIST X 1))))
  55.         (cond ((fixnump x) (return (fixnum-cfactor x))))
  56.     (SETQ K 2 DIVISOR 2)
  57.     SETT (SETQ TT 0)
  58.     LOOP (COND ((ZEROP (REMAINDER X DIVISOR))
  59.             (SETQ TT (ADD1 TT))
  60.             (SETQ X (QUOTIENT X DIVISOR))
  61.             (GO LOOP)))
  62.     (COND ((GREATERP TT 0)
  63.            (SETQ ANS (CONS DIVISOR (CONS TT ANS)))))
  64.     (COND ((EQUAL DIVISOR 2) (SETQ DIVISOR 3))
  65.           ((EQUAL DIVISOR 3) (SETQ DIVISOR 5))
  66.           (T (SETQ DIVISOR (PLUS DIVISOR K))
  67.          (COND ((EQL K 2) (SETQ K 4)) (T (SETQ K 2)))))
  68.     (COND ((OR (AND $INTFACLIM (GREATERP DIVISOR $INTFACLIM))
  69.            (GREATERP (TIMES DIVISOR DIVISOR) X))
  70.            (RETURN (COND ((GREATERP X 1)
  71.                   (CONS X (CONS 1 ANS)))
  72.                  (T ANS)))))
  73.     (GO SETT)))
  74.  
  75. (DEFMFUN fixnum-CFACTOR (X)
  76.     (declare (fixnum x))
  77.   (PROG ((DIVISOR 2)  (TT 0)  (K 2) ans)
  78.     (declare (fixnum divisor tt  k))
  79.     SETT (SETQ TT 0)
  80.     LOOP (COND ((f= 0 (fixnum-remainder X DIVISOR))
  81.             (SETQ TT (f+ 1 TT))
  82.             (SETQ X (the fixnum (quot  X DIVISOR)))
  83.             (GO LOOP)))
  84.     (COND ((> TT 0)
  85.            (SETQ ANS (CONS DIVISOR (CONS TT ANS)))))
  86.     (COND ((f= DIVISOR 2) (SETQ DIVISOR 3))
  87.           ((f= DIVISOR 3) (SETQ DIVISOR 5))
  88.           (T (SETQ DIVISOR (f+ DIVISOR K))
  89.          (COND ((f= K 2) (SETQ K 4)) (T (SETQ K 2)))))
  90.     (COND ((OR (AND $INTFACLIM (f> DIVISOR $INTFACLIM))
  91.            (f> (f* DIVISOR DIVISOR) X))
  92.            (RETURN (COND ((f> X 1)
  93.                   (CONS X (CONS 1 ANS)))
  94.                  (T ANS)))))
  95.     (GO SETT)))
  96.  
  97. ;;;****** END OF FUNCTION WHICH IS ONLY COMMENTED OUT IF THERE IS A LAP ******
  98.  
  99.  
  100. (DEFMFUN LISTOVARS (Q)
  101.   (COND ((PCOEFP Q) NIL)
  102.     (t (let ((ans nil))
  103.          (declare (special ans))
  104.          (listovars0 q)))))
  105.  
  106. (DEFUN LISTOVARS0 (Q)
  107.   (declare (special ans))
  108.   (COND ((PCOEFP Q) ANS)
  109.     ((MEMQ (CAR Q) ANS) (LISTOVARS1 (CDR Q)))
  110.     (T (PUSH (CAR Q) ANS)
  111.        (LISTOVARS1 (CDR Q)))))
  112.  
  113. (DEFUN LISTOVARS1 (QL)
  114.   (declare (special ans))
  115.   (COND ((NULL QL) ANS)
  116.     (T (LISTOVARS0 (CADR QL)) (LISTOVARS1 (CDDR QL)))))
  117.  
  118. (DEFUN DONTFACTOR (Y)
  119.        (COND ((OR (NULL $DONTFACTOR) (EQUAL $DONTFACTOR '((MLIST)))) NIL)
  120.          ((MEMALIKE (PDIS (MAKE-POLY Y)) $DONTFACTOR) T)))
  121.  
  122. (DEFUN REMOVEALG (L)
  123.        (sloop for var in l
  124.          unless (algv var) collect var))
  125.  
  126. (DEFUN DEGVECDISREP (DEGL)
  127.        (DO ((L DEGL (CDR L))
  128.         (GV GENVAR (CDR GV))
  129.         (ANS 1))
  130.        ((NULL L) ANS)
  131.        (AND (f> (CAR L) 0)
  132.         (SETQ ANS (LIST (CAR GV) (CAR L) ANS)))))
  133.  
  134. (DEFUN PTERMCONT (P)
  135.        (LET ((TCONT (DEGVECDISREP (PMINDEGVEC P)))
  136.          ($ALGEBRAIC))
  137.         (LIST TCONT (PQUOTIENT P TCONT))))
  138.  
  139. (DEFUN PMINDEGVEC (P)
  140.        (MINLIST (LET ((*ODR* (PUTODR (REVERSE GENVAR)))
  141.               (NN* (f1+ (LENGTH GENVAR)))
  142.               (*MIN* T))
  143.              (DEGVECTOR NIL 1 P))))
  144.  
  145. (DEFUN PDEGREEVECTOR (P)
  146.        (MAXLIST (LET ((*ODR* (PUTODR (REVERSE GENVAR)))
  147.               (NN* (f1+ (LENGTH GENVAR)))
  148.               (*MX* T))
  149.              (DEGVECTOR NIL 1 P))))
  150.  
  151. (DEFUN MAXLIST(L) (MAXMINL L T))
  152.  
  153. (DEFUN MINLIST(L) (MAXMINL L NIL))
  154.  
  155. (DEFUN MAXMINL (L SWITCH)
  156.        (DO ((L1 (COPY1 (CAR L)))
  157.         (LL (CDR L) (CDR LL)))
  158.        ((NULL LL) L1)
  159.        (DO ((V1 L1 (CDR V1))
  160.         (V2 (CAR LL) (CDR V2)))
  161.            ((NULL V1))
  162.            (COND (SWITCH
  163.                  (COND ((f> (CAR V2) (CAR V1))
  164.                    (RPLACA V1 (CAR V2)))))
  165.              (T (COND ((f< (CAR V2) (CAR V1))
  166.                    (RPLACA V1 (CAR V2)))))))))
  167.  
  168. (DEFUN NZEROS (N L) (DO ((J N (f1- J))
  169.              (L L (CONS 0 L)))
  170.             ((= 0 J) L)))
  171.  
  172. (DEFUN QUICK-SQFR-CHECK (P VAR)
  173.   (LET ((GV (zl-DELETE VAR (LISTOVARS P)))
  174.     (MODULUS (OR MODULUS *ALPHA))
  175.     (L) (P0))
  176.     (IF $ALGEBRAIC (SETQ GV (REMOVEALG GV)))
  177.     (AND GV
  178.      (NOT (PZEROP (PCSUBSTY (SETQ L (RAND (LENGTH GV) MODULUS))
  179.                 GV (PMOD (P-LC P)))))
  180.      (NOT (PCOEFP (SETQ P0 (PCSUBSTY L GV (PMOD P)))))
  181.      (PCOEFP (PGCD P0 (PDERIVATIVE P0 (CAR P0))))
  182.      (LIST L GV P0))))
  183.      
  184. (DEFUN MONOM->FACL (P)
  185.        (COND ((PCOEFP P) (IF (EQUAL P 1) NIL (LIST P 1)))
  186.          (T (LIST* (PGET (CAR P)) (CADR P) (MONOM->FACL (CADDR P))))))
  187.  
  188. (DEFUN PSQFR (P)
  189.       (PROG (R VARL VAR MULT FACTORS)
  190.       (COND ((PCOEFP P) (RETURN (CFACTOR P)))
  191.         ((PMINUSP P) (RETURN (CONS -1 (CONS 1 (PSQFR (PMINUS P)))))))
  192.       (DESETQ (FACTORS P) (PTERMCONT P))
  193.       (SETQ FACTORS (MONOM->FACL FACTORS))
  194.       (COND ((PCOEFP P) (GO END)))
  195.       (SETQ VARL (SORT (LISTOVARS P) 'POINTERGP))
  196.   SETVAR
  197.       (SETQ VAR (CAR VARL) VARL (CDR VARL) MULT 0)
  198.       (COND ((POINTERGP VAR (CAR P)) (GO NEXTVAR))
  199.         ((DONTFACTOR VAR)
  200.          (SETQ FACTORS (CONS P (CONS 1 FACTORS))
  201.            P 1)
  202.           (GO END)))
  203.       (COND ((QUICK-SQFR-CHECK P VAR)   ;QUICK SQFR CHECK BY SUBST.
  204.           (SETQ R (OLDCONTENT P))
  205.           (SETQ P (CAR R) FACTORS (CONS (CADR R)
  206.                         (CONS 1 FACTORS)))
  207.           (GO NEXTVAR)))
  208.     (SETQ R (PDERIVATIVE P VAR))
  209.     (COND ((PZEROP R) (GO NEXTVAR)))
  210.     (COND ((AND MODULUS (NOT (PCOEFP R))) (PMONICIZE (CDR R))))
  211.     (SETQ P (PGCDCOFACTS P R))
  212.     (AND ALGFAC* (CADDDR P) (SETQ ADN* (PTIMES ADN* (CADDDR P))))
  213.     (SETQ R (CADR P)              ; PRODUCT OF P[I]
  214.       P (CAR P))
  215.   A (SETQ R (PGCDCOFACTS R P)
  216.       P (CADDR R)
  217.       MULT (f1+ MULT))
  218.     (AND ALGFAC* (CADDDR R) (SETQ ADN* (PTIMES ADN* (CADDDR R)))) 
  219.     (COND ((NOT (PCOEFP (CADR R)))
  220.        (SETQ FACTORS
  221.          (CONS (CADR R)
  222.            (CONS MULT FACTORS)))))
  223.     (COND ((NOT (PCOEFP (SETQ R (CAR R)))) (GO A)))
  224.   NEXTVAR
  225.        (COND ((PCOEFP P) (GO END))
  226.          (VARL (GO SETVAR))
  227.          (MODULUS (SETQ FACTORS (APPEND (FIXMULT (PSQFR (PMODROOT P))
  228.                              MODULUS)
  229.                         FACTORS))
  230.               (SETQ P 1)))
  231.   END  (SETQ P (COND ((EQUAL 1 P) NIL)
  232.              (T (CFACTOR P))))
  233.        (RETURN (APPEND P FACTORS))))
  234.  
  235. (DEFUN FIXMULT (L N)
  236.        (DO ((L L (CDDR L))) ((NULL L)) (RPLACA (CDR L) (f* N (CADR L))))
  237.        L)
  238.  
  239. (DEFUN PMODROOT (P)
  240.        (COND ((PCOEFP P) P)
  241.          ((ALG P) (PEXPT P (EXPT MODULUS (f1- (CAR (ALG P))))))
  242.          (T (CONS (CAR P) (PMODROOT1 (CDR P))))))
  243.  
  244. (DEFUN PMODROOT1 (X)
  245.        (COND ((NULL X) X)
  246.          (T (CONS (// (CAR X) MODULUS)
  247.               (CONS (PMODROOT (CADR X))
  248.                 (PMODROOT1 (CDDR X)))))))
  249.  
  250. (DEFMVAR $SAVEFACTORS NIL "If t factors of ratreped forms will be saved")
  251.  
  252. (DEFVAR CHECKFACTORS () "List of saved factors")
  253.  
  254. (DEFUN SAVEFACTORS (L)
  255.   (WHEN $SAVEFACTORS
  256.     (SAVEFACTOR1 (CAR L))
  257.     (SAVEFACTOR1 (CDR L)))
  258.   L)
  259.  
  260. (DEFUN SAVEFACTOR1 (P)
  261.   (UNLESS (OR (PCOEFP P)
  262.           (PTZEROP (P-RED P))
  263.           (zl-MEMBER P CHECKFACTORS))
  264.       (PUSH P CHECKFACTORS)))
  265.  
  266. (DEFUN HEURTRIAL1 (POLY FACS)
  267.        (PROG (H J)
  268.          (SETQ H (PDEGREEVECTOR POLY))
  269.          (COND ((OR (zl-MEMBER 1 H) (zl-MEMBER 2 H)) (RETURN (LIST POLY))))
  270.          (COND ((NULL FACS) (RETURN (LIST POLY))))
  271.          (SETQ H (PGCD POLY (CAR FACS)))
  272.          (RETURN (COND ((PCOEFP H) (HEURTRIAL1 POLY (CDR FACS)))
  273.                ((PCOEFP (SETQ J (PQUOTIENT POLY H)))
  274.                 (HEURTRIAL1 POLY (CDR FACS)))
  275.                (T (HEURTRIAL (LIST H J) (CDR FACS)))))))
  276.  
  277. (DEFUN HEURTRIAL (X FACS)
  278.        (COND ((NULL X) NIL)
  279.          (T (NCONC (HEURTRIAL1 (CAR X) FACS)
  280.                (HEURTRIAL (CDR X) FACS)))))
  281.  
  282.  
  283. (DEFUN PFACTORQUAD (P)
  284.        (PROG (A B C D $DONTFACTOR L V)
  285.          (COND((OR (ONEVARP P)(EQUAL MODULUS 2))(RETURN (LIST P))))
  286.          (SETQ L (PDEGREEVECTOR P))
  287.          (COND ((NOT (zl-MEMBER 2 L)) (RETURN (LIST P))))
  288.          (SETQ L (NREVERSE L) V (REVERSE GENVAR))    ;FIND MOST MAIN VAR
  289.     LOOP (COND ((EQN (CAR L) 2) (SETQ V (CAR V)))
  290.            (T (SETQ L (CDR L)) (SETQ V (CDR V)) (GO LOOP)))
  291.          (DESETQ (A . C) (BOTHPRODCOEF (MAKE-POLY V 2 1) P))
  292.          (DESETQ (B . C) (BOTHPRODCOEF (MAKE-POLY V 1 1) C))
  293.          (SETQ D (PGCD (PGCD A B) C))
  294.           (COND ((PCOEFP D) NIL)
  295.            (T (SETQ *IRREDS (NCONC *IRREDS (PFACTOR1 D)))
  296.               (RETURN (PFACTORQUAD (PQUOTIENT P D)))))
  297.          (SETQ D (PPLUS (PEXPT B 2) (PTIMES -4 (PTIMES A C))))
  298.          (RETURN
  299.           (COND ((SETQ C (PNTHROOTP D 2))
  300.              (SETQ D (RATREDUCE (PPLUS B C) (PTIMES 2 A)))
  301.              (SETQ D (PABS (PPLUS (PTIMES (MAKE-POLY V) (CDR D))
  302.                       (CAR D))))
  303.              (SETQ *IRREDS (NCONC *IRREDS (LIST D (PQUOTIENT P D))))
  304.              NIL)
  305.             (MODULUS (LIST P))    ;NEED TO TAKE SQRT(INT. MOD P) LCF.
  306.             (T (SETQ *IRREDS (NCONC *IRREDS (LIST P)))NIL)))))
  307.  
  308. (DEFMFUN $ISQRT (X) ($INRT X 2))
  309.  
  310. (DEFMFUN $INRT (X N)
  311.        (COND ((NOT (INTEGERP (SETQ X (MRATCHECK X))))
  312.           (COND ((EQUAL N 2) (LIST '($ISQRT) X)) (T (LIST '($INRT) X N))))
  313.          ((ZEROP X) X)
  314.          ((NOT (INTEGERP (SETQ N (MRATCHECK N)))) (LIST '($INRT) X N))
  315.          (T (car (iroot (ABS X) N)))))
  316.  
  317. (defun iroot (a n) ; computes a^(1/n)  see Fitch, SIGSAM Bull Nov 74
  318.   (cond ((f< (haulong a) n) (list 1 (sub1 a)))
  319.     (t  ;assumes integer a>0 n>=2
  320.      (do ((x (expt 2 (f1+ (quotient (haulong a) n)))
  321.          (difference x (quotient (plus n1 bk) n)))
  322.           (n1 (f1- n)) (xn) (bk))
  323.          (nil)
  324.        (cond ((signp le (setq bk (*dif x (*quo a (setq xn (expt x n1))))))
  325.           (return (list x (difference a (times x xn))))))))))
  326.  
  327. (DEFMFUN $NTHROOT(P N)
  328.        (cond ((Setq n (PNTHROOTP (CADR ($RAT P)) N)) (pdis n))
  329.          (T (merror "Not an nth power"))))
  330.  
  331. (DEFUN PNTHROOTP (P N)
  332.        (LET ((ERRRJFFLAG T))
  333.         (CATCH 'RATERR (PNTHROOT P N))))
  334.  
  335. ;(defun pnthroot (poly n)
  336. ;   (cond ((pcoefp poly) (cnthroot poly n))
  337. ;     (t (let* ((var (p-var poly))
  338. ;           (ans (make-poly var (cquotient (p-le poly) n)
  339. ;                   (pnthroot (p-lc poly) n)))
  340. ;           (ae (p-terms (pquotient (pctimes n (leadterm poly)) ans))))
  341. ;          (do ((p (psimp var (p-red poly))
  342. ;              (pdifference poly (pexpt ans n))))
  343. ;              ((pzerop p) ans)
  344. ;              (cond ((or (pcoefp p) (not (eq (p-var p) var))
  345. ;                 (f> (car ae) (p-le p)))
  346. ;                 (throw 'raterr nil)))
  347. ;              (setq ans (nconc ans (pquotient1 (cdr (leadterm p)) ae)))
  348. ;              )))))
  349. ;New version from F302 --gsb
  350. (defun pnthroot (poly n)
  351.    (cond ((equal n 1) poly)
  352.      ((pcoefp poly) (cnthroot poly n))
  353.      (t (let* ((var (p-var poly))
  354.            (ans (make-poly var (cquotient (p-le poly) n)
  355.                    (pnthroot (p-lc poly) n)))
  356.            (ae (p-terms (pquotient (pctimes n (leadterm poly)) ans))))
  357.           (do ((p (psimp var (p-red poly))
  358.               (pdifference poly (pexpt ans n))))
  359.               ((pzerop p) ans)
  360.               (cond ((or (pcoefp p) (not (eq (p-var p) var))
  361.                  (f> (car ae) (p-le p)))
  362.                  (throw 'raterr nil)))
  363.               (setq ans (nconc ans (pquotient1 (cdr (leadterm p)) ae)))
  364.               )))))
  365.  
  366. (DEFUN CNTHROOT(C N)
  367.        (COND ((MINUSP C)
  368.           (COND ((ODDP N) (MINUS (cnthroot (MINUS C) N)))
  369.             (T (throw 'raterr nil))))
  370.          ((zerop c) c)
  371.          ((zerop (cadr (setq c (iroot C N)))) (car c))
  372.          (t (throw 'raterr nil))))
  373.  
  374.  
  375. (DEFMFUN PABS (X) (COND ((PMINUSP X) (PMINUS X)) (T X)))
  376.  
  377. (DEFUN PFACTORLIN (P L)
  378.        (do ((degl l (cdr degl))
  379.         (v genvar (cdr v))
  380.         (a)(b))
  381.        ((null degl) nil)
  382.        (cond ((and (= (car degl) 1)
  383.                (not (algv (car v))))
  384.           (desetq (a . b) (bothprodcoef (make-poly (car v)) p))
  385.           (setq a (pgcd a b))
  386.           (return (cons (pquotientchk p a)
  387.                 (cond ((equal a 1) nil)
  388.                       (t (pfactor1 a)))))))))
  389.  
  390.  
  391. (DEFUN FFACTOR (L FN &AUX (ALPHA ALPHA))
  392. ;  (declare (special varlist))        ;i suppose...
  393.   (PROG (Q)
  394.     (COND ((AND (NULL $FACTORFLAG) (MNUMP L)) (RETURN L))
  395.           ((OR (ATOM L) ALGFAC* MODULUS) NIL)
  396.           ((AND (NOT GAUSS)(MEMQ 'IRREDUCIBLE (CDAR L)))(RETURN L))
  397.           ((AND GAUSS (MEMQ 'IRREDUCIBLEG (CDAR L))) (RETURN L))
  398.           ((AND (NOT GAUSS)(MEMQ 'FACTORED (CDAR L)))(RETURN L))
  399.           ((AND GAUSS (MEMQ 'GFACTORED (CDAR L))) (RETURN L)))
  400.     (NEWVAR L)
  401.     (IF ALGFAC* (SETQ VARLIST (CONS ALPHA (zl-REMOVE ALPHA VARLIST))))
  402.     (SETQ Q (RATREP* L))
  403.     (WHEN ALGFAC*
  404.           (SETQ ALPHA (CADR (RATREP* ALPHA)))
  405.           (SETQ MINPOLY* (SUBST (CAR (LAST GENVAR))
  406.                     (CAR MINPOLY*)
  407.                     MINPOLY*)))
  408.     (MAPC #'(LAMBDA (Y Z) (PUTPROP Y Z (QUOTE DISREP)))
  409.           GENVAR
  410.           VARLIST)         
  411.     (RETURN (RETFACTOR (CDR Q) FN L))))
  412.      
  413. (DEFUN FACTOROUT1 (L P)
  414.        (do ((gv genvar (cdr gv))
  415.         (dl l (cdr dl))
  416.         (ans))
  417.        ((null dl) (list ans p))
  418.        (cond ((zerop (car dl)))
  419.          (t (setq ans (cons (pget (car gv)) (cons (car dl) ans))
  420.               p (pquotient p (list (car gv) (car dl) 1)))))))
  421.  
  422. (DEFUN FACTOROUT (P)
  423.        (COND ((AND (PCOEFP (PTERM (CDR P) 0))
  424.            (NOT (ZEROP (PTERM (CDR P) 0))))
  425.           (LIST NIL P))
  426.          (T (FACTOROUT1 (PMINDEGVEC P) P))))
  427.  
  428. (DEFMFUN PFACTOR (P &aux ($ALGEBRAIC ALGFAC*))
  429.        (COND ((PCOEFP P) (CFACTOR P))
  430.          ($RATFAC (PFACPROD P))
  431.          (T (SETQ P (FACTOROUT P))
  432.         (COND ((EQUAL (CADR P) 1) (CAR P))
  433.               ((NUMBERP (CADR P)) (APPEND (CFACTOR (CADR P)) (CAR P)))
  434.               (T ((LAMBDA (CONT)
  435.                     (NCONC
  436.                  (COND ((EQUAL (CAR CONT) 1) NIL)
  437.                    (ALGFAC*
  438.                     (COND (MODULUS (LIST (CAR CONT) 1))
  439.                       ((EQUAL (CAR CONT) '(1 . 1)) NIL)
  440.                       ((EQUAL (CDAR CONT) 1)
  441.                        (LIST (CAAR CONT) 1))
  442.                       (T (LIST (CAAR CONT) 1 (CDAR CONT) -1))))
  443.                    (T (CFACTOR (CAR CONT))))
  444.                  (PFACTOR11 (PSQFR (CADR CONT)))
  445.                  (CAR P)))
  446.               (COND (MODULUS (LIST (LEADALGCOEF (CADR P))
  447.                            (MONIZE (CADR P))))
  448.                 (ALGFAC* (ALGCONTENT (CADR P)))
  449.                 (T (PCONTENT (CADR P))))))))))
  450.      
  451. (DEFUN PFACTOR11 (P)
  452.   (COND ((NULL P) NIL)
  453.     ((NUMBERP (CAR P))
  454.      (CONS (CAR P) (CONS (CADR P) (PFACTOR11 (CDDR P)))))
  455.     (T (LET* ((ADN* 1)
  456.           (F (PFACTOR1 (CAR P))))
  457.          (NCONC (IF (EQUAL ADN* 1) NIL
  458.                 (LIST ADN* (f- (CADR P))))
  459.             (DO ((L F (CDR L))
  460.                  (ANS NIL (CONS (CAR L) (CONS (CADR P) ANS))))
  461.                 ((NULL L) ANS))
  462.             (PFACTOR11 (CDDR P)))))))
  463.  
  464. (DEFUN PFACTOR1 (P)                        ;ASSUMES P SQFR
  465.   (PROG (FACTORS *IRREDS *CHECKAGAIN)
  466.     (COND ((DONTFACTOR (CAR P)) (RETURN (LIST P)))
  467.           ((ONEVARP P)
  468.            (COND ((SETQ FACTORS (FACTXN+-1 P))
  469.               (IF (AND (NOT MODULUS)
  470.                    (OR GAUSS (NOT ALGFAC*)))
  471.               (SETQ *IRREDS FACTORS
  472.                 FACTORS NIL))
  473.               (GO OUT))
  474.              ((AND (NOT ALGFAC*) (NOT MODULUS)
  475.                (NOT (EQUAL (CADR P) 2.)) (ESTCHECK (CDR P)))
  476.               (RETURN (LIST P))))))
  477.     (AND (SETQ FACTORS (PFACTORLIN P (PDEGREEVECTOR P)))
  478.          (RETURN FACTORS))
  479.     (SETQ FACTORS(IF (OR ALGFAC* MODULUS) (LIST P) ;SQRT(NUM. CONT OF DISC)
  480.              (PFACTORQUAD P)))
  481.     (COND ((NULL FACTORS)(GO OUT)))
  482.     (WHEN CHECKFACTORS
  483.           (SETQ FACTORS (HEURTRIAL FACTORS CHECKFACTORS))
  484.           (SETQ *CHECKAGAIN (CDR FACTORS)))
  485.     OUT (RETURN (NCONC *IRREDS (MAPCAN (FUNCTION PFACTORANY) FACTORS)))))
  486.  
  487. (DEFMVAR $HOMOG_HACK NIL) ; If T tries to eliminate homogeneous vars.
  488.  
  489. (DECLARE-top (SPECIAL *HVAR *HMAT)
  490.      (*LEXPR HREDUCE HEXPAND))
  491.  
  492. (DEFUN PFACTORANY (P)
  493.        (COND (*CHECKAGAIN (LET (CHECKFACTORS) (PFACTOR1 P)))
  494.          ((AND $HOMOG_HACK (NOT ALGFAC*) (NOT (ONEVARP P)))
  495.           (LET ($HOMOG_HACK *HVAR *HMAT)
  496.         (MAPCAR #'HEXPAND (PFACTOR (HREDUCE P)))))
  497.          ($BERLEFACT (FACTOR1972 P))
  498.          (T (PKRONECK P))))
  499.  
  500.  
  501. (DEFUN RETFACTOR (X FN L &AUX (A (RATFACT X FN)))
  502.   (PROG ()
  503.    B    (COND ((NULL (CDDR A))
  504.            (SETQ A (RETFACTOR1 (CAR A) (CADR A)))
  505.            (RETURN (COND ((AND SCANMAPP (NOT (ATOM A)) (NOT (ATOM L))
  506.                    (EQ (CAAR A) (CAAR L)))
  507.                   (TAGIRR L))
  508.                  (T A))))
  509.           ((EQUAL (CAR A) 1) (SETQ A (CDDR A)) (GO B))
  510.           (T (SETQ A (MAP2C #'RETFACTOR1 A))
  511.          (RETURN (COND ((MEMQ 0 A) 0)
  512.                    (T (SETQ A (LET (($EXPOP 0) ($EXPON 0)
  513.                                $NEGDISTRIB)
  514.                         (MULN (SORTGREAT A) T)))
  515.                   (COND ((NOT (MTIMESP A)) A)
  516.                     (T (CONS '(MTIMES SIMP FACTORED)
  517.                          (CDR A)))))))))))
  518.  
  519. ;;; FOR LISTS OF ARBITRARY EXPRESSIONS
  520. (DEFUN RETFACTOR1 (P E)
  521.   (POWER (TAGIRR (SIMPLIFY (PDISREP P))) E))
  522.  
  523. (DEFUN TAGIRR (X)
  524.        (COND ((OR (ATOM X) (MEMQ 'IRREDUCIBLE (CDAR X))) X)
  525.          (T (CONS (APPEND (CAR X) '(IRREDUCIBLE)) (CDR X)))))
  526.  
  527. (DEFUN REVSIGN (X)
  528.        (COND ((NULL X) NIL)
  529.          (T (CONS (CAR X)
  530.               (CONS (MINUS (CADR X)) (REVSIGN (CDDR X)))))))
  531.      
  532. ;    THIS IS THE END OF THE NEW RATIONAL FUNCTION PACKAGE PART 4
  533.  
  534.  
  535. ;(DECLARE (UNSPECIAL ALPHA GAUSS GENVAR *MIN* *MX* *ODR* NN* LOW* ADN*))
  536.