Fix bug #4260: translate fails with go tag in final position
[maxima.git] / src / defint.lisp
blob1d2f09fc015bec1c2d53909971f404b4ad767a16
1 ;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancements. ;;;;;
4 ;;; ;;;;;
5 ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
6 ;;; All rights reserved ;;;;;
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; (c) copyright 1982 massachusetts institute of technology ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package :maxima)
13 (macsyma-module defint)
15 ;;; this is the definite integration package.
16 ;; defint does definite integration by trying to find an
17 ;;appropriate method for the integral in question. the first thing that
18 ;;is looked at is the endpoints of the problem.
20 ;; i(grand,var,a,b) will be used for integrate(grand,var,a,b)
22 ;; References are to "Evaluation of Definite Integrals by Symbolic
23 ;; Manipulation", by Paul S. Wang,
24 ;; (http://www.lcs.mit.edu/publications/pubs/pdf/MIT-LCS-TR-092.pdf;
25 ;; a better copy might be: https://maxima.sourceforge.io/misc/Paul_Wang_dissertation.pdf)
27 ;; nointegrate is a macsyma level flag which inhibits indefinite
28 ;;integration.
29 ;; abconv is a macsyma level flag which inhibits the absolute
30 ;;convergence test.
32 ;; $defint is the top level function that takes the user input
33 ;;and does minor changes to make the integrand ready for the package.
35 ;; next comes defint, which is the function that does the
36 ;;integration. it is often called recursively from the bowels of the
37 ;;package. defint does some of the easy cases and dispatches to:
39 ;; dintegrate. this program first sees if the limits of
40 ;;integration are 0,inf or minf,inf. if so it sends the problem to
41 ;;ztoinf or mtoinf, respectively.
42 ;; else, dintegrate tries:
44 ;; intsc1 - does integrals of sin's or cos's or exp(%i var)'s
45 ;; when the interval is 0,2 %pi or 0,%pi.
46 ;; method is conversion to rational function and find
47 ;; residues in the unit circle. [wang, pp 107-109]
49 ;; ratfnt - does rational functions over finite interval by
50 ;; doing polynomial part directly, and converting
51 ;; the rational part to an integral on 0,inf and finding
52 ;; the answer by residues.
54 ;; zto1 - i(x^(k-1)*(1-x)^(l-1),x,0,1) = beta(k,l) or
55 ;; i(log(x)*x^(x-1)*(1-x)^(l-1),x,0,1) = psi...
56 ;; [wang, pp 116,117]
58 ;; dintrad- i(x^m/(a*x^2+b*x+c)^(n+3/2),x,0,inf) [wang, p 74]
60 ;; dintlog- i(log(g(x))*f(x),x,0,inf) = 0 (by symmetry) or
61 ;; tries an integration by parts. (only routine to
62 ;; try integration by parts) [wang, pp 93-95]
64 ;; dintexp- i(f(exp(k*x)),x,a,inf) = i(f(x+1)/(x+1),x,0,inf)
65 ;; or i(f(x)/x,x,0,inf)/k. First case hold for a=0;
66 ;; the second for a=minf. [wang 96-97]
68 ;;dintegrate also tries indefinite integration based on certain
69 ;;predicates (such as abconv) and tries breaking up the integrand
70 ;;over a sum or tries a change of variable.
72 ;; ztoinf is the routine for doing integrals over the range 0,inf.
73 ;; it goes over a series of routines and sees if any will work:
75 ;; scaxn - sc(b*x^n) (sc stands for sin or cos) [wang, pp 81-83]
77 ;; ssp - a*sc^n(r*x)/x^m [wang, pp 86,87]
79 ;; zmtorat- rational function. done by multiplication by plog(-x)
80 ;; and finding the residues over the keyhole contour
81 ;; [wang, pp 59-61]
83 ;; log*rat- r(x)*log^n(x) [wang, pp 89-92]
85 ;; logquad0 log(x)/(a*x^2+b*x+c) uses formula
86 ;; i(log(x)/(x^2+2*x*a*cos(t)+a^2),x,0,inf) =
87 ;; t*log(a)/sin(t). a better formula might be
88 ;; i(log(x)/(x+b)/(x+c),x,0,inf) =
89 ;; (log^2(b)-log^2(c))/(2*(b-c))
91 ;; batapp - x^(p-1)/(b*x^n+a)^m uses formula related to the beta
92 ;; function [wang, p 71]
93 ;; there is also a special case when m=1 and a*b<0
94 ;; see [wang, p 65]
96 ;; sinnu - x^-a*n(x)/d(x) [wang, pp 69-70]
98 ;; ggr - x^r*exp(a*x^n+b)
100 ;; dintexp- see dintegrate
102 ;; ztoinf also tries 1/2*mtoinf if the integrand is an even function
104 ;; mtoinf is the routine for doing integrals on minf,inf.
105 ;; it too tries a series of routines and sees if any succeed.
107 ;; scaxn - when the integrand is an even function, see ztoinf
109 ;; mtosc - exp(%i*m*x)*r(x) by residues on either the upper half
110 ;; plane or the lower half plane, depending on whether
111 ;; m is positive or negative.
113 ;; zmtorat- does rational function by finding residues in upper
114 ;; half plane
116 ;; dintexp- see dintegrate
118 ;; rectzto%pi2 - poly(x)*rat(exp(x)) by finding residues in
119 ;; rectangle [wang, pp98-100]
121 ;; ggrm - x^r*exp((x+a)^n+b)
123 ;; mtoinf also tries 2*ztoinf if the integrand is an even function.
125 (load-macsyma-macros rzmac)
127 (declare-top (special *def2* pcprntd *mtoinf*
128 *nodiverg exp1
129 *ul1* *ll1* *dflag bptu bptd zn
130 *ul* *ll* exp
132 *scflag*
133 *sin-cos-recur* *rad-poly-recur* *dintlog-recur*
134 *dintexp-recur* defintdebug *defint-assumptions*
135 *current-assumptions*
136 *global-defint-assumptions*)
137 ;;;rsn* is in comdenom. does a ratsimp of numerator.
138 ;expvar
139 (special $intanalysis $noprincipal)
140 ;impvar
141 (special *roots *failures
142 context
143 ;;LIMITP T Causes $ASKSIGN to do special things
144 ;;For DEFINT like eliminate epsilon look for prin-inf
145 ;;take realpart and imagpart.
146 integer-info
147 ;;If LIMITP is non-null ask-integer conses
148 ;;its assumptions onto this list.
151 (defvar *loopstop* 0)
153 (defmvar $intanalysis t
154 "When @code{true}, definite integration tries to find poles in the integrand
155 in the interval of integration.")
157 (defmvar defintdebug () "If true Defint prints out debugging information")
159 (defmfun $defint (exp ivar *ll* *ul*)
161 ;; Distribute $defint over equations, lists, and matrices.
162 (cond ((mbagp exp)
163 (return-from $defint
164 (simplify
165 (cons (car exp)
166 (mapcar #'(lambda (e)
167 (simplify ($defint e ivar *ll* *ul*)))
168 (cdr exp)))))))
170 (let ((*global-defint-assumptions* ())
171 (integer-info ()) (integerl integerl) (nonintegerl nonintegerl))
172 (with-new-context (context)
173 (unwind-protect
174 (let ((*defint-assumptions* ()) (*def2* ()) (*rad-poly-recur* ())
175 (*sin-cos-recur* ()) (*dintexp-recur* ()) (*dintlog-recur* 0.)
176 (ans nil) (orig-exp exp) (orig-var ivar)
177 (orig-ll *ll*) (orig-ul *ul*)
178 (pcprntd nil) (*nodiverg nil) ($logabs t) ; (limitp t)
179 (rp-polylogp ())
180 ($%edispflag nil) ; to get internal representation
181 ($m1pbranch ())) ;Try this out.
183 (make-global-assumptions) ;sets *global-defint-assumptions*
184 (setq exp (ratdisrep exp))
185 (setq ivar (ratdisrep ivar))
186 (setq *ll* (ratdisrep *ll*))
187 (setq *ul* (ratdisrep *ul*))
188 (cond (($constantp ivar)
189 (merror (intl:gettext "defint: variable of integration cannot be a constant; found ~M") ivar))
190 (($subvarp ivar) (setq ivar (gensym))
191 (setq exp ($substitute ivar orig-var exp))))
192 (cond ((not (atom ivar))
193 (merror (intl:gettext "defint: variable of integration must be a simple or subscripted variable.~%defint: found ~M") ivar))
194 ((or (among ivar *ul*)
195 (among ivar *ll*))
196 (setq ivar (gensym))
197 (setq exp ($substitute ivar orig-var exp))))
198 (unless (lenient-extended-realp *ll*)
199 (merror (intl:gettext "defint: lower limit of integration must be real; found ~M") *ll*))
200 (unless (lenient-extended-realp *ul*)
201 (merror (intl:gettext "defint: upper limit of integration must be real; found ~M") *ul*))
203 (cond ((setq ans (defint exp ivar *ll* *ul*))
204 (setq ans (subst orig-var ivar ans))
205 (cond ((atom ans) ans)
206 ((and (free ans '%limit)
207 (free ans '%integrate)
208 (or (not (free ans '$inf))
209 (not (free ans '$minf))
210 (not (free ans '$infinity))))
211 (diverg))
212 ((not (free ans '$und))
213 `((%integrate) ,orig-exp ,orig-var ,orig-ll ,orig-ul))
214 (t ans)))
215 (t `((%integrate) ,orig-exp ,orig-var ,orig-ll ,orig-ul))))
216 (forget-global-assumptions)))))
218 (defun eezz (exp *ll* *ul* ivar)
219 (cond ((or (polyinx exp ivar nil)
220 (catch 'pin%ex (pin%ex exp ivar)))
221 (setq exp (antideriv exp ivar))
222 ;; If antideriv can't do it, returns nil
223 ;; use limit to evaluate every answer returned by antideriv.
224 (cond ((null exp) nil)
225 (t (intsubs exp *ll* *ul* ivar))))))
227 ;;;Hack the expression up for exponentials.
229 (defun sinintp (expr ivar)
230 ;; Is this expr a candidate for SININT ?
231 (let ((expr (factor expr))
232 (numer nil)
233 (denom nil))
234 (setq numer ($num expr))
235 (setq denom ($denom expr))
236 (cond ((polyinx numer ivar nil)
237 (cond ((and (polyinx denom ivar nil)
238 (deg-lessp denom ivar 2))
239 t)))
240 ;;ERF type things go here.
241 ((let ((exponent (%einvolve-var numer ivar)))
242 (and (polyinx exponent ivar nil)
243 (deg-lessp exponent ivar 2)))
244 (cond ((free denom ivar)
245 t))))))
247 (defun deg-lessp (expr ivar power)
248 (cond ((or (atom expr)
249 (mnump expr)) t)
250 ((or (mtimesp expr)
251 (mplusp expr))
252 (do ((ops (cdr expr) (cdr ops)))
253 ((null ops) t)
254 (cond ((not (deg-lessp (car ops) ivar power))
255 (return ())))))
256 ((mexptp expr)
257 (and (or (not (alike1 (cadr expr) ivar))
258 (and (numberp (caddr expr))
259 (not (eq (asksign (m+ power (m- (caddr expr))))
260 '$negative))))
261 (deg-lessp (cadr expr) ivar power)))
262 ((and (consp expr)
263 (member 'array (car expr))
264 (not (eq ivar (caar expr))))
265 ;; We have some subscripted variable that's not our variable
266 ;; (I think), so it's deg-lessp.
268 ;; FIXME: Is this the best way to handle this? Are there
269 ;; other cases we're mising here?
270 t)))
272 (defun antideriv (a ivar)
273 (let ((limitp ())
274 (ans ())
275 (generate-atan2 ()))
276 (setq ans (sinint a ivar))
277 (cond ((among '%integrate ans) nil)
278 (t (simplify ans)))))
280 ;; This routine tries to take a limit a couple of ways.
281 (defun get-limit (exp ivar val &optional (dir '$plus dir?))
282 (let ((ans (if dir?
283 (funcall #'limit-no-err exp ivar val dir)
284 (funcall #'limit-no-err exp ivar val))))
285 (if (and ans (not (among '%limit ans)))
287 (when (member val '($inf $minf) :test #'eq)
288 (setq ans (limit-no-err (maxima-substitute (m^t ivar -1) ivar exp)
289 ivar
291 (if (eq val '$inf) '$plus '$minus)))
292 (if (among '%limit ans) nil ans)))))
294 (defun limit-no-err (&rest argvec)
295 (let ((errorsw t) (ans nil))
296 (setq ans (catch 'errorsw (apply #'$limit argvec)))
297 (if (eq ans t) nil ans)))
299 ;; Test whether fun2 is inverse of fun1 at val.
300 (defun test-inverse (fun1 var1 fun2 var2 val)
301 (let* ((out1 (no-err-sub-var val fun1 var1))
302 (out2 (no-err-sub-var out1 fun2 var2)))
303 (alike1 val out2)))
305 ;; integration change of variable
306 (defun intcv (nv flag ivar)
307 (let ((d (bx**n+a nv ivar))
308 (*roots ()) (*failures ()) ($breakup ()))
309 (cond ((and (eq *ul* '$inf)
310 (equal *ll* 0)
311 (equal (cadr d) 1)) ())
312 ((eq ivar 'yx) ; new ivar cannot be same as old ivar
315 ;; This is a hack! If nv is of the form b*x^n+a, we can
316 ;; solve the equation manually instead of using solve.
317 ;; Why? Because solve asks us for the sign of yx and
318 ;; that's bogus.
319 (cond (d
320 ;; Solve yx = b*x^n+a, for x. Any root will do. So we
321 ;; have x = ((yx-a)/b)^(1/n).
322 (destructuring-bind (a n b)
324 (let ((root (power* (div (sub 'yx a) b) (inv n))))
325 (cond (t
326 (setq d root)
327 (cond (flag (intcv2 d nv ivar))
328 (t (intcv1 d nv ivar))))
329 ))))
331 (putprop 'yx t 'internal);; keep ivar from appearing in questions to user
332 (solve (m+t 'yx (m*t -1 nv)) ivar 1.)
333 (cond ((setq d ;; look for root that is inverse of nv
334 (do* ((roots *roots (cddr roots))
335 (root (caddar roots) (caddar roots)))
336 ((null root) nil)
337 (if (and (or (real-infinityp *ll*)
338 (test-inverse nv ivar root 'yx *ll*))
339 (or (real-infinityp *ul*)
340 (test-inverse nv ivar root 'yx *ul*)))
341 (return root))))
342 (cond (flag (intcv2 d nv ivar))
343 (t (intcv1 d nv ivar))))
344 (t ()))))))))
346 ;; d: original variable (ivar) as a function of 'yx
347 ;; ind: boolean flag
348 ;; nv: new variable ('yx) as a function of original variable (ivar)
349 (defun intcv1 (d nv ivar)
350 (cond ((and (intcv2 d nv ivar)
351 (equal ($imagpart *ll1*) 0)
352 (equal ($imagpart *ul1*) 0)
353 (not (alike1 *ll1* *ul1*)))
354 (let ((*def2* t))
355 (defint exp1 'yx *ll1* *ul1*)))))
357 ;; converts limits of integration to values for new variable 'yx
358 (defun intcv2 (d nv ivar)
359 (intcv3 d nv ivar)
360 (and (cond ((and (zerop1 (m+ *ll* *ul*))
361 (evenfn nv ivar))
362 (setq exp1 (m* 2 exp1)
363 *ll1* (limcp nv ivar 0 '$plus)))
364 (t (setq *ll1* (limcp nv ivar *ll* '$plus))))
365 (setq *ul1* (limcp nv ivar *ul* '$minus))))
367 ;; wrapper around limit, returns nil if
368 ;; limit not found (nounform returned), or undefined ($und or $ind)
369 (defun limcp (a b c d)
370 (let ((ans ($limit a b c d)))
371 (cond ((not (or (null ans)
372 (among '%limit ans)
373 (among '$ind ans)
374 (among '$und ans)))
375 ans))))
377 ;; rewrites exp, the integrand in terms of ivar,
378 ;; into exp1, the integrand in terms of 'yx.
379 (defun intcv3 (d nv ivar)
380 (setq exp1 (m* (sdiff d 'yx)
381 (subst d ivar (subst 'yx nv exp))))
382 (setq exp1 (sratsimp exp1)))
384 (defun integrand-changevar (d newvar exp ivar)
385 (m* (sdiff d newvar)
386 (subst d ivar exp)))
388 (defun defint (exp ivar *ll* *ul*)
389 (let ((old-assumptions *defint-assumptions*)
390 (*current-assumptions* ())
391 (limitp t))
392 (unwind-protect
393 (prog ()
394 (setq *current-assumptions* (make-defint-assumptions 'noask ivar))
395 (let ((exp (resimplify exp))
396 (ivar (resimplify ivar))
397 ($exptsubst t)
398 (*loopstop* 0)
399 ;; D (not used? -- cwh)
400 ans nn* dn* nd* $noprincipal)
401 (cond ((setq ans (defint-list exp ivar *ll* *ul*))
402 (return ans))
403 ((or (zerop1 exp)
404 (alike1 *ul* *ll*))
405 (return 0.))
406 ((not (among ivar exp))
407 (cond ((or (member *ul* '($inf $minf) :test #'eq)
408 (member *ll* '($inf $minf) :test #'eq))
409 (diverg))
410 (t (setq ans (m* exp (m+ *ul* (m- *ll*))))
411 (return ans))))
412 ;; Look for integrals which involve log and exp functions.
413 ;; Maxima has a special algorithm to get general results.
414 ((and (setq ans (defint-log-exp exp ivar *ll* *ul*)))
415 (return ans)))
416 (let* ((exp (rmconst1 exp ivar))
417 (c (car exp))
418 (exp (%i-out-of-denom (cdr exp))))
419 (cond ((and (not $nointegrate)
420 (not (atom exp))
421 (or (among 'mqapply exp)
422 (not (member (caar exp)
423 '(mexpt mplus mtimes %sin %cos
424 %tan %sinh %cosh %tanh
425 %log %asin %acos %atan
426 %cot %acot %sec
427 %asec %csc %acsc
428 %derivative) :test #'eq))))
429 ;; Call ANTIDERIV with logabs disabled,
430 ;; because the Risch algorithm assumes
431 ;; the integral of 1/x is log(x), not log(abs(x)).
432 ;; Why not just assume logabs = false within RISCHINT itself?
433 ;; Well, there's at least one existing result which requires
434 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
435 (cond ((setq ans (let ($logabs) (antideriv exp ivar)))
436 (setq ans (intsubs ans *ll* *ul* ivar))
437 (return (cond (ans (m* c ans)) (t nil))))
438 (t (return nil)))))
439 (setq exp (tansc-var exp ivar))
440 (cond ((setq ans (initial-analysis exp ivar *ll* *ul*))
441 (return (m* c ans))))
442 (return nil))))
443 (restore-defint-assumptions old-assumptions *current-assumptions*))))
445 (defun defint-list (exp ivar *ll* *ul*)
446 (cond ((mbagp exp)
447 (let ((ans (cons (car exp)
448 (mapcar
449 #'(lambda (sub-exp)
450 (defint sub-exp ivar *ll* *ul*))
451 (cdr exp)))))
452 (cond (ans (simplify ans))
453 (t nil))))
454 (t nil)))
456 (defun initial-analysis (exp ivar *ll* *ul*)
457 (let ((pole (cond ((not $intanalysis)
458 '$no) ;don't do any checking.
459 (t (poles-in-interval exp ivar *ll* *ul*)))))
460 (cond ((eq pole '$no)
461 (cond ((and (oddfn exp ivar)
462 (or (and (eq *ll* '$minf)
463 (eq *ul* '$inf))
464 (eq ($sign (m+ *ll* *ul*))
465 '$zero))) 0)
466 (t (parse-integrand exp ivar *ll* *ul*))))
467 ((eq pole '$unknown) ())
468 (t (principal-value-integral exp ivar *ll* *ul* pole)))))
470 (defun parse-integrand (exp ivar *ll* *ul*)
471 (let (ans)
472 (cond ((setq ans (eezz exp *ll* *ul* ivar)) ans)
473 ((and (ratp exp ivar)
474 (setq ans (method-by-limits exp ivar *ll* *ul*)))
475 ans)
476 ((and (mplusp exp)
477 (setq ans (intbyterm exp t ivar)))
478 ans)
479 ((setq ans (method-by-limits exp ivar *ll* *ul*)) ans)
480 (t ()))))
482 (defun rmconst1 (e ivar)
483 (cond ((not (freeof ivar e))
484 (partition e ivar 1))
485 (t (cons e 1))))
488 (defun method-by-limits (exp ivar *ll* *ul*)
489 (let ((old-assumptions *defint-assumptions*))
490 (setq *current-assumptions* (make-defint-assumptions 'noask ivar))
491 ;;Should be a PROG inside of unwind-protect, but Multics has a compiler
492 ;;bug wrt. and I want to test this code now.
493 (unwind-protect
494 (cond ((and (and (eq *ul* '$inf)
495 (eq *ll* '$minf))
496 (mtoinf exp ivar)))
497 ((and (and (eq *ul* '$inf)
498 (equal *ll* 0.))
499 (ztoinf exp ivar)))
500 ;;;This seems((and (and (eq *ul* '$inf)
501 ;;;fairly losing (setq exp (subin (m+ *ll* ivar) exp))
502 ;;; (setq *ll* 0.))
503 ;;; (ztoinf exp ivar)))
504 ((and (equal *ll* 0.)
505 (freeof ivar *ul*)
506 (eq ($asksign *ul*) '$pos)
507 (zto1 exp ivar)))
508 ;; ((and (and (equal *ul* 1.)
509 ;; (equal *ll* 0.)) (zto1 exp)))
510 (t (dintegrate exp ivar *ll* *ul*)))
511 (restore-defint-assumptions old-assumptions *defint-assumptions*))))
514 (defun dintegrate (exp ivar *ll* *ul*)
515 (let ((ans nil) (arg nil) (*scflag* nil)
516 (*dflag nil) ($%emode t))
517 ;;;NOT COMPLETE for sin's and cos's.
518 (cond ((and (not *sin-cos-recur*)
519 (oscip-var exp ivar)
520 (setq *scflag* t)
521 (intsc1 *ll* *ul* exp ivar)))
522 ((and (not *rad-poly-recur*)
523 (notinvolve-var exp ivar '(%log))
524 (not (%einvolve-var exp ivar))
525 (method-radical-poly exp ivar *ll* *ul*)))
526 ((and (not (equal *dintlog-recur* 2.))
527 (setq arg (involve-var exp ivar '(%log)))
528 (dintlog exp arg ivar)))
529 ((and (not *dintexp-recur*)
530 (setq arg (%einvolve-var exp ivar))
531 (dintexp exp ivar)))
532 ((and (not (ratp exp ivar))
533 (setq ans (let (($trigexpandtimes nil)
534 ($trigexpandplus t))
535 ($trigexpand exp)))
536 (setq ans ($expand ans))
537 (not (alike1 ans exp))
538 (intbyterm ans t ivar)))
539 ;; Call ANTIDERIV with logabs disabled,
540 ;; because the Risch algorithm assumes
541 ;; the integral of 1/x is log(x), not log(abs(x)).
542 ;; Why not just assume logabs = false within RISCHINT itself?
543 ;; Well, there's at least one existing result which requires
544 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
545 ((setq ans (let ($logabs) (antideriv exp ivar)))
546 (intsubs ans *ll* *ul* ivar))
547 (t nil))))
549 (defun method-radical-poly (exp ivar *ll* *ul*)
550 ;;;Recursion stopper
551 (let ((*rad-poly-recur* t) ;recursion stopper
552 (result ()))
553 (cond ((and (sinintp exp ivar)
554 (setq result (antideriv exp ivar))
555 (intsubs result *ll* *ul* ivar)))
556 ((and (ratp exp ivar)
557 (setq result (ratfnt exp ivar))))
558 ((and (not *scflag*)
559 (not (eq *ul* '$inf))
560 (radicalp exp ivar)
561 (kindp34 ivar)
562 (setq result (cv exp ivar))))
563 (t ()))))
565 (defun principal-value-integral (exp ivar *ll* *ul* poles)
566 (let ((anti-deriv ()))
567 (cond ((not (null (setq anti-deriv (antideriv exp ivar))))
568 (cond ((not (null poles))
569 (order-limits 'ask ivar)
570 (cond ((take-principal anti-deriv *ll* *ul* ivar poles))
571 (t ()))))))))
573 ;; adds up integrals of ranges between each pair of poles.
574 ;; checks if whole thing is divergent as limits of integration approach poles.
575 (defun take-principal (anti-deriv *ll* *ul* ivar poles &aux ans merged-list)
576 ;;; calling $logcontract causes antiderivative of 1/(1-x^5) to blow up
577 ;; (setq anti-deriv (cond ((involve anti-deriv '(%log))
578 ;; ($logcontract anti-deriv))
579 ;; (t anti-deriv)))
580 (setq ans 0.)
581 (setq merged-list (interval-list poles *ll* *ul*))
582 (do ((current-pole (cdr merged-list) (cdr current-pole))
583 (previous-pole merged-list (cdr previous-pole)))
584 ((null current-pole) t)
585 (setq ans (m+ ans
586 (intsubs anti-deriv (m+ (caar previous-pole) 'epsilon)
587 (m+ (caar current-pole) (m- 'epsilon))
588 ivar))))
590 (setq ans (get-limit (get-limit ans 'epsilon 0 '$plus) 'prin-inf '$inf))
591 ;;Return section.
592 (cond ((or (null ans)
593 (not (free ans '$infinity))
594 (not (free ans '$ind))) ())
595 ((or (among '$minf ans)
596 (among '$inf ans)
597 (among '$und ans))
598 (diverg))
599 (t (principal) ans)))
601 (defun interval-list (pole-list *ll* *ul*)
602 (let ((first (car (first pole-list)))
603 (last (caar (last pole-list))))
604 (cond ((eq *ul* last)
605 (if (eq *ul* '$inf)
606 (setq pole-list (subst 'prin-inf '$inf pole-list))))
607 (t (if (eq *ul* '$inf)
608 (setq *ul* 'prin-inf))
609 (setq pole-list (append pole-list (list (cons *ul* 'ignored))))))
610 (cond ((eq *ll* first)
611 (if (eq *ll* '$minf)
612 (setq pole-list (subst (m- 'prin-inf) '$minf pole-list))))
613 (t (if (eq *ll* '$minf)
614 (setq *ll* (m- 'prin-inf)))
615 (setq pole-list (append (list (cons *ll* 'ignored)) pole-list)))))
616 pole-list)
618 ;; Assumes EXP is a rational expression with no polynomial part and
619 ;; converts the finite integration to integration over a half-infinite
620 ;; interval. The substitution y = (x-a)/(b-x) is used. Equivalently,
621 ;; x = (b*y+a)/(y+1).
623 ;; (I'm guessing CV means Change Variable here.)
624 (defun cv (exp ivar)
625 (if (not (or (real-infinityp *ll*) (real-infinityp *ul*)))
626 ;; FIXME! This is a hack. We apply the transformation with
627 ;; symbolic limits and then substitute the actual limits later.
628 ;; That way method-by-limits (usually?) sees a simpler
629 ;; integrand.
631 ;; See Bugs 938235 and 941457. These fail because $FACTOR is
632 ;; unable to factor the transformed result. This needs more
633 ;; work (in other places).
634 (let ((trans (integrand-changevar (m// (m+t '*ll* (m*t '*ul* 'yx))
635 (m+t 1. 'yx))
636 'yx exp ivar)))
637 ;; If the limit is a number, use $substitute so we simplify
638 ;; the result. Do we really want to do this?
639 (setf trans (if (mnump *ll*)
640 ($substitute *ll* '*ll* trans)
641 (subst *ll* '*ll* trans)))
642 (setf trans (if (mnump *ul*)
643 ($substitute *ul* '*ul* trans)
644 (subst *ul* '*ul* trans)))
645 (method-by-limits trans 'yx 0. '$inf))
646 ()))
648 ;; Integrate rational functions over a finite interval by doing the
649 ;; polynomial part directly, and converting the rational part to an
650 ;; integral from 0 to inf. This is evaluated via residues.
651 (defun ratfnt (exp ivar)
652 (let ((e (pqr exp ivar)))
653 ;; PQR divides the rational expression and returns the quotient
654 ;; and remainder
655 (flet ((try-antideriv (e lo hi)
656 (let ((ans (antideriv e ivar)))
657 (when ans
658 (intsubs ans lo hi ivar)))))
660 (cond ((equal 0. (car e))
661 ;; No polynomial part
662 (let ((ans (try-antideriv exp *ll* *ul*)))
663 (if ans
665 (cv exp ivar))))
666 ((equal 0. (cdr e))
667 ;; Only polynomial part
668 (eezz (car e) *ll* *ul* ivar))
670 ;; A non-zero quotient and remainder. Combine the results
671 ;; together.
672 (let ((ans (try-antideriv (m// (cdr e) dn*) *ll* *ul*)))
673 (cond (ans
674 (m+t (eezz (car e) *ll* *ul* ivar)
675 ans))
677 (m+t (eezz (car e) *ll* *ul* ivar)
678 (cv (m// (cdr e) dn*) ivar))))))))))
680 ;; I think this takes a rational expression E, and finds the
681 ;; polynomial part. A cons is returned. The car is the quotient and
682 ;; the cdr is the remainder.
683 (defun pqr (e ivar)
684 (let ((varlist (list ivar)))
685 (newvar e)
686 (setq e (cdr (ratrep* e)))
687 (setq dn* (pdis (ratdenominator e)))
688 (setq e (pdivide (ratnumerator e) (ratdenominator e)))
689 (cons (simplify (rdis (car e))) (simplify (rdis (cadr e))))))
692 (defun intbyterm (exp *nodiverg ivar)
693 (let ((saved-exp exp))
694 (cond ((mplusp exp)
695 (let ((ans (catch 'divergent
696 (andmapcar #'(lambda (new-exp)
697 (let ((*def2* t))
698 (defint new-exp ivar *ll* *ul*)))
699 (cdr exp)))))
700 (cond ((null ans) nil)
701 ((eq ans 'divergent)
702 (let ((*nodiverg nil))
703 (cond ((setq ans (antideriv saved-exp ivar))
704 (intsubs ans *ll* *ul* ivar))
705 (t nil))))
706 (t (sratsimp (m+l ans))))))
707 ;;;If leadop isn't plus don't do anything.
708 (t nil))))
710 (defun kindp34 (ivar)
711 (numden-var exp ivar)
712 (let* ((d dn*)
713 (a (cond ((and (zerop1 ($limit d ivar *ll* '$plus))
714 (eq (limit-pole (m+ exp (m+ (m- *ll*) ivar))
715 ivar *ll* '$plus)
716 '$yes))
718 (t nil)))
719 (b (cond ((and (zerop1 ($limit d ivar *ul* '$minus))
720 (eq (limit-pole (m+ exp (m+ *ul* (m- ivar)))
721 ivar *ul* '$minus)
722 '$yes))
724 (t nil))))
725 (or a b)))
727 (defun diverg nil
728 (cond (*nodiverg (throw 'divergent 'divergent))
729 (t (merror (intl:gettext "defint: integral is divergent.")))))
731 (defun make-defint-assumptions (ask-or-not ivar)
732 (cond ((null (order-limits ask-or-not ivar)) ())
733 (t (mapc 'forget *defint-assumptions*)
734 (setq *defint-assumptions* ())
735 (let ((sign-ll (cond ((eq *ll* '$inf) '$pos)
736 ((eq *ll* '$minf) '$neg)
737 (t ($sign ($limit *ll*)))))
738 (sign-ul (cond ((eq *ul* '$inf) '$pos)
739 ((eq *ul* '$minf) '$neg)
740 (t ($sign ($limit *ul*)))))
741 (sign-ul-ll (cond ((and (eq *ul* '$inf)
742 (not (eq *ll* '$inf))) '$pos)
743 ((and (eq *ul* '$minf)
744 (not (eq *ll* '$minf))) '$neg)
745 (t ($sign ($limit (m+ *ul* (m- *ll*))))))))
746 (cond ((eq sign-ul-ll '$pos)
747 (setq *defint-assumptions*
748 `(,(assume `((mgreaterp) ,ivar ,*ll*))
749 ,(assume `((mgreaterp) ,*ul* ,ivar)))))
750 ((eq sign-ul-ll '$neg)
751 (setq *defint-assumptions*
752 `(,(assume `((mgreaterp) ,ivar ,*ul*))
753 ,(assume `((mgreaterp) ,*ll* ,ivar))))))
754 (cond ((and (eq sign-ll '$pos)
755 (eq sign-ul '$pos))
756 (setq *defint-assumptions*
757 `(,(assume `((mgreaterp) ,ivar 0))
758 ,@*defint-assumptions*)))
759 ((and (eq sign-ll '$neg)
760 (eq sign-ul '$neg))
761 (setq *defint-assumptions*
762 `(,(assume `((mgreaterp) 0 ,ivar))
763 ,@*defint-assumptions*)))
764 (t *defint-assumptions*))))))
766 (defun restore-defint-assumptions (old-assumptions assumptions)
767 (do ((llist assumptions (cdr llist)))
768 ((null llist) t)
769 (forget (car llist)))
770 (do ((llist old-assumptions (cdr llist)))
771 ((null llist) t)
772 (assume (car llist))))
774 (defun make-global-assumptions ()
775 (setq *global-defint-assumptions*
776 (cons (assume '((mgreaterp) *z* 0.))
777 *global-defint-assumptions*))
778 ;; *Z* is a "zero parameter" for this package.
779 ;; Its also used to transform.
780 ;; limit(exp,var,val,dir) -- limit(exp,tvar,0,dir)
781 (setq *global-defint-assumptions*
782 (cons (assume '((mgreaterp) epsilon 0.))
783 *global-defint-assumptions*))
784 (setq *global-defint-assumptions*
785 (cons (assume '((mlessp) epsilon 1.0e-8))
786 *global-defint-assumptions*))
787 ;; EPSILON is used in principal value code to denote the familiar
788 ;; mathematical entity.
789 (setq *global-defint-assumptions*
790 (cons (assume '((mgreaterp) prin-inf 1.0e+8))
791 *global-defint-assumptions*)))
793 ;;; PRIN-INF Is a special symbol in the principal value code used to
794 ;;; denote an end-point which is proceeding to infinity.
796 (defun forget-global-assumptions ()
797 (do ((llist *global-defint-assumptions* (cdr llist)))
798 ((null llist) t)
799 (forget (car llist)))
800 (cond ((not (null integer-info))
801 (do ((llist integer-info (cdr llist)))
802 ((null llist) t)
803 (i-$remove `(,(cadar llist) ,(caddar llist)))))))
805 (defun order-limits (ask-or-not ivar)
806 (cond ((or (not (equal ($imagpart *ll*) 0))
807 (not (equal ($imagpart *ul*) 0))) ())
808 (t (cond ((alike1 *ll* (m*t -1 '$inf))
809 (setq *ll* '$minf)))
810 (cond ((alike1 *ul* (m*t -1 '$inf))
811 (setq *ul* '$minf)))
812 (cond ((alike1 *ll* (m*t -1 '$minf))
813 (setq *ll* '$inf)))
814 (cond ((alike1 *ul* (m*t -1 '$minf))
815 (setq *ul* '$inf)))
816 (cond ((eq *ll* *ul*)
817 ; We have minf <= *ll* = *ul* <= inf
819 ((eq *ul* '$inf)
820 ; We have minf <= *ll* < *ul* = inf
822 ((eq *ll* '$minf)
823 ; We have minf = *ll* < *ul* < inf
825 ; Now substitute
827 ; ivar -> -ivar
828 ; *ll* -> -*ul*
829 ; *ul* -> inf
831 ; so that minf < *ll* < *ul* = inf
832 (setq exp (subin-var (m- ivar) exp ivar))
833 (setq *ll* (m- *ul*))
834 (setq *ul* '$inf))
835 ((or (eq *ll* '$inf)
836 (equal (complm ask-or-not) -1))
837 ; We have minf <= *ul* < *ll*
839 ; Now substitute
841 ; exp -> -exp
842 ; *ll* <-> *ul*
844 ; so that minf <= *ll* < *ul*
845 (setq exp (m- exp))
846 (rotatef *ll* *ul*)))
847 t)))
849 (defun complm (ask-or-not)
850 (let ((askflag (cond ((eq ask-or-not 'ask) t)
851 (t nil)))
852 (a ()))
853 (cond ((alike1 *ul* *ll*) 0.)
854 ((eq (setq a (cond (askflag ($asksign ($limit (m+t *ul* (m- *ll*)))))
855 (t ($sign ($limit (m+t *ul* (m- *ll*)))))))
856 '$pos)
858 ((eq a '$neg) -1)
859 (t 1.))))
861 ;; Substitute a and b into integral e
863 ;; Looks for discontinuties in integral, and works around them.
864 ;; For example, in
866 ;; integrate(x^(2*n)*exp(-(x)^2),x) ==>
867 ;; -gamma_incomplete((2*n+1)/2,x^2)*x^(2*n+1)*abs(x)^(-2*n-1)/2
869 ;; the integral has a discontinuity at x=0.
871 (defun intsubs (e a b ivar)
872 (let ((edges (cond ((not $intanalysis)
873 '$no) ;don't do any checking.
874 (t (discontinuities-in-interval
875 (let (($algebraic t))
876 (sratsimp e))
877 ivar a b)))))
879 (cond ((or (eq edges '$no)
880 (eq edges '$unknown))
881 (whole-intsubs e a b ivar))
883 (do* ((l edges (cdr l))
884 (total nil)
885 (a1 (car l) (car l))
886 (b1 (cadr l) (cadr l)))
887 ((null (cdr l)) (if (every (lambda (x) x) total)
888 (m+l total)))
889 (push
890 (whole-intsubs e a1 b1 ivar)
891 total))))))
893 ;; look for terms with a negative exponent
895 ;; recursively traverses exp in order to find discontinuities such as
896 ;; erfc(1/x-x) at x=0
897 (defun discontinuities-denom (exp ivar)
898 (cond ((atom exp) 1)
899 ((and (eq (caar exp) 'mexpt)
900 (not (freeof ivar (cadr exp)))
901 (not (member ($sign (caddr exp)) '($pos $pz))))
902 (m^ (cadr exp) (m- (caddr exp))))
904 (m*l (mapcar #'(lambda (e)
905 (discontinuities-denom e ivar))
906 (cdr exp))))))
908 ;; returns list of places where exp might be discontinuous in ivar.
909 ;; list begins with *ll* and ends with *ul*, and include any values between
910 ;; *ll* and *ul*.
911 ;; return '$no or '$unknown if no discontinuities found.
912 (defun discontinuities-in-interval (exp ivar *ll* *ul*)
913 (let* ((denom (discontinuities-denom exp ivar))
914 (roots (real-roots denom ivar)))
915 (cond ((eq roots '$failure)
916 '$unknown)
917 ((eq roots '$no)
918 '$no)
919 (t (do ((dummy roots (cdr dummy))
920 (pole-list nil))
921 ((null dummy)
922 (cond (pole-list
923 (append (list *ll*)
924 (sortgreat pole-list)
925 (list *ul*)))
926 (t '$no)))
927 (let ((soltn (caar dummy)))
928 ;; (multiplicity (cdar dummy)) ;; not used
929 (if (strictly-in-interval soltn *ll* *ul*)
930 (push soltn pole-list))))))))
933 ;; Carefully substitute the integration limits A and B into the
934 ;; expression E.
935 (defun whole-intsubs (e a b ivar)
936 (cond ((easy-subs e a b ivar))
937 (t (setq *current-assumptions*
938 (make-defint-assumptions 'ask ivar)) ;get forceful!
939 (let (($algebraic t))
940 (setq e (sratsimp e))
941 (cond ((limit-subs e a b ivar))
942 (t (same-sheet-subs e a b ivar)))))))
944 ;; Try easy substitutions. Return NIL if we can't.
945 (defun easy-subs (e *ll* *ul* ivar)
946 (cond ((or (infinityp *ll*) (infinityp *ul*))
947 ;; Infinite limits aren't easy
948 nil)
950 (cond ((or (polyinx e ivar ())
951 (and (not (involve-var e ivar '(%log %asin %acos %atan %asinh %acosh %atanh %atan2
952 %gamma_incomplete %expintegral_ei)))
953 (free ($denom e) ivar)))
954 ;; It's easy if we have a polynomial. I (rtoy) think
955 ;; it's also easy if the denominator is free of the
956 ;; integration variable and also if the expression
957 ;; doesn't involve inverse functions.
959 ;; gamma_incomplete and expintegral_ie
960 ;; included because of discontinuity in
961 ;; gamma_incomplete(0, exp(%i*x)) and
962 ;; expintegral_ei(exp(%i*x))
964 ;; XXX: Are there other cases we've forgotten about?
966 ;; So just try to substitute the limits into the
967 ;; expression. If no errors are produced, we're done.
968 (let ((ll-val (no-err-sub-var *ll* e ivar))
969 (ul-val (no-err-sub-var *ul* e ivar)))
970 (cond ((or (eq ll-val t)
971 (eq ul-val t))
972 ;; no-err-sub has returned T. An error was catched.
973 nil)
974 ((and ll-val ul-val)
975 (m- ul-val ll-val))
976 (t nil))))
977 (t nil)))))
979 (defun limit-subs (e *ll* *ul* ivar)
980 (cond ((involve-var e ivar '(%atan %gamma_incomplete %expintegral_ei))
981 ()) ; functions with discontinuities
982 (t (setq e ($multthru e))
983 (let ((a1 ($limit e ivar *ll* '$plus))
984 (a2 ($limit e ivar *ul* '$minus)))
985 (combine-ll-ans-ul-ans a1 a2)))))
987 ;; check for divergent integral
988 (defun combine-ll-ans-ul-ans (a1 a2)
989 (cond ((member a1 '($inf $minf $infinity ) :test #'eq)
990 (cond ((member a2 '($inf $minf $infinity) :test #'eq)
991 (cond ((eq a2 a1) ())
992 (t (diverg))))
993 (t (diverg))))
994 ((member a2 '($inf $minf $infinity) :test #'eq) (diverg))
995 ((or (member a1 '($und $ind) :test #'eq)
996 (member a2 '($und $ind) :test #'eq)) ())
997 (t (m- a2 a1))))
999 ;;;This function works only on things with ATAN's in them now.
1000 (defun same-sheet-subs (exp *ll* *ul* ivar &aux ll-ans ul-ans)
1001 ;; POLES-IN-INTERVAL doesn't know about the poles of tan(x). Call
1002 ;; trigsimp to convert tan into sin/cos, which POLES-IN-INTERVAL
1003 ;; knows how to handle.
1005 ;; XXX Should we fix POLES-IN-INTERVAL instead?
1007 ;; XXX Is calling trigsimp too much? Should we just only try to
1008 ;; substitute sin/cos for tan?
1010 ;; XXX Should the result try to convert sin/cos back into tan? (A
1011 ;; call to trigreduce would do it, among other things.)
1012 (let* ((exp (mfuncall '$trigsimp exp))
1013 (poles (atan-poles exp *ll* *ul* ivar)))
1014 ;;POLES -> ((mlist) ((mequal) ((%atan) foo) replacement) ......)
1015 ;;We can then use $SUBSTITUTE
1016 (setq ll-ans (limcp exp ivar *ll* '$plus))
1017 (setq exp (sratsimp ($substitute poles exp)))
1018 (setq ul-ans (limcp exp ivar *ul* '$minus))
1019 (if (and ll-ans
1020 ul-ans)
1021 (combine-ll-ans-ul-ans ll-ans ul-ans)
1022 nil)))
1024 (defun atan-poles (exp *ll* *ul* ivar)
1025 `((mlist) ,@(atan-pole1 exp *ll* *ul* ivar)))
1027 (defun atan-pole1 (exp *ll* *ul* ivar &aux ipart)
1028 (cond
1029 ((mapatom exp) ())
1030 ((matanp exp) ;neglect multiplicity and '$unknowns for now.
1031 (desetq (exp . ipart) (trisplit exp))
1032 (cond
1033 ((not (equal (sratsimp ipart) 0)) ())
1034 (t (let ((pole (poles-in-interval (let (($algebraic t))
1035 (sratsimp (cadr exp)))
1036 ivar *ll* *ul*)))
1037 (cond ((and pole (not (or (eq pole '$unknown)
1038 (eq pole '$no))))
1039 (do ((l pole (cdr l)) (llist ()))
1040 ((null l) llist)
1041 (cond
1042 ((zerop1 (m- (caar l) *ll*)) t) ; don't worry about discontinuity
1043 ((zerop1 (m- (caar l) *ul*)) t) ; at boundary of integration
1044 (t (let ((low-lim ($limit (cadr exp) ivar (caar l) '$minus))
1045 (up-lim ($limit (cadr exp) ivar (caar l) '$plus)))
1046 (cond ((and (not (eq low-lim up-lim))
1047 (real-infinityp low-lim)
1048 (real-infinityp up-lim))
1049 (let ((change (if (eq low-lim '$minf)
1050 (m- '$%pi)
1051 '$%pi)))
1052 (setq llist (cons `((mequal simp) ,exp ,(m+ exp change))
1053 llist)))))))))))))))
1054 (t (do ((l (cdr exp) (cdr l))
1055 (llist ()))
1056 ((null l) llist)
1057 (setq llist (append llist (atan-pole1 (car l) *ll* *ul* ivar)))))))
1059 (defun difapply (ivar n d s fn1)
1060 (prog (k m r $noprincipal)
1061 (cond ((eq ($asksign (m+ (deg-var d ivar) (m- s) (m- 2.))) '$neg)
1062 (return nil)))
1063 (setq $noprincipal t)
1064 (cond ((or (not (mexptp d))
1065 (not (numberp (setq r (caddr d)))))
1066 (return nil))
1067 ((and (equal n 1.)
1068 ;; There are no calls where fn1 is ever equal to
1069 ;; 'mtorat. Hence this case is never true. What is
1070 ;; this testing for?
1071 (eq fn1 'mtorat)
1072 (equal 1. (deg-var (cadr d) ivar)))
1073 (return 0.)))
1074 (setq m (deg-var (setq d (cadr d)) ivar))
1075 (setq k (m// (m+ s 2.) m))
1076 (cond ((eq (ask-integer (m// (m+ s 2.) m) '$any) '$yes)
1077 nil)
1078 (t (setq k (m+ 1 k))))
1079 (cond ((eq ($sign (m+ r (m- k))) '$pos)
1080 (return (diffhk fn1 n d k (m+ r (m- k)) ivar))))))
1082 (defun diffhk (fn1 n d r m ivar)
1083 (prog (d1 *dflag)
1084 (setq *dflag t)
1085 (setq d1 (funcall fn1 n
1086 (m^ (m+t '*z* d) r)
1087 (m* r (deg-var d ivar))))
1088 (cond (d1 (return (difap1 d1 r '*z* m 0.))))))
1090 (defun principal nil
1091 (cond ($noprincipal (diverg))
1092 ((not pcprntd)
1093 (format t "Principal Value~%")
1094 (setq pcprntd t))))
1096 ;; e is of form poly(x)*exp(m*%i*x)
1097 ;; s is degree of denominator
1098 ;; adds e to bptu or bptd according to sign of m
1099 (defun rib (e s ivar)
1100 (let (updn c)
1101 (cond ((or (mnump e) (constant e))
1102 (setq bptu (cons e bptu)))
1103 (t (setq e (rmconst1 e ivar))
1104 (setq c (car e))
1105 (setq nn* (cdr e))
1106 (setq nd* s)
1107 (multiple-value-setq (e updn)
1108 (catch 'ptimes%e (ptimes%e nn* nd* ivar)))
1109 (cond ((null e) nil)
1110 (t (setq e (m* c e))
1111 (cond (updn (setq bptu (cons e bptu)))
1112 (t (setq bptd (cons e bptd))))))))))
1114 ;; Check term is of form poly(x)*exp(m*%i*x)
1115 ;; n is degree of denominator.
1116 (defun ptimes%e (term n ivar &aux updn)
1117 (cond ((and (mexptp term)
1118 (eq (cadr term) '$%e)
1119 (polyinx (caddr term) ivar nil)
1120 (eq ($sign (m+ (deg-var ($realpart (caddr term)) ivar) -1))
1121 '$neg)
1122 (eq ($sign (m+ (deg-var (setq nn* ($imagpart (caddr term))) ivar)
1123 -2.))
1124 '$neg))
1125 ;; Set updn to T if the coefficient of IVAR in the
1126 ;; polynomial is known to be positive. Otherwise set to NIL.
1127 ;; (What does updn really mean?)
1128 (setq updn (eq ($asksign (ratdisrep (ratcoef nn* ivar))) '$pos))
1129 (values term updn))
1130 ((and (mtimesp term)
1131 (setq nn* (polfactors term ivar))
1132 (or (null (car nn*))
1133 (eq ($sign (m+ n (m- (deg-var (car nn*) ivar))))
1134 '$pos))
1135 (not (alike1 (cadr nn*) term))
1136 (multiple-value-setq (term updn)
1137 (ptimes%e (cadr nn*) n ivar))
1138 term)
1139 (values term updn))
1140 (t (throw 'ptimes%e nil))))
1142 (defun csemidown (n d ivar)
1143 (let ((pcprntd t)) ;Not sure what to do about PRINCIPAL values here.
1144 (princip
1145 (res-var ivar n d #'lowerhalf #'(lambda (x)
1146 (cond ((equal ($imagpart x) 0) t)
1147 (t ())))))))
1149 (defun lowerhalf (j)
1150 (eq ($asksign ($imagpart j)) '$neg))
1152 (defun upperhalf (j)
1153 (eq ($asksign ($imagpart j)) '$pos))
1156 (defun csemiup (n d ivar)
1157 (let ((pcprntd t)) ;I'm not sure what to do about PRINCIPAL values here.
1158 (princip
1159 (res-var ivar n d #'upperhalf #'(lambda (x)
1160 (cond ((equal ($imagpart x) 0) t)
1161 (t ())))))))
1163 (defun princip (n)
1164 (cond ((null n) nil)
1165 (t (m*t '$%i ($rectform (m+ (cond ((car n)
1166 (m*t 2. (car n)))
1167 (t 0.))
1168 (cond ((cadr n)
1169 (principal)
1170 (cadr n))
1171 (t 0.))))))))
1173 ;; exponentialize sin and cos
1174 (defun sconvert (e ivar)
1175 (cond ((atom e) e)
1176 ((polyinx e ivar nil) e)
1177 ((eq (caar e) '%sin)
1178 (m* '((rat) -1 2)
1179 '$%i
1180 (m+t (m^t '$%e (m*t '$%i (cadr e)))
1181 (m- (m^t '$%e (m*t (m- '$%i) (cadr e)))))))
1182 ((eq (caar e) '%cos)
1183 (mul* '((rat) 1. 2.)
1184 (m+t (m^t '$%e (m*t '$%i (cadr e)))
1185 (m^t '$%e (m*t (m- '$%i) (cadr e))))))
1186 (t (simplify
1187 (cons (list (caar e)) (mapcar #'(lambda (ee)
1188 (sconvert ee ivar))
1189 (cdr e)))))))
1191 (defun polfactors (exp ivar)
1192 (let (poly rest)
1193 (cond ((mplusp exp) nil)
1194 (t (cond ((mtimesp exp)
1195 (setq exp (reverse (cdr exp))))
1196 (t (setq exp (list exp))))
1197 (mapc #'(lambda (term)
1198 (cond ((polyinx term ivar nil)
1199 (push term poly))
1200 (t (push term rest))))
1201 exp)
1202 (list (m*l poly) (m*l rest))))))
1204 (defun esap (e)
1205 (prog (d)
1206 (cond ((atom e) (return e))
1207 ((not (among '$%e e)) (return e))
1208 ((and (mexptp e)
1209 (eq (cadr e) '$%e))
1210 (setq d ($imagpart (caddr e)))
1211 (return (m* (m^t '$%e ($realpart (caddr e)))
1212 (m+ `((%cos) ,d)
1213 (m*t '$%i `((%sin) ,d))))))
1214 (t (return (simplify (cons (list (caar e))
1215 (mapcar #'esap (cdr e)))))))))
1217 ;; computes integral from minf to inf for expressions of the form
1218 ;; exp(%i*m*x)*r(x) by residues on either the upper half
1219 ;; plane or the lower half plane, depending on whether
1220 ;; m is positive or negative. [wang p. 77]
1222 ;; exponentializes sin and cos before applying residue method.
1223 ;; can handle some expressions with poles on real line, such as
1224 ;; sin(x)*cos(x)/x.
1225 (defun mtosc (grand ivar)
1226 (numden-var grand ivar)
1227 (let ((n nn*)
1228 (d dn*)
1229 ratterms ratans
1230 plf bptu bptd s upans downans)
1231 (cond ((not (or (polyinx d ivar nil)
1232 (and (setq grand (%einvolve-var d ivar))
1233 (among '$%i grand)
1234 (polyinx (setq d (sratsimp (m// d (m^t '$%e grand))))
1235 ivar
1236 nil)
1237 (setq n (m// n (m^t '$%e grand)))))) nil)
1238 ((equal (setq s (deg-var d ivar)) 0) nil)
1239 ;;;Above tests for applicability of this method.
1240 ((and (or (setq plf (polfactors n ivar)) t)
1241 (setq n ($expand (cond ((car plf)
1242 (m*t 'x* (sconvert (cadr plf) ivar)))
1243 (t (sconvert n ivar)))))
1244 (cond ((mplusp n) (setq n (cdr n)))
1245 (t (setq n (list n))))
1246 (dolist (term n t)
1247 (cond ((polyinx term ivar nil)
1248 ;; call to $expand can create rational terms
1249 ;; with no exp(m*%i*x)
1250 (setq ratterms (cons term ratterms)))
1251 ((rib term s ivar))
1252 (t (return nil))))
1253 ;;;Function RIB sets up the values of BPTU and BPTD
1254 (cond ((car plf)
1255 (setq bptu (subst (car plf) 'x* bptu))
1256 (setq bptd (subst (car plf) 'x* bptd))
1257 (setq ratterms (subst (car plf) 'x* ratterms))
1258 t) ;CROCK, CROCK. This is TERRIBLE code.
1259 (t t))
1260 ;;;If there is BPTU then CSEMIUP must succeed.
1261 ;;;Likewise for BPTD.
1262 (setq ratans
1263 (if ratterms
1264 (let (($intanalysis nil))
1265 ;; The original integrand was already
1266 ;; determined to have no poles by initial-analysis.
1267 ;; If individual terms of the expansion have poles, the poles
1268 ;; must cancel each other out, so we can ignore them.
1269 (try-defint (m// (m+l ratterms) d) ivar '$minf '$inf))
1271 ;; if integral of ratterms is divergent, ratans is nil,
1272 ;; and mtosc returns nil
1274 (cond (bptu (setq upans (csemiup (m+l bptu) d ivar)))
1275 (t (setq upans 0)))
1276 (cond (bptd (setq downans (csemidown (m+l bptd) d ivar)))
1277 (t (setq downans 0))))
1279 (sratsimp (m+ ratans
1280 (m* '$%pi (m+ upans (m- downans)))))))))
1283 (defun evenfn (e ivar)
1284 (let ((temp (m+ (m- e)
1285 (cond ((atom ivar)
1286 ($substitute (m- ivar) ivar e))
1287 (t ($ratsubst (m- ivar) ivar e))))))
1288 (cond ((zerop1 temp)
1290 ((zerop1 (sratsimp temp))
1292 (t nil))))
1294 (defun oddfn (e ivar)
1295 (let ((temp (m+ e (cond ((atom ivar)
1296 ($substitute (m- ivar) ivar e))
1297 (t ($ratsubst (m- ivar) ivar e))))))
1298 (cond ((zerop1 temp)
1300 ((zerop1 (sratsimp temp))
1302 (t nil))))
1304 (defun ztoinf (grand ivar)
1305 (prog (n d sn sd varlist
1306 s nc dc
1307 ans r $savefactors *checkfactors* temp test-var)
1308 (setq $savefactors t sn (setq sd (list 1.)))
1309 (cond ((eq ($sign (m+ *loopstop* -1))
1310 '$pos)
1311 (return nil))
1312 ((setq temp (or (scaxn grand ivar)
1313 (ssp grand ivar)))
1314 (return temp))
1315 ((involve-var grand ivar '(%sin %cos %tan))
1316 (setq grand (sconvert grand ivar))
1317 (go on)))
1319 (cond ((polyinx grand ivar nil)
1320 (diverg))
1321 ((and (ratp grand ivar)
1322 (mtimesp grand)
1323 (andmapcar #'(lambda (e)
1324 (multiple-value-bind (result new-sn new-sd)
1325 (snumden-var e ivar sn sd)
1326 (when result
1327 (setf sn new-sn
1328 sd new-sd))
1329 result))
1330 (cdr grand)))
1331 (setq nn* (m*l sn)
1332 sn nil)
1333 (setq dn* (m*l sd)
1334 sd nil))
1335 (t (numden-var grand ivar)))
1337 ;;;New section.
1338 (setq n (rmconst1 nn* ivar))
1339 (setq d (rmconst1 dn* ivar))
1340 (setq nc (car n))
1341 (setq n (cdr n))
1342 (setq dc (car d))
1343 (setq d (cdr d))
1344 (cond ((polyinx d ivar nil)
1345 (setq s (deg-var d ivar)))
1346 (t (go findout)))
1347 (cond ((and (setq r (findp n ivar))
1348 (eq (ask-integer r '$integer) '$yes)
1349 (setq test-var (bxm d s ivar))
1350 (setq ans (apply 'fan (cons (m+ 1. r) test-var))))
1351 (return (m* (m// nc dc) (sratsimp ans))))
1352 ((and (ratp grand ivar)
1353 (setq ans (zmtorat n (cond ((mtimesp d) d)
1354 (t ($sqfr d)))
1356 #'(lambda (n d s)
1357 (ztorat n d s ivar))
1358 ivar)))
1359 (return (m* (m// nc dc) ans)))
1360 ((and (evenfn d ivar)
1361 (setq nn* (p*lognxp n s ivar)))
1362 (setq ans (log*rat (car nn*) d (cadr nn*) ivar))
1363 (return (m* (m// nc dc) ans)))
1364 ((involve-var grand ivar '(%log))
1365 (cond ((setq ans (logquad0 grand ivar))
1366 (return (m* (m// nc dc) ans)))
1367 (t (return nil)))))
1368 findout
1369 (cond ((setq temp (batapp grand ivar))
1370 (return temp))
1371 (t nil))
1373 (cond ((let ((*mtoinf* nil))
1374 (setq temp (ggr grand t ivar)))
1375 (return temp))
1376 ((mplusp grand)
1377 (cond ((let ((*nodiverg t))
1378 (setq ans (catch 'divergent
1379 (andmapcar #'(lambda (g)
1380 (ztoinf g ivar))
1381 (cdr grand)))))
1382 (cond ((eq ans 'divergent) nil)
1383 (t (return (sratsimp (m+l ans)))))))))
1385 (cond ((and (evenfn grand ivar)
1386 (setq *loopstop* (m+ 1 *loopstop*))
1387 (setq ans (method-by-limits grand ivar '$minf '$inf)))
1388 (return (m*t '((rat) 1. 2.) ans)))
1389 (t (return nil)))))
1391 (defun ztorat (n d s ivar)
1392 (cond ((and (null *dflag)
1393 (setq s (difapply ivar n d s #'(lambda (n d s)
1394 (ztorat n d s ivar)))))
1396 ((setq n (let ((plogabs ()))
1397 (keyhole (let ((var ivar))
1398 (declare (special var))
1399 ;; It's very important here to bind VAR
1400 ;; because the PLOG simplifier checks
1401 ;; for VAR. Without this, the
1402 ;; simplifier converts plog(-x) to
1403 ;; log(x)+%i*%pi, which messes up the
1404 ;; keyhole routine.
1405 (m* `((%plog) ,(m- ivar)) n))
1407 ivar)))
1408 (m- n))
1410 ;; Let's not signal an error here. Return nil so that we
1411 ;; eventually return a noun form if no other algorithm gives
1412 ;; a result.
1413 #+(or)
1414 (merror (intl:gettext "defint: keyhole integration failed.~%"))
1415 nil)))
1417 (setq *dflag nil)
1419 (defun logquad0 (exp ivar)
1420 (let ((a ()) (b ()) (c ()))
1421 (cond ((setq exp (logquad exp ivar))
1422 (setq a (car exp) b (cadr exp) c (caddr exp))
1423 ($asksign b) ;let the data base know about the sign of B.
1424 (cond ((eq ($asksign c) '$pos)
1425 (setq c (m^ (m// c a) '((rat) 1. 2.)))
1426 (setq b (simplify
1427 `((%acos) ,(add* 'epsilon (m// b (mul* 2. a c))))))
1428 (setq a (m// (m* b `((%log) ,c))
1429 (mul* a (simplify `((%sin) ,b)) c)))
1430 (get-limit a 'epsilon 0 '$plus))))
1431 (t ()))))
1433 (defun logquad (exp ivar)
1434 (let ((varlist (list ivar)))
1435 (newvar exp)
1436 (setq exp (cdr (ratrep* exp)))
1437 (cond ((and (alike1 (pdis (car exp))
1438 `((%log) ,ivar))
1439 (not (atom (cdr exp)))
1440 (equal (cadr (cdr exp)) 2.)
1441 (not (equal (ptterm (cddr exp) 0.) 0.)))
1442 (setq exp (mapcar 'pdis (cdr (oddelm (cdr exp)))))))))
1444 (defun mtoinf (grand ivar)
1445 (prog (ans ans1 sd sn pp pe n d s nc dc $savefactors *checkfactors* temp)
1446 (setq $savefactors t)
1447 (setq sn (setq sd (list 1.)))
1448 (cond ((eq ($sign (m+ *loopstop* -1)) '$pos)
1449 (return nil))
1450 ((involve-var grand ivar '(%sin %cos))
1451 (cond ((and (evenfn grand ivar)
1452 (or (setq temp (scaxn grand ivar))
1453 (setq temp (ssp grand ivar))))
1454 (return (m*t 2. temp)))
1455 ((setq temp (mtosc grand ivar))
1456 (return temp))
1457 (t (go en))))
1458 ((among '$%i (%einvolve-var grand ivar))
1459 (cond ((setq temp (mtosc grand ivar))
1460 (return temp))
1461 (t (go en)))))
1462 (setq grand ($exponentialize grand)) ; exponentializing before numden
1463 (cond ((polyinx grand ivar nil) ; avoids losing multiplicities [ 1309432 ]
1464 (diverg))
1465 ((and (ratp grand ivar)
1466 (mtimesp grand)
1467 (andmapcar #'(lambda (e)
1468 (multiple-value-bind (result new-sn new-sd)
1469 (snumden-var e ivar sn sd)
1470 (when result
1471 (setf sn new-sn
1472 sd new-sd))
1473 result))
1474 (cdr grand)))
1475 (setq nn* (m*l sn) sn nil)
1476 (setq dn* (m*l sd) sd nil))
1477 (t (numden-var grand ivar)))
1478 (setq n (rmconst1 nn* ivar))
1479 (setq d (rmconst1 dn* ivar))
1480 (setq nc (car n))
1481 (setq n (cdr n))
1482 (setq dc (car d))
1483 (setq d (cdr d))
1484 (cond ((polyinx d ivar nil)
1485 (setq s (deg-var d ivar))))
1486 (cond ((and (not (%einvolve-var grand ivar))
1487 (notinvolve-var exp ivar '(%sinh %cosh %tanh))
1488 (setq pp (findp n ivar))
1489 (eq (ask-integer pp '$integer) '$yes)
1490 (setq pe (bxm d s ivar)))
1491 (cond ((and (eq (ask-integer (caddr pe) '$even) '$yes)
1492 (eq (ask-integer pp '$even) '$yes))
1493 (cond ((setq ans (apply 'fan (cons (m+ 1. pp) pe)))
1494 (setq ans (m*t 2. ans))
1495 (return (m* (m// nc dc) ans)))))
1496 ((equal (car pe) 1.)
1497 (cond ((and (setq ans (apply 'fan (cons (m+ 1. pp) pe)))
1498 (setq nn* (fan (m+ 1. pp)
1499 (car pe)
1500 (m* -1 (cadr pe))
1501 (caddr pe)
1502 (cadddr pe))))
1503 (setq ans (m+ ans (m*t (m^ -1 pp) nn*)))
1504 (return (m* (m// nc dc) ans))))))))
1506 (labels
1507 ((pppin%ex (nd* ivar)
1508 ;; Test to see if exp is of the form p(x)*f(exp(x)). If so, set pp to
1509 ;; be p(x) and set pe to f(exp(x)).
1510 (setq nd* ($factor nd*))
1511 (cond ((polyinx nd* ivar nil)
1512 (setq pp (cons nd* pp)) t)
1513 ((catch 'pin%ex (pin%ex nd* ivar))
1514 (setq pe (cons nd* pe)) t)
1515 ((mtimesp nd*)
1516 (andmapcar #'(lambda (ex)
1517 (pppin%ex ex ivar))
1518 (cdr nd*))))))
1519 (cond ((and (ratp grand ivar)
1520 (setq ans1 (zmtorat n
1521 (cond ((mtimesp d) d) (t ($sqfr d)))
1523 #'(lambda (n d s)
1524 (mtorat n d s ivar))
1525 ivar)))
1526 (setq ans (m*t '$%pi ans1))
1527 (return (m* (m// nc dc) ans)))
1528 ((and (or (%einvolve-var grand ivar)
1529 (involve-var grand ivar '(%sinh %cosh %tanh)))
1530 (pppin%ex n ivar) ;setq's P* and PE*...Barf again.
1531 (setq ans (catch 'pin%ex (pin%ex d ivar))))
1532 ;; We have an integral of the form p(x)*F(exp(x)), where
1533 ;; p(x) is a polynomial.
1534 (cond ((null pp)
1535 ;; No polynomial
1536 (return (dintexp grand ivar)))
1537 ((not (and (zerop1 (get-limit grand ivar '$inf))
1538 (zerop1 (get-limit grand ivar '$minf))))
1539 ;; These limits must exist for the integral to converge.
1540 (diverg))
1541 ((setq ans (rectzto%pi2 (m*l pp) (m*l pe) d ivar))
1542 ;; This only handles the case when the F(z) is a
1543 ;; rational function.
1544 (return (m* (m// nc dc) ans)))
1545 ((setq ans (log-transform (m*l pp) (m*l pe) d ivar))
1546 ;; If we get here, F(z) is not a rational function.
1547 ;; We transform it using the substitution x=log(y)
1548 ;; which gives us an integral of the form
1549 ;; p(log(y))*F(y)/y, which maxima should be able to
1550 ;; handle.
1551 (return (m* (m// nc dc) ans)))
1553 ;; Give up. We don't know how to handle this.
1554 (return nil))))))
1556 (cond ((setq ans (ggrm grand ivar))
1557 (return ans))
1558 ((and (evenfn grand ivar)
1559 (setq *loopstop* (m+ 1 *loopstop*))
1560 (setq ans (method-by-limits grand ivar 0 '$inf)))
1561 (return (m*t 2. ans)))
1562 (t (return nil)))))
1564 (defun linpower0 (exp ivar)
1565 (cond ((and (setq exp (linpower exp ivar))
1566 (eq (ask-integer (caddr exp) '$even)
1567 '$yes)
1568 (ratgreaterp 0. (car exp)))
1569 exp)))
1571 ;;; given (b*x+a)^n+c returns (a b n c)
1572 (defun linpower (exp ivar)
1573 (let (linpart deg lc c varlist)
1574 (cond ((not (polyp-var exp ivar)) nil)
1575 (t (let ((varlist (list ivar)))
1576 (newvar exp)
1577 (setq linpart (cadr (ratrep* exp)))
1578 (cond ((atom linpart)
1579 nil)
1580 (t (setq deg (cadr linpart))
1581 ;;;get high degree of poly
1582 (setq linpart ($diff exp ivar (m+ deg -1)))
1583 ;;;diff down to linear.
1584 (setq lc (sdiff linpart ivar))
1585 ;;;all the way to constant.
1586 (setq linpart (sratsimp (m// linpart lc)))
1587 (setq lc (sratsimp (m// lc `((mfactorial) ,deg))))
1588 ;;;get rid of factorial from differentiation.
1589 (setq c (sratsimp (m+ exp (m* (m- lc)
1590 (m^ linpart deg)))))))
1591 ;;;Sees if can be expressed as (a*x+b)^n + part freeof x.
1592 (cond ((not (among ivar c))
1593 `(,lc ,linpart ,deg ,c))
1594 (t nil)))))))
1596 (defun mtorat (n d s ivar)
1597 (let ((*semirat* t))
1598 (cond ((and (null *dflag)
1599 (setq s (difapply ivar n d s #'(lambda (n d s)
1600 (mtorat n d s ivar)))))
1602 (t (csemiup n d ivar)))))
1604 (defun zmtorat (n d s fn1 ivar)
1605 (prog (c)
1606 (cond ((eq ($sign (m+ s (m+ 1 (setq nn* (deg-var n ivar)))))
1607 '$neg)
1608 (diverg))
1609 ((eq ($sign (m+ s -4))
1610 '$neg)
1611 (go on)))
1612 (setq d ($factor d))
1613 (setq c (rmconst1 d ivar))
1614 (setq d (cdr c))
1615 (setq c (car c))
1616 (cond
1617 ((mtimesp d)
1618 (setq d (cdr d))
1619 (setq n (partnum n d ivar))
1620 (let ((rsn* t))
1621 (setq n ($xthru (m+l
1622 (mapcar #'(lambda (a b)
1623 (let ((foo (funcall fn1 (car a) b (deg-var b ivar))))
1624 (if foo (m// foo (cadr a))
1625 (return-from zmtorat nil))))
1627 d)))))
1628 (return (cond (c (m// n c))
1629 (t n)))))
1632 (setq n (funcall fn1 n d s))
1633 (return (when n (sratsimp (cond (c (m// n c))
1634 (t n)))))))
1636 (defun pfrnum (f g n n2 ivar)
1637 (let ((varlist (list ivar)) genvar)
1638 (setq f (polyform f)
1639 g (polyform g)
1640 n (polyform n)
1641 n2 (polyform n2))
1642 (setq ivar (caadr (ratrep* ivar)))
1643 (setq f (resprog0-var ivar f g n n2))
1644 (list (list (pdis (cadr f)) (pdis (cddr f)))
1645 (list (pdis (caar f)) (pdis (cdar f))))))
1647 (defun polyform (e)
1648 (prog (f d)
1649 (newvar e)
1650 (setq f (ratrep* e))
1651 (and (equal (cddr f) 1)
1652 (return (cadr f)))
1653 (and (equal (length (setq d (cddr f))) 3)
1654 (not (among (car d)
1655 (cadr f)))
1656 (return (list (car d)
1657 (- (cadr d))
1658 (ptimes (cadr f) (caddr d)))))
1659 (merror "defint: bug from PFRNUM in RESIDU.")))
1661 (defun partnum (n dl ivar)
1662 (let ((n2 1) ans nl)
1663 (do ((dl dl (cdr dl)))
1664 ((null (cdr dl))
1665 (nconc ans (ncons (list n n2))))
1666 (setq nl (pfrnum (car dl) (m*l (cdr dl)) n n2 ivar))
1667 (setq ans (nconc ans (ncons (car nl))))
1668 (setq n2 (cadadr nl) n (caadr nl) nl nil))))
1670 (defun ggrm (e ivar)
1671 (prog (poly expo *mtoinf* mb varlist genvar l c gvar)
1672 (setq varlist (list ivar))
1673 (setq *mtoinf* t)
1674 (cond ((and (setq expo (%einvolve-var e ivar))
1675 (polyp-var (setq poly (sratsimp (m// e (m^t '$%e expo)))) ivar)
1676 (setq l (catch 'ggrm (ggr (m^t '$%e expo) nil ivar))))
1677 (setq *mtoinf* nil)
1678 (setq mb (m- (subin-var 0. (cadr l) ivar)))
1679 (setq poly (m+ (subin-var (m+t mb ivar) poly ivar)
1680 (subin-var (m+t mb (m*t -1 ivar)) poly ivar))))
1681 (t (return nil)))
1682 (setq expo (caddr l)
1683 c (cadddr l)
1684 l (m* -1 (car l))
1685 e nil)
1686 (newvar poly)
1687 (setq poly (cdr (ratrep* poly)))
1688 (setq mb (m^ (pdis (cdr poly)) -1)
1689 poly (car poly))
1690 (setq gvar (caadr (ratrep* ivar)))
1691 (cond ((or (atom poly)
1692 (pointergp gvar (car poly)))
1693 (setq poly (list 0. poly)))
1694 (t (setq poly (cdr poly))))
1695 (return (do ((poly poly (cddr poly)))
1696 ((null poly)
1697 (mul* (m^t '$%e c) (m^t expo -1) mb (m+l e)))
1698 (setq e (cons (ggrm1 (car poly) (pdis (cadr poly)) l expo)
1699 e))))))
1701 (defun ggrm1 (d k a b)
1702 (setq b (m// (m+t 1. d) b))
1703 (m* k `((%gamma) ,b) (m^ a (m- b))))
1705 ;; Compute the integral(n/d,x,0,inf) by computing the negative of the
1706 ;; sum of residues of log(-x)*n/d over the poles of n/d inside the
1707 ;; keyhole contour. This contour is basically an disk with a slit
1708 ;; along the positive real axis. n/d must be a rational function.
1709 (defun keyhole (n d ivar)
1710 (let* ((*semirat* ())
1711 (res (res-var ivar n d
1712 #'(lambda (j)
1713 ;; Ok if not on the positive real axis.
1714 (or (not (equal ($imagpart j) 0))
1715 (eq ($asksign j) '$neg)))
1716 #'(lambda (j)
1717 (cond ((eq ($asksign j) '$pos)
1719 (t (diverg)))))))
1720 (when res
1721 (let ((rsn* t))
1722 ($rectform ($multthru (m+ (cond ((car res)
1723 (car res))
1724 (t 0.))
1725 (cond ((cadr res)
1726 (cadr res))
1727 (t 0.)))))))))
1729 ;; Look at an expression e of the form sin(r*x)^k, where k is an
1730 ;; integer. Return the list (1 r k). (Not sure if the first element
1731 ;; of the list is always 1 because I'm not sure what partition is
1732 ;; trying to do here.)
1733 (defun skr (e ivar)
1734 (prog (m r k)
1735 (cond ((atom e) (return nil)))
1736 (setq e (partition e ivar 1))
1737 (setq m (car e))
1738 (setq e (cdr e))
1739 (cond ((setq r (sinrx e ivar))
1740 (return (list m r 1)))
1741 ((and (mexptp e)
1742 (eq (ask-integer (setq k (caddr e)) '$integer) '$yes)
1743 (setq r (sinrx (cadr e) ivar)))
1744 (return (list m r k))))))
1746 ;; Look at an expression e of the form sin(r*x) and return r.
1747 (defun sinrx (e ivar)
1748 (cond ((and (consp e) (eq (caar e) '%sin))
1749 (cond ((eq (cadr e) ivar)
1751 ((and (setq e (partition (cadr e) ivar 1))
1752 (eq (cdr e) ivar))
1753 (car e))))))
1757 ;; integrate(a*sc(r*x)^k/x^n,x,0,inf).
1758 (defun ssp (exp ivar)
1759 (prog (u n c arg)
1760 ;; Get the argument of the involved trig function.
1761 (when (null (setq arg (involve-var exp ivar '(%sin %cos))))
1762 (return nil))
1763 ;; I don't think this needs to be special.
1764 #+nil
1765 (declare (special n))
1766 ;; Replace (1-cos(arg)^2) with sin(arg)^2.
1767 (setq exp ($substitute ;(m^t `((%sin) ,ivar) 2.)
1768 ;(m+t 1. (m- (m^t `((%cos) ,ivar) 2.)))
1769 ;; The code from above generates expressions with
1770 ;; a missing simp flag. Furthermore, the
1771 ;; substitution has to be done for the complete
1772 ;; argument of the trig function. (DK 02/2010)
1773 `((mexpt simp) ((%sin simp) ,arg) 2)
1774 `((mplus) 1 ((mtimes) -1 ((mexpt) ((%cos) ,arg) 2)))
1775 exp))
1776 (numden-var exp ivar)
1777 (setq u nn*)
1778 (cond ((and (setq n (findp dn* ivar))
1779 (eq (ask-integer n '$integer) '$yes))
1780 ;; n is the power of the denominator.
1781 (cond ((setq c (skr u ivar))
1782 ;; The simple case.
1783 (return (scmp c n ivar)))
1784 ((and (mplusp u)
1785 (setq c (andmapcar #'(lambda (uu)
1786 (skr uu ivar))
1787 (cdr u))))
1788 ;; Do this for a sum of such terms.
1789 (return (m+l (mapcar #'(lambda (j) (scmp j n ivar))
1790 c)))))))))
1792 ;; We have an integral of the form sin(r*x)^k/x^n. C is the list (1 r k).
1794 ;; The substitution y=r*x converts this integral to
1796 ;; r^(n-1)*integral(sin(y)^k/y^n,y,0,inf)
1798 ;; (If r is negative, we need to negate the result.)
1800 ;; The recursion Wang gives on p. 87 has a typo. The second term
1801 ;; should be subtracted from the first. This formula is given in G&R,
1802 ;; 3.82, formula 12.
1804 ;; integrate(sin(x)^r/x^s,x) =
1805 ;; r*(r-1)/(s-1)/(s-2)*integrate(sin(x)^(r-2)/x^(s-2),x)
1806 ;; - r^2/(s-1)/(s-2)*integrate(sin(x)^r/x^(s-2),x)
1808 ;; (Limits are assumed to be 0 to inf.)
1810 ;; This recursion ends up with integrals with s = 1 or 2 and
1812 ;; integrate(sin(x)^p/x,x,0,inf) = integrate(sin(x)^(p-1),x,0,%pi/2)
1814 ;; with p > 0 and odd. This latter integral is known to maxima, and
1815 ;; it's value is beta(p/2,1/2)/2.
1817 ;; integrate(sin(x)^2/x^2,x,0,inf) = %pi/2*binomial(q-3/2,q-1)
1819 ;; where q >= 2.
1821 (defun scmp (c n ivar)
1822 ;; Compute sign(r)*r^(n-1)*integrate(sin(y)^k/y^n,y,0,inf)
1823 (destructuring-bind (mult r k)
1825 (let ((recursion (sinsp k n)))
1826 (if recursion
1827 (m* mult
1828 (m^ r (m+ n -1))
1829 `((%signum) ,r)
1830 recursion)
1831 ;; Recursion failed. Return the integrand
1832 ;; The following code generates expressions with a missing simp flag
1833 ;; for the sin function. Use better simplifying code. (DK 02/2010)
1834 ; (let ((integrand (div (pow `((%sin) ,(m* r ivar))
1835 ; k)
1836 ; (pow ivar n))))
1837 (let ((integrand (div (power (take '(%sin) (mul r ivar))
1839 (power ivar n))))
1840 (m* mult
1841 `((%integrate) ,integrand ,ivar ,*ll* ,*ul*)))))))
1843 ;; integrate(sin(x)^n/x^2,x,0,inf) = pi/2*binomial(n-3/2,n-1).
1844 ;; Express in terms of Gamma functions, though.
1845 (defun sevn (n)
1846 (m* half%pi ($makegamma `((%binomial) ,(m+t (m+ n -1) '((rat) -1 2))
1847 ,(m+ n -1)))))
1850 ;; integrate(sin(x)^n/x,x,0,inf) = beta((n+1)/2,1/2)/2, for n odd and
1851 ;; n > 0.
1852 (defun sforx (n)
1853 (cond ((equal n 1.)
1854 half%pi)
1855 (t (bygamma (m+ n -1) 0.))))
1857 ;; This implements the recursion for computing
1858 ;; integrate(sin(y)^l/y^k,y,0,inf). (Note the change in notation from
1859 ;; the above!)
1860 (defun sinsp (l k)
1861 (let ((i ())
1862 (j ()))
1863 (cond ((eq ($sign (m+ l (m- (m+ k -1))))
1864 '$neg)
1865 ;; Integral diverges if l-(k-1) < 0.
1866 (diverg))
1867 ((not (even1 (m+ l k)))
1868 ;; If l + k is not even, return NIL. (Is this the right
1869 ;; thing to do?)
1870 nil)
1871 ((equal k 2.)
1872 ;; We have integrate(sin(y)^l/y^2). Use sevn to evaluate.
1873 (sevn (m// l 2.)))
1874 ((equal k 1.)
1875 ;; We have integrate(sin(y)^l/y,y)
1876 (sforx l))
1877 ((eq ($sign (m+ k -2.))
1878 '$pos)
1879 (setq i (m* (m+ k -1)
1880 (setq j (m+ k -2.))))
1881 ;; j = k-2, i = (k-1)*(k-2)
1884 ;; The main recursion:
1886 ;; i(sin(y)^l/y^k)
1887 ;; = l*(l-1)/(k-1)/(k-2)*i(sin(y)^(l-2)/y^k)
1888 ;; - l^2/(k-1)/(k-1)*i(sin(y)^l/y^(k-2))
1889 (m+ (m* l (m+ l -1)
1890 (m^t i -1)
1891 (sinsp (m+ l -2.) j))
1892 (m* (m- (m^ l 2))
1893 (m^t i -1)
1894 (sinsp l j)))))))
1896 ;; Returns the fractional part of a?
1897 (defun fpart (a)
1898 (cond ((null a) 0.)
1899 ((numberp a)
1900 ;; Why do we return 0 if a is a number? Perhaps we really
1901 ;; mean integer?
1903 ((mnump a)
1904 ;; If we're here, this basically assumes a is a rational.
1905 ;; Compute the remainder and return the result.
1906 (list (car a) (rem (cadr a) (caddr a)) (caddr a)))
1907 ((and (atom a) (abless1 a)) a)
1908 ((and (mplusp a)
1909 (null (cdddr a))
1910 (abless1 (caddr a)))
1911 (caddr a))))
1913 ;; Doesn't appear to be used anywhere in Maxima. Not sure what this
1914 ;; was intended to do.
1915 #+nil
1916 (defun thrad (e)
1917 (cond ((polyinx e var nil) 0.)
1918 ((and (mexptp e)
1919 (eq (cadr e) var)
1920 (mnump (caddr e)))
1921 (fpart (caddr e)))
1922 ((mtimesp e)
1923 (m+l (mapcar #'thrad e)))))
1926 ;;; THE FOLLOWING FUNCTION IS FOR TRIG FUNCTIONS OF THE FOLLOWING TYPE:
1927 ;;; LOWER LIMIT=0 B A MULTIPLE OF %PI SCA FUNCTION OF SIN (X) COS (X)
1928 ;;; B<=%PI2
1930 (defun period (p e ivar)
1931 (and (alike1 (no-err-sub-var ivar e ivar)
1932 (setq e (no-err-sub-var (m+ p ivar) e ivar)))
1933 ;; means there was no error
1934 (not (eq e t))))
1936 ; returns cons of (integer_part . fractional_part) of a
1937 (defun infr (a)
1938 ;; I think we really want to compute how many full periods are in a
1939 ;; and the remainder.
1940 (let* ((q (igprt (div a (mul 2 '$%pi))))
1941 (r (add a (mul -1 (mul q 2 '$%pi)))))
1942 (cons q r)))
1944 ; returns cons of (integer_part . fractional_part) of a
1945 (defun lower-infr (a)
1946 ;; I think we really want to compute how many full periods are in a
1947 ;; and the remainder.
1948 (let* (;(q (igprt (div a (mul 2 '$%pi))))
1949 (q (mfuncall '$ceiling (div a (mul 2 '$%pi))))
1950 (r (add a (mul -1 (mul q 2 '$%pi)))))
1951 (cons q r)))
1954 ;; Return the integer part of r.
1955 (defun igprt (r)
1956 ;; r - fpart(r)
1957 (mfuncall '$floor r))
1960 ;;;Try making exp(%i*ivar) --> yy, if result is rational then do integral
1961 ;;;around unit circle. Make corrections for limits of integration if possible.
1962 (defun scrat (sc b ivar)
1963 (let* ((exp-form (sconvert sc ivar)) ;Exponentialize
1964 (rat-form (maxima-substitute 'yy (m^t '$%e (m*t '$%i ivar))
1965 exp-form))) ;Try to make Rational fun.
1966 (cond ((and (ratp rat-form 'yy)
1967 (not (among ivar rat-form)))
1968 (cond ((alike1 b %pi2)
1969 (let ((ans (zto%pi2 rat-form 'yy)))
1970 (cond (ans ans)
1971 (t nil))))
1972 ((and (eq b '$%pi)
1973 (evenfn exp-form ivar))
1974 (let ((ans (zto%pi2 rat-form 'yy)))
1975 (cond (ans (m*t '((rat) 1. 2.) ans))
1976 (t nil))))
1977 ((and (alike1 b half%pi)
1978 (evenfn exp-form ivar)
1979 (alike1 rat-form
1980 (no-err-sub-var (m+t '$%pi (m*t -1 ivar))
1981 rat-form
1982 ivar)))
1983 (let ((ans (zto%pi2 rat-form 'yy)))
1984 (cond (ans (m*t '((rat) 1. 4.) ans))
1985 (t nil)))))))))
1987 ;;; Do integrals of sin and cos. this routine makes sure lower limit
1988 ;;; is zero.
1989 (defun intsc1 (a b e ivar)
1990 ;; integrate(e,var,a,b)
1991 (let ((trigarg (find-first-trigarg e))
1992 ($%emode t)
1993 ($trigsign t)
1994 (*sin-cos-recur* t)) ;recursion stopper
1995 (prog (ans d nzp2 l int-zero-to-d int-nzp2 int-zero-to-c limit-diff)
1996 (let* ((arg (simple-trig-arg trigarg ivar)) ;; pattern match sin(cc*x + bb)
1997 (cc (cdras 'c arg))
1998 (bb (cdras 'b arg))
1999 (new-var (gensym "NEW-VAR-")))
2000 (putprop new-var t 'internal)
2001 (when (or (not arg)
2002 (not (every-trigarg-alike e trigarg)))
2003 (return nil))
2004 (when (not (and (equal cc 1) (equal bb 0)))
2005 (setq e (div (maxima-substitute (div (sub new-var bb) cc)
2006 ivar e)
2007 cc))
2008 (setq ivar new-var) ;; change of variables to get sin(new-var)
2009 (setq a (add bb (mul a cc)))
2010 (setq b (add bb (mul b cc)))))
2011 (setq limit-diff (m+ b (m* -1 a)))
2012 (when (or (not (period %pi2 e ivar))
2013 (member a *infinities*)
2014 (member b *infinities*)
2015 (not (and ($constantp a)
2016 ($constantp b))))
2017 ;; Exit if b or a is not a constant or if the integrand
2018 ;; doesn't appear to have a period of 2 pi.
2019 (return nil))
2021 ;; Multiples of 2*%pi in limits.
2022 (cond ((integerp (setq d (let (($float nil))
2023 (m// limit-diff %pi2))))
2024 (cond ((setq ans (intsc e %pi2 ivar))
2025 (return (m* d ans)))
2026 (t (return nil)))))
2028 ;; The integral is not over a full period (2*%pi) or multiple
2029 ;; of a full period.
2031 ;; Wang p. 111: The integral integrate(f(x),x,a,b) can be
2032 ;; written as:
2034 ;; n * integrate(f,x,0,2*%pi) + integrate(f,x,0,c)
2035 ;; - integrate(f,x,0,d)
2037 ;; for some integer n and d >= 0, c < 2*%pi because there exist
2038 ;; integers p and q such that a = 2 * p *%pi + d and b = 2 * q
2039 ;; * %pi + c. Then n = q - p.
2041 ;; Compute q and c for the upper limit b.
2042 (setq b (infr b))
2043 (setq l a)
2044 (cond ((null l)
2045 (setq nzp2 (car b))
2046 (setq int-zero-to-d 0.)
2047 (go out)))
2048 ;; Compute p and d for the lower limit a.
2049 (setq l (infr l))
2050 ;; avoid an extra trip around the circle - helps skip principal values
2051 (if (ratgreaterp (car b) (car l)) ; if q > p
2052 (setq l (cons (add 1 (car l)) ; p += 1
2053 (add (mul -1 %pi2) (cdr l))))) ; d -= 2*%pi
2055 ;; Compute -integrate(f,x,0,d)
2056 (setq int-zero-to-d
2057 (cond ((setq ans (try-intsc e (cdr l) ivar))
2058 (m*t -1 ans))
2059 (t nil)))
2060 ;; Compute n = q - p (stored in nzp2)
2061 (setq nzp2 (m+ (car b) (m- (car l))))
2063 ;; Compute n*integrate(f,x,0,2*%pi)
2064 (setq int-nzp2 (cond ((zerop1 nzp2)
2065 ;; n = 0
2067 ((setq ans (try-intsc e %pi2 ivar))
2068 ;; n is not zero, so compute
2069 ;; integrate(f,x,0,2*%pi)
2070 (m*t nzp2 ans))
2071 ;; Unable to compute integrate(f,x,0,2*%pi)
2072 (t nil)))
2073 ;; Compute integrate(f,x,0,c)
2074 (setq int-zero-to-c (try-intsc e (cdr b) ivar))
2076 (return (cond ((and int-zero-to-d int-nzp2 int-zero-to-c)
2077 ;; All three pieces succeeded.
2078 (add* int-zero-to-d int-nzp2 int-zero-to-c))
2079 ((ratgreaterp %pi2 limit-diff)
2080 ;; Less than 1 full period, so intsc can integrate it.
2081 ;; Apply the substitution to make the lower limit 0.
2082 ;; This is last resort because substitution often causes intsc to fail.
2083 (intsc (maxima-substitute (m+ a ivar) ivar e)
2084 limit-diff ivar))
2085 ;; nothing worked
2086 (t nil))))))
2088 ;; integrate(sc, var, 0, b), where sc is f(sin(x), cos(x)).
2089 ;; calls intsc with a wrapper to just return nil if integral is divergent,
2090 ;; rather than generating an error.
2091 (defun try-intsc (sc b ivar)
2092 (let* ((*nodiverg t)
2093 (ans (catch 'divergent (intsc sc b ivar))))
2094 (if (eq ans 'divergent)
2096 ans)))
2098 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)). I (rtoy)
2099 ;; think this expects b to be less than 2*%pi.
2100 (defun intsc (sc b ivar)
2101 (if (zerop1 b)
2103 (multiple-value-bind (b sc)
2104 (cond ((eq ($sign b) '$neg)
2105 (values (m*t -1 b)
2106 (m* -1 (subin-var (m*t -1 ivar) sc ivar))))
2108 (values b sc)))
2109 ;; Partition the integrand SC into the factors that do not
2110 ;; contain VAR (the car part) and the parts that do (the cdr
2111 ;; part).
2112 (setq sc (partition sc ivar 1))
2113 (cond ((setq b (intsc0 (cdr sc) b ivar))
2114 (m* (resimplify (car sc)) b))))))
2116 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)).
2117 (defun intsc0 (sc b ivar)
2118 ;; Determine if sc is a product of sin's and cos's.
2119 (let ((nn* (scprod sc ivar))
2120 (dn* ()))
2121 (cond (nn*
2122 ;; We have a product of sin's and cos's. We handle some
2123 ;; special cases here.
2124 (cond ((alike1 b half%pi)
2125 ;; Wang p. 110, formula (1):
2126 ;; integrate(sin(x)^m*cos(x)^n, x, 0, %pi/2) =
2127 ;; gamma((m+1)/2)*gamma((n+1)/2)/2/gamma((n+m+2)/2)
2128 (bygamma (car nn*) (cadr nn*)))
2129 ((eq b '$%pi)
2130 ;; Wang p. 110, near the bottom, says
2132 ;; int(f(sin(x),cos(x)), x, 0, %pi) =
2133 ;; int(f(sin(x),cos(x)) + f(sin(x),-cos(x)),x,0,%pi/2)
2134 (cond ((eq (real-branch (cadr nn*) -1) '$yes)
2135 (m* (m+ 1. (m^ -1 (cadr nn*)))
2136 (bygamma (car nn*) (cadr nn*))))))
2137 ((alike1 b %pi2)
2138 (cond ((or (and (eq (ask-integer (car nn*) '$even)
2139 '$yes)
2140 (eq (ask-integer (cadr nn*) '$even)
2141 '$yes))
2142 (and (ratnump (car nn*))
2143 (eq (real-branch (car nn*) -1)
2144 '$yes)
2145 (ratnump (cadr nn*))
2146 (eq (real-branch (cadr nn*) -1)
2147 '$yes)))
2148 (m* 4. (bygamma (car nn*) (cadr nn*))))
2149 ((or (eq (ask-integer (car nn*) '$odd) '$yes)
2150 (eq (ask-integer (cadr nn*) '$odd) '$yes))
2152 (t nil)))
2153 ((alike1 b half%pi3)
2154 ;; Wang, p. 111 says
2156 ;; int(f(sin(x),cos(x)),x,0,3*%pi/2) =
2157 ;; int(f(sin(x),cos(x)),x,0,%pi)
2158 ;; + int(f(-sin(x),-cos(x)),x,0,%pi/2)
2159 (m* (m+ 1. (m^ -1 (cadr nn*)) (m^ -1 (m+l nn*)))
2160 (bygamma (car nn*) (cadr nn*))))))
2162 ;; We don't have a product of sin's and cos's.
2163 (cond ((and (or (eq b '$%pi)
2164 (alike1 b %pi2)
2165 (alike1 b half%pi))
2166 (setq dn* (scrat sc b ivar)))
2167 dn*)
2168 ((setq nn* (antideriv sc ivar))
2169 (sin-cos-intsubs nn* ivar 0. b))
2170 (t ()))))))
2172 ;;;Is careful about substitution of limits where the denominator may be zero
2173 ;;;because of various assumptions made.
2174 (defun sin-cos-intsubs (exp ivar *ll* *ul*)
2175 (cond ((mplusp exp)
2176 (let ((l (mapcar #'(lambda (e)
2177 (sin-cos-intsubs1 e ivar))
2178 (cdr exp))))
2179 (if (not (some #'null l))
2180 (m+l l))))
2181 (t (sin-cos-intsubs1 exp ivar))))
2183 (defun sin-cos-intsubs1 (exp ivar)
2184 (let* ((rat-exp ($rat exp))
2185 (denom (pdis (cddr rat-exp))))
2186 (cond ((equal ($csign denom) '$zero)
2187 '$und)
2188 (t (try-intsubs exp *ll* *ul* ivar)))))
2190 (defun try-intsubs (exp *ll* *ul* ivar)
2191 (let* ((*nodiverg t)
2192 (ans (catch 'divergent (intsubs exp *ll* *ul* ivar))))
2193 (if (eq ans 'divergent)
2195 ans)))
2197 (defun try-defint (exp ivar *ll* *ul*)
2198 (let* ((*nodiverg t)
2199 (ans (catch 'divergent (defint exp ivar *ll* *ul*))))
2200 (if (eq ans 'divergent)
2202 ans)))
2204 ;; Determine whether E is of the form sin(x)^m*cos(x)^n and return the
2205 ;; list (m n).
2206 (defun scprod (e ivar)
2207 (let ((great-minus-1 #'(lambda (temp)
2208 (ratgreaterp temp -1)))
2209 m n)
2210 (cond
2211 ((setq m (powerofx e `((%sin) ,ivar) great-minus-1 ivar))
2212 (list m 0.))
2213 ((setq n (powerofx e `((%cos) ,ivar) great-minus-1 ivar))
2214 (setq m 0.)
2215 (list 0. n))
2216 ((and (mtimesp e)
2217 (or (setq m (powerofx (cadr e) `((%sin) ,ivar) great-minus-1 ivar))
2218 (setq n (powerofx (cadr e) `((%cos) ,ivar) great-minus-1 ivar)))
2219 (cond
2220 ((null m)
2221 (setq m (powerofx (caddr e) `((%sin) ,ivar) great-minus-1 ivar)))
2222 (t (setq n (powerofx (caddr e) `((%cos) ,ivar) great-minus-1 ivar))))
2223 (null (cdddr e)))
2224 (list m n))
2225 (t ()))))
2227 (defun real-branch (exponent value)
2228 ;; Says whether (m^t value exponent) has at least one real branch.
2229 ;; Only works for values of 1 and -1 now. Returns $yes $no
2230 ;; $unknown.
2231 (cond ((equal value 1.)
2232 '$yes)
2233 ((eq (ask-integer exponent '$integer) '$yes)
2234 '$yes)
2235 ((ratnump exponent)
2236 (cond ((eq ($oddp (caddr exponent)) t)
2237 '$yes)
2238 (t '$no)))
2239 (t '$unknown)))
2241 ;; Compute beta((m+1)/2,(n+1)/2)/2.
2242 (defun bygamma (m n)
2243 (let ((one-half (m//t 1. 2.)))
2244 (m* one-half `((%beta) ,(m* one-half (m+t 1. m))
2245 ,(m* one-half (m+t 1. n))))))
2247 ;;Seems like Guys who call this don't agree on what it should return.
2248 (defun powerofx (e x p ivar)
2249 (setq e (cond ((not (among ivar e)) nil)
2250 ((alike1 e x) 1.)
2251 ((atom e) nil)
2252 ((and (mexptp e)
2253 (alike1 (cadr e) x)
2254 (not (among ivar (caddr e))))
2255 (caddr e))))
2256 (cond ((null e) nil)
2257 ((funcall p e) e)))
2260 ;; Check e for an expression of the form x^kk*(b*x^n+a)^l. If it
2261 ;; matches, Return the two values kk and (list l a n b).
2262 (defun bata0 (e ivar)
2263 (let (k c)
2264 (cond ((atom e) nil)
2265 ((mexptp e)
2266 ;; We have f(x)^y. Look to see if f(x) has the desired
2267 ;; form. Then f(x)^y has the desired form too, with
2268 ;; suitably modified values.
2270 ;; XXX: Should we ask for the sign of f(x) if y is not an
2271 ;; integer? This transformation we're going to do requires
2272 ;; that f(x)^y be real.
2273 (destructuring-bind (mexp base power)
2275 (declare (ignore mexp))
2276 (multiple-value-bind (kk cc)
2277 (bata0 base ivar)
2278 (when kk
2279 ;; Got a match. Adjust kk and cc appropriately.
2280 (destructuring-bind (l a n b)
2282 (values (mul kk power)
2283 (list (mul l power) a n b)))))))
2284 ((and (mtimesp e)
2285 (null (cdddr e))
2286 (or (and (setq k (findp (cadr e) ivar))
2287 (setq c (bxm (caddr e) (polyinx (caddr e) ivar nil) ivar)))
2288 (and (setq k (findp (caddr e) ivar))
2289 (setq c (bxm (cadr e) (polyinx (cadr e) ivar nil) ivar)))))
2290 (values k c))
2291 ((setq c (bxm e (polyinx e ivar nil) ivar))
2292 (setq k 0.)
2293 (values k c)))))
2296 ;;(DEFUN BATAP (E)
2297 ;; (PROG (K C L)
2298 ;; (COND ((NOT (BATA0 E)) (RETURN NIL))
2299 ;; ((AND (EQUAL -1. (CADDDR C))
2300 ;; (EQ ($askSIGN (SETQ K (m+ 1. K)))
2301 ;; '$pos)
2302 ;; (EQ ($askSIGN (SETQ L (m+ 1. (CAR C))))
2303 ;; '$pos)
2304 ;; (ALIKE1 (CADR C)
2305 ;; (m^ UL (CADDR C)))
2306 ;; (SETQ E (CADR C))
2307 ;; (EQ ($askSIGN (SETQ C (CADDR C))) '$pos))
2308 ;; (RETURN (M// (m* (m^ UL (m+t K (m* C (m+t -1. L))))
2309 ;; `(($BETA) ,(SETQ NN* (M// K C))
2310 ;; ,(SETQ DN* L)))
2311 ;; C))))))
2314 ;; Integrals of the form i(log(x)^m*x^k*(a+b*x^n)^l,x,0,ul). There
2315 ;; are two cases to consider: One case has ul>0, b<0, a=-b*ul^n, k>-1,
2316 ;; l>-1, n>0, m a nonnegative integer. The second case has ul=inf, l < 0.
2318 ;; These integrals are essentially partial derivatives of the Beta
2319 ;; function (i.e. the Eulerian integral of the first kind). Note
2320 ;; that, currently, with the default setting intanalysis:true, this
2321 ;; function might not even be called for some of these integrals.
2322 ;; However, this can be palliated by setting intanalysis:false.
2324 (defun zto1 (e ivar)
2325 (when (or (mtimesp e) (mexptp e))
2326 (let ((m 0)
2327 (log (list '(%log) ivar)))
2328 (flet ((set-m (p)
2329 (setq m p)))
2330 (find-if #'(lambda (fac)
2331 (powerofx fac log #'set-m ivar))
2332 (cdr e)))
2333 (when (and (freeof ivar m)
2334 (eq (ask-integer m '$integer) '$yes)
2335 (not (eq ($asksign m) '$neg)))
2336 (setq e (m//t e (list '(mexpt) log m)))
2337 (cond
2338 ((eq *ul* '$inf)
2339 (multiple-value-bind (kk s d r cc)
2340 (batap-inf e ivar)
2341 ;; We have i(x^kk/(d+cc*x^r)^s,x,0,inf) =
2342 ;; beta(aa,bb)/(cc^aa*d^bb*r). Compute this, and then
2343 ;; differentiate it m times to get the log term
2344 ;; incorporated.
2345 (when kk
2346 (let* ((aa (div (add 1 ivar) r))
2347 (bb (sub s aa))
2348 (m (if (eq ($asksign m) '$zero)
2350 m)))
2351 (let ((res (div `((%beta) ,aa ,bb)
2352 (mul (m^t cc aa)
2353 (m^t d bb)
2354 r))))
2355 ($at ($diff res ivar m)
2356 (list '(mequal) ivar kk)))))))
2358 (multiple-value-bind
2359 (k/n l n b) (batap-new e ivar)
2360 (when k/n
2361 (let ((beta (ftake* '%beta k/n l))
2362 (m (if (eq ($asksign m) '$zero) 0 m)))
2363 ;; The result looks like B(k/n,l) ( ... ).
2364 ;; Perhaps, we should just $factor, instead of
2365 ;; pulling out beta like this.
2366 (m*t
2367 beta
2368 ($fullratsimp
2369 (m//t
2370 (m*t
2371 (m^t (m-t b) (m1-t l))
2372 (m^t *ul* (m*t n (m1-t l)))
2373 (m^t n (m-t (m1+t m)))
2374 ($at ($diff (m*t (m^t *ul* (m*t n ivar))
2375 (list '(%beta) ivar l))
2376 ivar m)
2377 (list '(mequal) ivar k/n)))
2378 beta))))))))))))
2381 ;;; If e is of the form given below, make the obvious change
2382 ;;; of variables (substituting ul*x^(1/n) for x) in order to reduce
2383 ;;; e to the usual form of the integrand in the Eulerian
2384 ;;; integral of the first kind.
2385 ;;; N. B: The old version of ZTO1 completely ignored this
2386 ;;; substitution; the log(x)s were just thrown in, which,
2387 ;;; of course would give wrong results.
2389 (defun batap-new (e ivar)
2390 ;; Parse e
2391 (multiple-value-bind (k c)
2392 (bata0 e ivar)
2393 (when k
2394 ;; e=x^k*(a+b*x^n)^l
2395 (destructuring-bind (l a n b)
2397 (when (and (freeof ivar k)
2398 (freeof ivar n)
2399 (freeof ivar l)
2400 (alike1 a (m-t (m*t b (m^t *ul* n))))
2401 (eq ($asksign b) '$neg)
2402 (eq ($asksign (setq k (m1+t k))) '$pos)
2403 (eq ($asksign (setq l (m1+t l))) '$pos)
2404 (eq ($asksign n) '$pos))
2405 (values (m//t k n) l n b))))))
2408 ;; Wang p. 71 gives the following formula for a beta function:
2410 ;; integrate(x^(k-1)/(c*x^r+d)^s,x,0,inf)
2411 ;; = beta(a,b)/(c^a*d^b*r)
2413 ;; where a = k/r > 0, b = s - a > 0, s > k > 0, r > 0, c*d > 0.
2415 ;; This function matches this and returns k-1, d, r, c, a, b. And
2416 ;; also checks that all the conditions hold. If not, NIL is returned.
2418 (defun batap-inf (e ivar)
2419 (multiple-value-bind (k c)
2420 (bata0 e ivar)
2421 (when k
2422 (destructuring-bind (l d r cc)
2424 (let* ((s (mul -1 l))
2425 (kk (add k 1))
2426 (a (div kk r))
2427 (b (sub s a)))
2428 (when (and (freeof ivar k)
2429 (freeof ivar r)
2430 (freeof ivar l)
2431 (eq ($asksign kk) '$pos)
2432 (eq ($asksign a) '$pos)
2433 (eq ($asksign b) '$pos)
2434 (eq ($asksign (sub s k)) '$pos)
2435 (eq ($asksign r) '$pos)
2436 (eq ($asksign (mul cc d)) '$pos))
2437 (values k s d r cc)))))))
2440 ;; Handles beta integrals.
2441 (defun batapp (e ivar)
2442 (cond ((not (or (equal *ll* 0)
2443 (eq *ll* '$minf)))
2444 (setq e (subin-var (m+ *ll* ivar) e ivar))))
2445 (multiple-value-bind (k c)
2446 (bata0 e ivar)
2447 (cond ((null k)
2448 nil)
2450 (destructuring-bind (l d al c)
2452 ;; e = x^k*(d+c*x^al)^l.
2453 (let ((new-k (m// (m+ 1 k) al)))
2454 (when (and (ratgreaterp al 0.)
2455 (eq ($asksign new-k) '$pos)
2456 (ratgreaterp (setq l (m* -1 l))
2457 new-k)
2458 (eq ($asksign (m* d c))
2459 '$pos))
2460 (setq l (m+ l (m*t -1 new-k)))
2461 (m// `((%beta) ,new-k ,l)
2462 (mul* al (m^ c new-k) (m^ d l))))))))))
2465 ;; Compute exp(d)*gamma((c+1)/b)/b/a^((c+1)/b). In essence, this is
2466 ;; the value of integrate(x^c*exp(d-a*x^b),x,0,inf).
2467 (defun gamma1 (c a b d)
2468 (m* (m^t '$%e d)
2469 (m^ (m* b (m^ a (setq c (m// (m+t c 1) b)))) -1)
2470 `((%gamma) ,c)))
2472 (defun zto%pi2 (grand ivar)
2473 (let ((result (unitcir (sratsimp (m// grand ivar)) ivar)))
2474 (cond (result (sratsimp (m* (m- '$%i) result)))
2475 (t nil))))
2477 ;; Evaluates the contour integral of GRAND around the unit circle
2478 ;; using residues.
2479 (defun unitcir (grand ivar)
2480 (numden-var grand ivar)
2481 (let* ((sgn nil)
2482 (result (princip (res-var ivar nn* dn*
2483 #'(lambda (pt)
2484 ;; Is pt stricly inside the unit circle?
2485 (setq sgn (let ((limitp nil))
2486 ($asksign (m+ -1 (cabs pt)))))
2487 (eq sgn '$neg))
2488 #'(lambda (pt)
2489 (declare (ignore pt))
2490 ;; Is pt on the unit circle? (Use
2491 ;; the cached value computed
2492 ;; above.)
2493 (prog1
2494 (eq sgn '$zero)
2495 (setq sgn nil)))))))
2496 (when result
2497 (m* '$%pi result))))
2500 (defun logx1 (exp *ll* *ul* ivar)
2501 (let ((arg nil))
2502 (cond
2503 ((and (notinvolve-var exp ivar '(%sin %cos %tan %atan %asin %acos))
2504 (setq arg (involve-var exp ivar '(%log))))
2505 (cond ((eq arg ivar)
2506 (cond ((ratgreaterp 1. *ll*)
2507 (cond ((not (eq *ul* '$inf))
2508 (intcv1 (m^t '$%e (m- 'yx)) (m- `((%log) ,ivar)) ivar))
2509 (t (intcv1 (m^t '$%e 'yx) `((%log) ,ivar) ivar))))))
2510 (t (intcv arg nil ivar)))))))
2513 ;; Wang 81-83. Unfortunately, the pdf version has page 82 as all
2514 ;; black, so here is, as best as I can tell, what Wang is doing.
2515 ;; Fortunately, p. 81 has the necessary hints.
2517 ;; First consider integrate(exp(%i*k*x^n),x) around the closed contour
2518 ;; consisting of the real axis from 0 to R, the arc from the angle 0
2519 ;; to %pi/(2*n) and the ray from the arc back to the origin.
2521 ;; There are no poles in this region, so the integral must be zero.
2522 ;; But consider the integral on the three parts. The real axis is the
2523 ;; integral we want. The return ray is
2525 ;; exp(%i*%pi/2/n) * integrate(exp(%i*k*(t*exp(%i*%pi/2/n))^n),t,R,0)
2526 ;; = exp(%i*%pi/2/n) * integrate(exp(%i*k*t^n*exp(%i*%pi/2)),t,R,0)
2527 ;; = -exp(%i*%pi/2/n) * integrate(exp(-k*t^n),t,0,R)
2529 ;; As R -> infinity, this last integral is gamma(1/n)/k^(1/n)/n.
2531 ;; We assume the integral on the circular arc approaches 0 as R ->
2532 ;; infinity. (Need to prove this.)
2534 ;; Thus, we have
2536 ;; integrate(exp(%i*k*t^n),t,0,inf)
2537 ;; = exp(%i*%pi/2/n) * gamma(1/n)/k^(1/n)/n.
2539 ;; Equating real and imaginary parts gives us the desired results:
2541 ;; integrate(cos(k*t^n),t,0,inf) = G * cos(%pi/2/n)
2542 ;; integrate(sin(k*t^n),t,0,inf) = G * sin(%pi/2/n)
2544 ;; where G = gamma(1/n)/k^(1/n)/n.
2546 (defun scaxn (e ivar)
2547 (let (ind s g)
2548 (cond ((atom e) nil)
2549 ((and (or (eq (caar e) '%sin)
2550 (eq (caar e) '%cos))
2551 (setq ind (caar e))
2552 (setq e (bx**n (cadr e) ivar)))
2553 ;; Ok, we have cos(b*x^n) or sin(b*x^n), and we set e = (n
2554 ;; b)
2555 (cond ((equal (car e) 1.)
2556 ;; n = 1. Give up. (Why not divergent?)
2557 nil)
2558 ((zerop (setq s (let ((sign ($asksign (cadr e))))
2559 (cond ((eq sign '$pos) 1)
2560 ((eq sign '$neg) -1)
2561 ((eq sign '$zero) 0)))))
2562 ;; s is the sign of b. Give up if it's zero.
2563 nil)
2564 ((not (eq ($asksign (m+ -1 (car e))) '$pos))
2565 ;; Give up if n-1 <= 0. (Why give up? Isn't the
2566 ;; integral divergent?)
2567 nil)
2569 ;; We can apply our formula now. g = gamma(1/n)/n/b^(1/n)
2570 (setq g (gamma1 0. (m* s (cadr e)) (car e) 0.))
2571 (setq e (m* g `((,ind) ,(m// half%pi (car e)))))
2572 (m* (cond ((and (eq ind '%sin)
2573 (equal s -1))
2575 (t 1))
2576 e)))))))
2579 ;; this is the second part of the definite integral package
2581 (defun p*lognxp (a s ivar)
2582 (let (b)
2583 (cond ((not (among '%log a))
2585 ((and (polyinx (setq b (maxima-substitute 1. `((%log) ,ivar) a))
2586 ivar t)
2587 (eq ($sign (m+ s (m+ 1 (deg-var b ivar))))
2588 '$pos)
2589 (evenfn b ivar)
2590 (setq a (lognxp (sratsimp (m// a b)) ivar)))
2591 (list b a)))))
2593 (defun lognxp (a ivar)
2594 (cond ((atom a) nil)
2595 ((and (eq (caar a) '%log)
2596 (eq (cadr a) ivar))
2598 ((and (mexptp a)
2599 (numberp (caddr a))
2600 (lognxp (cadr a) ivar))
2601 (caddr a))))
2603 (defun logcpi0 (n d ivar)
2604 (prog (polelist dp plm rlm factors pl rl pl1 rl1)
2605 (setq polelist
2606 (polelist-var ivar d #'upperhalf #'(lambda (j)
2607 (cond ((zerop1 j)
2608 nil)
2609 ((equal ($imagpart j) 0)
2610 t)))))
2611 (cond ((null polelist)
2612 (return nil)))
2613 (setq factors (car polelist)
2614 polelist (cdr polelist))
2615 (cond ((or (cadr polelist)
2616 (caddr polelist))
2617 (setq dp (sdiff d ivar))))
2618 (cond ((setq plm (car polelist))
2619 (setq rlm (residue-var ivar
2621 (cond (*leadcoef* factors)
2622 (t d))
2623 plm))))
2624 (cond ((setq pl (cadr polelist))
2625 (setq rl (res1-var ivar n dp pl))))
2626 (cond ((setq pl1 (caddr polelist))
2627 (setq rl1 (res1-var ivar n dp pl1))))
2628 (return (values
2629 (m*t (m//t 1. 2.)
2630 (m*t '$%pi
2631 (princip
2632 (list (cond ((setq nn* (append rl rlm))
2633 (m+l nn*)))
2634 (cond (rl1 (m+l rl1)))))))
2636 factors
2640 rl1))))
2642 (defun lognx2 (nn dn pl rl)
2643 (do ((pl pl (cdr pl))
2644 (rl rl (cdr rl))
2645 (ans ()))
2646 ((or (null pl)
2647 (null rl))
2648 ans)
2649 (setq ans (cons (m* dn (car rl)
2650 ;; AFAICT, this call to PLOG doesn't need
2651 ;; to bind VAR.
2652 (m^ `((%plog) ,(car pl)) nn))
2653 ans))))
2655 (defun logcpj (n d i ivar plm pl rl pl1 rl1)
2656 (setq n (append
2657 (if plm
2658 (list (mul* (m*t '$%i %pi2)
2659 (m+l
2660 ;; AFAICT, this call to PLOG doesn't need
2661 ;; to bind VAR. An example where this is
2662 ;; used is
2663 ;; integrate(log(x)^2/(1+x^2),x,0,1) =
2664 ;; %pi^3/16.
2665 (residue-var ivar
2666 (m* (m^ `((%plog) ,ivar) i)
2669 plm)))))
2670 (lognx2 i (m*t '$%i %pi2) pl rl)
2671 (lognx2 i %p%i pl1 rl1)))
2672 (if (null n)
2674 (simplify (m+l n))))
2676 ;; Handle integral(n(x)/d(x)*log(x)^m,x,0,inf). n and d are
2677 ;; polynomials.
2678 (defun log*rat (n d m ivar)
2679 (let ((i-vals (make-array (1+ m)))
2680 (j-vals (make-array (1+ m))))
2681 (labels
2682 ((logcpi (n d c ivar)
2683 (if (zerop c)
2684 (logcpi0 n d ivar)
2685 (m* '((rat) 1 2) (m+ (aref j-vals c) (m* -1 (sumi c))))))
2686 (sumi (c)
2687 (do ((k 1 (1+ k))
2688 (ans ()))
2689 ((= k c)
2690 (m+l ans))
2691 (push (mul* ($makegamma `((%binomial) ,c ,k))
2692 (m^t '$%pi k)
2693 (m^t '$%i k)
2694 (aref i-vals (- c k)))
2695 ans))))
2696 (setf (aref j-vals 0) 0)
2697 (prog (*leadcoef* res)
2698 (dotimes (c m (return (logcpi n d m ivar)))
2699 (multiple-value-bind (res plm factors pl rl pl1 rl1)
2700 (logcpi n d c ivar)
2701 (setf (aref i-vals c) res)
2702 (setf (aref j-vals c) (logcpj n factors c ivar plm pl rl pl1 rl1))))))))
2704 (defun fan (p m a n b)
2705 (let ((povern (m// p n))
2706 (ab (m// a b)))
2707 (cond
2708 ((or (eq (ask-integer povern '$integer) '$yes)
2709 (not (equal ($imagpart ab) 0))) ())
2710 (t (let ((ind ($asksign ab)))
2711 (cond ((eq ind '$zero) nil)
2712 ((eq ind '$neg) nil)
2713 ((not (ratgreaterp m povern)) nil)
2714 (t (m// (m* '$%pi
2715 ($makegamma `((%binomial) ,(m+ -1 m (m- povern))
2716 ,(m+t -1 m)))
2717 `((mabs) ,(m^ a (m+ povern (m- m)))))
2718 (m* (m^ b povern)
2720 `((%sin) ,(m*t '$%pi povern)))))))))))
2723 ;;Makes a new poly such that np(x)-np(x+2*%i*%pi)=p(x).
2724 ;;Constructs general POLY of degree one higher than P with
2725 ;;arbitrary coeff. and then solves for coeffs by equating like powers
2726 ;;of the varibale of integration.
2727 ;;Can probably be made simpler now.
2729 (defun makpoly (p ivar)
2730 (let ((n (deg-var p ivar)) (ans ()) (varlist ()) (gp ()) (cl ()) (zz ()))
2731 (setq ans (genpoly (m+ 1 n) ivar)) ;Make poly with gensyms of 1 higher deg.
2732 (setq cl (cdr ans)) ;Coefficient list
2733 (setq varlist (append cl (list ivar))) ;Make VAR most important.
2734 (setq gp (car ans)) ;This is the poly with gensym coeffs.
2735 ;;;Now, poly(x)-poly(x+2*%i*%pi)=p(x), P is the original poly.
2736 (setq ans (m+ gp (subin-var (m+t (m*t '$%i %pi2) ivar) (m- gp) ivar) (m- p)))
2737 (newvar ans)
2738 (setq ans (ratrep* ans)) ;Rational rep with VAR leading.
2739 (setq zz (coefsolve n cl (cond ((not (eq (caadr ans) ;What is Lead Var.
2740 (genfind (car ans) ivar)))
2741 (list 0 (cadr ans))) ;No VAR in ans.
2742 ((cdadr ans))))) ;The real Poly.
2743 (if (or (null zz) (null gp))
2745 ($substitute zz gp)))) ;Substitute Values for gensyms.
2747 (defun coefsolve (n cl e)
2748 (do (($breakup)
2749 (eql (ncons (pdis (ptterm e n))) (cons (pdis (ptterm e m)) eql))
2750 (m (m+ n -1) (m+ m -1)))
2751 ((signp l m) (solvex eql cl nil nil))))
2753 ;; Integrate(p(x)*f(exp(x))/g(exp(x)),x,minf,inf) by applying the
2754 ;; transformation y = exp(x) to get
2755 ;; integrate(p(log(y))*f(y)/g(y)/y,y,0,inf). This should be handled
2756 ;; by dintlog.
2757 (defun log-transform (p pe d ivar)
2758 (let ((new-p (subst (list '(%log) ivar) ivar p))
2759 (new-pe (subst ivar 'z* (catch 'pin%ex (pin%ex pe ivar))))
2760 (new-d (subst ivar 'z* (catch 'pin%ex (pin%ex d ivar)))))
2761 (defint (div (div (mul new-p new-pe) new-d) ivar) ivar 0 *ul*)))
2763 ;; This implements Wang's algorithm in Chapter 5.2, pp. 98-100.
2765 ;; This is a very brief description of the algorithm. Basically, we
2766 ;; have integrate(R(exp(x))*p(x),x,minf,inf), where R(x) is a rational
2767 ;; function and p(x) is a polynomial.
2769 ;; We find a polynomial q(x) such that q(x) - q(x+2*%i*%pi) = p(x).
2770 ;; Then consider a contour integral of R(exp(z))*q(z) over a
2771 ;; rectangular contour. Opposite corners of the rectangle are (-R,
2772 ;; 2*%i*%pi) and (R, 0).
2774 ;; Wang shows that this contour integral, in the limit, is the
2775 ;; integral of R(exp(x))*q(x)-R(exp(x))*q(x+2*%i*%pi), which is
2776 ;; exactly the integral we're looking for.
2778 ;; Thus, to find the value of the contour integral, we just need the
2779 ;; residues of R(exp(z))*q(z). The only tricky part is that we want
2780 ;; the log function to have an imaginary part between 0 and 2*%pi
2781 ;; instead of -%pi to %pi.
2782 (defun rectzto%pi2 (p pe d ivar)
2783 ;; We have R(exp(x))*p(x) represented as p(x)*pe(exp(x))/d(exp(x)).
2784 (prog (dp n pl a b c denom-exponential)
2785 (if (not (and (setq denom-exponential (catch 'pin%ex (pin%ex d ivar)))
2786 (%e-integer-coeff pe ivar)
2787 (%e-integer-coeff d ivar)))
2788 (return ()))
2789 ;; At this point denom-exponential has converted d(exp(x)) to the
2790 ;; polynomial d(z), where z = exp(x).
2791 (setq n (m* (cond ((null p) -1)
2792 (t ($expand (m*t '$%i %pi2 (makpoly p ivar)))))
2793 pe))
2794 (let ((*leadcoef* ()))
2795 ;; Find the poles of the denominator. denom-exponential is the
2796 ;; denominator of R(x).
2798 ;; It seems as if polelist returns a list of several items.
2799 ;; The first element is a list consisting of the pole and (z -
2800 ;; pole). We don't care about this, so we take the rest of the
2801 ;; result.
2802 (setq pl (cdr (polelist-var 'z* denom-exponential
2803 #'(lambda (j)
2804 ;; The imaginary part is nonzero,
2805 ;; or the realpart is negative.
2806 (or (not (equal ($imagpart j) 0))
2807 (eq ($asksign ($realpart j)) '$neg)))
2808 #'(lambda (j)
2809 ;; The realpart is not zero.
2810 (not (eq ($asksign ($realpart j)) '$zero)))))))
2811 ;; Not sure what this does.
2812 (cond ((null pl)
2813 ;; No roots at all, so return
2814 (return nil))
2815 ((or (cadr pl)
2816 (caddr pl))
2817 ;; We have simple roots or roots in REGION1
2818 (setq dp (sdiff d ivar))))
2819 (cond ((cadr pl)
2820 ;; The cadr of pl is the list of the simple poles of
2821 ;; denom-exponential. Take the log of them to find the
2822 ;; poles of the original expression. Then compute the
2823 ;; residues at each of these poles and sum them up and put
2824 ;; the result in B. (If no simple poles set B to 0.)
2825 (setq b (mapcar #'log-imag-0-2%pi (cadr pl)))
2826 (setq b (res1-var ivar n dp b))
2827 (setq b (m+l b)))
2828 (t (setq b 0.)))
2829 (cond ((caddr pl)
2830 ;; I think this handles the case of poles outside the
2831 ;; regions. The sum of these residues are placed in C.
2832 (let ((temp (mapcar #'log-imag-0-2%pi (caddr pl))))
2833 (setq c (append temp (mapcar #'(lambda (j)
2834 (m+ (m*t '$%i %pi2) j))
2835 temp)))
2836 (setq c (res1-var ivar n dp c))
2837 (setq c (m+l c))))
2838 (t (setq c 0.)))
2839 (cond ((car pl)
2840 ;; We have the repeated poles of deonom-exponential, so we
2841 ;; need to convert them to the actual pole values for
2842 ;; R(exp(x)), by taking the log of the value of poles.
2843 (let ((poles (mapcar #'(lambda (p)
2844 (log-imag-0-2%pi (car p)))
2845 (car pl)))
2846 (exp (m// n (subst (m^t '$%e ivar) 'z* denom-exponential))))
2847 ;; Compute the residues at all of these poles and sum
2848 ;; them up.
2849 (setq a (mapcar #'(lambda (j)
2850 ($residue exp ivar j))
2851 poles))
2852 (setq a (m+l a))))
2853 (t (setq a 0.)))
2854 (return (sratsimp (m+ a b (m* '((rat) 1. 2.) c))))))
2856 (defun genpoly (i ivar)
2857 (do ((i i (m+ i -1))
2858 (c (gensym) (gensym))
2859 (cl ())
2860 (ans ()))
2861 ((zerop i)
2862 (cons (m+l ans) cl))
2863 (setq ans (cons (m* c (m^t ivar i)) ans))
2864 (setq cl (cons c cl))))
2866 ;; Check to see if each term in exp that is of the form exp(k*x) has
2867 ;; an integer value for k.
2868 (defun %e-integer-coeff (exp ivar)
2869 (cond ((mapatom exp) t)
2870 ((and (mexptp exp)
2871 (eq (cadr exp) '$%e))
2872 (eq (ask-integer ($coeff (caddr exp) ivar) '$integer)
2873 '$yes))
2874 (t (every #'(lambda (e)
2875 (%e-integer-coeff e ivar))
2876 (cdr exp)))))
2878 (defun wlinearpoly (e ivar)
2879 (cond ((and (setq e (polyinx e ivar t))
2880 (equal (deg-var e ivar) 1))
2881 (subin-var 1 e ivar))))
2883 ;; Test to see if exp is of the form f(exp(x)), and if so, replace
2884 ;; exp(x) with 'z*. That is, basically return f(z*).
2885 (defun pin%ex (exp ivar)
2886 (pin%ex0 (cond ((notinvolve-var exp ivar '(%sinh %cosh %tanh))
2887 exp)
2889 (let (($exponentialize t))
2890 (setq exp ($expand exp)))))
2891 ivar))
2893 (defun pin%ex0 (e ivar)
2894 ;; Does e really need to be special here? Seems to be ok without
2895 ;; it; testsuite works.
2896 #+nil
2897 (declare (special e))
2898 (cond ((not (among ivar e))
2900 ((atom e)
2901 (throw 'pin%ex nil))
2902 ((and (mexptp e)
2903 (eq (cadr e) '$%e))
2904 (cond ((eq (caddr e) ivar)
2905 'z*)
2906 ((let ((linterm (wlinearpoly (caddr e) ivar)))
2907 (and linterm
2908 (m* (subin-var 0 e ivar) (m^t 'z* linterm)))))
2910 (throw 'pin%ex nil))))
2911 ((mtimesp e)
2912 (m*l (mapcar #'(lambda (ee)
2913 (pin%ex0 ee ivar))
2914 (cdr e))))
2915 ((mplusp e)
2916 (m+l (mapcar #'(lambda (ee)
2917 (pin%ex0 ee ivar))
2918 (cdr e))))
2920 (throw 'pin%ex nil))))
2922 (defun findsub (p ivar)
2923 (cond ((findp p ivar) nil)
2924 ((setq nd* (bx**n p ivar))
2925 (m^t ivar (car nd*)))
2926 ((setq p (bx**n+a p ivar))
2927 (m* (caddr p) (m^t ivar (cadr p))))))
2929 ;; I think this is looking at f(exp(x)) and tries to find some
2930 ;; rational function R and some number k such that f(exp(x)) =
2931 ;; R(exp(k*x)).
2932 (defun funclogor%e (e ivar)
2933 (prog (ans arg nvar r)
2934 (cond ((or (ratp e ivar)
2935 (involve-var e ivar '(%sin %cos %tan))
2936 (not (setq arg (xor (and (setq arg (involve-var e ivar '(%log)))
2937 (setq r '%log))
2938 (%einvolve-var e ivar)))))
2939 (return nil)))
2940 ag (setq nvar (cond ((eq r '%log) `((%log) ,arg))
2941 (t (m^t '$%e arg))))
2942 (setq ans (maxima-substitute (m^t 'yx -1) (m^t nvar -1) (maxima-substitute 'yx nvar e)))
2943 (cond ((not (among ivar ans)) (return (list (subst ivar 'yx ans) nvar)))
2944 ((and (null r)
2945 (setq arg (findsub arg ivar)))
2946 (go ag)))))
2948 ;; Integration by parts.
2950 ;; integrate(u(x)*diff(v(x),x),x,a,b)
2951 ;; |b
2952 ;; = u(x)*v(x)| - integrate(v(x)*diff(u(x),x))
2953 ;; |a
2955 (defun dintbypart (u v a b ivar)
2956 ;;;SINCE ONLY CALLED FROM DINTLOG TO get RID OF LOGS - IF LOG REMAINS, QUIT
2957 (let ((ad (antideriv v ivar)))
2958 (cond ((or (null ad)
2959 (involve-var ad ivar '(%log)))
2960 nil)
2961 (t (let ((p1 (m* u ad))
2962 (p2 (m* ad (sdiff u ivar))))
2963 (let ((p1-part1 (get-limit p1 ivar b '$minus))
2964 (p1-part2 (get-limit p1 ivar a '$plus)))
2965 (cond ((or (null p1-part1)
2966 (null p1-part2))
2967 nil)
2968 (t (let ((p2 (let ((*def2* t))
2969 (defint p2 ivar a b))))
2970 (cond (p2 (add* p1-part1
2971 (m- p1-part2)
2972 (m- p2)))
2973 (t nil)))))))))))
2975 ;; integrate(f(exp(k*x)),x,a,b), where f(z) is rational.
2977 ;; See Wang p. 96-97.
2979 ;; If the limits are minf to inf, we use the substitution y=exp(k*x)
2980 ;; to get integrate(f(y)/y,y,0,inf)/k. If the limits are 0 to inf,
2981 ;; use the substitution s+1=exp(k*x) to get
2982 ;; integrate(f(s+1)/(s+1),s,0,inf).
2983 (defun dintexp (exp ivar &aux ans)
2984 (let ((*dintexp-recur* t)) ;recursion stopper
2985 (cond ((and (sinintp exp ivar) ;To be moved higher in the code.
2986 (setq ans (antideriv exp ivar))
2987 (setq ans (intsubs ans *ll* *ul* ivar)))
2988 ;; If we can integrate it directly, do so and take the
2989 ;; appropriate limits.
2991 ((setq ans (funclogor%e exp ivar))
2992 ;; ans is the list (f(x) exp(k*x)).
2993 (cond ((and (equal *ll* 0.)
2994 (eq *ul* '$inf))
2995 ;; Use the substitution s + 1 = exp(k*x). The
2996 ;; integral becomes integrate(f(s+1)/(s+1),s,0,inf)
2997 (setq ans (m+t -1 (cadr ans))))
2999 ;; Use the substitution y=exp(k*x) because the
3000 ;; limits are minf to inf.
3001 (setq ans (cadr ans))))
3002 ;; Apply the substitution and integrate it.
3003 (intcv ans nil ivar)))))
3005 ;; integrate(log(g(x))*f(x),x,0,inf)
3006 (defun dintlog (exp arg ivar)
3007 (let ((*dintlog-recur* (1+ *dintlog-recur*))) ;recursion stopper
3008 (prog (ans d)
3009 (cond ((and (eq *ul* '$inf)
3010 (equal *ll* 0.)
3011 (eq arg ivar)
3012 (equal 1 (sratsimp (m// exp (m* (m- (subin-var (m^t ivar -1)
3014 ivar))
3015 (m^t ivar -2))))))
3016 ;; Make the substitution y=1/x. If the integrand has
3017 ;; exactly the same form, the answer has to be 0.
3018 (return 0.))
3019 ((and (setq ans (let (($gamma_expand t)) (logx1 exp *ll* *ul* ivar)))
3020 (free ans '%limit))
3021 (return ans))
3022 ((setq ans (antideriv exp ivar))
3023 ;; It's easy if we have the antiderivative.
3024 ;; but intsubs sometimes gives results containing %limit
3025 (return (intsubs ans *ll* *ul* ivar))))
3026 ;; Ok, the easy cases didn't work. We now try integration by
3027 ;; parts. Set ANS to f(x).
3028 (setq ans (m// exp `((%log) ,arg)))
3029 (cond ((involve-var ans ivar '(%log))
3030 ;; Bad. f(x) contains a log term, so we give up.
3031 (return nil))
3032 ((and (eq arg ivar)
3033 (equal 0. (no-err-sub-var 0. ans ivar))
3034 (setq d (let ((*def2* t))
3035 (defint (m* ans (m^t ivar '*z*))
3036 ivar *ll* *ul*))))
3037 ;; The arg of the log function is the same as the
3038 ;; integration variable. We can do something a little
3039 ;; simpler than integration by parts. We have something
3040 ;; like f(x)*log(x). Consider f(x)*x^z. If we
3041 ;; differentiate this wrt to z, the integrand becomes
3042 ;; f(x)*log(x)*x^z. When we evaluate this at z = 0, we
3043 ;; get the desired integrand.
3045 ;; So we need f(0) to be 0 at 0. If we can integrate
3046 ;; f(x)*x^z, then we differentiate the result and
3047 ;; evaluate it at z = 0.
3048 (return (derivat '*z* 1. d 0.)))
3049 ((setq ans (dintbypart `((%log) ,arg) ans *ll* *ul* ivar))
3050 ;; Try integration by parts.
3051 (return ans))))))
3053 ;; Compute diff(e,ivar,n) at the point pt.
3054 (defun derivat (ivar n e pt)
3055 (subin-var pt (apply '$diff (list e ivar n)) ivar))
3057 ;;; GGR and friends
3059 ;; MAYBPC returns (COEF EXPO CONST)
3061 ;; This basically picks off b*x^n+a and returns the list
3062 ;; (b n a). It may also set the global *zd*.
3063 (defun maybpc (e ivar)
3064 (let (zd)
3065 (cond (*mtoinf* (throw 'ggrm (linpower0 e ivar)))
3066 ((and (not *mtoinf*)
3067 (null (setq e (bx**n+a e ivar)))) ;bx**n+a --> (a n b) or nil.
3068 nil) ;with ivar being x.
3069 ;; At this point, e is of the form (a n b)
3070 ((and (among '$%i (caddr e))
3071 (zerop1 ($realpart (caddr e)))
3072 (setq zn ($imagpart (caddr e)))
3073 (eq ($asksign (cadr e)) '$pos))
3074 ;; If we're here, b is complex, and n > 0. zn = imagpart(b).
3076 ;; Set ivar to the same sign as zn.
3077 (cond ((eq ($asksign zn) '$neg)
3078 (setq ivar -1)
3079 (setq zn (m- zn)))
3080 (t (setq ivar 1)))
3081 ;; zd = exp(ivar*%i*%pi*(1+nd)/(2*n). (ZD is special!)
3082 (setq zd (m^t '$%e (m// (mul* ivar '$%i '$%pi (m+t 1 nd*))
3083 (m*t 2 (cadr e)))))
3084 ;; Return zn, n, a, zd.
3085 (values `(,(caddr e) ,(cadr e) ,(car e)) zd))
3086 ((and (or (eq (setq ivar ($asksign ($realpart (caddr e)))) '$neg)
3087 (equal ivar '$zero))
3088 (equal ($imagpart (cadr e)) 0)
3089 (ratgreaterp (cadr e) 0.))
3090 ;; We're here if realpart(b) <= 0, and n >= 0. Then return -b, n, a.
3091 `(,(caddr e) ,(cadr e) ,(car e))))))
3093 ;; Integrate x^m*exp(b*x^n+a), with realpart(m) > -1.
3095 ;; See Wang, pp. 84-85.
3097 ;; I believe the formula Wang gives is incorrect. The derivation is
3098 ;; correct except for the last step.
3100 ;; Let J = integrate(x^m*exp(%i*k*x^n),x,0,inf), with real k.
3102 ;; Consider the case for k < 0. Take a sector of a circle bounded by
3103 ;; the real line and the angle -%pi/(2*n), and by the radii, r and R.
3104 ;; Since there are no poles inside this contour, the integral
3106 ;; integrate(z^m*exp(%i*k*z^n),z) = 0
3108 ;; Then J = exp(-%pi*%i*(m+1)/(2*n))*integrate(R^m*exp(k*R^n),R,0,inf)
3110 ;; because the integral along the boundary is zero except for the part
3111 ;; on the real axis. (Proof?)
3113 ;; Wang seems to say this last integral is gamma(s/n/(-k)^s) where s =
3114 ;; (m+1)/n. But that seems wrong. If we use the substitution R =
3115 ;; (y/(-k))^(1/n), we end up with the result:
3117 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n).
3119 ;; or gamma((m+1)/n)/k^((m+1)/n)/n.
3121 ;; Note that this also handles the case of
3123 ;; integrate(x^m*exp(-k*x^n),x,0,inf);
3125 ;; where k is positive real number. A simple change of variables,
3126 ;; y=k*x^n, gives
3128 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n))
3130 ;; which is the same form above.
3131 (defun ggr (e ind ivar)
3132 (prog (c zd zn nn* dn* nd* dosimp $%emode)
3133 (setq nd* 0.)
3134 (cond (ind (setq e ($expand e))
3135 (cond ((and (mplusp e)
3136 (let ((*nodiverg t))
3137 (setq e (catch 'divergent
3138 (andmapcar
3139 #'(lambda (j)
3140 (ggr j nil ivar))
3141 (cdr e))))))
3142 (cond ((eq e 'divergent) nil)
3143 (t (return (sratsimp (cons '(mplus) e)))))))))
3144 (setq e (rmconst1 e ivar))
3145 (setq c (car e))
3146 (setq e (cdr e))
3147 (cond ((multiple-value-setq (e zd)
3148 (ggr1 e ivar))
3149 ;; e = (m b n a). That is, the integral is of the form
3150 ;; x^m*exp(b*x^n+a). I think we want to compute
3151 ;; gamma((m+1)/n)/b^((m+1)/n)/n.
3153 ;; FIXME: If n > m + 1, the integral converges. We need
3154 ;; to check for this.
3155 (destructuring-bind (m b n a)
3157 (when (and (not (zerop1 ($realpart b)))
3158 (not (zerop1 ($imagpart b))))
3159 ;; The derivation only holds if b is purely real or
3160 ;; purely imaginary. Give up if it's not.
3161 (return nil))
3162 ;; Check for convergence. If b is complex, we need n -
3163 ;; m > 1. If b is real, we need b < 0.
3164 (when (and (zerop1 ($imagpart b))
3165 (not (eq ($asksign b) '$neg)))
3166 (diverg))
3167 (when (and (not (zerop1 ($imagpart b)))
3168 (not (eq ($asksign (sub n (add m 1))) '$pos)))
3169 (diverg))
3171 (setq e (gamma1 m (cond ((zerop1 ($imagpart b))
3172 ;; If we're here, b must be negative.
3173 (neg b))
3175 ;; Complex b. Take the imaginary part
3176 `((mabs) ,($imagpart b))))
3177 n a))
3178 (when zd
3179 ;; FIXME: Why do we set %emode here? Shouldn't we just
3180 ;; bind it? And why do we want it bound to T anyway?
3181 ;; Shouldn't the user control that? The same goes for
3182 ;; dosimp.
3183 ;;(setq $%emode t)
3184 (setq dosimp t)
3185 (setq e (m* zd e))))))
3186 (cond (e (return (m* c e))))))
3189 ;; Match x^m*exp(b*x^n+a). If it does, return (list m b n a).
3190 (defun ggr1 (e ivar)
3191 (let (zd)
3192 (cond ((atom e) nil)
3193 ((and (mexptp e)
3194 (eq (cadr e) '$%e))
3195 ;; We're looking at something like exp(f(ivar)). See if it's
3196 ;; of the form b*x^n+a, and return (list 0 b n a). (The 0 is
3197 ;; so we can graft something onto it if needed.)
3198 (cond ((multiple-value-setq (e zd)
3199 (maybpc (caddr e) ivar))
3200 (values (cons 0. e) zd))))
3201 ((and (mtimesp e)
3202 ;; E should be the product of exactly 2 terms
3203 (null (cdddr e))
3204 ;; Check to see if one of the terms is of the form
3205 ;; ivar^p. If so, make sure the realpart of p > -1. If
3206 ;; so, check the other term has the right form via
3207 ;; another call to ggr1.
3208 (or (and (setq dn* (xtorterm (cadr e) ivar))
3209 (ratgreaterp (setq nd* ($realpart dn*))
3210 -1.)
3211 (multiple-value-setq (nn* zd)
3212 (ggr1 (caddr e) ivar)))
3213 (and (setq dn* (xtorterm (caddr e) ivar))
3214 (ratgreaterp (setq nd* ($realpart dn*))
3215 -1.)
3216 (multiple-value-setq (nn* zd)
3217 (ggr1 (cadr e) ivar)))))
3218 ;; Both terms have the right form and nn* contains the ivar of
3219 ;; the exponential term. Put dn* as the car of nn*. The
3220 ;; result is something like (m b n a) when we have the
3221 ;; expression x^m*exp(b*x^n+a).
3222 (values (rplaca nn* dn*) zd)))))
3225 ;; Match b*x^n+a. If a match is found, return the list (a n b).
3226 ;; Otherwise, return NIL
3227 (defun bx**n+a (e ivar)
3228 (cond ((eq e ivar)
3229 (list 0 1 1))
3230 ((or (atom e)
3231 (mnump e)) ())
3232 (t (let ((a (no-err-sub-var 0. e ivar)))
3233 (cond ((null a) ())
3234 (t (setq e (m+ e (m*t -1 a)))
3235 (cond ((setq e (bx**n e ivar))
3236 (cons a e))
3237 (t ()))))))))
3239 ;; Match b*x^n. Return the list (n b) if found or NIL if not.
3240 (defun bx**n (e ivar)
3241 (let ((n ()))
3242 (and (setq n (xexponget e ivar))
3243 (not (among ivar
3244 (setq e (let (($maxposex 1)
3245 ($maxnegex 1))
3246 ($expand (m// e (m^t ivar n)))))))
3247 (list n e))))
3249 ;; nn* should be the value of var. This is only called by bx**n with
3250 ;; the second arg of var.
3251 (defun xexponget (e nn*)
3252 (cond ((atom e) (cond ((eq e nn*) 1.)))
3253 ((mnump e) nil)
3254 ((and (mexptp e)
3255 (eq (cadr e) nn*)
3256 (not (among nn* (caddr e))))
3257 (caddr e))
3258 (t (some #'(lambda (j) (xexponget j nn*)) (cdr e)))))
3261 ;;; given (b*x^n+a)^m returns (m a n b)
3262 (defun bxm (e ind ivar)
3263 (let (m r)
3264 (cond ((or (atom e)
3265 (mnump e)
3266 (involve-var e ivar '(%log %sin %cos %tan))
3267 (%einvolve-var e ivar))
3268 nil)
3269 ((mtimesp e) nil)
3270 ((mexptp e) (cond ((among ivar (caddr e)) nil)
3271 ((setq r (bx**n+a (cadr e) ivar))
3272 (cons (caddr e) r))))
3273 ((setq r (bx**n+a e ivar)) (cons 1. r))
3274 ((not (null ind))
3275 ;;;Catches Unfactored forms.
3276 (setq m (m// (sdiff e ivar) e))
3277 (numden-var m ivar)
3278 (setq m nn*)
3279 (setq r dn*)
3280 (cond
3281 ((and (setq r (bx**n+a (sratsimp r) ivar))
3282 (not (among ivar (setq m (m// m (m* (cadr r) (caddr r)
3283 (m^t ivar (m+t -1 (cadr r))))))))
3284 (setq e (m// (subin-var 0. e ivar) (m^t (car r) m))))
3285 (cond ((equal e 1.)
3286 (cons m r))
3287 (t (setq e (m^ e (m// 1. m)))
3288 (list m (m* e (car r)) (cadr r)
3289 (m* e (caddr r))))))))
3290 (t ()))))
3292 ;;;Is E = VAR raised to some power? If so return power or 0.
3293 (defun findp (e ivar)
3294 (cond ((not (among ivar e)) 0.)
3295 (t (xtorterm e ivar))))
3297 (defun xtorterm (e ivar)
3298 ;;;Is E = VAR1 raised to some power? If so return power.
3299 (cond ((alike1 e ivar) 1.)
3300 ((atom e) nil)
3301 ((and (mexptp e)
3302 (alike1 (cadr e) ivar)
3303 (not (among ivar (caddr e))))
3304 (caddr e))))
3306 (defun tbf (l)
3307 (m^ (m* (m^ (caddr l) '((rat) 1 2))
3308 (m+ (cadr l) (m^ (m* (car l) (caddr l))
3309 '((rat) 1 2))))
3310 -1))
3312 (defun radbyterm (d l ivar)
3313 (do ((l l (cdr l))
3314 (ans ()))
3315 ((null l)
3316 (m+l ans))
3317 (destructuring-let (((const . integrand) (rmconst1 (car l) ivar)))
3318 (setq ans (cons (m* const (dintrad0 integrand d ivar))
3319 ans)))))
3321 (defun sqdtc (e ind ivar)
3322 (prog (a b c varlist)
3323 (setq varlist (list ivar))
3324 (newvar e)
3325 (setq e (cdadr (ratrep* e)))
3326 (setq c (pdis (ptterm e 0)))
3327 (setq b (m*t (m//t 1 2) (pdis (ptterm e 1))))
3328 (setq a (pdis (ptterm e 2)))
3329 (cond ((and (eq ($asksign (m+ b (m^ (m* a c)
3330 '((rat) 1 2))))
3331 '$pos)
3332 (or (and ind
3333 (not (eq ($asksign a) '$neg))
3334 (eq ($asksign c) '$pos))
3335 (and (eq ($asksign a) '$pos)
3336 (not (eq ($asksign c) '$neg)))))
3337 (return (list a b c))))))
3339 (defun difap1 (e pwr ivar m pt)
3340 (m// (mul* (cond ((eq (ask-integer m '$even) '$yes)
3342 (t -1))
3343 `((%gamma) ,pwr)
3344 (derivat ivar m e pt))
3345 `((%gamma) ,(m+ pwr m))))
3347 ;; Note: This doesn't seem be called from anywhere.
3348 (defun sqrtinvolve (e ivar)
3349 (cond ((atom e) nil)
3350 ((mnump e) nil)
3351 ((and (mexptp e)
3352 (and (mnump (caddr e))
3353 (not (numberp (caddr e)))
3354 (equal (caddr (caddr e)) 2.))
3355 (among ivar (cadr e)))
3356 (cadr e))
3357 (t (some #'(lambda (a)
3358 (sqrtinvolve a ivar))
3359 (cdr e)))))
3361 (defun bydif (r s d ivar)
3362 (let ((b 1) p)
3363 (setq d (m+ (m*t '*z* ivar) d))
3364 (cond ((or (zerop1 (setq p (m+ s (m*t -1 r))))
3365 (and (zerop1 (m+ 1 p))
3366 (setq b ivar)))
3367 (difap1 (dintrad0 b (m^ d '((rat) 3 2)) ivar)
3368 '((rat) 3 2) '*z* r 0))
3369 ((eq ($asksign p) '$pos)
3370 (difap1 (difap1 (dintrad0 1 (m^ (m+t 'z** d)
3371 '((rat) 3 2))
3372 ivar)
3373 '((rat) 3 2) '*z* r 0)
3374 '((rat) 3 2) 'z** p 0)))))
3376 (defun dintrad0 (n d ivar)
3377 (let (l r s)
3378 (cond ((and (mexptp d)
3379 (equal (deg-var (cadr d) ivar) 2.))
3380 (cond ((alike1 (caddr d) '((rat) 3. 2.))
3381 (cond ((and (equal n 1.)
3382 (setq l (sqdtc (cadr d) t ivar)))
3383 (tbf l))
3384 ((and (eq n ivar)
3385 (setq l (sqdtc (cadr d) nil ivar)))
3386 (tbf (reverse l)))))
3387 ((and (setq r (findp n ivar))
3388 (or (eq ($asksign (m+ -1. (m- r) (m*t 2.
3389 (caddr d))))
3390 '$pos)
3391 (diverg))
3392 (setq s (m+ '((rat) -3. 2.) (caddr d)))
3393 (eq ($asksign s) '$pos)
3394 (eq (ask-integer s '$integer) '$yes))
3395 (bydif r s (cadr d) ivar))
3396 ((polyinx n ivar nil)
3397 (radbyterm d (cdr n) ivar)))))))
3400 ;;;Looks at the IMAGINARY part of a log and puts it in the interval 0 2*%pi.
3401 (defun log-imag-0-2%pi (x)
3402 (let ((plog (simplify ($rectform `((%plog) ,x)))))
3403 ;; We take the $rectform above to make sure that the log is
3404 ;; expanded out for the situations where simplifying plog itself
3405 ;; doesn't do it. This should probably be considered a bug in the
3406 ;; plog simplifier and should be fixed there.
3407 (cond ((not (free plog '%plog))
3408 (subst '%log '%plog plog))
3410 (destructuring-let (((real . imag) (trisplit plog)))
3411 (cond ((eq ($asksign imag) '$neg)
3412 (setq imag (m+ imag %pi2)))
3413 ((eq ($asksign (m- imag %pi2)) '$pos)
3414 (setq imag (m- imag %pi2)))
3415 (t t))
3416 (m+ real (m* '$%i imag)))))))
3419 ;;; Temporary fix for a lacking in taylor, which loses with %i in denom.
3420 ;;; Besides doesn't seem like a bad thing to do in general.
3421 (defun %i-out-of-denom (exp)
3422 (let ((denom ($denom exp)))
3423 (cond ((among '$%i denom)
3424 ;; Multiply the denominator by it's conjugate to get rid of
3425 ;; %i.
3426 (let* ((den-conj (maxima-substitute (m- '$%i) '$%i denom))
3427 (num ($num exp))
3428 (new-denom (sratsimp (m* denom den-conj)))
3429 (new-exp (sratsimp (m// (m* num den-conj) new-denom))))
3430 ;; If the new denominator still contains %i, just give up.
3431 (if (among '$%i ($denom new-exp))
3433 new-exp)))
3434 (t exp))))
3436 ;;; LL and UL must be real otherwise this routine return $UNKNOWN.
3437 ;;; Returns $no $unknown or a list of poles in the interval (*ll* *ul*)
3438 ;;; for exp w.r.t. ivar.
3439 ;;; Form of list ((pole . multiplicity) (pole1 . multiplicity) ....)
3440 (defun poles-in-interval (exp ivar *ll* *ul*)
3441 (let* ((denom (cond ((mplusp exp)
3442 ($denom (sratsimp exp)))
3443 ((and (mexptp exp)
3444 (free (caddr exp) ivar)
3445 (eq ($asksign (caddr exp)) '$neg))
3446 (m^ (cadr exp) (m- (caddr exp))))
3447 (t ($denom exp))))
3448 (roots (real-roots denom ivar))
3449 (ll-pole (limit-pole exp ivar *ll* '$plus))
3450 (ul-pole (limit-pole exp ivar *ul* '$minus)))
3451 (cond ((or (eq roots '$failure)
3452 (null ll-pole)
3453 (null ul-pole)) '$unknown)
3454 ((and (or (eq roots '$no)
3455 (member ($csign denom) '($pos $neg $pn)))
3456 ;; this clause handles cases where we can't find the exact roots,
3457 ;; but we know that they occur outside the interval of integration.
3458 ;; example: integrate ((1+exp(t))/sqrt(t+exp(t)), t, 0, 1);
3459 (eq ll-pole '$no)
3460 (eq ul-pole '$no)) '$no)
3461 (t (cond ((equal roots '$no)
3462 (setq roots ())))
3463 (do ((dummy roots (cdr dummy))
3464 (pole-list (cond ((not (eq ll-pole '$no))
3465 `((,*ll* . 1)))
3466 (t nil))))
3467 ((null dummy)
3468 (cond ((not (eq ul-pole '$no))
3469 (sort-poles (push `(,*ul* . 1) pole-list)))
3470 ((not (null pole-list))
3471 (sort-poles pole-list))
3472 (t '$no)))
3473 (let* ((soltn (caar dummy))
3474 ;; (multiplicity (cdar dummy)) (not used? -- cwh)
3475 (root-in-ll-ul (in-interval soltn *ll* *ul*)))
3476 (cond ((eq root-in-ll-ul '$no) '$no)
3477 ((eq root-in-ll-ul '$yes)
3478 (let ((lim-ans (is-a-pole exp soltn ivar)))
3479 (cond ((null lim-ans)
3480 (return '$unknown))
3481 ((equal lim-ans 0)
3482 '$no)
3483 (t (push (car dummy)
3484 pole-list))))))))))))
3487 ;;;Returns $YES if there is no pole and $NO if there is one.
3488 (defun limit-pole (exp ivar limit direction)
3489 (let ((ans (cond ((member limit '($minf $inf) :test #'eq)
3490 (cond ((eq (special-convergent-formp exp limit ivar) '$yes)
3491 '$no)
3492 (t (get-limit (m* exp ivar) ivar limit direction))))
3493 (t '$no))))
3494 (cond ((eq ans '$no) '$no)
3495 ((null ans) nil)
3496 ((eq ans '$und) '$no)
3497 ((equal ans 0.) '$no)
3498 (t '$yes))))
3500 ;;;Takes care of forms that the ratio test fails on.
3501 (defun special-convergent-formp (exp limit ivar)
3502 (cond ((not (oscip-var exp ivar)) '$no)
3503 ((or (eq (sc-converg-form exp limit ivar) '$yes)
3504 (eq (exp-converg-form exp limit ivar) '$yes))
3505 '$yes)
3506 (t '$no)))
3508 (defun exp-converg-form (exp limit ivar)
3509 (let (exparg)
3510 (setq exparg (%einvolve-var exp ivar))
3511 (cond ((or (null exparg)
3512 (freeof '$%i exparg))
3513 '$no)
3514 (t (cond
3515 ((and (freeof '$%i
3516 (%einvolve-var
3517 (setq exp
3518 (sratsimp (m// exp (m^t '$%e exparg))))
3519 ivar))
3520 (equal (get-limit exp ivar limit) 0))
3521 '$yes)
3522 (t '$no))))))
3524 (defun sc-converg-form (exp limit ivar)
3525 (prog (scarg trigpow)
3526 (setq exp ($expand exp))
3527 (setq scarg (involve-var (sin-sq-cos-sq-sub exp) ivar '(%sin %cos)))
3528 (cond ((null scarg) (return '$no))
3529 ((and (polyinx scarg ivar ())
3530 (eq ($asksign (m- ($hipow scarg ivar) 1)) '$pos))
3531 (return '$yes))
3532 ((not (freeof ivar (sdiff scarg ivar)))
3533 (return '$no))
3534 ((and (setq trigpow ($hipow exp `((%sin) ,scarg)))
3535 (eq (ask-integer trigpow '$odd) '$yes)
3536 (equal (get-limit (m// exp `((%sin) ,scarg)) ivar limit)
3538 (return '$yes))
3539 ((and (setq trigpow ($hipow exp `((%cos) ,scarg)))
3540 (eq (ask-integer trigpow '$odd) '$yes)
3541 (equal (get-limit (m// exp `((%cos) ,scarg)) ivar limit)
3543 (return '$yes))
3544 (t (return '$no)))))
3546 (defun is-a-pole (exp soltn ivar)
3547 (get-limit ($radcan
3548 (m* (maxima-substitute (m+ 'epsilon soltn) ivar exp)
3549 'epsilon))
3550 'epsilon 0 '$plus))
3552 (defun in-interval (place *ll* *ul*)
3553 ;; real values for *ll* and *ul*; place can be imaginary.
3554 (let ((order (ask-greateq *ul* *ll*)))
3555 (cond ((eq order '$yes))
3556 ((eq order '$no) (let ((temp *ul*)) (setq *ul* *ll* *ll* temp)))
3557 (t (merror (intl:gettext "defint: failed to order limits of integration:~%~M")
3558 (list '(mlist simp) *ll* *ul*)))))
3559 (if (not (equal ($imagpart place) 0))
3560 '$no
3561 (let ((lesseq-ul (ask-greateq *ul* place))
3562 (greateq-ll (ask-greateq place *ll*)))
3563 (if (and (eq lesseq-ul '$yes) (eq greateq-ll '$yes)) '$yes '$no))))
3565 ;; returns true or nil
3566 (defun strictly-in-interval (place *ll* *ul*)
3567 ;; real values for *ll* and *ul*; place can be imaginary.
3568 (and (equal ($imagpart place) 0)
3569 (or (eq *ul* '$inf)
3570 (eq ($asksign (m+ *ul* (m- place))) '$pos))
3571 (or (eq *ll* '$minf)
3572 (eq ($asksign (m+ place (m- *ll*))) '$pos))))
3574 (defun real-roots (exp ivar)
3575 (let (($solvetrigwarn (cond (defintdebug t) ;Rest of the code for
3576 (t ()))) ;TRIGS in denom needed.
3577 ($solveradcan (cond ((or (among '$%i exp)
3578 (among '$%e exp)) t)
3579 (t nil)))
3580 *roots *failures) ;special vars for solve.
3581 (cond ((not (among ivar exp)) '$no)
3582 (t (solve exp ivar 1)
3583 ;; If *failures is set, we may have missed some roots.
3584 ;; We still return the roots that we have found.
3585 (do ((dummy *roots (cddr dummy))
3586 (rootlist))
3587 ((null dummy)
3588 (cond ((not (null rootlist))
3589 rootlist)
3590 (t '$no)))
3591 (cond ((equal ($imagpart (caddar dummy)) 0)
3592 (setq rootlist
3593 (cons (cons
3594 ($rectform (caddar dummy))
3595 (cadr dummy))
3596 rootlist)))))))))
3598 (defun ask-greateq (x y)
3599 ;;; Is x > y. X or Y can be $MINF or $INF, zeroA or zeroB.
3600 (let ((x (cond ((among 'zeroa x)
3601 (subst 0 'zeroa x))
3602 ((among 'zerob x)
3603 (subst 0 'zerob x))
3604 ((among 'epsilon x)
3605 (subst 0 'epsilon x))
3606 ((or (among '$inf x)
3607 (among '$minf x))
3608 ($limit x))
3609 (t x)))
3610 (y (cond ((among 'zeroa y)
3611 (subst 0 'zeroa y))
3612 ((among 'zerob y)
3613 (subst 0 'zerob y))
3614 ((among 'epsilon y)
3615 (subst 0 'epsilon y))
3616 ((or (among '$inf y)
3617 (among '$minf y))
3618 ($limit y))
3619 (t y))))
3620 (cond ((eq x '$inf)
3621 '$yes)
3622 ((eq x '$minf)
3623 '$no)
3624 ((eq y '$inf)
3625 '$no)
3626 ((eq y '$minf)
3627 '$yes)
3628 (t (let ((ans ($asksign (m+ x (m- y)))))
3629 (cond ((member ans '($zero $pos) :test #'eq)
3630 '$yes)
3631 ((eq ans '$neg)
3632 '$no)
3633 (t '$unknown)))))))
3635 (defun sort-poles (pole-list)
3636 (sort pole-list #'(lambda (x y)
3637 (cond ((eq (ask-greateq (car x) (car y))
3638 '$yes)
3639 nil)
3640 (t t)))))
3642 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3644 ;;; Integrate Definite Integrals involving log and exp functions. The algorithm
3645 ;;; are taken from the paper "Evaluation of CLasses of Definite Integrals ..."
3646 ;;; by K.O.Geddes et. al.
3648 ;;; 1. CASE: Integrals generated by the Gamma function.
3650 ;;; inf
3651 ;;; /
3652 ;;; [ w m s - m - 1
3653 ;;; I t log (t) expt(- t ) dt = s signum(s)
3654 ;;; ]
3655 ;;; /
3656 ;;; 0
3657 ;;; !
3658 ;;; m !
3659 ;;; d !
3660 ;;; (--- (gamma(z))! )
3661 ;;; m !
3662 ;;; dz ! w + 1
3663 ;;; !z = -----
3664 ;;; s
3666 ;;; The integral converges for:
3667 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3668 ;;;
3669 ;;; 2. CASE: Integrals generated by the Incomplete Gamma function.
3671 ;;; inf !
3672 ;;; / m !
3673 ;;; [ w m s d s !
3674 ;;; I t log (t) exp(- t ) dt = (--- (gamma_incomplete(a, x ))! )
3675 ;;; ] m !
3676 ;;; / da ! w + 1
3677 ;;; x !z = -----
3678 ;;; s
3679 ;;; - m - 1
3680 ;;; s signum(s)
3682 ;;; The integral converges for:
3683 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3684 ;;; The shown solution is valid for s>0. For s<0 gamma_incomplete has to be
3685 ;;; replaced by gamma(a) - gamma_incomplete(a,x^s).
3687 ;;; 3. CASE: Integrals generated by the beta function.
3689 ;;; 1
3690 ;;; /
3691 ;;; [ m s r n
3692 ;;; I log (1 - t) (1 - t) t log (t) dt =
3693 ;;; ]
3694 ;;; /
3695 ;;; 0
3696 ;;; !
3697 ;;; ! !
3698 ;;; n m ! !
3699 ;;; d d ! !
3700 ;;; --- (--- (beta(z, w))! )!
3701 ;;; n m ! !
3702 ;;; dz dw ! !
3703 ;;; !w = s + 1 !
3704 ;;; !z = r + 1
3706 ;;; The integral converges for:
3707 ;;; n, m = 0, 1, 2, ..., s > -1 and r > -1.
3708 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3710 (defvar *debug-defint-log* nil)
3712 ;;; Recognize c*z^w*log(z)^m*exp(-t^s)
3714 (defun m2-log-exp-1 (expr ivar)
3715 (when *debug-defint-log*
3716 (format t "~&M2-LOG-EXP-1 with ~A~%" expr))
3717 (m2 expr
3718 `((mtimes)
3719 (c freevar2 ,ivar)
3720 ((mexpt) (z varp2 ,ivar) (w freevar2 ,ivar))
3721 ((mexpt) $%e ((mtimes) -1 ((mexpt) (z varp2 ,ivar) (s freevar02 ,ivar))))
3722 ((mexpt) ((%log) (z varp2 ,ivar)) (m freevar2 ,ivar)))))
3724 ;;; Recognize c*z^r*log(z)^n*(1-z)^s*log(1-z)^m
3726 (defun m2-log-exp-2 (expr ivar)
3727 (when *debug-defint-log*
3728 (format t "~&M2-LOG-EXP-2 with ~A~%" expr))
3729 (m2 expr
3730 `((mtimes)
3731 (c freevar2 ,ivar)
3732 ((mexpt) (z varp2 ,ivar) (r freevar2 ,ivar))
3733 ((mexpt) ((%log) (z varp2 ,ivar)) (n freevar2 ,ivar))
3734 ((mexpt) ((mplus) 1 ((mtimes) -1 (z varp2 ,ivar))) (s freevar2 ,ivar))
3735 ((mexpt) ((%log) ((mplus) 1 ((mtimes)-1 (z varp2 ,ivar)))) (m freevar2 ,ivar)))))
3737 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3739 (defun defint-log-exp (expr ivar *ll* *ul*)
3740 (let ((x nil)
3741 (result nil)
3742 (var1 (gensym)))
3744 ;; var1 is used as a parameter for differentiation. Add var1>0 to the
3745 ;; database, to get the desired simplification of the differentiation of
3746 ;; the gamma_incomplete function.
3747 (setq *global-defint-assumptions*
3748 (cons (assume `((mgreaterp) ,var1 0))
3749 *global-defint-assumptions*))
3751 (cond
3752 ((and (eq *ul* '$inf)
3753 (setq x (m2-log-exp-1 expr ivar)))
3754 ;; The integrand matches the cases 1 and 2.
3755 (let ((c (cdras 'c x))
3756 (w (cdras 'w x))
3757 (m (cdras 'm x))
3758 (s (cdras 's x))
3759 ($gamma_expand nil)) ; No expansion of Gamma functions.
3761 (when *debug-defint-log*
3762 (format t "~&DEFINT-LOG-EXP-1:~%")
3763 (format t "~& : c = ~A~%" c)
3764 (format t "~& : w = ~A~%" w)
3765 (format t "~& : m = ~A~%" m)
3766 (format t "~& : s = ~A~%" s))
3768 (cond ((and (zerop1 *ll*)
3769 (integerp m)
3770 (>= m 0)
3771 (not (eq ($sign s) '$zero))
3772 (eq ($sign (div (add w 1) s)) '$pos))
3773 ;; Case 1: Generated by the Gamma function.
3774 (setq result
3775 (mul c
3776 (simplify (list '(%signum) s))
3777 (power s (mul -1 (add m 1)))
3778 ($at ($diff (list '(%gamma) var1) var1 m)
3779 (list '(mequal)
3780 var1
3781 (div (add w 1) s))))))
3782 ((and (member ($sign *ll*) '($pos $pz))
3783 (integerp m)
3784 (or (= m 0) (= m 1)) ; Exclude m>1, because Maxima can not
3785 ; derivate the involved hypergeometric
3786 ; functions.
3787 (or (and (eq ($sign s) '$neg)
3788 (eq ($sign (div (add 1 w) s)) '$pos))
3789 (and (eq ($sign s) '$pos)
3790 (eq ($sign (div (add 1 w) s)) '$pos))))
3791 ;; Case 2: Generated by the Incomplete Gamma function.
3792 (let ((f (if (eq ($sign s) '$pos)
3793 (list '(%gamma_incomplete) var1 (power *ll* s))
3794 (sub (list '(%gamma) var1)
3795 (list '(%gamma_incomplete) var1 (power *ll* s))))))
3796 (setq result
3797 (mul c
3798 (simplify (list '(%signum) s))
3799 (power s (mul -1 (add m 1)))
3800 ($at ($diff f var1 m)
3801 (list '(mequal) var1 (div (add 1 w) s)))))))
3803 (setq result nil)))))
3804 ((and (zerop1 *ll*)
3805 (onep1 *ul*)
3806 (setq x (m2-log-exp-2 expr ivar)))
3807 ;; Case 3: Generated by the Beta function.
3808 (let ((c (cdras 'c x))
3809 (r (cdras 'r x))
3810 (n (cdras 'n x))
3811 (s (cdras 's x))
3812 (m (cdras 'm x))
3813 (var1 (gensym))
3814 (var2 (gensym)))
3816 (when *debug-defint-log*
3817 (format t "~&DEFINT-LOG-EXP-2:~%")
3818 (format t "~& : c = ~A~%" c)
3819 (format t "~& : r = ~A~%" r)
3820 (format t "~& : n = ~A~%" n)
3821 (format t "~& : s = ~A~%" s)
3822 (format t "~& : m = ~A~%" m))
3824 (cond ((and (integerp m)
3825 (>= m 0)
3826 (integerp n)
3827 (>= n 0)
3828 (eq ($sign (add 1 r)) '$pos)
3829 (eq ($sign (add 1 s)) '$pos))
3830 (setq result
3831 (mul c
3832 ($at ($diff ($at ($diff (list '(%beta) var1 var2)
3833 var2 m)
3834 (list '(mequal) var2 (add 1 s)))
3835 var1 n)
3836 (list '(mequal) var1 (add 1 r))))))
3838 (setq result nil)))))
3840 (setq result nil)))
3841 ;; Simplify result and set $gamma_expand to global value
3842 (let (($gamma_expand $gamma_expand)) (sratsimp result))))
3844 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;