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 / rat3e.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  34.6 KB  |  1,131 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 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module rat3e)
  13.  
  14. ;;    This is the rational function package part 5.
  15. ;;    It includes the conversion and top-level routines used
  16. ;;    by the rest of the functions.
  17.  
  18. (DECLARE-TOP(*LEXPR OUTERMAP1 $DIVIDE $CONTENT $GCD $RAT $RATSIMP $FACTOR FACTOR)
  19.      (*EXPR $FLOAT)
  20.      (SPECIAL INTBS* ALFLAG VAR DOSIMP ALC $MYOPTIONS TRUNCLIST
  21.           VLIST SCANMAPP RADLIST EXPSUMSPLIT *RATSIMP* MPLC*
  22.           $RATSIMPEXPONS $EXPOP $EXPON $NEGDISTRIB $GCD))
  23.  
  24. (LOAD-MACSYMA-MACROS RZMAC RATMAC)
  25.  
  26. (DECLARE-TOP(GENPREFIX A_5))
  27.  
  28. (DEFMVAR GENVAR NIL
  29.      "List of gensyms used to point to kernels from within polynomials.
  30.      The values cell and property lists of these symbols are used to
  31.      store various information.")
  32. (DEFMVAR GENPAIRS NIL)
  33. (DEFMVAR VARLIST NIL "List of kernels")
  34. (DEFMVAR *FNEWVARSW NIL)
  35. (DEFMVAR *RATWEIGHTS NIL)
  36. (DEFVAR *RATSIMP* NIL)
  37. (DEFMVAR FACTORRESIMP NIL "If T resimplifies FACTOR(X-Y) to X-Y")
  38.  
  39. ;; User level global variables.
  40.  
  41. (DEFMVAR $KEEPFLOAT NIL
  42.      "If t floating point coeffs are not converted to rationals")
  43. (DEFMVAR $FACTORFLAG NIL "If t constant factor of polynomial is also factored")
  44. (DEFMVAR $DONTFACTOR '((MLIST)))
  45. (DEFMVAR $NOREPEAT T)
  46. (DEFMVAR $RATWEIGHTS '((MLIST SIMP)))
  47.  
  48. (DEFMVAR $RATFAC NIL "If t cre-forms are kept factored")
  49. (DEFMVAR $ALGEBRAIC NIL)
  50. (DEFMVAR $RATVARS '((MLIST SIMP)))
  51. (DEFMVAR $FACEXPAND T)
  52.  
  53. ;; Constants required for Franz
  54. #+Franz
  55. (progn 'compile
  56.    (defvar two30f    (expt 2.0 30.))
  57.    (defvar two30     (expt 2. 30.))
  58.    (defvar two53f    (expt 2.0 53.))
  59.    (defvar two53     (expt 2. 53.)))
  60.  
  61. (DECLARE-TOP(SPECIAL EVP $INFEVAL))
  62.  
  63. (DEFMFUN MRATEVAL (X)
  64.   (LET ((VARLIST (CADDAR X)))
  65.     (COND ((AND EVP $INFEVAL) (MEVAL ($RATDISREP X)))
  66.       ((OR EVP
  67.            (AND $FLOAT $KEEPFLOAT)
  68.            (NOT (ALIKE VARLIST (MAPCAR #'MEVAL VARLIST))))
  69.        (RATF (MEVAL ($RATDISREP X))))
  70.       (T X))))
  71.  
  72. ;(DEFPROP MRAT (LAMBDA (X) (MRATEVAL X)) MFEXPR*)
  73. (DEFPROP MRAT mrateval MFEXPR*)
  74.  
  75. (DEFMFUN $RATNUMER (X)
  76.  (SETQ X (TAYCHK2RAT X)) (CONS (CAR X) (CONS (CADR X) 1)))
  77.  
  78. (DEFMFUN $RATDENOM (X)
  79.  (SETQ X (TAYCHK2RAT X)) (CONS (CAR X) (CONS (CDDR X) 1)))
  80.  
  81. (DEFUN TAYCHK2RAT (X)
  82.  (COND ((AND ($RATP X) (MEMQ 'TRUNC (CDAR X))) ($TAYTORAT X)) (T (RATF X))))
  83.  
  84.  
  85. (DEFMVAR TELLRATLIST NIL)
  86.  
  87. (DEFUN TELLRATDISP (X)
  88.        (PDISREP+ (TRDISP1 (CDR X) (CAR X))))
  89.  
  90. (DEFUN TRDISP1 (P VAR)
  91.        (COND ((NULL P) NIL)
  92.          (T (CONS (PDISREP* (IF (MTIMESP (CADR P)) (COPY1 (CADR P))
  93.                     (CADR P))        ;prevents clobbering p
  94.                 (PDISREP! (CAR P) VAR))
  95.               (TRDISP1 (CDDR P) VAR)))))
  96.  
  97. (DEFMFUN $UNTELLRAT N
  98.   (DOLIST (X (LISTIFY N))
  99.       (IF (SETQ X (ASSOL X TELLRATLIST))
  100.           (SETQ TELLRATLIST (zl-REMOVE X TELLRATLIST))))
  101.   (CONS '(MLIST) (MAPCAR 'TELLRATDISP TELLRATLIST)))
  102.  
  103. #+cl
  104. (DEFMFUN $TELLRAT (&rest narg-rest-argument &aux
  105.              #+lispm (default-cons-area working-storage-area )
  106.              (narg (length narg-rest-argument)) n)
  107.     (setq n narg)
  108.   (DO ((I 1 (f1+ I))) ((f> I N)) (TELLRAT1 (narg-ARG I)))
  109.   (OR (= N 0) (ADD2LNC 'TELLRATLIST $MYOPTIONS))
  110.   (CONS '(MLIST) (MAPCAR 'TELLRATDISP TELLRATLIST)))
  111.  
  112. #-cl
  113. (DEFMFUN $TELLRAT N
  114.   (DO ((I 1 (f1+ I))) ((f> I N)) (TELLRAT1 (ARG I)))
  115.   (OR (= N 0) (ADD2LNC 'TELLRATLIST $MYOPTIONS))
  116.   (CONS '(MLIST) (MAPCAR 'TELLRATDISP TELLRATLIST)))
  117.  
  118. (DEFUN TELLRAT1 (X &AUX VARLIST GENVAR $ALGEBRAIC $RATFAC ALGVAR)
  119.   (SETQ X ($TOTALDISREP X))
  120.   (AND (NOT (ATOM X)) (EQ (CAAR X) 'MEQUAL)
  121.        (NEWVAR (CADR X)))
  122.   (NEWVAR (SETQ X (MEQHK X)))
  123.   (OR VARLIST (MERROR "Improper polynomial"))
  124.   (SETQ ALGVAR (CAR (LAST VARLIST)))
  125.   (SETQ X (P-TERMS (PRIMPART (CADR (RATREP* X)))))
  126.   (IF (NOT (EQUAL (PT-LC X) 1)) (MERROR "Minimal polynomial must be monic"))
  127.   (DO ((P (PT-RED X) (PT-RED P))) ((PTZEROP P)) (SETF (PT-LC P) (PDIS (PT-LC P))))
  128.   (SETQ ALGVAR (CONS ALGVAR X))
  129.   (IF (SETQ X (ASSOL (CAR ALGVAR) TELLRATLIST))
  130.       (SETQ TELLRATLIST (zl-REMOVE X TELLRATLIST)))
  131.   (PUSH ALGVAR TELLRATLIST))
  132.  
  133.  
  134. (DEFMFUN $PRINTVARLIST () (CONS '(MLIST) (COPY VARLIST)))
  135.  
  136. ;(DEFMFUN $SHOWRATVARS (E)
  137. ;  (CONS '(MLIST SIMP)
  138. ;    (IF ($RATP E) (CADDAR E)
  139. ;        (LET (VARLIST)
  140. ;          (LNEWVAR E) 
  141. ;          VARLIST))))
  142. ;Update from F302 --gsb
  143. (DEFMFUN $SHOWRATVARS (E)
  144.   (CONS '(MLIST SIMP)
  145.     (COND (($RATP E)
  146.            (IF (MEMQ 'TRUNC (CDAR E)) (SETQ E ($TAYTORAT E)))
  147.            (CADDAR (MINIMIZE-VARLIST E)))
  148.           (T (LET (VARLIST) (LNEWVAR E) VARLIST)))))
  149.  
  150. (DEFMFUN $RATVARS N
  151.   (ADD2LNC '$RATVARS $MYOPTIONS)
  152.   (SETQ $RATVARS
  153.     (CONS '(MLIST SIMP) (SETQ VARLIST (MAPFR1 (LISTIFY N) VARLIST)))))
  154.  
  155. (DEFUN MAPFR1 (L VARLIST) (MAPCAR #'(LAMBDA (Z) (FR1 Z VARLIST)) L))
  156.  
  157. (DEFMVAR INRATSIMP NIL)
  158.  
  159. (DEFMFUN $FULLRATSIMP N
  160.        (IF (= N 0) (WNA-ERR '$FULLRATSIMP))
  161.        (PROG (EXP EXP1 ARGL)
  162.          (SETQ EXP (ARG 1) ARGL (CDR (LISTIFY N)))
  163.     LOOP (SETQ EXP1 (SIMPLIFY (APPLY #'$RATSIMP (CONS EXP ARGL))))
  164.          (COND ((ALIKE1 EXP EXP1) (RETURN EXP)))
  165.          (SETQ EXP EXP1)
  166.          (GO LOOP)))
  167.  
  168. (DEFUN FULLRATSIMP (L)
  169.  (LET (($EXPOP 0) ($EXPON 0) (INRATSIMP T) $RATSIMPEXPONS)
  170.       (SETQ L ($TOTALDISREP L)) (FR1 L VARLIST))) 
  171.  
  172. (DEFMFUN $TOTALDISREP (L)
  173.   (COND ((ATOM L) L)
  174.     ((NOT (AMONG 'MRAT L)) L)
  175.     ((EQ (CAAR L) 'MRAT) (RATDISREP L))
  176.     (T (CONS (DELQ 'RATSIMP (CAR L)) (MAPCAR '$TOTALDISREP (CDR L))))))
  177.  
  178. ;;;VARLIST HAS MAIN VARIABLE AT END
  179.  
  180. (DEFUN JOINVARLIST (CDRL)
  181.        (MAPC #'(LAMBDA (Z) (IF (NOT (MEMALIKE Z VARLIST))
  182.                    (SETQ VARLIST (CONS Z VARLIST))))
  183.          (REVERSE (MAPFR1 CDRL NIL))))
  184.  
  185. (DEFMFUN $RAT N
  186.        (IF (f= N 0) (WNA-ERR '$RAT))
  187.        (COND ((f> N 1)
  188.           (LET (VARLIST) (JOINVARLIST (CDR (LISTIFY N)))
  189.                  (LNEWVAR (ARG 1))
  190.                  (RAT0 (ARG 1))))
  191.          (T (LNEWVAR (ARG 1)) (RAT0 (ARG 1)))))
  192.  
  193. (DEFUN RAT0 (EXP)                    ;SIMP FLAGS?
  194.   (IF (MBAGP EXP) (CONS (CAR EXP) (MAPCAR #'RAT0 (CDR EXP))) (RATF EXP)))
  195.  
  196. (DEFMFUN $RATSIMP N
  197.        (IF (f= N 0) (WNA-ERR '$RATSIMP))
  198.        (COND ((f> N 1)
  199.           (LET (VARLIST) (JOINVARLIST (CDR (LISTIFY N)))
  200.                  (FULLRATSIMP (ARG 1))))
  201.          (T (FULLRATSIMP (ARG 1)))))
  202.  
  203. ; $RATSIMP, $FULLRATSIMP, and $RAT are LEXPRs to allow for optional extra 
  204. ; arguments specifying the VARLIST.
  205.  
  206. ;;;PSQFR HAS NOT BEEN CHANGED TO MAKE USE OF THE SQFR FLAGS YET
  207.  
  208. (DEFMFUN $SQFR (X)
  209.  (LET ((VARLIST (CDR $RATVARS)) GENVAR $KEEPFLOAT $RATFAC)
  210.       (SUBLIS '((FACTORED . SQFRED) (IRREDUCIBLE . SQFR))
  211.           (FFACTOR X (FUNCTION PSQFR)))))
  212.  
  213. (DECLARE-TOP(SPECIAL FN CARGS))
  214.  
  215. (DEFUN WHICHFN (P)
  216.        (COND ((AND (MEXPTP P) (INTEGERP (CADDR P)))
  217.           (LIST '(MEXPT) (WHICHFN (CADR P)) (CADDR P)))
  218.          ((MTIMESP P)
  219.           (CONS '(MTIMES) (MAPCAR (FUNCTION WHICHFN) (CDR P))))
  220.          (FN (FFACTOR P (FUNCTION PFACTOR)))
  221.          (T (FACTORALG P))))
  222.  
  223. (DECLARE-TOP(SPECIAL VAR))
  224.  
  225. (DEFMVAR ADN* 1 "common denom for algebraic coefficients")
  226.  
  227. (DEFUN FACTORALG (P) 
  228.      (PROG (ALC ANS ADN* $GCD)
  229.            (SETQ $GCD '$ALGEBRAIC)
  230.            (COND((OR (ATOM P) (NUMBERP P))(RETURN P)))
  231.            (SETQ ADN* 1)
  232.            (COND ((AND (NOT $NALGFAC) (NOT INTBS*))
  233.               (SETQ INTBS* (FINDIBASE MINPOLY*))))
  234.            (SETQ ALGFAC* T)
  235.            (SETQ ANS (FFACTOR P (FUNCTION PFACTOR)))
  236.            (COND ((EQ (CAAR ANS) 'MPLUS)(RETURN P))
  237.              (MPLC* (SETQ ANS (ALBK ANS))))
  238.            (IF (AND (NOT ALC) (EQUAL  1 ADN*)) (RETURN ANS))
  239.            (SETQ ANS (PARTITION ANS (CAR (LAST VARLIST)) 1))
  240.            (RETURN (MUL (LET ((DOSIMP T))
  241.                   (MUL `((RAT) 1 ,ADN*)
  242.                     (CAR ANS)
  243.                     (IF ALC (PDIS ALC) 1)))
  244.                 (CDR ANS)))))
  245.  
  246. (DEFUN ALBK (P)                     ;to undo monicizing subst 
  247.   (let ((alpha (pdis alpha)) ($RATFAC T))
  248.     (declare (special alpha))
  249. ;      (sratsimp    ;; don't multiply them back out
  250.     (MAXIMA-SUBSTITUTE (list '(mtimes simp) mplc* alpha)    ;assumes mplc* is int
  251.                alpha p)))
  252.  
  253.  
  254. (DEFMFUN $GFACTOR (P &AUX (GAUSS T)) 
  255.   (IF ($RATP P) (SETQ P ($RATDISREP P)))
  256.   (SETQ P ($FACTOR (SUBST '%I '$%I P)
  257.            '((MPLUS) 1 ((MEXPT) %I 2))))
  258.   (SETQ P (SUBLIS '((FACTORED . GFACTORED)
  259.             (IRREDUCIBLE . IRREDUCIBLEG))
  260.           P))
  261.   (LET (($EXPOP 0) ($EXPON 0) $NEGDISTRIB) (MAXIMA-SUBSTITUTE '$%I '%I P)))
  262.  
  263.  
  264. ;; (DEFMFUN $FACTOR (EXP &OPTIONAL MINIMUM-POLYNOMIAL) ...)
  265.  
  266. (DEFMFUN $FACTOR NARGS
  267.   (UNLESS (OR (f= NARGS 1) (f= NARGS 2)) (WNA-ERR '$FACTOR))
  268.   (LET ($INTFACLIM (VARLIST (CDR $RATVARS)) GENVAR ANS)
  269.     (SETQ ANS (APPLY #'FACTOR (LISTIFY NARGS)))
  270.     (IF (AND FACTORRESIMP $NEGDISTRIB
  271.          (MTIMESP ANS) (NULL (CDDDR ANS))
  272.          (EQUAL (CADR ANS) -1) (MPLUSP (CADDR ANS)))
  273.     (LET (($EXPOP 0) ($EXPON 0)) ($MULTTHRU ANS))
  274.     ANS)))
  275.  
  276. #+cl (defvar alpha nil)
  277.  
  278. (DEFMFUN FACTOR NARGS
  279.   ((LAMBDA (TELLRATLIST VARLIST GENVAR $GCD $NEGDISTRIB)
  280.      (PROG (FN VAR MM* MPLC* INTBS* ALFLAG MINPOLY* ALPHA P ALGFAC* 
  281.         $KEEPFLOAT $ALGEBRAIC CARGS)
  282.        (OR (MEMQ $GCD *GCDL*) (SETQ $GCD (CAR *GCDL*)))
  283.        (LET  ($RATFAC)
  284.          (SETQ P (ARG 1) MM* 1 CARGS (CDR (LISTIFY NARGS)))
  285.          (AND (EQ (ml-typep P)  'symbol) (GO OUT))
  286.          (AND ($NUMBERP P) (GO NUM))
  287.          (COND ((MBAGP P)
  288.             (RETURN (CONS (CAR P)
  289.                   (MAPCAR #'(LAMBDA (X) (APPLY 'FACTOR (CONS X CARGS)))
  290.                       (CDR P))))))
  291.          (COND ((f= NARGS 2)
  292.             (SETQ ALPHA (MEQHK (ARG 2)))
  293.             (NEWVAR ALPHA)
  294.             (SETQ MINPOLY* (CADR (RATREP* ALPHA)))
  295.             (IF (OR (NOT (UNIVAR (CDR MINPOLY*)))
  296.                 (PCOEFP MINPOLY*)
  297.                 (f< (CADR MINPOLY*) 2))
  298.             (MERROR
  299.               "The second argument to FACTOR must be a non-linear, univariate polynomial:~%~M"
  300.               ALPHA))
  301.             (SETQ ALPHA (PDIS (LIST (CAR MINPOLY*) 1 1)) 
  302.               MM* (CADR MINPOLY*))
  303.             (COND ((NOT (EQUAL (CADDR MINPOLY*) 1))
  304.                (SETQ MPLC* (CADDR MINPOLY*))
  305.                (SETQ MINPOLY* (PMONZ MINPOLY*))
  306.                (SETQ P (MAXIMA-SUBSTITUTE (DIV ALPHA MPLC*) ALPHA P)) ))
  307.             (SETQ $ALGEBRAIC T)
  308.             ($TELLRAT(PDIS MINPOLY*))
  309.             (SETQ ALGFAC* T))
  310.            (T (SETQ FN T)))
  311.          (IF (NOT SCANMAPP) (SETQ P (LET (($RATFAC T)) (SRATSIMP P))))
  312.          (NEWVAR P)
  313.          (AND (EQ (ml-typep P)  'symbol) (GO OUT))
  314.          (COND ((NUMBERP P) (GO NUM)))
  315.          (SETQ $NEGDISTRIB NIL)
  316.          (SETQ P (LET ($FACTORFLAG ($RATEXPAND $FACEXPAND)) (WHICHFN P))))
  317.                                  
  318.        (SETQ P (LET (($EXPOP 0) ($EXPON 0)) (SIMPLIFY P)))
  319.        (COND ((MNUMP P) (RETURN (FACTORNUMBER P)))
  320.          ((ATOM P) (GO OUT)))
  321.        (AND $RATFAC (NOT $FACTORFLAG) ($RATP (ARG 1)) (RETURN ($RAT P)))
  322.        (AND $FACTORFLAG (MTIMESP P) (MNUMP (CADR P))
  323.         (SETQ ALPHA (FACTORNUMBER (CADR P)))
  324.         (COND ((ALIKE1 ALPHA (CADR P)))
  325.               ((MTIMESP ALPHA)
  326.                (SETQ P (CONS (CAR P) (APPEND (CDR ALPHA) (CDDR P)))))
  327.               (T (SETQ P (CONS (CAR P) (CONS ALPHA (CDDR P)))))))
  328.        (AND (NULL (MEMQ 'FACTORED (CAR P)))
  329.         (SETQ P (CONS (APPEND (CAR P) '(FACTORED)) (CDR P))))
  330.     OUT  (RETURN P)
  331.     NUM (RETURN (LET (($FACTORFLAG (NOT SCANMAPP))) (FACTORNUMBER P)))))
  332.    NIL VARLIST NIL $GCD $NEGDISTRIB))
  333.  
  334.  
  335. (DEFUN FACTORNUMBER (N)
  336.  (SETQ N (NRETFACTOR1 (NRATFACT (CDR ($RAT N)))))
  337.  (COND ((CDR N) (CONS '(MTIMES SIMP FACTORED)
  338.               (COND ((EQUAL (CAR N) -1)
  339.                  (CONS (CAR N) (NREVERSE (CDR N))))
  340.                 (T (NREVERSE N)))))
  341.        ((ATOM (CAR N)) (CAR N))
  342.        (T (CONS (CONS (CAAAR N) '(SIMP FACTORED)) (CDAR N)))))
  343.  
  344. (DEFUN NRATFACT (X)
  345.  (COND ((EQUAL (CDR X) 1) (CFACTOR (CAR X)))
  346.        ((EQUAL (CAR X) 1) (REVSIGN (CFACTOR (CDR X))))
  347.        (T (NCONC (CFACTOR (CAR X)) (REVSIGN (CFACTOR (CDR X)))))))
  348.  
  349. ;;; FOR LISTS OF JUST NUMBERS
  350. (DEFUN NRETFACTOR1 (L)
  351.   (COND ((NULL L) NIL)
  352.     ((EQUAL (CADR L) 1) (CONS (CAR L) (NRETFACTOR1 (CDDR L))))
  353.     (T (CONS (COND ((EQUAL (CADR L) -1)
  354.             (LIST '(RAT SIMP) 1 (CAR L)))
  355.                (T (LIST '(MEXPT SIMP) (CAR L) (CADR L))))
  356.          (NRETFACTOR1 (CDDR L))))))
  357.  
  358. (DECLARE-TOP(UNSPECIAL VAR))
  359.  
  360.  
  361. (DEFMFUN $MOD NARGS
  362.  (IF (NOT (OR (f= NARGS 1) (f= NARGS 2))) (WNA-ERR '$MOD))
  363.  (LET ((MODULUS MODULUS))
  364.       (COND ((f= NARGS 2)
  365.          (SETQ MODULUS (ARG 2))
  366.          (IF (OR (NOT (INTEGERP MODULUS)) (ZEROP MODULUS))
  367.          (MERROR "Improper value for MODULUS:~%~M" MODULUS))))
  368.       (IF (MINUSP MODULUS) (SETQ MODULUS (ABS MODULUS)))
  369.       (MOD1 (ARG 1))))
  370.  
  371. (DEFUN MOD1 (E)
  372.  (IF (MBAGP E) (CONS (CAR E) (MAPCAR 'MOD1 (CDR E)))
  373.      (LET (FORMFLAG)
  374.        (NEWVAR E)
  375.        (SETQ FORMFLAG ($RATP E) E (RATREP* E))
  376.        (SETQ E (CONS (CAR E) (RATREDUCE (PMOD (CADR E)) (PMOD (CDDR E)))))
  377.        (COND (FORMFLAG E) (T (RATDISREP E))))))
  378.  
  379. (DEFMFUN $DIVIDE NARGS
  380.   (PROG (X Y H VARLIST TT TY FORMFLAG $RATFAC)
  381.     (IF (f< NARGS 2) (MERROR "DIVIDE needs at least two arguments."))
  382.     (SETQ X (ARG 1))
  383.     (IF (AND ($RATP X) (SETQ FORMFLAG T) (INTEGERP (CADR X)) (EQUAL (CDDR X) 1))
  384.         (SETQ X (CADR X)))
  385.     (SETQ Y (ARG 2))
  386.     (IF (AND ($RATP Y) (SETQ FORMFLAG T) (INTEGERP (CADR Y)) (EQUAL (CDDR Y) 1))
  387.         (SETQ Y (CADR Y)))
  388.     (IF (AND (INTEGERP X) (INTEGERP Y))
  389.         (RETURN (LIST '(MLIST) (*QUO X Y) (REMAINDER X Y))))
  390.     (SETQ VARLIST (CDDR (LISTIFY NARGS)))
  391.     (MAPC #'NEWVAR (REVERSE (CDR $RATVARS)))
  392.     (NEWVAR Y)
  393.     (NEWVAR X)
  394.     (SETQ X (RATREP* X))
  395.     (SETQ H (CAR X))
  396.     (SETQ X (CDR X))
  397.     (SETQ Y (CDR (RATREP* Y)))
  398.     (COND ((AND (EQN (SETQ TT (CDR X)) 1) (EQN (CDR Y) 1)) 
  399.            (SETQ X (PDIVIDE (CAR X) (CAR Y))))
  400.           (T (SETQ TY (CDR Y))
  401.          (SETQ X (PTIMES (CAR X) (CDR Y)))
  402.          (SETQ X (PDIVIDE X (CAR Y))) 
  403.          (SETQ X (LIST
  404.               (RATQU (CAR X) TT)
  405.               (RATQU (CADR X) (PTIMES TT TY))))))
  406.     (SETQ H (LIST (QUOTE (MLIST)) (CONS H (CAR X)) (CONS H (CADR X))))
  407.     (RETURN (IF FORMFLAG H ($TOTALDISREP H)))))
  408.  
  409. (DEFMFUN $QUOTIENT NARGS (CADR (APPLY '$DIVIDE (LISTIFY NARGS))))
  410.  
  411. (DEFMFUN $REMAINDER NARGS (CADDR (APPLY '$DIVIDE (LISTIFY NARGS))))
  412.  
  413.  
  414. (DEFMFUN $GCD NARGS
  415.   (PROG (X Y H VARLIST GENVAR $KEEPFLOAT FORMFLAG)
  416.     (IF (f< NARGS 2) (MERROR "GCD needs 2 arguments"))
  417.     (SETQ FORMFLAG ($RATP (SETQ X (ARG 1))))
  418.     (SETQ Y (ARG 2))
  419.     (AND ($RATP Y) (SETQ FORMFLAG T))
  420.     (SETQ VARLIST (CDDR (LISTIFY NARGS)))
  421.     (DOLIST (V VARLIST) (IF (NUMBERP V) (IMPROPER-ARG-ERR V '$GCD)))
  422.     (NEWVAR X)
  423.     (NEWVAR Y)
  424.     (WHEN (AND ($RATP X) ($RATP Y) (EQUAL (CAR X) (CAR Y)))
  425.           (SETQ GENVAR (CAR (LAST (CAR X))) H (CAR X) X (CDR X) Y (CDR Y))
  426.           (GO ON))
  427.     (SETQ X (RATREP* X))
  428.     (SETQ H (CAR X))
  429.     (SETQ X (CDR X))
  430.     (SETQ Y (CDR (RATREP* Y)))
  431. ON    (SETQ X (CONS (PGCD (CAR X) (CAR Y)) (PLCM (CDR X) (CDR Y))))
  432.     (SETQ H (CONS H X))
  433.     (RETURN (IF FORMFLAG H (RATDISREP H)))))
  434.  
  435. (DEFMFUN $CONTENT NARGS
  436.     (PROG (X Y H VARLIST FORMFLAG)
  437.           (SETQ FORMFLAG ($RATP (SETQ X (ARG 1))))
  438.           (SETQ VARLIST (CDR (LISTIFY NARGS)))
  439.           (NEWVAR X)
  440.           (DESETQ (H X . Y) (RATREP* X))
  441.           (unless (atom x)
  442.         ;; (CAR X) => gensym corresponding to apparent main var.
  443.         ;; MAIN-GENVAR => gensym corresponding to the genuine main var.
  444.         (let ((main-genvar (nth (1- (length varlist)) genvar)))
  445.           (unless (eq (car x) main-genvar)
  446.             (setq x `(,main-genvar 0 ,x)))))
  447.           (SETQ X (RCONTENT X)
  448.             Y (CONS 1 Y))
  449.           (SETQ H (LIST '(MLIST)
  450.                 (CONS H (RATTIMES (CAR X) Y NIL))
  451.                 (CONS H (CADR X))))
  452.           (RETURN (IF FORMFLAG H ($TOTALDISREP H)))))
  453.  
  454. (DEFMFUN PGET (GEN) (CONS GEN '(1 1)))
  455.  
  456. (DEFUN M$EXP? (X) (AND (MEXPTP X) (EQ (CADR X) '$%E)))
  457.  
  458. (DEFUN ALGP ($X) (ALGPCHK $X NIL))
  459.  
  460. (DEFUN ALGPGET ($X) (ALGPCHK $X T))
  461.  
  462. (DEFUN ALGPCHK ($X MPFLAG &AUX TEMP)
  463.   (COND ((EQ $X '$%I) '(2 -1))
  464.     ((EQ $X '$%PHI) '(2 1 1 -1 0 -1))
  465.     ((RADFUNP $X NIL)
  466.      (IF (NOT MPFLAG) T
  467.        (LET ((R (PREP1 (CADR $X))))
  468.          (COND ((ONEP1 (CDR R))        ;INTEGRAL ALG. QUANT.?
  469.             (LIST (CADDR (CADDR $X))
  470.               (CAR R)))
  471.            (*RATSIMP* (SETQ RADLIST (CONS $X RADLIST)) NIL)))))
  472.     ((NOT $ALGEBRAIC) NIL)
  473.     ((AND (M$EXP? $X) (MTIMESP (SETQ TEMP (CADDR $X)))
  474.           (EQUAL (CDDR TEMP) '($%I $%PI))
  475.           (RATNUMP (SETQ TEMP (CADR TEMP))))
  476.      (IF MPFLAG (PRIMCYCLO (f* 2 (CADDR TEMP))) T))
  477.     ((NOT MPFLAG) (ASSOLIKE $X TELLRATLIST))
  478.     ((SETQ TEMP (COPY1 (ASSOLIKE $X TELLRATLIST)))
  479.      (DO ((P TEMP (CDDR P))) ((NULL P))
  480.          (RPLACA (CDR P) (CAR (PREP1 (CADR P)))))
  481.      (SETQ TEMP
  482.            (COND ((PTZEROP (PT-RED TEMP)) (LIST (PT-LE TEMP) (PZERO)))
  483.              ((ZEROP (PT-LE (PT-RED TEMP)))
  484.               (LIST (PT-LE TEMP) (PMINUS (PT-LC (PT-RED TEMP)))))
  485.              (T TEMP)))
  486.      (IF (AND (f= (PT-LE TEMP) 1) (SETQ $X (ASSOL $X GENPAIRS)))
  487.          (RPLACD $X (CONS (CADR TEMP) 1)))
  488.      TEMP)))
  489.  
  490. (DEFUN RADFUNP (X FUNCFLAG)    ;FUNCFLAG -> TEST FOR ALG FUNCTION NOT NUMBER
  491.        (COND ((ATOM X) NIL)
  492.          ((NOT (EQ (CAAR X) 'MEXPT)) NIL)
  493.          ((NOT (RATNUMP (CADDR X))) NIL)
  494.          (FUNCFLAG (NOT (NUMBERP (CADR X))))
  495.          (T T)))
  496.  
  497. (DEFMFUN RATSETUP (VL GL) (RATSETUP1 VL GL) (RATSETUP2 VL GL))
  498.  
  499. (DEFUN RATSETUP1 (VL GL)
  500.   (AND $RATWTLVL
  501.        (MAPC #'(LAMBDA (V G) 
  502.             (SETQ V (ASSOLIKE V *RATWEIGHTS))
  503.             (IF V (PUTPROP G V '$RATWEIGHT) (REMPROP G '$RATWEIGHT)))
  504.          VL GL)))
  505.  
  506. (DEFUN RATSETUP2 (VL GL)
  507.   (WHEN $ALGEBRAIC
  508.     (MAPC #'(LAMBDA (G) (REMPROP G 'ALGORD)) GL)
  509.     (MAPL #'(LAMBDA (V LG)
  510.         (COND ((SETQ V (ALGPGET (CAR V)))
  511.                (ALGORDSET V LG) (PUTPROP (CAR LG) V 'TELLRAT))
  512.               (T (REMPROP (CAR LG) 'TELLRAT))))
  513.          VL GL))
  514.   (AND $RATFAC (LET ($RATFAC)
  515.             (MAPC #'(LAMBDA (V G) 
  516.                  (IF (MPLUSP V)
  517.                  (PUTPROP G (CAR (PREP1 V)) 'UNHACKED)
  518.                  (REMPROP G 'UNHACKED)))
  519.               VL GL))))
  520.  
  521. (defun porder (p) (IF (pcoefp p) 0 (valget (car p))))
  522.  
  523. (defun algordset (x gl)
  524.        (do ((p x (cddr p))
  525.         (mv 0))
  526.        ((null p)
  527.         (do ((l gl (cdr l))) ((or (null l) (f> (valget (car l)) mv)))
  528.         (putprop (car l) t 'algord)))
  529.        (setq mv (max mv (porder (cadr p))))))
  530.  
  531.  
  532. #+cl
  533. (defun gensym-readable (name &aux #+lispm
  534.                  (default-cons-area working-storage-area ))
  535.   (cond ((symbolp name)(gensym (string-trim "$" (string name))))
  536.     (t  (setq name (aformat nil "~:M" name))
  537.         (cond (name (gensym name))
  538.           (t (gensym))))))
  539.  
  540. #+cl
  541. (defun orderpointer (l)
  542.   (sloop for v in l
  543.     for i below (f- (length l) (length genvar))
  544.     collecting  (gensym-readable v) into tem
  545.     finally (setq genvar (nconc tem genvar)) (return (prenumber genvar 1))))
  546. #-cl
  547. (DEFUN ORDERPOINTER (L)
  548.        (CREATSYM (f- (LENGTH L) (LENGTH GENVAR)))
  549.        (PRENUMBER GENVAR 1))
  550.  
  551. (DEFUN CREATSYM (N)
  552.   #+lispm (let ((default-cons-area working-storage-area))
  553.         (COND ((f> N 0) (SETQ GENVAR (CONS (GENSYM) GENVAR))
  554.            (CREATSYM (SUB1 N)))))
  555.   #-lispm   (COND ((f> N 0) (SETQ GENVAR (CONS (GENSYM) GENVAR))
  556.            (CREATSYM (SUB1 N)))))
  557.  
  558. (DEFUN PRENUMBER (V N)
  559.        (DO ((VL V (CDR VL))
  560.         (I N (f1+ I)))
  561.        ((NULL VL) NIL)
  562.        (SET (CAR VL) I)))
  563.  
  564. (DEFUN RGET (GENV)
  565.        (CONS (IF (AND $RATWTLVL
  566.               (OR (fixnump $ratwtlvl) 
  567.               (MERROR "Illegal value for RATWTLVL:~%~M" $RATWTLVL))
  568.               (f> (OR (GET GENV '$RATWEIGHT) -1) $RATWTLVL))
  569.          (PZERO)
  570.          (PGET GENV))
  571.          1))
  572.  
  573. (DEFMFUN RATREP (X VARL) (SETQ VARLIST VARL) (RATREP* X))
  574.  
  575. (DEFMFUN RATREP* (X) 
  576.        (LET (GENPAIRS)
  577.         (ORDERPOINTER VARLIST)
  578.         (RATSETUP1 VARLIST GENVAR)
  579.         (MAPC #'(LAMBDA (Y Z) (PUSH (CONS Y (RGET Z)) GENPAIRS))
  580.           VARLIST GENVAR)
  581.         (RATSETUP2 VARLIST GENVAR)
  582.         (XCONS (PREP1 X)                  ; PREP1 changes VARLIST
  583.            (LIST* 'MRAT 'SIMP VARLIST GENVAR  ;    when $RATFAC is T.
  584.               (IF (AND (NOT (ATOM X)) (MEMQ 'IRREDUCIBLE (CDAR X)))
  585.                   '(IRREDUCIBLE))))))
  586.  
  587. (DEFVAR *WITHINRATF* NIL)
  588.  
  589. (DEFMFUN RATF (L)
  590.  (PROG (U *WITHINRATF*)
  591.        (SETQ *WITHINRATF* T)
  592.        (WHEN (EQ '%% (CATCH 'RATF (NEWVAR L)))
  593.          (SETQ *WITHINRATF* NIL) (RETURN (SRF L)))
  594.        (SETQ U (CATCH 'RATF (RATREP* L)))  ; for truncation routines
  595.        (RETURN (OR U (PROG2 (SETQ *WITHINRATF* NIL) (SRF L))))))
  596.  
  597.  
  598. (DEFUN PREP1 (X &AUX TEMP) 
  599.        (COND ((FLOATP X)
  600.           (COND ($KEEPFLOAT (CONS X 1.0)) ((PREPFLOAT X))))
  601.          ((INTEGERP X) (CONS (CMOD X) 1))
  602.          #+cl ((rationalp x)
  603.               (cond ((null modulus)(cons  (numerator x) (denominator x)))
  604.                 (t (cquotient (numerator x) (denominator x)))))
  605.          ((ATOM X)(COND ((ASSOLIKE X GENPAIRS)) (T (NEWSYM X))))
  606.          ((AND $RATFAC (ASSOLIKE X GENPAIRS)))
  607.          ((EQ (CAAR X) 'MPLUS)
  608.           (COND ($RATFAC
  609.              (SETQ X (MAPCAR 'PREP1 (CDR X)))
  610.              (COND ((ANDMAPC 'FRPOLY? X)
  611.                 (CONS (MFACPPLUS (MAPL #'(lambda (X)
  612.                               (RPLACA X (CAAR X)))
  613.                           X)) 
  614.                   1))
  615.                (T (DO ((A (CAR X) (FACRPLUS A (CAR L)))
  616.                    (L (CDR X) (CDR L)))
  617.                   ((NULL L) A)))))
  618.             (T (DO ((A (PREP1 (CADR X)) (RATPLUS A (PREP1 (CAR L))))
  619.                 (L (CDDR X) (CDR L)))
  620.                ((NULL L) A)))))
  621.          ((EQ (CAAR X) 'MTIMES)
  622.           (DO ((A (SAVEFACTORS (PREP1 (CADR X)))
  623.               (RATTIMES A (SAVEFACTORS (PREP1 (CAR L))) SW))
  624.            (L (CDDR X) (CDR L))
  625.            (SW (NOT (AND $NOREPEAT (MEMQ 'RATSIMP (CDAR X))))))
  626.           ((NULL L) A)))
  627.          ((EQ (CAAR X) 'MEXPT)
  628.           (NEWVARMEXPT X (CADDR X) T))
  629.          ((EQ (CAAR X) 'MQUOTIENT)
  630.           (RATQUOTIENT (SAVEFACTORS (PREP1 (CADR X)))
  631.                (SAVEFACTORS (PREP1 (CADDR X)))))
  632.          ((EQ (CAAR X) 'MMINUS)
  633.           (RATMINUS (PREP1 (CADR X))))
  634.          ((EQ (CAAR X) 'RAT)
  635.           (COND (MODULUS (CONS (CQUOTIENT (CMOD (CADR X)) (CMOD (CADDR X))) 1))
  636.             (T (CONS (CADR X) (CADDR X)))))
  637.          ((EQ (CAAR X) 'BIGFLOAT)(BIGFLOAT2RAT X))
  638.          ((EQ (CAAR X) 'MRAT)
  639.           (COND ((AND *WITHINRATF* (MEMQ 'TRUNC (CAR X)))
  640.              (THROW 'RATF NIL))
  641.             ((CATCH 'COMPATVL
  642.                (PROGN (SETQ TEMP (COMPATVARL (CADDAR X)
  643.                              VARLIST
  644.                              (CADDDR (CAR X))
  645.                              GENVAR))
  646.                   T))
  647.              (COND ((MEMQ 'TRUNC (CAR X))
  648.                 (CDR ($TAYTORAT X)))
  649.                ((AND (NOT $KEEPFLOAT)
  650.                  (OR (PFLOATP (CADR X)) (PFLOATP (CDDR X))))
  651.                 (CDR (RATREP* ($RATDISREP X))))
  652.                ((SUBLIS TEMP (CDR X)))))
  653.             (T (CDR (RATREP* ($RATDISREP X))))))
  654.          ((ASSOLIKE X GENPAIRS))
  655.          (T (SETQ X (LITTLEFR1 X))
  656.         (COND ((ASSOLIKE X GENPAIRS))
  657.               (T (NEWSYM X))))))
  658.  
  659.  
  660. (DEFUN PUTONVLIST (X)
  661.        (PUSH X VLIST)
  662.        (AND $ALGEBRAIC
  663.         (SETQ X (ASSOLIKE X TELLRATLIST))
  664.         (MAPC 'NEWVAR1 X)))
  665.  
  666. (SETQ EXPSUMSPLIT T)               ;CONTROLS SPLITTING SUMS IN EXPONS
  667.  
  668. (DEFUN NEWVARMEXPT (X E FLAG) 
  669.  
  670.        ;; WHEN FLAG IS T, CALL RETURNS RATFORM
  671.        (PROG (TOPEXP) 
  672.          (COND ((AND (INTEGERP E) (NOT FLAG))
  673.             (RETURN (NEWVAR1 (CADR X))))
  674.  
  675.            ;; THIS MAKES PROBLEMS FOR RISCH ((AND(NOT(INTEGERP
  676.            ;;E))(MEMQ 'RATSIMP (CDAR X))) (RETURN(SETQ VLIST
  677.            ;;(CONS X VLIST))))
  678.            )
  679.          (SETQ TOPEXP 1)
  680.     TOP  (COND
  681.  
  682.           ;; X=B^N FOR N A NUMBER
  683.           ((INTEGERP E)
  684.            (SETQ TOPEXP (TIMES TOPEXP E))
  685.            (SETQ X (CADR X)))
  686.           ((ATOM E) NIL)
  687.  
  688.           ;; X=B^(P/Q) FOR P AND Q INTEGERS
  689.           ((EQ (CAAR E) 'RAT)
  690.            (COND ((OR (MINUSP (CADR E)) (GREATERP (CADR E) 1))
  691.               (SETQ TOPEXP (TIMES TOPEXP (CADR E)))
  692.               (SETQ X (LIST '(MEXPT)
  693.                     (CADR X)
  694.                     (LIST '(RAT) 1 (CADDR E))))))
  695.            (COND ((OR FLAG (NUMBERP (CADR X)) ))
  696.              (*RATSIMP*
  697.               (COND ((MEMALIKE X RADLIST) (RETURN NIL))
  698.                 (T (SETQ RADLIST (CONS X RADLIST))
  699.                    (RETURN (NEWVAR1 (CADR X))))) )
  700.              ($ALGEBRAIC (NEWVAR1 (CADR X)))))
  701.           ;; X=B^(A*C)
  702.           ((EQ (CAAR E) 'MTIMES)
  703.            (COND
  704.         ((OR 
  705.  
  706.              ;; X=B^(N *C)
  707.              (AND (ATOM (CADR E))
  708.               (INTEGERP (CADR E))
  709.               (SETQ TOPEXP (TIMES TOPEXP (CADR E)))
  710.               (SETQ E (CDDR E)))
  711.  
  712.              ;; X=B^(P/Q *C)
  713.              (AND (NOT (ATOM (CADR E)))
  714.               (EQ (CAAADR E) 'RAT)
  715.               (NOT (EQUAL 1 (CADADR E)))
  716.               (SETQ TOPEXP (TIMES TOPEXP (CADADR E)))
  717.               (SETQ E (CONS (LIST '(RAT)
  718.                           1
  719.                           (CADDR (CADR E)))
  720.                     (CDDR E)))))
  721.          (SETQ X
  722.                (LIST '(MEXPT)
  723.                  (CADR X)
  724.                  (SETQ E (SIMPLIFY (CONS '(MTIMES)
  725.                               E)))))
  726.          (GO TOP))))
  727.  
  728.           ;; X=B^(A+C)
  729.           ((AND (EQ (CAAR E) 'MPLUS) EXPSUMSPLIT)    ;SWITCH CONTROLS
  730.            (SETQ                    ;SPLITTING EXPONENT
  731.         X                    ;SUMS
  732.         (CONS
  733.          '(MTIMES)
  734.          (MAPCAR 
  735.           (FUNCTION (LAMBDA (LL) 
  736.                     (LIST '(MEXPT)
  737.                       (CADR X)
  738.                       (SIMPLIFY (LIST '(MTIMES)
  739.                                TOPEXP
  740.                                LL)))))
  741.           (CDR E))))
  742.            (COND (FLAG (RETURN (PREP1 X)))
  743.              (T (RETURN (NEWVAR1 X))))))
  744.          (COND (FLAG NIL)
  745.            ((EQUAL 1 TOPEXP)
  746.             (COND ((OR (ATOM X)
  747.                    (NOT (EQ (CAAR X) 'MEXPT)))
  748.                (NEWVAR1 X))
  749.               ((OR (MEMALIKE X VARLIST) (MEMALIKE X VLIST))
  750.                NIL)
  751.               (T (COND ((OR (ATOM X) (NULL *FNEWVARSW))
  752.                     (PUTONVLIST X))
  753.                    (T (SETQ X (LITTLEFR1 X))
  754.                       (MAPC (FUNCTION NEWVAR1)
  755.                         (CDR X))
  756.                      (OR (MEMALIKE X VLIST)
  757.                      (MEMALIKE X VARLIST)
  758.                      (PUTONVLIST X)))))))
  759.            (T (NEWVAR1 X)))
  760.          (RETURN
  761.           (COND
  762.            ((NULL FLAG) NIL)
  763.            ((EQUAL 1 TOPEXP)
  764.         (COND
  765.          ((AND (NOT (ATOM X)) (EQ (CAAR X) 'MEXPT))
  766.           (COND ((ASSOLIKE X GENPAIRS))
  767. ; *** SHOULD ONLY GET HERE IF CALLED FROM FR1. *FNEWVARSW=NIL
  768.             (T (SETQ X (LITTLEFR1 X))
  769.              (COND ((ASSOLIKE X GENPAIRS))
  770.                    (T (NEWSYM X))))))
  771.          (T (PREP1 X))))
  772.            (T (RATEXPT (PREP1 X) TOPEXP))))))
  773.  
  774. (DEFUN NEWVAR1 (X) 
  775.        (COND ((NUMBERP X) NIL)
  776.          ((MEMALIKE X VARLIST) NIL)
  777.          ((MEMALIKE X VLIST) NIL)
  778.          ((ATOM X) (PUTONVLIST X))
  779.          ((MEMQ (CAAR X)
  780.             '(MPLUS MTIMES RAT MDIFFERENCE
  781.                 MQUOTIENT MMINUS BIGFLOAT))
  782.           (MAPC (FUNCTION NEWVAR1) (CDR X)))
  783.          ((EQ (CAAR X) 'MEXPT)
  784.           (NEWVARMEXPT X (CADDR X) NIL))
  785.          ((EQ (CAAR X) 'MRAT)
  786.           (AND *WITHINRATF* (MEMQ 'TRUNC (CDDDAR X)) (THROW 'RATF '%%))
  787.           (COND ($RATFAC (MAPC 'NEWVAR3 (CADDAR X)))
  788.             (T (MAPC (FUNCTION NEWVAR1) (REVERSE (CADDAR X))))))
  789.          (T (COND (*FNEWVARSW (SETQ X (LITTLEFR1 X))
  790.                   (MAPC (FUNCTION NEWVAR1)
  791.                     (CDR X))
  792.                   (OR (MEMALIKE X VLIST)
  793.                       (MEMALIKE X VARLIST)
  794.                       (PUTONVLIST X)))
  795.               (T (PUTONVLIST X))))))
  796.  
  797. (DEFUN NEWVAR3 (X)
  798.        (OR (MEMALIKE X VLIST)
  799.        (MEMALIKE X VARLIST)
  800.        (PUTONVLIST X)))
  801.  
  802.  
  803.  
  804. (DEFUN FR1 (X VARLIST)        ;put radicands on initial varlist?
  805.   (PROG (GENVAR $NOREPEAT *RATSIMP* RADLIST VLIST NVARLIST OVARLIST GENPAIRS)
  806.     (NEWVAR1 X)
  807.     (SETQ NVARLIST (MAPCAR #'FR-ARGS VLIST))
  808.     (COND ((NOT *RATSIMP*)    ;*ratsimp* not set for initial varlist
  809.            (SETQ VARLIST (NCONC (SORTGREAT VLIST) VARLIST))
  810.            (RETURN (RDIS (CDR (RATREP* X))))))
  811.     (SETQ OVARLIST (NCONC VLIST VARLIST)
  812.           VLIST NIL)
  813.     (MAPC (FUNCTION NEWVAR1) NVARLIST) ;*RATSIMP*=T PUTS RADICANDS ON VLIST
  814.     (SETQ NVARLIST (NCONC NVARLIST VARLIST) ; RADICALS ON RADLIST
  815.           VARLIST (NCONC (SORTGREAT VLIST) (RADSORT RADLIST) VARLIST))
  816.     (ORDERPOINTER VARLIST)
  817.     (SETQ GENPAIRS
  818.           (MAPCAR (FUNCTION (LAMBDA (X Y) (CONS X (RGET Y))))
  819.               VARLIST GENVAR))
  820.     (LET (($ALGEBRAIC $ALGEBRAIC) ($RATALGDENOM $RATALGDENOM) RADLIST)
  821.          (AND (NOT $ALGEBRAIC)
  822.           (ORMAPC (FUNCTION ALGPGET) VARLIST) ;NEEDS *RATSIMP*=T
  823.           (SETQ $ALGEBRAIC T $RATALGDENOM NIL))
  824.          (RATSETUP VARLIST GENVAR)
  825.          (SETQ GENPAIRS
  826.            (MAPCAR (FUNCTION (LAMBDA (X Y) (CONS X (PREP1 Y))))
  827.                OVARLIST NVARLIST))
  828.          (SETQ X (RDIS (PREP1 X)))
  829.          (COND (RADLIST                ;rational radicands
  830.             (SETQ *RATSIMP* NIL)
  831.             (SETQ X (RATSIMP (SIMPLIFY X) NIL NIL)))))
  832.     (RETURN X) ))
  833.  
  834. (DEFUN RATSIMP (X VARLIST GENVAR) ($RATDISREP (RATF X)))
  835.  
  836. (DEFUN LITTLEFR1 (X) 
  837.        (CONS (REMQ 'SIMP (CAR X))
  838.          (MAPFR1 (CDR X) NIL)))
  839.  
  840. ;;IF T RATSIMP FACTORS RADICANDS AND LOGANDS
  841. (DEFMVAR FR-FACTOR NIL)                       
  842.  
  843. (DEFUN FR-ARGS (X)    ;SIMP (A/B)^N TO A^N/B^N ?
  844.   (COND ((ATOM X)
  845.      (WHEN (EQ X '$%I) (SETQ *RATSIMP* T)) ;indicates algebraic present
  846.      X)
  847.     (T (SETQ *RATSIMP* T)    ;FLAG TO CHANGED ELMT.
  848.        (SIMPLIFY (ZP (CONS (REMQ 'SIMP (CAR X))
  849.                    (IF (OR (RADFUNP X NIL) (EQ (CAAR X) '%LOG))
  850.                    (CONS (IF FR-FACTOR (FACTOR (CADR X))
  851.                          (FR1 (CADR X) VARLIST))
  852.                      (CDDR X))
  853.                    (LET (MODULUS)
  854.                     (MAPFR1 (CDR X) VARLIST)))))))))
  855.  
  856. ;(DEFUN ZP (X)                        ;SIMPLIFY MEXPT'S &
  857. ;       (COND ((ATOM X) X)                ;RATEXPAND EXPONENT
  858. ;         ((NOT (EQ (CAAR X) 'MEXPT)) X)
  859. ;         ((EQUAL 0 (CADDR X)) 1)
  860. ;         ((EQUAL 0 (CADR X)) 0)
  861. ;         ((EQUAL 1 (CADR X)) 1)
  862. ;         ((ATOM (CADDR X)) X)
  863. ;         (T (LIST (CAR X) (CADR X)
  864. ;              ((LAMBDA (VARLIST *RATSIMP*) ($RATEXPAND (CADDR X)))
  865. ;               VARLIST NIL)))))
  866.  
  867. (DEFUN ZP (X)
  868.        (IF (AND (MEXPTP X) (NOT (ATOM (CADDR X))))
  869.        (LIST (CAR X) (CADR X)
  870.          (LET ((VARLIST VARLIST) *RATSIMP*)
  871.               ($RATEXPAND (CADDR X))))
  872.        X))
  873.  
  874.  
  875. (DEFUN NEWSYM (E)
  876.   (PROG (G P)
  877.     (COND ((SETQ G (ASSOLIKE E GENPAIRS))
  878.            (RETURN G)))
  879.     #-cl
  880.     (SETQ G (GENSYM))
  881.     #+cl
  882.     (SETQ G (gensym-readable e))
  883.     (PUTPROP G E 'DISREP)
  884.     (PUSH E VARLIST)
  885.     (PUSH (CONS E (RGET G)) GENPAIRS)
  886.     (VALPUT G (IF GENVAR (SUB1 (VALGET (CAR GENVAR))) 1))
  887.     (PUSH G GENVAR)
  888.     (COND ((SETQ P (AND $ALGEBRAIC (ALGPGET E)))
  889.            (ALGORDSET P GENVAR)
  890.            (PUTPROP G P 'TELLRAT)))
  891.     (RETURN (RGET G))))
  892.  
  893.  
  894. ;;  Any program which calls RATF on
  895. ;;  a floating point number but does not wish to see "RAT replaced ..."
  896. ;;  message, must bind $RATPRINT to NIL.
  897.  
  898. (DEFMVAR $RATPRINT T)
  899.  
  900. (DEFMVAR $RATEPSILON #-Franz 2.0E-8 
  901.              #+(and Franz VAX) (expt 2.0 -56.)
  902.              #+(and Franz 68k) (expt 2.0 -52.))
  903.                 ;; Some 68k stuff has a shorter significand.
  904. ;; This control of conversion from float to rational appears to be explained
  905. ;; nowhere. - RJF
  906.  
  907. (DEFMFUN MAXIMA-RATIONALIZE (X)
  908.   (COND ((NOT (FLOATP X)) X)
  909.     ((< X 0.0) (SETQ X (RATION1 (*$ -1.0 X)))
  910.            (RPLACA X (TIMES -1 (CAR X))))
  911.     (T (RATION1 X))))
  912.  
  913. ; the following code patches the fact that fix(float(bignum))
  914. ; sometimes fails in franz.
  915. #+Franz
  916. (defun ration1 (x)
  917.  ((lambda (rateps)
  918.        (or (and (zerop x) (cons 0 1))
  919.        (prog (y a)
  920.          (return (do ((xx x (setq y (//$ 1.0 (-$ xx (float a)))))
  921.                   (num (setq a (newfix x)) 
  922.                    (plus (times (setq a (newfix y)) num) onum))
  923.                   (den 1 (plus (times a den) oden))
  924.                   (onum 1 num)
  925.                   (oden 0 den))
  926.                  ((and (not (zerop den))
  927.                    (< (abs (//$ (-$ x (//$ (float num) (float den)))
  928.                         x))
  929.                       rateps))
  930.                   (cons num den))  )))))
  931.  (cond ((not (floatp $ratepsilon)) ($float $ratepsilon)) (t $ratepsilon))))
  932.  
  933. #+Franz
  934. (defun newfix (x)
  935.   (cond ((greaterp (abs x) two30f)
  936.      (times two30 (newfix (quotient x two30f))))
  937.     (t (fix x))))
  938.  
  939. #-Franz
  940. (DEFUN RATION1 (X)
  941.  (let ((rateps
  942.     (COND ((NOT (FLOATP $RATEPSILON))
  943.            ($FLOAT $RATEPSILON)) (T $RATEPSILON))))
  944.    (OR (AND (ZEROP X) (CONS 0 1))
  945.        (PROG
  946.     (Y A)
  947.     (RETURN
  948.      (DO ((XX X (SETQ Y (/ 1.0 (- XX (FLOAT A x)))))
  949.           (NUM (SETQ A (FIX X)) (PLUS (TIMES (SETQ A (FIX Y)) NUM) ONUM))
  950.           (DEN 1 (PLUS (TIMES A DEN) ODEN))
  951.           (ONUM 1 NUM)
  952.           (ODEN 0 DEN))
  953.          ((AND (NOT (ZEROP DEN))
  954.            (NOT (> (ABS
  955.                 (/
  956.                  (- X
  957.                 (/ (FLOAT NUM x)
  958.                    (FLOAT DEN x)))
  959.                  X))
  960.                RATEPS)))
  961.           (CONS NUM DEN))))))))
  962.  
  963. (DEFUN PREPFLOAT (F)
  964.  (COND ((< (ABS F) 1.0E-37) (SETQ F 0.0)))   ;changed 38 to 37 --wfs
  965.  (COND (MODULUS (MERROR "Floating point meaningless unless MODULUS = FALSE"))
  966.        ($RATPRINT (MTELL "~&RAT replaced ~A by" F)))
  967.  (SETQ F (MAXIMA-RATIONALIZE F))
  968.  (IF $RATPRINT (MTELL " ~A//~A = ~A~%"  (CAR F) (CDR F)
  969.               (FPCOFRAT1 (CAR F) (CDR F))))
  970.  F)
  971.  
  972.  
  973. (DEFUN PDISREP (P)
  974.        (COND ((ATOM P) P)
  975.          (T (PDISREP+ (PDISREP2 (CDR P) (GET (CAR P) 'DISREP))))))
  976.  
  977. (DEFUN PDISREP! (N VAR)
  978.        (COND ((ZEROP N) 1)
  979.          ((EQN N 1) (COND ((ATOM VAR) VAR)
  980.                   ((OR (EQ (CAAR VAR) 'MTIMES)
  981.                    (EQ (CAAR VAR) 'MPLUS))
  982.                    (COPY1 VAR))
  983.                   (T VAR)))
  984.          (T (LIST '(MEXPT RATSIMP) VAR N))))
  985.  
  986. (DEFUN PDISREP+ (P)
  987.        (COND ((NULL (CDR P)) (CAR P))
  988.          (T (LET ((A (LAST P)))
  989.           (COND ((MPLUSP (CAR A))
  990.              (RPLACD A (CDDAR A))
  991.              (RPLACA A (CADAR A))))
  992.           (CONS '(MPLUS RATSIMP) P)))))
  993.      
  994. (DEFUN PDISREP* (A B)
  995.   (COND ((EQN A 1) B)
  996.     ((EQN B 1) A)
  997.     (T (CONS '(MTIMES RATSIMP)
  998.          (NCONC (PDISREP*CHK A) (PDISREP*CHK B))))))
  999.  
  1000. (DEFUN PDISREP*CHK (A)
  1001.   (IF (MTIMESP A) (CDR A) (NCONS A)))
  1002.  
  1003. (DEFUN PDISREP2 (P VAR)
  1004.        (COND ((NULL P) NIL)
  1005.          ($RATEXPAND (PDISREP2EXPAND P VAR))
  1006.          (T (DO ((L () (CONS (PDISREP* (PDISREP (CADR P))
  1007.                        (PDISREP! (CAR P) VAR))
  1008.                  L))
  1009.              (P P (CDDR P)))
  1010.             ((NULL P)
  1011.              (NREVERSE L))))))
  1012.  
  1013. ;; IF $RATEXPAND IS TRUE, (X+1)*(Y+1) WILL DISPLAY AS
  1014. ;; XY + Y + X + 1  OTHERWISE, AS (X+1)Y + X + 1
  1015. (DEFMVAR $RATEXPAND NIL)
  1016.  
  1017. (DEFMFUN $RATEXPAND (X)
  1018.  (COND ((MBAGP X) (CONS (CAR X) (MAPCAR '$RATEXPAND (CDR X))))
  1019.        (T ((LAMBDA ($RATEXPAND $RATFAC) (RATDISREP (RATF X))) T NIL))))
  1020.      
  1021. (DEFUN PDISREP*EXPAND (A B)
  1022.   (COND ((EQN A 1) (LIST B))
  1023.     ((EQN B 1) (LIST A))
  1024.     ((OR (ATOM A) (NOT (EQ (CAAR A) 'MPLUS)))
  1025.      (LIST (CONS (QUOTE (MTIMES RATSIMP))
  1026.              (NCONC (PDISREP*CHK A) (PDISREP*CHK B)))))
  1027.     (T (MAPCAR #'(LAMBDA (Z) (IF (EQN Z 1) B
  1028.                      (CONS '(MTIMES RATSIMP)
  1029.                        (NCONC (PDISREP*CHK Z)
  1030.                           (PDISREP*CHK B)))))
  1031.            (CDR A)))))
  1032.      
  1033. (DEFUN PDISREP2EXPAND (P VAR)
  1034.   (COND ((NULL P) NIL)
  1035.     (T (NCONC (PDISREP*EXPAND (PDISREP (CADR P))
  1036.                   (PDISREP! (CAR P) VAR))
  1037.           (PDISREP2EXPAND (CDDR P) VAR)))))
  1038.  
  1039.  
  1040. (DEFMVAR $RATDENOMDIVIDE T)
  1041.  
  1042. (DEFMFUN $RATDISREP (X)
  1043.   (COND ((NOT ($RATP X)) X)
  1044.     (T (SETQ X (RATDISREPD X))
  1045.        (IF (AND (NOT (ATOM X)) (MEMQ 'TRUNC (CDAR X)))
  1046.            (CONS (DELQ 'TRUNC (copy-top-level (CAR X)) 1) (CDR X))
  1047.            X))))
  1048.  
  1049. ; RATDISREPD is needed by DISPLA. - JPG
  1050. (DEFUN RATDISREPD (X)
  1051.   (MAPC #'(LAMBDA (Y Z) (PUTPROP Y Z (QUOTE DISREP)))
  1052.     (CADDDR (CAR X))
  1053.     (CADDAR X))
  1054.   (LET ((VARLIST (CADDAR X)))
  1055.        (IF (MEMQ 'TRUNC (CAR X)) (SRDISREP X) (CDISREP (CDR X)))))
  1056.  
  1057. (DEFUN CDISREP (X &AUX N D SIGN)
  1058.   (COND ((PZEROP (CAR X)) 0)
  1059.     ((OR (EQN 1 (CDR X)) (FLOATP (CDR X))) (PDISREP (CAR X)))
  1060.     (T (SETQ SIGN (COND ($RATEXPAND (SETQ N (PDISREP (CAR X))) 1)
  1061.                 ((PMINUSP (CAR X))
  1062.                  (SETQ N (PDISREP (PMINUS (CAR X)))) -1)
  1063.                 (T (SETQ N (PDISREP (CAR X))) 1)))
  1064.        (SETQ D (PDISREP (CDR X)))
  1065.        (COND ((AND (NUMBERP N) (NUMBERP D))
  1066.           (LIST '(RAT) (TIMES SIGN N) D))
  1067.          ((AND $RATDENOMDIVIDE $RATEXPAND
  1068.                (NOT (ATOM N))
  1069.                (EQ (CAAR N) 'MPLUS))
  1070.           (FANCYDIS N D))
  1071.          ((NUMBERP D)
  1072.           (LIST '(MTIMES RATSIMP)
  1073.             (LIST '(RAT) SIGN D) N))
  1074.          ((EQN SIGN -1) 
  1075.           (CONS '(MTIMES RATSIMP)
  1076.             (COND ((NUMBERP N)
  1077.                    (LIST (TIMES N -1)
  1078.                      (LIST '(MEXPT RATSIMP) D -1)))
  1079.                   (T (LIST SIGN N (LIST '(MEXPT RATSIMP) D -1))))))
  1080.          ((EQN N 1)
  1081.           (LIST '(MEXPT RATSIMP) D -1))
  1082.          (T (LIST '(MTIMES RATSIMP) N
  1083.               (LIST '(MEXPT RATSIMP) D -1)))))))
  1084.  
  1085.  
  1086. ;; FANCYDIS GOES THROUGH EACH TERM AND DIVIDES IT BY THE DENOMINATOR.
  1087.  
  1088. (DEFUN FANCYDIS (N D)
  1089.   (SETQ D (SIMPLIFY (LIST '(MEXPT) D -1)))
  1090.   (SIMPLIFY (CONS '(MPLUS)
  1091.           (MAPCAR #'(LAMBDA (Z)
  1092.                     ($RATDISREP (RATF (LIST '(MTIMES) Z D))))
  1093.               (CDR N)))))
  1094.  
  1095.  
  1096. (DEFUN COMPATVARL (A B C D)
  1097.        (COND ((NULL A) NIL)
  1098.          ((OR (NULL B) (NULL C) (NULL D)) (THROW 'COMPATVL NIL))
  1099.          ((ALIKE1 (CAR A) (CAR B))
  1100.           (SETQ A (COMPATVARL (CDR A) (CDR B) (CDR C) (CDR D)))
  1101.           (COND ((EQ (CAR C) (CAR D)) A)
  1102.             (T (CONS (CONS (CAR C) (CAR D)) A))))
  1103.          (T (COMPATVARL A (CDR B) C (CDR D)))))
  1104.  
  1105. (DEFUN NEWVAR (L &AUX VLIST)
  1106.   (NEWVAR1 L)
  1107.   (SETQ VARLIST (NCONC (SORTGREAT VLIST) VARLIST)))
  1108.  
  1109. (DEFUN SORTGREAT (L) (AND L (NREVERSE (SORT L 'GREAT))))
  1110.  
  1111. (DEFUN FNEWVAR (L &AUX (*FNEWVARSW T)) (NEWVAR L))
  1112.  
  1113. (DEFUN NESTLEV (EXP)
  1114.        (COND ((ATOM EXP) 0)
  1115.          (T (DO ((M (NESTLEV (CADR EXP)) (MAX M (NESTLEV (CAR L))))
  1116.              (L (CDDR EXP) (CDR L)))
  1117.             ((NULL L) (f1+ M))))))
  1118.  
  1119. (DEFUN RADSORT (L)
  1120.   (SORT L #'(LAMBDA (A B)
  1121.           ((LAMBDA (NA NB)
  1122.          (COND ((< NA NB) T)
  1123.                ((> NA NB) NIL)
  1124.                (T (GREAT B A))))
  1125.            (NESTLEV A) (NESTLEV B)))))
  1126.  
  1127. ;;    THIS IS THE END OF THE NEW RATIONAL FUNCTION PACKAGE PART 5
  1128. ;;    IT INCLUDES THE CONVERSION AND TOP-LEVEL ROUTINES USED
  1129. ;;    BY THE REST OF THE FUNCTIONS.
  1130.  
  1131.