;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     The data in this file contains enhancments.                    ;;;;;
;;;                                                                    ;;;;;
;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
;;;     All rights reserved                                            ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "MAXIMA")
(macsyma-module rat3d)

(DECLARE-top (GENPREFIX A_4))


(LOAD-MACSYMA-MACROS RATMAC)


;	THIS IS THE NEW RATIONAL FUNCTION PACKAGE PART 4.
;	IT INCLUDES THE POLYNOMIAL FACTORING ROUTINES.

(DECLARE-top (SPECIAL *MIN* *MX* *ODR* NN* SCANMAPP *CHECKAGAIN ADN*))

(declare-top (special $factorflag $intfaclim $dontfactor $algebraic $ratfac)
	 (special errrjfflag)
	 )

;There really do seem to be two such variables...
(declare-top (special alpha *alpha)
	 (special gauss genvar minpoly*))

(DEFMVAR *IRREDS NIL)
(DEFMVAR ALGFAC* NIL)
(DEFMVAR LOW* NIL)

(DEFMVAR $INTFACLIM 1000.)
(DEFMVAR $BERLEFACT T)


;; Do not remove the following function -- it is needed for non-PDP10 Macsymas
;; On PDP10s, the function is hand coded in RAT;RATLAP >.

#-PDP10
(DEFMFUN CFACTOR (X)
  (PROG (DIVISOR TT ANS K)
	(COND ((NULL $FACTORFLAG) (RETURN (LIST X 1)))
	      ((FLOATP X)
	       (ERRRJF "FACTOR given floating arg"))
	      ((PZEROP X) (RETURN (LIST (PZERO) 1)))
	      ((EQN X -1) (RETURN (LIST -1 1)))
	      ((MINUSP X)
	       (RETURN (CONS -1 (CONS 1 (CFACTOR (MINUS X))))))
	      ((LESSP X 2) (RETURN (LIST X 1))))
        (cond ((fixnump x) (return (fixnum-cfactor x))))
	(SETQ K 2 DIVISOR 2)
	SETT (SETQ TT 0)
	LOOP (COND ((ZEROP (REMAINDER X DIVISOR))
		    (SETQ TT (ADD1 TT))
		    (SETQ X (QUOTIENT X DIVISOR))
		    (GO LOOP)))
	(COND ((GREATERP TT 0)
	       (SETQ ANS (CONS DIVISOR (CONS TT ANS)))))
	(COND ((EQUAL DIVISOR 2) (SETQ DIVISOR 3))
	      ((EQUAL DIVISOR 3) (SETQ DIVISOR 5))
	      (T (SETQ DIVISOR (PLUS DIVISOR K))
		 (COND ((EQL K 2) (SETQ K 4)) (T (SETQ K 2)))))
	(COND ((OR (AND $INTFACLIM (GREATERP DIVISOR $INTFACLIM))
		   (GREATERP (TIMES DIVISOR DIVISOR) X))
	       (RETURN (COND ((GREATERP X 1)
			      (CONS X (CONS 1 ANS)))
			     (T ANS)))))
	(GO SETT)))

(DEFMFUN fixnum-CFACTOR (X)
	(declare (fixnum x))
  (PROG ((DIVISOR 2)  (TT 0)  (K 2) ans)
	(declare (fixnum divisor tt  k))
	SETT (SETQ TT 0)
	LOOP (COND ((f= 0 (fixnum-remainder X DIVISOR))
		    (SETQ TT (f+ 1 TT))
		    (SETQ X (the fixnum (quot  X DIVISOR)))
		    (GO LOOP)))
	(COND ((> TT 0)
	       (SETQ ANS (CONS DIVISOR (CONS TT ANS)))))
	(COND ((f= DIVISOR 2) (SETQ DIVISOR 3))
	      ((f= DIVISOR 3) (SETQ DIVISOR 5))
	      (T (SETQ DIVISOR (f+ DIVISOR K))
		 (COND ((f= K 2) (SETQ K 4)) (T (SETQ K 2)))))
	(COND ((OR (AND $INTFACLIM (f> DIVISOR $INTFACLIM))
		   (f> (f* DIVISOR DIVISOR) X))
	       (RETURN (COND ((f> X 1)
			      (CONS X (CONS 1 ANS)))
			     (T ANS)))))
	(GO SETT)))

;;;****** END OF FUNCTION WHICH IS ONLY COMMENTED OUT IF THERE IS A LAP ******


(DEFMFUN LISTOVARS (Q)
  (COND ((PCOEFP Q) NIL)
	(t (let ((ans nil))
	     (declare (special ans))
	     (listovars0 q)))))

(DEFUN LISTOVARS0 (Q)
  (declare (special ans))
  (COND ((PCOEFP Q) ANS)
	((MEMQ (CAR Q) ANS) (LISTOVARS1 (CDR Q)))
	(T (PUSH (CAR Q) ANS)
	   (LISTOVARS1 (CDR Q)))))

(DEFUN LISTOVARS1 (QL)
  (declare (special ans))
  (COND ((NULL QL) ANS)
	(T (LISTOVARS0 (CADR QL)) (LISTOVARS1 (CDDR QL)))))

(DEFUN DONTFACTOR (Y)
       (COND ((OR (NULL $DONTFACTOR) (EQUAL $DONTFACTOR '((MLIST)))) NIL)
	     ((MEMALIKE (PDIS (MAKE-POLY Y)) $DONTFACTOR) T)))

(DEFUN REMOVEALG (L)
       (sloop for var in l
	     unless (algv var) collect var))

(DEFUN DEGVECDISREP (DEGL)
       (DO ((L DEGL (CDR L))
	    (GV GENVAR (CDR GV))
	    (ANS 1))
	   ((NULL L) ANS)
	   (AND (f> (CAR L) 0)
		(SETQ ANS (LIST (CAR GV) (CAR L) ANS)))))

(DEFUN PTERMCONT (P)
       (LET ((TCONT (DEGVECDISREP (PMINDEGVEC P)))
	     ($ALGEBRAIC))
	    (LIST TCONT (PQUOTIENT P TCONT))))

(DEFUN PMINDEGVEC (P)
       (MINLIST (LET ((*ODR* (PUTODR (REVERSE GENVAR)))
		      (NN* (f1+ (LENGTH GENVAR)))
		      (*MIN* T))
		     (DEGVECTOR NIL 1 P))))

(DEFUN PDEGREEVECTOR (P)
       (MAXLIST (LET ((*ODR* (PUTODR (REVERSE GENVAR)))
		      (NN* (f1+ (LENGTH GENVAR)))
		      (*MX* T))
		     (DEGVECTOR NIL 1 P))))

(DEFUN MAXLIST(L) (MAXMINL L T))

(DEFUN MINLIST(L) (MAXMINL L NIL))

(DEFUN MAXMINL (L SWITCH)
       (DO ((L1 (COPY1 (CAR L)))
	    (LL (CDR L) (CDR LL)))
	   ((NULL LL) L1)
	   (DO ((V1 L1 (CDR V1))
		(V2 (CAR LL) (CDR V2)))
	       ((NULL V1))
	       (COND (SWITCH
 		        (COND ((f> (CAR V2) (CAR V1))
			       (RPLACA V1 (CAR V2)))))
		     (T (COND ((f< (CAR V2) (CAR V1))
			       (RPLACA V1 (CAR V2)))))))))

(DEFUN NZEROS (N L) (DO ((J N (f1- J))
			 (L L (CONS 0 L)))
			((= 0 J) L)))

(DEFUN QUICK-SQFR-CHECK (P VAR)
  (LET ((GV (zl-DELETE VAR (LISTOVARS P)))
	(MODULUS (OR MODULUS *ALPHA))
	(L) (P0))
    (IF $ALGEBRAIC (SETQ GV (REMOVEALG GV)))
    (AND GV
	 (NOT (PZEROP (PCSUBSTY (SETQ L (RAND (LENGTH GV) MODULUS))
				GV (PMOD (P-LC P)))))
	 (NOT (PCOEFP (SETQ P0 (PCSUBSTY L GV (PMOD P)))))
	 (PCOEFP (PGCD P0 (PDERIVATIVE P0 (CAR P0))))
	 (LIST L GV P0))))
	 
(DEFUN MONOM->FACL (P)
       (COND ((PCOEFP P) (IF (EQUAL P 1) NIL (LIST P 1)))
	     (T (LIST* (PGET (CAR P)) (CADR P) (MONOM->FACL (CADDR P))))))

(DEFUN PSQFR (P)
      (PROG (R VARL VAR MULT FACTORS)
      (COND ((PCOEFP P) (RETURN (CFACTOR P)))
	    ((PMINUSP P) (RETURN (CONS -1 (CONS 1 (PSQFR (PMINUS P)))))))
      (DESETQ (FACTORS P) (PTERMCONT P))
      (SETQ FACTORS (MONOM->FACL FACTORS))
      (COND ((PCOEFP P) (GO END)))
      (SETQ VARL (SORT (LISTOVARS P) 'POINTERGP))
  SETVAR
      (SETQ VAR (CAR VARL) VARL (CDR VARL) MULT 0)
      (COND ((POINTERGP VAR (CAR P)) (GO NEXTVAR))
	    ((DONTFACTOR VAR)
	     (SETQ FACTORS (CONS P (CONS 1 FACTORS))
		   P 1)
	      (GO END)))
      (COND ((QUICK-SQFR-CHECK P VAR)   ;QUICK SQFR CHECK BY SUBST.
	      (SETQ R (OLDCONTENT P))
	      (SETQ P (CAR R) FACTORS (CONS (CADR R)
					    (CONS 1 FACTORS)))
	      (GO NEXTVAR)))
    (SETQ R (PDERIVATIVE P VAR))
    (COND ((PZEROP R) (GO NEXTVAR)))
    (COND ((AND MODULUS (NOT (PCOEFP R))) (PMONICIZE (CDR R))))
    (SETQ P (PGCDCOFACTS P R))
    (AND ALGFAC* (CADDDR P) (SETQ ADN* (PTIMES ADN* (CADDDR P))))
    (SETQ R (CADR P)              ; PRODUCT OF P[I]
	  P (CAR P))
  A (SETQ R (PGCDCOFACTS R P)
	  P (CADDR R)
	  MULT (f1+ MULT))
    (AND ALGFAC* (CADDDR R) (SETQ ADN* (PTIMES ADN* (CADDDR R)))) 
    (COND ((NOT (PCOEFP (CADR R)))
	   (SETQ FACTORS
	     (CONS (CADR R)
		   (CONS MULT FACTORS)))))
    (COND ((NOT (PCOEFP (SETQ R (CAR R)))) (GO A)))
  NEXTVAR
       (COND ((PCOEFP P) (GO END))
	     (VARL (GO SETVAR))
	     (MODULUS (SETQ FACTORS (APPEND (FIXMULT (PSQFR (PMODROOT P))
						     MODULUS)
					    FACTORS))
		      (SETQ P 1)))
  END  (SETQ P (COND ((EQUAL 1 P) NIL)
		     (T (CFACTOR P))))
       (RETURN (APPEND P FACTORS))))

(DEFUN FIXMULT (L N)
       (DO ((L L (CDDR L))) ((NULL L)) (RPLACA (CDR L) (f* N (CADR L))))
       L)

(DEFUN PMODROOT (P)
       (COND ((PCOEFP P) P)
	     ((ALG P) (PEXPT P (EXPT MODULUS (f1- (CAR (ALG P))))))
	     (T (CONS (CAR P) (PMODROOT1 (CDR P))))))

(DEFUN PMODROOT1 (X)
       (COND ((NULL X) X)
	     (T (CONS (// (CAR X) MODULUS)
		      (CONS (PMODROOT (CADR X))
			    (PMODROOT1 (CDDR X)))))))

(DEFMVAR $SAVEFACTORS NIL "If t factors of ratreped forms will be saved")

(DEFVAR CHECKFACTORS () "List of saved factors")

(DEFUN SAVEFACTORS (L)
  (WHEN $SAVEFACTORS
	(SAVEFACTOR1 (CAR L))
	(SAVEFACTOR1 (CDR L)))
  L)

(DEFUN SAVEFACTOR1 (P)
  (UNLESS (OR (PCOEFP P)
	      (PTZEROP (P-RED P))
	      (zl-MEMBER P CHECKFACTORS))
	  (PUSH P CHECKFACTORS)))

(DEFUN HEURTRIAL1 (POLY FACS)
       (PROG (H J)
	     (SETQ H (PDEGREEVECTOR POLY))
	     (COND ((OR (zl-MEMBER 1 H) (zl-MEMBER 2 H)) (RETURN (LIST POLY))))
	     (COND ((NULL FACS) (RETURN (LIST POLY))))
	     (SETQ H (PGCD POLY (CAR FACS)))
	     (RETURN (COND ((PCOEFP H) (HEURTRIAL1 POLY (CDR FACS)))
			   ((PCOEFP (SETQ J (PQUOTIENT POLY H)))
			    (HEURTRIAL1 POLY (CDR FACS)))
			   (T (HEURTRIAL (LIST H J) (CDR FACS)))))))

(DEFUN HEURTRIAL (X FACS)
       (COND ((NULL X) NIL)
	     (T (NCONC (HEURTRIAL1 (CAR X) FACS)
		       (HEURTRIAL (CDR X) FACS)))))


(DEFUN PFACTORQUAD (P)
       (PROG (A B C D $DONTFACTOR L V)
	     (COND((OR (ONEVARP P)(EQUAL MODULUS 2))(RETURN (LIST P))))
	     (SETQ L (PDEGREEVECTOR P))
	     (COND ((NOT (zl-MEMBER 2 L)) (RETURN (LIST P))))
	     (SETQ L (NREVERSE L) V (REVERSE GENVAR))	;FIND MOST MAIN VAR
	LOOP (COND ((EQN (CAR L) 2) (SETQ V (CAR V)))
		   (T (SETQ L (CDR L)) (SETQ V (CDR V)) (GO LOOP)))
	     (DESETQ (A . C) (BOTHPRODCOEF (MAKE-POLY V 2 1) P))
	     (DESETQ (B . C) (BOTHPRODCOEF (MAKE-POLY V 1 1) C))
	     (SETQ D (PGCD (PGCD A B) C))
 	     (COND ((PCOEFP D) NIL)
		   (T (SETQ *IRREDS (NCONC *IRREDS (PFACTOR1 D)))
		      (RETURN (PFACTORQUAD (PQUOTIENT P D)))))
	     (SETQ D (PPLUS (PEXPT B 2) (PTIMES -4 (PTIMES A C))))
	     (RETURN
	      (COND ((SETQ C (PNTHROOTP D 2))
		     (SETQ D (RATREDUCE (PPLUS B C) (PTIMES 2 A)))
		     (SETQ D (PABS (PPLUS (PTIMES (MAKE-POLY V) (CDR D))
					  (CAR D))))
		     (SETQ *IRREDS (NCONC *IRREDS (LIST D (PQUOTIENT P D))))
		     NIL)
		    (MODULUS (LIST P))    ;NEED TO TAKE SQRT(INT. MOD P) LCF.
		    (T (SETQ *IRREDS (NCONC *IRREDS (LIST P)))NIL)))))

(DEFMFUN $ISQRT (X) ($INRT X 2))

(DEFMFUN $INRT (X N)
       (COND ((NOT (INTEGERP (SETQ X (MRATCHECK X))))
	      (COND ((EQUAL N 2) (LIST '($ISQRT) X)) (T (LIST '($INRT) X N))))
	     ((ZEROP X) X)
	     ((NOT (INTEGERP (SETQ N (MRATCHECK N)))) (LIST '($INRT) X N))
	     (T (car (iroot (ABS X) N)))))

(defun iroot (a n) ; computes a^(1/n)  see Fitch, SIGSAM Bull Nov 74
  (cond ((f< (haulong a) n) (list 1 (sub1 a)))
	(t  ;assumes integer a>0 n>=2
	 (do ((x (expt 2 (f1+ (quotient (haulong a) n)))
		 (difference x (quotient (plus n1 bk) n)))
	      (n1 (f1- n)) (xn) (bk))
	     (nil)
	   (cond ((signp le (setq bk (*dif x (*quo a (setq xn (expt x n1))))))
		  (return (list x (difference a (times x xn))))))))))

(DEFMFUN $NTHROOT(P N)
       (cond ((Setq n (PNTHROOTP (CADR ($RAT P)) N)) (pdis n))
	     (T (merror "Not an nth power"))))

(DEFUN PNTHROOTP (P N)
       (LET ((ERRRJFFLAG T))
	    (CATCH 'RATERR (PNTHROOT P N))))

;(defun pnthroot (poly n)
;   (cond ((pcoefp poly) (cnthroot poly n))
;	 (t (let* ((var (p-var poly))
;		   (ans (make-poly var (cquotient (p-le poly) n)
;				   (pnthroot (p-lc poly) n)))
;		   (ae (p-terms (pquotient (pctimes n (leadterm poly)) ans))))
;		  (do ((p (psimp var (p-red poly))
;			  (pdifference poly (pexpt ans n))))
;		      ((pzerop p) ans)
;		      (cond ((or (pcoefp p) (not (eq (p-var p) var))
;				 (f> (car ae) (p-le p)))
;			     (throw 'raterr nil)))
;		      (setq ans (nconc ans (pquotient1 (cdr (leadterm p)) ae)))
;		      )))))
;New version from F302 --gsb
(defun pnthroot (poly n)
   (cond ((equal n 1) poly)
	 ((pcoefp poly) (cnthroot poly n))
	 (t (let* ((var (p-var poly))
		   (ans (make-poly var (cquotient (p-le poly) n)
				   (pnthroot (p-lc poly) n)))
		   (ae (p-terms (pquotient (pctimes n (leadterm poly)) ans))))
		  (do ((p (psimp var (p-red poly))
			  (pdifference poly (pexpt ans n))))
		      ((pzerop p) ans)
		      (cond ((or (pcoefp p) (not (eq (p-var p) var))
				 (f> (car ae) (p-le p)))
			     (throw 'raterr nil)))
		      (setq ans (nconc ans (pquotient1 (cdr (leadterm p)) ae)))
		      )))))

(DEFUN CNTHROOT(C N)
       (COND ((MINUSP C)
	      (COND ((ODDP N) (MINUS (cnthroot (MINUS C) N)))
		    (T (throw 'raterr nil))))
	     ((zerop c) c)
	     ((zerop (cadr (setq c (iroot C N)))) (car c))
	     (t (throw 'raterr nil))))


(DEFMFUN PABS (X) (COND ((PMINUSP X) (PMINUS X)) (T X)))

(DEFUN PFACTORLIN (P L)
       (do ((degl l (cdr degl))
	    (v genvar (cdr v))
	    (a)(b))
	   ((null degl) nil)
	   (cond ((and (= (car degl) 1)
		       (not (algv (car v))))
		  (desetq (a . b) (bothprodcoef (make-poly (car v)) p))
		  (setq a (pgcd a b))
		  (return (cons (pquotientchk p a)
				(cond ((equal a 1) nil)
				      (t (pfactor1 a)))))))))


(DEFUN FFACTOR (L FN &AUX (ALPHA ALPHA))
;  (declare (special varlist))		;i suppose...
  (PROG (Q)
	(COND ((AND (NULL $FACTORFLAG) (MNUMP L)) (RETURN L))
	      ((OR (ATOM L) ALGFAC* MODULUS) NIL)
	      ((AND (NOT GAUSS)(MEMQ 'IRREDUCIBLE (CDAR L)))(RETURN L))
	      ((AND GAUSS (MEMQ 'IRREDUCIBLEG (CDAR L))) (RETURN L))
	      ((AND (NOT GAUSS)(MEMQ 'FACTORED (CDAR L)))(RETURN L))
	      ((AND GAUSS (MEMQ 'GFACTORED (CDAR L))) (RETURN L)))
	(NEWVAR L)
	(IF ALGFAC* (SETQ VARLIST (CONS ALPHA (zl-REMOVE ALPHA VARLIST))))
	(SETQ Q (RATREP* L))
	(WHEN ALGFAC*
	      (SETQ ALPHA (CADR (RATREP* ALPHA)))
	      (SETQ MINPOLY* (SUBST (CAR (LAST GENVAR))
				    (CAR MINPOLY*)
				    MINPOLY*)))
	(MAPC #'(LAMBDA (Y Z) (PUTPROP Y Z (QUOTE DISREP)))
	      GENVAR
	      VARLIST)		 
	(RETURN (RETFACTOR (CDR Q) FN L))))
	 
(DEFUN FACTOROUT1 (L P)
       (do ((gv genvar (cdr gv))
	    (dl l (cdr dl))
	    (ans))
	   ((null dl) (list ans p))
	   (cond ((zerop (car dl)))
		 (t (setq ans (cons (pget (car gv)) (cons (car dl) ans))
			  p (pquotient p (list (car gv) (car dl) 1)))))))

(DEFUN FACTOROUT (P)
       (COND ((AND (PCOEFP (PTERM (CDR P) 0))
		   (NOT (ZEROP (PTERM (CDR P) 0))))
	      (LIST NIL P))
	     (T (FACTOROUT1 (PMINDEGVEC P) P))))

(DEFMFUN PFACTOR (P &aux ($ALGEBRAIC ALGFAC*))
       (COND ((PCOEFP P) (CFACTOR P))
	     ($RATFAC (PFACPROD P))
	     (T (SETQ P (FACTOROUT P))
		(COND ((EQUAL (CADR P) 1) (CAR P))
		      ((NUMBERP (CADR P)) (APPEND (CFACTOR (CADR P)) (CAR P)))
		      (T ((LAMBDA (CONT)
		            (NCONC
			     (COND ((EQUAL (CAR CONT) 1) NIL)
				   (ALGFAC*
				    (COND (MODULUS (LIST (CAR CONT) 1))
					  ((EQUAL (CAR CONT) '(1 . 1)) NIL)
					  ((EQUAL (CDAR CONT) 1)
					   (LIST (CAAR CONT) 1))
					  (T (LIST (CAAR CONT) 1 (CDAR CONT) -1))))
				   (T (CFACTOR (CAR CONT))))
			     (PFACTOR11 (PSQFR (CADR CONT)))
			     (CAR P)))
			  (COND (MODULUS (LIST (LEADALGCOEF (CADR P))
					       (MONIZE (CADR P))))
				(ALGFAC* (ALGCONTENT (CADR P)))
				(T (PCONTENT (CADR P))))))))))
	 
(DEFUN PFACTOR11 (P)
  (COND ((NULL P) NIL)
	((NUMBERP (CAR P))
	 (CONS (CAR P) (CONS (CADR P) (PFACTOR11 (CDDR P)))))
	(T (LET* ((ADN* 1)
		  (F (PFACTOR1 (CAR P))))
		 (NCONC (IF (EQUAL ADN* 1) NIL
			    (LIST ADN* (f- (CADR P))))
			(DO ((L F (CDR L))
			     (ANS NIL (CONS (CAR L) (CONS (CADR P) ANS))))
			    ((NULL L) ANS))
			(PFACTOR11 (CDDR P)))))))

(DEFUN PFACTOR1 (P)						;ASSUMES P SQFR
  (PROG (FACTORS *IRREDS *CHECKAGAIN)
	(COND ((DONTFACTOR (CAR P)) (RETURN (LIST P)))
	      ((ONEVARP P)
	       (COND ((SETQ FACTORS (FACTXN+-1 P))
		      (IF (AND (NOT MODULUS)
			       (OR GAUSS (NOT ALGFAC*)))
			  (SETQ *IRREDS FACTORS
				FACTORS NIL))
		      (GO OUT))
		     ((AND (NOT ALGFAC*) (NOT MODULUS)
			   (NOT (EQUAL (CADR P) 2.)) (ESTCHECK (CDR P)))
		      (RETURN (LIST P))))))
	(AND (SETQ FACTORS (PFACTORLIN P (PDEGREEVECTOR P)))
	     (RETURN FACTORS))
	(SETQ FACTORS(IF (OR ALGFAC* MODULUS) (LIST P) ;SQRT(NUM. CONT OF DISC)
			 (PFACTORQUAD P)))
	(COND ((NULL FACTORS)(GO OUT)))
	(WHEN CHECKFACTORS
	      (SETQ FACTORS (HEURTRIAL FACTORS CHECKFACTORS))
	      (SETQ *CHECKAGAIN (CDR FACTORS)))
	OUT (RETURN (NCONC *IRREDS (MAPCAN (FUNCTION PFACTORANY) FACTORS)))))

(DEFMVAR $HOMOG_HACK NIL) ; If T tries to eliminate homogeneous vars.

(DECLARE-top (SPECIAL *HVAR *HMAT)
	 (*LEXPR HREDUCE HEXPAND))

(DEFUN PFACTORANY (P)
       (COND (*CHECKAGAIN (LET (CHECKFACTORS) (PFACTOR1 P)))
	     ((AND $HOMOG_HACK (NOT ALGFAC*) (NOT (ONEVARP P)))
	      (LET ($HOMOG_HACK *HVAR *HMAT)
		(MAPCAR #'HEXPAND (PFACTOR (HREDUCE P)))))
	     ($BERLEFACT (FACTOR1972 P))
	     (T (PKRONECK P))))


(DEFUN RETFACTOR (X FN L &AUX (A (RATFACT X FN)))
  (PROG ()
   B    (COND ((NULL (CDDR A))
	       (SETQ A (RETFACTOR1 (CAR A) (CADR A)))
	       (RETURN (COND ((AND SCANMAPP (NOT (ATOM A)) (NOT (ATOM L))
				   (EQ (CAAR A) (CAAR L)))
			      (TAGIRR L))
			     (T A))))
	      ((EQUAL (CAR A) 1) (SETQ A (CDDR A)) (GO B))
	      (T (SETQ A (MAP2C #'RETFACTOR1 A))
		 (RETURN (COND ((MEMQ 0 A) 0)
			       (T (SETQ A (LET (($EXPOP 0) ($EXPON 0)
							   $NEGDISTRIB)
					    (MULN (SORTGREAT A) T)))
				  (COND ((NOT (MTIMESP A)) A)
					(T (CONS '(MTIMES SIMP FACTORED)
						 (CDR A)))))))))))

;;; FOR LISTS OF ARBITRARY EXPRESSIONS
(DEFUN RETFACTOR1 (P E)
  (POWER (TAGIRR (SIMPLIFY (PDISREP P))) E))

(DEFUN TAGIRR (X)
       (COND ((OR (ATOM X) (MEMQ 'IRREDUCIBLE (CDAR X))) X)
	     (T (CONS (APPEND (CAR X) '(IRREDUCIBLE)) (CDR X)))))

(DEFUN REVSIGN (X)
       (COND ((NULL X) NIL)
	     (T (CONS (CAR X)
		      (CONS (MINUS (CADR X)) (REVSIGN (CDDR X)))))))
	 
;	THIS IS THE END OF THE NEW RATIONAL FUNCTION PACKAGE PART 4


;(DECLARE (UNSPECIAL ALPHA GAUSS GENVAR *MIN* *MX* *ODR* NN* LOW* ADN*))