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