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 / simp.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  81.0 KB  |  2,321 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 simp)
  13.  
  14. (DECLARE-TOP (SPECIAL EXPTRLSW RULESW $%E_TO_NUMLOG *INV* SUBSTP
  15.           $%EMODE $RADEXPAND TIMESINP *CONST* LIMITP PLUSFLAG
  16.           PRODS NEGPRODS SUMS NEGSUMS EXPANDP $DOMAIN $LISTARITH
  17.           $LOGSIMP $LOGEXPAND $LOGNUMER $LOGNEGINT $M1PBRANCH
  18.           EXPANDFLAG $MAPERROR $SCALARMATRIXP NOUNL
  19.           DERIVFLAG $RATSIMPEXPONS $KEEPFLOAT $RATPRINT
  20.           $DEMOIVRE *ZEXPTSIMP? %E-VAL %PI-VAL FMAPLVL
  21.           BIGFLOATZERO BIGFLOATONE $ASSUMESCALAR $SUBNUMSIMP
  22.           OPERS-LIST *OPERS-LIST WFLAG $DONTFACTOR *N
  23.           *OUT *IN VARLIST GENVAR $FACTORFLAG RADCANP)
  24.      (UNSPECIAL ARGS)
  25.      #-cl
  26.      (*EXPR PSQUOREM1 PNTHROOTP)
  27.      #-cl
  28.      (*LEXPR FMAPL1 $LIMIT OUTERMAP1 $RATSIMP $EXPAND)
  29.      (FIXNUM FMAPLVL L1 L2 XN NARGS I #-cl (SIGNUM1))
  30.      (NOTYPE N)
  31.      (GENPREFIX SM)
  32.      (MUZZLED T))
  33.  
  34. ;; General purpose simplification and conversion switches.
  35.  
  36. (DEFMVAR $FLOAT NIL
  37.      "Causes non-integral rational numbers to be converted to
  38.      floating point."
  39.      EVFLAG
  40.      SEE-ALSO $NUMER)
  41.  
  42. (DEFMVAR $NEGDISTRIB T
  43.      "Causes negations to be distributed over sums, e.g. -(A+B) is
  44.      simplified to -A-B.")
  45.  
  46. (DEFMVAR $NUMER NIL
  47.      "Causes zl-SOME mathematical functions (including exponentiation)
  48.      with numerical arguments to be evaluated in floating point.
  49.      It causes variables in an expression which have been given
  50.      NUMERVALs to be replaced by their values.  It also turns
  51.      on the FLOAT switch."
  52.      SEE-ALSO ($NUMERVAL $FLOAT))
  53.  
  54. (DEFMVAR $SIMP T "Enables simplification.")
  55.  
  56. (DEFMVAR $SUMEXPAND NIL
  57.      "If TRUE, products of sums and exponentiated sums go into nested 
  58.      sums.")
  59.  
  60. (DEFMVAR $NUMER_PBRANCH NIL)
  61.  
  62. ;; Switches dealing with matrices and non-commutative multiplication.
  63.  
  64. (DEFMVAR $DOSCMXPLUS NIL
  65.      "Causes SCALAR + MATRIX to return a matrix answer.  This switch
  66.      is not subsumed under DOALLMXOPS.")
  67.  
  68. (DEFMVAR $DOMXEXPT T
  69.      "Causes SCALAR^MATRIX([1,2],[3,4]) to return
  70.      MATRIX([SCALAR,SCALAR^2],[SCALAR^3,SCALAR^4]).  In general, this
  71.      transformation affects exponentiations where the *print-base* is a scalar
  72.      and the power is a matrix or list.")
  73.  
  74. (DEFMVAR $DOMXPLUS NIL)
  75.  
  76. (DEFMVAR $DOMXTIMES NIL)
  77.  
  78. (DEFMVAR $MX0SIMP T)
  79.  
  80. ;; Switches dealing with expansion.
  81.  
  82. (DEFMVAR $EXPOP 0
  83.      "The largest positive exponent which will be automatically
  84.      expanded.  (X+1)^3 will be automatically expanded if
  85.      EXPOP is greater than or equal to 3."
  86.      FIXNUM
  87.      SEE-ALSO ($EXPON $MAXPOSEX $EXPAND))
  88.  
  89. (DEFMVAR $EXPON 0
  90.      "The largest negative exponent which will be automatically
  91.      expanded.  (X+1)^(-3) will be automatically expanded if
  92.      EXPON is greater than or equal to 3."
  93.      FIXNUM
  94.      SEE-ALSO ($EXPOP $MAXNEGEX $EXPAND))
  95.  
  96. (DEFMVAR $MAXPOSEX 1000.
  97.      "The largest positive exponent which will be expanded by
  98.      the EXPAND command."
  99.      FIXNUM
  100.      SEE-ALSO ($MAXNEGEX $EXPOP $EXPAND))
  101.  
  102. (DEFMVAR $MAXNEGEX 1000.
  103.      "The largest negative exponent which will be expanded by
  104.      the EXPAND command."
  105.      FIXNUM
  106.      SEE-ALSO ($MAXPOSEX $EXPON $EXPAND))
  107.  
  108. ;; Lisp level variables
  109.  
  110. (DEFMVAR DOSIMP NIL
  111.      "Causes SIMP flags to be ignored.  $EXPAND works by binding
  112.      $EXPOP to $MAXPOSEX, $EXPON to $MAXNEGEX, and DOSIMP to T.")
  113.  
  114. (DEFMVAR ERRORSW NIL
  115.      "Causes a throw to the tag ERRORSW when certain errors occur
  116.      rather than the printing of a message.  Kludgy MAXIMA-SUBSTITUTE for
  117.      MAXIMA-ERROR signalling.")
  118.  
  119. (DEFMVAR DERIVSIMP T "Hack in SIMPDERIV for RWG")
  120.  
  121. ;; The following SETQs should be replaced with DEFMVARS in the correct places.
  122. (declare-top (special $ROOTSEPSILON $GRINDSWITCH $ALGEPSILON $ALGDELTA $TRUE
  123.               $FALSE $ON $OFF $LOGABS RISCHPF $LIMITDOMAIN RISCHP RP-POLYLOGP ))
  124. (SETQ $ROOTSEPSILON 1.0E-7 $%RNUM 0
  125.       $GRINDSWITCH NIL $ALGEPSILON 100000000. $ALGDELTA 1.0E-5) 
  126.  
  127. (PROGn
  128.  (SETQ $LISTARITH T WFLAG NIL $LOGNUMER NIL EXPANDP NIL $DOMAIN '$REAL
  129.          $M1PBRANCH NIL $%E_TO_NUMLOG NIL $%EMODE T TIMESINP NIL
  130.          $TRUE T $FALSE NIL $ON T $OFF NIL %E-VAL (MGET '$%E '$NUMER)
  131.          %PI-VAL (MGET '$%PI '$NUMER) $LOGABS NIL $LOGNEGINT NIL
  132.          DERIVFLAG NIL $RATSIMPEXPONS NIL EXPTRLSW NIL $LOGEXPAND T
  133.          EXPANDFLAG NIL $RADEXPAND T *ZEXPTSIMP? NIL $SUBNUMSIMP NIL
  134.          RISCHPF NIL $LIMITDOMAIN '$COMPLEX $LOGSIMP T
  135. ;         $MATCHIDENT T $MATCHASSOC T $MATCHCOMM T $MATCHCRE NIL
  136.          RISCHP NIL RP-POLYLOGP NIL *CONST* 0))
  137.  
  138. (eval-when (load)
  139.   (MAPC #'(LAMBDA (X) (MPUTPROP X T '$CONSTANT) (PUTPROP X T 'SYSCONST))
  140.          '($%PI $%I $%E $%PHI $INF $MINF $INFINITY %I $%GAMMA)))
  141.  
  142. (DEFPROP MNCTIMES T ASSOCIATIVE)
  143. (DEFPROP LAMBDA T LISP-NO-SIMP)
  144. ;; Local functions should not be simplified.   Various
  145. ;; lisps use various names for the list structure defining
  146. ;; these:
  147. (eval-when (load)
  148.    (eval '(let* ((x 1) (y1 #'(lambda (u) (+ x u)))
  149.          (z #'(lambda () 3)))
  150.         (dolist (y (list x z))
  151.             (and (consp y)
  152.              (symbolp (car y))
  153.              (setf (get (car y) 'lisp-no-simp) t))))))
  154.   
  155.  
  156. (DOLIST (X '(MPLUS MTIMES MNCTIMES MEXPT MNCEXPT %SUM))
  157.     (PUTPROP X (CONS X '(SIMP)) 'MSIMPIND))
  158.  
  159. (PROG1 '(OPERATORS properties)
  160.        (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPERATORS))
  161.          '((MPLUS SIMPLUS) (MTIMES SIMPTIMES) (MNCEXPT SIMPNCEXPT)
  162.            (MMINUS SIMPMIN) (%GAMMA SIMPGAMMA) (MFACTORIAL SIMPFACT)
  163.            (MNCTIMES SIMPNCT) (MQUOTIENT SIMPQUOT) (MEXPT SIMPEXPT)
  164.            (%LOG SIMPLN) (%SQRT SIMPSQRT) (%DERIVATIVE SIMPDERIV)
  165.            (MABS SIMPABS) (%SIGNUM SIMPSIGNUM)
  166.            (%INTEGRATE SIMPINTEG) (%LIMIT SIMP-LIMIT) ($EXP SIMPEXP)
  167.            (BIGFLOAT SIMPBIGFLOAT) (LAMBDA SIMPLAMBDA) (MDEFINE SIMPMDEF)
  168.            (MQAPPLY SIMPMQAPPLY) (%GAMMA SIMPGAMMA) (%ERF SIMPERF) 
  169.            ($BETA SIMPBETA) (%SUM SIMPSUM) (%BINOMIAL SIMPBINOCOEF) 
  170.            (%PLOG SIMPPLOG) (%PRODUCT SIMPPROD) (%GENFACT SIMPGFACT)
  171.            ($ATAN2 SIMPATAN2) ($MATRIX SIMPMATRIX) (%MATRIX SIMPMATRIX)
  172.            ($BERN SIMPBERN) ($EULER SIMPEULER))))
  173.  
  174. (DEFPROP $LI LISIMP SPECSIMP)
  175. (DEFPROP $PSI PSISIMP SPECSIMP)
  176.  
  177. (DEFPROP $EQUAL T BINARY)
  178. (DEFPROP $NOTEQUAL T BINARY)
  179.  
  180. ;; The following definitions of ONEP and ONEP1 are bummed for speed, and should
  181. ;; be moved to a special place for implementation dependent code.
  182. ;; ONEP is the same as (EQUAL A 1), but does the check inline rather than
  183. ;; calling EQUAL (uses more instructions, so this isn't done by default).  ONEP
  184. ;; seems to be used very rarely, so it seems hardly worth the effort.  On the
  185. ;; Lisp Machine, this is probably more efficient as simply (EQUAL A 1).
  186.  
  187. #+(and cl (not cmu))
  188. (defmacro onep (a) `(eql ,a 1))
  189.  
  190. #+cl
  191. (DEFMFUN ONEP1 (A) (OR (and (numberp a) (= A 1)) (EQUAL A BIGFLOATONE)))
  192.  
  193. #-cl
  194. (progn 'compile
  195. (DEFMFUN ONEP (A)
  196.   #-NIL (AND (EQ (ml-typep A) 'fixnum) (= A 1))
  197.   #+NIL (eql a 1))
  198.  
  199. #-(or Franz cl)
  200.  
  201. (DEFMFUN ONEP1 (A) (OR (EQUAL A 1) (EQUAL A 1.0) (EQUAL A BIGFLOATONE)))
  202.  
  203. #+Franz
  204. (DEFUN ONEP1 (A)
  205.   (LET ((TYPE (ml-typep A)))
  206.        (COND ((EQ TYPE 'fixnum) (EQUAL A 1))
  207.          ((EQ TYPE 'flonum) (EQUAL A 1.0))
  208.          ((EQ TYPE 'LISPT) (EQUAL A BIGFLOATONE)))))
  209.  
  210. )
  211. (DEFMFUN ZEROP1 (A) (IF (NUMBERP A) (ZEROP A) (ALIKE1 A BIGFLOATZERO)))
  212.  
  213. (DEFMFUN $BFLOATP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'BIGFLOAT)))
  214.  
  215.  
  216. #-cl
  217. (DEFMFUN MNUMP (X)
  218.   (OR (NUMBERP X) (AND (NOT (ATOM X)) (MEMQ (CAAR X) '(RAT BIGFLOAT)))))
  219.  
  220. #+cl 
  221. (DEFMFUN MNUMP (X)
  222.   (OR (NUMBERP X) (AND (NOT (ATOM X))(not (atom (car x)))
  223.                (MEMQ (CAAR X) '(RAT BIGFLOAT)))))
  224.  
  225. ;; EVEN works for any arbitrary lisp object since it does an integer
  226. ;; check first.  In other cases, you may want the Lisp EVENP function
  227. ;; which only works for integers.
  228.  
  229. (DEFMFUN EVEN (A) (AND (INTEGERP A) (NOT (ODDP A))))
  230.  
  231. (DEFMFUN RATNUMP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'RAT)))
  232.  
  233. (DEFMFUN MPLUSP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MPLUS)))
  234.  
  235. (DEFMFUN MTIMESP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MTIMES)))
  236.  
  237. (DEFMFUN MEXPTP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MEXPT)))
  238.  
  239. (DEFMFUN MNCTIMESP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MNCTIMES)))
  240.  
  241. (DEFMFUN MNCEXPTP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MNCEXPT)))
  242.  
  243. (DEFMFUN MLOGP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) '%LOG)))
  244.  
  245. (DEFMFUN MMMINUSP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MMINUS)))
  246.  
  247. (DEFMFUN MNEGP (X) (COND ((NUMBERP X) (MINUSP X))
  248.              ((OR (RATNUMP X) ($BFLOATP X)) (MINUSP (CADR X)))))
  249.  
  250. (DEFMFUN MQAPPLYP (E) (AND (NOT (ATOM E)) (EQ (CAAR E) 'MQAPPLY)))
  251.  
  252. (DEFMFUN RATDISREP (E) (SIMPLIFYA ($RATDISREP E) NIL))
  253.  
  254. (DEFMFUN SRATSIMP (E) (SIMPLIFYA ($RATSIMP E) NIL))
  255.  
  256. (DEFMFUN SIMPCHECK (E FLAG)
  257.   (COND ((SPECREPP E) (SPECDISREP E)) (FLAG E) (T (SIMPLIFYA E NIL))))
  258.  
  259. (DEFMFUN MRATCHECK (E) (IF ($RATP E) (RATDISREP E) E))
  260.  
  261. (DEFMFUN $NUMBERP (E) (OR ($RATNUMP E) ($FLOATNUMP E) ($BFLOATP E)))
  262.  
  263. (DEFMFUN $INTEGERP (X)
  264.   (OR (INTEGERP X)
  265.       (AND ($RATP X) (INTEGERP (CADR X)) (EQUAL (CDDR X) 1))))
  266.  
  267. ;; The call to $INTEGERP in the following two functions checks for a CRE 
  268. ;; rational number with an integral numerator and a unity denominator.
  269.  
  270. (DEFMFUN $ODDP (X)
  271.   (COND ((INTEGERP X) (ODDP X))
  272.     (($INTEGERP X) (ODDP (CADR X)))))
  273.  
  274. (DEFMFUN $EVENP (X)
  275.   (COND ((INTEGERP X) (EVENP X))
  276.     (($INTEGERP X) (NOT (ODDP (CADR X))))))
  277.  
  278. (DEFMFUN $FLOATNUMP (X)
  279.   (OR (FLOATP X)
  280.       (AND ($RATP X) (FLOATP (CADR X)) (ONEP1 (CDDR X)))))
  281.  
  282. (DEFMFUN $RATNUMP (X)
  283.   (OR (INTEGERP X)
  284.       (RATNUMP X)
  285.       (AND ($RATP X) (INTEGERP (CADR X)) (INTEGERP (CDDR X)))))
  286.  
  287. (DEFMFUN $RATP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MRAT)))
  288.  
  289. (DEFMFUN $TAYLORP (X)
  290.   (AND (NOT (ATOM X)) (EQ (CAAR X) 'MRAT) (MEMQ 'TRUNC (CDAR X)) T))
  291.  
  292. (DEFMFUN SPECREPCHECK (E) (IF (SPECREPP E) (SPECDISREP E) E))
  293.   
  294. ;; Note that the following two functions are carefully coupled.
  295.  
  296. (DEFMFUN SPECREPP (E) (AND (NOT (ATOM E)) (MEMQ (CAAR E) '(MRAT MPOIS))))
  297.   
  298. (DEFMFUN SPECDISREP (E)
  299.  (COND ((EQ (CAAR E) 'MRAT) (RATDISREP E))
  300. ;      ((EQ (CAAR E) 'MPOIS) ($OUTOFPOIS E))
  301.        (T ($OUTOFPOIS E))))
  302.   
  303. (DEFMFUN $POLYSIGN (X) (SETQ X (CADR (RATF X)))
  304.   (COND ((EQUAL X 0) 0) ((PMINUSP X) -1) (T 1)))
  305.  
  306. ;; These check for the correct number of operands within Macsyma expressions,
  307. ;; not arguments in a procedure call as the name may imply.
  308.  
  309. (DEFMFUN ONEARGCHECK (L)
  310.  (IF (OR (NULL (CDR L)) (CDDR L)) (WNA-ERR (CAAR L))))
  311.  
  312. (DEFMFUN TWOARGCHECK (L)
  313.  (IF (OR (NULL (CDDR L)) (CDDDR L)) (WNA-ERR (CAAR L))))
  314.  
  315. (DEFMFUN WNA-ERR (OP) (MERROR "Wrong number of arguments to ~:@M" OP))
  316.  
  317. (DEFMFUN IMPROPER-ARG-ERR (EXP FN)
  318.  (MERROR "Improper argument to ~:M:~%~M" FN EXP))
  319.  
  320. (DEFMFUN SUBARGCHECK (FORM SUBSHARP ARGSHARP FUN)
  321.   (IF (OR (NOT (= (LENGTH (SUBFUNSUBS FORM)) SUBSHARP))
  322.       (NOT (= (LENGTH (SUBFUNARGS FORM)) ARGSHARP)))
  323.       (MERROR "Wrong number of arguments or subscripts to ~:@M" FUN)))
  324.  
  325. ;; Constructor and extractor primitives for subscripted functions, e.g.
  326. ;; F[1,2](X,Y).  SUBL is (1 2) and ARGL is (X Y).
  327.  
  328. ;; These will be flushed when NOPERS is finished.  They will be macros in
  329. ;; NOPERS instead of functions, so we have to be careful that they aren't
  330. ;; mapped or applied anyplace.  What we really want is open-codable routines.
  331.  
  332. (DEFMFUN SUBFUNMAKES (FUN SUBL ARGL)
  333.   `((MQAPPLY SIMP) ((,FUN SIMP ARRAY) . ,SUBL) . ,ARGL))
  334.  
  335. (DEFMFUN SUBFUNMAKE (FUN SUBL ARGL)
  336.   `((MQAPPLY) ((,FUN SIMP ARRAY) . ,SUBL) . ,ARGL))
  337.  
  338. (DEFMFUN SUBFUNNAME (EXP) (CAAADR EXP))
  339.  
  340. (DEFMFUN SUBFUNSUBS (EXP) (CDADR EXP))
  341.  
  342. (DEFMFUN SUBFUNARGS (EXP) (CDDR EXP))
  343.  
  344. (DEFMFUN $NUMFACTOR (X)
  345.   (SETQ X (SPECREPCHECK X))
  346.   (COND ((MNUMP X) X)
  347.     ((ATOM X) 1)
  348.     ((NOT (EQ (CAAR X) 'MTIMES)) 1)
  349.     ((MNUMP (CADR X)) (CADR X))
  350.     (T 1)))
  351.  
  352. (DEFUN SCALAR-OR-CONSTANT-P (X FLAG)
  353.  (IF FLAG (NOT ($NONSCALARP X)) ($SCALARP X)))
  354.  
  355. (DEFMFUN $CONSTANTP (X)
  356.  (COND ((ATOM X) (OR ($NUMBERP X) (MGET X '$CONSTANT)))
  357.        ((MEMQ (CAAR X) '(RAT BIGFLOAT)) T)
  358.        ((SPECREPP X) ($CONSTANTP (SPECDISREP X)))
  359.        ((OR (MOPP (CAAR X)) (MGET (CAAR X) '$CONSTANT))
  360.     (DO ((X (CDR X) (CDR X))) ((NULL X) T)
  361.         (IF (NOT ($CONSTANTP (CAR X))) (RETURN NIL))))))
  362.  
  363. (DEFMFUN CONSTANT (X)
  364.  (COND ((SYMBOLP X) (MGET X '$CONSTANT))
  365.        (($SUBVARP X)
  366.     (AND (MGET (CAAR X) '$CONSTANT)
  367.          (DO ((X (CDR X) (CDR X))) ((NULL X) T)
  368.          (IF (NOT ($CONSTANTP (CAR X))) (RETURN NIL)))))))
  369.  
  370. (DEFUN MAXIMA-CONSTANTP (X) (OR (NUMBERP X) (MGET X '$CONSTANT)))
  371.  
  372. (DEFUN CONSTTERMP (X) (AND ($CONSTANTP X) (NOT ($NONSCALARP X))))
  373.  
  374. (DEFMFUN $SCALARP (X) (OR (CONSTTERMP X) (EQ (SCALARCLASS X) '$SCALAR)))
  375.  
  376. (DEFMFUN $NONSCALARP (X) (EQ (SCALARCLASS X) '$NONSCALAR))
  377.  
  378. (DEFUN SCALARCLASS (EXP);  Returns $SCALAR, $NONSCALAR, or NIL (unknown).
  379.        (COND ((ATOM EXP)
  380.           (COND ((MGET EXP '$NONSCALAR) '$NONSCALAR)
  381.             ((MGET EXP '$SCALAR) '$SCALAR)))
  382.          ((SPECREPP EXP) (SCALARCLASS (SPECDISREP EXP)))
  383. ;  If the function is declared scalar or nonscalar, then return.  If it isn't
  384. ;  explicitly declared, then try to be intelligent by looking at the arguments
  385. ;  to the function.
  386.          ((SCALARCLASS (CAAR EXP)))
  387. ;  <number> + <scalar> is SCALARP because that seems to be useful.  This should
  388. ;  probably only be true if <number> is a member of the field of scalars.
  389. ;  <number> * <scalar> is SCALARP since <scalar> + <scalar> is SCALARP.
  390. ;  Also, this has to be done to make <scalar> - <scalar> SCALARP.
  391.          ((MEMQ (CAAR EXP) '(MPLUS MTIMES))
  392.           (DO ((L (CDR EXP) (CDR L))) ((NULL L) '$SCALAR)
  393.           (IF (NOT (CONSTTERMP (CAR L)))
  394.               (RETURN (SCALARCLASS-LIST L)))))
  395.          ((AND (EQ (CAAR EXP) 'MQAPPLY) (SCALARCLASS (CADR EXP))))
  396.          ((MXORLISTP EXP) '$NONSCALAR)
  397. ;  If we can't find out anything about the operator, then look at the arguments
  398. ;  to the operator.  I think NIL should be returned at this point.  -cwh
  399.          (T (DO ((EXP (CDR EXP) (CDR EXP)) (L))
  400.             ((NULL EXP) (SCALARCLASS-LIST L))
  401.             (IF (NOT (CONSTTERMP (CAR EXP)))
  402.                 (SETQ L (CONS (CAR EXP) L)))))))
  403.  
  404. ;  Could also do <scalar> +|-|*|/ |^ <declared constant>, but this is not
  405. ;  always correct and could screw somebody.
  406.  
  407. ;  SCALARCLASS-LIST takes a list of expressions as its argument.  If their
  408. ;  scalarclasses all agree, then that scalarclass is returned.
  409.  
  410. (DEFUN SCALARCLASS-LIST (LLIST)
  411.        (COND ((NULL LLIST) NIL)
  412.          ((NULL (CDR LLIST)) (SCALARCLASS (CAR LLIST)))
  413.          (T (LET ((SC-CAR (SCALARCLASS (CAR LLIST)))
  414.               (SC-CDR (SCALARCLASS-LIST (CDR LLIST))))
  415.              (COND ((OR (EQ SC-CAR '$NONSCALAR)
  416.                 (EQ SC-CDR '$NONSCALAR))
  417.                 '$NONSCALAR)
  418.                ((AND (EQ SC-CAR '$SCALAR) (EQ SC-CDR '$SCALAR))
  419.                 '$SCALAR))))))
  420.  
  421. (DEFMFUN MBAGP (X) (AND (NOT (ATOM X)) (MEMQ (CAAR X) '(MEQUAL MLIST $MATRIX))))
  422.  
  423. (DEFMFUN MEQUALP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MEQUAL)))
  424.  
  425. (DEFMFUN MXORLISTP (X) (AND (NOT (ATOM X)) (MEMQ (CAAR X) '(MLIST $MATRIX))))
  426.  
  427. (DEFUN MXORLISTP1 (X)
  428.        (AND (NOT (ATOM X))
  429.         (OR (EQ (CAAR X) '$MATRIX)
  430.         (AND (EQ (CAAR X) 'MLIST) $LISTARITH))))
  431.  
  432. (DEFMFUN CONSTFUN (X)
  433.      X  ; Arg ignored.  Function used for mapping down lists.
  434.      *CONST*)
  435.  
  436. (DEFUN CONSTMX (*CONST* X) (SIMPLIFYA (FMAPL1 'CONSTFUN X) T))
  437.  
  438. (DEFMFUN ISINOP (EXP VAR)  ; VAR is assumed to be an atom
  439.  (COND ((ATOM EXP) NIL)
  440.        ((AND (EQ (CAAR EXP) VAR) (NOT (MEMQ 'array (CDAR EXP)))))
  441.        (T (DO ((EXP (CDR EXP) (CDR EXP))) ((NULL EXP))
  442.           (COND ((ISINOP (CAR EXP) VAR) (RETURN T)))))))
  443.  
  444. (DEFMFUN FREE (EXP VAR)
  445.   (COND ((ALIKE1 EXP VAR) NIL)
  446.     ((ATOM EXP) T)
  447.     (T (AND (FREE (CAAR EXP) VAR) (FREEL (CDR EXP) VAR)))))
  448.  
  449. (DEFMFUN FREEL (L VAR)
  450.  (DO ((L L (CDR L))) ((NULL L) T)
  451.      (COND ((NOT (FREE (CAR L) VAR)) (RETURN NIL)))))
  452.  
  453. (DEFMFUN FREEARGS (EXP VAR)
  454.   (COND ((ALIKE1 EXP VAR) NIL)
  455.     ((ATOM EXP) T)
  456.     (T (DO ((L (MARGS EXP) (CDR L))) ((NULL L) T)
  457.            (COND ((NOT (FREEARGS (CAR L) VAR)) (RETURN NIL)))))))
  458.  
  459. (DEFMFUN SIMPLIFYA (X Y)
  460.   (COND ((ATOM X) (COND ((AND (EQ X '$%PI) $NUMER) %PI-VAL) (T X)))
  461.     ((NOT $SIMP) X)                
  462.     ((ATOM (CAR X))
  463.      (COND ((AND (CDR X) (ATOM (CDR X)))
  464.         (MERROR "~%~S is a cons with an atomic cdr - SIMPLIFYA" X))
  465.            ((GET (CAR X) 'LISP-NO-SIMP)
  466.         ; this feature is to be used with care. it is meant to be
  467.         ; used to implement data objects with minimum of consing.
  468.         ; forms must not bash the DISPLA package. Only new forms
  469.         ; with carefully chosen names should use this feature.
  470.         X)
  471.            (T (CONS (CAR X)
  472.             (MAPCAR (FUNCTION (LAMBDA (X) (SIMPLIFYA X Y)))
  473.                 (CDR X))))))
  474.     ((EQ (CAAR X) 'RAT) (*RED1 X))
  475.     ((AND (NOT DOSIMP) (MEMQ 'SIMP (CDAR X))) X)
  476.     ((EQ (CAAR X) 'MRAT) X)
  477.     ((AND (MEMQ (CAAR X) '(MPLUS MTIMES MEXPT))
  478.           (MEMQ (GET (CAAR X) 'OPERATORS) '(SIMPLUS SIMPEXPT SIMPTIMES))
  479.           (NOT (MEMQ 'array (CDAR X))))
  480.      (COND ((EQ (CAAR X) 'MPLUS) (SIMPLUS X 1 Y))
  481.            ((EQ (CAAR X) 'MTIMES) (SIMPTIMES X 1 Y))
  482.            (T (SIMPEXPT X 1 Y))))
  483.     ((NOT (ATOM (CAAR X)))
  484.      (COND ((OR (EQ (CAAAR X) 'LAMBDA)
  485.             (AND (NOT (ATOM (CAAAR X))) (EQ (CAAAAR X) 'LAMBDA)))
  486.         (MAPPLY1 (CAAR X) (CDR X) (CAAR X) x))
  487.            (T (MERROR "Illegal form - SIMPLIFYA:~%~S" X))))
  488.     ((GET (CAAR X) 'OPERS)
  489.      (LET ((OPERS-LIST *OPERS-LIST)) (OPER-APPLY X Y)))
  490.     ((AND (EQ (CAAR X) 'MQAPPLY)
  491.           (OR (ATOM (CADR X))
  492.           (AND (EQ SUBSTP 'MQAPPLY)
  493.                (OR (EQ (CAR (CADR X)) 'LAMBDA)
  494.                (EQ (CAAR (CADR X)) 'LAMBDA)))))
  495.      (COND ((OR (SYMBOLP (CADR X)) (NOT (ATOM (CADR X))))
  496.         (SIMPLIFYA (CONS (CONS (CADR X) (CDAR X)) (CDDR X)) Y))
  497.            ((OR (NOT (MEMQ 'array (CDAR X))) (NOT $SUBNUMSIMP))
  498.         (MERROR "Improper value in functional position:~%~M" X))
  499.            (T (CADR X))))
  500. ;;sometimes want function or closure!
  501. ;        ((and (not (symbolp (caar x)))
  502. ;          (functionp (caar x))) (show (caar x))
  503. ;     (apply (caar x) (cdr x)))
  504.     (T (LET ((W (GET (CAAR X) 'OPERATORS)))
  505.         (COND ((AND W (OR (NOT (MEMQ 'array (CDAR X))) (RULECHK (CAAR X))))
  506.                (FUNCALL W X 1 Y))
  507.               (T (SIMPARGS X Y)))))))
  508.  
  509.   
  510. (DEFMFUN EQTEST (X CHECK)
  511.       ((LAMBDA (Y)
  512.     (COND ((OR (ATOM X) (EQ (CAAR X) 'RAT) (EQ (CAAR X) 'MRAT)
  513.            (MEMQ 'SIMP (CDAR X)))
  514.            X)
  515.           ((AND (EQ (CAAR X) (CAAR CHECK)) (EQUAL (CDR X) (CDR CHECK)))
  516.            (COND ((AND (NULL (CDAR CHECK))
  517.                (SETQ Y (GET (CAAR CHECK) 'MSIMPIND)))
  518.               (CONS Y (CDR CHECK)))
  519.              ((MEMQ 'SIMP (CDAR CHECK)) CHECK)
  520.              (T (CONS (CONS (CAAR CHECK)
  521.                     (COND ((CDAR CHECK) (CONS 'SIMP (CDAR CHECK)))
  522.                       (T '(SIMP))))
  523.                   (CDR CHECK)))))
  524.           ((SETQ Y (GET (CAAR X) 'MSIMPIND)) (RPLACA X Y))
  525.           ((OR (MEMQ 'array (CDAR X))
  526.            (AND (EQ (CAAR X) (CAAR CHECK))
  527.             (MEMQ 'array (CDAR CHECK))))
  528.            (RPLACA X (CONS (CAAR X) '(SIMP ARRAY))))
  529.           (T (RPLACA X (CONS (CAAR X) '(SIMP))))))
  530.        NIL))
  531.  
  532. (DEFUN RULECHK (X) (OR (MGET X 'OLDRULES) (GET X 'RULES)))
  533.  
  534. (DEFMFUN RESIMPLIFY (X) (LET ((DOSIMP T)) (SIMPLIFYA X NIL)))
  535.  
  536. (DEFMFUN SSIMPLIFYA (X) (LET ((DOSIMP T)) (SIMPLIFYA X NIL)))  ; temporary
  537.  
  538. ;(DEFMFUN SIMPARGS (X Y)
  539. ; (IF (OR (EQ (GET (CAAR X) 'DIMENSION) 'DIMENSION-INFIX)
  540. ;     (GET (CAAR X) 'BINARY))
  541. ;     (TWOARGCHECK X))
  542. ; (EQTEST
  543. ;  (COND (Y X)
  544. ;    (T (LET ((FLAG (MEMQ (CAAR X) '(MLIST MEQUAL))))
  545. ;        (CONS (NCONS (CAAR X))
  546. ;              (MAPCAR #'(LAMBDA (J)
  547. ;                 (COND (FLAG (SIMPLIFYA J NIL))
  548. ;                       (T (SIMPCHECK J NIL))))
  549. ;                  (CDR X))))))
  550. ;  X))
  551. ;Update from F302 --gsb
  552. (DEFUN SIMPARGS (X Y)
  553.   (IF (OR (EQ (GET (CAAR X) 'DIMENSION) 'DIMENSION-INFIX)
  554.       (GET (CAAR X) 'BINARY))
  555.       (TWOARGCHECK X))
  556.   (IF (AND (MEMQ 'array (CDAR X)) (NULL (MARGS X)))
  557.       (MERROR "Subscripted variable found with no subscripts."))
  558.   (EQTEST (IF Y X (LET ((FLAG (MEMQ (CAAR X) '(MLIST MEQUAL))))
  559.             (CONS (NCONS (CAAR X))
  560.               (MAPCAR #'(LAMBDA (U)
  561.                      (IF FLAG (SIMPLIFYA U NIL)
  562.                           (SIMPCHECK U NIL)))
  563.                   (CDR X)))))
  564.       X))
  565.  
  566. (DEFMFUN ADDK (XX YY)  ; Xx and Yy are assumed to be alreadyy reduced
  567.  (COND ((EQUAL XX 0) YY)
  568.        ((EQUAL YY 0) XX)
  569.        ((AND (NUMBERP XX) (NUMBERP YY)) (PLUS XX YY))
  570.        ((OR ($BFLOATP Xx) ($BFLOATP Yy)) ($BFLOAT (LIST '(MPLUS) Xx Yy)))
  571.        (T (PROG (G A B (x xx)(y yy))
  572.         (COND ((NUMBERP X)
  573.                (COND ((FLOATP X) (RETURN (PLUS X (FPCOFRAT Y))))
  574.                  (T (SETQ X (LIST '(RAT) X 1)))))
  575.               ((NUMBERP Y)
  576.                (COND ((FLOATP Y) (RETURN (PLUS Y (FPCOFRAT X))))
  577.                  (T (SETQ Y (LIST '(RAT) Y 1))))))
  578.         (SETQ G (GCD (CADDR X) (CADDR Y)))
  579.         (SETQ A (*QUO (CADDR X) G) B (*QUO (CADDR Y) G))
  580.         (SETQ G (TIMESKL (LIST '(RAT) 1 G)
  581.                  (LIST '(RAT)
  582.                        (PLUS (TIMES (CADR X) B)
  583.                          (TIMES (CADR Y) A))
  584.                        (TIMES A B))))
  585.         (RETURN (COND ((NUMBERP G) G)
  586.                   ((EQUAL (CADDR G) 1) (CADR G)) 
  587.                   ($FLOAT (FPCOFRAT G))
  588.                   (T G)))))))
  589.  
  590. #-Franz
  591. (DEFUN *RED1 (X)
  592.  (COND ((MEMQ 'SIMP (CDAR X)) (COND ($FLOAT (FPCOFRAT X)) (T X)))
  593.        (T (*RED (CADR X) (CADDR X)))))
  594. #-lispm
  595. (DEFUN *RED (N D)
  596.        (COND ((ZEROP N) 0)
  597.          ((EQUAL D 1) N)
  598.          (T (LET ((U (GCD N D)))
  599.              (SETQ N (*QUO N U) D (*QUO D U))
  600.              (IF (MINUSP D) (SETQ N (MINUS N) D (MINUS D)))
  601.              (COND ((EQUAL D 1) N)
  602.                ($FLOAT (FPCOFRAT1 N D))
  603.                (T (LIST '(RAT SIMP) N D)))))))
  604.  
  605.  
  606.  
  607. #+lispm
  608. (DEFUN *RED (N D &aux tem )
  609.   (COND ((ZEROP N) 0)
  610.     ((EQUAL D 1) N)
  611.         (t (setq tem (sys:rational-quotient n d))
  612.        (cond ((si:rationalp tem)
  613.           (list '(rat simp)
  614.             (si:rational-numerator tem)
  615.             (si:rational-denominator tem)))
  616.          (t tem)))))
  617.  
  618. (DEFUN NUM1 (A) (IF (NUMBERP A) A (CADR A)))
  619.  
  620. (DEFUN DENOM1 (A) (IF (NUMBERP A) 1 (CADDR A)))
  621.  
  622. (DEFMFUN TIMESK (X Y)  ; X and Y are assumed to be already reduced
  623.  (COND ((EQUAL X 1) Y)
  624.        ((EQUAL Y 1) X)
  625.        ((AND (NUMBERP X) (NUMBERP Y)) (TIMES X Y))
  626.        ((OR ($BFLOATP X) ($BFLOATP Y)) ($BFLOAT (LIST '(MTIMES) X Y)))
  627.        ((FLOATP X) (TIMES X (FPCOFRAT Y)))
  628.        ((FLOATP Y) (TIMES Y (FPCOFRAT X)))
  629.        (T (TIMESKL X Y))))
  630.  
  631. (DEFUN TIMESKL (X Y)
  632.  (PROG (U V G)
  633.        (SETQ U (*RED (NUM1 X) (DENOM1 Y)))
  634.        (SETQ V (*RED (NUM1 Y) (DENOM1 X)))
  635.        (SETQ G (COND ((OR (EQUAL U 0) (EQUAL V 0)) 0)
  636.              ((EQUAL V 1) U)
  637.              ((AND (NUMBERP U) (NUMBERP V)) (TIMES U V))
  638.              (T (LIST '(RAT SIMP)
  639.                   (TIMES (NUM1 U) (NUM1 V))
  640.                   (TIMES (DENOM1 U) (DENOM1 V))))))
  641.        (RETURN (COND ((NUMBERP G) G)
  642.              ((EQUAL (CADDR G) 1) (CADR G))
  643.              ($FLOAT (FPCOFRAT G))
  644.              (T G)))))
  645.  
  646. (DEFMFUN FPCOFRAT (RATNO) (FPCOFRAT1 (CADR RATNO) (CADDR RATNO)))
  647.  
  648. ;--- fpcofrat1  :: Floating Point Conversion OF RATional number routine
  649. ;  find floating point approximation to rational number
  650. ;  fpcofrat1 computes the quotient of nu/d
  651. ;  It checks for the case of the division of two bignums because
  652. ;  simply computing (quotient (float nu) (float d)) may cause one of
  653. ;  the floats to overflow even if the quotient is within the floating
  654. ;  point range.
  655. ;  If both nu and d are bignums, then the smaller one is reduced to the 
  656. ;  'machine-mantissa-precision' most significant bits.  The other one is
  657. ;  then reduced by stripping off the exact same number of rightmost bits.
  658. ;  'machine-mantissa-precision' is related to the length of the significand 
  659. ;  in the floating point representation: it doesn't make sense to maintain
  660. ;  any more bits than can be represented in the significand of a floating
  661. ;  point number.
  662. (eval-when (compile load)
  663. (defconstant machine-mantissa-precision
  664.   (float-digits 1d0))
  665. )
  666. (DEFUN FPCOFRAT1 (NU D)
  667.   (IF (AND (BIGP NU) (BIGP D))
  668.       (LET ((SIGN (IF (MINUSP NU) (PLUSP D) (MINUSP D)))
  669.         (LN (HAULONG NU)) (LD (HAULONG D)))
  670.     (IF (> LN LD)
  671.         (SETQ D (HAIPART D #.machine-mantissa-precision)
  672.           NU (HAIPART NU (f- LN (f- LD #.machine-mantissa-precision))))
  673.         (SETQ NU (HAIPART NU #.machine-mantissa-precision)
  674.           D (HAIPART D (f- LD (f- LN #.machine-mantissa-precision)))))
  675.     (IF SIGN (SETQ NU (MINUS NU)))))
  676.   (*QUO (FLOAT NU) D))
  677.  
  678. ; Definition of FPCOFRAT1 below semi-coloned out on 3/7/81 by JPG 
  679. ; until it gives 0.0 for FLOAT(33^-33); rather than 8.9684807E+26
  680. ;(DEFUN FPCOFRAT1 (NU D)
  681. ; (DECLARE (FIXNUM FP-PREC SCALE-FAC))
  682. ; (IF (OR (BIGP NU) (BIGP D))
  683. ;     (LET* ((SIGN (IF (MINUSP NU) (PLUSP D) (MINUSP D)))
  684. ;        (FP-PREC 35.)
  685. ;    ;; upper bound on number of bits of mantissa supplied for f.p. numbers
  686. ;    ;; 35. is big enough to be ok for mc,multics,lispm
  687. ;    ;; RJF said he was going to use his own code for franz.
  688. ;    ;; Does he want a #-Franz around this code? - BMT and JPG
  689. ;        (SCALE-FAC (f- (MAX FP-PREC (HAULONG NU))
  690. ;              (MAX FP-PREC (HAULONG D)))))
  691. ;         (SETQ NU (HAIPART (ABS NU) FP-PREC) D (HAIPART (ABS D) FP-PREC))
  692. ;       (IF SIGN (SETQ NU (MINUS NU)))
  693. ;       (FSC (*QUO (FLOAT NU) D) SCALE-FAC))
  694. ;    ;; Does the LISPM have FSC?
  695. ;      (*QUO (FLOAT NU) D)))
  696.  
  697. (DEFUN EXPTA (X Y) (COND ((EQUAL Y 1) X)
  698.              ((NUMBERP X) (EXPTB X (NUM1 Y)))
  699.              (($BFLOATP X) ($BFLOAT (LIST '(MEXPT) X Y)))
  700.              ((MINUSP (NUM1 Y))
  701.               (*RED (EXPTB (CADDR X) (MINUS (NUM1 Y)))
  702.                 (EXPTB (CADR X) (MINUS (NUM1 Y)))))
  703.              (T (*RED (EXPTB (CADR X) (NUM1 Y))
  704.                   (EXPTB (CADDR X) (NUM1 Y))))))
  705.  
  706. (DEFUN EXPTB (A B)
  707.  (COND ((EQUAL A %E-VAL) (EXP B))
  708.        ((OR (FLOATP A) (NOT (MINUSP B))) (EXPT A B))
  709.        (T (SETQ B (EXPT A (MINUS B))) (*RED 1 B))))
  710.  
  711. (DEFMFUN SIMPLUS (X W Z)  ; W must be 1
  712.   (PROG (RES CHECK EQNFLAG MATRIXFLAG SUMFLAG)
  713.     (IF (NULL (CDR X)) (RETURN 0))
  714.     (SETQ CHECK X)
  715.    START(SETQ X (CDR X))
  716.     (IF (NULL X) (GO END))
  717.     (SETQ W (IF Z (CAR X) (SIMPLIFYA (CAR X) NIL)))
  718.    ST1  (COND
  719.      ((ATOM W) NIL)
  720.      ((EQ (CAAR W) 'MRAT)
  721.       (COND ((OR EQNFLAG MATRIXFLAG
  722.              (AND SUMFLAG (NOT (MEMQ 'TRUNC (CDAR W))))
  723.              (SPSIMPCASES (CDR X) W))
  724.          (SETQ W (RATDISREP W)) (GO ST1))
  725.         (T (RETURN (RATF (CONS '(MPLUS)
  726.                        (NCONC (MAPCAR #'SIMPLIFY (CONS W (CDR X)))
  727.                           (CDR RES))))))))
  728.      ((EQ (CAAR W) 'MEQUAL)
  729.       (SETQ EQNFLAG
  730.         (IF (NOT EQNFLAG)
  731.             W
  732.             (LIST (CAR EQNFLAG)
  733.               (ADD2 (CADR EQNFLAG) (CADR W))
  734.               (ADD2 (CADDR EQNFLAG) (CADDR W)))))
  735.       (GO START))
  736.      ((MEMQ (CAAR W) '(MLIST $MATRIX)) 
  737.       (SETQ MATRIXFLAG
  738.         (COND ((NOT MATRIXFLAG) W)
  739.               ((AND (OR $DOALLMXOPS $DOMXMXOPS $DOMXPLUS
  740.                 (AND (EQ (CAAR W) 'MLIST) ($LISTP MATRIXFLAG)))
  741.                 (OR (NOT (EQ (CAAR W) 'MLIST)) $LISTARITH))
  742.                (ADDMX MATRIXFLAG W))
  743.               (T (SETQ RES (PLS W RES)) MATRIXFLAG)))
  744.       (GO START))
  745.      ((EQ (CAAR W) '%SUM)
  746.       (SETQ SUMFLAG T RES (SUMPLS W RES))
  747.       (SETQ W (CAR RES) RES (CDR RES))))
  748.     (SETQ RES (PLS W RES))
  749.     (GO START)
  750.    END  (SETQ RES (TESTP RES))
  751.     (IF MATRIXFLAG
  752.         (SETQ RES (COND ((ZEROP1 RES) MATRIXFLAG)
  753.                 ((AND (OR ($LISTP MATRIXFLAG)
  754.                       $DOALLMXOPS $DOSCMXPLUS $DOSCMXOPS)
  755.                   (OR (NOT ($LISTP MATRIXFLAG)) $LISTARITH))
  756.                  (MXPLUSC RES MATRIXFLAG))
  757.                 (T (TESTP (PLS MATRIXFLAG (PLS RES NIL)))))))
  758.     (SETQ RES (EQTEST RES CHECK))
  759.     (RETURN (IF EQNFLAG
  760.             (LIST (CAR EQNFLAG)
  761.               (ADD2 (CADR EQNFLAG) RES)
  762.               (ADD2 (CADDR EQNFLAG) RES))
  763.             RES))))
  764.  
  765. (DEFUN MXPLUSC (SC MX)
  766.   (COND ((MPLUSP SC)
  767.      (SETQ SC (PARTITION-NS (CDR SC)))
  768.      (COND ((NULL (CAR SC)) (CONS '(MPLUS) (CONS MX (CADR SC))))
  769.            ((NOT (NULL (CADR SC)))
  770.         (CONS '(MPLUS)
  771.               (CONS (SIMPLIFY
  772.                  (OUTERMAP1 'MPLUS (CONS '(MPLUS) (CAR SC)) MX))
  773.                 (CADR SC))))
  774.            (T (SIMPLIFY (OUTERMAP1 'MPLUS (CONS '(MPLUS) (CAR SC)) MX)))))
  775.     ((NOT (SCALAR-OR-CONSTANT-P SC $ASSUMESCALAR))
  776.      (TESTP (PLS MX (PLS SC NIL))))
  777.     (T (SIMPLIFY (OUTERMAP1 'MPLUS SC MX)))))
  778.  
  779. (DEFUN PARTITION-NS (X)
  780.   (LET (SP NSP) ; SP = scalar part, NSP = nonscalar part
  781.     (MAPC #'(LAMBDA (Z) (IF (SCALAR-OR-CONSTANT-P Z $ASSUMESCALAR)
  782.                 (SETQ SP (CONS Z SP))
  783.                 (SETQ NSP (CONS Z NSP))))
  784.       X)
  785.     (LIST (NREVERSE SP) (NREVERSE NSP))))
  786.  
  787. (DEFUN ADDMX (X1 X2)
  788.  (LET (($DOSCMXOPS T) ($DOMXMXOPS T) ($LISTARITH T))
  789.    (SIMPLIFY (FMAPL1 'MPLUS X1 X2))))
  790.  
  791. (DEFUN PLUSIN (X FM)
  792.   (PROG (X1 FLAG CHECK W XNEW)
  793.     (SETQ W 1)
  794.     (COND ((MTIMESP X)
  795.            (SETQ CHECK X)
  796.            (IF (MNUMP (CADR X)) (SETQ W (CADR X) X (CDDR X))
  797.                     (SETQ X (CDR X))))
  798.           (T (SETQ X (NCONS X))))
  799.     (SETQ X1 (IF (NULL (CDR X)) (CAR X) (CONS '(MTIMES) X))
  800.           XNEW (LIST* '(MTIMES) W X))
  801.    START(COND ((NULL (CDR FM)))
  802.           ((MTIMESP (CADR FM))
  803.            (SETQ FLAG (CDADR FM))
  804.            (COND ((OR (AND (MNUMP (CAR FLAG)) (ALIKE X (CDR FLAG)))
  805.               (ALIKE1 X1 (CADR FM)))
  806.               (GO EQUT))
  807.              ((GREAT XNEW (CADR FM)) (GO GR))))
  808.           ((AND (ALIKE1 X1 (CADR FM)) (NULL (CDR X))) (GO EQU))
  809.           ((GREAT X1 (CADR FM)) (GO GR)))
  810.     (SETQ FLAG (EQTEST (TESTT XNEW) (OR CHECK '((FOO)))))
  811.     (RETURN (CDR (RPLACD FM (CONS FLAG (CDR FM)))))
  812.    GR    (SETQ FM (CDR FM))
  813.     (GO START)
  814.    EQU    (RPLACA (CDR FM) (TESTTNEG (LIST* '(MTIMES SIMP) (ADDK 1 W) X)))
  815.    DEL    (COND ((NOT (MTIMESP (CADR FM))) (GO CHECK))
  816.           ((ONEP1 (CADADR FM))
  817.            (RPLACD (CADR FM) (CDDADR FM)) (RETURN (CDR FM)))
  818.           ((NOT (ZEROP1 (CADADR FM))) (RETURN (CDR FM))))
  819.     (RETURN (RPLACD FM (CDDR FM)))
  820.    EQUT (SETQ X1 (TESTTNEG (LIST* '(MTIMES SIMP)
  821.                   (ADDK (COND ((MNUMP (CADADR FM))
  822.                            (SETQ FLAG T) (CADADR FM))
  823.                           (T (SETQ FLAG NIL) 1))
  824.                     W)
  825.                   X)))
  826.     (RPLACA (CDR FM) X1)
  827.     (IF (NOT (MTIMESP X1)) (GO CHECK))
  828.     (WHEN (AND (ONEP1 (CADADR FM)) FLAG (NULL (CDDDR (CADR FM))))
  829.       (RPLACA (CDR FM) (CADDR (CADR FM))) (GO CHECK))
  830.     (GO DEL)
  831.    CHECK(IF (MPLUSP (CADR FM)) (SETQ PLUSFLAG T))
  832.     (RETURN (CDR FM))))
  833.  
  834. (DEFMFUN SIMPLN (X Y Z)
  835.    (ONEARGCHECK X)
  836.    (COND ((ONEP1 (SETQ Y (SIMPCHECK (CADR X) Z))) (ADDK -1 Y))
  837.      ((ZEROP1 Y)
  838.       (COND (RADCANP (LIST '(%LOG SIMP) 0))
  839.         ((NOT ERRORSW) (MERROR "LOG(0) has been generated."))
  840.         (T (THROW 'ERRORSW T))))
  841.      ((EQ Y '$%E) 1)
  842.      ((RATNUMP Y)
  843.       (COND ((EQUAL (CADR Y) 1) (SIMPLN1 (LIST NIL (CADDR Y) -1)))
  844.         ((EQ $LOGEXPAND '$SUPER)
  845.          (SIMPLIFYA (LIST '(MPLUS) (SIMPLIFYA (LIST '(%LOG) (CADR Y)) T)
  846.                   (SIMPLN1 (LIST NIL (CADDR Y) -1))) T))
  847.         (T (EQTEST (LIST '(%LOG) Y) X))))
  848.      ((AND $LOGEXPAND (MEXPTP Y)) (SIMPLN1 Y))
  849.      ((AND (MEMQ $LOGEXPAND '($ALL $SUPER)) (MTIMESP Y))
  850.       (PROG (B)
  851.         (SETQ Y (CDR Y))
  852.        LOOP (SETQ B (CONS (COND ((NOT (MEXPTP (CAR Y))) 
  853.                      (SIMPLIFYA (LIST '(%LOG) (CAR Y)) T))
  854.                     (T (SIMPLN1 (CAR Y)))) B))
  855.         (COND ((NULL (SETQ Y (CDR Y)))
  856.                (RETURN (SIMPLIFYA (CONS '(MPLUS) B) T))))
  857.         (GO LOOP)))
  858.      (($BFLOATP Y) ($BFLOAT (LIST '(%LOG) Y)))
  859.      ((OR (FLOATP Y) (AND $NUMER (INTEGERP Y)))
  860.       (COND ((PLUSP Y) (LOG Y))
  861.         ($LOGNUMER (COND ((EQUAL Y -1) 0) (T (LOG (MINUS Y)))))
  862.         (T (ADD2 (LOG (MINUS Y)) (MUL2 '$%I %PI-VAL)))))
  863.      ((AND $LOGNEGINT (MAXIMA-INTEGERP Y) (EQ ($SIGN Y) '$NEG))
  864.       (ADD2 '((MTIMES SIMP) $%I $%PI)
  865.         (COND ((EQUAL Y -1) 0) (T (LIST '(%LOG SIMP) (NEG Y))))))
  866.      (T (EQTEST (LIST '(%LOG) Y) X))))
  867.  
  868. (DEFUN SIMPLN1 (W)
  869.        (SIMPLIFYA (LIST '(MTIMES) (CADDR W)
  870.             (SIMPLIFYA (LIST '(%LOG) (CADR W)) T)) T))
  871.  
  872. (DEFMFUN SIMPSQRT (X VESTIGIAL Z)
  873.  VESTIGIAL ;Ignored.       
  874.  (ONEARGCHECK X)
  875.  (SIMPLIFYA (LIST '(MEXPT) (CADR X) '((RAT SIMP) 1 2)) Z))
  876.  
  877. (DEFMFUN SIMPQUOT (X Y Z)
  878.  (TWOARGCHECK X)
  879.  (COND ((AND (INTEGERP (CADR X)) (INTEGERP (CADDR X)) (NOT (ZEROP (CADDR X))))
  880.     (*RED (CADR X) (CADDR X)))
  881.        ((AND (NUMBERP (CADR X)) (NUMBERP (CADDR X)) (NOT (ZEROP (CADDR X))))
  882.     (*QUO (CADR X) (CADDR X)))
  883.        (T (SETQ Y (SIMPLIFYA (CADR X) Z))
  884.       (SETQ X (SIMPLIFYA (LIST '(MEXPT) (CADDR X) -1) Z))
  885.       (IF (EQUAL Y 1) X (SIMPLIFYA (LIST '(MTIMES) Y X) T)))))
  886.  
  887. ;; Obsolete.  Use DIV*.  All references to this should now be flushed.
  888. ;; This definition will go away soon.
  889.  
  890. ;(DEFUN QSNT (X Y) (SIMPLIFY (LIST '(MTIMES) X (LIST '(MEXPT) Y -1))))
  891.  
  892. (DEFMFUN SIMPABS (X Y Z) 
  893.   (ONEARGCHECK X)
  894.   (SETQ Y (SIMPCHECK (CADR X) Z))
  895.   (COND ((NUMBERP Y) (ABS Y)) 
  896.     ((OR (RATNUMP Y) ($BFLOATP Y)) (LIST (CAR Y) (ABS (CADR Y)) (CADDR Y))) 
  897.     ((EQ (SETQ Z (CSIGN Y)) T) (CABS Y))
  898.     ((MEMQ Z '($POS $PZ)) Y) 
  899.     ((MEMQ Z '($NEG $NZ)) (NEG Y)) 
  900.     ((EQ Z '$ZERO) 0)
  901.     ((AND (MEXPTP Y) (INTEGERP (CADDR Y)))
  902.      (LIST (CAR Y) (SIMPABS (LIST '(MABS) (CADR Y)) NIL T) (CADDR Y)))
  903.     ((MTIMESP Y)
  904.      (MULN (MAPCAR #'(LAMBDA (U) (SIMPABS (LIST '(MABS) U) NIL T)) (CDR Y)) T))
  905.     ((MMINUSP Y) (LIST '(MABS SIMP) (NEG Y)))
  906.     ((MBAGP Y)
  907.      (CONS (CAR Y)
  908.            (MAPCAR #'(LAMBDA (U) (SIMPABS (LIST '(MABS) U) NIL T)) (CDR Y))))
  909.     (T (EQTEST (LIST '(MABS) Y) X))))
  910.  
  911. (DEFUN PLS (X OUT)
  912.        (PROG (FM PLUSFLAG)
  913.          (IF (MTIMESP X) (SETQ X (TESTTNEG X)))
  914.          (COND ((NULL OUT)
  915.             (RETURN
  916.              (CONS '(MPLUS)
  917.                (COND ((MNUMP X) (NCONS X))
  918.                  ((NOT (MPLUSP X))
  919.                   (LIST 0 (COND ((ATOM X) X) (T (copy-top-level X)))))
  920.                  ((MNUMP (CADR X)) (copy-top-level (CDR X) ))
  921.                  (T (CONS 0 (copy-top-level (CDR X) )))))))
  922.            ((MNUMP X)
  923.             (RETURN (CONS '(MPLUS)
  924.                   (IF (MNUMP (CADR OUT))
  925.                       (CONS (ADDK (CADR OUT) X) (CDDR OUT))
  926.                       (CONS X (CDR OUT))))))
  927.            ((NOT (MPLUSP X)) (PLUSIN X (CDR OUT)) (GO END)))
  928.          (RPLACA (CDR OUT)
  929.              (ADDK (IF (MNUMP (CADR OUT)) (CADR OUT) 0)
  930.                (COND ((MNUMP (CADR X)) (SETQ X (CDR X)) (CAR X)) (T 0))))
  931.          (SETQ FM (CDR OUT))
  932.     START(IF (NULL (SETQ X (CDR X))) (GO END))
  933.          (SETQ FM (PLUSIN (CAR X) FM))
  934.          (GO START)
  935.      END  (IF (NOT PLUSFLAG) (RETURN OUT))
  936.          (SETQ PLUSFLAG NIL)  ; PLUSFLAG T handles e.g.
  937.     A    (SETQ FM (CDR OUT))  ;    a+b+3*(a+b)-2*(a+b)
  938.     LOOP (WHEN (MPLUSP (CADR FM))
  939.            (SETQ X (CADR FM)) (RPLACD FM (CDDR FM))
  940.            (PLS X OUT) (GO A))
  941.          (SETQ FM (CDR FM))
  942.          (IF (NULL (CDR FM)) (RETURN OUT))
  943.          (GO LOOP)))
  944.  
  945. (DEFUN TESTT (X)
  946.  (COND ((MNUMP X) X)
  947.        ((NULL (CDDR X)) (CADR X))
  948.        ((ONEP1 (CADR X))
  949.     (COND ((NULL (CDDDR X)) (CADDR X)) (T (RPLACD X (CDDR X)))))
  950.        (T (TESTTNEG X))))
  951.  
  952. (DEFUN TESTTNEG (X)
  953.  (COND ((AND (EQUAL (CADR X) -1) (NULL (CDDDR X)) (MPLUSP (CADDR X)) $NEGDISTRIB)
  954.     (ADDN (MAPCAR (FUNCTION (LAMBDA (Z) (MUL2 -1 Z))) (CDADDR X)) T))
  955.        (T X)))
  956.  
  957. (DEFUN TESTP (X) (COND ((ATOM X) 0)
  958.                ((NULL (CDDR X)) (CADR X))
  959.                ((ZEROP1 (CADR X))
  960.             (COND ((NULL (CDDDR X)) (CADDR X)) (T (RPLACD X (CDDR X)))))
  961.                (T X)))
  962.  
  963. (DEFUN SIMPMIN (X VESTIGIAL Z)
  964.   VESTIGIAL ;Ignored       
  965.  (ONEARGCHECK X)
  966.  (COND ((NUMBERP (CADR X)) (MINUS (CADR X)))
  967.        ((ATOM (CADR X)) (LIST '(MTIMES SIMP) -1 (CADR X)))
  968.        (T (SIMPLIFYA (LIST '(MTIMES) -1 (SIMPLIFYA (CADR X) Z)) T))))
  969.  
  970. (DEFMFUN SIMPTIMES (X W Z)  ; W must be 1
  971.   (PROG (RES CHECK EQNFLAG MATRIXFLAG SUMFLAG)
  972.     (IF (NULL (CDR X)) (RETURN 1))
  973.     (SETQ CHECK X)
  974.    START(SETQ X (CDR X))
  975.     (COND ((ZEROP1 RES)
  976.            (COND ($MX0SIMP
  977.               (COND ((AND MATRIXFLAG (MXORLISTP1 MATRIXFLAG))
  978.                  (RETURN (CONSTMX RES MATRIXFLAG)))
  979.                 (EQNFLAG (RETURN (LIST '(MEQUAL SIMP)
  980.                            (MUL2 RES (CADR EQNFLAG))
  981.                            (MUL2 RES (CADDR EQNFLAG)))))
  982.                 (T (DOLIST (U X)
  983.                 (COND ((MXORLISTP1 U)
  984.                        (RETURN
  985.                     (SETQ RES (CONSTMX RES U))))
  986.                       ((AND (MEXPTP U)
  987.                         (MXORLISTP1 (CADR U))
  988.                         ($NUMBERP (CADDR U)))
  989.                        (RETURN
  990.                     (SETQ RES (CONSTMX RES (CADR U)))))
  991.                       ((MEQUALP U)
  992.                        (RETURN
  993.                     (SETQ RES (LIST '(MEQUAL SIMP)
  994.                                 (MUL2 RES (CADR U))
  995.                                 (MUL2 RES (CADDR U))))))))))))
  996.            (RETURN RES))
  997.           ((NULL X) (GO END)))
  998.     (SETQ W (IF Z (CAR X) (SIMPLIFYA (CAR X) NIL)))
  999.    ST1  (COND
  1000.      ((ATOM W) NIL)
  1001.      ((EQ (CAAR W) 'MRAT)
  1002.       (COND ((OR EQNFLAG MATRIXFLAG
  1003.              (AND SUMFLAG (NOT (MEMQ 'TRUNC (CDAR W))))
  1004.              (SPSIMPCASES (CDR X) W))
  1005.          (SETQ W (RATDISREP W)) (GO ST1))
  1006.         (T (RETURN (RATF (CONS '(MTIMES)
  1007.                        (NCONC (MAPCAR #'SIMPLIFY (CONS W (CDR X)))
  1008.                           (CDR RES))))))))
  1009.      ((EQ (CAAR W) 'MEQUAL)
  1010.       (SETQ EQNFLAG
  1011.         (IF (NOT EQNFLAG)
  1012.             W
  1013.             (LIST (CAR EQNFLAG)
  1014.               (MUL2 (CADR EQNFLAG) (CADR W))
  1015.               (MUL2 (CADDR EQNFLAG) (CADDR W)))))
  1016.       (GO START))
  1017.      ((MEMQ (CAAR W) '(MLIST $MATRIX))
  1018.       (SETQ MATRIXFLAG
  1019.         (COND ((NOT MATRIXFLAG) W)
  1020.               ((AND (OR $DOALLMXOPS $DOMXMXOPS $DOMXTIMES)
  1021.                 (OR (NOT (EQ (CAAR W) 'MLIST)) $LISTARITH)
  1022.                 (NOT (EQ *INV* '$DETOUT)))
  1023.                (STIMEX MATRIXFLAG W))
  1024.               (T (SETQ RES (TMS W 1 RES)) MATRIXFLAG)))
  1025.       (GO START))
  1026.      ((AND (EQ (CAAR W) '%SUM) $SUMEXPAND)
  1027.       (SETQ SUMFLAG (SUMTIMES SUMFLAG W)) (GO START)))
  1028.     (SETQ RES (TMS W 1 RES))
  1029.     (GO START)
  1030.    END  (COND ((MTIMESP RES) (SETQ RES (TESTT RES))))
  1031.     (COND (SUMFLAG (SETQ RES (COND ((OR (NULL RES) (EQUAL RES 1)) SUMFLAG)
  1032.                        ((NOT (MTIMESP RES))
  1033.                     (LIST '(MTIMES) RES SUMFLAG))
  1034.                        (T (NCONC RES (LIST SUMFLAG)))))))
  1035.     (COND ((OR (ATOM RES)
  1036.            (NOT (MEMQ (CAAR RES) '(MEXPT MTIMES)))          
  1037.            (AND (ZEROP $EXPOP) (ZEROP $EXPON))
  1038.            EXPANDFLAG))
  1039.           ((EQ (CAAR RES) 'MTIMES) (SETQ RES (EXPANDTIMES RES)))
  1040.           ((AND (MPLUSP (CADR RES))
  1041.             (FIXNUMP (CADDR RES))
  1042.             (NOT (OR (GREATERP (CADDR RES) $EXPOP)
  1043.                  (GREATERP (MINUS (CADDR RES)) $EXPON))))
  1044.            (SETQ RES (EXPANDEXPT (CADR RES) (CADDR RES)))))
  1045.     (COND (MATRIXFLAG 
  1046.            (SETQ RES (COND ((NULL RES) MATRIXFLAG)
  1047.                    ((AND (OR ($LISTP MATRIXFLAG) $DOALLMXOPS 
  1048.                      (AND $DOSCMXOPS (NOT (zl-MEMBER RES '(-1 -1.0))))
  1049.             ;;; RES should only be -1 here (not = 1)
  1050.                      (AND $DOMXMXOPS (zl-MEMBER RES '(-1 -1.0))))
  1051.                      (OR (NOT ($LISTP MATRIXFLAG)) $LISTARITH))
  1052.                 (MXTIMESC RES MATRIXFLAG))
  1053.                    (T (TESTT (TMS MATRIXFLAG 1 (TMS RES 1 NIL))))))))
  1054.     (IF RES (SETQ RES (EQTEST RES CHECK)))
  1055.     (RETURN (COND (EQNFLAG
  1056.                (IF (NULL RES) (SETQ RES 1))
  1057.                (LIST (CAR EQNFLAG)
  1058.                  (MUL2 (CADR EQNFLAG) RES)
  1059.                  (MUL2 (CADDR EQNFLAG) RES)))
  1060.               (T RES)))))
  1061.  
  1062. (DEFUN SPSIMPCASES (L E)
  1063.   (DOLIST (U L)
  1064.     (IF (OR (MBAGP U) (AND (NOT (ATOM U))
  1065.                (EQ (CAAR U) '%SUM)
  1066.                (NOT (MEMQ 'TRUNC (CDAR E)))))
  1067.     (RETURN T))))
  1068.  
  1069. (DEFUN MXTIMESC (SC MX) 
  1070.  (LET (SIGN OUT)
  1071.    (AND (MTIMESP SC) (zl-MEMBER (CADR SC) '(-1 -1.0)) 
  1072.     $DOSCMXOPS (NOT (OR $DOALLMXOPS $DOMXMXOPS $DOMXTIMES))
  1073.     (SETQ SIGN (CADR SC)) (RPLACA (CDR SC) NIL))
  1074.    (SETQ OUT ((LAMBDA (SCP*) 
  1075.        (COND  ((NULL SCP*) (LIST '(MTIMES SIMP) SC MX))
  1076.           ((AND (NOT (ATOM SCP*)) (NULL (CAR SCP*)))
  1077.            (APPEND '((MTIMES)) (CADR SCP*) (LIST MX)))
  1078.           ((OR (ATOM SCP*) (AND (NULL (CDR SCP*)) 
  1079.                     (NOT (NULL (CDR SC)))
  1080.                     (SETQ SCP* (CONS '(MTIMES) (CAR SCP*))))
  1081.                (NOT (MTIMESP SC)))
  1082.             (SIMPLIFYA (OUTERMAP1 'MTIMES SCP* MX) NIL))
  1083.           (T (APPEND '((MTIMES))
  1084.                 (LIST (SIMPLIFYA 
  1085.                        (OUTERMAP1 'MTIMES
  1086.                    (CONS '(MTIMES) (CAR SCP*)) MX)
  1087.                      T))
  1088.                  (CADR SCP*)))))
  1089.     (COND ((MTIMESP SC) (PARTITION-NS (CDR SC)))
  1090.           ((NOT (SCALAR-OR-CONSTANT-P SC $ASSUMESCALAR)) NIL)
  1091.           (T SC))))
  1092.    (COND (SIGN (IF (MTIMESP OUT) (RPLACD OUT (CONS SIGN (CDR OUT)))
  1093.                  (LIST '(MTIMES) SIGN OUT)))
  1094.      ((MTIMESP OUT) (TESTT OUT))
  1095.      (T OUT))))
  1096.  
  1097. (DEFUN STIMEX (X Y) 
  1098.   (LET (($DOSCMXOPS T) ($DOMXMXOPS T) ($LISTARITH T))
  1099.     (SIMPLIFY (FMAPL1 'MTIMES X Y))))
  1100.  
  1101. ;  TMS takes a simplified expression FACTOR and a cumulative
  1102. ;  PRODUCT as arguments and modifies the cumulative product so
  1103. ;  that the expression is now one of its factors.  The
  1104. ;  exception to this occurs when a tellsimp rule is triggered.
  1105. ;  The second argument is the POWER to which the expression is
  1106. ;  to be raised within the product.
  1107.  
  1108. (DEFUN TMS (FACTOR POWER PRODUCT &aux tem)
  1109.  ((LAMBDA (RULESW Z)
  1110.    (COND ((MPLUSP PRODUCT) (SETQ PRODUCT (LIST '(MTIMES SIMP) PRODUCT))))
  1111.    (COND ((ZEROP1 FACTOR)
  1112.       (COND ((MNEGP POWER)
  1113.          (COND (ERRORSW (THROW 'ERRORSW T))
  1114.                (T (MERROR "Division by 0"))))
  1115.         (T FACTOR)))
  1116.      ((AND (NULL PRODUCT)
  1117.            (OR (AND (MTIMESP FACTOR) (EQUAL POWER 1))
  1118.            (AND (SETQ PRODUCT (LIST '(MTIMES) 1)) NIL)))
  1119.       (setq tem (APPEND '((MTIMES)) (COND ((MNUMP (CADR FACTOR)) NIL) (T '(1))) 
  1120.           (CDR FACTOR) NIL))
  1121.       (cond ((eql (length tem) 1)(setq tem (copy-top-level tem)))
  1122.         (t tem))
  1123.       )
  1124.      ((MNUMP FACTOR)
  1125.       (RPLACA (CDR PRODUCT) (TIMESK (CADR PRODUCT) (EXPTA FACTOR POWER)))
  1126.       PRODUCT)
  1127.      ((MTIMESP FACTOR)
  1128.       (COND ((MNUMP (CADR FACTOR))
  1129.          (SETQ FACTOR (CDR FACTOR))
  1130.          (RPLACA (CDR PRODUCT)
  1131.              (TIMESK (CADR PRODUCT) (EXPTA (CAR FACTOR) POWER)))))
  1132.       (DO ((FACTOR-LIST (CDR FACTOR) (CDR FACTOR-LIST)))
  1133.           ((OR (NULL FACTOR-LIST) (ZEROP1 PRODUCT))  PRODUCT)
  1134.           (SETQ Z (TIMESIN (CAR FACTOR-LIST) (CDR PRODUCT) POWER))
  1135.           (COND (RULESW (SETQ RULESW NIL)
  1136.                 (SETQ PRODUCT (TMS-FORMAT-PRODUCT Z))))))
  1137.      (T (SETQ Z (TIMESIN FACTOR (CDR PRODUCT) POWER))
  1138.         (COND (RULESW (TMS-FORMAT-PRODUCT Z)) (T PRODUCT)))))
  1139.   NIL NIL))
  1140.  
  1141. (DEFUN TMS-FORMAT-PRODUCT (X)
  1142.        (COND ((ZEROP1 X) X)
  1143.          ((MNUMP X) (LIST '(MTIMES) X))
  1144.          ((NOT (MTIMESP X)) (LIST '(MTIMES) 1 X))
  1145.          ((NOT (MNUMP (CADR X))) (CONS '(MTIMES) (CONS 1 (CDR X))))
  1146.          (T X)))
  1147.  
  1148. (DEFUN PLSK (X Y) (COND ($RATSIMPEXPONS (SRATSIMP (LIST '(MPLUS) X Y)))
  1149.             ((AND (MNUMP X) (MNUMP Y)) (ADDK X Y))
  1150.             (T (ADD2 X Y))))
  1151.  
  1152. (DEFUN MULT (X Y) (COND ((AND (MNUMP X) (MNUMP Y)) (TIMESK X Y))
  1153.             (T (MUL2 X Y))))
  1154.  
  1155. (DEFMFUN SIMP-LIMIT (X VESTIGIAL Z) 
  1156.  VESTIGIAL ;Ignored.
  1157.  ((LAMBDA (L1 Y) 
  1158.    (COND ((NOT (OR (= L1 2) (= L1 4) (= L1 5))) (WNA-ERR '%LIMIT)))
  1159.    (SETQ Y (SIMPMAP (CDR X) Z))
  1160.    (COND ((AND (= L1 5) (NOT (MEMQ (CADDDR Y) '($PLUS $MINUS))))
  1161.       (MERROR "4th arg to LIMIT must be either PLUS or MINUS:~%~M"
  1162.           (CADDDR Y)))
  1163.      ((MNUMP (CADR Y))
  1164.       (MERROR "Wrong second arg to LIMIT:~%~M" (CADR Y)))
  1165.      ((EQUAL (CAR Y) 1) 1)
  1166.      (T (EQTEST (CONS '(%LIMIT) Y) X))))
  1167.   (LENGTH X) NIL))
  1168.  
  1169. (DEFMFUN SIMPINTEG (X VESTIGIAL Z) 
  1170.  VESTIGIAL ;Ignored.
  1171.  ((LAMBDA (L1 Y) 
  1172.    (COND ((NOT (OR (= L1 3) (= L1 5)))
  1173.       (MERROR "Wrong number of arguments to 'INTEGRATE")))
  1174.    (SETQ Y (SIMPMAP (CDR X) Z))
  1175.    (COND ((MNUMP (CADR Y))
  1176.       (MERROR "Attempt to integrate with respect to a number:~%~M" (CADR Y)))
  1177.      ((AND (= L1 5) (ALIKE1 (CADDR Y) (CADDDR Y))) 0)
  1178.      ((AND (= L1 5) (FREE (SETQ Z (SUB (CADDDR Y) (CADDR Y))) '$%I)
  1179.            (EQ ($SIGN Z) '$NEG))
  1180.       (NEG (SIMPLIFYA (LIST '(%INTEGRATE) (CAR Y) (CADR Y) (CADDDR Y) (CADDR Y)) T)))
  1181.      ((EQUAL (CAR Y) 1)
  1182.       (COND ((= L1 3) (CADR Y))
  1183.         (T (COND ((OR (AMONG '$INF Z) (AMONG '$MINF Z)) (INFSIMP Z))
  1184.              (T Z)))))
  1185.      (T (EQTEST (CONS '(%INTEGRATE) Y) X))))
  1186.   (LENGTH X) NIL))
  1187.  
  1188. (DEFMFUN SIMPBIGFLOAT (X VESTIGIAL SIMP-FLAG)
  1189.        VESTIGIAL ;Ignored.
  1190.        SIMP-FLAG ;No interesting subexpressions
  1191.        (BIGFLOATM* X))
  1192.  
  1193. (DEFMFUN SIMPEXP (X VESTIGIAL Z)
  1194.  VESTIGIAL ;Ignored.
  1195.  (ONEARGCHECK X) (SIMPLIFYA (LIST '(MEXPT) '$%E (CADR X)) Z))
  1196.  
  1197. (DEFMFUN SIMPLAMBDA (X VESTIGIAL SIMP-FLAG)
  1198.        VESTIGIAL ;Ignored.
  1199.        SIMP-FLAG ;No interesting subexpressions
  1200.        (CONS '(LAMBDA SIMP) (CDR X)))
  1201.  
  1202. (DEFMFUN SIMPMDEF (X VESTIGIAL SIMP-FLAG)
  1203.        VESTIGIAL ;Ignored.
  1204.        SIMP-FLAG ;No interesting subexpressions
  1205.        (TWOARGCHECK X)
  1206.        (CONS '(MDEFINE SIMP) (CDR X)))
  1207.  
  1208. (DEFUN SIMPMAP (E Z) (MAPCAR #'(LAMBDA (U) (SIMPCHECK U Z)) E))
  1209.  
  1210. (defmfun infsimp (e)
  1211.  (let ((x ($expand e 1 1)))
  1212.       (cond ((or (not (free x '$ind)) (not (free x '$und))
  1213.          (not (free x '$zeroa)) (not (free x '$zerob))
  1214.          (not (free x '$infinity))
  1215.          (mbagp x))
  1216.          (infsimp2 x e))
  1217.         ((and (free x '$inf) (free x '$minf)) x)
  1218.         (t (infsimp1 x e)))))
  1219.  
  1220. (defun infsimp1 (x e)
  1221.   (let ((minf-coef (coeff x '$minf 1))
  1222.     (inf-coef (coeff x '$inf 1)))
  1223.     (cond ((or (and (equal minf-coef 0)
  1224.             (equal inf-coef 0))
  1225.            (and (not (free minf-coef '$inf))
  1226.             (not (free inf-coef '$minf)))
  1227.            (let ((new-exp (sub (add2 (mul2 minf-coef '$minf)
  1228.                      (mul2 inf-coef '$inf))
  1229.                    x)))
  1230.          (and (not (free new-exp '$inf))
  1231.               (not (free new-exp '$minf)))))
  1232.        (infsimp2 x e))
  1233.       (t (let ((sign-minf-coef ($asksign minf-coef))
  1234.            (sign-inf-coef ($asksign inf-coef)))
  1235.            (cond ((or (and (eq sign-inf-coef '$zero)
  1236.                    (eq sign-minf-coef '$neg))
  1237.               (and (eq sign-inf-coef '$pos)
  1238.                    (eq sign-minf-coef '$zero))
  1239.               (and (eq sign-inf-coef '$pos)
  1240.                    (eq sign-minf-coef '$neg)))  '$inf)
  1241.              ((or (and (eq sign-inf-coef '$zero)
  1242.                    (eq sign-minf-coef '$pos))
  1243.               (and (eq sign-inf-coef '$neg)
  1244.                    (eq sign-minf-coef '$zero))
  1245.               (and (eq sign-inf-coef '$neg)
  1246.                    (eq sign-minf-coef '$pos)))  '$minf)
  1247.              ((or (and (eq sign-inf-coef '$pos)
  1248.                    (eq sign-minf-coef '$pos))
  1249.               (and (eq sign-inf-coef '$neg)
  1250.                    (eq sign-minf-coef '$neg)))  '$und)))))))
  1251.  
  1252. (defun infsimp2 (x e)
  1253.  (setq x ($limit x))
  1254.  (if (isinop x '%limit) e x))
  1255.  
  1256. (DEFMFUN SIMPDERIV (X Y Z)
  1257.   (PROG (FLAG W U)
  1258.     (COND ((NOT (EVEN (LENGTH X)))
  1259.            (COND ((AND (CDR X) (NULL (CDDDR X))) (NCONC X '(1)))
  1260.              (T (WNA-ERR '%DERIVATIVE)))))
  1261.     (SETQ W (CONS '(%DERIVATIVE) (SIMPMAP (CDR X) Z)))
  1262.     (SETQ Y (CADR W))
  1263.     (DO ((U (CDDR W) (CDDR U))) ((NULL U))
  1264.         (COND ((MNUMP (CAR U))
  1265.            (MERROR "Attempt to differentiate with respect to a number:~%~M"
  1266.                (CAR U)))))
  1267.     (COND ((OR (ZEROP1 Y)
  1268.            (AND (OR (MNUMP Y) (AND (ATOM Y) (CONSTANT Y)))
  1269.             (OR (NULL (CDDR W))
  1270.                 (AND (NOT (ALIKE1 Y (CADDR W)))
  1271.                  (DO ((U (CDDR W) (CDDR U))) ((NULL U))
  1272.                      (COND ((AND (NUMBERP (CADR U)) (NOT (ZEROP (CADR U))))
  1273.                         (RETURN T))))))))
  1274.            (RETURN 0))
  1275.           ((AND (NOT (ATOM Y)) (EQ (CAAR Y) '%DERIVATIVE) DERIVSIMP)
  1276.            (RPLACD W (APPEND (CDR Y) (CDDR W)))))
  1277.     (IF (NULL (CDDR W))
  1278.         (RETURN (IF (NULL DERIVFLAG) (LIST '(%DEL SIMP) Y) (DERIV (CDR W)))))
  1279.     (SETQ U (CDR W))
  1280.    ZTEST(COND ((NULL U) (GO NEXT))
  1281.           ((ZEROP1 (CADDR U)) (RPLACD U (CDDDR U)))
  1282.           (T (SETQ U (CDDR U))))
  1283.     (GO ZTEST)
  1284.    NEXT (COND ((NULL (CDDR W)) (RETURN Y))
  1285.           ((AND (NULL (CDDDDR W)) (ONEP (CADDDR W))
  1286.             (ALIKE1 (CADR W) (CADDR W)))
  1287.            (RETURN 1)))
  1288.    AGAIN(SETQ Z (CDDR W))
  1289.    SORT    (COND ((NULL (CDDR Z)) (GO LOOP))
  1290.           ((ALIKE1 (CAR Z) (CADDR Z))
  1291.            (RPLACA (CDDDR Z) (ADD2 (CADR Z) (CADDDR Z)))
  1292.            (RPLACD Z (CDDDR Z)))
  1293.           ((GREAT (CAR Z) (CADDR Z))
  1294.            (LET ((U1 (CAR Z)) (U2 (CADR Z)) (V1 (CADDR Z)) (V2 (CADDDR Z)))
  1295.             (SETQ FLAG T) (RPLACA Z V1)
  1296.             (RPLACD Z (CONS V2 (CONS U1 (CONS U2 (CDDDDR Z))))))))
  1297.     (COND ((SETQ Z (CDDR Z)) (GO SORT)))
  1298.    LOOP    (COND ((NULL FLAG) (RETURN (COND ((NULL DERIVFLAG) (EQTEST W X))
  1299.                      (T (DERIV (CDR W)))))))
  1300.     (SETQ FLAG NIL)
  1301.     (GO AGAIN)))
  1302.  
  1303. (DEFMFUN SIGNUM1 (X)
  1304.  (declare (object x))
  1305.  (COND ((MNUMP X)
  1306.     (SETQ X (NUM1 X)) (COND ((PLUSP X) 1) ((MINUSP X) -1) (T 0))) 
  1307.        ((ATOM X) 1)
  1308.        ((MPLUSP X) (IF EXPANDP 1 (SIGNUM1 (CAR (LAST X)))))
  1309.        ((MTIMESP X) (IF (MPLUSP (CADR X)) 1 (SIGNUM1 (CADR X))))
  1310.        (T 1)))
  1311.  
  1312. (DEFMFUN SIMPSIGNUM (X Y Z) 
  1313.   (ONEARGCHECK X)
  1314.   (SETQ Y (SIMPCHECK (CADR X) Z))
  1315.   (COND ((MNUMP Y)
  1316.      (SETQ Y (NUM1 Y)) (COND ((PLUSP Y) 1) ((MINUSP Y) -1) (T 0))) 
  1317.     ((EQ (SETQ Z (CSIGN Y)) T) (EQTEST (LIST '(%SIGNUM) Y) X))
  1318.     ((EQ Z '$POS) 1) 
  1319.     ((EQ Z '$NEG) -1) 
  1320.     ((EQ Z '$ZERO) 0) 
  1321.     ((MMINUSP Y) (MUL2 -1 (LIST '(%SIGNUM SIMP) (NEG Y)))) 
  1322.     (T (EQTEST (LIST '(%SIGNUM) Y) X))))
  1323.  
  1324. (DEFMFUN EXPTRL (R1 R2)
  1325.   (COND ((EQUAL R2 1) R1)
  1326.     ((EQUAL R2 1.0) (COND ((MNUMP R1) (ADDK 0.0 R1)) (T R1)))
  1327.     ((EQUAL R2 BIGFLOATONE) (COND ((MNUMP R1) ($BFLOAT R1)) (T R1)))
  1328.     ((ZEROP1 R1)
  1329.      (COND ((OR (ZEROP1 R2) (MNEGP R2))
  1330.         (COND ((NOT ERRORSW)
  1331.                (MERROR "~M has been generated" (LIST '(MEXPT) R1 R2)))
  1332.               (T (THROW 'ERRORSW T))))
  1333.            (T (ZERORES R1 R2))))
  1334.     ((OR (ZEROP1 R2) (ONEP1 R1))
  1335.      (COND ((OR ($BFLOATP R1) ($BFLOATP R2)) BIGFLOATONE)
  1336.            ((OR (FLOATP R1) (FLOATP R2)) 1.0)
  1337.            (T 1)))
  1338.     ((OR ($BFLOATP R1) ($BFLOATP R2)) ($BFLOAT (LIST '(MEXPT) R1 R2)))
  1339.     ((AND (NUMBERP R1) (INTEGERP R2)) (EXPTB R1 R2))
  1340.     ((AND (NUMBERP R1) (FLOATP R2) (EQUAL R2 (FLOAT (FIX R2))))
  1341.      (EXPTB (FLOAT R1) (FIX R2)))
  1342.     ((OR $NUMER (AND (FLOATP R2) (OR (PLUSP (NUM1 R1)) $NUMER_PBRANCH)))
  1343.      (LET (Y  #+kcl(r1 r1) #+kcl(r2 r2))
  1344.        (COND ((MINUSP (SETQ R1 (ADDK 0.0 R1)))
  1345.           (COND ((OR $NUMER_PBRANCH (EQ $DOMAIN '$COMPLEX))
  1346.         ;; for R1<0: R1^R2 = (-R1)^R2*cos(pi*R2) + i*(-R1)^R2*sin(pi*R2)
  1347.              (SETQ R2 (ADDK 0.0 R2))
  1348.              (SETQ Y (EXPTRL (-$ R1) R2) R2 (TIMES %PI-VAL R2))
  1349.              (ADD2 (TIMES Y (COS R2))
  1350.                    (LIST '(MTIMES SIMP) (TIMES Y (SIN R2)) '$%I)))
  1351.             (T (SETQ Y (LET ($NUMER $FLOAT $KEEPFLOAT $RATPRINT)
  1352.                     (POWER -1 (RATF R2))))
  1353.                (SETQ Y (IF (AND (MEXPTP Y) (EQUAL (CADR Y) -1))
  1354.                        (LIST '(MEXPT SIMP) -1 (FPCOFRAT (CADDR Y)))
  1355.                        (RESIMPLIFY Y)))
  1356.                (MUL2 Y (EXPTRL (-$ R1) R2)))))
  1357.          ((EQUAL (SETQ R2 (ADDK 0.0 R2)) (FLOAT (FIX R2))) (EXPTB R1 (FIX R2)))
  1358.          ((AND (EQUAL (SETQ Y (*$ 2.0 R2)) (FLOAT (FIX Y))) (NOT (EQUAL R1 %E-VAL)))
  1359.           (EXPTB (SQRT R1) (FIX Y)))
  1360.          (T (EXP (TIMES R2 (LOG R1)))))))
  1361.     ((FLOATP R2) (LIST '(MEXPT SIMP) R1 R2))
  1362.     ((INTEGERP R2)
  1363.      (COND ((MINUSP R2)
  1364.         (EXPTRL (COND ((EQUAL (ABS (CADR R1)) 1) (TIMES (CADR R1) (CADDR R1)))
  1365.                   ((MINUSP (CADR R1))
  1366.                    (LIST '(RAT) (MINUS (CADDR R1)) (MINUS (CADR R1))))
  1367.                   (T (LIST '(RAT) (CADDR R1) (CADR R1))))
  1368.             (MINUS R2)))
  1369.            (T (LIST '(RAT SIMP) (EXPTB (CADR R1) R2) (EXPTB (CADDR R1) R2)))))
  1370.     ((AND (FLOATP R1) (ALIKE1 R2 '((RAT) 1 2)))
  1371.      (COND ((MINUSP R1) (LIST '(MTIMES SIMP) (SQRT (MINUS R1)) '$%I)) (T (SQRT R1))))
  1372.     ((AND (FLOATP R1) (ALIKE1 R2 '((RAT) -1 2)))
  1373.      (COND ((MINUSP R1) (LIST '(MTIMES SIMP) (//$ -1.0 (SQRT (MINUS R1))) '$%I))
  1374.            (T (//$ 1.0 (SQRT R1)))))
  1375.     ((AND (FLOATP R1) (PLUSP R1)) (EXPTRL R1 (FPCOFRAT R2)))
  1376.     (EXPTRLSW (LIST '(MEXPT SIMP) R1 R2))
  1377.     (T ((LAMBDA (EXPTRLSW)
  1378.          (SIMPTIMES
  1379.           (LIST '(MTIMES)
  1380.             (EXPTRL R1 (*QUO (CADR R2) (CADDR R2)))
  1381.             ((LAMBDA (Y Z)
  1382.               (COND ((MEXPTP Y) (LIST (CAR Y) (CADR Y) (MUL2 (CADDR Y) Z)))
  1383.                 (T (POWER Y Z))))
  1384.              (LET ($KEEPFLOAT $RATPRINT) (SIMPNRT R1 (CADDR R2)))
  1385.              (REMAINDER (CADR R2) (CADDR R2))))
  1386.           1 T))
  1387.         T))))
  1388.  
  1389. (DEFMFUN SIMPEXPT (X Y Z)
  1390.   (PROG (GR POT CHECK RES RULESW W MLPGR MLPPOT)
  1391.     (SETQ CHECK X)
  1392.     (COND (Z (SETQ GR (CADR X) POT (CADDR X)) (GO CONT)))
  1393.     (TWOARGCHECK X)
  1394.     (SETQ GR (SIMPLIFYA (CADR X) NIL))
  1395.     (SETQ POT (SIMPLIFYA (IF $RATSIMPEXPONS ($RATSIMP (CADDR X)) (CADDR X)) NIL))
  1396.    CONT    (COND (($RATP POT) (SETQ POT (RATDISREP POT)) (GO CONT))
  1397.           (($RATP GR)
  1398.            (COND ((MEMQ 'TRUNC (CAR GR)) (RETURN (SRF (LIST '(MEXPT) GR POT))))
  1399.              ((INTEGERP POT)
  1400.               (LET ((VARLIST (CADDAR GR)) (GENVAR (CADDDR (CAR GR))))
  1401.                (RETURN (RATREP* (LIST '(MEXPT) GR POT)))))
  1402.              (T (SETQ GR (RATDISREP GR)) (GO CONT))))
  1403.           ((OR (SETQ MLPGR (MXORLISTP GR)) (SETQ MLPPOT (MXORLISTP POT)))
  1404.            (GO MATRIX))
  1405.           ((ONEP1 POT) (GO ATGR))
  1406.           ((OR (ZEROP1 POT) (ONEP1 GR)) (GO RETNO))
  1407.           ((ZEROP1 GR)
  1408.            (COND ((OR (MNEGP POT) (AND *ZEXPTSIMP? (EQ ($ASKSIGN POT) '$NEG)))
  1409.               (COND ((NOT ERRORSW) (MERROR "Division by 0"))
  1410.                 (T (THROW 'ERRORSW T))))
  1411.              ((NOT (FREE POT '$%I))
  1412.               (COND ((NOT ERRORSW)
  1413.                  (MERROR "0 to a complex quantity has been generated."))
  1414.                 (T (THROW 'ERRORSW T))))
  1415.              (T (RETURN (ZERORES GR POT)))))
  1416.           ((AND (MNUMP GR) (MNUMP POT)
  1417.             (OR (NOT (RATNUMP GR)) (NOT (RATNUMP POT))))
  1418.            (RETURN (EQTEST (EXPTRL GR POT) CHECK)))
  1419.           ((EQ GR '$%I) (RETURN (%ITOPOT POT)))
  1420.           ((AND (NUMBERP GR) (MINUSP GR) (MEVENP POT)) (SETQ GR (MINUS GR)) (GO CONT))
  1421.           ((AND (NUMBERP GR) (MINUSP GR) (MODDP POT))
  1422.            (RETURN (MUL2 -1 (POWER (MINUS GR) POT))))
  1423.           ((AND (EQUAL GR -1) (MAXIMA-INTEGERP POT) (MMINUSP POT))
  1424.            (SETQ POT (NEG POT)) (GO CONT))
  1425.           ((AND (EQUAL GR -1) (MAXIMA-INTEGERP POT) (MTIMESP POT)
  1426.             (= (LENGTH POT) 3) (FIXNUMP (CADR POT))
  1427.             (ODDP (CADR POT)) (MAXIMA-INTEGERP (CADDR POT)))
  1428.            (SETQ POT (CADDR POT)) (GO CONT))
  1429.           ((ATOM GR) (GO ATGR))
  1430.           ((AND (EQ (CAAR GR) 'MABS)
  1431.             (EVNUMP POT)
  1432.             (OR (AND (EQ $DOMAIN '$REAL) (NOT (DECL-COMPLEXP (CADR GR))))
  1433.             (AND (EQ $DOMAIN '$COMPLEX) (DECL-REALP (CADR GR)))))
  1434.            (RETURN (POWER (CADR GR) POT)))
  1435.           ((EQ (CAAR GR) 'MEQUAL)
  1436.            (RETURN (EQTEST (LIST (NCONS (CAAR GR))
  1437.                      (POWER (CADR GR) POT)
  1438.                      (POWER (CADDR GR) POT))
  1439.                    GR)))
  1440.           ((SYMBOLP POT) (GO OPP))
  1441.           ((EQ (CAAR GR) 'MEXPT) (GO E1))
  1442.           ((AND (EQ (CAAR GR) '%SUM) $SUMEXPAND (INTEGERP POT)
  1443.             (SIGNP G POT) (LESSP POT $MAXPOSEX))
  1444.            (RETURN (DO ((I (f1- POT) (f1- I))
  1445.                 (AN GR (SIMPTIMES (LIST '(MTIMES) AN GR) 1 T)))
  1446.                ((SIGNP E I) AN))))
  1447.           ((EQUAL POT -1) (RETURN (EQTEST (TESTT (TMS GR POT NIL)) CHECK)))
  1448.           ((FIXNUMP POT)
  1449.            (RETURN (EQTEST (COND ((AND (MPLUSP GR)
  1450.                        (NOT (OR (GREATERP POT $EXPOP)
  1451.                             (GREATERP (MINUS POT) $EXPON))))
  1452.                       (EXPANDEXPT GR POT))
  1453.                      (T (SIMPLIFYA (TMS GR POT NIL) T)))
  1454.                    CHECK))))
  1455.    OPP    (COND ((EQ (CAAR GR) 'MEXPT) (GO E1))
  1456.           ((EQ (CAAR GR) 'RAT)
  1457.            (RETURN (MUL2 (POWER (CADR GR) POT) (POWER (CADDR GR) (MUL2 -1 POT)))))
  1458.           ((NOT (EQ (CAAR GR) 'MTIMES)) (GO UP))
  1459.           ((OR (EQ $RADEXPAND '$ALL) (AND $RADEXPAND (SIMPLEXPON POT)))
  1460.            (SETQ RES (LIST 1)) (GO START))
  1461.           ((AND (OR (NOT (NUMBERP (CADR GR))) (EQUAL (CADR GR) -1))
  1462.             (SETQ W (zl-MEMBER ($NUM GR) '(1 -1))))
  1463.            (SETQ POT (MULT -1 POT) GR (MUL2 (CAR W) ($DENOM GR))) (GO CONT))
  1464.           ((NOT $RADEXPAND) (GO UP)))
  1465.    (RETURN (DO ((L (CDR GR) (CDR L)) (RES (NCONS 1)) (RAD))
  1466.            ((NULL L)
  1467.         (COND ((EQUAL RES '(1))
  1468.                (EQTEST (LIST '(MEXPT) GR POT) CHECK))
  1469.               ((NULL RAD) (TESTT (CONS '(MTIMES SIMP) RES)))
  1470.               (T (SETQ RAD (POWER*    ; RADEXPAND=()?
  1471.                     (CONS '(MTIMES) (NREVERSE RAD)) POT))
  1472.              (COND ((NOT (ONEP1 RAD))
  1473.                 (SETQ RAD (TESTT (TMS RAD 1 (CONS '(MTIMES) RES))))
  1474.                 (COND (RULESW (SETQ RULESW NIL RES (CDR RAD))))))
  1475.              (EQTEST (TESTT (CONS '(MTIMES) RES)) CHECK))))
  1476.            (SETQ Z (COND ((NOT (FREE (CAR L) '$%I)) '$PNZ)
  1477.                  (T ($SIGN (CAR L)))))
  1478.            (SETQ W (COND ((MEMQ Z '($NEG $NZ))
  1479.                   (SETQ RAD (CONS -1 RAD)) (MULT -1 (CAR L)))
  1480.                  (T (CAR L))))
  1481.            (COND ((ONEP1 W))
  1482.              ((ALIKE1 W GR) (RETURN (LIST '(MEXPT SIMP) GR POT)))
  1483. ;not needed?         ((MEXPTP W)
  1484. ;              (SETQ Z (LIST '(MEXPT) (CAR L) POT))
  1485. ;              (COND ((ALIKE1 Z (SETQ Z (SIMPLIFYA Z NIL)))
  1486. ;                 (SETQ RAD (CONS W RAD)))
  1487. ;                (T (SETQ W (TIMESIN Z RES 1)))))
  1488.              ((MEMQ Z '($PN $PNZ)) (SETQ RAD (CONS W RAD)))
  1489.              (T (SETQ W (TESTT (TMS (SIMPLIFYA (LIST '(MEXPT) W POT) T)
  1490.                         1 (CONS '(MTIMES) RES))))))
  1491.            (COND (RULESW (SETQ RULESW NIL RES (CDR W))))))
  1492.    START(COND ((AND (CDR RES) (ONEP1 (CAR RES)) (RATNUMP (CADR RES)))
  1493.            (SETQ RES (CDR RES))))
  1494.     (COND ((NULL (SETQ GR (CDR GR)))
  1495.            (RETURN (EQTEST (TESTT (CONS '(MTIMES) RES)) CHECK)))
  1496.           ((MEXPTP (CAR GR))
  1497.            (SETQ Y (LIST (CAAR GR) (CADAR GR) (MULT (CADDAR GR) POT))))
  1498.           ((EQ (CAR GR) '$%I) (SETQ Y (%ITOPOT POT)))
  1499.           ((MNUMP (CAR GR)) (SETQ Y (LIST '(MEXPT) (CAR GR) POT)))
  1500.           (T (SETQ Y (LIST '(MEXPT SIMP) (CAR GR) POT))))
  1501.     (SETQ W (TESTT (TMS (SIMPLIFYA Y T) 1 (CONS '(MTIMES) RES))))
  1502.     (COND (RULESW (SETQ RULESW NIL RES (CDR W))))
  1503.     (GO START)
  1504.    RETNO(RETURN (EXPTRL GR POT))
  1505.    ATGR (COND ((ZEROP1 POT) (GO RETNO))
  1506.           ((ONEP1 POT)
  1507.            ((LAMBDA (Y)
  1508.          (COND ((AND Y (FLOATP Y) (OR $NUMER (NOT (EQUAL POT 1))))
  1509.             (RETURN
  1510.              (COND ((AND (EQ GR '$%E) (EQUAL POT BIGFLOATONE))
  1511.                 ($BFLOAT '$%E))
  1512.                    (T Y))))
  1513.                (T (GO RETNO))))
  1514.         (MGET GR '$NUMER)))
  1515.           ((EQ GR '$%E)
  1516.            (COND (($BFLOATP POT) (RETURN ($BFLOAT (LIST '(MEXPT) '$%E POT))))
  1517.              ((OR (FLOATP POT) (AND $NUMER (INTEGERP POT)))
  1518.               (RETURN (EXP POT)))
  1519.              ((AND $LOGSIMP (AMONG '%LOG POT)) (RETURN (%ETOLOG POT)))
  1520.              ((AND $DEMOIVRE (SETQ Z (DEMOIVRE POT))) (RETURN Z))
  1521.              ((AND $%EMODE (SETQ Z (%ESPECIAL POT))) (RETURN Z))))
  1522.           (T ((LAMBDA (Y) (AND Y (FLOATP Y)
  1523.                    (OR (FLOATP POT) (AND $NUMER (INTEGERP POT)))
  1524.                    (RETURN (EXPTRL Y POT)))) (MGET GR '$NUMER))))
  1525.    UP    (RETURN (EQTEST (LIST '(MEXPT) GR POT) CHECK))
  1526.    MATRIX
  1527.    (COND ((ZEROP1 POT)
  1528.       (COND ((MXORLISTP1 GR) (RETURN (CONSTMX (ADDK 1 POT) GR))) (T (GO RETNO))))
  1529.      ((ONEP1 POT) (RETURN GR))
  1530.      ((OR $DOALLMXOPS $DOSCMXOPS $DOMXEXPT)
  1531.       (COND ((OR (AND MLPGR (OR (NOT ($LISTP GR)) $LISTARITH)
  1532.                 (SCALAR-OR-CONSTANT-P POT $ASSUMESCALAR))
  1533.              (AND $DOMXEXPT MLPPOT (OR (NOT ($LISTP POT)) $LISTARITH)
  1534.                  (SCALAR-OR-CONSTANT-P GR $ASSUMESCALAR)))
  1535.          (RETURN (SIMPLIFYA (OUTERMAP1 'MEXPT GR POT) T)))
  1536.         (T (GO UP))))
  1537.     ((AND $DOMXMXOPS (zl-MEMBER POT '(-1 -1.0)))
  1538.      (RETURN (SIMPLIFYA (OUTERMAP1 'MEXPT GR POT) T)))
  1539.     (T (GO UP)))
  1540.    E1  (COND ((OR (EQ $RADEXPAND '$ALL) (SIMPLEXPON POT) (NONEG (CADR GR))
  1541.           (EQUAL (CADDR GR) -1)
  1542.           (AND (EQ $DOMAIN '$REAL) (ODNUMP (CADDR GR))))
  1543.           (SETQ POT (MULT POT (CADDR GR)) GR (CADR GR)))
  1544.          ((AND (EQ $DOMAIN '$REAL) (FREE GR '$%I) $RADEXPAND
  1545.            (NOT (DECL-COMPLEXP (CADR GR))) (EVNUMP (CADDR GR)))
  1546.           (SETQ POT (MULT POT (CADDR GR)) GR (RADMABS (CADR GR))))
  1547.          ((MMINUSP (CADDR GR))
  1548.           (SETQ POT (NEG POT)
  1549.             GR (LIST (CAR GR) (CADR GR) (NEG (CADDR GR)))))
  1550.          (T (GO UP)))
  1551.        (GO CONT)))
  1552.  
  1553. (DEFUN TIMESIN (X Y W)  ; Multiply X^W into Y
  1554.  (PROG (FM TEMP Z CHECK U)
  1555.        (IF (MEXPTP X) (SETQ CHECK X))
  1556.   TOP  (COND ((EQUAL W 1) (SETQ TEMP X))
  1557.          (T (SETQ TEMP (CONS '(MEXPT) (IF CHECK (LIST (CADR X) (MULT (CADDR X) W))
  1558.                             (LIST X W))))
  1559.         (IF (AND (NOT TIMESINP) (NOT (EQ X '$%I)))
  1560.             (LET ((TIMESINP T)) (SETQ TEMP (SIMPLIFYA TEMP T))))))
  1561.        (SETQ X (IF (MEXPTP TEMP) (CDR TEMP) (LIST TEMP 1)))
  1562.        (SETQ W (CADR X) FM Y)
  1563.   START(COND ((NULL (CDR FM)) (GO LESS))
  1564.          ((MEXPTP (CADR FM))
  1565.           (COND ((ALIKE1 (CAR X) (CADADR FM))
  1566.              (COND ((ZEROP1 (SETQ W (PLSK (CADDR (CADR FM)) W))) (GO DEL))
  1567.                ((AND (MNUMP W) (OR (MNUMP (CAR X)) (EQ (CAR X) '$%I)))
  1568.                 (RPLACD FM (CDDR FM))
  1569.                 (COND ((MNUMP (SETQ X (IF (MNUMP (CAR X))
  1570.                               (EXPTRL (CAR X) W)
  1571.                               (POWER (CAR X) W))))
  1572.                    (RETURN (RPLACA Y (TIMESK (CAR Y) X))))
  1573.                   ((MTIMESP X) (GO TIMES))
  1574.                   (T (SETQ TEMP X X (IF (MEXPTP X) (CDR X) (LIST X 1)))
  1575.                      (SETQ W (CADR X) FM Y) (GO START))))
  1576.                ((MAXIMA-CONSTANTP (CAR X)) (GO CONST))
  1577.                ((ONEP1 W) (RETURN (RPLACA (CDR FM) (CAR X))))
  1578.                (T (GO SPCHECK))))
  1579.             ((OR (MAXIMA-CONSTANTP (CAR X)) (MAXIMA-CONSTANTP (CADADR FM)))
  1580.              (IF (GREAT TEMP (CADR FM)) (GO GR)))
  1581.             ((GREAT (CAR X) (CADADR FM)) (GO GR)))
  1582.           (GO LESS))
  1583.          ((ALIKE1 (CAR X) (CADR FM)) (GO EQU))
  1584.          ((MAXIMA-CONSTANTP (CAR X)) (IF (GREAT TEMP (CADR FM)) (GO GR)))
  1585.          ((GREAT (CAR X) (CADR FM)) (GO GR)))
  1586.   LESS (COND ((AND (EQ (CAR X) '$%I) (FIXNUMP W)) (GO %I))
  1587.          ((AND (EQ (CAR X) '$%E) $NUMER (INTEGERP W))
  1588.           (RETURN (RPLACA Y (TIMESK (CAR Y) (EXP W)))))
  1589.          ((AND (ONEP1 W) (NOT (CONSTANT (CAR X)))) (GO LESS1))
  1590.          ((AND (MAXIMA-CONSTANTP (CAR X))
  1591.            (DO ((L (CDR FM) (CDR L))) ((NULL (CDR L)))
  1592.                (WHEN (AND (MEXPTP (CADR L)) (ALIKE1 (CAR X) (CADADR L)))
  1593.                  (SETQ FM L) (RETURN T))))
  1594.           (GO START))
  1595.          ((OR (AND (MNUMP (CAR X)) (MNUMP W))
  1596.           (AND (EQ (CAR X) '$%E) $%EMODE (SETQ U (%ESPECIAL W))))
  1597.           (SETQ X (COND (U)
  1598.                 ((ALIKE (CDR CHECK) X) CHECK)
  1599.                 (T (EXPTRL (CAR X) W))))
  1600.           (COND ((MNUMP X) (RETURN (RPLACA Y (TIMESK (CAR Y) X))))
  1601.             ((MTIMESP X) (GO TIMES))
  1602.             ((MEXPTP X) (RETURN (CDR (RPLACD FM (CONS X (CDR FM))))))
  1603.             (T (SETQ TEMP X X (LIST X 1) W 1 FM Y) (GO START))))
  1604.          ((ONEP1 W) (GO LESS1))
  1605.          (T (SETQ TEMP (LIST '(MEXPT) (CAR X) W))
  1606.         (SETQ TEMP (EQTEST TEMP (OR CHECK '((FOO)))))
  1607.         (RETURN (CDR (RPLACD FM (CONS TEMP (CDR FM)))))))
  1608.   LESS1 (RETURN (CDR (RPLACD FM (CONS (CAR X) (CDR FM)))))
  1609.   GR    (SETQ FM (CDR FM)) (GO START)
  1610.   EQU   (COND ((AND (EQ (CAR X) '$%I) (EQUAL W 1))
  1611.            (RPLACD FM (CDDR FM)) (RETURN (RPLACA Y (TIMESK -1 (CAR Y)))))
  1612.           ((ZEROP1 (SETQ W (PLSK 1 W))) (GO DEL))
  1613.           ((AND (MNUMP (CAR X)) (MNUMP W))
  1614.            (RETURN (RPLACA (CDR FM) (EXPTRL (CAR X) W))))
  1615.           ((MAXIMA-CONSTANTP (CAR X)) (GO CONST)))
  1616.  SPCHECK(SETQ Z (LIST '(MEXPT) (CAR X) W))
  1617.     (COND ((ALIKE1 (SETQ X (SIMPLIFYA Z T)) Z) (RETURN (RPLACA (CDR FM) X)))
  1618.           (T (RPLACD FM (CDDR FM)) (SETQ RULESW T) (RETURN (MULN (CONS X Y) T))))
  1619.   CONST (RPLACD FM (CDDR FM))
  1620.     (SETQ X (CAR X) CHECK NIL)
  1621.     (GO TOP)
  1622.   TIMES (SETQ Z (TMS X 1 (SETQ TEMP (CONS '(MTIMES) Y))))
  1623.     (RETURN (COND ((EQ Z TEMP) (CDR Z)) (T (SETQ RULESW T) Z)))
  1624.   DEL    (RETURN (RPLACD FM (CDDR FM)))
  1625.   %I    (IF (MINUSP (SETQ W (REMAINDER W 4))) (SETQ W (f+ 4 W)))
  1626.     (RETURN (COND ((ZEROP W) FM) 
  1627.               ((= W 2) (RPLACA Y (TIMESK -1 (CAR Y))))
  1628.               ((= W 3) (RPLACA Y (TIMESK -1 (CAR Y))) 
  1629.                    (RPLACD FM (CONS '$%I (CDR FM))))
  1630.               (T (RPLACD FM (CONS '$%I (CDR FM))))))))
  1631.  
  1632. (DEFMFUN SIMPMATRIX (X VESTIGIAL Z)
  1633.   VESTIGIAL ;Ignored.
  1634.   (IF (AND (NULL (CDDR X))
  1635.        $SCALARMATRIXP
  1636.        (OR (EQ $SCALARMATRIXP '$ALL) (MEMQ 'MULT (CDAR X)))
  1637.        ($LISTP (CADR X)) (CDADR X) (NULL (CDDADR X)))
  1638.       (SIMPLIFYA (CADADR X) Z)
  1639.       (LET ((BADP (DOLIST (ROW (CDR X)) (IF (NOT ($LISTP ROW)) (RETURN T))))
  1640.         (ARGS (SIMPMAP (CDR X) Z)))
  1641.     (IF (AND ARGS (NOT BADP)) (MATCHECK ARGS))
  1642.     (CONS (IF BADP '(%MATRIX SIMP) '($MATRIX SIMP)) ARGS))))
  1643.  
  1644. (DEFUN %ITOPOT (POT)
  1645.  (IF (FIXNUMP POT)
  1646.      (LET ((I (BOOLE  BOOLE-AND POT 3)))
  1647.       (COND ((= I 0) 1)
  1648.         ((= I 1) '$%I)
  1649.         ((= I 2) -1)
  1650.         (T (LIST '(MTIMES SIMP) -1 '$%I))))
  1651.      (POWER -1 (MUL2 POT '((RAT SIMP) 1 2)))))
  1652.  
  1653. (DEFUN MNLOGP (POT)
  1654.  (COND ((EQ (CAAR POT) '%LOG) (SIMPLIFYA (CADR POT) NIL))
  1655.        ((AND (EQ (CAAR POT) 'MTIMES)
  1656.          (OR (MAXIMA-INTEGERP (CADR POT)) (AND $%E_TO_NUMLOG ($NUMBERP (CADR POT))))
  1657.          (NOT (ATOM (CADDR POT))) (EQ (CAAR (CADDR POT)) '%LOG)
  1658.          (NULL (CDDDR POT)))
  1659.     (POWER (CADR (CADDR POT)) (CADR POT)))))
  1660.  
  1661. (DEFUN MNLOG (POT)
  1662.  (PROG (A B C)
  1663.   LOOP (COND ((NULL POT)
  1664.           (COND (A (SETQ A (CONS '(MTIMES) A))))
  1665.           (COND (C (SETQ C (LIST '(MEXPT SIMP) '$%E (ADDN C NIL))))) 
  1666.           (RETURN (COND ((NULL C) (SIMPTIMES A 1 NIL))
  1667.                 ((NULL A) C)
  1668.                 (T (SIMPTIMES (APPEND A (LIST C)) 1 NIL)))))
  1669.          ((AND (AMONG '%LOG (CAR POT)) (SETQ B (MNLOGP (CAR POT))))
  1670.           (SETQ A (CONS B A)))
  1671.          (T (SETQ C (CONS (CAR POT) C))))
  1672.        (SETQ POT (CDR POT))
  1673.        (GO LOOP)))
  1674.  
  1675. (DEFUN %ETOLOG (POT) (COND ((MNLOGP POT))
  1676.                ((EQ (CAAR POT) 'MPLUS) (MNLOG (CDR POT)))
  1677.                (T (LIST '(MEXPT SIMP) '$%E POT)))) 
  1678.  
  1679. (DEFUN ZERORES (R1 R2)
  1680.   (COND ((OR ($BFLOATP R1) ($BFLOATP R2)) BIGFLOATZERO)
  1681.     ((OR (FLOATP R1) (FLOATP R2)) 0.0)
  1682.     (T 0)))
  1683.  
  1684. (DEFMFUN $ORDERLESSP (A B)
  1685.   (SETQ A (SPECREPCHECK A) B (SPECREPCHECK B))
  1686.   (AND (NOT (ALIKE1 A B)) (GREAT B A) T))
  1687.  
  1688.  
  1689. (DEFMFUN $ORDERGREATP (A B)
  1690.   (SETQ A (SPECREPCHECK A) B (SPECREPCHECK B))
  1691.   (AND (NOT (ALIKE1 A B)) (GREAT A B) T))
  1692.  
  1693.  
  1694. (DEFUN EVNUMP (N) (OR (EVEN N) (AND (RATNUMP N) (EVEN (CADR N)))))
  1695. (DEFUN ODNUMP (N) (OR (AND (INTEGERP N) (ODDP N))
  1696.               (AND (RATNUMP N) (ODDP (CADR N)))))
  1697.  
  1698. (DEFUN SIMPLEXPON (E)
  1699.   (OR (MAXIMA-INTEGERP E)
  1700.       (AND (EQ $DOMAIN '$REAL) (RATNUMP E) (ODDP (CADDR E)))))
  1701.  
  1702. (DEFUN NONEG (P) (AND (FREE P '$%I) (MEMQ ($SIGN P) '($POS $PZ $ZERO))))
  1703.  
  1704. (DEFUN RADMABS (E)
  1705.   (IF (AND LIMITP (FREE E '$%I)) (ASKSIGN-P-OR-N E))
  1706.   (SIMPLIFYA (LIST '(MABS) E) T))
  1707.  
  1708. (DEFMFUN SIMPMQAPPLY (EXP Y Z)
  1709.  (LET ((SIMPFUN (AND (NOT (ATOM (CADR EXP))) (GET (CAAADR EXP) 'SPECSIMP))) U)
  1710.       (IF SIMPFUN
  1711.       (FUNCALL SIMPFUN EXP Y Z)
  1712.       (PROGN (SETQ U (SIMPARGS EXP Z))
  1713.          (IF (SYMBOLP (CADR U))
  1714.              (SIMPLIFYA (CONS (CONS (CADR U) (CDAR U)) (CDDR U)) Z)
  1715.              U)))))
  1716.  
  1717. (DEFMFUN DECL-COMPLEXP (E)
  1718.   (AND (SYMBOLP E)
  1719.        (KINDP E '$COMPLEX)
  1720.        (NOT (KINDP E '$REAL))))
  1721.  
  1722. (DEFMFUN DECL-REALP (E)
  1723.   (AND (SYMBOLP E) (KINDP E '$REAL)))
  1724.  
  1725. (DEFMFUN GREAT (X Y)
  1726.  (declare (object y))
  1727.  (COND ((ATOM X)
  1728.     (COND ((ATOM Y)
  1729.            (COND #+NIL
  1730.              ;; kludge until we think of something better.
  1731.              ;; no gc yet, so at least si:address-of won't change.
  1732.              ((OR (SI:EXTENDP X) (SI:EXTENDP Y))
  1733.               (> (SI:ADDRESS-OF X) (SI:ADDRESS-OF Y)))
  1734.              ((NUMBERP X)
  1735.               (COND ((NUMBERP Y)
  1736.                  (SETQ Y (*DIF X Y))
  1737.                  (COND ((ZEROP Y) (FLOATP X)) (T (PLUSP Y))))))
  1738.              ((CONSTANT X)
  1739.               (COND ((CONSTANT Y) (ALPHALESSP Y X)) (T (NUMBERP Y))))
  1740.              ((MGET X '$SCALAR)
  1741.               (COND ((MGET Y '$SCALAR) (ALPHALESSP Y X)) (T (MAXIMA-CONSTANTP Y))))
  1742.              ((MGET X '$MAINVAR)
  1743.               (COND ((MGET Y '$MAINVAR) (ALPHALESSP Y X)) (T T)))
  1744.              (T (OR (MAXIMA-CONSTANTP Y) (MGET Y '$SCALAR) 
  1745.                 (AND (NOT (MGET Y '$MAINVAR)) (ALPHALESSP Y X))))))
  1746.           (T (NOT (ORDFNA Y X)))))
  1747. ;       ((SI::EXTENDP Y)#+nil (> (SI:ADDRESS-OF X) (SI:ADDRESS-OF Y))
  1748. ;    #-nil (alphalessp y x))
  1749.        ((ATOM Y) (ORDFNA X Y))
  1750.        ((EQ (CAAR X) 'RAT)
  1751.     (COND ((EQ (CAAR Y) 'RAT)
  1752.            (GREATERP (TIMES (CADDR Y) (CADR X)) (TIMES (CADDR X) (CADR Y))))))
  1753.        ((EQ (CAAR Y) 'RAT))
  1754.        ((MEMQ (CAAR X) '(MBOX MLABOX)) (GREAT (CADR X) Y))
  1755.        ((MEMQ (CAAR Y) '(MBOX MLABOX)) (GREAT X (CADR Y)))
  1756.        ((OR (MEMQ (CAAR X) '(MTIMES MPLUS MEXPT %DEL))
  1757.         (MEMQ (CAAR Y) '(MTIMES MPLUS MEXPT %DEL)))
  1758.     (ORDFN X Y))
  1759.        ((AND (EQ (CAAR X) 'BIGFLOAT) (EQ (CAAR Y) 'BIGFLOAT)) (MGRP X Y))
  1760.        (T (DO ((X1 (MARGS X) (CDR X1)) (Y1 (MARGS Y) (CDR Y1))) (())
  1761.           (COND ((NULL X1)
  1762.              (RETURN (COND (Y1 NIL)
  1763.                    ((NOT (ALIKE1 (MOP X) (MOP Y)))
  1764.                     (GREAT (MOP X) (MOP Y)))
  1765.                    ((MEMQ 'array (CDAR X)) T))))
  1766.             ((NULL Y1) (RETURN T))
  1767.             ((NOT (ALIKE1 (CAR X1) (CAR Y1)))
  1768.              (RETURN (GREAT (CAR X1) (CAR Y1)))))))))
  1769.  
  1770.  
  1771.  
  1772.  
  1773.  
  1774.  
  1775.  
  1776. ;; Trivial function used only in ALIKE1.  Should be defined as an open-codable subr.
  1777.  
  1778. (DEFMACRO MEMQARR (L) `(IF (MEMQ 'array ,L) T))
  1779.  
  1780. ;; Compares two Macsyma expressions ignoring SIMP flags and all other
  1781. ;; items in the header except for the ARRAY flag.
  1782.  
  1783. (DEFMFUN ALIKE1 (X Y)
  1784.  (COND ((EQ X Y))
  1785.        ((ATOM X) (EQUAL X Y))
  1786.        ((ATOM Y) NIL)
  1787.        (T (AND (NOT (ATOM (CAR X)))
  1788.            (NOT (ATOM (CAR Y)))
  1789.            (EQ (CAAR X) (CAAR Y))
  1790.            (EQ (MEMQARR (CDAR X)) (MEMQARR (CDAR Y)))
  1791.            (ALIKE (CDR X) (CDR Y)))))) 
  1792.  
  1793. ;; Maps ALIKE1 down two lists.
  1794.  
  1795. (DEFMFUN ALIKE (X Y)
  1796.  (DO ((X X (CDR X)) (Y Y (CDR Y))) ((ATOM X) (EQUAL X Y))
  1797.      (COND ((OR (ATOM Y) (NOT (ALIKE1 (CAR X) (CAR Y))))
  1798.         (RETURN NIL)))))
  1799.  
  1800. #+Franz
  1801. (DEFUN ALIKE1-PART2 (X Y)
  1802.   (AND (NOT (ATOM (CAR X)))
  1803.        (NOT (ATOM (CAR Y)))
  1804.        (EQ (CAAR X) (CAAR Y))
  1805.        (EQ (MEMQARR (CDAR X)) (MEMQARR (CDAR Y)))
  1806.        (ALIKE (CDR X) (CDR Y))))
  1807.  
  1808. (DEFUN ORDFNA (E A)  ; A is an atom
  1809.  (COND ((NUMBERP A)
  1810.     (OR (NOT (EQ (CAAR E) 'RAT))
  1811.         (GREATERP (CADR E) (TIMES (CADDR E) A))))
  1812.        ((AND (CONSTANT A) (NOT (MEMQ (CAAR E) '(MPLUS MTIMES MEXPT))))
  1813.     (NOT (MEMQ (CAAR E) '(RAT BIGFLOAT))))
  1814.        ((NULL (MARGS E)) NIL)
  1815.        ((EQ (CAAR E) 'MEXPT)
  1816.     (COND ((AND (MAXIMA-CONSTANTP (CADR E))
  1817.             (OR (NOT (CONSTANT A)) (NOT (MAXIMA-CONSTANTP (CADDR E)))))
  1818.            (OR (NOT (FREE (CADDR E) A)) (GREAT (CADDR E) A)))
  1819.           ((EQ (CADR E) A) (GREAT (CADDR E) 1))
  1820.           (T (GREAT (CADR E) A))))
  1821.        ((MEMQ (CAAR E) '(MPLUS MTIMES))
  1822.     (LET ((U (CAR (LAST E))))
  1823.          (COND ((EQ U A) (NOT (ORDHACK E))) (T (GREAT U A)))))
  1824.        ((EQ (CAAR E) '%DEL))
  1825.        ((PROG2 (SETQ E (CAR (MARGS E)))
  1826.            (AND (NOT (ATOM E)) (MEMQ (CAAR E) '(MPLUS MTIMES))))
  1827.     (LET ((U (CAR (LAST E)))) (OR (EQ U A) (GREAT U A))))
  1828.        ((EQ E A))
  1829.        (T (GREAT E A)))) 
  1830.  
  1831. (DEFUN ORDLIST (A B CX CY)
  1832.        (PROG (L1 L2 C D) 
  1833.          (SETQ L1 (LENGTH A) L2 (LENGTH B))
  1834.     LOOP (COND ((= L1 0)
  1835.             (RETURN (COND ((= L2 0) (EQ CX 'MPLUS))
  1836.                   ((AND (EQ CX CY) (= L2 1))
  1837.                    (GREAT (COND ((EQ CX 'MPLUS) 0) (T 1)) (CAR B))))))
  1838.            ((= L2 0) (RETURN (NOT (ORDLIST B A CY CX)))))
  1839.          (SETQ C (NTHELEM L1 A) D (NTHELEM L2 B))
  1840.          (COND ((NOT (ALIKE1 C D)) (RETURN (GREAT C D))))
  1841.          (SETQ L1 (f1- L1) L2 (f1- L2))
  1842.          (GO LOOP)))
  1843.  
  1844. (DEFUN ORDFN (X Y)
  1845.   (LET ((CX (CAAR X)) (CY (CAAR Y)) U) 
  1846.     (COND ((EQ CX '%DEL) (IF (EQ CY '%DEL) (GREAT (CADR X) (CADR Y)) T))
  1847.       ((EQ CY '%DEL) NIL)
  1848.       ((MEMQ CX '(MPLUS MTIMES))
  1849.        (COND ((MEMQ CY '(MPLUS MTIMES)) (ORDLIST (CDR X) (CDR Y) CX CY))
  1850.          ((ALIKE1 (SETQ U (CAR (LAST X))) Y) (NOT (ORDHACK X)))
  1851.          ((AND (EQ CX 'MPLUS) (EQ CY 'MEXPT) (MPLUSP (CADR Y)))
  1852.           (NOT (ORDMEXPT Y X)))
  1853.          (T (GREAT U Y))))
  1854.       ((MEMQ CY '(MPLUS MTIMES)) (NOT (ORDFN Y X)))
  1855.       ((EQ CX 'MEXPT) (ORDMEXPT X Y))
  1856.       (T (NOT (ORDMEXPT Y X))))))  ; (EQ CY 'MEXPT)
  1857.  
  1858. (DEFUN ORDHACK (X)
  1859.   (IF (AND (CDDR X) (NULL (CDDDR X)))
  1860.       (GREAT (IF (EQ (CAAR X) 'MPLUS) 0 1) (CADR X))))
  1861.  
  1862. (DEFUN ORDMEXPT (X Y)
  1863.   (COND ((EQ (CAAR Y) 'MEXPT)
  1864.      (COND ((ALIKE1 (CADR X) (CADR Y)) (GREAT (CADDR X) (CADDR Y)))
  1865.            ((MAXIMA-CONSTANTP (CADR X))
  1866.         (IF (MAXIMA-CONSTANTP (CADR Y))
  1867.             (IF (OR (ALIKE1 (CADDR X) (CADDR Y))
  1868.                 (AND (MNUMP (CADDR X)) (MNUMP (CADDR Y))))
  1869.             (GREAT (CADR X) (CADR Y))
  1870.             (GREAT (CADDR X) (CADDR Y)))
  1871.             (GREAT X (CADR Y))))
  1872.            ((MAXIMA-CONSTANTP (CADR Y)) (GREAT (CADR X) Y))
  1873.            ((MNUMP (CADDR X))
  1874.         (GREAT (CADR X) (IF (MNUMP (CADDR Y)) (CADR Y) Y)))
  1875.            ((MNUMP (CADDR Y)) (GREAT X (CADR Y)))
  1876.            (T (LET ((X1 (SIMPLN1 X)) (Y1 (SIMPLN1 Y)))
  1877.             (IF (ALIKE1 X1 Y1) (GREAT (CADR X) (CADR Y))
  1878.                        (GREAT X1 Y1))))))
  1879.     ((MAXIMA-CONSTANTP (CADR X))
  1880.      (IF (ALIKE1 (CADDR X) Y) T (GREAT (CADDR X) Y)))
  1881.     ((ALIKE1 (CADR X) Y) (GREAT (CADDR X) 1))
  1882.     ((MNUMP (CADDR X)) (GREAT (CADR X) Y))
  1883.     (T (GREAT (SIMPLN1 X) (SIMPLN (LIST '(%LOG) Y) 1 T)))))
  1884.  
  1885. (DEFMFUN $MULTTHRU NARGS
  1886.   (LET (ARG1 ARG2)
  1887.     (COND ((= NARGS 2)
  1888.        (SETQ ARG1 (SPECREPCHECK (ARG 1)) ARG2 (SPECREPCHECK (ARG 2)))
  1889.        (COND ((OR (ATOM ARG2) (NOT (MEMQ (CAAR ARG2) '(MPLUS MEQUAL))))
  1890.           (MUL2 ARG1 ARG2))
  1891.          ((EQ (CAAR ARG2) 'MEQUAL)
  1892.           (LIST (CAR ARG2) ($MULTTHRU ARG1 (CADR ARG2))
  1893.                    ($MULTTHRU ARG1 (CADDR ARG2))))
  1894.          (T (EXPANDTERMS ARG1 (CDR ARG2)))))
  1895.       ((= NARGS 1)
  1896.        (PROG (L1) 
  1897.          (SETQ ARG1 (SETQ ARG2 (SPECREPCHECK (ARG 1))))
  1898.          (COND ((ATOM ARG1) (RETURN ARG1))
  1899.                ((EQ (CAAR ARG1) 'MNCTIMES)
  1900.             (SETQ ARG1 (CDR ARG1)) (GO NCT))
  1901.                ((NOT (EQ (CAAR ARG1) 'MTIMES)) (RETURN ARG1)))
  1902.          (SETQ ARG1 (REVERSE (CDR ARG1)))
  1903.         TIMES(WHEN (MPLUSP (CAR ARG1))
  1904.            (SETQ L1 (NCONC L1 (CDR ARG1)))
  1905.            (RETURN (EXPANDTERMS (MULN L1 T) (CDAR ARG1))))
  1906.          (SETQ L1 (CONS (CAR ARG1) L1))
  1907.          (SETQ ARG1 (CDR ARG1))
  1908.          (IF (NULL ARG1) (RETURN ARG2))
  1909.          (GO TIMES)
  1910.         NCT  (WHEN (MPLUSP (CAR ARG1))
  1911.            (SETQ L1 (NREVERSE L1))
  1912.            (RETURN (ADDN (MAPCAR
  1913.                   #'(LAMBDA (U) 
  1914.                      (SIMPLIFYA
  1915.                       (CONS '(MNCTIMES) 
  1916.                         (APPEND L1 (NCONS U) (CDR ARG1)))
  1917.                       T))
  1918.                   (CDAR ARG1))
  1919.                  T)))
  1920.          (SETQ L1 (CONS (CAR ARG1) L1))
  1921.          (SETQ ARG1 (CDR ARG1))
  1922.          (IF (NULL ARG1) (RETURN ARG2))
  1923.          (GO NCT)))
  1924.       (T (WNA-ERR '$MULTTHRU)))))
  1925.  
  1926. ;  EXPANDEXPT computes the expansion of (x1 + x2 + ... + xm)^n
  1927. ;  taking a sum and integer power as arguments.
  1928. ;  Its theory is to recurse down the binomial expansion of
  1929. ;  (x1 + (x2 + x3 + ... + xm))^n using the Binomial Expansion
  1930. ;  Thus it does a sigma:
  1931. ;
  1932. ;                n
  1933. ;             -------
  1934. ;              \         / n \    k                (n - k)
  1935. ;               >        |   |  x1  (x2 + x3 + ... + xm)
  1936. ;           /     \ k / 
  1937. ;             -------
  1938. ;               k=0
  1939. ;
  1940. ;   The function EXPONENTIATE-SUM does this and recurses through the second
  1941. ;   sum raised to a power.  It takes a list of terms and a positive integer
  1942. ;   power as arguments.
  1943.  
  1944.  
  1945. (DEFUN EXPANDEXPT (SUM POWER)
  1946.        (DECLARE (FIXNUM POWER))
  1947.        (LET ((EXPANSION (EXPONENTIATE-SUM (CDR SUM) (ABS POWER))))
  1948.         (COND ((PLUSP POWER) EXPANSION)
  1949.           (T `((MEXPT SIMP) ,EXPANSION -1)))))
  1950.  
  1951. (DEFUN EXPONENTIATE-SUM (TERMS RPOWER)
  1952.    (DECLARE (FIXNUM RPOWER))
  1953.    (COND ((= RPOWER 0) 1)
  1954.      ((NULL (CDR TERMS)) (POWER (CAR TERMS) RPOWER))
  1955.      ((= RPOWER 1) (CONS '(MPLUS SIMP) TERMS))
  1956.      (T (DO ((I 0 (f1+ I))
  1957.          (RESULT 0 (ADD2 RESULT
  1958.                  (MULN (LIST (COMBINATION RPOWER I)
  1959.                          (EXPONENTIATE-SUM (CDR TERMS)
  1960.                                    (f- RPOWER I))
  1961.                          (POWER (CAR TERMS) I)) T))))
  1962.         ((> I RPOWER) RESULT)
  1963.           (declare (fixnum i))
  1964.           ))))
  1965.                     
  1966. ;  Computes the combination of n elements taken m at a time by the formula
  1967. ;  
  1968. ;     (n * (n-1) * ... * (n - m + 1)) / m! =
  1969. ;      (n / 1) * ((n - 1) / 2) * ... * ((n - m + 1) / m)
  1970. ;  
  1971. ;  Checks for the case when m is greater than n/2 and translates
  1972. ;  to an equivalent expression.
  1973.  
  1974. (DEFUN COMBINATION (N M)
  1975.        (DECLARE (FIXNUM N M))
  1976.        (COND ((> M (// N 2)) (COMBINATION N (f- N M)))
  1977.          (T (DO ((RESULT 1 (QUOTIENT (TIMES RESULT N1) M1))
  1978.              (N1 N (f1- N1))
  1979.              (M1 1 (f1+ M1)))
  1980.             ((> M1 M) RESULT)
  1981.           (declare (fixnum  N1 M1))
  1982.           ))))
  1983.  
  1984. (DEFUN EXPANDSUMS (A B) 
  1985.        (ADDN (PROG (C)
  1986.            (SETQ A (FIXEXPAND A) B (CDR B))
  1987.           LOOP (COND ((NULL A) (RETURN C)))
  1988.            (SETQ C (CONS (EXPANDTERMS (CAR A) B) C))
  1989.            (SETQ A (CDR A))
  1990.            (GO LOOP))
  1991.          T))
  1992.  
  1993. (DEFUN EXPANDTERMS (A B) 
  1994.        (ADDN (PROG (C)
  1995.           LOOP (COND ((NULL B) (RETURN C)))
  1996.            (SETQ C (CONS (MUL2 A (CAR B)) C))
  1997.            (SETQ B (CDR B))
  1998.            (GO LOOP))
  1999.          T))
  2000.  
  2001. (DEFUN GENEXPANDS (L) 
  2002.  (PROG NIL
  2003.   LOOP (SETQ L (CDR L))
  2004.        (COND ((NULL L)
  2005.           (SETQ PRODS (NREVERSE PRODS) NEGPRODS (NREVERSE NEGPRODS)
  2006.             SUMS (NREVERSE SUMS) NEGSUMS (NREVERSE NEGSUMS))
  2007.           (RETURN NIL))
  2008.          ((ATOM (CAR L)) (SETQ PRODS (CONS (CAR L) PRODS)))
  2009.          ((EQ (CAAAR L) 'RAT)
  2010.           (COND ((NOT (EQUAL (CADAR L) 1)) (SETQ PRODS (CONS (CADAR L) PRODS))))
  2011.           (SETQ NEGPRODS (CONS (CADDAR L) NEGPRODS)))
  2012.          ((EQ (CAAAR L) 'MPLUS) (SETQ SUMS (CONS (CAR L) SUMS)))
  2013.          ((AND (EQ (CAAAR L) 'MEXPT) (EQUAL (CADDAR L) -1) (MPLUSP (CADAR L)))
  2014.           (SETQ NEGSUMS (CONS (CADAR L) NEGSUMS)))
  2015.          ((AND (EQ (CAAAR L) 'MEXPT) ((LAMBDA (EXPANDP) (MMINUSP (CADDAR L))) T))
  2016.           (SETQ NEGPRODS
  2017.             (CONS (COND ((EQUAL (CADDAR L) -1) (CADAR L))
  2018.                 (T (LIST (CAAR L) (CADAR L) (NEG (CADDAR L)))))
  2019.               NEGPRODS)))
  2020.          (T (SETQ PRODS (CONS (CAR L) PRODS))))
  2021.        (GO LOOP)))
  2022.  
  2023. (DEFUN EXPANDTIMES (A) 
  2024.        (PROG (PRODS NEGPRODS SUMS NEGSUMS EXPSUMS EXPNEGSUMS) 
  2025.          (GENEXPANDS A)
  2026.          (SETQ PRODS (COND ((NULL PRODS) 1)
  2027.                    ((NULL (CDR PRODS)) (CAR PRODS))
  2028.                    (T (CONS '(MTIMES SIMP) PRODS))))
  2029.          (SETQ NEGPRODS (COND ((NULL NEGPRODS) 1)
  2030.                   ((NULL (CDR NEGPRODS)) (CAR NEGPRODS))
  2031.                   (T (CONS '(MTIMES SIMP) NEGPRODS))))
  2032.          (COND ((NULL SUMS) (GO DOWN))
  2033.            (T (SETQ EXPSUMS (CAR SUMS))
  2034.               (MAPC (FUNCTION (LAMBDA (C)
  2035.                        (SETQ EXPSUMS (EXPANDSUMS EXPSUMS C))))
  2036.                 (CDR SUMS))))
  2037.          (SETQ PRODS (COND ((EQUAL PRODS 1) EXPSUMS)
  2038.                    (T (EXPANDTERMS PRODS (FIXEXPAND EXPSUMS)))))
  2039.     DOWN (COND
  2040.           ((NULL NEGSUMS)
  2041.            (COND
  2042.         ((EQUAL 1 NEGPRODS) (RETURN PRODS))
  2043.         ((MPLUSP PRODS) (RETURN (EXPANDTERMS (POWER NEGPRODS -1) (CDR PRODS))))
  2044.         (T (RETURN ((LAMBDA (EXPANDFLAG) (MUL2 PRODS (POWER NEGPRODS -1))) T)))))
  2045.           (T (SETQ EXPNEGSUMS (CAR NEGSUMS))
  2046.          (MAPC (FUNCTION (LAMBDA (C)
  2047.                   (SETQ EXPNEGSUMS (EXPANDSUMS EXPNEGSUMS C))))
  2048.                (CDR NEGSUMS))))
  2049.          (SETQ EXPNEGSUMS (EXPANDTERMS NEGPRODS (FIXEXPAND EXPNEGSUMS)))
  2050.          (RETURN
  2051.           (COND ((MPLUSP PRODS)
  2052.              (EXPANDTERMS (LIST '(MEXPT SIMP) EXPNEGSUMS -1) (CDR PRODS)))
  2053.             (T ((LAMBDA (EXPANDFLAG)
  2054.              (MUL2 PRODS (LIST '(MEXPT SIMP) EXPNEGSUMS -1))) T))))))
  2055.  
  2056. (DEFMFUN EXPAND1 (EXP $EXPOP $EXPON)
  2057.   (SSIMPLIFYA (SPECREPCHECK EXP)))
  2058.  
  2059. ;; When the arg-count checking code is implemented ...
  2060. ;; (DEFMFUN $EXPAND (EXP &OPTIONAL ($EXPOP $MAXPOSEX) ($EXPON $MAXNEGEX))
  2061. ;;   (SSIMPLIFYA (SPECREPCHECK EXP)))
  2062.  
  2063. (DEFMFUN $EXPAND NARGS
  2064.  (COND ((= NARGS 1) (EXPAND1 (ARG 1) $MAXPOSEX $MAXNEGEX))
  2065.        ((= NARGS 2) (EXPAND1 (ARG 1) (ARG 2) $MAXNEGEX))
  2066.        ((= NARGS 3) (EXPAND1 (ARG 1) (ARG 2) (ARG 3)))
  2067.        (T (WNA-ERR '$EXPAND))))
  2068.  
  2069. (DEFUN FIXEXPAND (A) (COND ((NOT (MPLUSP A)) (NCONS A)) (T (CDR A))))
  2070.  
  2071.  
  2072. (DEFMFUN SIMPNRT (X *N)  ; computes X^(1/*N)
  2073.        (PROG (*IN *OUT VARLIST GENVAR $FACTORFLAG $DONTFACTOR)
  2074.          (SETQ $FACTORFLAG T)
  2075.          (NEWVAR X)
  2076.          (SETQ X (RATREP* X))
  2077.          (COND ((EQUAL (CADR X) 0) (RETURN 0)))
  2078.          (SETQ X (RATFACT (CDR X) 'PSQFR))
  2079.          (SIMPNRT1 (MAPCAR #'PDIS X))
  2080.          (SETQ *OUT (COND (*OUT (MULN *OUT NIL)) (T 1)))
  2081.          (SETQ *IN (COND (*IN (SETQ *IN (MULN *IN NIL))
  2082.                   (NRTHK *IN *N))
  2083.                  (T 1)))
  2084.          (RETURN
  2085.           ((LAMBDA ($%EMODE) 
  2086.                (SIMPLIFYA (LIST '(MTIMES) *IN *OUT)
  2087.                   (NOT (OR (ATOM *IN)
  2088.                        (ATOM (CADR *IN))
  2089.                        (MEMQ (CAAADR *IN) '(MPLUS MTIMES RAT))))))
  2090.            T))))
  2091.  
  2092. (DEFUN SIMPNRT1 (X) 
  2093.  (DO ((X X (CDDR X)) (Y)) ((NULL X))
  2094.      (COND ((NOT (EQUAL 1 (SETQ Y (GCD (CADR X) *N))))
  2095.         (PUSH (SIMPNRT (LIST '(MEXPT) (CAR X) (QUOTIENT (CADR X) Y))
  2096.                (QUOTIENT *N Y))
  2097.           *OUT))
  2098.        ((AND (EQUAL (CADR X) 1) (INTEGERP (CAR X)) (PLUSP (CAR X))
  2099.          (SETQ Y (PNTHROOTP (CAR X) *N)))
  2100.         (PUSH Y *OUT))
  2101.        (T (COND ((NOT (GREATERP *N (ABS (CADR X))))
  2102.              (PUSH (LIST '(MEXPT) (CAR X) (QUOTIENT (CADR X) *N)) *OUT)))
  2103.           (PUSH (LIST '(MEXPT) (CAR X) (REMAINDER (CADR X) *N)) *IN)))))
  2104.  
  2105. (DEFUN NRTHK (IN *N) 
  2106.  (COND ((EQUAL IN 1) 1)
  2107.        ((EQUAL IN -1)
  2108.     (COND ((EQUAL *N 2) '$%I)
  2109.           ((EQ $DOMAIN '$REAL)
  2110.            (COND ((EVEN *N) (NRTHK2 -1 *N))
  2111.              (T -1)))
  2112.           ($M1PBRANCH
  2113.            ((LAMBDA ($%EMODE) 
  2114.          (POWER* '$%E (LIST '(MTIMES) (LIST '(RAT) 1 *N) '$%PI '$%I)))
  2115.         T))
  2116.           (T (NRTHK2 -1 *N))))
  2117.        ((OR (AND WFLAG (EQ ($ASKSIGN IN) '$NEG))
  2118.         (AND (MNUMP IN) (EQUAL ($SIGN IN) '$NEG)))
  2119.     (NRTHK1 (MUL2* -1 IN) *N))
  2120.        (T (NRTHK2 IN *N))))
  2121.  
  2122. (DEFUN NRTHK1 (IN *N)  ; computes (-IN)^(1/*N)
  2123.  (COND ($RADEXPAND (MUL2 (NRTHK2 IN *N) (NRTHK -1 *N)))
  2124.        (T (NRTHK2 (MUL2* -1 IN) *N))))
  2125.  
  2126. (DEFUN NRTHK2 (IN *N) (POWER* IN (LIST '(RAT) 1 *N)))  ; computes IN^(1/*N)
  2127.  
  2128. ;; The following was formerly in SININT.  This code was placed here because 
  2129. ;; SININT is now an out-of-core file on MC, and this code is needed in-core
  2130. ;; because of the various calls to it. - BMT & JPG
  2131.  
  2132. (DECLARE-TOP(SPECIAL VAR $RATFAC RATFORM CONTEXT) (FIXNUM NARGS)
  2133.      #-cl
  2134.      (*LEXPR CONTEXT))    
  2135.  
  2136. (DEFMFUN $INTEGRATE NARGS
  2137.   (LET ($RATFAC)
  2138.     (COND ((= NARGS 2)
  2139.        (WITH-NEW-CONTEXT (CONTEXT)
  2140.          (IF (MEMQ '%RISCH NOUNL) (RISCHINT (ARG 1) (ARG 2))
  2141.                       (SININT (ARG 1) (ARG 2)))))
  2142.       ((= NARGS 4) ($DEFINT (ARG 1) (ARG 2) (ARG 3) (ARG 4)))
  2143.       (T (WNA-ERR '$INTEGRATE))))) 
  2144.  
  2145. (DEFMFUN RATP (A VAR)
  2146.   (COND ((ATOM A) T)
  2147.     ((MEMQ (CAAR A) '(MPLUS MTIMES))
  2148.      (DO ((L (CDR A) (CDR L))) ((NULL L) T)
  2149.        (OR (RATP (CAR L) VAR) (RETURN NIL))))
  2150.     ((EQ (CAAR A) 'MEXPT)
  2151.      (IF (FREE (CADR A) VAR)
  2152.          (FREE (CADDR A) VAR)
  2153.          (AND (INTEGERP (CADDR A)) (RATP (CADR A) VAR))))
  2154.     (T (FREE A VAR))))
  2155.  
  2156. (DEFMFUN RATNUMERATOR (R)
  2157.   (COND ((ATOM R) R)
  2158.     ((ATOM (CDR R)) (CAR R))
  2159.     ((NUMBERP (CADR R)) R)
  2160.     (T (CAR R))))
  2161.      
  2162. (DEFMFUN RATDENOMINATOR (R)
  2163.   (COND ((ATOM R) 1)
  2164.     ((ATOM (CDR R)) (CDR R))
  2165.     ((NUMBERP (CADR R)) 1)
  2166.     (T (CDR R))))
  2167.  
  2168. (DECLARE-TOP(SPECIAL VAR))
  2169.  
  2170. ;(DEFMFUN BPROG (R S)
  2171. ;  (PROG (P1B P2B COEF1R COEF2R COEF1S COEF2S F1 F2 A EGCD)
  2172. ;    (SETQ R (RATFIX R))
  2173. ;    (SETQ S (RATFIX S))
  2174. ;    (SETQ COEF2R (SETQ COEF1S 0))
  2175. ;    (SETQ COEF2S (SETQ COEF1R 1))
  2176. ;     (SETQ A 1 EGCD 1)
  2177. ;    (SETQ P1B (CAR R))
  2178. ;    (UNLESS (ZEROP (PDEGREE P1B VAR)) (SETQ EGCD (PGCDEXPON P1B)))
  2179. ;    (SETQ P2B (CAR S))
  2180. ;    (UNLESS (OR (ZEROP (PDEGREE P2B VAR)) (= EGCD 1))
  2181. ;        (SETQ EGCD (GCD EGCD (PGCDEXPON P2B)))
  2182. ;        (SETQ P1B (PEXPON*// P1B EGCD NIL)
  2183. ;              P2B (PEXPON*// P2B EGCD NIL)))
  2184. ;   B1   (COND ((LESSP (PDEGREE P1B VAR) (PDEGREE P2B VAR))
  2185. ;           (EXCH P1B P2B)
  2186. ;           (EXCH COEF1R COEF2R)
  2187. ;           (EXCH COEF1S COEF2S)))
  2188. ;    (WHEN (ZEROP (PDEGREE P2B VAR))
  2189. ;          (UNLESS (ZEROP (PDEGREE COEF2R VAR))
  2190. ;              (SETQ COEF2R (PEXPON*// COEF2R EGCD T)))
  2191. ;          (UNLESS (ZEROP (PDEGREE COEF2S VAR))
  2192. ;              (SETQ COEF2S (PEXPON*// COEF2S EGCD T)))
  2193. ;          (RETURN (CONS (RATREDUCE (PTIMES (CDR R) COEF2R) P2B)
  2194. ;                (RATREDUCE (PTIMES (CDR S) COEF2S) P2B))))
  2195. ;    (SETQ F1 (PSQUOREM1 (CDR P1B) (CDR P2B) T))
  2196. ;    (SETQ F2 (PSIMP VAR (CADR F1)))
  2197. ;    (SETQ P1B (PQUOTIENTCHK (PSIMP VAR (CADDR F1)) A))
  2198. ;    (SETQ F1 (CAR F1))
  2199. ;    (SETQ COEF1R (PQUOTIENTCHK (PDIFFERENCE (PTIMES F1 COEF1R)
  2200. ;                        (PTIMES F2 COEF2R))
  2201. ;                   A))
  2202. ;    (SETQ COEF1S (PQUOTIENTCHK (PDIFFERENCE (PTIMES F1 COEF1S)
  2203. ;                        (PTIMES F2 COEF2S))
  2204. ;                   A))
  2205. ;    (SETQ A F1)
  2206. ;    (GO B1)))
  2207. ;Update from F302 --gsb
  2208. (DEFUN BPROG (R S)
  2209.   (PROG (P1B P2B COEF1R COEF2R COEF1S COEF2S F1 F2 A EGCD)
  2210.     (SETQ R (RATFIX R))
  2211.     (SETQ S (RATFIX S))
  2212.     (SETQ COEF2R (SETQ COEF1S 0))
  2213.     (SETQ COEF2S (SETQ COEF1R 1))
  2214.      (SETQ A 1 EGCD 1)
  2215.     (SETQ P1B (CAR R))
  2216.     (UNLESS (ZEROP (PDEGREE P1B VAR)) (SETQ EGCD (PGCDEXPON P1B)))
  2217.     (SETQ P2B (CAR S))
  2218.     (UNLESS (OR (ZEROP (PDEGREE P2B VAR)) (= EGCD 1))
  2219.         (SETQ EGCD (GCD EGCD (PGCDEXPON P2B)))
  2220.         (SETQ P1B (PEXPON*// P1B EGCD NIL)
  2221.               P2B (PEXPON*// P2B EGCD NIL)))
  2222.    B1   (COND ((LESSP (PDEGREE P1B VAR) (PDEGREE P2B VAR))
  2223.            (EXCH P1B P2B)
  2224.            (EXCH COEF1R COEF2R)
  2225.            (EXCH COEF1S COEF2S)))
  2226.     (WHEN (ZEROP (PDEGREE P2B VAR))
  2227.           (UNLESS (ZEROP (PDEGREE COEF2R VAR))
  2228.               (SETQ COEF2R (PEXPON*// COEF2R EGCD T)))
  2229.           (UNLESS (ZEROP (PDEGREE COEF2S VAR))
  2230.               (SETQ COEF2S (PEXPON*// COEF2S EGCD T)))
  2231.           (RETURN (CONS (RATREDUCE (PTIMES (CDR R) COEF2R) P2B)
  2232.                 (RATREDUCE (PTIMES (CDR S) COEF2S) P2B))))
  2233.     (SETQ F1 (PSQUOREM1 (CDR P1B) (CDR P2B) T))
  2234.     (SETQ F2 (PSIMP VAR (CADR F1)))
  2235.     (SETQ P1B (PQUOTIENTCHK (PSIMP VAR (CADDR F1)) A))
  2236.     (SETQ F1 (CAR F1))
  2237.     (SETQ COEF1R (PQUOTIENTCHK (PDIFFERENCE (PTIMES F1 COEF1R)
  2238.                         (PTIMES F2 COEF2R))
  2239.                    A))
  2240.     (SETQ COEF1S (PQUOTIENTCHK (PDIFFERENCE (PTIMES F1 COEF1S)
  2241.                         (PTIMES F2 COEF2S))
  2242.                    A))
  2243.     (SETQ A F1)
  2244.     (GO B1)))
  2245.  
  2246. (DEFMFUN RATDIFFERENCE (A B) (RATPLUS A (RATMINUS B)))
  2247.  
  2248. (DEFMFUN RATPL (A B) (RATPLUS (RATFIX A) (RATFIX B)))
  2249.  
  2250. (DEFMFUN RATTI (A B C) (RATTIMES (RATFIX A) (RATFIX B) C)) 
  2251.  
  2252. (DEFMFUN RATQU (A B) (RATQUOTIENT (RATFIX A) (RATFIX B))) 
  2253.  
  2254. (DEFMFUN RATFIX (A) (COND ((EQUAL A (RATNUMERATOR A)) (CONS A 1)) (T A)))
  2255.      
  2256. (DEFMFUN RATDIVIDE (F G)
  2257.        (LET* (((FNUM . FDEN) (RATFIX F))
  2258.           ((GNUM . GDEN) (RATFIX G))
  2259.           ((Q R) (PDIVIDE FNUM GNUM)))
  2260.          (CONS (RATQU (RATTI Q GDEN T) FDEN)
  2261.            (RATQU R FDEN))))
  2262.  
  2263. (DEFMFUN POLCOEF (L N) (COND ((OR (ATOM L) (POINTERGP VAR (CAR L)))
  2264.                 (COND ((EQUAL N 0) L) (T 0)))
  2265.                (T (PTERM (CDR L) N))))
  2266.  
  2267. (DEFUN DISREP (L) (COND ((EQUAL (RATNUMERATOR L) L)
  2268.              ($RATDISREP (CONS RATFORM (CONS L 1))))
  2269.             (T ($RATDISREP (CONS RATFORM L)))))
  2270.  
  2271. (DECLARE-TOP(UNSPECIAL VAR))
  2272.  
  2273.  
  2274. ;; The following was formerly in MATRUN.  This code was placed here because 
  2275. ;; MATRUN is now an out-of-core file on MC, and this code is needed in-core 
  2276. ;; so that MACSYMA SAVE files will work. - JPG
  2277.  
  2278. (DEFVAR *AFTERFLAG NIL)
  2279.  
  2280. (DEFMFUN MATCHERR NIL (THROW 'MATCH NIL))
  2281.  
  2282. (DEFMFUN KAR (X) (IF (ATOM X) (MATCHERR) (CAR X)))
  2283.  
  2284. (DEFMFUN KDR (X) (IF (ATOM X) (MATCHERR) (CDR X)))
  2285.  
  2286. (DEFMFUN SIMPARGS1 (A VESTIGIAL C)
  2287.        VESTIGIAL ;Ignored.
  2288.        (SIMPARGS A C))
  2289.  
  2290. (DEFMFUN *KAR (X) (IF (NOT (ATOM X)) (CAR X)))
  2291.  
  2292. ;MATCOEF is obsolete, only needed for old SAVE files. - JPG 5/12/80
  2293. #-(or cl NIL)
  2294. (DEFUN MATCOEF FEXPR (L)
  2295.  (RATDISREP (RATCOEF (MEVAL (CAR L)) (MEVAL (CADR L)))))
  2296. ; NIL doesn't handle fexprs, and the compatibility mode isn't
  2297. ; hacked for it yet. The lexical scoping in the evaluator will
  2298. ; absolutely shoot to hell any chance of running the output of
  2299. ; the matchcompiler anyway, without a good bit of hacking to MATCOM
  2300. ; to make sure all the special declarations are generated.
  2301. ; The same problem comes up if one tried to compile the output of
  2302. ; the match compiler in just about any lisp of course.
  2303. ; The easiest thing to do is probably to write a simple
  2304. ; dynamic-binding evaluator for use in lusing situations like
  2305. ; this!
  2306. #-(or NIL cl)
  2307. (DEFUN RETLIST FEXPR (L)
  2308.  (CONS '(MLIST SIMP)
  2309.        (MAPCAR #'(LAMBDA (Z) (LIST '(MEQUAL SIMP) Z (MEVAL Z))) L)))
  2310. #+cl
  2311. (defquote RETLIST (&rest L)
  2312.  (CONS '(MLIST SIMP)
  2313.        (MAPCAR #'(LAMBDA (Z) (LIST '(MEQUAL SIMP) Z (MEVAL Z))) L)))
  2314.  
  2315. (DEFMFUN NTHKDR (X C) (IF (ZEROP C) X (NTHKDR (KDR X) (SUB1 C))))
  2316.  
  2317.  
  2318. ; Undeclarations for the file:
  2319. #-NIL
  2320. (DECLARE-TOP(NOTYPE L1 L2 XN NARGS I))
  2321.