1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancments. ;;;;;
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
15 (declare-top (special rulesw
*inv
* substp limitp
16 prods negprods sums negsums
17 $scalarmatrixp
*nounl
*
20 bigfloatzero bigfloatone $assumescalar
21 opers-list
*opers-list $dontfactor
*n
22 *out
*in varlist genvar $factorflag radcanp
23 *builtin-numeric-constants
*))
25 ;; General purpose simplification and conversion switches.
27 (defmvar $negdistrib t
28 "Causes negations to be distributed over sums, e.g. -(A+B) is
32 "Causes SOME mathematical functions (including exponentiation)
33 with numerical arguments to be evaluated in floating point.
34 It causes variables in an expression which have been given
35 NUMERVALs to be replaced by their values. It also turns
37 see-also
($numerval $float
))
39 (defmvar $simp t
"Enables simplification.")
41 (defmvar $sumexpand nil
42 "If TRUE, products of sums and exponentiated sums go into nested
45 (defmvar $numer_pbranch nil
)
47 ;; Switches dealing with matrices and non-commutative multiplication.
49 (defmvar $doscmxplus nil
50 "Causes SCALAR + MATRIX to return a matrix answer. This switch
51 is not subsumed under DOALLMXOPS.")
54 "Causes SCALAR^MATRIX([1,2],[3,4]) to return
55 MATRIX([SCALAR,SCALAR^2],[SCALAR^3,SCALAR^4]). In general, this
56 transformation affects exponentiations where the *print-base* is a
57 scalar and the power is a matrix or list.")
59 (defmvar $domxplus nil
)
61 (defmvar $domxtimes nil
)
65 ;; Switches dealing with expansion.
68 "The largest positive exponent which will be automatically
69 expanded. (X+1)^3 will be automatically expanded if
70 EXPOP is greater than or equal to 3."
72 see-also
($expon $maxposex $expand
))
75 "The largest negative exponent which will be automatically
76 expanded. (X+1)^(-3) will be automatically expanded if
77 EXPON is greater than or equal to 3."
79 see-also
($expop $maxnegex $expand
))
81 (defmvar $maxposex
1000.
82 "The largest positive exponent which will be expanded by
85 see-also
($maxnegex $expop $expand
))
87 ;; Check assignment to be a positive integer
88 (putprop '$maxposex
'posintegerset
'assign
)
90 (defmvar $maxnegex
1000.
91 "The largest negative exponent which will be expanded by
94 see-also
($maxposex $expon $expand
))
96 ;; Check assignment to be a positive integer
97 (putprop '$maxnegex
'posintegerset
'assign
)
99 ;; Lisp level variables
102 "Causes SIMP flags to be ignored. $EXPAND works by binding
103 $EXPOP to $MAXPOSEX, $EXPON to $MAXNEGEX, and DOSIMP to T.")
106 "Causes a throw to the tag ERRORSW when certain errors occur
107 rather than the printing of a message. Kludgy MAXIMA-SUBSTITUTE for
108 MAXIMA-ERROR signalling.")
110 (defmvar derivsimp t
"Hack in `simpderiv' for `rwg'")
112 (defmvar $rootsepsilon
#+gcl
(float 1/10000000) #-gcl
1e-7)
113 (defmvar $grindswitch nil
)
114 (defmvar $algepsilon
100000000)
119 (defmvar $logabs nil
)
120 (defmvar $limitdomain
'$complex
)
121 (defmvar $listarith t
)
122 (defmvar $domain
'$real
)
123 (defmvar $m1pbranch nil
)
124 (defmvar $%e_to_numlog nil
)
126 (defmvar $lognegint nil
)
127 (defmvar $ratsimpexpons nil
)
128 (defmvar $logexpand t
) ; Possible values are T, $ALL and $SUPER
129 (defmvar $radexpand t
)
130 (defmvar $subnumsimp nil
)
132 (defmvar $distribute_over t
) ; If T, functions are distributed over bags.
135 (defvar rp-polylogp nil
)
138 (defvar timesinp nil
)
139 (defvar %e-val
(mget '$%e
'$numer
))
140 (defvar %pi-val
(mget '$%pi
'$numer
))
141 (defvar derivflag nil
)
142 (defvar exptrlsw nil
)
143 (defvar expandflag nil
)
144 (defvar *zexptsimp? nil
)
147 (defprop mnctimes t associative
)
148 (defprop lambda t lisp-no-simp
)
150 ;; Local functions should not be simplified. Various lisps
151 ;; use various names for the list structure defining these:
154 #-gcl
(:load-toplevel
)
157 (dolist (y (list x z
))
160 (setf (get (car y
) 'lisp-no-simp
) t
))))))
162 (dolist (x '(mplus mtimes mnctimes mexpt mncexpt %sum
))
163 (setf (get x
'msimpind
) (cons x
'(simp))))
165 ;; operators properties
167 (mapc #'(lambda (x) (setf (get (first x
) 'operators
) (second x
)))
168 '((mplus simplus
) (mtimes simptimes
) (mncexpt simpncexpt
)
169 (mminus simpmin
) (%gamma simpgamma
) (mfactorial simpfact
)
170 (mnctimes simpnct
) (mquotient simpquot
) (mexpt simpexpt
)
172 (%derivative simpderiv
)
174 (%integrate simpinteg
) (%limit simp-limit
)
175 (bigfloat simpbigfloat
) (lambda simplambda
) (mdefine simpmdef
)
176 (mqapply simpmqapply
) (%gamma simpgamma
)
177 ($beta simpbeta
) (%sum simpsum
) (%binomial simpbinocoef
)
178 (%plog simpplog
) (%product simpprod
) (%genfact simpgfact
)
179 ($atan2 simpatan2
) ($matrix simpmatrix
) (%matrix simpmatrix
)
180 ($bern simpbern
) ($euler simpeuler
)))
182 (defprop $li lisimp specsimp
)
183 (defprop $psi psisimp specsimp
)
185 (defprop $equal t binary
)
186 (defprop $notequal t binary
)
188 (defmfun $bfloatp
(x)
191 (eq (caar x
) 'bigfloat
)))
194 (or (and (integerp x
) (= 0 x
))
195 (and (floatp x
) (= 0.0 x
))
196 (and ($bfloatp x
) (= 0 (second x
)))))
199 (or (and (integerp x
) (= 1 x
))
200 (and (floatp x
) (= 1.0 x
))
201 (and ($bfloatp x
) (zerop1 (sub x
1)))))
205 (and (not (atom x
)) (not (atom (car x
)))
206 (member (caar x
) '(rat bigfloat
)))))
208 ;; Does X or a subexpression match PREDICATE?
210 ;; If X is a tree then we recurse depth-first down its arguments. The specrep
211 ;; check is because rat forms are built rather differently from normal Maxima
212 ;; expressions so we need to unpack them for the recursion to work properly.
213 (defun subexpression-matches-p (predicate x
)
214 (or (funcall predicate x
)
217 (subexpression-matches-p predicate
(specdisrep x
))
218 (some (lambda (arg) (subexpression-matches-p predicate arg
))
221 ;; Is there a bfloat anywhere in X?
222 (defun some-bfloatp (x) (subexpression-matches-p '$bfloatp x
))
224 ;; Is there a float anywhere in X?
225 (defun some-floatp (x) (subexpression-matches-p 'floatp x
))
227 ;; EVEN works for any arbitrary lisp object since it does an integer
228 ;; check first. In other cases, you may want the Lisp EVENP function
229 ;; which only works for integers.
231 (defun even (a) (and (integerp a
) (not (oddp a
))))
233 (defun ratnump (x) (and (not (atom x
)) (eq (caar x
) 'rat
)))
235 (defun mplusp (x) (and (not (atom x
)) (eq (caar x
) 'mplus
)))
237 (defun mtimesp (x) (and (not (atom x
)) (eq (caar x
) 'mtimes
)))
239 (defun mexptp (x) (and (not (atom x
)) (eq (caar x
) 'mexpt
)))
241 (defun mnctimesp (x) (and (not (atom x
)) (eq (caar x
) 'mnctimes
)))
243 (defun mncexptp (x) (and (not (atom x
)) (eq (caar x
) 'mncexpt
)))
245 (defun mlogp (x) (and (not (atom x
)) (eq (caar x
) '%log
)))
247 (defun mmminusp (x) (and (not (atom x
)) (eq (caar x
) 'mminus
)))
250 (cond ((realp x
) (minusp x
))
251 ((or (ratnump x
) ($bfloatp x
)) (minusp (cadr x
)))))
253 (defun mqapplyp (e) (and (not (atom e
)) (eq (caar e
) 'mqapply
)))
255 (defun ratdisrep (e) (simplifya ($ratdisrep e
) nil
))
257 (defun sratsimp (e) (simplifya ($ratsimp e
) nil
))
259 (defun simpcheck (e flag
)
260 (cond ((specrepp e
) (specdisrep e
))
262 (t (let (($%enumer $numer
))
263 ;; Switch $%enumer on, when $numer is TRUE to allow
264 ;; simplification of $%e to its numerical value.
265 (simplifya e nil
)))))
267 (defun mratcheck (e) (if ($ratp e
) (ratdisrep e
) e
))
269 (defmfun $numberp
(e) (or ($ratnump e
) ($floatnump e
) ($bfloatp e
)))
271 (defmfun $integerp
(x)
274 (not (member 'trunc
(car x
)))
276 (equal (cddr x
) 1))))
278 ;; The call to $INTEGERP in the following two functions checks for a CRE
279 ;; rational number with an integral numerator and a unity denominator.
282 (cond ((integerp x
) (oddp x
))
283 (($integerp x
) (oddp (cadr x
)))))
286 (cond ((integerp x
) (evenp x
))
287 (($integerp x
) (not (oddp (cadr x
))))))
289 (defmfun $floatnump
(x)
291 (and ($ratp x
) (floatp (cadr x
)) (onep1 (cddr x
)))))
293 (defmfun $ratnump
(x)
297 (not (member 'trunc
(car x
)))
299 (integerp (cddr x
)))))
304 (eq (caar x
) 'mrat
)))
306 (defmfun $taylorp
(x)
309 (member 'trunc
(cdar x
) :test
#'eq
) t
))
311 (defun specrepcheck (e) (if (specrepp e
) (specdisrep e
) e
))
313 ;; Note that the following two functions are carefully coupled.
317 (member (caar e
) '(mrat mpois
) :test
#'eq
)))
319 (defun specdisrep (e)
320 (cond ((eq (caar e
) 'mrat
) (ratdisrep e
))
323 (defmfun $polysign
(x)
324 (setq x
(cadr (ratf x
)))
325 (cond ((equal x
0) 0) ((pminusp x
) -
1) (t 1)))
327 ;; These check for the correct number of operands within Macsyma expressions,
328 ;; not arguments in a procedure call as the name may imply.
330 (defun arg-count-check (required-arg-count expr
)
331 (unless (= required-arg-count
(length (rest expr
)))
332 (wna-err expr required-arg-count
)))
334 (defun oneargcheck (expr)
335 (arg-count-check 1 expr
))
337 (defun twoargcheck (expr)
338 (arg-count-check 2 expr
))
340 ;; WNA-ERR: Wrong Number of Arguments error
342 ;; If REQUIRED-ARG-COUNT is non-NIL, then we check that EXPR has the
343 ;; correct number of arguments. A informative error message is shown
344 ;; if the number of arguments is not given.
346 ;; Otherwise, EXPR must be a symbol and a generic message is printed.
347 ;; (This is for backward compatibility for existing uses of WNA-ERR.)
348 (defun wna-err (exprs &optional required-arg-count
)
349 (if required-arg-count
350 (let ((op (caar exprs
))
351 (actual-count (length (rest exprs
))))
352 (merror (intl:gettext
"~M: expected exactly ~M arguments but got ~M: ~M")
353 op required-arg-count actual-count
(list* '(mlist) (rest exprs
))))
354 (merror (intl:gettext
"~:@M: wrong number of arguments.")
357 (defun improper-arg-err (exp fn
)
358 (merror (intl:gettext
"~:M: improper argument: ~M") fn exp
))
360 (defun subargcheck (form subsharp argsharp fun
)
361 (if (or (not (= (length (subfunsubs form
)) subsharp
))
362 (not (= (length (subfunargs form
)) argsharp
)))
363 (merror (intl:gettext
"~:@M: wrong number of arguments or subscripts.") fun
)))
365 ;; Constructor and extractor primitives for subscripted functions, e.g.
366 ;; F[1,2](X,Y). SUBL is (1 2) and ARGL is (X Y).
368 ;; These will be flushed when NOPERS is finished. They will be macros in
369 ;; NOPERS instead of functions, so we have to be careful that they aren't
370 ;; mapped or applied anyplace. What we really want is open-codable routines.
372 (defun subfunmakes (fun subl argl
)
373 `((mqapply simp
) ((,fun simp array
) .
,subl
) .
,argl
))
375 (defun subfunmake (fun subl argl
)
376 `((mqapply) ((,fun simp array
) .
,subl
) .
,argl
))
378 (defun subfunname (exp) (caaadr exp
))
380 (defun subfunsubs (exp) (cdadr exp
))
382 (defun subfunargs (exp) (cddr exp
))
384 (defmfun $numfactor
(x)
385 (setq x
(specrepcheck x
))
388 ((not (eq (caar x
) 'mtimes
)) 1)
389 ((mnump (cadr x
)) (cadr x
))
392 (defun scalar-or-constant-p (x flag
)
393 (if flag
(not ($nonscalarp x
)) ($scalarp x
)))
395 (defmfun $constantp
(x)
396 (cond ((atom x
) (or ($numberp x
) (kindp x
'$constant
)))
397 ((member (caar x
) '(rat bigfloat
) :test
#'eq
) t
)
398 ((specrepp x
) ($constantp
(specdisrep x
)))
399 ((or (mopp (caar x
)) (kindp (caar x
) '$constant
))
400 (do ((x (cdr x
) (cdr x
))) ((null x
) t
)
401 (if (not ($constantp
(car x
))) (return nil
))))))
404 (cond ((symbolp x
) (kindp x
'$constant
))
406 (and (kindp (caar x
) '$constant
)
407 (do ((x (cdr x
) (cdr x
))) ((null x
) t
)
408 (if (not ($constantp
(car x
))) (return nil
)))))))
410 (defun maxima-constantp (x)
412 (and (symbolp x
) (kindp x
'$constant
))))
414 (defun consttermp (x) (and ($constantp x
) (not ($nonscalarp x
))))
416 (defmfun $scalarp
(x) (or (consttermp x
) (eq (scalarclass x
) '$scalar
)))
418 (defmfun $nonscalarp
(x) (eq (scalarclass x
) '$nonscalar
))
420 (defun scalarclass (exp) ; Returns $SCALAR, $NONSCALAR, or NIL (unknown).
422 ;; Maxima numbers are scalar.
425 (cond ((or (mget exp
'$nonscalar
)
426 (and (not (mget exp
'$scalar
))
427 ;; Arrays are nonscalar, but not if declared scalar.
429 ($member exp $arrays
))))
431 ((or (mget exp
'$scalar
)
432 ;; Include constant atoms which are not declared nonscalar.
435 ((member 'array
(car exp
))
436 (cond ((mget (caar exp
) '$scalar
) '$scalar
)
437 ((mget (caar exp
) '$nonscalar
) '$nonscalar
)
439 ((specrepp exp
) (scalarclass (specdisrep exp
)))
440 ;; If the function is declared scalar or nonscalar, then return. If it
441 ;; isn't explicitly declared, then try to be intelligent by looking at
442 ;; the arguments to the function.
443 ((scalarclass (caar exp
)))
444 ;; <number> + <scalar> is SCALARP because that seems to be useful.
445 ;; This should probably only be true if <number> is a member of the
446 ;; field of scalars. <number> * <scalar> is SCALARP since
447 ;; <scalar> + <scalar> is SCALARP. Also, this has to be done to make
448 ;; <scalar> - <scalar> SCALARP.
449 ((member (caar exp
) '(mplus mtimes
) :test
#'eq
)
450 (do ((l (cdr exp
) (cdr l
))) ((null l
) '$scalar
)
451 (if (not (consttermp (car l
)))
452 (return (scalarclass-list l
)))))
453 ((and (eq (caar exp
) 'mqapply
) (scalarclass (cadr exp
))))
454 ((mxorlistp exp
) '$nonscalar
)
455 ;; If we can't find out anything about the operator, then look at the
456 ;; arguments to the operator. I think NIL should be returned at this
459 (do ((exp (cdr exp
) (cdr exp
)) (l '(1)))
460 ((null exp
) (scalarclass-list l
))
461 (if (not (consttermp (car exp
)))
462 (setq l
(cons (car exp
) l
)))))))
464 ;; Could also do <scalar> +|-|*|/ |^ <declared constant>, but this is not
465 ;; always correct and could screw somebody.
467 ;; SCALARCLASS-LIST takes a list of expressions as its argument. If their
468 ;; scalarclasses all agree, then that scalarclass is returned.
470 (defun scalarclass-list (llist)
471 (cond ((null llist
) nil
)
472 ((null (cdr llist
)) (scalarclass (car llist
)))
473 (t (let ((sc-car (scalarclass (car llist
)))
474 (sc-cdr (scalarclass-list (cdr llist
))))
475 (cond ((or (eq sc-car
'$nonscalar
)
476 (eq sc-cdr
'$nonscalar
))
478 ((and (eq sc-car
'$scalar
) (eq sc-cdr
'$scalar
))
483 (member (caar x
) '(mequal mlist $matrix
) :test
#'eq
)))
485 (defun mequalp (x) (and (not (atom x
)) (eq (caar x
) 'mequal
)))
489 (member (caar x
) '(mlist $matrix
) :test
#'eq
)))
491 (defun mxorlistp1 (x)
493 (or (eq (caar x
) '$matrix
)
494 (and (eq (caar x
) 'mlist
) $listarith
))))
496 (defun constfun (ign)
497 (declare (ignore ign
)) ; Arg ignored. Function used for mapping down lists.
500 (defun constmx (*const
* x
)
501 (simplifya (fmapl1 'constfun x
) t
))
503 ;;; ISINOP returns the complete subexpression with the operator OP, when the
504 ;;; operator OP is found in EXPR.
506 (defun isinop (expr op
) ; OP is assumed to be an atom
507 (cond ((atom expr
) nil
)
508 ((and (eq (caar expr
) op
)
509 (not (member 'array
(cdar expr
) :test
#'eq
)))
512 (do ((expr (cdr expr
) (cdr expr
))
515 (when (setq res
(isinop (car expr
) op
))
518 (defun free (exp var
)
519 (cond ((alike1 exp var
) nil
)
522 (and (listp (car exp
))
523 (free (caar exp
) var
)
524 (freel (cdr exp
) var
)))))
527 (do ((l l
(cdr l
))) ((null l
) t
)
529 ((atom l
) (return (free l var
))) ;; second element of a pair
530 ((not (free (car l
) var
)) (return nil
)))))
533 (defun freeargs (exp var
)
534 (cond ((alike1 exp var
) nil
)
536 (t (do ((l (margs exp
) (cdr l
))) ((null l
) t
)
537 (cond ((not (freeargs (car l
) var
)) (return nil
)))))))
539 (defun simplifya (x y
)
540 (cond ((not $simp
) x
)
542 (cond ((and $%enumer $numer
(eq x
'$%e
))
543 ;; Replace $%e with its numerical value,
544 ;; when %enumer and $numer TRUE
548 (cond ((and (cdr x
) (atom (cdr x
)))
549 (merror (intl:gettext
"simplifya: malformed expression (atomic cdr).")))
550 ((get (car x
) 'lisp-no-simp
)
551 ;; this feature is to be used with care. it is meant to be
552 ;; used to implement data objects with minimum of consing.
553 ;; forms must not bash the DISPLA package. Only new forms
554 ;; with carefully chosen names should use this feature.
557 (mapcar #'(lambda (x) (simplifya x y
)) (cdr x
))))))
558 ((eq (caar x
) 'rat
) (*red1 x
))
559 ;; Enforced resimplification: Reset dosimp and strip 'simp tags from x.
560 (dosimp (let ((dosimp nil
)) (simplifya (unsimplify x
) y
)))
561 ((member 'simp
(cdar x
) :test
#'eq
) x
)
562 ((eq (caar x
) 'mrat
) x
)
563 ((not (atom (caar x
)))
564 (cond ((or (eq (caaar x
) 'lambda
)
565 (and (not (atom (caaar x
))) (eq (caaaar x
) 'lambda
)))
566 (mapply1 (caar x
) (cdr x
) (caar x
) x
))
567 (t (merror (intl:gettext
"simplifya: operator is neither an atom nor a lambda expression: ~S") x
))))
568 ((and $distribute_over
569 (get (caar x
) 'distribute_over
)
570 ;; A function with the property 'distribute_over.
571 ;; Look, if we have a bag as argument to the function.
572 (distribute-over x
)))
573 ((get (caar x
) 'opers
)
574 (let ((opers-list *opers-list
)) (oper-apply x y
)))
575 ((and (eq (caar x
) 'mqapply
)
577 (and (eq substp
'mqapply
)
578 (or (eq (car (cadr x
)) 'lambda
)
579 (eq (caar (cadr x
)) 'lambda
)))))
580 (cond ((or (symbolp (cadr x
)) (not (atom (cadr x
))))
581 (simplifya (cons (cons (cadr x
) (cdar x
)) (cddr x
)) y
))
582 ((or (not (member 'array
(cdar x
) :test
#'eq
)) (not $subnumsimp
))
583 (merror (intl:gettext
"simplifya: I don't know how to simplify this operator: ~M") x
))
585 (t (let ((w (get (caar x
) 'operators
)))
587 (or (not (member 'array
(cdar x
) :test
#'eq
))
590 (t (simpargs x y
)))))))
592 ;; EQTEST returns an expression which is the same as X
593 ;; except that it is marked with SIMP and maybe other flags from CHECK.
595 ;; Following description is inferred from the code. Dunno why the function is named "EQTEST".
597 ;; (1) if X is already marked with SIMP flag or doesn't need it: return X.
598 ;; (2) if X is pretty much the same as CHECK (same operator and same arguments),
599 ;; then return CHECK after marking it with SIMP flag.
600 ;; (3) if operator of X has the MSIMPIND property, replace it
601 ;; with value of MSIMPIND (something like '(MPLUS SIMP)) and return X.
602 ;; (4) if X or CHECK is an array expression, return X after marking it with SIMP and ARRAY flags.
603 ;; (5) otherwise, return X after marking it with SIMP flag.
605 (defun eqtest (x check
)
610 (member 'simp
(cdar x
) :test
#'eq
))
612 ((and (eq (caar x
) (caar check
))
613 (equal (cdr x
) (cdr check
)))
614 (cond ((and (null (cdar check
))
615 (setq y
(get (caar check
) 'msimpind
)))
616 (cons y
(cdr check
)))
617 ((member 'simp
(cdar check
) :test
#'eq
)
620 (cons (cons (caar check
)
622 (cons 'simp
(cdar check
))
625 ((setq y
(get (caar x
) 'msimpind
))
627 ((or (member 'array
(cdar x
) :test
#'eq
)
628 (and (eq (caar x
) (caar check
))
629 (member 'array
(cdar check
) :test
#'eq
)))
630 (rplaca x
(cons (caar x
) '(simp array
))))
632 (rplaca x
(cons (caar x
) '(simp)))))))
634 ;; A function, which distributes of bags like a list, matrix, or equation.
635 ;; Check, if we have to distribute of one of the bags or any other operator.
636 (defun distribute-over (expr)
637 (cond ((= 1 (length (cdr expr
)))
638 ;; Distribute over for a function with one argument.
639 (cond ((and (not (atom (cadr expr
)))
640 (member (caaadr expr
) (get (caar expr
) 'distribute_over
)))
643 (mapcar #'(lambda (u) (simplify (list (car expr
) u
)))
647 ;; A function with more than one argument.
648 (do ((args (cdr expr
) (cdr args
))
651 (when (and (not (atom (car args
)))
652 (member (caar (car args
))
653 (get (caar expr
) 'distribute_over
)))
654 ;; Distribute the function over the arguments and simplify again.
657 (cons (ncons (caar (car args
)))
658 (mapcar #'(lambda (u)
662 (cons (ncons (caar expr
))
663 (reverse first-args
))
666 (cdr (car args
)))))))
667 (setq first-args
(cons (car args
) first-args
))))))
669 (defun rulechk (x) (or (mget x
'oldrules
) (get x
'rules
)))
671 (defun resimplify (x) (let ((dosimp t
)) (simplifya x nil
)))
673 (defun unsimplify (x)
674 (if (or (atom x
) (specrepp x
))
676 (cons (remove 'simp
(car x
) :count
1) (mapcar #'unsimplify
(cdr x
)))))
678 (defun simpargs (x y
)
679 (if (or (eq (get (caar x
) 'dimension
) 'dimension-infix
)
680 (get (caar x
) 'binary
))
682 (if (and (member 'array
(cdar x
) :test
#'eq
) (null (margs x
)))
683 (merror (intl:gettext
"SIMPARGS: subscripted variable found with no subscripts.")))
684 (eqtest (if y x
(let ((flag (member (caar x
) '(mlist mequal
) :test
#'eq
)))
685 (cons (ncons (caar x
))
686 (mapcar #'(lambda (u)
687 (if flag
(simplifya u nil
)
692 ;;;-----------------------------------------------------------------------------
693 ;;; ADDK (X Y) 27.09.2010/DK
695 ;;; Arguments and values:
696 ;;; X - a Maxima number
697 ;;; Y - a Maxima number
698 ;;; result - a simplified Maxima number
701 ;;; ADDK adds two Maxima numbers and returns a simplified Maxima number.
702 ;;; ADDK can be called in Lisp code, whenever the arguments are valid
703 ;;; Maxima numbers, these are integer, float, Maxima rational, or
704 ;;; Maxima bigfloat numbers. The arguments must not be simplified. The
705 ;;; precision of a bigfloat result depends on the setting of the
706 ;;; global variable $FPPREC. If the option variable $FLOAT is T, a
707 ;;; Maxima rational number as a result is converted to a float number.
711 ;;; (addk 2.0 3) -> 5.0
712 ;;; (addk ($bfloat 2) 3)-> ((BIGFLOAT SIMP 56) 45035996273704960 3)
713 ;;; (addk 2 '((rat) 1 2)) -> ((RAT SIMP) 5 2)
714 ;;; (let (($float t)) (addk 2 '((rat) 1 2))) -> 2.5
717 ;;; The option variables $FLOAT and $FPPREC.
720 ;;; TIMESK to multiply and EXPTRL to exponentiate two Maxima numbers.
723 ;;; The routine works for Lisp rational and Lisp complex numbers too.
724 ;;; This feature is not used in Maxima code. If Lisp complex and
725 ;;; rational numbers are mixed with Maxima rational or bigfloat
726 ;;; numbers the result is wrong or a Lisp error is generated.
727 ;;;-----------------------------------------------------------------------------
732 ((and (numberp x
) (numberp y
)) (+ x y
))
733 ((or ($bfloatp x
) ($bfloatp y
)) ($bfloat
(list '(mplus) x y
)))
736 (cond ((floatp x
) (return (+ x
(fpcofrat y
))))
737 (t (setq x
(list '(rat) x
1)))))
739 (cond ((floatp y
) (return (+ y
(fpcofrat x
))))
740 (t (setq y
(list '(rat) y
1))))))
741 (setq g
(gcd (caddr x
) (caddr y
)))
742 (setq a
(truncate (caddr x
) g
)
743 b
(truncate (caddr y
) g
))
744 (return (timeskl (list '(rat) 1 g
)
750 ;;;-----------------------------------------------------------------------------
751 ;;; *RED1 (X) 27.09.2010/DK
754 ;;; Arguments and values:
755 ;;; X - a Maxima rational number (for *RED1)
756 ;;; N - an integer number representing the numerator of a rational
757 ;;; D - an integer number representing the denominator of a rational
758 ;;; result - a simplified Maxima rational number
761 ;;; *RED1 is called from SIMPLIFYA to reduce and simplify a Maxima rational
762 ;;; number. *RED1 checks if the rational number is already simplified. If
763 ;;; the option variable $FLOAT is T, the rational number is converted to a
764 ;;; float number. If the number is not simplified, *RED is called.
766 ;;; *RED reduces the numerator N and the demoniator D and returns a
767 ;;; simplified Maxima rational number. The result is converted to a float
768 ;;; number, if the option variable $FLOAT is T.
771 ;;; The option variable $FLOAT.
772 ;;;-----------------------------------------------------------------------------
775 (cond ((member 'simp
(cdar x
) :test
#'eq
)
776 (if $float
(fpcofrat x
) x
))
777 (t (*red
(cadr x
) (caddr x
)))))
782 (t (let ((u (gcd n d
)))
783 (setq n
(truncate n u
)
785 (if (minusp d
) (setq n
(- n
) d
(- d
)))
786 (cond ((equal d
1) n
)
787 ($float
(fpcofrat1 n d
))
788 (t (list '(rat simp
) n d
)))))))
790 ;;;-----------------------------------------------------------------------------
791 ;;; TIMESK (X Y) 27.09.2010/DK
793 ;;; Arguments and values:
794 ;;; X - a Maxima number
795 ;;; Y - a Maxima number
796 ;;; result - a simplified Maxima number
799 ;;; TIMESK Multiplies two Maxima numbers and returns a simplified Maxima
800 ;;; number. TIMESK can be called in Lisp code, whenever the arguments are
801 ;;; valid Maxima numbers, these are integer, float, Maxima rational, or
802 ;;; Maxima bigfloat numbers. The arguments must not be simplified. The
803 ;;; precision of a bigfloat result depends on the setting of the
804 ;;; global variable $FPPREC. If the option variable $FLOAT is T, a
805 ;;; Maxima rational number as a result is converted to a float number.
807 ;;; TIMESKL is called from TIMESK to multiply two Maxima rational numbers or
808 ;;; a rational number with an integer number.
811 ;;; (timesk 2 3) -> 6
812 ;;; (timesk 2.0 3) -> 6.0
813 ;;; (timesk ($bfloat 2) 3)-> ((BIGFLOAT SIMP 56) 54043195528445952 3)
814 ;;; (timesk 3 '((rat) 1 2)) -> ((RAT SIMP) 3 2)
815 ;;; (let (($float t)) (timesk 3 '((rat) 1 2))) -> 1.5
818 ;;; The option variables $FLOAT and $FPPREC.
821 ;;; ADDK to add and EXPTRL to exponentiate two Maxima numbers.
824 ;;; The routine works for Lisp rational and Lisp complex numbers too.
825 ;;; This feature is not used in Maxima code. If Lisp complex and
826 ;;; rational numbers are mixed with Maxima rational or bigfloat
827 ;;; numbers the result is wrong or a Lisp error is generated.
828 ;;;-----------------------------------------------------------------------------
830 ;; NUM1 and DENOM1 are helper functions for TIMESKL to get the numerator and the
831 ;; denominator of an integer or Maxima rational number. For an integer the
832 ;; denominator is 1. Both functions are used at other places in Maxima code too.
835 (if (numberp a
) a
(cadr a
)))
838 (if (numberp a
) 1 (caddr a
)))
840 (defun timesk (x y
) ; X and Y are assumed to be already reduced
841 (cond ((equal x
1) y
)
843 ((and (numberp x
) (numberp y
)) (* x y
))
844 ((or ($bfloatp x
) ($bfloatp y
)) ($bfloat
(list '(mtimes) x y
)))
845 ((floatp x
) (* x
(fpcofrat y
)))
846 ((floatp y
) (* y
(fpcofrat x
)))
849 ;; TIMESKL takes one or two Maxima rational numbers, one argument can be an
850 ;; integer number. The result is a Maxima rational or an integer number.
851 ;; If the option variable $FLOAT is T, a Maxima rational number in converted
856 (setq u
(*red
(num1 x
) (denom1 y
)))
857 (setq v
(*red
(num1 y
) (denom1 x
)))
858 (setq g
(cond ((or (equal u
0) (equal v
0)) 0)
860 ((and (numberp u
) (numberp v
)) (* u v
))
862 (* (num1 u
) (num1 v
))
863 (* (denom1 u
) (denom1 v
))))))
864 (return (cond ((numberp g
) g
)
865 ((equal (caddr g
) 1) (cadr g
))
866 ($float
(fpcofrat g
))
869 ;;;-----------------------------------------------------------------------------
870 ;;; FPCOFRAT (RATNO) 27.09.2010/DK
873 ;;; Arguments and values:
874 ;;; RATNO - a Maxima rational number (for FPCOFRAT)
875 ;;; NU - an integer number which represents the numerator of a rational
876 ;;; D - an integer number which represents the denominator of a rational
877 ;;; result - floating point approximation of a rational number
880 ;;; Floating Point Conversion OF RATional number routine.
881 ;;; Finds floating point approximation to rational number.
883 ;;; FPCOFRAT1 computes the quotient of NU/D.
885 ;;; Exceptional situations:
886 ;;; A Lisp error is generated, if the rational number does not fit into a
888 ;;;-----------------------------------------------------------------------------
890 ;; This constant is only needed in the file float.lisp.
892 #+gcl
(compile load eval
)
893 #-gcl
(:compile-toplevel
:load-toplevel
:execute
)
894 (defconstant machine-mantissa-precision
(float-digits 1.0)))
896 (defun fpcofrat (ratno)
897 (fpcofrat1 (cadr ratno
) (caddr ratno
)))
899 (defun fpcofrat1 (nu d
)
902 ;;;-----------------------------------------------------------------------------
903 ;;; EXPTA (X Y) 27.09.2010/DK
905 ;;; Arguments and values:
906 ;;; X - a Maxima number
907 ;;; Y - an integer number
908 ;;; result - a simplified Maxima number
911 ;;; Computes X^Y, where X is Maxima number and Y an integer. The result is
912 ;;; a simplified Maxima number. Y can be a rational Maxima number. For this
913 ;;; case the numerator is taken as the power.
916 ;;; The option variables $FLOAT and $FPPREC.
919 ;;; This routine is not used within the simplifier. There is only one
920 ;;; call from the file hayat.lisp. This call can be replaced with a
921 ;;; call of the function power.
922 ;;;-----------------------------------------------------------------------------
930 ($bfloat
(list '(mexpt) x y
)))
932 (*red
(exptb (caddr x
) (- (num1 y
)))
933 (exptb (cadr x
) (- (num1 y
)))))
935 (*red
(exptb (cadr x
) (num1 y
))
936 (exptb (caddr x
) (num1 y
))))))
938 ;;;-----------------------------------------------------------------------------
939 ;;; EXPTB (A B) 27.09.2010/DK
941 ;;; Arguments and values:
942 ;;; A - a float or integer number
943 ;;; B - an integer number
944 ;;; result - a simplified Maxima number
947 ;;; Computes A^B, where A is a float or an integer number and B is an
948 ;;; integer number. The result is an integer, float, or Maxima
953 ;;; (exptb 3.0 2) -> 9.0
954 ;;; (exptb 3 -2) -> ((RAT SiMP) 1 9)
955 ;;; (let (($float t)) (exptb 3 -2)) -> 0.1111111111111111
958 ;;; The option variable $FLOAT.
961 ;;; EXPTB calls the Lisp functions EXP or EXPT to compute the result.
962 ;;;-----------------------------------------------------------------------------
966 (cond ((equal a %e-val
)
967 ;; Make B a float so we'll get double-precision result.
969 ((or (floatp a
) (not (minusp b
)))
972 (setq b
(expt a
(- b
)))
974 (if (float-inf-p result
) ;; needed for gcl - no trap of overflow
975 (signal 'floating-point-overflow
)
979 ;;;-----------------------------------------------------------------------------
980 ;;; SIMPLUS (X W Z) 27.09.2010/DK
982 ;;; Arguments and values:
983 ;;; X - a Maxima expression of the form ((mplus) term1 term2 ...)
984 ;;; W - an arbitrary value, the value is ignored
985 ;;; Z - T or NIL, if T the arguments are assumed to be simplified
986 ;;; result - a simplified mplus-expression or an atom
989 ;;; Implementation of the simplifier for the "+" operator.
990 ;;; A general description of SIMPLUS can be found in the paper:
991 ;;; http://www.cs.berkeley.edu/~fateman/papers/simplifier.txt
994 ;;; The addition of matrices and lists is affected by the following option
996 ;;; $DOALLMXOPS, $DOMXMXOPS, $DOMXPLUS, $DOSCMXOPPS, $DOSCMXPLUS, $LISTARITH
999 ;;; This routine should not be called directely. It is called by SIMPLIFYA.
1000 ;;; A save access is to call the function ADD.
1001 ;;;-----------------------------------------------------------------------------
1003 (defun simplus (x w z
)
1004 (prog (res check eqnflag matrixflag sumflag
)
1005 (if (null (cdr x
)) (return 0))
1009 (if (null x
) (go end
))
1010 (setq w
(if z
(car x
) (simplifya (car x
) nil
)))
1012 (cond ((atom w
) nil
)
1013 ((eq (caar w
) 'mrat
)
1017 (not (member 'trunc
(cdar w
) :test
#'eq
)))
1018 (spsimpcases (cdr x
) w
))
1019 (setq w
(ratdisrep w
))
1023 (ratf (cons '(mplus)
1024 (nconc (mapcar #'simplify
(cons w
(cdr x
)))
1026 ((eq (caar w
) 'mequal
)
1031 (add2 (cadr eqnflag
) (cadr w
))
1032 (add2 (caddr eqnflag
) (caddr w
)))))
1034 ((member (caar w
) '(mlist $matrix
) :test
#'eq
)
1036 (cond ((not matrixflag
) w
)
1037 ((and (or $doallmxops $domxmxops $domxplus
1038 (and (eq (caar w
) 'mlist
)
1039 ($listp matrixflag
)))
1040 (or (not (eq (caar w
) 'mlist
)) $listarith
))
1041 (addmx matrixflag w
))
1042 (t (setq res
(pls w res
)) matrixflag
)))
1044 ((eq (caar w
) '%sum
)
1045 (setq sumflag t res
(sumpls w res
))
1046 (setq w
(car res
) res
(cdr res
))))
1047 (setq res
(pls w res
))
1050 (setq res
(testp res
))
1053 (cond ((and (or ($listp matrixflag
)
1054 $doallmxops $doscmxplus $doscmxops
)
1055 (or (not ($listp matrixflag
)) $listarith
))
1056 (mxplusc res matrixflag
))
1057 (t (testp (pls matrixflag
(pls res nil
)))))))
1058 (setq res
(eqtest res check
))
1061 (add2 (cadr eqnflag
) res
)
1062 (add2 (caddr eqnflag
) res
))
1065 ;;;-----------------------------------------------------------------------------
1066 ;;; PLS (X OUT) 27.09.2010/DK
1068 ;;; Arguments and values:
1069 ;;; X - a Maxima expression or an atom
1070 ;;; OUT - a form ((mplus) <number> term1 term2 ...) or NIL
1071 ;;; result - a form ((mplus) <number> term1 ...), where x is added in.
1074 ;;; Adds the argument X into the form OUT. If OUT is NIL a form
1075 ;;; ((mplus) 0 X) is initialized, if X is an expression or a symbol,
1076 ;;; or ((mplus) X), if X is a number. Numbers are added to the first
1077 ;;; term <number> of the form. Any other symbol or expression is added
1078 ;;; into the canonical ordered list of arguments. The result is in a
1079 ;;; canonical order, but it is not a valid Maxima expression. To get a
1080 ;;; valid Maxima expression the result has to be checked with the
1081 ;;; function TESTP. This is done by the calling routine SIMPLUS.
1083 ;;; PLS checks the global flag *PLUSFLAG*, which is set in PLUSIN to T,
1084 ;;; if a mplus-expression is part of the result.
1087 ;;; (pls 2 nil) -> ((MPLUS) 2)
1088 ;;; (pls '$A nil) -> ((MPLUS) 0 $A)
1089 ;;; (pls '$B '((mplus) 0 $A)) -> ((MPLUS) 0 $A $B)
1090 ;;; (pls '$A '((mplus) 0 $A)) -> ((MPLUS) 0 ((MTIMES SIMP) 2 $A))
1092 ;;; Examples with the option variables $NUMER and $NEGDISTRIB:
1093 ;;; (let (($numer t)) (pls '$%e nil)) -> ((MPLUS) 2.718281828459045)
1094 ;;; (let (($negdistrib t)) (pls '((mtimes) -1 ((mplus) $A $B)) nil))
1095 ;;; -> ((MPLUS) 0 ((MTIMES SIMP) -1 $A) ((MTIMES SIMP) -1 $B))
1096 ;;; (let (($negdistrib nil)) (pls '((mtimes) -1 ((mplus) $A $B)) nil))
1097 ;;; -> ((MPLUS) 0 ((MTIMES) -1 ((MPLUS) $A $B)))
1100 ;;; The option variables $NUMER and $NEGDISTRIB and the global flag
1101 ;;; *PLUSFLAG*, which is set in the routine PLUSIN.
1104 ;;; PLUSIN and ADDK which are called from PLS and SIMPLUS.
1107 ;;; To add an expression into the list (CDR OUT), the list is passed
1108 ;;; to the routine PLUSIN as an argument. PLUSIN adds the argument to
1109 ;;; the list of terms by modifying the list (CDR OUT) destructively.
1110 ;;; The new value of OUT is returned as a result by PLS.
1111 ;;;-----------------------------------------------------------------------------
1113 ;; Set in PLUSIN to T to indicate a nested mplus expression.
1114 (defvar *plusflag
* nil
)
1116 ;; TESTP checks the result of PLS to get a valid Maxima mplus-expression.
1120 ((null (cddr x
)) (cadr x
))
1122 (cond ((null (cdddr x
)) (caddr x
)) (t (rplacd x
(cddr x
)))))
1126 (prog (fm *plusflag
*)
1127 (if (mtimesp x
) (setq x
(testtneg x
)))
1128 (when (and $numer
(atom x
) (eq x
'$%e
))
1129 ;; Replace $%e with its numerical value, when $numer ist TRUE
1132 ;; Initialize a form like ((mplus) <number> expr)
1135 (cond ((mnump x
) (ncons x
))
1137 (list 0 (cond ((atom x
) x
) (t (copy-list x
)))))
1138 ((mnump (cadr x
)) (copy-list (cdr x
) ))
1139 (t (cons 0 (copy-list (cdr x
) )))))))
1141 ;; Add a number into the first term of the list out.
1142 (return (cons '(mplus)
1143 (if (mnump (cadr out
))
1144 (cons (addk (cadr out
) x
) (cddr out
))
1145 (cons x
(cdr out
))))))
1146 ((not (mplusp x
)) (plusin x
(cdr out
)) (go end
)))
1147 ;; At this point we have a mplus expression as argument x. The following
1148 ;; code assumes that the argument x is already simplified and the terms
1149 ;; are in a canonical order.
1150 ;; First we add the number to the first term of the list out.
1152 (addk (if (mnump (cadr out
)) (cadr out
) 0)
1153 (cond ((mnump (cadr x
)) (setq x
(cdr x
)) (car x
)) (t 0))))
1154 ;; Initialize fm with the list of terms and start the loop to add the
1155 ;; terms of an mplus expression into the list out.
1158 (if (null (setq x
(cdr x
))) (go end
))
1159 ;; The return value of PLUSIN is a list, where the first element is the
1160 ;; added argument and the rest are the terms which follow the added
1162 (setq fm
(plusin (car x
) fm
))
1165 (if (not *plusflag
*) (return out
))
1166 (setq *plusflag
* nil
) ; *PLUSFLAG* T handles e.g. a+b+3*(a+b)-2*(a+b)
1168 ;; *PLUSFLAG* is set by PLUSIN to indicate that a mplus expression is
1169 ;; part of the result. For this case go again through the terms of the
1170 ;; result and add any term of the mplus expression into the list out.
1173 (when (mplusp (cadr fm
))
1175 (rplacd fm
(cddr fm
))
1179 (if (null (cdr fm
)) (return out
))
1182 ;;;-----------------------------------------------------------------------------
1183 ;;; PLUSIN (X FM) 27.09.2010/DK
1185 ;;; Arguments and values:
1186 ;;; X - a Maxima expression or atom
1187 ;;; FM - a list with the terms of an addition
1188 ;;; result - part of the list fm, which starts at the inserted expression
1191 ;;; Adds X into running list of additive terms FM. The routine modifies
1192 ;;; the argument FM destructively, but does not return the modified list as
1193 ;;; a result. The return value is a part of the list FM, which starts at the
1194 ;;; inserted term. PLUSIN can not handle Maxima numbers. PLUSIN is called
1195 ;;; only from the routine PLS.
1199 ;;; (plusin '$a fm) -> ($A)
1201 ;;; (plusin '$b fm) -> ($B)
1203 ;;; (plusin '$a fm) -> (((MTIMES SIMP) 2 $A) $B)
1204 ;;; fm -> (0 ((MTIMES SIMP) 2 $A) $B)
1207 ;;; Modifies destructively the argument FM, which contains the result of the
1208 ;;; addition of the argument X into the list FM.
1211 ;;; The option variables $doallmxops and $listarith.
1214 ;;; The return value is used in PLS to go in parallel through the list of
1215 ;;; terms, when adding a complete mplus-expression into the list of terms.
1216 ;;; This is triggered by the flag *PLUSFLAG*, which is set in PLUSIN, if
1217 ;;; a mplus-expression is added to the result list.
1218 ;;;-----------------------------------------------------------------------------
1220 (defun plusin (x fm
)
1221 (prog (x1 x2 flag check v w xnew a n m c
)
1226 (if (mnump (cadr x
)) (setq w
(cadr x
) x
(cddr x
))
1228 (t (setq x
(ncons x
))))
1229 (setq x1
(if (null (cdr x
)) (car x
) (cons '(mtimes) x
))
1230 xnew
(list* '(mtimes) w x
))
1232 (cond ((null (cdr fm
)))
1233 ((and (alike1 x1
(cadr fm
)) (null (cdr x
)))
1235 ;; Implement the simplification of
1236 ;; v*a^(c+n)+w*a^(c+m) -> (v*a^n+w*a^m)*a^c
1237 ;; where a, v, w, and (n-m) are integers.
1238 ((and (or (and (mexptp (setq x2
(cadr fm
)))
1241 (not (alike1 x1 x2
))
1243 (integerp (setq v
(cadr x2
)))
1244 (mexptp (setq x2
(caddr x2
)))))
1245 (integerp (setq a
(cadr x2
)))
1248 (integerp (sub (caddr x2
) (caddr x1
))))
1249 (setq n
(if (and (mplusp (caddr x2
))
1250 (mnump (cadr (caddr x2
))))
1252 (if (mnump (caddr x2
))
1255 (setq m
(if (and (mplusp (caddr x1
))
1256 (mnump (cadr (caddr x1
))))
1258 (if (mnump (caddr x1
))
1261 (setq c
(sub (caddr x2
) n
))
1264 ;; n and m are integers and the result is (v*a^n+w*a^m)*a^c.
1265 (setq x1
(mul (addk (timesk v
(exptb a n
))
1266 (timesk w
(exptb a m
)))
1270 ;; n and m are rational numbers: The difference n-m is an
1271 ;; integer. The rational numbers might be improper fractions.
1272 ;; The mixed numbers are: n = n1 + d1/r and m = n2 + d2/r,
1273 ;; where r is the common denominator. We have two cases:
1274 ;; I) d1 = d2: e.g. 2^(1/3+c)+2^(4/3+c)
1275 ;; The result is (v*a^n1+w*a^n2)*a^(c+d1/r)
1276 ;; II) d1 # d2: e.g. 2^(1/2+c)+2^(-1/2+c)
1277 ;; In this case one of the exponents d1 or d2 must
1278 ;; be negative. The negative exponent is factored out.
1279 ;; This guarantees that the factor (v*a^n1+w*a^n2)
1280 ;; is an integer. But the positive exponent has to be
1281 ;; adjusted accordingly. E.g. when we factor out
1282 ;; a^(d2/r) because d2 is negative, then we have to
1283 ;; adjust the positive exponent to n1 -> n1+(d1-d2)/r.
1285 ;; Part of the simplification is done in simptimes. E.g.
1286 ;; this algorithm simplifies the sum sqrt(2)+3*sqrt(2)
1287 ;; to 4*sqrt(2). In simptimes this is further simplified
1289 (multiple-value-bind (n1 d1
)
1290 (truncate (num1 n
) (denom1 n
))
1291 (multiple-value-bind (n2 d2
)
1292 (truncate (num1 m
) (denom1 m
))
1293 (cond ((equal d1 d2
)
1294 ;; Case I: -> (v*a^n1+w*a^n2)*a^(c+d1/r)
1296 (mul (addk (timesk v
(exptb a n1
))
1297 (timesk w
(exptb a n2
)))
1300 (div d1
(denom1 n
))))))
1303 ;; Case II:: d2 is negative, adjust n1.
1304 (setq n1
(add n1
(div (sub d1 d2
) (denom1 n
))))
1306 (mul (addk (timesk v
(exptb a n1
))
1307 (timesk w
(exptb a n2
)))
1310 (div d2
(denom1 n
))))))
1313 ;; Case II: d1 is negative, adjust n2.
1314 (setq n2
(add n2
(div (sub d2 d1
) (denom1 n
))))
1316 (mul (addk (timesk v
(exptb a n1
))
1317 (timesk w
(exptb a n2
)))
1320 (div d1
(denom1 n
))))))
1322 ;; This clause should never be reached.
1323 (t (merror "Internal error in simplus."))))))))
1324 ((mtimesp (cadr fm
))
1325 (cond ((alike1 x1
(cadr fm
))
1327 ((and (mnump (cadadr fm
)) (alike x
(cddadr fm
)))
1328 (setq flag t
) ; found common factor
1330 ((great xnew
(cadr fm
)) (go gr
))))
1331 ((great x1
(cadr fm
)) (go gr
)))
1332 (setq xnew
(eqtest (testt xnew
) (or check
'((foo)))))
1333 (return (cdr (rplacd fm
(cons xnew
(cdr fm
)))))
1340 (list* '(mtimes simp
) 0 x
)
1341 ;; Call muln to get a simplified product.
1342 (if (mtimesp (setq x1
(muln (cons (addk 1 w
) x
) t
)))
1346 (cond ((not (mtimesp (cadr fm
)))
1349 ;; Do this simplification for an integer 1, not for 1.0 and 1.0b0
1350 (rplacd (cadr fm
) (cddadr fm
))
1352 ((not (zerop1 (cadadr fm
)))
1354 ;; Handle the multiplication with a zero.
1355 ((and (or (not $listarith
) (not $doallmxops
))
1356 (mxorlistp (caddr (cadr fm
))))
1358 (cons (constmx 0 (caddr (cadr fm
))) (cddr fm
))))))
1359 ;; (cadadr fm) is zero. If the first term of fm is a number,
1360 ;; add it to preserve the type.
1361 (when (mnump (car fm
))
1362 (rplaca fm
(addk (car fm
) (cadadr fm
))))
1363 (return (rplacd fm
(cddr fm
)))
1365 ;; Call muln to get a simplified product.
1366 (setq x1
(muln (cons (addk w
(if flag
(cadadr fm
) 1)) x
) t
))
1367 ;; Make a mplus expression to guarantee that x1 is added again into the sum
1368 (setq x1
(list '(mplus) x1
))
1372 (list* '(mtimes) x1 x
)
1373 (if (mtimesp x1
) (testtneg x1
) x1
)))
1374 (if (not (mtimesp (cadr fm
))) (go check
))
1375 (when (and (onep (cadadr fm
)) flag
(null (cdddr (cadr fm
))))
1376 ;; Do this simplification for an integer 1, not for 1.0 and 1.0b0
1377 (rplaca (cdr fm
) (caddr (cadr fm
))) (go check
))
1380 (if (mplusp (cadr fm
)) (setq *plusflag
* t
)) ; A nested mplus expression
1383 ;;;-----------------------------------------------------------------------------
1385 ;; Routines to add matrices
1387 (defun mxplusc (sc mx
)
1389 (setq sc
(partition-ns (cdr sc
)))
1390 (cond ((null (car sc
)) (cons '(mplus) (cons mx
(cadr sc
))))
1391 ((not (null (cadr sc
)))
1394 (outermap1 'mplus
(cons '(mplus) (car sc
)) mx
))
1396 (t (simplify (outermap1 'mplus
(cons '(mplus) (car sc
)) mx
)))))
1397 ((not (scalar-or-constant-p sc $assumescalar
))
1398 (testp (pls mx
(pls sc nil
))))
1399 (t (simplify (outermap1 'mplus sc mx
)))))
1401 (defun partition-ns (x)
1402 (let (sp nsp
) ; SP = scalar part, NSP = nonscalar part
1403 (mapc #'(lambda (z) (if (scalar-or-constant-p z $assumescalar
)
1404 (setq sp
(cons z sp
))
1405 (setq nsp
(cons z nsp
))))
1407 (list (nreverse sp
) (nreverse nsp
))))
1409 (defun addmx (x1 x2
)
1410 (let (($doscmxops t
) ($domxmxops t
) ($listarith t
))
1411 (simplify (fmapl1 'mplus x1 x2
))))
1413 ;;; ----------------------------------------------------------------------------
1415 ;;; Simplification of the Log function
1417 ;; The log function distributes over lists, matrices, and equations
1418 (defprop %log
(mlist $matrix mequal
) distribute_over
)
1420 (defun simpln (x y z
)
1422 (setq y
(simpcheck (cadr x
) z
))
1423 (cond ((onep1 y
) (addk -
1 y
))
1425 (cond (radcanp (list '(%log simp
) 0))
1427 (merror (intl:gettext
"log: encountered log(0).")))
1428 (t (throw 'errorsw t
))))
1429 ;; Check evaluation in floating point precision.
1430 ((flonum-eval (mop x
) y
))
1431 ;; Check evaluation in bigfloag precision.
1432 ((and (not (member 'simp
(car x
) :test
#'eq
))
1433 (big-float-eval (mop x
) y
)))
1436 (cond ((or (and $logexpand
(eq $domain
'$real
))
1437 (member $logexpand
'($all $super
))
1438 (and (eq ($csign
(cadr y
)) '$pos
)
1439 (not (member ($csign
(caddr y
))
1440 '($complex $imaginary
)))))
1441 ;; Simplify log(x^a) -> a*log(x), where x > 0 and a is real
1442 (mul (caddr y
) (take '(%log
) (cadr y
))))
1443 ((or (and (ratnump (caddr y
))
1444 (or (eql 1 (cadr (caddr y
)))
1445 (eql -
1 (cadr (caddr y
)))))
1446 (maxima-integerp (inv (caddr y
))))
1447 ;; Simplify log(z^(1/n)) -> log(z)/n, where n is an integer
1449 (take '(%log
) (cadr y
))))
1450 ((and (eq (cadr y
) '$%e
)
1451 (or (not (member ($csign
(caddr y
))
1452 '($complex $imaginary
)))
1453 (not (member ($csign
(mul '$%i
(caddr y
)))
1454 '($complex $imaginary
)))))
1455 ;; Simplify log(exp(x)) and log(exp(%i*x)), where x is a real
1457 (t (eqtest (list '(%log
) y
) x
))))
1459 ;; Simplify log(n/d)
1460 (cond ((eql (cadr y
) 1)
1461 (mul -
1 (take '(%log
) (caddr y
))))
1462 ((eq $logexpand
'$super
)
1463 (sub (take '(%log
) (cadr y
)) (take '(%log
) (caddr y
))))
1464 (t (eqtest (list '(%log
) y
) x
))))
1465 ((and (member $logexpand
'($all $super
) :test
#'eq
)
1467 (do ((y (cdr y
) (cdr y
))
1469 ((null y
) (return (addn b t
)))
1470 (setq b
(cons (take '(%log
) (car y
)) b
))))
1471 ((and (member $logexpand
'($all $super
))
1473 (member (caar y
) '(%product $product
)))
1474 (let ((new-op (if (char= (get-first-char (caar y
)) #\%
) '%sum
'$sum
)))
1475 (simplifya `((,new-op
) ((%log
) ,(cadr y
)) ,@(cddr y
)) t
)))
1478 (eq ($sign y
) '$neg
))
1479 (add (mul '$%i
'$%pi
) (take '(%log
) (neg y
))))
1480 ((taylorize (mop x
) (second x
)))
1481 (t (eqtest (list '(%log
) y
) x
))))
1484 (simplifya (list '(mtimes) (caddr w
)
1485 (simplifya (list '(%log
) (cadr w
)) t
)) t
))
1487 ;;; ----------------------------------------------------------------------------
1489 ;;; Implementation of the Square root function
1491 (defprop $sqrt %sqrt verb
)
1492 (defprop $sqrt %sqrt alias
)
1494 (defprop %sqrt $sqrt noun
)
1495 (defprop %sqrt $sqrt reversealias
)
1497 (defprop %sqrt simp-sqrt operators
)
1500 (simplify (list '(%sqrt
) z
)))
1502 (defun simp-sqrt (x ignored z
)
1503 (declare (ignore ignored
))
1505 (simplifya (list '(mexpt) (cadr x
) '((rat simp
) 1 2)) z
))
1507 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1509 ;;; Simplification of the "/" operator.
1511 (defun simpquot (x y z
)
1513 (cond ((and (integerp (cadr x
)) (integerp (caddr x
)) (not (zerop (caddr x
))))
1514 (*red
(cadr x
) (caddr x
)))
1515 ((and (numberp (cadr x
)) (numberp (caddr x
)) (not (zerop (caddr x
))))
1516 (/ (cadr x
) (caddr x
)))
1517 ((and (floatp (cadr x
)) (floatp (caddr x
)) #-ieee-floating-point
(not (zerop (caddr x
))))
1518 (/ (cadr x
) (caddr x
)))
1519 ((and ($bfloatp
(cadr x
)) ($bfloatp
(caddr x
)) (not (equal bigfloatzero
(caddr x
))))
1520 ;; Call BIGFLOATP to ensure that arguments have same precision.
1521 ;; Otherwise FPQUOTIENT could return a spurious value.
1522 (bcons (fpquotient (cdr (bigfloatp (cadr x
))) (cdr (bigfloatp (caddr x
))))))
1523 (t (setq y
(simplifya (cadr x
) z
))
1524 (setq x
(simplifya (list '(mexpt) (caddr x
) -
1) z
))
1525 (if (equal y
1) x
(simplifya (list '(mtimes) y x
) t
)))))
1527 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1529 ;;; Implementation of the abs function.
1531 ;; Put the properties alias, reversealiases, noun and verb on the property list.
1532 (defprop $abs mabs alias
)
1533 (defprop $abs mabs verb
)
1534 (defprop mabs $abs reversealias
)
1535 (defprop mabs $abs noun
)
1537 ;; The abs function distributes over bags.
1538 (defprop mabs
(mlist $matrix mequal
) distribute_over
)
1540 ;; Define a verb function $abs
1542 (simplify (list '(mabs) x
)))
1544 ;; The abs function is a simplifying function.
1545 (defprop mabs simpabs operators
)
1547 (defun simpabs (e y z
)
1548 (declare (ignore y
))
1551 (x (simpcheck (second e
) z
)))
1553 (cond ((complex-number-p x
#'(lambda (s) (or (floatp s
) ($bfloatp s
))))
1554 (maxima::to
(bigfloat::abs
(bigfloat:to x
))))
1556 ((complex-number-p x
#'mnump
)
1559 ;; nounform for arrays...
1560 ((or (arrayp x
) ($member x $arrays
)) `((mabs simp
) ,x
))
1562 ;; taylor polynomials
1563 ((taylorize 'mabs x
))
1565 ;; values for extended real arguments:
1566 ((member x
'($inf $infinity $minf
) :test
#'eq
) '$inf
)
1567 ((member x
'($ind $und
) :test
#'eq
) x
)
1569 ;; abs(abs(expr)) --> abs(expr). Since x is simplified, it's OK to return x.
1570 ((and (consp x
) (consp (car x
)) (eq (caar x
) 'mabs
))
1573 ;; abs(conjugate(expr)) = abs(expr).
1574 ((and (consp x
) (consp (car x
)) (eq (caar x
) '$conjugate
))
1575 (take '(mabs) (cadr x
)))
1578 (setq sgn
($csign x
))
1579 (cond ((member sgn
'($neg $nz
) :test
#'eq
) (mul -
1 x
))
1580 ((eq '$zero sgn
) (mul 0 x
))
1581 ((member sgn
'($pos $pz
) :test
#'eq
) x
)
1583 ;; for complex constant expressions, use $cabs
1584 ((and (eq sgn
'$complex
) ($constantp x
))
1587 ;; abs(pos^complex) --> pos^(realpart(complex)).
1588 ((and (eq sgn
'$complex
) (mexptp x
) (eq '$pos
($csign
(second x
))))
1589 (power (second x
) ($realpart
(third x
))))
1591 ;; for abs(neg^z), use cabs.
1592 ((and (mexptp x
) (eq '$neg
($csign
(second x
))))
1595 ;; When x # 0, we have abs(signum(x)) = 1.
1596 ((and (eq '$pn sgn
) (consp x
) (consp (car x
)) (eq (caar x
) '%signum
)) 1)
1598 ;; multiplicative property: abs(x*y) = abs(x) * abs(y). We would like
1599 ;; assume(a*b > 0), abs(a*b) --> a*b. Thus the multiplicative property
1600 ;; is applied after the sign test.
1602 (muln (mapcar #'(lambda (u) (take '(mabs) u
)) (margs x
)) t
))
1604 ;; abs(x^n) = abs(x)^n for integer n. Is the featurep check worthwhile?
1605 ;; Again the sign check is done first because we'd like abs(x^2) --> x^2.
1606 ((and (mexptp x
) ($featurep
(caddr x
) '$integer
))
1607 (power (take '(mabs) (cadr x
)) (caddr x
)))
1609 ;; Reflection rule: abs(-x) --> abs(x)
1610 ((great (neg x
) x
) (take '(mabs) (neg x
)))
1613 (t (eqtest (list '(mabs) x
) e
)))))))
1615 (defun abs-integral (x)
1616 (mul (div 1 2) x
(take '(mabs) x
)))
1618 (putprop 'mabs
`((x) ,#'abs-integral
) 'integral
)
1620 ;; I (rtoy) think this does some simple optimizations of x * y.
1625 ;; We have something like ((mtimes) foo). This is the same as foo.
1628 ;; We have 1*foo. Which is the same as foo. This should not
1629 ;; be applied to 1.0 or 1b0!
1630 (cond ((null (cdddr x
))
1632 (t (rplacd x
(cddr x
)))))
1636 ;; This basically converts -(a+b) to -a-b.
1638 (cond ((and (equal (cadr x
) -
1)
1642 ;; If x is exactly of the form -1*(sum), and $negdistrib is
1643 ;; true, we distribute the -1 across the sum.
1644 (addn (mapcar #'(lambda (z)
1650 ;; Simplification of the "-" operator
1651 (defun simpmin (x vestigial z
)
1652 (declare (ignore vestigial
))
1653 (cond ((null (cdr x
)) 0)
1655 (mul -
1 (simplifya (cadr x
) z
)))
1657 ;; ((mminus) a b ...) -> ((mplus) a ((mtimes) -1 b) ...)
1658 (sub (simplifya (cadr x
) z
) (addn (cddr x
) z
)))))
1660 (defun simptimes (x w z
) ; W must be 1
1661 (prog (res check eqnflag matrixflag sumflag
)
1662 (if (null (cdr x
)) (return 1))
1668 (cond ((and matrixflag
(mxorlistp1 matrixflag
))
1669 (return (constmx res matrixflag
)))
1670 (eqnflag (return (list '(mequal simp
)
1671 (mul2 res
(cadr eqnflag
))
1672 (mul2 res
(caddr eqnflag
)))))
1675 (cond ((mxorlistp u
)
1676 (return (setq res
(constmx res u
))))
1678 (mxorlistp1 (cadr u
))
1679 ($numberp
(caddr u
)))
1680 (return (setq res
(constmx res
(cadr u
)))))
1684 (list '(mequal simp
)
1686 (mul2 res
(caddr u
))))))))))))
1688 ((null x
) (go end
)))
1689 (setq w
(if z
(car x
) (simplifya (car x
) nil
)))
1691 (cond ((atom w
) nil
)
1692 ((eq (caar w
) 'mrat
)
1693 (cond ((or eqnflag matrixflag
1695 (not (member 'trunc
(cdar w
) :test
#'eq
)))
1696 (spsimpcases (cdr x
) w
))
1697 (setq w
(ratdisrep w
))
1701 (ratf (cons '(mtimes)
1702 (nconc (mapcar #'simplify
(cons w
(cdr x
)))
1704 ((eq (caar w
) 'mequal
)
1709 (mul2 (cadr eqnflag
) (cadr w
))
1710 (mul2 (caddr eqnflag
) (caddr w
)))))
1712 ((member (caar w
) '(mlist $matrix
) :test
#'eq
)
1714 (cond ((not matrixflag
) w
)
1715 ((and (or $doallmxops $domxmxops $domxtimes
)
1716 (or (not (eq (caar w
) 'mlist
)) $listarith
)
1717 (not (eq *inv
* '$detout
)))
1718 (stimex matrixflag w
))
1719 (t (setq res
(tms (copy-tree w
) 1 (copy-tree res
))) matrixflag
)))
1721 ((and (eq (caar w
) '%sum
) $sumexpand
)
1722 (setq sumflag
(sumtimes sumflag w
))
1724 (setq res
(tms (copy-tree w
) 1 (copy-tree res
)))
1727 (cond ((mtimesp res
) (setq res
(testt res
))))
1728 (cond (sumflag (setq res
(cond ((or (null res
) (equal res
1)) sumflag
)
1729 ((not (mtimesp res
))
1730 (list '(mtimes) res sumflag
))
1731 (t (nconc res
(list sumflag
)))))))
1732 (cond ((or (atom res
)
1733 (not (member (caar res
) '(mexpt mtimes
) :test
#'eq
))
1734 (and (zerop $expop
) (zerop $expon
))
1736 ((eq (caar res
) 'mtimes
) (setq res
(expandtimes res
)))
1737 ((and (mplusp (cadr res
))
1738 (fixnump (caddr res
))
1739 (not (or (> (caddr res
) $expop
)
1740 (> (- (caddr res
)) $expon
))))
1741 (setq res
(expandexpt (cadr res
) (caddr res
)))))
1744 (cond ((null res
) matrixflag
)
1745 ((and (or ($listp matrixflag
)
1748 (not (member res
'(-1 -
1.0) :test
#'equal
)))
1749 ;; RES should only be -1 here (not = 1)
1751 (member res
'(-1 -
1.0) :test
#'equal
)))
1752 (or (not ($listp matrixflag
)) $listarith
))
1753 (mxtimesc res matrixflag
))
1754 (t (testt (tms matrixflag
1 (tms res
1 nil
))))))))
1755 (if res
(setq res
(eqtest res check
)))
1756 (return (cond (eqnflag
1757 (if (null res
) (setq res
1))
1759 (mul2 (cadr eqnflag
) res
)
1760 (mul2 (caddr eqnflag
) res
)))
1763 (defun spsimpcases (l e
)
1765 (if (or (mbagp u
) (and (not (atom u
))
1767 (not (member 'trunc
(cdar e
) :test
#'eq
))))
1770 (defun mxtimesc (sc mx
)
1772 (and (mtimesp sc
) (member (cadr sc
) '(-1 -
1.0) :test
#'equal
)
1773 $doscmxops
(not (or $doallmxops $domxmxops $domxtimes
))
1774 (setq sign
(cadr sc
)) (rplaca (cdr sc
) nil
))
1775 (setq out
(let ((scp* (cond ((mtimesp sc
) (partition-ns (cdr sc
)))
1776 ((not (scalar-or-constant-p sc $assumescalar
))
1779 (cond ((null scp
*) (list '(mtimes simp
) sc mx
))
1780 ((and (not (atom scp
*)) (null (car scp
*)))
1781 (append '((mtimes)) (cadr scp
*) (list mx
)))
1782 ((or (atom scp
*) (and (null (cdr scp
*))
1783 (not (null (cdr sc
)))
1784 (setq scp
* (cons '(mtimes) (car scp
*))))
1786 (simplifya (outermap1 'mtimes scp
* mx
) nil
))
1787 (t (append '((mtimes))
1790 (cons '(mtimes) (car scp
*)) mx
)
1793 (cond (sign (if (mtimesp out
)
1794 (rplacd out
(cons sign
(cdr out
)))
1795 (list '(mtimes) sign out
)))
1796 ((mtimesp out
) (testt out
))
1800 (let (($doscmxops t
) ($domxmxops t
) ($listarith t
))
1801 (simplify (fmapl1 'mtimes x y
))))
1803 ;; TMS takes a simplified expression FACTOR and a cumulative
1804 ;; PRODUCT as arguments and modifies the cumulative product so
1805 ;; that the expression is now one of its factors. The
1806 ;; exception to this occurs when a tellsimp rule is triggered.
1807 ;; The second argument is the POWER to which the expression is
1808 ;; to be raised within the product.
1810 (defun tms (factor power product
&aux tem
)
1813 (when (mplusp product
) (setq product
(list '(mtimes simp
) product
)))
1814 (cond ((zerop1 factor
)
1815 (cond ((mnegp power
)
1818 (merror (intl:gettext
"Division by 0"))))
1820 ((and (null product
)
1821 (or (and (mtimesp factor
) (equal power
1))
1822 (and (setq product
(list '(mtimes) 1)) nil
)))
1823 (setq tem
(append '((mtimes)) (if (mnump (cadr factor
)) nil
'(1))
1825 (if (= (length tem
) 1)
1826 (setq tem
(copy-list tem
))
1829 (do ((factor-list (cdr factor
) (cdr factor-list
)))
1830 ((or (null factor-list
) (zerop1 product
)) product
)
1831 (setq z
(timesin (car factor-list
) (cdr product
) power
))
1834 (setq product
(tms-format-product z
)))))
1836 (setq z
(timesin factor
(cdr product
) power
))
1838 (tms-format-product z
)
1841 (defun tms-format-product (x)
1842 (cond ((zerop1 x
) x
)
1843 ((mnump x
) (list '(mtimes) x
))
1844 ((not (mtimesp x
)) (list '(mtimes) 1 x
))
1845 ((not (mnump (cadr x
))) (cons '(mtimes) (cons 1 (cdr x
))))
1849 (cond ($ratsimpexpons
(sratsimp (list '(mplus) x y
)))
1850 ((and (mnump x
) (mnump y
)) (addk x y
))
1854 (if (and (mnump x
) (mnump y
))
1858 (defun simp-limit (x vestigial z
)
1859 (declare (ignore vestigial
))
1860 (let ((l1 (length x
))
1862 (unless (or (= l1
2) (= l1
4) (= l1
5))
1863 (merror (intl:gettext
"limit: wrong number of arguments.")))
1864 (setq y
(simpmap (cdr x
) z
))
1865 (cond ((and (= l1
5) (not (member (cadddr y
) '($plus $minus
) :test
#'eq
)))
1866 (merror (intl:gettext
"limit: direction must be either 'plus' or 'minus': ~M") (cadddr y
)))
1868 (merror (intl:gettext
"limit: variable must not be a number; found: ~M") (cadr y
)))
1872 (eqtest (cons '(%limit
) y
) x
)))))
1874 (defun simpinteg (x vestigial z
)
1875 (declare (ignore vestigial
))
1876 (let ((l1 (length x
))
1878 (unless (or (= l1
3) (= l1
5))
1879 (merror (intl:gettext
"integrate: wrong number of arguments.")))
1880 (setq y
(simpmap (cdr x
) z
))
1881 (cond ((mnump (cadr y
))
1882 (merror (intl:gettext
"integrate: variable must not be a number; found: ~M") (cadr y
)))
1883 ((and (= l1
5) (alike1 (caddr y
) (cadddr y
)))
1886 (free (setq z
(sub (cadddr y
) (caddr y
))) '$%i
)
1887 (eq ($sign z
) '$neg
))
1888 (neg (simplifya (list '(%integrate
) (car y
) (cadr y
) (cadddr y
) (caddr y
)) t
)))
1892 (if (or (among '$inf z
) (among '$minf z
))
1896 (eqtest (cons '(%integrate
) y
) x
)))))
1898 (defun simpbigfloat (x vestigial simp-flag
)
1899 (declare (ignore vestigial simp-flag
))
1902 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1904 ;;; Implementation of the Exp function.
1906 (defprop $exp %exp verb
)
1907 (defprop $exp %exp alias
)
1909 (defprop %exp $exp noun
)
1910 (defprop %exp $exp reversealias
)
1912 (defprop %exp simp-exp operators
)
1915 (simplify (list '(%exp
) z
)))
1917 ;; Support a function for code,
1918 ;; which depends on an unsimplified noun form.
1919 (defmfun $exp-form
(z)
1920 (list '(mexpt) '$%e z
))
1922 (defun simp-exp (x ignored z
)
1923 (declare (ignore ignored
))
1925 (simplifya (list '(mexpt) '$%e
(cadr x
)) z
))
1927 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1929 (defun simplambda (x vestigial simp-flag
)
1930 (declare (ignore vestigial simp-flag
))
1931 ; Check for malformed lambda expressions.
1932 ; We verify that we have a valid list of parameters and a non-empty body.
1933 (let ((params (cadr x
)))
1934 (unless ($listp params
)
1935 (merror (intl:gettext
"lambda: first argument must be a list; found: ~M") params
))
1936 (do ((params (cdr params
) (cdr params
))
1939 (when (mdeflistp params
)
1940 (setq params
(cdar params
)))
1941 (let ((p (car params
)))
1942 (unless (or (mdefparam p
)
1943 (and (op-equalp p
'mquote
)
1944 (mdefparam (cadr p
))))
1945 (merror (intl:gettext
"lambda: parameter must be a symbol and must not be a system constant; found: ~M") p
))
1947 (when (member p seen-params
:test
#'eq
)
1948 (merror (intl:gettext
"lambda: ~M occurs more than once in the parameter list") p
))
1949 (push p seen-params
))))
1950 (when (null (cddr x
))
1951 (merror (intl:gettext
"lambda: no body present")))
1952 (cons '(lambda simp
) (cdr x
)))
1954 (defun simpmdef (x vestigial simp-flag
)
1955 (declare (ignore vestigial simp-flag
))
1957 (cons '(mdefine simp
) (cdr x
)))
1959 (defun simpmap (e z
)
1960 (mapcar #'(lambda (u) (simpcheck u z
)) e
))
1963 (let ((x ($expand e
1 1)))
1964 (cond ((or (not (free x
'$ind
)) (not (free x
'$und
))
1965 (not (free x
'$zeroa
)) (not (free x
'$zerob
))
1966 (not (free x
'$infinity
))
1969 ((and (free x
'$inf
) (free x
'$minf
)) x
)
1970 (t (infsimp1 x e
)))))
1972 (defun infsimp1 (x e
)
1973 (let ((minf-coef (coeff x
'$minf
1))
1974 (inf-coef (coeff x
'$inf
1)))
1975 (cond ((or (and (equal minf-coef
0)
1977 (and (not (free minf-coef
'$inf
))
1978 (not (free inf-coef
'$minf
)))
1979 (let ((new-exp (sub (add2 (mul2 minf-coef
'$minf
)
1980 (mul2 inf-coef
'$inf
))
1982 (and (not (free new-exp
'$inf
))
1983 (not (free new-exp
'$minf
)))))
1985 (t (let ((sign-minf-coef ($asksign minf-coef
))
1986 (sign-inf-coef ($asksign inf-coef
)))
1987 (cond ((or (and (eq sign-inf-coef
'$zero
)
1988 (eq sign-minf-coef
'$neg
))
1989 (and (eq sign-inf-coef
'$pos
)
1990 (eq sign-minf-coef
'$zero
))
1991 (and (eq sign-inf-coef
'$pos
)
1992 (eq sign-minf-coef
'$neg
))) '$inf
)
1993 ((or (and (eq sign-inf-coef
'$zero
)
1994 (eq sign-minf-coef
'$pos
))
1995 (and (eq sign-inf-coef
'$neg
)
1996 (eq sign-minf-coef
'$zero
))
1997 (and (eq sign-inf-coef
'$neg
)
1998 (eq sign-minf-coef
'$pos
))) '$minf
)
1999 ((or (and (eq sign-inf-coef
'$pos
)
2000 (eq sign-minf-coef
'$pos
))
2001 (and (eq sign-inf-coef
'$neg
)
2002 (eq sign-minf-coef
'$neg
))) '$und
)))))))
2004 (defun infsimp2 (x e
)
2006 (if (isinop x
'%limit
) e x
))
2008 (defun simpderiv (x y z
)
2010 (cond ((not (even (length x
)))
2011 (cond ((and (cdr x
) (null (cdddr x
))) (nconc x
'(1)))
2012 (t (wna-err '%derivative
)))))
2013 (setq w
(cons '(%derivative
) (simpmap (cdr x
) z
)))
2015 (do ((u (cddr w
) (cddr u
))) ((null u
))
2016 (cond ((mnump (car u
))
2017 (merror (intl:gettext
"diff: variable must not be a number; found: ~M") (car u
)))))
2018 (cond ((or (zerop1 y
)
2019 (and (or (mnump y
) (and (atom y
) (constant y
)))
2021 (and (not (alike1 y
(caddr w
)))
2022 (do ((u (cddr w
) (cddr u
))) ((null u
))
2023 (cond ((and (numberp (cadr u
))
2024 (not (zerop (cadr u
))))
2027 ((and (not (atom y
)) (eq (caar y
) '%derivative
) derivsimp
)
2028 (rplacd w
(append (cdr y
) (cddr w
)))))
2030 (return (if (null derivflag
) (list '(%del simp
) y
) (deriv (cdr w
)))))
2033 (cond ((null u
) (go next
))
2034 ((zerop1 (caddr u
)) (rplacd u
(cdddr u
)))
2035 (t (setq u
(cddr u
))))
2038 (cond ((null (cddr w
)) (return y
))
2039 ((and (null (cddddr w
))
2041 (alike1 (cadr w
) (caddr w
)))
2046 (cond ((null (cddr z
)) (go loop
))
2047 ((alike1 (car z
) (caddr z
))
2048 (rplaca (cdddr z
) (add2 (cadr z
) (cadddr z
)))
2049 (rplacd z
(cdddr z
)))
2050 ((great (car z
) (caddr z
))
2051 (let ((u1 (car z
)) (u2 (cadr z
)) (v1 (caddr z
)) (v2 (cadddr z
)))
2054 (rplacd z
(cons v2
(cons u1
(cons u2
(cddddr z
))))))))
2055 (cond ((setq z
(cddr z
)) (go sort
)))
2057 (cond ((null flag
) (return (cond ((null derivflag
) (eqtest w x
))
2058 (t (deriv (cdr w
)))))))
2064 (setq x
(num1 x
)) (cond ((plusp x
) 1) ((minusp x
) -
1) (t 0)))
2066 ((mplusp x
) (if expandp
1 (signum1 (car (last x
)))))
2067 ((mtimesp x
) (if (mplusp (cadr x
)) 1 (signum1 (cadr x
))))
2070 (defprop %signum
(mlist $matrix mequal
) distribute_over
)
2072 (defun simpsignum (e y z
)
2073 (declare (ignore y
))
2075 (let ((x (simpcheck (second e
) z
)) (sgn))
2077 (cond ((complex-number-p x
#'mnump
)
2078 (if (complex-number-p x
#'$ratnump
) ;; nonfloat complex
2079 (if (zerop1 x
) 0 ($rectform
(div x
($cabs x
))))
2080 (maxima::to
(bigfloat::signum
(bigfloat::to x
)))))
2082 ;; idempotent: signum(signum(z)) = signum(z).
2083 ((and (consp x
) (consp (car x
)) (eq '%signum
(mop x
))) x
)
2086 (setq sgn
($csign x
))
2087 (cond ((eq sgn
'$neg
) -
1)
2091 ;; multiplicative: signum(ab) = signum(a) * signum(b).
2093 (muln (mapcar #'(lambda (s) (take '(%signum
) s
)) (margs x
)) t
))
2095 ;; Reflection rule: signum(-x) --> -signum(x).
2096 ((great (neg x
) x
) (neg (take '(%signum
) (neg x
))))
2099 (t (eqtest (list '(%signum
) x
) e
)))))))
2101 (defun exptrl (r1 r2
)
2102 (cond ((equal r2
1) r1
)
2104 (cond ((mnump r1
) (addk 0.0 r1
))
2105 ;; Do not simplify the type of the number away.
2106 (t (list '(mexpt simp
) r1
1.0))))
2107 ((equal r2 bigfloatone
)
2108 (cond ((mnump r1
) ($bfloat r1
))
2109 ;; Do not simplify the type of the number away.
2110 (t (list '(mexpt simp
) r1 bigfloatone
))))
2112 (cond ((or (zerop1 r2
) (mnegp r2
))
2114 (merror (intl:gettext
"expt: undefined: ~M") (list '(mexpt) r1 r2
))
2115 (throw 'errorsw t
)))
2116 (t (zerores r1 r2
))))
2117 ((or (zerop1 r2
) (onep1 r1
))
2118 (cond ((or ($bfloatp r1
) ($bfloatp r2
)) bigfloatone
)
2119 ((or (floatp r1
) (floatp r2
)) 1.0)
2121 ((or ($bfloatp r1
) ($bfloatp r2
)) ($bfloat
(list '(mexpt) r1 r2
)))
2122 ((and (numberp r1
) (integerp r2
)) (exptb r1 r2
))
2123 ((and (numberp r1
) (floatp r2
) (equal r2
(float (floor r2
))))
2124 (exptb (float r1
) (floor r2
)))
2125 ((or $numer
(and (floatp r2
) (or (plusp (num1 r1
)) $numer_pbranch
)))
2126 (let (y #+kcl
(r1 r1
) #+kcl
(r2 r2
))
2127 (cond ((minusp (setq r1
(addk 0.0 r1
)))
2128 (cond ((or $numer_pbranch
(eq $domain
'$complex
))
2130 ;; R1^R2 = (-R1)^R2*cos(pi*R2) + i*(-R1)^R2*sin(pi*R2)
2131 (setq r2
(addk 0.0 r2
))
2132 (setq y
(exptrl (- r1
) r2
) r2
(* %pi-val r2
))
2133 (add2 (* y
(cos r2
))
2134 (list '(mtimes simp
) (* y
(sin r2
)) '$%i
)))
2135 (t (setq y
(let ($numer $float $keepfloat $ratprint
)
2137 (mul2 y
(exptrl (- r1
) r2
)))))
2138 ((equal (setq r2
(addk 0.0 r2
)) (float (floor r2
)))
2139 (exptb r1
(floor r2
)))
2140 ((and (equal (setq y
(* 2.0 r2
)) (float (floor y
)))
2141 (not (equal r1 %e-val
)))
2142 (exptb (sqrt r1
) (floor y
)))
2143 (t (exp (* r2
(log r1
)))))))
2144 ((floatp r2
) (list '(mexpt simp
) r1 r2
))
2147 (exptrl (cond ((equal (abs (cadr r1
)) 1)
2148 (* (cadr r1
) (caddr r1
)))
2149 ;; We set the simp flag at this place. This
2150 ;; changes nothing for an exponent r2 # -1.
2151 ;; exptrl is called again and does not look at
2152 ;; the simp flag. For the case r2 = -1 exptrl
2153 ;; is called with an exponent 1. For this case
2154 ;; the base is immediately returned. Now the
2155 ;; base has the correct simp flag. (DK 02/2010)
2157 (list '(rat simp
) (- (caddr r1
)) (- (cadr r1
))))
2158 (t (list '(rat simp
) (caddr r1
) (cadr r1
))))
2160 (t (list '(rat simp
) (exptb (cadr r1
) r2
) (exptb (caddr r1
) r2
)))))
2161 ((and (floatp r1
) (alike1 r2
'((rat) 1 2)))
2163 (list '(mtimes simp
) (sqrt (- r1
)) '$%i
)
2165 ((and (floatp r1
) (alike1 r2
'((rat) -
1 2)))
2167 (list '(mtimes simp
) (/ -
1.0 (sqrt (- r1
))) '$%i
)
2171 (exptrl r1
(fpcofrat r2
))
2172 (mul2 (exptrl -
1 r2
) ;; (-4.5)^(1/4) -> (4.5)^(1/4) * (-1)^(1/4)
2173 (exptrl (- r1
) r2
))))
2174 (exptrlsw (list '(mexpt simp
) r1 r2
))
2177 (simptimes (list '(mtimes)
2178 (exptrl r1
(truncate (cadr r2
) (caddr r2
)))
2179 (let ((y (let ($keepfloat $ratprint
)
2180 (simpnrt r1
(caddr r2
))))
2181 (z (rem (cadr r2
) (caddr r2
))))
2183 (list (car y
) (cadr y
) (mul2 (caddr y
) z
))
2187 (defun simpexpt (x y z
)
2188 (prog (gr pot check res rulesw w mlpgr mlppot
)
2190 (cond (z (setq gr
(cadr x
) pot
(caddr x
)) (go cont
)))
2192 (setq gr
(simplifya (cadr x
) nil
))
2194 (let (($%enumer $numer
))
2195 ;; Switch $%enumer on, when $numer is TRUE to allow
2196 ;; simplification of $%e to its numerical value.
2197 (simplifya (if $ratsimpexpons
($ratsimp
(caddr x
)) (caddr x
))
2201 (setq pot
(ratdisrep pot
))
2204 (cond ((member 'trunc
(car gr
) :test
#'eq
)
2205 (return (srf (list '(mexpt) gr pot
))))
2207 (let ((varlist (caddar gr
)) (genvar (cadddr (car gr
))))
2208 (return (ratrep* (list '(mexpt) gr pot
)))))
2210 (setq gr
(ratdisrep gr
))
2212 ((or (setq mlpgr
(mxorlistp gr
))
2213 (setq mlppot
(mxorlistp pot
)))
2215 ((onep1 pot
) (go atgr
))
2216 ((or (zerop1 pot
) (onep1 gr
)) (go retno
))
2218 ;; This code tries to handle 0^a more complete.
2219 ;; If the sign of realpart(a) is not known return an unsimplified
2220 ;; expression. The handling of the flag *zexptsimp? is not changed.
2221 ;; Reverting the return of an unsimplified 0^a, because timesin
2222 ;; can not handle such expressions. (DK 02/2010)
2224 (cond ((or (member (setq z
($csign pot
)) '($neg $nz
))
2225 (and *zexptsimp?
(eq ($asksign pot
) '$neg
)))
2226 ;; A negative exponent. Maxima error.
2227 (cond ((not errorsw
) (merror (intl:gettext
"expt: undefined: 0 to a negative exponent.")))
2228 (t (throw 'errorsw t
))))
2229 ((and (member z
'($complex $imaginary
))
2230 ;; A complex exponent. Look at the sign of the realpart.
2231 (member (setq z
($sign
($realpart pot
)))
2233 (cond ((not errorsw
)
2234 (merror (intl:gettext
"expt: undefined: 0 to a complex exponent.")))
2235 (t (throw 'errorsw t
))))
2236 ((and *zexptsimp?
(eq ($asksign pot
) '$zero
))
2237 (cond ((not errorsw
)
2238 (merror (intl:gettext
"expt: undefined: 0^0")))
2239 (t (throw 'errorsw t
))))
2240 ((not (member z
'($pos $pz
)))
2241 ;; The sign of realpart(pot) is not known. We can not return
2242 ;; an unsimplified 0^a expression, because timesin can not
2243 ;; handle it. We return ZERO. That is the old behavior.
2244 ;; Look for the imaginary symbol to be consistent with
2246 (cond ((not (free pot
'$%i
))
2247 (cond ((not errorsw
)
2248 (merror (intl:gettext
"expt: undefined: 0 to a complex exponent.")))
2249 (t (throw 'errorsw t
))))
2251 ;; Return ZERO and not an unsimplified expression.
2252 (return (zerores gr pot
)))))
2253 (t (return (zerores gr pot
)))))
2257 (or (not (ratnump gr
)) (not (ratnump pot
))))
2258 (return (eqtest (exptrl gr pot
) check
)))
2259 ;; Check for numerical evaluation of the sqrt.
2260 ((and (alike1 pot
'((rat) 1 2))
2261 (or (setq res
(flonum-eval '%sqrt gr
))
2262 (and (not (member 'simp
(car x
) :test
#'eq
))
2263 (setq res
(big-float-eval '%sqrt gr
)))))
2266 (return (%itopot pot
)))
2267 ((and (realp gr
) (minusp gr
) (mevenp pot
))
2270 ((and (realp gr
) (minusp gr
) (moddp pot
))
2271 (return (mul2 -
1 (power (- gr
) pot
))))
2272 ((and (equal gr -
1) (maxima-integerp pot
) (mminusp pot
))
2273 (setq pot
(neg pot
))
2276 (maxima-integerp pot
)
2279 (fixnump (cadr pot
))
2281 (maxima-integerp (caddr pot
)))
2282 (setq pot
(caddr pot
))
2284 ((atom gr
) (go atgr
))
2285 ((and (eq (caar gr
) 'mabs
)
2288 (or (and (eq $domain
'$real
) (not (apparently-complex-to-judge-by-$csign-p
(cadr gr
))))
2289 (and (eq $domain
'$complex
) (apparently-real-to-judge-by-$csign-p
(cadr gr
)))))
2290 (return (power (cadr gr
) pot
)))
2291 ((and (eq (caar gr
) 'mabs
)
2294 (not (equal pot -
1))
2295 (or (and (eq $domain
'$real
) (not (apparently-complex-to-judge-by-$csign-p
(cadr gr
))))
2296 (and (eq $domain
'$complex
) (apparently-real-to-judge-by-$csign-p
(cadr gr
)))))
2297 ;; abs(x)^(2*n+1) -> abs(x)*x^(2*n), n an integer number
2299 (return (mul (power (cadr gr
) (add pot -
1))
2301 (return (mul (power (cadr gr
) (add pot
1))
2303 ((eq (caar gr
) 'mequal
)
2304 (return (eqtest (list (ncons (caar gr
))
2305 (power (cadr gr
) pot
)
2306 (power (caddr gr
) pot
))
2308 ((symbolp pot
) (go opp
))
2309 ((eq (caar gr
) 'mexpt
) (go e1
))
2310 ((and (eq (caar gr
) '%sum
)
2315 (return (do ((i (1- pot
) (1- i
))
2316 (an gr
(simptimes (list '(mtimes) an gr
) 1 t
)))
2319 (return (eqtest (testt (tms gr pot nil
)) check
)))
2321 (return (eqtest (cond ((and (mplusp gr
)
2322 (not (or (> pot $expop
)
2323 (> (- pot
) $expon
))))
2324 (expandexpt gr pot
))
2325 (t (simplifya (tms gr pot nil
) t
)))
2329 (cond ((eq (caar gr
) 'mexpt
) (go e1
))
2330 ((eq (caar gr
) 'rat
)
2331 (return (mul2 (power (cadr gr
) pot
)
2332 (power (caddr gr
) (mul2 -
1 pot
)))))
2333 ((not (eq (caar gr
) 'mtimes
)) (go up
))
2334 ((or (eq $radexpand
'$all
) (and $radexpand
(simplexpon pot
)))
2337 ((and (or (not (numberp (cadr gr
)))
2338 (equal (cadr gr
) -
1))
2339 (equal -
1 ($num gr
)) ; only for -1
2340 ;; Do not simplify for a complex base.
2341 (not (member ($csign gr
) '($complex $imaginary
)))
2342 (and (eq $domain
'$real
) $radexpand
))
2343 ;; (-1/x)^a -> 1/(-x)^a for x negative
2344 ;; For all other cases (-1)^a/x^a
2345 (if (eq ($csign
(setq w
($denom gr
))) '$neg
)
2346 (return (inv (power (neg w
) pot
)))
2347 (return (div (power -
1 pot
)
2349 ((or (eq $domain
'$complex
) (not $radexpand
)) (go up
)))
2350 (return (do ((l (cdr gr
) (cdr l
)) (res (ncons 1)) (rad))
2352 (cond ((equal res
'(1))
2353 (eqtest (list '(mexpt) gr pot
) check
))
2355 (testt (cons '(mtimes simp
) res
)))
2357 (setq rad
(power* ; RADEXPAND=()?
2358 (cons '(mtimes) (nreverse rad
)) pot
))
2359 (cond ((not (onep1 rad
))
2361 (testt (tms rad
1 (cons '(mtimes) res
))))
2363 (setq rulesw nil res
(cdr rad
))))))
2364 (eqtest (testt (cons '(mtimes) res
)) check
))))
2365 ;; Check with $csign to be more complete. This prevents wrong
2366 ;; simplifications like sqrt(-z^2)->%i*sqrt(z^2) for z complex.
2367 (setq z
($csign
(car l
)))
2368 (if (member z
'($complex $imaginary
))
2369 (setq z
'$pnz
)) ; if appears complex, unknown sign
2370 (setq w
(cond ((member z
'($neg $nz
) :test
#'eq
)
2371 (setq rad
(cons -
1 rad
))
2375 ((alike1 w gr
) (return (list '(mexpt simp
) gr pot
)))
2376 ((member z
'($pn $pnz
) :test
#'eq
)
2377 (setq rad
(cons w rad
)))
2379 (setq w
(testt (tms (simplifya (list '(mexpt) w pot
) t
)
2380 1 (cons '(mtimes) res
))))))
2381 (cond (rulesw (setq rulesw nil res
(cdr w
))))))
2384 (cond ((and (cdr res
) (onep1 (car res
)) (ratnump (cadr res
)))
2385 (setq res
(cdr res
))))
2386 (cond ((null (setq gr
(cdr gr
)))
2387 (return (eqtest (testt (cons '(mtimes) res
)) check
)))
2389 (setq y
(power (cadar gr
) (mult (caddar gr
) pot
))))
2391 (setq y
(%itopot pot
)))
2393 (setq y
(list '(mexpt) (car gr
) pot
)))
2394 (t (setq y
(list '(mexpt simp
) (car gr
) pot
))))
2395 (setq w
(testt (tms (simplifya y t
) 1 (cons '(mtimes) res
))))
2396 (cond (rulesw (setq rulesw nil res
(cdr w
))))
2400 (return (exptrl gr pot
))
2403 (cond ((zerop1 pot
) (go retno
))
2405 (let ((y (mget gr
'$numer
)))
2406 (if (and y
(floatp y
) (or $numer
(not (equal pot
1))))
2407 ;; A numeric constant like %e, %pi, ... and
2408 ;; exponent is a float or bigfloat value.
2409 (return (if (and (member gr
*builtin-numeric-constants
*)
2410 (equal pot bigfloatone
))
2411 ;; Return a bigfloat value.
2413 ;; Return a float value.
2415 ;; In all other cases exptrl simplifies accordingly.
2416 (return (exptrl gr pot
)))))
2418 ;; Numerically evaluate if the power is a flonum.
2420 (let ((val (flonum-eval '%exp pot
)))
2421 (if (float-inf-p val
)
2422 ;; needed for gcl - no trap of overflow
2423 (signal 'floating-point-overflow
))
2426 ;; Numerically evaluate if the power is a (complex)
2427 ;; big-float. (This is basically the guts of
2428 ;; big-float-eval, but we can't use big-float-eval.)
2429 (when (and (not (member 'simp
(car x
) :test
#'eq
))
2430 (complex-number-p pot
'bigfloat-or-number-p
))
2431 (let ((x ($realpart pot
))
2432 (y ($imagpart pot
)))
2433 (cond ((and ($bfloatp x
) (like 0 y
))
2434 (return ($bfloat
`((mexpt simp
) $%e
,pot
))))
2435 ((or ($bfloatp x
) ($bfloatp y
))
2436 (let ((z (add ($bfloat x
) (mul '$%i
($bfloat y
)))))
2437 (setq z
($rectform
`((mexpt simp
) $%e
,z
)))
2438 (return ($bfloat z
))))))))
2439 (cond ((and $logsimp
(among '%log pot
)) (return (%etolog pot
)))
2440 ((and $demoivre
(setq z
(demoivre pot
))) (return z
))
2444 ;; Exponent contains %i and %pi and %emode is TRUE:
2445 ;; Check simplification of exp(%i*%pi*p/q*x)
2446 (setq z
(%especial pot
)))
2448 (($taylorp
(third x
))
2449 ;; taylorize %e^taylor(...)
2450 (return ($taylor x
)))))
2452 (let ((y (mget gr
'$numer
)))
2453 ;; Check for a numeric constant.
2457 ;; The exponent is a bigfloat. Convert base to bigfloat.
2459 (member gr
*builtin-numeric-constants
*)
2460 (setq y
($bfloat gr
)))
2461 (and $numer
(integerp pot
)))
2462 (return (exptrl y pot
))))))
2465 (return (eqtest (list '(mexpt) gr pot
) check
))
2469 (cond ((mxorlistp1 gr
) (return (constmx (addk 1 pot
) gr
)))
2471 ((onep1 pot
) (return gr
))
2472 ((or $doallmxops $doscmxops $domxexpt
)
2473 (cond ((or (and mlpgr
2474 (or (not ($listp gr
)) $listarith
)
2475 (scalar-or-constant-p pot $assumescalar
))
2478 (or (not ($listp pot
)) $listarith
)
2479 (scalar-or-constant-p gr $assumescalar
)))
2480 (return (simplifya (outermap1 'mexpt gr pot
) t
)))
2482 ((and $domxmxops
(member pot
'(-1 -
1.0) :test
#'equal
))
2483 (return (simplifya (outermap1 'mexpt gr pot
) t
)))
2486 ;; At this point we have an expression: (z^a)^b with gr = z^a and pot = b
2487 (cond ((or (eq $radexpand
'$all
)
2488 ;; b is an integer or an odd rational
2490 (and (eq $domain
'$complex
)
2491 (not (member ($csign
(caddr gr
)) '($complex $imaginary
)))
2492 ;; z >= 0 and a not a complex
2493 (or (member ($csign
(cadr gr
)) '($pos $pz $zero
))
2495 (and (mnump (caddr gr
))
2496 (eq ($sign
(sub 1 (take '(mabs) (caddr gr
))))
2498 (and (eq $domain
'$real
)
2499 (member ($csign
(cadr gr
)) '($pos $pz $zero
)))
2500 ;; (1/z)^a -> 1/z^a when z a constant complex
2501 (and (eql (caddr gr
) -
1)
2503 (eq $domain
'$real
))
2504 (and (eq ($csign
(cadr gr
)) '$complex
)
2505 ($constantp
(cadr gr
)))))
2506 ;; This does (1/z)^a -> 1/z^a. This is in general wrong.
2507 ;; We switch this type of simplification on, when
2508 ;; $ratsimpexpons is T. E.g. radcan sets this flag to T.
2509 ;; radcan hangs for expressions like sqrt(1/(1+x)) without
2510 ;; this simplification.
2512 (equal (caddr gr
) -
1))
2515 (odnump (caddr gr
))))
2516 ;; Simplify (z^a)^b -> z^(a*b)
2517 (setq pot
(mul pot
(caddr gr
))
2519 ((and (eq $domain
'$real
)
2522 (not (apparently-complex-to-judge-by-$csign-p
(cadr gr
)))
2523 (evnump (caddr gr
)))
2524 ;; Simplify (x^a)^b -> abs(x)^(a*b)
2525 (setq pot
(mul pot
(caddr gr
))
2526 gr
(radmabs (cadr gr
))))
2529 (mminusp (caddr gr
)))
2530 ;; Simplify (1/z^a)^b -> 1/(z^a)^b
2532 gr
(power (cadr gr
) (neg (caddr gr
)))))
2536 (defun apparently-complex-to-judge-by-$csign-p
(e)
2537 (let ((s ($csign e
)))
2538 (member s
'($complex $imaginary
))))
2540 (defun apparently-real-to-judge-by-$csign-p
(e)
2541 (let ((s ($csign e
)))
2542 (member s
'($pos $neg $zero $pn $pnz $pz $nz
))))
2544 ;; Basically computes log of m base b. Except if m is not a power
2545 ;; of b, we return nil. m is a positive integer and base an integer
2546 ;; not equal to +/-1.
2547 (defun exponent-of (m base
)
2548 ;; Just compute base^k until base^k >= m. Then check if they're equal.
2549 ;; If so, we have the exponent. Otherwise, give up.
2552 (multiple-value-bind (q r
)
2558 (if (zerop expo
) nil expo
)))
2560 (defun timesin (x y w
) ; Multiply X^W into Y
2561 (prog (fm temp z check u expo
)
2562 (if (mexptp x
) (setq check x
))
2564 ;; Prepare the factor x^w and initialize the work of timesin
2568 (setq temp
(cons '(mexpt) (if check
2569 (list (cadr x
) (mult (caddr x
) w
))
2571 (if (and (not timesinp
) (not (eq x
'$%i
)))
2573 (setq temp
(simplifya temp t
))))))
2574 (setq x
(if (mexptp temp
)
2580 ;; Go through the list of terms in fm and look what is to do.
2581 (cond ((null (cdr fm
))
2582 ;; The list of terms is empty. The loop is finshed.
2584 ((or (and (mnump temp
)
2585 (not (or (integerp temp
)
2587 (and (integerp temp
)
2589 ;; Stop the loop for a float or bigfloat number, or number -1.
2592 (cond ((alike1 (car x
) (cadadr fm
))
2593 (cond ((zerop1 (setq w
(plsk (caddr (cadr fm
)) w
)))
2598 (rplacd fm
(cddr fm
))
2599 (cond ((mnump (setq x
(if (mnump (car x
))
2601 (power (car x
) w
))))
2602 (return (rplaca y
(timesk (car y
) x
))))
2607 x
(if (mexptp x
) (cdr x
) (list x
1)))
2611 ((maxima-constantp (car x
))
2614 (cond ((mtimesp (car x
))
2615 ;; A base which is a mtimes expression. Remove
2616 ;; the factor from the lists of products.
2617 (rplacd fm
(cddr fm
))
2618 ;; Multiply the factors of the base with
2619 ;; the list of all remaining products.
2621 (return (muln (nconc y
(cdar x
)) t
)))
2622 (t (return (rplaca (cdr fm
) (car x
))))))
2625 ;; At this place we have to add code for a rational number
2626 ;; as a factor to the list of products.
2628 (or (ratnump (car x
))
2629 (and (integerp (car x
))
2630 (not (onep (car x
))))))
2631 ;; Multiplying bas^k * num/den
2632 (let ((num (num1 (car x
)))
2633 (den (denom1 (car x
)))
2634 (bas (second (cadr fm
))))
2635 (cond ((and (integerp bas
)
2636 (not (eql 1 (abs bas
)))
2637 (setq expo
(exponent-of (abs num
) bas
)))
2638 ;; We have bas^m*bas^k = bas^(k+m).
2639 (setq temp
(power bas
2640 (add (third (cadr fm
)) expo
)))
2641 ;; Set fm to have 1/denom term.
2642 (setq x
(mul (car y
)
2646 ((and (integerp bas
)
2647 (not (eql 1 (abs bas
)))
2648 (setq expo
(exponent-of den bas
)))
2649 (setq expo
(- expo
))
2650 ;; We have bas^(-m)*bas^k = bas^(k-m).
2651 (setq temp
(power bas
2652 (add (third (cadr fm
)) expo
)))
2653 ;; Set fm to have the numerator term.
2654 (setq x
(mul (car y
)
2657 (exptrl bas
(- expo
)))))))
2659 ;; Next term in list of products.
2662 ;; Add in the bas^(k+m) term or bas^(k-m)
2663 (setf y
(rplaca y
1))
2664 (rplacd fm
(cddr fm
))
2665 (rplacd fm
(cons temp
(cdr fm
)))
2671 ((and (not (atom (car x
)))
2672 (eq (caar (car x
)) 'mabs
)
2674 (integerp (caddr (cadr fm
)))
2675 (< (caddr (cadr fm
)) -
1)
2676 (alike1 (cadr (car x
)) (cadr (cadr fm
)))
2677 (not (member ($csign
(cadr (car x
)))
2678 '($complex imaginary
))))
2679 ;; 1/x^n*abs(x) -> 1/(x^(n-2)*abs(x)), where n an integer
2680 ;; Replace 1/x^n -> 1/x^(n-2)
2681 (setq temp
(power (cadr (cadr fm
))
2682 (add (caddr (cadr fm
)) 2)))
2683 (rplacd fm
(cddr fm
))
2684 (if (not (equal temp
1))
2685 (rplacd fm
(cons temp
(cdr fm
))))
2686 ;; Multiply factor 1/abs(x) into list of products.
2687 (setq x
(list (car x
) -
1))
2688 (setq temp
(power (car x
) (cadr x
)))
2692 ((and (not (atom (car x
)))
2693 (eq (caar (car x
)) 'mabs
)
2695 (integerp (caddr (cadr fm
)))
2696 (> (caddr (cadr fm
)) 1)
2697 (alike1 (cadr (car x
)) (cadr (cadr fm
)))
2698 (not (member ($csign
(cadr (car x
)))
2699 '($complex imaginary
))))
2700 ;; x^n/abs(x) -> x^(n-2)*abs(x), where n an integer.
2701 ;; Replace x^n -> x^(n-2)
2702 (setq temp
(power (cadr (cadr fm
))
2703 (add (caddr (cadr fm
)) -
2)))
2704 (rplacd fm
(cddr fm
))
2705 (if (not (equal temp
1))
2706 (rplacd fm
(cons temp
(cdr fm
))))
2707 ;; Multiply factor abs(x) into list of products.
2708 (setq x
(list (car x
) 1))
2709 (setq temp
(power (car x
) (cadr x
)))
2713 ((and (not (atom (cadr fm
)))
2714 (not (atom (cadr (cadr fm
))))
2715 (eq (caaadr (cadr fm
)) 'mabs
)
2716 (equal (caddr (cadr fm
)) -
1)
2719 (alike1 (cadadr (cadr fm
)) (car x
))
2720 (not (member ($csign
(cadadr (cadr fm
)))
2721 '($complex imaginary
))))
2722 ;; 1/abs(x)*x^n -> x^(n-2)*abs(x), where n an integer.
2723 ;; Replace 1/abs(x) -> abs(x)
2724 (setq temp
(cadr (cadr fm
)))
2725 (rplacd fm
(cddr fm
))
2726 (rplacd fm
(cons temp
(cdr fm
)))
2727 ;; Multiply factor x^(n-2) into list of products.
2728 (setq x
(list (car x
) (add (cadr x
) -
2)))
2729 (setq temp
(power (car x
) (cadr x
)))
2733 ((or (maxima-constantp (car x
))
2734 (maxima-constantp (cadadr fm
)))
2735 (if (great temp
(cadr fm
))
2737 ((great (car x
) (cadadr fm
))
2740 ((alike1 (car x
) (cadr fm
))
2743 ;; When a number goto start and look in the next term.
2747 ((and (not (atom (cadr fm
)))
2748 (eq (caar (cadr fm
)) 'mabs
)
2751 (alike1 (cadr (cadr fm
)) (car x
))
2752 (not (member ($csign
(cadr (cadr fm
)))
2753 '($complex imaginary
))))
2754 ;; abs(x)/x^n -> 1/(x^(n-2)*abs(x)), where n an integer.
2755 ;; Replace abs(x) -> 1/abs(x).
2756 (setq temp
(power (cadr fm
) -
1))
2757 (rplacd fm
(cddr fm
))
2758 (rplacd fm
(cons temp
(cdr fm
)))
2759 ;; Multiply factor x^(-n+2) into list of products.
2760 (setq x
(list (car x
) (add (cadr x
) 2)))
2761 (setq temp
(power (car x
) (cadr x
)))
2765 ((maxima-constantp (car x
))
2766 (when (great temp
(cadr fm
))
2768 ((great (car x
) (cadr fm
))
2772 ;; Multiply a number into the list of products.
2773 (return (rplaca y
(timesk (car y
) temp
))))
2774 ((and (eq (car x
) '$%i
)
2777 ((and (eq (car x
) '$%e
)
2780 (return (rplaca y
(timesk (car y
) (exp (float w
))))))
2782 (not (constant (car x
))))
2784 ;; At this point we will insert a mexpt expression,
2785 ;; but first we look at the car of the list of products and
2786 ;; modify the expression if we found a rational number.
2788 (not (onep1 (car y
)))
2789 (or (integerp (car y
))
2791 ;; Multiplying bas^k * num/den.
2792 (let ((num (num1 (car y
)))
2793 (den (denom1 (car y
)))
2795 (cond ((and (integerp bas
)
2796 (not (eql 1 (abs bas
)))
2797 (setq expo
(exponent-of (abs num
) bas
)))
2798 ;; We have bas^m*bas^k.
2799 (setq temp
(power bas
(add (cadr x
) expo
)))
2800 ;; Set fm to have 1/denom term.
2801 (setq x
(div (div num
(exptrl bas expo
)) den
)))
2802 ((and (integerp bas
)
2803 (not (eql 1 (abs bas
)))
2804 (setq expo
(exponent-of den bas
)))
2805 (setq expo
(- expo
))
2806 ;; We have bas^(-m)*bas^k.
2807 (setq temp
(power bas
(add (cadr x
) expo
)))
2808 ;; Set fm to have the numerator term.
2809 (setq x
(div num
(div den
(exptrl bas
(- expo
))))))
2811 ;; The rational doesn't contain any (simple) powers of
2812 ;; the exponential term. We're done.
2813 (return (cdr (rplacd fm
(cons temp
(cdr fm
)))))))
2814 ;; Add in the a^(m+k) or a^(k-m) term.
2815 (setf y
(rplaca y
1))
2816 (rplacd fm
(cons temp
(cdr fm
)))
2822 ((and (maxima-constantp (car x
))
2823 (do ((l (cdr fm
) (cdr l
)))
2825 (when (and (mexptp (cadr l
))
2826 (alike1 (car x
) (cadadr l
)))
2830 ((or (and (mnump (car x
))
2832 (and (eq (car x
) '$%e
)
2836 (setq u
(%especial w
))))
2838 ((alike (cdr check
) x
)
2841 (exptrl (car x
) w
))))
2843 (return (rplaca y
(timesk (car y
) x
))))
2847 (return (cdr (rplacd fm
(cons x
(cdr fm
))))))
2857 (setq temp
(list '(mexpt) (car x
) w
))
2858 (setq temp
(eqtest temp
(or check
'((foo)))))
2859 (return (cdr (rplacd fm
(cons temp
(cdr fm
)))))))
2861 (return (cdr (rplacd fm
(cons (car x
) (cdr fm
)))))
2866 (cond ((and (eq (car x
) '$%i
) (equal w
1))
2867 (rplacd fm
(cddr fm
))
2868 (return (rplaca y
(timesk -
1 (car y
)))))
2869 ((zerop1 (setq w
(plsk 1 w
)))
2871 ((and (mnump (car x
)) (mnump w
))
2872 (return (rplaca (cdr fm
) (exptrl (car x
) w
))))
2873 ((maxima-constantp (car x
))
2876 (setq z
(list '(mexpt) (car x
) w
))
2877 (cond ((alike1 (setq x
(simplifya z t
)) z
)
2878 (return (rplaca (cdr fm
) x
)))
2880 (rplacd fm
(cddr fm
))
2882 (return (muln (cons x y
) t
))))
2884 (rplacd fm
(cddr fm
))
2885 (setq x
(car x
) check nil
)
2888 (setq z
(tms x
1 (setq temp
(cons '(mtimes) y
))))
2889 (return (cond ((eq z temp
)
2892 (setq rulesw t
) z
)))
2894 (return (rplacd fm
(cddr fm
)))
2896 (if (minusp (setq w
(rem w
4)))
2898 (return (cond ((zerop w
)
2901 (rplaca y
(timesk -
1 (car y
))))
2903 (rplaca y
(timesk -
1 (car y
)))
2904 (rplacd fm
(cons '$%i
(cdr fm
))))
2906 (rplacd fm
(cons '$%i
(cdr fm
))))))))
2908 (defun simpmatrix (x vestigial z
)
2909 (declare (ignore vestigial
))
2910 (if (and (null (cddr x
))
2912 (or (eq $scalarmatrixp
'$all
) (member 'mult
(cdar x
) :test
#'eq
))
2913 ($listp
(cadr x
)) (cdadr x
) (null (cddadr x
)))
2914 (simplifya (cadadr x
) z
)
2915 (let ((badp (dolist (row (cdr x
)) (if (not ($listp row
)) (return t
))))
2916 (args (simpmap (cdr x
) z
)))
2917 (if (and args
(not badp
)) (matcheck args
))
2918 (cons (if badp
'(%matrix simp
) '($matrix simp
)) args
))))
2920 (defun %itopot
(pot)
2922 (let ((i (boole boole-and pot
3)))
2926 (t (list '(mtimes simp
) -
1 '$%i
))))
2927 (power -
1 (mul2 pot
'((rat simp
) 1 2)))))
2930 (cond ((eq (caar pot
) '%log
) (simplifya (cadr pot
) nil
))
2931 ((and (eq (caar pot
) 'mtimes
)
2932 (or (maxima-integerp (cadr pot
))
2933 (and $%e_to_numlog
($numberp
(cadr pot
))))
2934 (not (atom (caddr pot
))) (eq (caar (caddr pot
)) '%log
)
2936 (power (cadr (caddr pot
)) (cadr pot
)))))
2940 loop
(cond ((null pot
)
2941 (cond (a (setq a
(cons '(mtimes) a
))))
2942 (cond (c (setq c
(list '(mexpt simp
) '$%e
(addn c nil
)))))
2943 (return (cond ((null c
) (simptimes a
1 nil
))
2945 (t (simptimes (append a
(list c
)) 1 nil
)))))
2946 ((and (among '%log
(car pot
)) (setq b
(mnlogp (car pot
))))
2947 (setq a
(cons b a
)))
2948 (t (setq c
(cons (car pot
) c
))))
2949 (setq pot
(cdr pot
))
2952 (defun %etolog
(pot) (cond ((mnlogp pot
))
2953 ((eq (caar pot
) 'mplus
) (mnlog (cdr pot
)))
2954 (t (list '(mexpt simp
) '$%e pot
))))
2956 (defun zerores (r1 r2
)
2957 (cond ((or ($bfloatp r1
) ($bfloatp r2
)) bigfloatzero
)
2958 ((or (floatp r1
) (floatp r2
)) 0.0)
2961 (defmfun $orderlessp
(a b
)
2962 (setq a
($totaldisrep
(specrepcheck a
))
2963 b
($totaldisrep
(specrepcheck b
)))
2964 (and (not (alike1 a b
)) (great b a
) t
))
2966 (defmfun $ordergreatp
(a b
)
2967 (setq a
($totaldisrep
(specrepcheck a
))
2968 b
($totaldisrep
(specrepcheck b
)))
2969 (and (not (alike1 a b
)) (great a b
) t
))
2971 ;; Test function to order a and b by magnitude. If it is not possible to
2972 ;; order a and b by magnitude they are ordered by great. This function
2973 ;; can be used by sort, e.g. sort([3,1,7,x,sin(1),minf],ordermagnitudep)
2974 (defmfun $ordermagnitudep
(a b
)
2976 (setq a
($totaldisrep
(specrepcheck a
))
2977 b
($totaldisrep
(specrepcheck b
)))
2978 (cond ((and (or (constp a
) (member a
'($inf $minf
)))
2979 (or (constp b
) (member b
'($inf $minf
)))
2980 (member (setq sgn
($csign
(sub b a
))) '($pos $neg $zero
)))
2981 (cond ((eq sgn
'$pos
) t
)
2982 ((eq sgn
'$zero
) (and (not (alike1 a b
)) (great b a
)))
2984 ((or (constp a
) (member a
'($inf $minf
))) t
)
2985 ((or (constp b
) (member b
'($inf $minf
))) nil
)
2986 (t (and (not (alike1 a b
)) (great b a
))))))
2988 (defun evnump (n) (or (even n
) (and (ratnump n
) (even (cadr n
)))))
2989 (defun odnump (n) (or (and (integerp n
) (oddp n
))
2990 (and (ratnump n
) (oddp (cadr n
)))))
2992 (defun simplexpon (e)
2993 (or (maxima-integerp e
)
2994 (and (eq $domain
'$real
) (ratnump e
) (oddp (caddr e
)))))
2996 ;; This function is not called in Maxima core or share code
2997 ;; and can be cut out.
2999 (and (free p
'$%i
) (member ($sign p
) '($pos $pz $zero
) :test
#'eq
)))
3002 (if (and limitp
(free e
'$%i
)) (asksign-p-or-n e
))
3003 (simplifya (list '(mabs) e
) t
))
3005 (defun simpmqapply (exp y z
)
3006 (let ((simpfun (and (not (atom (cadr exp
))) (safe-get (caaadr exp
) 'specsimp
))) u
)
3008 (funcall simpfun exp y z
)
3009 (progn (setq u
(simpargs exp z
))
3010 (if (symbolp (cadr u
))
3011 (simplifya (cons (cons (cadr u
) (cdar u
)) (cddr u
)) z
)
3014 ;; TRUE, if the symbol e is declared to be $complex or $imaginary.
3015 (defun decl-complexp (e)
3017 (kindp e
'$complex
)))
3019 ;; TRUE, if the symbol e is declared to be $real, $rational, $irrational
3021 (defun decl-realp (e)
3023 (or (kindp e
'$real
)
3024 (kindp e
'$rational
)
3025 (kindp e
'$irrational
)
3026 (kindp e
'$integer
))))
3028 ;; WARNING: Exercise extreme caution when modifying this function!
3030 ;; Richard Fateman and Stavros Macrakis both say that changing the
3031 ;; actual ordering relations (as opposed to making them faster to
3032 ;; determine) could have very subtle and wide-ranging effects. Also,
3033 ;; the simplifier spends the vast majority of its time here, so be
3034 ;; very careful about changes that may drastically slow down the
3042 (cond ((zerop y
) (floatp x
)) (t (plusp y
))))))
3044 (cond ((constant y
) (alphalessp y x
)) (t (numberp y
))))
3046 (cond ((mget y
'$scalar
) (alphalessp y x
))
3047 (t (maxima-constantp y
))))
3049 (cond ((mget y
'$mainvar
) (alphalessp y x
)) (t t
)))
3050 (t (or (maxima-constantp y
) (mget y
'$scalar
)
3051 (and (not (mget y
'$mainvar
)) (not (null (alphalessp y x
))))))))
3052 (t (not (ordfna y x
)))))
3053 ((atom y
) (ordfna x y
))
3055 (cond ((eq (caar y
) 'rat
)
3056 (> (* (caddr y
) (cadr x
)) (* (caddr x
) (cadr y
))))))
3057 ((eq (caar y
) 'rat
))
3058 ((or (member (caar x
) '(mtimes mplus mexpt %del
) :test
#'eq
)
3059 (member (caar y
) '(mtimes mplus mexpt %del
) :test
#'eq
))
3061 ((and (eq (caar x
) 'bigfloat
) (eq (caar y
) 'bigfloat
)) (mgrp x y
))
3062 ((or (eq (caar x
) 'mrat
) (eq (caar y
) 'mrat
))
3063 (error "GREAT: internal error: unexpected MRAT argument"))
3064 (t (do ((x1 (margs x
) (cdr x1
)) (y1 (margs y
) (cdr y1
))) (())
3066 (return (cond (y1 nil
)
3067 ((not (alike1 (mop x
) (mop y
)))
3068 (great (mop x
) (mop y
)))
3069 ((member 'array
(cdar x
) :test
#'eq
) t
))))
3070 ((null y1
) (return t
))
3071 ((not (alike1 (car x1
) (car y1
)))
3072 (return (great (car x1
) (car y1
)))))))))
3074 ;; Trivial function used only in ALIKE1.
3075 ;; Should be defined as an open-codable subr.
3077 (defmacro memqarr
(l)
3078 `(if (member 'array
,l
:test
#'eq
) t
))
3080 ;; Compares two Macsyma expressions ignoring SIMP flags and all other
3081 ;; items in the header except for the ARRAY flag.
3088 (and (arrayp y
) (lisp-array-alike1 x y
)))
3090 ;; NOT SURE IF WE WANT TO ENABLE COMPARISON OF MAXIMA ARRAYS
3091 ;; ASIDE FROM THAT, ADD2LNC CALLS ALIKE1 (VIA MEMALIKE) AND THAT CAUSES TROUBLE
3092 ;; ((maxima-declared-arrayp x)
3093 ;; (and (maxima-declared-arrayp y) (maxima-declared-array-alike1 x y)))
3094 ;; ((maxima-undeclared-arrayp x)
3095 ;; (and (maxima-undeclared-arrayp y) (maxima-undeclared-array-alike1 x y)))
3100 (not (atom (car x
)))
3101 (not (atom (car y
)))
3102 (eq (caar x
) (caar y
)))
3104 ((eq (caar x
) 'mrat
)
3105 ;; Punt back to LIKE, which handles CREs.
3108 (eq (memqarr (cdar x
)) (memqarr (cdar y
)))
3109 (alike (cdr x
) (cdr y
))))))))
3111 (defun lisp-array-alike1 (x y
)
3113 (equal (array-dimensions x
) (array-dimensions y
))
3115 (dotimes (i (array-total-size x
))
3116 (if (not (alike1 (row-major-aref x i
) (row-major-aref y i
)))
3117 (return-from lisp-array-alike1 nil
)))
3120 (defun maxima-declared-array-alike1 (x y
)
3121 (lisp-array-alike1 (get (mget x
'array
) 'array
) (get (mget y
'array
) 'array
)))
3123 (defun maxima-undeclared-array-alike1 (x y
)
3125 (alike1 (mfuncall '$arrayinfo x
) (mfuncall '$arrayinfo y
))
3126 (alike1 ($listarray x
) ($listarray y
))))
3128 ;; Maps ALIKE1 down two lists.
3131 (do ((x x
(cdr x
)) (y y
(cdr y
))) ((atom x
) (equal x y
))
3132 (cond ((or (atom y
) (not (alike1 (car x
) (car y
))))
3135 (defun ordfna (e a
) ; A is an atom
3137 (or (not (eq (caar e
) 'rat
))
3138 (> (cadr e
) (* (caddr e
) a
))))
3140 (not (member (caar e
) '(mplus mtimes mexpt
) :test
#'eq
)))
3141 (not (member (caar e
) '(rat bigfloat
) :test
#'eq
)))
3142 ((eq (caar e
) 'mrat
)) ;; all MRATs succeed all atoms
3143 ((null (margs e
)) nil
)
3144 ((eq (caar e
) 'mexpt
)
3145 (cond ((and (maxima-constantp (cadr e
))
3146 (or (not (constant a
)) (not (maxima-constantp (caddr e
)))))
3147 (or (not (free (caddr e
) a
)) (great (caddr e
) a
)))
3148 ((eq (cadr e
) a
) (great (caddr e
) 1))
3149 (t (great (cadr e
) a
))))
3150 ((member (caar e
) '(mplus mtimes
) :test
#'eq
)
3151 (let ((u (car (last e
))))
3152 (cond ((eq u a
) (not (ordhack e
))) (t (great u a
)))))
3153 ((eq (caar e
) '%del
))
3154 ((prog2 (setq e
(car (margs e
))) ; use first arg of e
3155 (and (not (atom e
)) (member (caar e
) '(mplus mtimes
) :test
#'eq
)))
3156 (let ((u (car (last e
)))) ; and compare using
3157 (cond ((eq u a
) (not (ordhack e
))) ; same procedure as above
3162 ;; compare lists a and b elementwise from back to front
3163 (defun ordlist (a b cx cy
)
3165 (setq l1
(length a
) l2
(length b
))
3166 loop
(cond ((= l1
0)
3167 (return (cond ((= l2
0) (eq cx
'mplus
))
3168 ((and (eq cx cy
) (= l2
1))
3169 (great (cond ((eq cx
'mplus
) 0) (t 1)) (car b
))))))
3170 ((= l2
0) (return (not (ordlist b a cy cx
)))))
3171 (setq c
(nthelem l1 a
) d
(nthelem l2 b
))
3172 (cond ((not (alike1 c d
)) (return (great c d
))))
3173 (setq l1
(1- l1
) l2
(1- l2
))
3176 (defun term-list (x)
3181 (defun factor-list (x)
3186 ;; one of the exprs x or y should be one of:
3187 ;; %del, mexpt, mplus, mtimes
3189 (let ((cx (caar x
)) (cy (caar y
)))
3190 (cond ((eq cx
'%del
) (if (eq cy
'%del
) (great (cadr x
) (cadr y
)) t
))
3192 ((or (eq cx
'mtimes
) (eq cy
'mtimes
))
3193 (ordlist (factor-list x
) (factor-list y
) 'mtimes
'mtimes
))
3194 ((or (eq cx
'mplus
) (eq cy
'mplus
))
3195 (ordlist (term-list x
) (term-list y
) 'mplus
'mplus
))
3196 ((eq cx
'mexpt
) (ordmexpt x y
))
3197 ((eq cy
'mexpt
) (not (ordmexpt y x
))))))
3200 (if (and (cddr x
) (null (cdddr x
)))
3201 (great (if (eq (caar x
) 'mplus
) 0 1) (cadr x
))))
3203 (defun ordmexpt (x y
)
3204 (cond ((eq (caar y
) 'mexpt
)
3205 (cond ((alike1 (cadr x
) (cadr y
)) (great (caddr x
) (caddr y
)))
3206 ((maxima-constantp (cadr x
))
3207 (if (maxima-constantp (cadr y
))
3208 (if (or (alike1 (caddr x
) (caddr y
))
3209 (and (mnump (caddr x
)) (mnump (caddr y
))))
3210 (great (cadr x
) (cadr y
))
3211 (great (caddr x
) (caddr y
)))
3212 (great x
(cadr y
))))
3213 ((maxima-constantp (cadr y
)) (great (cadr x
) y
))
3215 (great (cadr x
) (if (mnump (caddr y
)) (cadr y
) y
)))
3216 ((mnump (caddr y
)) (great x
(cadr y
)))
3217 (t (let ((x1 (simpln1 x
)) (y1 (simpln1 y
)))
3218 (if (alike1 x1 y1
) (great (cadr x
) (cadr y
))
3220 ((alike1 (cadr x
) y
) (great (caddr x
) 1))
3221 ((mnump (caddr x
)) (great (cadr x
) y
))
3222 (t (great (simpln1 x
) (simpln (list '(%log
) y
) 1 t
)))))
3224 (defmfun $multthru
(e1 &optional e2
)
3226 (cond (e2 ;called with two args
3227 (setq arg1
(specrepcheck e1
)
3228 arg2
(specrepcheck e2
))
3229 (cond ((or (atom arg2
)
3230 (not (member (caar arg2
) '(mplus mequal
) :test
#'eq
)))
3232 ((eq (caar arg2
) 'mequal
)
3233 (list (car arg2
) ($multthru arg1
(cadr arg2
))
3234 ($multthru arg1
(caddr arg2
))))
3235 (t (expandterms arg1
(cdr arg2
)))))
3236 (t ;called with only one arg
3238 (setq arg1
(setq arg2
(specrepcheck e1
)))
3239 (cond ((atom arg1
) (return arg1
))
3240 ((eq (caar arg1
) 'mnctimes
)
3241 (setq arg1
(cdr arg1
)) (go nct
))
3242 ((not (eq (caar arg1
) 'mtimes
)) (return arg1
)))
3243 (setq arg1
(reverse (cdr arg1
)))
3244 times
(when (mplusp (car arg1
))
3245 (setq l1
(nconc l1
(cdr arg1
)))
3246 (return (expandterms (muln l1 t
) (cdar arg1
))))
3247 (setq l1
(cons (car arg1
) l1
))
3248 (setq arg1
(cdr arg1
))
3249 (if (null arg1
) (return arg2
))
3251 nct
(when (mplusp (car arg1
))
3252 (setq l1
(nreverse l1
))
3253 (return (addn (mapcar
3257 (append l1
(ncons u
) (cdr arg1
)))
3261 (setq l1
(cons (car arg1
) l1
))
3262 (setq arg1
(cdr arg1
))
3263 (if (null arg1
) (return arg2
))
3266 ;; EXPANDEXPT computes the expansion of (x1 + x2 + ... + xm)^n
3267 ;; taking a sum and integer power as arguments.
3268 ;; Its theory is to recurse down the binomial expansion of
3269 ;; (x1 + (x2 + x3 + ... + xm))^n using the Binomial Expansion
3270 ;; Thus it does a sigma:
3274 ;; \ / n \ k (n - k)
3275 ;; > | | x1 (x2 + x3 + ... + xm)
3280 ;; The function EXPONENTIATE-SUM does this and recurses through the second
3281 ;; sum raised to a power. It takes a list of terms and a positive integer
3282 ;; power as arguments.
3285 (defun expandexpt (sum power
)
3286 (declare (fixnum power
))
3287 (let ((expansion (exponentiate-sum (cdr sum
) (abs power
))))
3288 (cond ((plusp power
) expansion
)
3289 (t `((mexpt simp
) ,expansion -
1)))))
3291 (defun exponentiate-sum (terms rpower
)
3292 (declare (fixnum rpower
))
3293 (cond ((= rpower
0) 1)
3294 ((null (cdr terms
)) (power (car terms
) rpower
))
3295 ((= rpower
1) (cons '(mplus simp
) terms
))
3296 (t (do ((i 0 (1+ i
))
3297 (result 0 (add2 result
3298 (muln (list (combination rpower i
)
3299 (exponentiate-sum (cdr terms
)
3301 (power (car terms
) i
)) t
))))
3302 ((> i rpower
) result
)
3303 (declare (fixnum i
))))))
3305 ;; Computes the combination of n elements taken m at a time by the formula
3307 ;; (n * (n-1) * ... * (n - m + 1)) / m! =
3308 ;; (n / 1) * ((n - 1) / 2) * ... * ((n - m + 1) / m)
3310 ;; Checks for the case when m is greater than n/2 and translates
3311 ;; to an equivalent expression.
3313 (defun combination (n m
)
3314 (declare (fixnum n m
))
3315 (cond ((> m
(truncate n
2))
3316 (combination n
(- n m
)))
3318 (do ((result 1 (truncate (* result n1
) m1
))
3322 (declare (fixnum n1 m1
))))))
3324 (defun expandsums (a b
)
3326 (setq a
(fixexpand a
) b
(cdr b
))
3328 (when (null a
) (return c
))
3329 (setq c
(cons (expandterms (car a
) b
) c
))
3334 (defun expandterms (a b
)
3337 (when (null b
) (return c
))
3338 (setq c
(cons (mul2 a
(car b
)) c
))
3343 (defun genexpands (l)
3348 (setq prods
(nreverse prods
)
3349 negprods
(nreverse negprods
)
3350 sums
(nreverse sums
)
3351 negsums
(nreverse negsums
))
3354 (push (car l
) prods
))
3355 ((eq (caaar l
) 'rat
)
3356 (unless (equal (cadar l
) 1)
3357 (push (cadar l
) prods
))
3358 (push (caddar l
) negprods
))
3359 ((eq (caaar l
) 'mplus
)
3360 (push (car l
) sums
))
3361 ((and (eq (caaar l
) 'mexpt
)
3362 (equal (caddar l
) -
1) (mplusp (cadar l
)))
3363 (push (cadar l
) negsums
))
3364 ((and (eq (caaar l
) 'mexpt
)
3366 (mminusp (caddar l
))))
3367 (push (if (equal (caddar l
) -
1)
3369 (list (caar l
) (cadar l
) (neg (caddar l
))))
3372 (push (car l
) prods
)))
3375 (defun expandtimes (a)
3376 (prog (prods negprods sums negsums expsums expnegsums
)
3378 (setq prods
(cond ((null prods
) 1)
3379 ((null (cdr prods
)) (car prods
))
3380 (t (cons '(mtimes simp
) prods
))))
3381 (setq negprods
(cond ((null negprods
) 1)
3382 ((null (cdr negprods
)) (car negprods
))
3383 (t (cons '(mtimes simp
) negprods
))))
3384 (cond ((null sums
) (go down
))
3385 (t (setq expsums
(car sums
))
3387 (setq expsums
(expandsums expsums c
)))
3389 (setq prods
(cond ((equal prods
1) expsums
)
3390 (t (expandterms prods
(fixexpand expsums
)))))
3391 down
(cond ((null negsums
)
3392 (cond ((equal 1 negprods
) (return prods
))
3394 (return (expandterms (power negprods -
1) (cdr prods
))))
3395 (t (return (let ((expandflag t
))
3396 (mul2 prods
(power negprods -
1)))))))
3398 (setq expnegsums
(car negsums
))
3400 (setq expnegsums
(expandsums expnegsums c
)))
3402 (setq expnegsums
(expandterms negprods
(fixexpand expnegsums
)))
3403 (return (if (mplusp prods
)
3404 (expandterms (list '(mexpt simp
) expnegsums -
1) (cdr prods
))
3405 (let ((expandflag t
))
3406 (mul2 prods
(list '(mexpt simp
) expnegsums -
1)))))))
3408 (defun expand1 (exp $expop $expon
)
3409 (unless (and (integerp $expop
) (> $expop -
1))
3410 (merror (intl:gettext
"expand: expop must be a nonnegative integer; found: ~M") $expop
))
3411 (unless (and (integerp $expon
) (> $expon -
1))
3412 (merror (intl:gettext
"expand: expon must be a nonnegative integer; found: ~M") $expon
))
3413 (resimplify (specrepcheck exp
)))
3415 (defmfun $expand
(exp &optional
(expop $maxposex
) (expon $maxnegex
))
3416 (expand1 exp expop expon
))
3418 (defun fixexpand (a)
3419 (if (not (mplusp a
))
3423 (defun simpnrt (x *n
) ; computes X^(1/*N)
3424 (prog (*in
*out varlist genvar $factorflag $dontfactor
)
3425 (setq $factorflag t
)
3427 (setq x
(ratrep* x
))
3428 (when (equal (cadr x
) 0) (return 0))
3429 (setq x
(ratfact (cdr x
) 'psqfr
))
3430 (simpnrt1 (mapcar #'pdis x
))
3431 (setq *out
(if *out
(muln *out nil
) 1))
3432 (setq *in
(cond (*in
3433 (setq *in
(muln *in nil
))
3436 (return (let (($%emode t
))
3437 (simplifya (list '(mtimes) *in
*out
)
3440 (member (caaadr *in
) '(mplus mtimes rat
) :test
#'eq
))))))))
3443 (do ((x x
(cddr x
)) (y))
3445 (cond ((not (equal 1 (setq y
(gcd (cadr x
) *n
))))
3446 (push (simpnrt (list '(mexpt) (car x
) (quotient (cadr x
) y
))
3449 ((and (equal (cadr x
) 1) (integerp (car x
)) (plusp (car x
))
3450 (setq y
(pnthrootp (car x
) *n
)))
3453 (unless (> *n
(abs (cadr x
)))
3454 (push (list '(mexpt) (car x
) (quotient (cadr x
) *n
)) *out
))
3455 (push (list '(mexpt) (car x
) (rem (cadr x
) *n
)) *in
)))))
3457 (defun nrthk (in *n
)
3463 ((eq $domain
'$real
)
3469 (power* '$%e
(list '(mtimes) (list '(rat) 1 *n
) '$%pi
'$%i
))))
3472 ((or (and wflag
(eq ($asksign in
) '$neg
))
3473 (and (mnump in
) (equal ($sign in
) '$neg
)))
3474 (nrthk1 (mul2* -
1 in
) *n
))
3478 (defun nrthk1 (in *n
) ; computes (-IN)^(1/*N)
3480 (mul2 (nrthk2 in
*n
) (nrthk -
1 *n
))
3481 (nrthk2 (mul2* -
1 in
) *n
)))
3483 (defun nrthk2 (in *n
)
3484 (power* in
(list '(rat) 1 *n
))) ; computes IN^(1/*N)
3486 ;; The following was formerly in SININT. This code was placed here because
3487 ;; SININT is now an out-of-core file on MC, and this code is needed in-core
3488 ;; because of the various calls to it. - BMT & JPG
3490 (declare-top (special var $ratfac ratform context
))
3492 (defmfun $integrate
(expr x
&optional lo hi
)
3495 (with-new-context (context)
3496 (if (member '%risch
*nounl
* :test
#'eq
)
3499 ($defint expr x lo hi
))))
3503 ((member (caar a
) '(mplus mtimes
) :test
#'eq
)
3504 (do ((l (cdr a
) (cdr l
))) ((null l
) t
)
3505 (or (ratp (car l
) var
) (return nil
))))
3506 ((eq (caar a
) 'mexpt
)
3507 (if (free (cadr a
) var
)
3508 (free (caddr a
) var
)
3509 (and (integerp (caddr a
)) (ratp (cadr a
) var
))))
3512 (defun ratnumerator (r)
3514 ((atom (cdr r
)) (car r
))
3515 ((numberp (cadr r
)) r
)
3518 (defun ratdenominator (r)
3520 ((atom (cdr r
)) (cdr r
))
3521 ((numberp (cadr r
)) 1)
3524 (declare-top (special var
))
3526 ;; (BPROG U V) appears to return A and B (as ((A1 . A2) B1 . B2) with A = A1/A2, B = B1/B2)
3527 ;; such that B/U + A/V = 1/(U*V), where U, V are polynomials represented as a list of
3528 ;; exponents and coefficients, (<gensym> E1 C1 E2 C2 ...) = C1*<gensym>^E1 + C2*<gensym>^E2 + ....
3530 ;; (%i73) partfrac ((2*x^2-3)/(x^4-3*x^2+2), x);
3531 ;; 1. Trace: (PARTFRAC '((#:X16910 2 2 0 -3) #:X16910 4 1 2 -3 0 2) '#:X16910)
3532 ;; 2. Trace: (BPROG '(#:X16910 2 1 0 -2) '(#:X16910 2 1 0 -1))
3533 ;; 2. Trace: BPROG ==> ((-1 . 1) 1 . 1)
3534 ;; 2. Trace: (BPROG '(#:X16910 1 1 0 1) '(#:X16910 1 1 0 -1))
3535 ;; 2. Trace: BPROG ==> ((1 . 2) -1 . 2)
3536 ;; 2. Trace: (BPROG '(#:X16910 1 1 0 -1) '1)
3537 ;; 2. Trace: BPROG ==> ((0 . 1) 1 . 1)
3538 ;; 1. Trace: PARTFRAC ==> ((0 . 1) ((1 . 2) (#:X16910 1 1 0 -1) 1) ((-1 . 2) (#:X16910 1 1 0 1) 1) ((1 . 1) (#:X16910 2 1 0 -2) 1))
3539 ;; (%o73) 1/(x^2-2)-1/(2*(x+1))+1/(2*(x-1))
3542 (prog (p1b p2b coef1r coef2r coef1s coef2s f1 f2 a egcd state seen-state
)
3545 (setq coef2r
(setq coef1s
0))
3546 (setq coef2s
(setq coef1r
1))
3549 (unless (zerop (pdegree p1b var
)) (setq egcd
(pgcdexpon p1b
)))
3551 (setq seen-state nil
)
3552 (unless (or (zerop (pdegree p2b var
)) (= egcd
1))
3553 (setq egcd
(gcd egcd
(pgcdexpon p2b
)))
3554 (setq p1b
(pexpon*// p1b egcd nil
)
3555 p2b
(pexpon*// p2b egcd nil
)))
3556 b1
(cond ((< (pdegree p1b var
) (pdegree p2b var
))
3558 (rotatef coef1r coef2r
)
3559 (rotatef coef1s coef2s
)))
3560 (when (zerop (pdegree p2b var
))
3561 (unless (zerop (pdegree coef2r var
))
3562 (setq coef2r
(pexpon*// coef2r egcd t
)))
3563 (unless (zerop (pdegree coef2s var
))
3564 (setq coef2s
(pexpon*// coef2s egcd t
)))
3565 (return (cons (ratreduce (ptimes (cdr r
) coef2r
) p2b
)
3566 (ratreduce (ptimes (cdr s
) coef2s
) p2b
))))
3567 (setq f1
(psquorem1 (cdr p1b
) (cdr p2b
) t
))
3568 (setq f2
(psimp var
(cadr f1
)))
3569 (setq p1b
(pquotientchk (psimp var
(caddr f1
)) a
))
3571 (setq coef1r
(pquotientchk (pdifference (ptimes f1 coef1r
)
3574 (setq coef1s
(pquotientchk (pdifference (ptimes f1 coef1s
)
3578 ;; Catch an endless loop by keeping track of (p1b, p2b) combinations seen.
3579 ;; Without this, rat(1/(x^(2/3)+1)) with algebraic = true loops forever.
3580 (when (member (setq state
(cons p1b p2b
)) seen-state
:test
#'equal
)
3581 (rat-error (intl:gettext
"BPROG: Failed to apply Bezout's identity")))
3582 (push state seen-state
)
3585 (defun ratdifference (a b
) (ratplus a
(ratminus b
)))
3587 (defun ratpl (a b
) (ratplus (ratfix a
) (ratfix b
)))
3589 (defun ratti (a b c
) (rattimes (ratfix a
) (ratfix b
) c
))
3591 (defun ratqu (a b
) (ratquotient (ratfix a
) (ratfix b
)))
3593 (defun ratfix (a) (cond ((equal a
(ratnumerator a
)) (cons a
1)) (t a
)))
3595 (defun ratdivide (f g
)
3596 (destructuring-let* (((fnum . fden
) (ratfix f
))
3597 ((gnum . gden
) (ratfix g
))
3598 ((q r
) (pdivide fnum gnum
)))
3599 (cons (ratqu (ratti q gden t
) fden
)
3602 (defun polcoef (l n
) (cond ((or (atom l
) (pointergp var
(car l
)))
3603 (cond ((equal n
0) l
) (t 0)))
3604 (t (ptterm (cdr l
) n
))))
3606 (defun disrep (l) (cond ((equal (ratnumerator l
) l
)
3607 ($ratdisrep
(cons ratform
(cons l
1))))
3608 (t ($ratdisrep
(cons ratform l
)))))
3610 (declare-top (unspecial var
))
3613 ;; The following was formerly in MATRUN. This code was placed here because
3614 ;; MATRUN is now an out-of-core file on MC, and this code is needed in-core
3615 ;; so that MACSYMA SAVE files will work. - JPG
3620 (defun kar (x) (if (atom x
) (matcherr) (car x
)))
3622 (defun kaar (x) (kar (kar x
)))
3624 (defun kdr (x) (if (atom x
) (matcherr) (cdr x
)))
3626 (defun simpargs1 (a vestigial c
)
3627 (declare (ignore vestigial
))
3631 (if (not (atom x
)) (car x
)))
3633 (defquote retlist
(&rest l
)
3635 (mapcar #'(lambda (z) (list '(mequal simp
) z
(meval z
))) l
)))
3638 (if (zerop c
) x
(nthkdr (kdr x
) (1- c
))))
