;;; -*-  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 ezgcd)

(DECLARE-TOP(SPECIAL VARLIST GENVAR LCPROD SVALS SVARS OLDSVARS OLDSVALS
		  VALFLAG $GCD PL0 D0 DEGD0 SUBVAR SUBVAL VAR
		  MANY*  TEMPPRIME OVARLIST VALIST MODULUS KLIM
		  ZL *PRIME PLIM NN* NE NN*-1 BLIST1 DLP *ALPHA
		  EZ1SKIP SVALSL NSVALS ERRRJFFLAG $ALGEBRAIC
		  LC1 OLDLC DF1 DF2 RES LIMK *AB* *ALPHA
		  *SHARPA *SHARPB FACT1 FACT2 HMODULUS $RATFAC)
	 (*EXPR ITH)
	 (GENPREFIX EZG))

(LOAD-MACSYMA-MACROS RATMAC)

(DEFUN EZGCD2 (F G) (PROG (ALLVARS)
       (SETQ ALLVARS (UNION* (LISTOVARS F) (LISTOVARS G)))
       (COND ((GREATERP 2 (LENGTH ALLVARS)) 
              (SETQ ALLVARS (NEWGCD F G MODULUS))
              (COND ((CDR ALLVARS) (RETURN ALLVARS))
                    (T (RETURN (LIST (SETQ ALLVARS (CAR ALLVARS))
                                     (PQUOTIENT F ALLVARS)
                                     (PQUOTIENT G ALLVARS)))))))
       (SETQ ALLVARS (SORT ALLVARS 'POINTERGP))
       (RETURN (EZGCD (LIST F G) ALLVARS MODULUS))
))

(DEFUN NEWGCDCALL (P Q) (CAR (NEWGCD P Q MODULUS)))

(DEFUN GCDL (PL)
       (DO ((D (CAR PL) (PGCD D (CAR L)))
	    (L (CDR PL) (CDR L)))
	   ((OR (NULL L) (EQUAL D 1)) D)))

(DEFUN NEWGCDL (PL)
       (LET (($GCD '$MOD))
	    (GCDL PL)))

(DEFUN OLDGCDL (ELT PL)
       (LET (($GCD '$RED))
	    (GCDL (CONS ELT PL))))

(DEFUN OLDGCDCALL (PFL)
       (LET ((A (OLDGCDL (CAR PFL) (CDR PFL))))
	    (CONS A (MAPCAR (FUNCTION (LAMBDA (H) (PQUOTIENT H A))) PFL))))

(DEFUN NON0RAND (MODULUS)
       (DO ((R)) ((NOT (ZEROP (SETQ R (CMOD (RANDOM 1000))))) R)))

(DECLARE-TOP(SPECIAL TEMPPRIME))

(DEFUN GETGOODVALS (VARL LCP)
  (MAPCAR #'(LAMBDA (V) (DO ((VAL 0 (NON0RAND TEMPPRIME)) (TEMP))
			   ((NOT (PZEROP (SETQ TEMP (PCSUBSTY VAL V LCP))))
			    (SETQ LCP TEMP) VAL)))
	  VARL))

(DEFUN EVMAP (VALS PL)
       (PROG (PL0 D0)
	     (COND ((EQUAL NSVALS (LENGTH SVALSL)) (RETURN NIL)))
	     (COND (VALFLAG (GO NEWVALS)))
	     (SETQ VALS (GETGOODVALS SVARS LCPROD))
	AGAIN(COND ((zl-MEMBER VALS SVALSL)
		    (SETQ VALS (RAND (LENGTH SVARS) TEMPPRIME))
		    (GO AGAIN)))
	     (SETQ VALFLAG T SVALSL (CONS VALS SVALSL))
	     (GO END)
	NEWVALS
	     (SETQ PL0 (RAND (LENGTH SVARS) TEMPPRIME))
	     (COND ((zl-MEMBER PL0 SVALSL) (GO NEWVALS))
		   (T (SETQ VALS PL0 SVALSL (CONS VALS SVALSL))))
	     (COND ((EQUAL 0. (PCSUB LCPROD VALS SVARS))
		    (COND ((EQUAL NSVALS (LENGTH SVALSL))
			   (RETURN NIL))
			  (T (GO NEWVALS)))))
;	     END  (GETD0 PL(SETQ VALS(SUBST 1. 0.  VALS))) WHAT WAS SUBST FOR?
	END  (GETD0 PL VALS)
	     (RETURN (LIST VALS PL0 D0))))

(DEFUN DEGODR (A B) (COND ((NUMBERP A) NIL)
			  ((NUMBERP B) T)
			  (T (GREATERP (CADR A) (CADR B)))))

(DEFUN EVTILDEGLESS (PL)
       (PROG (EVOUT NPL0 ND0 NDEG)
	AGAIN(SETQ EVOUT (EVMAP SVALS PL))
	     (COND (EVOUT (SETQ NPL0 (CADR EVOUT) ND0 (CADDR EVOUT)))
		   (T (RETURN NIL)))
	     (COND ((NUMBERP ND0) (SETQ NDEG 0.)) (T (SETQ NDEG (CADR ND0))))
	     (COND ((OR (EQUAL DEGD0 NDEG) (GREATERP NDEG DEGD0)) (GO AGAIN)))
	     (RETURN (SETQ DEGD0 NDEG PL0 NPL0 D0 ND0 SVALS (CAR EVOUT)))))

(DEFUN PTIMESMERGE (PL1 PL2)
       (COND (PL1 (CONS (PTIMES (CAR PL1) (CAR PL2)) 
			  (PTIMESMERGE (CDR PL1) (CDR PL2))))
	     (T NIL)))

;(DEFUN RESTORELCZ (P INVLC LC)
;  (LET ((VAR) (DEG))
;       (COND ((EQUAL 1 INVLC)
;	      (SETQ P (PMOD (OLDREP P)))
;	      (SETQ VAR (CAR P)))
;	     (T (SETQ VAR (CAR P))
;		(SETQ DEG (CADR P))
;		(SETQ P (PTIMES INVLC (PSIMP VAR (CDDDR P))))
;		(SETQ P (PPLUS (LIST VAR DEG LC)
;			       (PMOD (OLDREP (DROPTERMS P)))))))
;       (LET ((MODULUS))
;	    (CADR (FASTCONT P)))))

;(DEFUN RPLALC (POLY NEWLC)
;       (APPEND (LIST (CAR POLY) (CADR POLY) NEWLC) (CDDDR POLY)))


;(DEFUN EZ1 (POLY FACT1 FACT2) 
;   (PROG (RES HSTEPS STEPS KTERM A B C D *AB* M DF1 DF2 DLR STEP *SHARPA *SHARPB) 
;      (LET ((MODULUS) (HMODULUS))
;	   (SETQMODULUS *PRIME)
;	   (SETQ *SHARPB (FACT20 FACT1 FACT2 LIMK)))
;      (SETQ *SHARPA (CAR *SHARPB))
;      (SETQ *SHARPB (CADR *SHARPB))
;      (SETQ *AB* (LIST (LIST 0 *SHARPA *SHARPB)))
;      (SETQ STEPS (APPLY 'MAX (MAPCAR (FUNCTION MULTIDEG) (CDR (ODDELM POLY)))))
;      (SETQ HSTEPS (QUOTIENT STEPS 2.))
;      (SETQ STEP 0)
;      (SETQ DF1 (RPLALC FACT1 (PMOD (NEWREP LC1))))
;      (SETQ DF2 (RPLALC FACT2 (PMOD (NEWREP OLDLC))))
;      (SETQ RES (PDIFFERENCE (PTIMES DF1 DF2) (PMOD POLY)))
;      (SETQ POLY NIL)
; LOOP (COND ((EQUAL RES 0) (GO OUT))) 
;   BK (SETQ STEP (ADD1 STEP)) 
;      (COND ((GREATERP STEP STEPS) (GO OUT))) 
;      (COND ((EQ (CAR RES) VAR)(SETQ C (CDR RES)))
;	    (T (SETQ C (LIST 0 RES))))
;      (SETQ A 0 B 0)
;NEXTM (COND ((NULL C)(Z2 A B STEP HSTEPS)(GO LOOP)))
;      (SETQ M (CAR C))
;      (SETQ DLR (CADR C))
;      (SETQ C (CDDR C))
;      (SETQ KTERM (KTERMS DLR STEP))
;      (SETQ DLR NIL)
;      (COND ((EQUAL 0 KTERM) (GO NEXTM))) 
;      (SETQ D (OBTAINABM M))
;      (SETQ B (PPLUS B (PTIMES (CAR D) KTERM)))
;      (SETQ A (PPLUS A (PTIMES (CADR D) KTERM)))
;      (SETQ KTERM NIL)
;      (GO NEXTM)
;  OUT (RETURN (LIST DF1 DF2)))) 

(DEFUN EZ1CALL (BUILDER FACTRS LC1 VALIST OVARLIST)
       (PROG (*PRIME PLIM NN* NE NN*-1 ZL ZFACTR OLDLC LCD0
	      BLIST1 DLP LIMK GENVAR SUBVAR SUBVAL MULT)
	     (SETQ OLDLC (CADDR BUILDER))
	     (COND ((NOT (EQUAL 1 LC1)) 
		    (SETQ BUILDER (PTIMES BUILDER LC1))))
	     (SETQ GENVAR (APPEND OVARLIST (LIST (CAR BUILDER))))
	     (COND (MODULUS
		    (SETQ *PRIME MODULUS PLIM MODULUS LIMK -1)
		    (GO MOD))
		   (T (SETQ *PRIME (MAX (NORM BUILDER)
			       (MAXCOEFFICIENT (CAR FACTRS))
			       (MAXCOEFFICIENT (CADR FACTRS))))))
	     (COND ((GREATERP *PRIME *ALPHA) 
		    (PROG (NEWMODULUS) 
			  (SETQ NEWMODULUS (TIMES *ALPHA *ALPHA)
				LIMK 0)
		     AGAIN(COND ((GREATERP NEWMODULUS *PRIME) 
				 (SETQ *PRIME *ALPHA PLIM NEWMODULUS))
				(T (SETQ LIMK (ADD1 LIMK) NEWMODULUS (TIMES NEWMODULUS NEWMODULUS))
				   (GO AGAIN)))))
		   (T (SETQ LIMK -1 *PRIME *ALPHA PLIM *ALPHA)))
	MOD  (SETQ NN* (ADD1 (SETQ NE (SETQ NN*-1 (LENGTH OVARLIST)))))
	     (SETQ ZL (COMPLETEVECTOR NIL 1 NN* 0))
	     (FIXVL VALIST OVARLIST)
	     (COND ((EQUAL 1 LC1)
		    (SETQ MODULUS PLIM BUILDER (NEWREP BUILDER))
       		    (SETQ DLP #+NIL (sloop for x in (cdr (oddelm builder))
					  maximize (multideg x))
			      #-NIL (APPLY 'MAX
					   (MAPCAR (FUNCTION MULTIDEG) 
						   (CDR (ODDELM BUILDER)))))
		    (SETQ ZFACTR (Z1 BUILDER (CAR FACTRS)(CADR FACTRS)))
		    (SETQ ZFACTR (RESTORELC ZFACTR (CADDR BUILDER)))
		    (RETURN (OLDREP(CADR ZFACTR)))))
	     (SETQ MODULUS PLIM LCD0 (CADDAR FACTRS))
	     (SETQ MULT (CTIMES (PCSUB LC1 SVALS SVARS)
				(CRECIP LCD0)))
	     (SETQ FACTRS (LIST (PTIMES MULT (CAR FACTRS))
				(PTIMES LCD0 (CADR FACTRS))))
	     (SETQ BUILDER (NEWREP BUILDER))
	     (SETQ DLP #+NIL (sloop for x in (cdr (oddelm builder))
				   maximize (multideg x))
		       #-NIL (APPLY 'MAX (MAPCAR (FUNCTION MULTIDEG) 
						 (CDR (ODDELM BUILDER)))))
	     (SETQ ZFACTR (Z1 BUILDER (CAR FACTRS) (CADR FACTRS)))
	     (SETQ ZFACTR (PMOD (OLDREP (CAR ZFACTR))))
	     (RETURN (CADR ((LAMBDA (MODULUS) (FASTCONT ZFACTR)) NIL)))))

(DEFUN GETD0 (TPL TVALS) (PROG (C)
       (SETQ D0 (PCSUB (CAR TPL) TVALS SVARS) 
	     PL0 (LIST D0) TPL (CDR TPL))
  LOOP (COND ((NULL TPL) (RETURN D0)))
       (SETQ C (PCSUB (CAR TPL) TVALS SVARS)
	     D0 (NEWGCDCALL D0 C))
       (COND ((NUMBERP D0) (RETURN (SETQ D0 1))))
       (SETQ PL0 (APPEND PL0 (LIST C)) TPL (CDR TPL))
       (GO LOOP)))

(DEFUN NUMBERINLISTP (L)
       (DO ((L L (CDR L))) ((NULL L))
	   (AND (NUMBERP (CAR L)) (RETURN (CAR L)))))

(DEFUN EZGCD (PFL VL MODULUS)
       (PROG (SVARS SVALS VALFLAG TEMPPRIME PFCONTL CONTGCD CONTCOFACTL
		    PL NSVARS NSVALS SVALSL LCPROD GCDLCS LCPL EVMAPOUT
		    PL0 D0 D DEGD0 DEGD0N D0N PL0N TEMP TRYAGAIN COFACT0
		    PCOFACTL ITH BUILDER VAR TERMCONT TCONTL $ALGEBRAIC)
	     (COND ((SETQ TEMP (NUMBERINLISTP PFL))
		    (COND ((OR (zl-MEMBER 1 PFL)(zl-MEMBER -1 PFL))
			   (RETURN (CONS 1 PFL))))
		    (SETQ TEMP (OLDGCDL TEMP (zl-REMOVE TEMP PFL))
			  PL (MAPCAR (FUNCTION (LAMBDA(H) (PQUOTIENT H TEMP))) PFL))
		    (RETURN (CONS TEMP PL))))
	     (SETQ SVARS (CDR VL) VAR (CAR VL))
	     (COND (SVARS (SETQ MANY* T))
		   (T (RETURN (CONS (SETQ D (NEWGCDL PFL))
					(MAPCAR (FUNCTION (LAMBDA(H) (PQUOTIENT H D))) PFL)))))
	     (COND (MODULUS (SETQ TEMPPRIME MODULUS))
		   (T (SETQ TEMPPRIME 13.)))
	     (SETQ TCONTL (MAPCAR (FUNCTION PTERMCONT) PFL)
		   PFL (MAPCAR (FUNCTION CADR) TCONTL)
		   TCONTL (MAPCAR (FUNCTION CAR) TCONTL))
	     (SETQ TERMCONT (OLDGCDCALL TCONTL)
		   TCONTL (CDR TERMCONT)
		   TERMCONT (CAR TERMCONT))
	     (COND ((SETQ TEMP (NUMBERINLISTP PFL))
		    (SETQ D (OLDGCDL TEMP (zl-REMOVE TEMP PFL))
			  PCOFACTL
			  (MAPCAR (FUNCTION (LAMBDA(H) (PQUOTIENT H D))) PFL))
		    (SETQ CONTGCD TERMCONT CONTCOFACTL TCONTL)
		    (GO OUT)))
	     (SETQ PFCONTL 
		   (MAPCAR (FUNCTION (LAMBDA(H) 
			   (COND ((EQ VAR (CAR H)) (FASTCONT H))
				 (T (LIST H 1)))))
			   PFL))
	     (SETQ PFL
		   (MAPCAR (FUNCTION CADR) PFCONTL)
		   PFCONTL
		   (MAPCAR (FUNCTION CAR) PFCONTL))
	     (SETQ CONTGCD (EZGCD PFCONTL SVARS MODULUS) PFCONTL NIL
		   CONTCOFACTL (PTIMESMERGE TCONTL (CDR CONTGCD))
		   CONTGCD (PTIMES TERMCONT (CAR CONTGCD)))
	     (COND ((NUMBERINLISTP PFL)
		    (SETQ D 1. PCOFACTL PFL)(GO OUT)))
	     (SETQ TEMP (LISTOVARSL PFL))
	     (COND ((SETQ TEMP (INTERSECT SVARS TEMP)) NIL)
		   (T (SETQ D (NEWGCDL PFL)) (GO END)))
	     (SETQ PL (BBSORT PFL (QUOTE DEGODR)))
	     (SETQ NSVARS (LENGTH SVARS))
	     (DO ((I NSVARS (SUB1 I))) ((ZEROP I)) (SETQ SVALS (CONS 0. SVALS)))
	     (SETQ LCPROD 1 SVALSL (LIST SVALS) 
		   NSVALS (EXPT TEMPPRIME (LENGTH SVARS)))
	     (DO ((L
		 (MAPCAR (FUNCTION CADDR) PL)
		 (CDR L)))
		 ((NULL L))
		 (SETQ LCPROD (PTIMES LCPROD (CAR L))))
	     (COND ((EQUAL 0. (PCSUB LCPROD SVALS SVARS))
		    (SETQ EVMAPOUT (EVMAP SVALS PL))
		    (COND (EVMAPOUT (SETQ SVALS (CAR EVMAPOUT)
					  PL0 (CADR EVMAPOUT)
					  D0 (CADDR EVMAPOUT)))
			  (T (DESETQ (D . PCOFACTL) (OLDGCDCALL PFL))
			     (GO OUT))))
		   (T (SETQ VALFLAG T) (GETD0 PL SVALS)))
	     (COND ((NUMBERP D0) (SETQ DEGD0 0))
		   (T (SETQ DEGD0 (CADR D0))))
	TESTD0
	     (COND ((EQUAL 1. D0) (SETQ D 1.) 
		    (SETQ D 1. PCOFACTL PFL) (GO OUT)))
	     (COND (DEGD0N (GO TESTCOFACT)))
	ANOTHERSVALS
	     (SETQ EVMAPOUT (EVMAP SVALS PL))
	     (COND (EVMAPOUT (SETQ PL0N (CADR EVMAPOUT)
				   D0N (CADDR EVMAPOUT)
				   EVMAPOUT (CAR EVMAPOUT)))
		   (T (DESETQ (D . PCOFACTL) (OLDGCDCALL PFL))
		      (GO OUT)))
	     (COND ((NUMBERP D0N) (SETQ DEGD0N 0.))
		   (T (SETQ DEGD0N (CADR D0N))))
	     (COND ((GREATERP DEGD0 DEGD0N)
		    (SETQ DEGD0 DEGD0N PL0 PL0N D0 D0N SVALS EVMAPOUT)
		    (GO ANOTHERSVALS)))
	     (COND ((EQUAL DEGD0 DEGD0N) (GO TESTD0)) (T (GO ANOTHERSVALS)))
	TESTCOFACT
	     (COND ((EQUAL DEGD0 (CADAR PL0)) NIL) (T (GO TESTGCD)))
	     (SETQ D (CAR PL) TEMP PFL PCOFACTL NIL)
	LOOP (COND (TEMP (SETQ D0N (EZTESTDIVIDE (CAR TEMP) D))) 
		   (T (SETQ EZ1SKIP T) (GO OUT)))
	     (COND (D0N (SETQ PCOFACTL (APPEND PCOFACTL (LIST D0N)))
		    (SETQ TEMP (CDR TEMP)) (GO LOOP))
		   (T (COND ((EVTILDEGLESS PL)
			     (SETQ DEGD0N NIL) (GO TESTD0))
			    (T (DESETQ (D . PCOFACTL) (OLDGCDCALL PFL))
			       (GO OUT)))))
	TESTGCD
	     (SETQ ITH 1. TEMP PL0)
	NEXT (COND (TEMP NIL)   
		   (T (COND (TRYAGAIN  (SETQ D (NONSQFRCASE PFL VL)
					     PCOFACTL (CDR D)
					     D (CAR D))
				       (GO OUT))
			    (T (SETQ DEGD0 DEGD0N PL0 PL0N D0 D0N
				     DEGD0N NIL PL0N NIL D0N NIL
				     SVALS EVMAPOUT TRYAGAIN T)
			       (GO TESTGCD)))))
	     (SETQ COFACT0 (PQUOTIENT (CAR TEMP) D0))
	     (COND ((NUMBERP (NEWGCDCALL D0 COFACT0))
			(SETQ BUILDER (ITH PL ITH))
			(COND ((INTERSECT (LISTOVARS BUILDER) SVARS)
			       (GO CALLEZ1)))))
	     (SETQ TEMP (CDR TEMP) ITH (ADD1 ITH)) (GO NEXT)
	CALLEZ1
	     (SETQ LCPL (MAPCAR (FUNCTION CADDR) PL)
		   GCDLCS (CAR (EZGCD LCPL SVARS MODULUS))
		   LCPL NIL)
	     (SETQ D (EZ1CALL BUILDER 
				(LIST D0 COFACT0) GCDLCS
				(REVERSE SVALS)
				(REVERSE SVARS)))
	     (SETQ MODULUS NIL)
  	END  (SETQ PCOFACTL NIL TEMP PFL)
	     (COND ((PMINUSP D) (SETQ D (PMINUS D))))
	LOOP1(COND (TEMP (SETQ COFACT0 (EZTESTDIVIDE (CAR TEMP) D)))
		   (T (SETQ EZ1SKIP NIL) (GO OUT)))
	     (COND (COFACT0 (SETQ PCOFACTL (APPEND PCOFACTL (LIST COFACT0)))
			(SETQ TEMP (CDR TEMP)) (GO LOOP1))
		       (T (COND ((EVTILDEGLESS PL)
				 (SETQ DEGD0N NIL) (GO TESTD0))
				(T (DESETQ (D . PCOFACTL) (OLDGCDCALL PFL))
				   (GO OUT)))))
	OUT  (SETQ OLDSVARS SVARS OLDSVALS SVALS)
	     (RETURN (CONS (PTIMES CONTGCD D)
			   (PTIMESMERGE CONTCOFACTL PCOFACTL)))))

(DEFUN LISTOVARSL (PLIST) (PROG (ALLVARSL ALLVARS)
       (SETQ ALLVARSL (MAPCAR (FUNCTION LISTOVARS) PLIST))
       (SETQ ALLVARS (CAR ALLVARSL))
       (DO ((L (CDR ALLVARSL) (CDR L))) ((NULL L))
	   (SETQ ALLVARS (UNION* ALLVARS (CAR L))))
       (RETURN ALLVARS)))

(DEFMFUN $EZGCD NARGS
 (PROG (PFL ALLVARS PRESULT FLAG genvar DENOM PFL2)
       		;need if genvar doesn't shrink
       (IF (= NARGS 0) (WNA-ERR '$EZGCD))
       (DO ((I NARGS (f1- I))) ((= I 0)) (IF ($RATP (ARG I)) (RETURN (SETQ FLAG T))))
       (SETQ PFL (MAPCAR #'(LAMBDA (H) (CDR (RATF H))) (LISTIFY NARGS)))
       (SETQ PFL2 (LIST 1))
       (DO ((LCM (CDAR PFL))
	    (L (CDR PFL) (CDR L))
	    (COF1) (COF2))
	   ((NULL L) (SETQ DENOM LCM))
	   (DESETQ (LCM COF1 COF2) (PLCMCOFACTS LCM (CDAR L)))
	   (OR (EQUAL COF1 1)
	       (MAPCAR #'(LAMBDA (X) (PTIMES X COF1)) PFL2))
	   (PUSH COF2 PFL2))
       (SETQ PFL (MAPCAR #'CAR PFL))
       (SETQ ALLVARS (SORT (LISTOVARSL PFL) #'POINTERGP))
       (SETQ PRESULT
	     (COND ($RATFAC ((LAMBDA ($GCD) (FACMGCD PFL)) '$EZ))
		   (T (EZGCD PFL ALLVARS MODULUS))))
       (SETQ PRESULT (CONS (CONS (CAR PRESULT) DENOM)
			   (COND ((EQUAL DENOM 1) (CDR PRESULT))
				 (T (MAPCAR #'PTIMES (CDR PRESULT) PFL2)))))
       (SETQ PRESULT (CONS '(MLIST)
			   (CONS (RDIS* (CAR PRESULT))
				 (MAPCAR #'PDIS* (CDR PRESULT)))))
       (RETURN (IF FLAG PRESULT ($TOTALDISREP PRESULT)))))

(DEFUN INSRT (NTH ELT L)
       (COND ((EQUAL NTH 1) (CONS ELT L))
	     (T (CONS (CAR L) (INSRT (f1- NTH) ELT (CDR L))))))

(DEFUN NONSQFRCASE(PL VL)
       (PROG (D F PTR)
	     (DO ((DL PL (CDR DL))
		  (PT 1 (f1+ PT)))
		 ((INTERSECT (CDR VL) (LISTOVARS (CAR DL)))
		  (SETQ F (CAR DL) PTR PT)))
	     (SETQ D (EZGCD (LIST F (PDERIVATIVE F (CAR F))) VL MODULUS)
		   PL (EZGCD (CONS (CADR D) (zl-REMOVE F PL)) VL MODULUS)
		   PL (CONS (CAR PL) (CONS (CAR D) (CDDR PL)))
		   D (CAR PL))
       LOOP  (SETQ PL (EZGCD PL VL MODULUS))
	     (COND ((EQUAL 1 (CAR PL))
		    (RETURN (CONS D (INSRT PTR (PQUOTIENT F D) (CDDDR PL))))))
	     (SETQ D (PTIMES (CAR PL) D)
		   PL (CONS (CAR PL) (CDDR PL)))
	     (GO LOOP))) 

(DEFUN EZTESTDIVIDE (X Y)
       (LET ((ERRRJFFLAG T))
	    (COND ((OR (PCOEFP X) (PCOEFP Y)
		       (CATCH 'RATERR (PQUOTIENT (CAR (LAST X)) (CAR (LAST Y)))))
		   (CATCH 'RATERR (PQUOTIENT X Y))))))

(DEFUN NOTERMS (P)
       (COND ((PCOEFP P) 1)
	     (T (DO ((NT (NOTERMS (CADDR P)) (f+ NT (NOTERMS (CADR P))))
		     (P (CDDDR P) (CDDR P)))
		    ((NULL P) NT)))))

(DEFUN FASTCONT (P)
   (PROG (OLDGENVAR VAR TPPL TCONTL TCONT COEFVARL TEMP SMALL1 SMALL2 ANS MINUS?)
      (COND ((UNIVAR (CDR P)) (RETURN (OLDCONTENT P)))
	    (T (SETQ OLDGENVAR GENVAR)
	       (SETQ VAR (CAR P))
	       (SETQ GENVAR (zl-REMOVE VAR (INTERSECT (CDR GENVAR) (LISTOVARS P))))))
      (COND ((PMINUSP P) (SETQ P (PMINUS P) MINUS? T)))
      (SETQ TPPL (ODDELM (CDDR P)))
      (COND ((NULL (CDR TPPL))
	     (SETQ TCONT 1)
	     (SETQ ANS (CAR TPPL))
	     (GO OUT)))
      (SETQ TCONTL (MAPCAR (FUNCTION PMINDEGVEC) TPPL))
      (SETQ TPPL (MAPCAR (FUNCTION (LAMBDA(X Y) (PQUOTIENT X (DEGVECDISREP Y))))
			 TPPL TCONTL))
      (SETQ TCONT (CAR TCONTL))
      (DO ((L (CDR TCONTL) (CDR L))) ((NULL L))
	  (SETQ TCONT (MAPCAR (FUNCTION (LAMBDA (X Y) (MIN X Y)))
			      TCONT (CAR L))))
      (SETQ TCONTL NIL)
      (SETQ TCONT (DEGVECDISREP TCONT))
      (SETQ GENVAR OLDGENVAR)
      (COND ((SETQ TEMP (NUMBERINLISTP TPPL))
	     (COND ((OR (zl-MEMBER 1 TPPL)(zl-MEMBER -1 TPPL))
		    (SETQ ANS 1))
		   (T (SETQ ANS (OLDGCDL TEMP (zl-DELETE TEMP TPPL)))))
	     (GO OUT)))
      (COND ((GREATERP 4 (LENGTH TPPL))
	     (SETQ TPPL (BBSORT TPPL 
				(FUNCTION (LAMBDA(A B) (GREATERP (LENGTH A) (LENGTH B))))))
	     (GO SKIP)))
      (SETQ COEFVARL (MAPCAR (FUNCTION LISTOVARS) TPPL))
      (SETQ TEMP (CAR COEFVARL))
      (SETQ COEFVARL (CDR COEFVARL))
 LOOP (COND ((NULL COEFVARL) NIL)
	    (T (COND ((NULL (SETQ TEMP (INTERSECT TEMP (CAR COEFVARL)))) 
		      (SETQ ANS 1) (GO OUT))
		     (T (SETQ COEFVARL (CDR COEFVARL)) (GO LOOP)))))
      (SETQ TEMP (MAPCAR (FUNCTION NOTERMS) TPPL))
      (SETQ TPPL (MAPCAR (FUNCTION (LAMBDA (X Y) (LIST X Y)))
			 TEMP TPPL))
      (SETQ TPPL (BBSORT TPPL (QUOTE (LAMBDA(X Y) (GREATERP (CAR X) (CAR Y))))))
      (SETQ TPPL (MAPCAR (FUNCTION CADR) TPPL))
 SKIP (SETQ SMALL1 (CAR TPPL))
      (SETQ SMALL2 (CADR TPPL))
      (SETQ ANS (PGCD SMALL1 SMALL2))
      (COND ((EQUAL 1 ANS) (GO OUT))
	    ((EQUAL -1 ANS) (SETQ ANS 1) (GO OUT)))
      (COND ((CDDR TPPL) (SETQ ANS (CONS ANS (CDDR TPPL))))
	    (T (GO OUT)))
      (SETQ TEMP (SORT (LISTOVARSL ANS) (FUNCTION POINTERGP)))
      (SETQ ANS (CAR (EZGCD ANS TEMP MODULUS)))
  OUT (SETQ TCONT (PTIMES TCONT ANS))
      (SETQ P (PQUOTIENT P TCONT))
      (COND (MINUS? (SETQ TCONT (PMINUS TCONT))))
      (RETURN (LIST TCONT P))))

#-NIL
(DECLARE-TOP(UNSPECIAL LCPROD SVALS SVARS OLDSVARS OLDSVALS
		    VALFLAG PL0 D0 DEGD0 SUBVAR SUBVAL VAR
		    MANY* TEMPPRIME OVARLIST VALIST KLIM
		    ZL *PRIME PLIM NN* NE NN*-1 BLIST1 DLP
		    EZ1SKIP SVALSL NSVALS
		    LC1 OLDLC DF1 DF2 RES LIMK *AB*
		    *SHARPA *SHARPB FACT1 FACT2))