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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 ;; ** (c) Copyright 1982 Massachusetts Institute of Technology **
15 (declare-top (special $exptsubst $linechar $nolabels $inflag $piece $dispflag
16 $gradefs $props $dependencies derivflag derivlist
17 $linenum $partswitch
*linelabel
* nn
* dn
*
18 $powerdisp atvars $errexp $derivsubst $dotdistrib
19 $opsubst $subnumsimp $transrun in-p substp $sqrtdispflag
20 $pfeformat dummy-variable-operators
))
22 (defvar *islinp
* nil
) ; When T, sdiff is called from the function islinear.
23 (defvar *atp
* nil
) ; When T, prevents substitution from applying to vars
24 ; bound by %sum, %product, %integrate, %limit
26 ;; op and opr properties
28 (defvar *opr-table
* (make-hash-table :test
#'equal
))
32 (and (symbolp x
) (get x
'opr
))
33 (and (stringp x
) (gethash x
*opr-table
*))))
40 (and (symbolp x
) (setf (get x
'opr
) y
))
41 (and (stringp x
) (setf (gethash x
*opr-table
*) y
))))
45 (and (symbolp x
) (remprop x
'opr
))
46 (and (stringp x
) (remhash x
*opr-table
*))))
48 ;; Store built-in operators, which get additional properties.
49 ;; These operators aren't killed by the function kill-operator.
52 ;; This business about operator properties is terrible --
53 ;; this stuff should be in src/nparse.lisp, and it should be split up
54 ;; for each operator. Extra points for making it declarative.
57 (putprop (car x
) (cadr x
) 'op
)
58 (putprop (intern (concatenate 'string
"%" (symbol-name (car x
)))) (cadr x
) 'op
) ;; nounify not yet available
59 (putopr (cadr x
) (car x
))
60 (push (cadr x
) *mopl
*))
62 '((mplus "+") (mminus "-") (mtimes "*") (mexpt "**") (mexpt "^")
63 (mnctimes ".") (rat "/") (mquotient "/") (mncexpt "^^")
64 (mequal "=") (mgreaterp ">") (mlessp "<") (mleqp "<=") (mgeqp ">=")
65 (mnotequal "#") (mand "and") (mor "or") (mnot "not") (msetq ":")
66 (mdefine ":=") (mdefmacro "::=") (mquote "'") (mlist "[")
67 (mset "::") (mfactorial "!") (marrow "-->") (mprogn "(")
68 (mcond "if") (mdo "do") (mdoin "do_in")))
70 (mapc #'(lambda (x) (putprop (car x
) (cadr x
) 'op
))
71 '((mqapply $subvar
) (bigfloat $bfloat
)))
73 (defmvar $exptsubst nil
)
74 (defmvar $partswitch nil
)
76 (defmvar $derivsubst nil
)
78 (defvar $gradefs
'((mlist simp
)))
79 (defvar $dependencies
'((mlist simp
)))
80 (defvar atvars
'($
@1 $
@2 $
@3 $
@4))
84 (defmvar $vect_cross nil
85 "If TRUE allows DIFF(X~Y,T) to work where ~ is defined in
86 SHARE;VECT where VECT_CROSS is set to TRUE.")
88 (defmfun $substitute
(new old
&optional
(expr nil three-arg?
))
89 (cond (three-arg?
(maxima-substitute new old expr
))
91 (let ((l new
) (z old
))
92 (cond ((and ($listp l
) ($listp
(cadr l
)) (null (cddr l
)))
93 ($substitute
(cadr l
) z
))
94 ((notloreq l
) (improper-arg-err l
'$substitute
))
95 ((eq (caar l
) 'mequal
) (maxima-substitute (caddr l
) (cadr l
) z
))
96 (t (do ((l (cdr l
) (cdr l
)))
98 (setq z
($substitute
(car l
) z
)))))))))
100 ;; Define an alias $psubst and a reversealias for $psubstitute
101 (defprop $psubst $psubstitute alias
)
102 (defprop $psubstitute $psubst reversealias
)
104 ;; $psubstitute is similar to $substitute. In distinction from $substitute
105 ;; the function $psubstitute does parallel substitution, if the first argument
106 ;; is a list of equations.
107 (defmfun $psubstitute
(old new
&optional
(expr nil three-arg?
))
108 (cond (three-arg?
(maxima-substitute old new expr
))
110 (let ((l old
) (z new
))
111 (cond ((and ($listp l
)
115 ($psubstitute
(cadr l
) z
))
117 (eq (caar (cadr l
)) 'mequal
)
119 ;; A list with one equation.
120 ($psubstitute
(cadr l
) z
))
121 ((notloreq l
) (improper-arg-err l
'$psubstitute
))
122 ((eq (caar l
) 'mequal
)
123 ;; Do a substitution for one equation.
124 (maxima-substitute (caddr l
) (cadr l
) z
))
126 ;; We have a list of equations. We do parallel substitution.
127 (let (gensymbol genlist eqn
($simp nil
))
128 ;; At first substitute a gensym for the expressions of
129 ;; the left hand side of the equations.
130 (do ((l (cdr l
) (cdr l
)))
133 (when (not (eq 'mequal
(caar eqn
)))
134 (improper-arg-err old
'$substitute
))
135 (setq gensymbol
(gensym))
136 ;; Store the gensym and the new expression into a list.
137 (push (cons gensymbol
(caddr eqn
)) genlist
)
138 ;; Substitute a gensym for the old expression.
139 (setq z
(maxima-substitute gensymbol
(cadr eqn
) z
)))
140 ;; Substitute the new expressions for the gensyms.
141 (do ((l genlist
(cdr l
)))
143 ;; Resimplify the result.
144 (let (($simp t
)) (resimplify z
)))
145 (setq z
(maxima-substitute (cdar l
) (caar l
) z
))))))))))
147 (defun maxima-substitute (x y z
) ; The args to SUBSTITUTE are assumed to be simplified.
148 ;; Prevent replacing dependent variable with constant in derivative
149 (cond ((and (not (atom z
)) (eq (caar z
) '%derivative
) (eq (cadr z
) y
) (typep x
'number
)) z
)
151 (let ((in-p t
) (substp t
))
152 (if (and (mnump y
) (= (signum1 y
) 1))
153 (let ($sqrtdispflag
($pfeformat t
)) (setq z
(nformat-all z
))))
157 (setq y
'((mminus) 1)) (subst2 x y
(nformat-all z
) nil nil
)) ;; negxpty and timesp don't matter in this call since (caar y) != 'mexpt
159 (cond ((and (not (symbolp x
))
161 (let ((tem (gensym)))
162 (setf (get tem
'operators
) 'application-operator
)
163 (setf (symbol-function tem
) x
)
166 (let ((negxpty (if (and (eq (caar y
) 'mexpt
)
167 (= (signum1 (caddr y
)) 1))
168 (mul2 -
1 (caddr y
))))
169 (timesp (if (eq (caar y
) 'mtimes
) (setq y
(nformat y
)))))
170 (subst2 x y z negxpty timesp
)))
174 ;;Remainder of page is update from F302 --gsb
176 ;;Used in COMM2 (AT), limit, and below.
177 (defvar dummy-variable-operators
'(%product %sum %laplace %integrate %limit %at
))
179 (defun subst1 (x y z
) ; Y is an atom
180 (cond ((atom z
) (if (equal y z
) x z
))
181 ((specrepp z
) (subst1 x y
(specdisrep z
)))
182 ((eq (caar z
) 'bigfloat
) z
)
183 ((and (eq (caar z
) 'rat
) (or (equal y
(cadr z
)) (equal y
(caddr z
))))
184 (div (subst1 x y
(cadr z
)) (subst1 x y
(caddr z
))))
185 ((at-substp z
) (subst-except-second-arg x y z
))
186 ((and (eq y t
) (eq (caar z
) 'mcond
))
187 (list (cons (caar z
) nil
) (subst1 x y
(cadr z
)) (subst1 x y
(caddr z
))
188 (cadddr z
) (subst1 x y
(car (cddddr z
)))))
189 (t (let ((margs (mapcar #'(lambda (z1) (subst1 x y z1
)) (cdr z
)))
190 (oprx (getopr x
)) (opry (getopr y
)))
192 (or (eq opry
(caar z
))
193 (and (eq (caar z
) 'rat
) (eq opry
'mquotient
))))
195 (member x
'(t nil $%e $%pi $%i
) :test
#'eq
)
197 (not (or (eq (car x
) 'lambda
)
198 (eq (caar x
) 'lambda
)))))
199 (if (or (and (member 'array
(cdar z
) :test
#'eq
)
200 (or (and (mnump x
) $subnumsimp
)
201 (and (not (mnump x
)) (not (atom x
)))))
203 (let ((substp 'mqapply
))
204 (subst0 (list* '(mqapply) x margs
) z
))
205 (merror (intl:gettext
"subst: cannot substitute ~M for operator ~M in expression ~M") x y z
))
206 (subst0 (cons (cons oprx nil
) margs
) z
))
207 (subst0 (cons (cons (caar z
) nil
) margs
) z
))))))
209 (defun subst2 (x y z negxpty timesp
)
212 ((specrepp z
) (subst2 x y
(specdisrep z
) negxpty timesp
))
213 ((at-substp z
) z
) ;; IS SUBST-EXCEPT-SECOND-ARG APPROPRIATE HERE ?? !!
215 ((and timesp
(eq (caar z
) 'mtimes
) (alike1 y
(setq z
(nformat z
)))) x
)
216 ((and (eq (caar y
) 'mexpt
) (eq (caar z
) 'mexpt
) (alike1 (cadr y
) (cadr z
))
217 (setq newexpt
(cond ((alike1 negxpty
(caddr z
)) -
1)
218 ($exptsubst
(expthack (caddr y
) (caddr z
))))))
219 (list '(mexpt) x newexpt
))
220 ((and $derivsubst
(eq (caar y
) '%derivative
) (eq (caar z
) '%derivative
)
221 (alike1 (cadr y
) (cadr z
)))
222 (let ((tail (subst-diff-match (cddr y
) (cdr z
))))
223 (cond ((null tail
) z
)
224 (t (cons (cons (caar z
) nil
) (cons x
(cdr tail
)))))))
225 (t (recur-apply #'(lambda (z1) (subst2 x y z1 negxpty timesp
)) z
)))))
227 ;; replace y with x in z, but leave z's second arg unchanged.
228 ;; This is for cases like at(integrate(x, x, a, b), [x=3])
229 ;; where second arg of integrate binds a new variable x,
230 ;; and we do not wish to subst 3 for x inside integrand.
231 (defun subst-except-second-arg (x y z
)
233 ((member (caar z
) '(%integrate %sum %product %limit %laplace
))
235 (list (remove 'simp
(car z
)) ; ensure resimplification after substitution
236 (if (eq y
(third z
)) ; if (third z) is new var that shadows y
237 (second z
) ; leave (second z) unchanged
238 (subst1 x y
(second z
))) ; otherwise replace y with x in (second z)
239 (third z
)) ; never change integration var
240 (mapcar (lambda (z) (subst1 x y z
)); do subst in limits of integral
243 ;; similar considerations here, but different structure of expression.
245 ((at-eqn-or-eqns (third z
))
246 (at-eqns-list (if (eq (caar at-eqn-or-eqns
) 'mlist
) (rest at-eqn-or-eqns
) (list at-eqn-or-eqns
))))
248 (remove 'simp
(car z
)) ;; ensure resimplification after substitution
249 (if (member y
(mapcar #'(lambda (e) (second e
)) at-eqns-list
))
251 (subst1 x y
(second z
)))
252 `((mlist) ,@(mapcar #'(lambda (e) (list (first e
) (second e
) (subst1 x y
(third e
)))) at-eqns-list
)))))
253 ((eq (caar z
) '%derivative
)
254 ;; and again, with yet a different structure.
256 ((vars-and-degrees (rest (rest z
)))
257 (diff-vars (loop for v in vars-and-degrees by
#'cddr collect v
))
258 (diff-degrees (loop for n in
(rest vars-and-degrees
) by
#'cddr collect n
)))
261 (remove 'simp
(car z
)) ;; ensure resimplification after substitution
262 (if (member y diff-vars
)
264 (subst1 x y
(second z
))))
265 (apply #'append
(loop for v in diff-vars for n in diff-degrees collect
(list v
(subst1 x y n
)))))))
268 (defun subst0 (new old
)
269 (cond ((atom new
) new
)
270 ((alike (cdr new
) (cdr old
))
271 (cond ((eq (caar new
) (caar old
)) old
)
272 (t (simplifya (cons (cons (caar new
) (member 'array
(cdar old
) :test
#'eq
)) (cdr old
))
274 ((member 'array
(cdar old
) :test
#'eq
)
275 (simplifya (cons (cons (caar new
) '(array)) (cdr new
)) nil
))
276 (t (simplifya new nil
))))
278 (defun expthack (y z
)
279 (prog (nn* dn
* yn yd zn zd qd
)
280 (cond ((and (mnump y
) (mnump z
))
281 (return (if (numberp (setq y
(div* z y
))) y
)))
282 ((atom z
) (if (not (mnump y
)) (return nil
)))
283 ((or (ratnump z
) (eq (caar z
) 'mplus
)) (return nil
)))
284 (numden y
) ; (CSIMP) sets NN* and DN*
288 (setq qd
(cond ((and (equal zd
1) (equal yd
1)) 1)
289 ((prog2 (numden (div* zd yd
))
290 (and (equal dn
* 1) (equal nn
* 1)))
292 ((equal nn
* 1) (div* 1 dn
*))
295 (numden (div* zn yn
))
296 (if (equal dn
* 1) (return (div* nn
* qd
)))))
298 (defun subst-diff-match (l1 l2
)
299 (do ((l l1
(cddr l
)) (l2 (copy-list l2
)) (failed nil nil
))
301 (do ((l2 l2
(cddr l2
)))
302 ((null (cdr l2
)) (setq failed t
))
303 (if (alike1 (car l
) (cadr l2
))
304 (if (and (fixnump (cadr l
)) (fixnump (caddr l2
)))
305 (cond ((< (cadr l
) (caddr l2
))
306 (return (rplacd (cdr l2
)
307 (cons (- (caddr l2
) (cadr l
))
309 ((= (cadr l
) (caddr l2
))
310 (return (rplacd l2
(cdddr l2
))))
311 (t (return (setq failed t
))))
312 (return (setq failed t
)))))
313 (if failed
(return nil
))))
315 ;;This probably should be a subst or macro.
318 (or (member (caar z
) '(%derivative %del
) :test
#'eq
)
319 (member (caar z
) dummy-variable-operators
:test
#'eq
))))
321 (defun recur-apply (fun e
)
322 (cond ((eq (caar e
) 'bigfloat
) e
)
323 ((specrepp e
) (funcall fun
(specdisrep e
)))
324 (t (let ((newargs (mapcar fun
(cdr e
))))
325 (if (alike newargs
(cdr e
))
327 (simplifya (cons (cons (caar e
) (member 'array
(cdar e
) :test
#'eq
)) newargs
)
330 (defmfun $depends
(&rest args
)
331 (when (oddp (length args
))
332 (merror (intl:gettext
"depends: number of arguments must be even.")))
333 (do ((args args
(cddr args
))
335 ((null args
) (i-$dependencies
(nreverse l
)))
336 (if ($listp
(first args
))
337 (mapc #'(lambda (e) (push (depends1 e
(second args
)) l
))
339 (push (depends1 (first args
) (second args
)) l
))))
341 (defun depends1 (x y
)
342 (nonsymchk x
'$depends
)
343 (cons (cons x nil
) (if ($listp y
) (cdr y
) (cons y nil
))))
345 (defmspec $dependencies
(form)
346 (i-$dependencies
(cdr form
)))
348 (defun i-$dependencies
(l &aux res
)
354 "depends: argument must be a non-atomic expression; found ~M") z
))
359 (mputprop (caar z
) (setq y
(reverse y
)) 'depends
)
360 (setq res
(push (cons (ncons (caar z
)) y
) res
))
361 (unless (cdr $dependencies
)
362 (setq $dependencies
(copy-list '((mlist simp
)))))
363 (add2lnc (cons (cons (caar z
) nil
) y
) $dependencies
))
364 (cond ((and ($subvarp
(cadr zz
))
365 (not (member (caar (cadr zz
)) y
)))
366 (setq y
(push (cadr zz
) y
)))
367 ((not (symbolp (cadr zz
)))
369 (intl:gettext
"depends: argument must be a symbol; found ~M")
372 (not (member (cadr zz
) y
)))
373 (setq y
(push (cadr zz
) y
))))))))
374 (cons '(mlist simp
) (reverse res
)))
376 (defmspec $gradef
(l)
378 (let ((z (car l
)) (n 0))
380 (if (not (= (length l
) 3)) (merror (intl:gettext
"gradef: expected exactly three arguments.")))
382 (cons (cons (cadr l
) (meval (caddr l
)))
385 (i-$dependencies
(cons (cons (ncons z
)
386 ;; Append existing dependencies
387 (cons (cadr l
) (mget z
'depends
)))
391 ((or (mopp1 (caar z
)) (member 'array
(cdar z
) :test
#'eq
))
392 (merror (intl:gettext
"gradef: argument cannot be a built-in operator or subscripted expression; found ~M") z
))
393 ((prog2 (setq n
(- (length z
) (length l
))) (minusp n
))
395 (t (do ((zl (cdr z
) (cdr zl
))) ((null zl
))
396 (if (not (symbolp (car zl
)))
397 (merror (intl:gettext
"gradef: argument must be a symbol; found ~M") (car zl
))))
398 (setq l
(nconc (mapcar #'(lambda (x) (remsimp (meval x
)))
400 (mapcar #'(lambda (x) (list '(%derivative
) z x
1))
401 (nthcdr (- (length z
) n
) z
))))
403 (sublis (mapcar #'cons
(cdr z
) (mapcar #'stripdollar
(cdr z
)))
406 (or (cdr $gradefs
) (setq $gradefs
(copy-list '((mlist simp
)))))
407 (add2lnc (cons (cons (caar z
) nil
) (cdr z
)) $gradefs
) z
))))
409 (defmfun $diff
(&rest args
)
411 (declare (dynamic-extent args
))
420 (cond ((null e
) (wna-err '$diff
))
421 ((null (cdr e
)) (return (stotaldiff (car e
))))
422 ((null (cddr e
)) (nconc e
'(1))))
423 (setq exp
(car e
) z
(setq e
(copy-list e
)))
424 loop
(if (or (null derivlist
) (member (cadr z
) derivlist
:test
#'equal
)) (go doit
))
425 ; DERIVLIST is set by $EV
427 loop2
(cond ((cdr z
) (go loop
))
428 ((null (cdr e
)) (return exp
))
430 doit
(cond ((nonvarcheck (cadr z
) '$diff
))
431 ((null (cddr z
)) (wna-err '$diff
))
432 ((not (fixnump (caddr z
))) (go noun
))
433 ((minusp (setq count
(caddr z
)))
434 (merror (intl:gettext
"diff: order of derivative must be a nonnegative integer; found ~M") count
)))
435 loop1
(cond ((zerop count
) (rplacd z
(cdddr z
)) (go loop2
))
436 ((equal (setq exp
(sdiff exp
(cadr z
))) 0) (return 0)))
437 (setq count
(1- count
))
439 noun
(return (diff%deriv
(cons exp
(cdr e
))))))
441 (defun chainrule (e x
)
444 ;; sdiff is called from the function islinear.
445 (if (and (not (atom e
))
446 (eq (caar e
) '%derivative
)
447 (not (freel (cdr e
) x
)))
448 (diff%deriv
(list e x
1))
451 ((not (setq w
(mget (cond ((atom e
) e
)
452 ((member 'array
(cdar e
) :test
#'eq
) (caar e
))
453 ((atom (cadr e
)) (cadr e
))
460 (let ((y (sdiff u x
)))
465 (list '(%derivative
) e u
1))
470 (defun atomgrad (e x
)
472 (and (atom e
) (setq y
(mget e
'$atomgrad
)) (assolike x y
))))
474 (defun depends (e x
&aux l
)
475 (setq e
(specrepcheck e
))
476 (cond ((alike1 e x
) t
)
478 ((and (symbolp e
) (setq l
(mget e
'depends
)))
479 ;; Go recursively through the list of dependencies.
480 ;; This code detects indirect dependencies like a(x) and x(t).
483 (t (or (depends (caar e
) x
)
484 (dependsl (cdr e
) x
)))))
486 (defun dependsl (l x
)
488 (if (depends u x
) (return t
))))
490 (defun sdiff (e x
) ; The args to SDIFF are assumed to be simplified.
491 ;; Remove a special representation from the variable of differentiation
492 (setq x
(specrepcheck x
))
493 (cond ((alike1 e x
) 1)
495 ((or (atom e
) (member 'array
(cdar e
) :test
#'eq
)) (chainrule e x
))
496 ((eq (caar e
) 'mrat
) (ratdx e x
))
497 ((eq (caar e
) 'mpois
) ($poisdiff e x
)) ; Poisson series
498 ((eq (caar e
) 'mplus
) (addn (sdiffmap (cdr e
) x
) t
))
499 ((mbagp e
) (cons (car e
) (sdiffmap (cdr e
) x
)))
500 ((member (caar e
) '(%sum %product
) :test
#'eq
) (diffsumprod e x
))
501 ((eq (caar e
) '%at
) (diff-%at e x
))
502 ((not (depends e x
)) 0)
503 ((eq (caar e
) 'mtimes
) (addn (sdifftimes (cdr e
) x
) t
))
504 ((eq (caar e
) 'mexpt
) (diffexpt e x
))
505 ((eq (caar e
) 'mnctimes
)
506 (let (($dotdistrib t
))
507 (add2 (ncmuln (cons (sdiff (cadr e
) x
) (cddr e
)) t
)
508 (ncmul2 (cadr e
) (sdiff (cons '(mnctimes) (cddr e
)) x
)))))
509 ((and $vect_cross
(eq (caar e
) '|$~|
))
510 (add2* `((|$~|
) ,(cadr e
) ,(sdiff (caddr e
) x
))
511 `((|$~|
) ,(sdiff (cadr e
) x
) ,(caddr e
))))
512 ((eq (caar e
) 'mncexpt
) (diffncexpt e x
))
513 ((member (caar e
) '(%log %plog
) :test
#'eq
)
514 (sdiffgrad (cond ((and (not (atom (cadr e
))) (eq (caaadr e
) 'mabs
))
515 (cons (car e
) (cdadr e
)))
518 ((eq (caar e
) '%derivative
)
519 (cond ((or (atom (cadr e
)) (member 'array
(cdaadr e
) :test
#'eq
)) (chainrule e x
))
520 ((freel (cddr e
) x
) (diff%deriv
(cons (sdiff (cadr e
) x
) (cddr e
))))
521 (t (diff%deriv
(list e x
1)))))
522 ((member (caar e
) '(%binomial $beta
) :test
#'eq
)
523 (let ((efact ($makefact e
)))
524 (mul2 (factor (sdiff efact x
)) (div e efact
))))
525 ((eq (caar e
) '%integrate
) (diffint e x
))
526 ((eq (caar e
) '%laplace
) (difflaplace e x
))
527 ((eq (caar e
) '%at
) (diff-%at e x
))
528 ; This rule is not correct. We cut it out.
529 ; ((member (caar e) '(%realpart %imagpart) :test #'eq)
530 ; (list (cons (caar e) nil) (sdiff (cadr e) x)))
531 ((and (eq (caar e
) 'mqapply
)
532 (eq (caaadr e
) '$%f
))
533 ;; Handle %f, hypergeometric function
535 ;; The derivative of %f[p,q]([a1,...,ap],[b1,...,bq],z) is
537 ;; a1*a2*...*ap/(b1*b2*...*bq)
538 ;; *%f[p,q]([a1+1,a2+1,...,ap+1],[b1+1,b2+1,...,bq+1],z)
539 (let* ((arg1 (cdr (third e
)))
540 (arg2 (cdr (fourth e
)))
543 (div (mull arg1
) (mull arg2
))
544 `((mqapply) (($%f array
) ,(length arg1
) ,(length arg2
))
545 ((mlist) ,@(incr1 arg1
))
546 ((mlist) ,@(incr1 arg2
))
548 (t (sdiffgrad e x
))))
550 (defun sdiffgrad (e x
)
551 (let ((fun (caar e
)) grad args result
)
552 (cond ((and (eq fun
'mqapply
) (zl-get (caaadr e
) 'grad
))
553 ;; Change the array function f[n](x) to f(n,x), call sdiffgrad again.
555 (sdiffgrad (cons (cons (caaadr e
) nil
)
556 (append (cdadr e
) (cddr e
)))
558 ;; If noun form for f(n,x), adjust the noun form for f[n](x)
559 (if (isinop result
'%derivative
)
560 (if (not (depends e x
))
562 (diff%deriv
(list e x
1)))
565 ;; extension for pdiff.
566 ((and (get '$pderivop
'operators
) (funcall 'sdiffgrad-pdiff e x
)))
568 ;; two line extension for hypergeometric.
569 ((and (equal fun
'$hypergeometric
) (get '$hypergeometric
'operators
))
570 (funcall 'diff-hypergeometric
(second e
) (third e
) (fourth e
) x
))
572 ((or (eq fun
'mqapply
) (null (setq grad
(zl-get fun
'grad
))))
573 (if (not (depends e x
)) 0 (diff%deriv
(list e x
1))))
574 ((not (= (length (cdr e
)) (length (car grad
))))
575 (merror (intl:gettext
"~:M: expected exactly ~M arguments.")
577 (length (car grad
))))
579 (setq args
(sdiffmap (cdr e
) x
))
588 (do ((l1 (cdr grad
) (cdr l1
))
589 (args args
(cdr args
))
591 ((null l1
) (cons '(mlist) (nreverse l2
)))
593 (cons (cond ((equal (car args
) 0) 0)
594 ((functionp (car l1
))
595 ;; Evaluate a lambda expression
596 ;; given as a derivative.
597 (apply (car l1
) (cdr e
)))
602 (if (or (null result
) (not (freeof nil result
)))
603 ;; A derivative has returned NIL. Return a noun form.
604 (if (not (depends e x
))
606 (diff%deriv
(list e x
1)))
609 (defun sdiffmap (e x
)
610 (mapcar #'(lambda (term) (sdiff term x
)) e
))
612 (defun sdifftimes (l x
)
613 (prog (term left out
)
614 loop
(setq term
(car l
) l
(cdr l
))
615 (setq out
(cons (muln (cons (sdiff term x
) (append left l
)) t
) out
))
616 (if (null l
) (return out
))
617 (setq left
(cons term left
))
620 (defun diffexpt (e x
)
621 (if (mnump (caddr e
))
622 (mul3 (caddr e
) (power (cadr e
) (addk (caddr e
) -
1)) (sdiff (cadr e
) x
))
623 (mul2 e
(add2 (mul3 (power (cadr e
) -
1) (caddr e
) (sdiff (cadr e
) x
))
624 (mul2 (simplifya (list '(%log
) (cadr e
)) t
)
625 (sdiff (caddr e
) x
))))))
627 (defun diff%deriv
(e)
629 (simplifya (cons '(%derivative
) e
) t
)))
635 (mapc #'(lambda (z) (putprop (car z
) (cons header
(cdr z
)) 'grad
))
636 ;; All these GRAD templates have been simplified and then the SIMP flags
637 ;; (which are unnecessary) have been removed to save core space.
638 '((%log
((mexpt) x -
1)) (%plog
((mexpt) x -
1))
639 (%gamma
((mtimes) ((mqapply) (($psi array
) 0) x
) ((%gamma
) x
)))
640 (mfactorial ((mtimes) ((mqapply) (($psi array
) 0) ((mplus) 1 x
)) ((mfactorial) x
)))
642 (%cos
((mtimes) -
1 ((%sin
) x
)))
643 (%tan
((mexpt) ((%sec
) x
) 2))
644 (%cot
((mtimes) -
1 ((mexpt) ((%csc
) x
) 2)))
645 (%sec
((mtimes) ((%sec
) x
) ((%tan
) x
)))
646 (%csc
((mtimes) -
1 ((%cot
) x
) ((%csc
) x
)))
647 (%asin
((mexpt) ((mplus) 1 ((mtimes) -
1 ((mexpt) x
2))) ((rat) -
1 2)))
648 (%acos
((mtimes) -
1 ((mexpt) ((mplus) 1 ((mtimes) -
1 ((mexpt) x
2)))
650 (%atan
((mexpt) ((mplus) 1 ((mexpt) x
2)) -
1))
651 (%acot
((mtimes) -
1 ((mexpt) ((mplus) 1 ((mexpt) x
2)) -
1)))
653 ((mexpt) ((mplus) 1 ((mtimes) -
1 ((mexpt) x -
2)))
657 ((mexpt) ((mplus) 1 ((mtimes) -
1 ((mexpt) x -
2)))
662 (%tanh
((mexpt) ((%sech
) x
) 2))
663 (%coth
((mtimes) -
1 ((mexpt) ((%csch
) x
) 2)))
664 (%sech
((mtimes) -
1 ((%sech
) x
) ((%tanh
) x
)))
665 (%csch
((mtimes) -
1 ((%coth
) x
) ((%csch
) x
)))
666 (%asinh
((mexpt) ((mplus) 1 ((mexpt) x
2)) ((rat) -
1 2)))
667 (%acosh
((mexpt) ((mplus) -
1 ((mexpt) x
2)) ((rat) -
1 2)))
668 (%atanh
((mexpt) ((mplus) 1 ((mtimes) -
1 ((mexpt) x
2))) -
1))
669 (%acoth
((mtimes) -
1 ((mexpt) ((mplus) -
1 ((mexpt) x
2)) -
1)))
671 ((mexpt) ((mplus) -
1 ((mexpt) x -
2)) ((rat) -
1 2))
674 ((mexpt) ((mplus) 1 ((mexpt) x -
2)) ((rat) -
1 2))
676 (mabs ((mtimes) x
((mexpt) ((mabs) x
) -
1)))
677 (%erf
((mtimes) 2 ((mexpt) $%pi
((rat) -
1 2))
678 ((mexpt) $%e
((mtimes) -
1 ((mexpt) x
2)))))
681 (defprop $atan2
((x y
) ((mtimes) y
((mexpt) ((mplus) ((mexpt) x
2) ((mexpt) y
2)) -
1))
682 ((mtimes) -
1 x
((mexpt) ((mplus) ((mexpt) x
2) ((mexpt) y
2)) -
1)))
687 ; Do not put a noun form on the property list, but NIL.
688 ; SDIFFGRAD generates the noun form.
689 ; ((%derivative) ((mqapply) (($li array) n) x) n 1)
691 ((mtimes) ((mqapply) (($li array
) ((mplus) -
1 n
)) x
) ((mexpt) x -
1)))
696 ; Do not put a noun form on the property list, but NIL.
697 ; SDIFFGRAD generates the noun form.
699 ((mqapply) (($psi array
) ((mplus) 1 n
)) x
))
702 (defun atvarschk (argl)
703 (do ((largl (length argl
) (1- largl
))
704 (latvrs (length atvars
))
706 ((not (< latvrs largl
)) (nconc atvars l
))
707 (setq l
(cons (implode (cons '$
(cons '@ (mexploden largl
)))) l
))))
711 (not (member (caar x
) '(mlist mequal
) :test
#'eq
))
712 (and (eq (caar x
) 'mlist
)
714 (if (not (mequalp u
)) (return t
))))))
716 (defun substitutel (l1 l2 e
)
717 "l1 is a list of expressions. l2 is a list of variables. For each
718 element in list l2, substitute corresponding element of l1 into e"
719 (do ((l1 l1
(cdr l1
))
722 (setq e
(maxima-substitute (car l1
) (car l2
) e
))))
728 (if (not (memalike (car a
) b
)) (setq x
(cons (car a
) x
)))))
730 (defun intersect* (a b
)
734 (if (memalike (car a
) b
) (setq x
(cons (car a
) x
)))))
737 (car (nthcdr (1- n
) e
)))
740 (delete 'simp
(copy-list e
) :count
1 :test
#'eq
))
743 (if (atom e
) e
(cons (delsimp (car e
)) (mapcar #'remsimp
(cdr e
)))))
747 ((eq (caar e
) 'mplus
) (cons (append (car e
) '(trunc)) (cdr e
)))
748 ((mbagp e
) (cons (car e
) (mapcar #'$trunc
(cdr e
))))
749 ((specrepp e
) ($trunc
(specdisrep e
)))
752 (defun nonvarcheck (e fn
)
756 (and (not (atom e
)) (not (eq (caar e
) 'mqapply
)) (mopp1 (caar e
))))
757 (merror (intl:gettext
"~:M: second argument must be a variable; found ~M") fn e
)))
759 (defmspec $ldisplay
(form)
760 (disp1 (cdr form
) t t
))
762 (defmfun $ldisp
(&rest args
)
764 (declare (dynamic-extent args
))
767 (defmspec $display
(form)
768 (disp1 (cdr form
) nil t
))
770 (defmfun $disp
(&rest args
)
772 (declare (dynamic-extent args
))
773 (disp1 args nil nil
))
775 (defun disp1 (ll lablist eqnsp
)
776 (if lablist
(setq lablist
(cons '(mlist simp
) nil
)))
777 (do ((ll ll
(cdr ll
))
782 ((null ll
) (or lablist
'$done
))
783 (setq l
(car ll
) ans
(if eqnsp
(meval l
) l
))
784 (if (and eqnsp
(not (mequalp ans
)))
785 (setq ans
(list '(mequal simp
) (disp2 l
) ans
)))
786 (if lablist
(nconc lablist
(cons (elabel ans
) nil
)))
787 (setq tim
(get-internal-run-time))
788 (let ((*display-labels-p
* (not (null lablist
))))
789 (declare (special *display-labels-p
*))
790 (displa (list '(mlabel) (if lablist
*linelabel
*) ans
)))
796 ((eq (caar e
) 'mqapply
)
797 (cons '(mqapply) (cons (cons (caadr e
) (mapcar #'meval
(cdadr e
)))
798 (mapcar #'meval
(cddr e
)))))
799 ((eq (caar e
) 'msetq
) (disp2 (cadr e
)))
800 ((eq (caar e
) 'mset
) (disp2 (meval (cadr e
))))
801 ((eq (caar e
) 'mlist
) (cons (car e
) (mapcar #'disp2
(cdr e
))))
802 ((mspecfunp (caar e
)) e
)
803 (t (cons (car e
) (mapcar #'meval
(cdr e
))))))
805 ; Construct a new intermediate result label,
806 ; and bind it to the expression e.
807 ; The global flag $NOLABELS is ignored; the label is always bound.
808 ; Otherwise (if ELABEL were to observe $NOLABELS) it would be
809 ; impossible to programmatically refer to intermediate result expression.
812 (if (not (checklabel $linechar
)) (setq $linenum
(1+ $linenum
)))
813 (let (($nolabels nil
)) ; <-- This is pretty ugly. MAKELABEL should take another argument.
814 (makelabel $linechar
))
815 (setf (symbol-value *linelabel
*) e
)
818 (defmfun $dispterms
(e)
819 (cond ((or (atom e
) (eq (caar e
) 'bigfloat
)) (displa e
))
820 ((specrepp e
) ($dispterms
(specdisrep e
)))
821 (t (let (($dispflag t
))
823 (displa (getop (mop e
)))
824 (do ((e (if (and (eq (caar e
) 'mplus
) (not $powerdisp
))
827 (cdr e
))) ((null e
)) (mterpri) (displa (car e
)) (mterpri)))
831 (defmfun $dispform
(e &optional
(flag nil flag?
))
832 (when (and flag?
(not (eq flag
'$all
)))
833 (merror (intl:gettext
"dispform: second argument, if present, must be 'all'; found ~M") flag
))
835 (atom (setq e
(if flag?
(nformat-all e
) (nformat e
))))
836 (member 'simp
(cdar e
) :test
#'eq
))
838 (cons (cons (caar e
) (cons 'simp
(cdar e
)))
839 (if (and (eq (caar e
) 'mplus
) (not $powerdisp
))
843 ;;; These functions implement the Macsyma functions $op and $operatorp.
848 (defmfun $operatorp
(expr oplist
)
850 ($member
($op expr
) oplist
)
851 (alike1 ($op expr
) oplist
)))
853 (defmfun $part
(&rest args
)
855 (declare (dynamic-extent args
))
856 (mpart args nil nil $inflag
'$part
))
858 (defmfun $inpart
(&rest args
)
860 (declare (dynamic-extent args
))
861 (mpart args nil nil t
'$inpart
))
863 (defmspec $substpart
(l)
865 (mpart (cdr l
) t nil $inflag
'$substpart
)))
867 (defmspec $substinpart
(l)
869 (mpart (cdr l
) t nil t
'$substinpart
)))
871 (defun part1 (arglist substflag dispflag inflag fn
) ; called only by TRANSLATE
873 (mpart arglist substflag dispflag inflag fn
)))
875 (defun mpart (arglist substflag dispflag inflag fn
)
876 (prog (substitem arg arg1 exp exp1 exp
* sevlist count prevcount n specp
878 (setq specp
(or substflag dispflag
))
879 (if substflag
(setq substitem
(car arglist
) arglist
(cdr arglist
)))
880 (if (null arglist
) (wna-err fn
))
881 (setq exp
(if substflag
(meval (car arglist
)) (car arglist
)))
882 (when (null (setq arglist
(cdr arglist
)))
884 (return (cond (substflag (meval substitem
))
885 (dispflag (box exp dispflag
))
888 (cond ((or (and ($listp exp
) (null (cdr arglist
)))
890 (or (null (cdr arglist
)) (null (cddr arglist
)))))
892 ((not specp
) (setq exp
(nformat exp
)))
893 (t (setq exp
(nformat-all exp
)))))
894 ((specrepp exp
) (setq exp
(specdisrep exp
))))
895 (when (and (atom exp
) (null $partswitch
))
896 (merror (intl:gettext
"~:M: argument must be a non-atomic expression; found ~:M") fn exp
))
897 (when (and inflag specp
)
898 (setq exp
(copy-tree exp
)))
900 ;; Replace all occurrences of 'rat with 'mquotient when in subst.
901 (setq exp
(let (($simp nil
)) (maxima-substitute 'mquotient
'rat exp
))))
903 start
(cond ((or (atom exp
) (eq (caar exp
) 'bigfloat
)) (go err
))
904 ((equal (setq arg
(if substflag
(meval (car arglist
)) (car arglist
)))
906 (setq arglist
(cdr arglist
))
907 (cond ((mnump substitem
)
908 (merror (intl:gettext
"~:M: argument cannot be a number; found ~M") fn substitem
))
910 (if (eq (caar exp
) 'mqapply
)
911 (prog2 (setq exp
(cadr exp
)) (go start
))
912 ;; NOT CLEAR WHAT IS INVALID HERE. OH WELL.
913 (merror (intl:gettext
"~:M: invalid operator.") fn
)))
914 (t (setq $piece
(getop (mop exp
)))
917 (setq substitem
(getopr (meval substitem
)))
918 (cond ((mnump substitem
)
919 (merror (intl:gettext
"~:M: argument cannot be a number; found ~M") fn substitem
))
920 ((not (atom substitem
))
921 (if (not (eq (caar exp
) 'mqapply
))
922 (rplaca (rplacd exp
(cons (car exp
)
925 (rplaca (cdr exp
) substitem
)
926 (return (resimplify exp
*)))
927 ((eq (caar exp
) 'mqapply
)
928 (rplacd exp
(cddr exp
))))
929 (rplaca exp
(cons substitem
930 (if (and (member 'array
(cdar exp
) :test
#'eq
)
931 (not (mopp substitem
)))
935 (rplacd exp
(cdr (box (copy-tree exp
) dispflag
)))
936 (rplaca exp
(if (eq dispflag t
)
940 (t (when arglist
(setq exp $piece
) (go a
))
942 ((not (atom arg
)) (go several
))
944 (merror (intl:gettext
"~:M: argument must be an integer; found ~M") fn arg
))
945 ((< arg
0) (go bad
)))
946 (if (eq (caar exp
) 'mqapply
) (setq exp
(cdr exp
)))
947 loop
(cond ((not (zerop arg
)) (setq arg
(1- arg
) exp
(cdr exp
))
948 (if (null exp
) (go err
))
950 ((null (setq arglist
(cdr arglist
)))
951 (return (cond (substflag (setq $piece
(resimplify (car exp
)))
952 (rplaca exp
(meval substitem
))
954 (dispflag (setq $piece
(resimplify (car exp
)))
955 (rplaca exp
(box (car exp
) dispflag
))
957 (inflag (setq $piece
(car exp
)))
958 (t (setq $piece
(simplify (car exp
))))))))
960 a
(cond ((and (not inflag
) (not specp
)) (setq exp
(nformat exp
)))
961 ((specrepp exp
) (setq exp
(specdisrep exp
))))
963 err
(cond ((eq $partswitch
'mapply
)
964 (merror (intl:gettext
"~M: invalid index ~M of list or matrix.") fn
(car arglist
)))
965 ($partswitch
(return (setq $piece
'$end
)))
966 (t (merror (intl:gettext
"~:M: fell off the end.") fn
)))
967 bad
(improper-arg-err arg fn
)
969 (if (or (not (member (caar arg
) '(mlist $allbut
) :test
#'eq
)) (cdr arglist
))
971 (setq exp1
(cons (caar exp
) (if (member 'array
(cdar exp
) :test
#'eq
) '(array))))
972 (if (eq (caar exp
) 'mqapply
)
973 (setq sevlist
(list (cadr exp
) exp1
) exp
(cddr exp
))
974 (setq sevlist
(ncons exp1
) exp
(cdr exp
)))
975 (setq arg1
(cdr arg
) prevcount
0 exp1 exp
)
977 (if (not (fixnump arg
*))
978 (merror (intl:gettext
"~:M: argument must be an integer; found ~M") fn arg
*)))
979 (when (and specp
(eq (caar arg
) 'mlist
))
980 (if substflag
(setq lastelem
(car (last arg1
))))
981 (setq arg1
(sort (copy-list arg1
) #'<)))
982 (when (eq (caar arg
) '$allbut
)
983 (setq n
(length exp
))
985 (if (or (< i
1) (> i n
))
986 (merror (intl:gettext
"~:M: index must be in range 1 to ~M, inclusive; found ~M") fn n i
)))
987 (do ((i n
(1- i
)) (arg2))
988 ((= i
0) (setq arg1 arg2
))
989 (if (not (member i arg1
:test
#'equal
)) (setq arg2
(cons i arg2
))))
990 (if substflag
(setq lastelem
(car (last arg1
)))))
991 (if (null arg1
) (if specp
(go bad
) (go end
)))
992 (if substflag
(setq lastcount lastelem
))
995 (setq count
(- (car arg1
) prevcount
) prevcount
(car arg1
))
996 (setq count
(car arg1
)))
997 (if (< count
1) (go bad
))
998 (if (and substflag
(< (car arg1
) lastelem
))
999 (setq lastcount
(1- lastcount
)))
1000 count
(cond ((null exp
) (go err
))
1001 ((not (= count
1)) (setq count
(1- count
) exp
(cdr exp
)) (go count
)))
1002 (setq sevlist
(cons (car exp
) sevlist
))
1003 (setq arg1
(cdr arg1
))
1004 end
(cond ((null arg1
)
1005 (setq sevlist
(nreverse sevlist
))
1006 (setq $piece
(if (or inflag
(not specp
))
1008 (resimplify sevlist
)))
1009 (return (cond (substflag (rplaca (nthcdr (1- lastcount
) exp1
)
1012 (dispflag (rplaca exp
(box (car exp
) dispflag
))
1015 (substflag (if (null (cdr exp
)) (go err
))
1016 (rplaca exp
(cadr exp
)) (rplacd exp
(cddr exp
)))
1017 (dispflag (rplaca exp
(box (car exp
) dispflag
))
1018 (setq exp
(cdr exp
)))
1019 (t (setq exp exp1
)))
1023 (or (and (symbolp x
) (get x
'op
)) x
))
1027 (not (atom (car x
)))
1028 (eq (caar x
) 'mlist
)))
1030 (defmfun $cons
(x e
)
1031 (atomchk (setq e
(format1 e
)) '$cons t
)
1032 (mcons-exp-args e
(cons x
(margs e
))))
1034 (defmfun $endcons
(x e
)
1035 (atomchk (setq e
(format1 e
)) '$endcons t
)
1036 (mcons-exp-args e
(append (margs e
) (ncons x
))))
1038 (defmfun $reverse
(e)
1039 (atomchk (setq e
(format1 e
)) '$reverse nil
)
1040 (mcons-exp-args e
(reverse (margs e
))))
1042 (defmfun $append
(&rest args
)
1045 (let ((arg1 (specrepcheck (first args
))) op arrp
)
1046 (atomchk arg1
'$append nil
)
1048 arrp
(if (member 'array
(cdar arg1
) :test
#'eq
) t
))
1052 (mapcar #'(lambda (u)
1053 (atomchk (setq u
(specrepcheck u
)) '$append nil
)
1054 (unless (and (alike1 op
(mop u
))
1055 (eq arrp
(if (member 'array
(cdar u
) :test
#'eq
) t
)))
1056 (merror (intl:gettext
"append: operators of arguments must all be the same.")))
1060 (defun mcons-exp-args (e args
)
1061 (if (eq (caar e
) 'mqapply
)
1062 (list* (delsimp (car e
)) (cadr e
) args
)
1063 (cons (delsimp (car e
)) args
)))
1065 (defmfun $member
(x e
)
1066 (atomchk (setq e
($totaldisrep e
)) '$member t
)
1067 (if (memalike ($totaldisrep x
) (margs e
)) t
))
1069 (defun atomchk (e fun
2ndp
)
1070 (if (or (atom e
) (eq (caar e
) 'bigfloat
))
1071 (merror (intl:gettext
"~:M: ~Margument must be a non-atomic expression; found ~M") fun
(if 2ndp
"2nd " "") e
)))
1074 (cond (($listp e
) e
)
1075 ($inflag
(specrepcheck e
))
1079 (atomchk (setq e
(format1 e
)) '$first nil
)
1080 (if (null (cdr e
)) (merror (intl:gettext
"first: empty argument.")))
1083 ;; This macro is used to create functions second thru tenth.
1084 ;; Rather than try to modify mformat for ~:R, use the quoted symbol
1086 (macrolet ((make-nth (si i
)
1087 (let ((sim (intern (concatenate 'string
"$" (symbol-name si
)))))
1089 (atomchk (setq e
(format1 e
)) ',sim nil
)
1090 (if (< (length (margs e
)) ,i
)
1091 (merror (intl:gettext
"~:M: no such element in ~M") ',sim e
))
1099 (make-nth seventh
7)
1102 (make-nth tenth
10))
1104 (defmfun $rest
(e &optional
(n 1 n?
))
1105 (prog (m fun fun1 revp
)
1106 (when (and n?
(equal n
0))
1108 (atomchk (setq m
(format1 e
)) '$rest nil
)
1109 (cond ((and n?
(not (fixnump n
)))
1110 (merror (intl:gettext
"rest: second argument, if present, must be an integer; found ~M") n
))
1112 (setq n
(- n
) revp t
)))
1113 (if (< (length (margs m
)) n
)
1116 (merror (intl:gettext
"rest: fell off the end."))))
1118 (when (eq (car fun
) 'mqapply
)
1122 (when revp
(setq m
(reverse m
)))
1123 (setq m
(nthcdr n m
))
1124 (setq m
(cons (if (eq (car fun
) 'mlist
) fun
(delsimp fun
))
1125 (if revp
(nreverse m
) m
)))
1126 (when (eq (car fun
) 'mqapply
)
1127 (return (cons (car m
) (cons fun1
(cdr m
)))))
1131 (atomchk (setq e
(format1 e
)) '$last nil
)
1132 (when (null (cdr e
))
1133 (merror (intl:gettext
"last: empty argument.")))
1136 (defmfun $firstn
(e n
)
1137 (atomchk (setq e
(format1 e
)) '$firstn nil
)
1138 (if (or (not (fixnump n
)) (minusp n
))
1139 (merror (intl:gettext
"firstn: second argument must be a nonnegative integer; found: ~M") n
))
1140 (let ((m ($length e
)))
1143 ($rest e
(- n m
)))))
1145 (defmfun $lastn
(e n
)
1146 (atomchk (setq e
(format1 e
)) '$lastn nil
)
1147 (if (or (not (fixnump n
)) (minusp n
))
1148 (merror (intl:gettext
"lastn: second argument must be a nonnegative integer; found: ~M") n
))
1149 (let ((m ($length e
)))
1152 ($rest e
(- m n
)))))
1155 (atomchk (setq e
(format1 e
)) '$args nil
)
1156 (cons '(mlist) (margs e
)))
1158 (defmfun $delete
(x l
&optional
(n -
1 n?
))
1159 (when (and n?
(or (not (fixnump n
)) (minusp n
))) ; if n is set, it must be a nonneg fixnum
1160 (merror (intl:gettext
"delete: third argument, if present, must be a nonnegative integer; found ~M") n
))
1161 (atomchk (setq l
(specrepcheck l
)) '$delete t
)
1162 (setq x
(specrepcheck x
)
1163 l
(cons (delsimp (car l
)) (copy-list (cdr l
))))
1164 (do ((l1 (if (eq (caar l
) 'mqapply
) (cdr l
) l
)))
1165 ((or (null (cdr l1
)) (zerop n
)) l
)
1166 (if (alike1 x
(specrepcheck (cadr l1
)))
1169 (rplacd l1
(cddr l1
)))
1170 (setq l1
(cdr l1
)))))
1172 (defmfun $length
(e)
1173 (setq e
(cond (($listp e
) e
)
1174 ((or $inflag
(not ($ratp e
))) (specrepcheck e
))
1175 (t ($ratdisrep e
))))
1176 (cond ((symbolp e
) (merror (intl:gettext
"length: argument cannot be a symbol; found ~:M") e
))
1177 ((or (numberp e
) (eq (caar e
) 'bigfloat
))
1178 (if (and (not $inflag
) (mnegp e
))
1180 (merror (intl:gettext
"length: argument cannot be a number; found ~:M") e
)))
1181 ((or $inflag
(not (member (caar e
) '(mtimes mexpt
) :test
#'eq
))) (length (margs e
)))
1182 ((eq (caar e
) 'mexpt
)
1183 (if (and (alike1 (caddr e
) '((rat simp
) 1 2)) $sqrtdispflag
) 1 2))
1184 (t (length (cdr (nformat e
))))))
1187 (setq x
(specrepcheck x
)) (or (atom x
) (eq (caar x
) 'bigfloat
)))
1189 (defmfun $symbolp
(x)
1190 (setq x
(specrepcheck x
)) (symbolp x
))
1195 ((eq (caar e
) 'mrat
) ($ratnumer e
))
1196 ((eq (caar e
) 'rat
) (cadr e
))
1197 ((eq (caar (setq x
(nformat e
))) 'mquotient
) (simplify (cadr x
)))
1198 ((and (eq (caar x
) 'mminus
) (not (atom (setq x
(cadr x
))))
1199 (eq (caar x
) 'mquotient
))
1200 (simplify (list '(mtimes) -
1 (cadr x
))))
1205 ((eq (caar e
) 'mrat
) ($ratdenom e
))
1206 ((eq (caar e
) 'rat
) (caddr e
))
1207 ((or (eq (caar (setq e
(nformat e
))) 'mquotient
)
1208 (and (eq (caar e
) 'mminus
) (not (atom (setq e
(cadr e
))))
1209 (eq (caar e
) 'mquotient
)))
1210 (simplify (caddr e
)))
1213 (defmfun $entier
(e) (take '($floor
) e
))
1215 (defmfun $fix
(e) (take '($floor
) e
))
1217 ;; Evaluate THUNK ignoring any error that might occur. If the THUNK
1218 ;; returns a good number (not infinity or NaN), then return the
1219 ;; number. Otherwise, return NIL to indicate that we the computation
1220 ;; failed. This is a pretty brute-force approach.
1221 (defun try-float-computation (thunk)
1223 (errcatch (cons bindlist loclist
))
1225 (declare (special errcatch
))
1226 (let ((result (errset (funcall thunk
))))
1227 (labels ((bad-number-p (num)
1229 (or (bad-number-p (realpart num
))
1230 (bad-number-p (imagpart num
)))
1231 (or (float-inf-p num
)
1232 (float-nan-p num
)))))
1233 (if (and result
(bad-number-p (car result
)))
1239 (let ((e1 (float e
))) (if (float-inf-p e1
) (signal 'floating-point-overflow
) e1
)))
1240 ((and (symbolp e
) (mget e
'$numer
)))
1241 ((or (atom e
) (member 'array
(cdar e
) :test
#'eq
)) e
)
1242 ((eq (caar e
) 'rat
) (fpcofrat e
))
1243 ((eq (caar e
) 'bigfloat
) (fp2flo e
))
1244 ((member (caar e
) '(mexpt mncexpt
) :test
#'eq
)
1245 ;; avoid x^2 -> x^2.0, allow %e^%pi -> 23.14
1246 (let ((res (recur-apply #'$float e
)))
1249 (list (ncons (caar e
)) ($float
(cadr e
)) (caddr e
)))))
1250 ((and (eq (caar e
) '%log
)
1251 (complex-number-p (second e
) '$ratnump
))
1252 ;; Basically we try to compute float(log(x)) as directly as
1253 ;; possible, expecting Lisp to return some error if it can't.
1254 ;; Then we do a more complicated approach to compute the
1255 ;; result. However, gcl and ecl don't signal errors in these
1256 ;; cases, so we always use the complicated approach for these lisps.
1257 (let ((n (second e
)))
1259 ;; float(log(int)). First try to compute (log
1260 ;; (float n)). If that works, we're done.
1261 ;; Otherwise we need to do more.
1262 (to (or (try-float-computation #'(lambda ()
1264 (let ((m (integer-length n
)))
1265 ;; Write n as (n/2^m)*2^m where m is the number of
1266 ;; bits in n. Then log(n) = log(2^m) + log(n/2^m).
1267 ;; n/2^m is approximately 1, so converting that to a
1268 ;; float is no problem. log(2^m) = m * log(2).
1270 (log (float (/ n
(ash 1 m
)))))))))
1272 ;; float(log(n/m)) where n and m are integers. Try computing
1273 ;; it first. If it fails, compute as log(n) - log(m).
1274 (let ((try (try-float-computation #'(lambda()
1275 (log (fpcofrat n
))))))
1278 (sub ($float
`((%log
) ,(second n
)))
1279 ($float
`((%log
) ,(third n
)))))))
1280 ((complex-number-p n
'integerp
)
1281 ;; float(log(n+m*%i)).
1282 (let ((re ($realpart n
))
1284 (to (or (try-float-computation #'(lambda ()
1285 (log (complex (float re
)
1287 (let* ((size (max (integer-length re
)
1288 (integer-length im
)))
1289 (scale (ash 1 size
)))
1290 (+ (* size
(log 2e0
))
1291 (log (complex (float (/ re scale
))
1292 (float (/ im scale
))))))))))
1294 ;; log(n1/d1 + n2/d2*%i) =
1295 ;; log(s*(n+m*%i)) = log(s) + log(n+m*%i)
1297 ;; where s = lcm(d1, d2), n and m are integers
1299 (let* ((s (lcm ($denom
($realpart n
))
1300 ($denom
($imagpart n
))))
1301 (p ($expand
(mul s n
))))
1302 (add ($float
`((%log
) ,s
))
1303 ($float
`((%log
) ,p
))))))))
1304 ((and (eq (caar e
) '%erf
)
1305 (eq (second e
) '$%i
))
1306 ;; Handle like erf(%i). float(%i) (via recur-apply below)
1307 ;; just returns %i, so we never numerically evaluate it.
1308 (complexify (complex-erf (complex 0 1d0
))))
1309 ((or (eq (caar e
) '%derivative
) (eq (caar e
) '$diff
))
1310 (append (list (remove 'simp
(first e
)) ($float
(second e
))) (rest (rest e
))))
1311 (t (recur-apply #'$float e
))))
1313 (defmfun $coeff
(e x
&optional
(n 1))
1316 (coeff e
(power x n
) 1)))
1318 (defun coeff (e var pow
)
1320 (cond ((alike1 e var
) (if (equal pow
1) 1 0))
1321 ((atom e
) (if (equal pow
0) e
0))
1322 ((eq (caar e
) 'mexpt
)
1323 (cond ((alike1 (cadr e
) var
)
1324 (if (or (equal pow
0) (not (alike1 (caddr e
) pow
))) 0 1))
1327 ((or (eq (caar e
) 'mplus
) (mbagp e
))
1328 (cons (if (eq (caar e
) 'mplus
) '(mplus) (car e
))
1329 (mapcar #'(lambda (e) (coeff e var pow
)) (cdr e
))))
1330 ((eq (caar e
) 'mrat
) (ratcoeff e var pow
))
1331 ((equal pow
0) (if (coeff-contains-powers e var
) 0 e
))
1332 ((eq (caar e
) 'mtimes
)
1333 (let ((term (if (equal pow
1) var
(power var pow
))))
1334 (if (memalike term
(cdr e
)) ($delete term e
1) 0)))
1337 (defun coeff-contains-powers (e var
)
1338 (cond ((alike1 e var
) t
)
1340 ((eq (caar e
) 'mexpt
)
1341 (alike1 (cadr e
) var
))
1342 ((eq (caar e
) 'mtimes
)
1343 (member t
(mapcar #'(lambda (e)
1344 (coeff-contains-powers e var
)) (cdr e
))))
1347 (let (my-powers my-num my-flag
)
1348 (declare (special my-powers my-num my-flag
))
1350 (defmfun $hipow
(e var
)
1351 (findpowers e t var
))
1353 ;; These work best on expanded "simple" expressions.
1355 (defmfun $lopow
(e var
)
1356 (findpowers e nil var
))
1358 (defun findpowers (e hiflg var
)
1359 (let (my-powers my-num my-flag
)
1360 (declare (special my-powers my-num my-flag
))
1361 (findpowers1 e hiflg var
)
1362 (cond ((null my-powers
) (if (null my-num
) 0 my-num
))
1363 (t (when my-num
(setq my-powers
(cons my-num my-powers
)))
1364 (maximin my-powers
(if hiflg
'$max
'$min
))))))
1366 (defun findpowers1 (e hiflg var
)
1367 (cond ((alike1 e var
) (checkpow 1 hiflg
))
1369 ((eq (caar e
) 'mplus
)
1370 (cond ((not (freel (cdr e
) var
))
1371 (do ((e (cdr e
) (cdr e
))) ((null e
))
1372 (setq my-flag nil
) (findpowers1 (car e
) hiflg var
)
1373 (if (null my-flag
) (checkpow 0 hiflg
))))))
1374 ((and (eq (caar e
) 'mexpt
) (alike1 (cadr e
) var
)) (checkpow (caddr e
) hiflg
))
1375 ((specrepp e
) (findpowers1 (specdisrep e
) hiflg var
))
1376 (t (mapc #'(lambda (x) (findpowers1 x hiflg var
)) (cdr e
)))))
1378 (defun checkpow (pow hiflg
)
1380 (cond ((not (numberp pow
)) (setq my-powers
(cons pow my-powers
)))
1381 ((null my-num
) (setq my-num pow
))
1382 (hiflg (if (> pow my-num
) (setq my-num pow
)))
1383 ((< pow my-num
) (setq my-num pow
)))))
1385 ;; push(x,l): The argument l must be a mapatom that is bound to a list. Prepend x to
1386 ;; the value of l and return this list. The arguments to push are evaluated from left to right.
1388 ;; We assume that if each member of a list is simplified, the list members are still simplified
1389 ;; after pushing onto (or popping) the list. Just before returning, the code calls simplifya
1390 ;; with second argument true. Without this call to simplifya, the general simplifier would simplify
1391 ;; every list member after returning. (Barton Willis, author of $push and $pop)
1394 (let* ((o (car (pop z
)))
1395 (x (if z
(pop z
) (wna-err o
)))
1396 (l (if z
(pop z
) (wna-err o
)))
1402 (setq lo
(simplifya (cons (list (meval (mop l
)) 'array
) (mevalargs (margs l
))) t
))
1403 (setq ll
(let ((noevalargs t
)) (meval lo
))))
1406 (setq ll
(meval l
))))
1407 (if (and ($mapatom lo
) ($listp ll
))
1409 (setq ll
(cons x
(cdr ll
)))
1410 (mset lo
(simplifya (cons '(mlist) ll
) t
)))
1411 (merror "Second argument to push must be a mapatom that is bound to a list"))))
1413 ;; pop(l): The argument l must be a mapatom that is bound to a list. Remove the
1414 ;; first member of the value of l and return it.
1416 ;; We assume that if each member of a list is simplified, the list members are still simplified
1417 ;; after popping (or pushing onto) the list. Just before returning, the code calls simplifya
1418 ;; with second argument true. Without this call to simplifya, the general simplifier would simplify
1419 ;; every list member after returning.
1422 (let* ((o (car (pop z
)))
1423 (l (if z
(pop z
) (wna-err o
)))
1427 (setq lo
(simplifya (cons (list (meval (mop l
)) 'array
) (mevalargs (margs l
))) t
))
1428 (setq ll
(let ((noevalargs t
)) (meval lo
))))
1431 (setq ll
(meval lo
))))
1433 (cond ((and ($mapatom lo
) ($listp ll
))
1434 (if ($emptyp ll
) (merror "Pop called on an empty list")
1438 (mset lo
(simplifya (cons '(mlist) ll
) t
)))))
1439 (t (merror "Argument to pop must be a mapatom that is bound to a list")))))
