1 ;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancements. ;;;;;
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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
29 ;; abconv is a macsyma level flag which inhibits the absolute
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...
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
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
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
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 *mtoinf
*
130 *current-assumptions
*
131 *global-defint-assumptions
*)
132 ;;;rsn* is in comdenom. does a ratsimp of numerator.
134 (special $noprincipal
)
136 (special *roots
*failures
138 ;;LIMITP T Causes $ASKSIGN to do special things
139 ;;For DEFINT like eliminate epsilon look for prin-inf
140 ;;take realpart and imagpart.
142 ;;If LIMITP is non-null ask-integer conses
143 ;;its assumptions onto this list.
146 (defvar *loopstop
* 0)
148 (defmvar $intanalysis t
149 "When @code{true}, definite integration tries to find poles in the integrand
150 in the interval of integration.")
152 ;; Currently, if true, $solvetrigwarn is set to true. No additional
153 ;; debugging information is displayed.
154 (defvar *defintdebug
* ()
155 "If true Defint prints out some debugging information.")
159 "When NIL, print a message that the principal value of the integral has
164 "When non-NIL, a divergent integral will throw to `divergent.
165 Otherwise, an error is signaled that the integral is divergent.")
172 ;; Set to true when OSCIP-VAR returns true in DINTEGRATE.
173 (defvar *scflag
* nil
)
175 (defvar *sin-cos-recur
* nil
176 "Prevents recursion of integrals of sin and cos in intsc1.")
178 (defvar *rad-poly-recur
* nil
179 "Prevents recursion in method-radical-poly.")
181 (defvar *dintlog-recur
* nil
182 "Prevents recursion in dintlog.")
184 (defvar *dintexp-recur
* nil
185 "Prevents recursion in dintexp.")
188 (defmfun $defint
(exp ivar
*ll
* *ul
*)
190 ;; Distribute $defint over equations, lists, and matrices.
195 (mapcar #'(lambda (e)
196 (simplify ($defint e ivar
*ll
* *ul
*)))
199 (let ((*global-defint-assumptions
* ())
200 (integer-info ()) (integerl integerl
) (nonintegerl nonintegerl
))
201 (with-new-context (context)
203 (let ((*defint-assumptions
* ()) (*rad-poly-recur
* ())
204 (*sin-cos-recur
* ()) (*dintexp-recur
* ()) (*dintlog-recur
* 0.
)
205 (ans nil
) (orig-exp exp
) (orig-var ivar
)
206 (orig-ll *ll
*) (orig-ul *ul
*)
207 (*pcprntd
* nil
) (*nodiverg
* nil
) ($logabs t
) ; (limitp t)
209 ($%edispflag nil
) ; to get internal representation
210 ($m1pbranch
())) ;Try this out.
212 (make-global-assumptions) ;sets *global-defint-assumptions*
213 (setq exp
(ratdisrep exp
))
214 (setq ivar
(ratdisrep ivar
))
215 (setq *ll
* (ratdisrep *ll
*))
216 (setq *ul
* (ratdisrep *ul
*))
217 (cond (($constantp ivar
)
218 (merror (intl:gettext
"defint: variable of integration cannot be a constant; found ~M") ivar
))
219 (($subvarp ivar
) (setq ivar
(gensym))
220 (setq exp
($substitute ivar orig-var exp
))))
221 (cond ((not (atom ivar
))
222 (merror (intl:gettext
"defint: variable of integration must be a simple or subscripted variable.~%defint: found ~M") ivar
))
223 ((or (among ivar
*ul
*)
226 (setq exp
($substitute ivar orig-var exp
))))
227 (unless (lenient-extended-realp *ll
*)
228 (merror (intl:gettext
"defint: lower limit of integration must be real; found ~M") *ll
*))
229 (unless (lenient-extended-realp *ul
*)
230 (merror (intl:gettext
"defint: upper limit of integration must be real; found ~M") *ul
*))
232 (cond ((setq ans
(defint exp ivar
*ll
* *ul
*))
233 (setq ans
(subst orig-var ivar ans
))
234 (cond ((atom ans
) ans
)
235 ((and (free ans
'%limit
)
236 (free ans
'%integrate
)
237 (or (not (free ans
'$inf
))
238 (not (free ans
'$minf
))
239 (not (free ans
'$infinity
))))
241 ((not (free ans
'$und
))
242 `((%integrate
) ,orig-exp
,orig-var
,orig-ll
,orig-ul
))
244 (t `((%integrate
) ,orig-exp
,orig-var
,orig-ll
,orig-ul
))))
245 (forget-global-assumptions)))))
247 (defun eezz (exp ll ul ivar
)
248 (cond ((or (polyinx exp ivar nil
)
249 (catch 'pin%ex
(pin%ex exp ivar
)))
250 (setq exp
(antideriv exp ivar
))
251 ;; If antideriv can't do it, returns nil
252 ;; use limit to evaluate every answer returned by antideriv.
253 (cond ((null exp
) nil
)
254 (t (intsubs exp ll ul ivar
))))))
256 ;;;Hack the expression up for exponentials.
258 (defun sinintp (expr ivar
)
259 ;; Is this expr a candidate for SININT ?
260 (let ((expr (factor expr
))
263 (setq numer
($num expr
))
264 (setq denom
($denom expr
))
265 (cond ((polyinx numer ivar nil
)
266 (cond ((and (polyinx denom ivar nil
)
267 (deg-lessp denom ivar
2))
269 ;;ERF type things go here.
270 ((let ((exponent (%einvolve-var numer ivar
)))
271 (and (polyinx exponent ivar nil
)
272 (deg-lessp exponent ivar
2)))
273 (cond ((free denom ivar
)
276 (defun deg-lessp (expr ivar power
)
277 (cond ((or (atom expr
)
281 (do ((ops (cdr expr
) (cdr ops
)))
283 (cond ((not (deg-lessp (car ops
) ivar power
))
286 (and (or (not (alike1 (cadr expr
) ivar
))
287 (and (numberp (caddr expr
))
288 (not (eq (asksign (m+ power
(m- (caddr expr
))))
290 (deg-lessp (cadr expr
) ivar power
)))
292 (member 'array
(car expr
))
293 (not (eq ivar
(caar expr
))))
294 ;; We have some subscripted variable that's not our variable
295 ;; (I think), so it's deg-lessp.
297 ;; FIXME: Is this the best way to handle this? Are there
298 ;; other cases we're mising here?
301 (defun antideriv (a ivar
)
305 (setq ans
(sinint a ivar
))
306 (cond ((among '%integrate ans
) nil
)
307 (t (simplify ans
)))))
309 ;; This routine tries to take a limit a couple of ways.
310 (defun get-limit (exp ivar val
&optional
(dir '$plus dir?
))
312 (funcall #'limit-no-err exp ivar val dir
)
313 (funcall #'limit-no-err exp ivar val
))))
314 (if (and ans
(not (among '%limit ans
)))
316 (when (member val
'($inf $minf
) :test
#'eq
)
317 (setq ans
(limit-no-err (maxima-substitute (m^t ivar -
1) ivar exp
)
320 (if (eq val
'$inf
) '$plus
'$minus
)))
321 (if (among '%limit ans
) nil ans
)))))
323 (defun limit-no-err (&rest argvec
)
324 (let ((errorsw t
) (ans nil
))
325 (setq ans
(catch 'errorsw
(apply #'$limit argvec
)))
326 (if (eq ans t
) nil ans
)))
328 ;; Test whether fun2 is inverse of fun1 at val.
329 (defun test-inverse (fun1 var1 fun2 var2 val
)
330 (let* ((out1 (no-err-sub-var val fun1 var1
))
331 (out2 (no-err-sub-var out1 fun2 var2
)))
334 ;; integration change of variable
335 (defun intcv (nv flag ivar ll ul
)
336 (let ((d (bx**n
+a nv ivar
))
337 (*roots
()) (*failures
()) ($breakup
()))
338 (cond ((and (eq ul
'$inf
)
340 (equal (cadr d
) 1)) ())
341 ((eq ivar
'yx
) ; new ivar cannot be same as old ivar
344 ;; This is a hack! If nv is of the form b*x^n+a, we can
345 ;; solve the equation manually instead of using solve.
346 ;; Why? Because solve asks us for the sign of yx and
349 ;; Solve yx = b*x^n+a, for x. Any root will do. So we
350 ;; have x = ((yx-a)/b)^(1/n).
351 (destructuring-bind (a n b
)
353 (let ((root (power* (div (sub 'yx a
) b
) (inv n
))))
356 (cond (flag (intcv2 d nv ivar ll ul
))
357 (t (intcv1 d nv ivar ll ul
))))
360 (putprop 'yx t
'internal
);; keep ivar from appearing in questions to user
361 (solve (m+t
'yx
(m*t -
1 nv
)) ivar
1.
)
362 (cond ((setq d
;; look for root that is inverse of nv
363 (do* ((roots *roots
(cddr roots
))
364 (root (caddar roots
) (caddar roots
)))
366 (if (and (or (real-infinityp ll
)
367 (test-inverse nv ivar root
'yx ll
))
368 (or (real-infinityp ul
)
369 (test-inverse nv ivar root
'yx ul
)))
371 (cond (flag (intcv2 d nv ivar ll ul
))
372 (t (intcv1 d nv ivar ll ul
))))
375 ;; d: original variable (ivar) as a function of 'yx
377 ;; nv: new variable ('yx) as a function of original variable (ivar)
378 (defun intcv1 (d nv ivar ll ul
)
379 (multiple-value-bind (exp-yx ll1 ul1
)
380 (intcv2 d nv ivar ll ul
)
381 (cond ((and (equal ($imagpart ll1
) 0)
382 (equal ($imagpart ul1
) 0)
383 (not (alike1 ll1 ul1
)))
384 (defint exp-yx
'yx ll1 ul1
)))))
386 ;; converts limits of integration to values for new variable 'yx
387 (defun intcv2 (d nv ivar ll ul
)
388 (flet ((intcv3 (d nv ivar
)
389 ;; rewrites exp, the integrand in terms of ivar, the
390 ;; integrand in terms of 'yx, and returns the new
392 (let ((exp-yx (m* (sdiff d
'yx
)
393 (subst d ivar
(subst 'yx nv exp
)))))
395 (let ((exp-yx (intcv3 d nv ivar
))
397 (and (cond ((and (zerop1 (m+ ll ul
))
399 (setq exp-yx
(m* 2 exp-yx
)
400 ll1
(limcp nv ivar
0 '$plus
)))
401 (t (setq ll1
(limcp nv ivar ll
'$plus
))))
402 (setq ul1
(limcp nv ivar ul
'$minus
))
403 (values exp-yx ll1 ul1
)))))
405 ;; wrapper around limit, returns nil if
406 ;; limit not found (nounform returned), or undefined ($und or $ind)
407 (defun limcp (a b c d
)
408 (let ((ans ($limit a b c d
)))
409 (cond ((not (or (null ans
)
415 (defun integrand-changevar (d newvar exp ivar
)
419 (defun defint (exp ivar ll ul
)
420 (let ((old-assumptions *defint-assumptions
*)
421 (*current-assumptions
* ())
425 (multiple-value-setq (*current-assumptions
* ll ul
)
426 (make-defint-assumptions 'noask ivar ll ul
))
428 (format t
"new limits ~A ~A~%" ll ul
)
429 (let ((exp (resimplify exp
))
430 (ivar (resimplify ivar
))
433 ;; D (not used? -- cwh)
434 ans nn
* dn
* $noprincipal
)
435 (cond ((setq ans
(defint-list exp ivar ll ul
))
440 ((not (among ivar exp
))
441 (cond ((or (member ul
'($inf $minf
) :test
#'eq
)
442 (member ll
'($inf $minf
) :test
#'eq
))
444 (t (setq ans
(m* exp
(m+ ul
(m- ll
))))
446 ;; Look for integrals which involve log and exp functions.
447 ;; Maxima has a special algorithm to get general results.
448 ((and (setq ans
(defint-log-exp exp ivar ll ul
)))
450 (let* ((exp (rmconst1 exp ivar
))
452 (exp (%i-out-of-denom
(cdr exp
))))
453 (cond ((and (not $nointegrate
)
455 (or (among 'mqapply exp
)
456 (not (member (caar exp
)
457 '(mexpt mplus mtimes %sin %cos
458 %tan %sinh %cosh %tanh
459 %log %asin %acos %atan
462 %derivative
) :test
#'eq
))))
463 ;; Call ANTIDERIV with logabs disabled,
464 ;; because the Risch algorithm assumes
465 ;; the integral of 1/x is log(x), not log(abs(x)).
466 ;; Why not just assume logabs = false within RISCHINT itself?
467 ;; Well, there's at least one existing result which requires
468 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
469 (cond ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
470 (setq ans
(intsubs ans ll ul ivar
))
471 (return (cond (ans (m* c ans
)) (t nil
))))
473 (setq exp
(tansc-var exp ivar
))
474 (cond ((setq ans
(initial-analysis exp ivar ll ul
))
475 (return (m* c ans
))))
477 (restore-defint-assumptions old-assumptions
*current-assumptions
*))))
479 (defun defint-list (exp ivar ll ul
)
481 (let ((ans (cons (car exp
)
484 (defint sub-exp ivar ll ul
))
486 (cond (ans (simplify ans
))
490 (defun initial-analysis (exp ivar ll ul
)
491 (let ((pole (cond ((not $intanalysis
)
492 '$no
) ;don't do any checking.
493 (t (poles-in-interval exp ivar ll ul
)))))
494 (cond ((eq pole
'$no
)
495 (cond ((and (oddfn exp ivar
)
496 (or (and (eq ll
'$minf
)
498 (eq ($sign
(m+ ll ul
))
500 (t (parse-integrand exp ivar ll ul
))))
501 ((eq pole
'$unknown
) ())
502 (t (principal-value-integral exp ivar ll ul pole
)))))
504 (defun parse-integrand (exp ivar ll ul
)
506 (cond ((setq ans
(eezz exp ll ul ivar
)) ans
)
507 ((and (ratp exp ivar
)
508 (setq ans
(method-by-limits exp ivar ll ul
)))
511 (setq ans
(intbyterm exp t ivar ll ul
)))
513 ((setq ans
(method-by-limits exp ivar ll ul
)) ans
)
516 (defun rmconst1 (e ivar
)
517 (cond ((not (freeof ivar e
))
518 (partition e ivar
1))
522 (defun method-by-limits (exp ivar ll ul
)
523 (let ((old-assumptions *defint-assumptions
*))
524 (multiple-value-bind (*current-assumptions
* ll ul
)
525 (make-defint-assumptions 'noask ivar ll ul
))
527 ;;Should be a PROG inside of unwind-protect, but Multics has a compiler
528 ;;bug wrt. and I want to test this code now.
530 (cond ((and (and (eq ul
'$inf
)
532 (mtoinf exp ivar ll ul
)))
533 ((and (and (eq ul
'$inf
)
535 (ztoinf exp ivar ll ul
)))
536 ;;;This seems((and (and (eq ul '$inf)
537 ;;;fairly losing (setq exp (subin (m+ ll ivar) exp))
539 ;;; (ztoinf exp ivar)))
542 (eq ($asksign ul
) '$pos
)
544 ;; ((and (and (equal ul 1.)
545 ;; (equal ll 0.)) (zto1 exp)))
546 (t (dintegrate exp ivar ll ul
)))
547 (restore-defint-assumptions old-assumptions
*defint-assumptions
*))))
550 (defun dintegrate (exp ivar ll ul
)
551 (let ((ans nil
) (arg nil
) (*scflag
* nil
)
552 (*dflag
* nil
) ($%emode t
))
553 ;;;NOT COMPLETE for sin's and cos's.
554 (cond ((and (not *sin-cos-recur
*)
557 (intsc1 ll ul exp ivar
)))
558 ((and (not *rad-poly-recur
*)
559 (notinvolve-var exp ivar
'(%log
))
560 (not (%einvolve-var exp ivar
))
561 (method-radical-poly exp ivar ll ul
)))
562 ((and (not (equal *dintlog-recur
* 2.
))
563 (setq arg
(involve-var exp ivar
'(%log
)))
564 (dintlog exp arg ivar ll ul
)))
565 ((and (not *dintexp-recur
*)
566 (setq arg
(%einvolve-var exp ivar
))
567 (dintexp exp ivar ll ul
)))
568 ((and (not (ratp exp ivar
))
569 (setq ans
(let (($trigexpandtimes nil
)
572 (setq ans
($expand ans
))
573 (not (alike1 ans exp
))
574 (intbyterm ans t ivar ll ul
)))
575 ;; Call ANTIDERIV with logabs disabled,
576 ;; because the Risch algorithm assumes
577 ;; the integral of 1/x is log(x), not log(abs(x)).
578 ;; Why not just assume logabs = false within RISCHINT itself?
579 ;; Well, there's at least one existing result which requires
580 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
581 ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
582 (intsubs ans ll ul ivar
))
585 (defun method-radical-poly (exp ivar ll ul
)
587 (let ((*rad-poly-recur
* t
) ;recursion stopper
589 (cond ((and (sinintp exp ivar
)
590 (setq result
(antideriv exp ivar
))
591 (intsubs result ll ul ivar
)))
592 ((and (ratp exp ivar
)
593 (setq result
(ratfnt exp ivar ll ul
))))
598 (setq result
(cv exp ivar ll ul
))))
601 (defun principal-value-integral (exp ivar ll ul poles
)
602 (let ((anti-deriv ()))
603 (cond ((not (null (setq anti-deriv
(antideriv exp ivar
))))
604 (cond ((not (null poles
))
605 (multiple-value-bind (ignore new-ll new-ul
)
606 (order-limits 'ask ivar ll ul
)
607 (declare (ignore ignore
))
608 (cond ((take-principal anti-deriv new-ll new-ul ivar poles
))
611 ;; adds up integrals of ranges between each pair of poles.
612 ;; checks if whole thing is divergent as limits of integration approach poles.
613 (defun take-principal (anti-deriv ll ul ivar poles
&aux ans merged-list
)
614 ;;; calling $logcontract causes antiderivative of 1/(1-x^5) to blow up
615 ;; (setq anti-deriv (cond ((involve anti-deriv '(%log))
616 ;; ($logcontract anti-deriv))
619 (multiple-value-setq (merged-list ll ul
)
620 (interval-list poles ll ul
))
621 (do ((current-pole (cdr merged-list
) (cdr current-pole
))
622 (previous-pole merged-list
(cdr previous-pole
)))
623 ((null current-pole
) t
)
625 (intsubs anti-deriv
(m+ (caar previous-pole
) 'epsilon
)
626 (m+ (caar current-pole
) (m- 'epsilon
))
629 (setq ans
(get-limit (get-limit ans
'epsilon
0 '$plus
) 'prin-inf
'$inf
))
631 (cond ((or (null ans
)
632 (not (free ans
'$infinity
))
633 (not (free ans
'$ind
))) ())
634 ((or (among '$minf ans
)
638 (t (principal) ans
)))
640 ;; I think this takes the pole-list and replaces $MINF with -PRIN-INF
641 ;; and $INF with PRIN-INF. The lower and upper integration limits
642 ;; (ll, ul) can also be modified to be -PRIN-INF and PRIN-INF. These
643 ;; special values are used in TAKE-PRINCIPAL.
644 (defun interval-list (pole-list ll ul
)
645 (let ((first (car (first pole-list
)))
646 (last (caar (last pole-list
))))
649 (setq pole-list
(subst 'prin-inf
'$inf pole-list
))))
652 (setq pole-list
(append pole-list
(list (cons ul
'ignored
))))))
655 (setq pole-list
(subst (m- 'prin-inf
) '$minf pole-list
))))
656 (t (if (eq ll
'$minf
)
657 (setq ll
(m- 'prin-inf
)))
658 (setq pole-list
(append (list (cons ll
'ignored
)) pole-list
)))))
659 (values pole-list ll ul
))
661 ;; Assumes EXP is a rational expression with no polynomial part and
662 ;; converts the finite integration to integration over a half-infinite
663 ;; interval. The substitution y = (x-a)/(b-x) is used. Equivalently,
664 ;; x = (b*y+a)/(y+1).
666 ;; (I'm guessing CV means Change Variable here.)
667 (defun cv (exp ivar ll ul
)
668 (if (not (or (real-infinityp ll
) (real-infinityp ul
)))
669 ;; FIXME! This is a hack. We apply the transformation with
670 ;; symbolic limits and then substitute the actual limits later.
671 ;; That way method-by-limits (usually?) sees a simpler
674 ;; See Bugs 938235 and 941457. These fail because $FACTOR is
675 ;; unable to factor the transformed result. This needs more
676 ;; work (in other places).
677 (let ((trans (integrand-changevar (m// (m+t
'll
(m*t
'ul
'yx
))
680 ;; If the limit is a number, use $substitute so we simplify
681 ;; the result. Do we really want to do this?
682 (setf trans
(if (mnump ll
)
683 ($substitute ll
'll trans
)
684 (subst ll
'll trans
)))
685 (setf trans
(if (mnump ul
)
686 ($substitute ul
'ul trans
)
687 (subst ul
'ul trans
)))
688 (method-by-limits trans
'yx
0.
'$inf
))
691 ;; Integrate rational functions over a finite interval by doing the
692 ;; polynomial part directly, and converting the rational part to an
693 ;; integral from 0 to inf. This is evaluated via residues.
694 (defun ratfnt (exp ivar ll ul
)
695 (let ((e (pqr exp ivar
)))
696 ;; PQR divides the rational expression and returns the quotient
698 (flet ((try-antideriv (e lo hi
)
699 (let ((ans (antideriv e ivar
)))
701 (intsubs ans lo hi ivar
)))))
703 (cond ((equal 0.
(car e
))
704 ;; No polynomial part
705 (let ((ans (try-antideriv exp ll ul
)))
708 (cv exp ivar ll ul
))))
710 ;; Only polynomial part
711 (eezz (car e
) ll ul ivar
))
713 ;; A non-zero quotient and remainder. Combine the results
715 (let ((ans (try-antideriv (m// (cdr e
) dn
*) ll ul
)))
717 (m+t
(eezz (car e
) ll ul ivar
)
720 (m+t
(eezz (car e
) ll ul ivar
)
721 (cv (m// (cdr e
) dn
*) ivar ll ul
))))))))))
723 ;; I think this takes a rational expression E, and finds the
724 ;; polynomial part. A cons is returned. The car is the quotient and
725 ;; the cdr is the remainder.
727 (let ((varlist (list ivar
)))
729 (setq e
(cdr (ratrep* e
)))
730 (setq dn
* (pdis (ratdenominator e
)))
731 (setq e
(pdivide (ratnumerator e
) (ratdenominator e
)))
732 (cons (simplify (rdis (car e
))) (simplify (rdis (cadr e
))))))
735 (defun intbyterm (exp *nodiverg
* ivar ll ul
)
736 (let ((saved-exp exp
))
738 (let ((ans (catch 'divergent
739 (andmapcar #'(lambda (new-exp)
740 (defint new-exp ivar ll ul
))
742 (cond ((null ans
) nil
)
744 (let ((*nodiverg
* nil
))
745 (cond ((setq ans
(antideriv saved-exp ivar
))
746 (intsubs ans ll ul ivar
))
748 (t (sratsimp (m+l ans
))))))
749 ;;;If leadop isn't plus don't do anything.
752 (defun kindp34 (ivar ll ul
)
753 (let* ((d (nth-value 1 (numden-var exp ivar
)))
754 (a (cond ((and (zerop1 ($limit d ivar ll
'$plus
))
755 (eq (limit-pole (m+ exp
(m+ (m- ll
) ivar
))
760 (b (cond ((and (zerop1 ($limit d ivar ul
'$minus
))
761 (eq (limit-pole (m+ exp
(m+ ul
(m- ivar
)))
769 (cond (*nodiverg
* (throw 'divergent
'divergent
))
770 (t (merror (intl:gettext
"defint: integral is divergent.")))))
772 (defun make-defint-assumptions (ask-or-not ivar ll ul
)
775 (multiple-value-setq (result ll ul
)
776 (order-limits ask-or-not ivar ll ul
)))
778 (t (mapc 'forget
*defint-assumptions
*)
779 (setq *defint-assumptions
* ())
780 (let ((sign-ll (cond ((eq ll
'$inf
) '$pos
)
781 ((eq ll
'$minf
) '$neg
)
782 (t ($sign
($limit ll
)))))
783 (sign-ul (cond ((eq ul
'$inf
) '$pos
)
784 ((eq ul
'$minf
) '$neg
)
785 (t ($sign
($limit ul
)))))
786 (sign-ul-ll (cond ((and (eq ul
'$inf
)
787 (not (eq ll
'$inf
))) '$pos
)
789 (not (eq ll
'$minf
))) '$neg
)
790 (t ($sign
($limit
(m+ ul
(m- ll
))))))))
791 (cond ((eq sign-ul-ll
'$pos
)
792 (setq *defint-assumptions
*
793 `(,(assume `((mgreaterp) ,ivar
,ll
))
794 ,(assume `((mgreaterp) ,ul
,ivar
)))))
795 ((eq sign-ul-ll
'$neg
)
796 (setq *defint-assumptions
*
797 `(,(assume `((mgreaterp) ,ivar
,ul
))
798 ,(assume `((mgreaterp) ,ll
,ivar
))))))
799 (cond ((and (eq sign-ll
'$pos
)
801 (setq *defint-assumptions
*
802 `(,(assume `((mgreaterp) ,ivar
0))
803 ,@*defint-assumptions
*)))
804 ((and (eq sign-ll
'$neg
)
806 (setq *defint-assumptions
*
807 `(,(assume `((mgreaterp) 0 ,ivar
))
808 ,@*defint-assumptions
*)))
809 (t *defint-assumptions
*)))))
812 (defun restore-defint-assumptions (old-assumptions assumptions
)
813 (do ((llist assumptions
(cdr llist
)))
815 (forget (car llist
)))
816 (do ((llist old-assumptions
(cdr llist
)))
818 (assume (car llist
))))
820 (defun make-global-assumptions ()
821 (setq *global-defint-assumptions
*
822 (cons (assume '((mgreaterp) *z
* 0.
))
823 *global-defint-assumptions
*))
824 ;; *Z* is a "zero parameter" for this package.
825 ;; Its also used to transform.
826 ;; limit(exp,var,val,dir) -- limit(exp,tvar,0,dir)
827 (setq *global-defint-assumptions
*
828 (cons (assume '((mgreaterp) epsilon
0.
))
829 *global-defint-assumptions
*))
830 (setq *global-defint-assumptions
*
831 (cons (assume '((mlessp) epsilon
1.0e-8))
832 *global-defint-assumptions
*))
833 ;; EPSILON is used in principal value code to denote the familiar
834 ;; mathematical entity.
835 (setq *global-defint-assumptions
*
836 (cons (assume '((mgreaterp) prin-inf
1.0e+8))
837 *global-defint-assumptions
*)))
839 ;;; PRIN-INF Is a special symbol in the principal value code used to
840 ;;; denote an end-point which is proceeding to infinity.
842 (defun forget-global-assumptions ()
843 (do ((llist *global-defint-assumptions
* (cdr llist
)))
845 (forget (car llist
)))
846 (cond ((not (null integer-info
))
847 (do ((llist integer-info
(cdr llist
)))
849 (i-$remove
`(,(cadar llist
) ,(caddar llist
)))))))
851 (defun order-limits (ask-or-not ivar ll ul
)
853 (cond ((or (not (equal ($imagpart ll
) 0))
854 (not (equal ($imagpart ul
) 0))) ())
855 (t (cond ((alike1 ll
(m*t -
1 '$inf
))
857 (cond ((alike1 ul
(m*t -
1 '$inf
))
859 (cond ((alike1 ll
(m*t -
1 '$minf
))
861 (cond ((alike1 ul
(m*t -
1 '$minf
))
864 ;; We have minf <= ll = ul <= inf
867 ;; We have minf <= ll < ul = inf
870 ;; We have minf = ll < ul < inf
878 ;; so that minf < ll < ul = inf
879 (setq exp
(subin-var (m- ivar
) exp ivar
))
883 (equal (complm ask-or-not ll ul
) -
1))
884 ;; We have minf <= ul < ll
891 ;; so that minf <= ll < ul
897 (defun complm (ask-or-not ll ul
)
898 (let ((askflag (cond ((eq ask-or-not
'ask
) t
)
901 (cond ((alike1 ul ll
) 0.
)
902 ((eq (setq a
(cond (askflag ($asksign
($limit
(m+t ul
(m- ll
)))))
903 (t ($sign
($limit
(m+t ul
(m- ll
)))))))
909 ;; Substitute a and b into integral e
911 ;; Looks for discontinuties in integral, and works around them.
914 ;; integrate(x^(2*n)*exp(-(x)^2),x) ==>
915 ;; -gamma_incomplete((2*n+1)/2,x^2)*x^(2*n+1)*abs(x)^(-2*n-1)/2
917 ;; the integral has a discontinuity at x=0.
919 (defun intsubs (e a b ivar
)
920 (let ((edges (cond ((not $intanalysis
)
921 '$no
) ;don't do any checking.
922 (t (discontinuities-in-interval
923 (let (($algebraic t
))
927 (cond ((or (eq edges
'$no
)
928 (eq edges
'$unknown
))
929 (whole-intsubs e a b ivar
))
931 (do* ((l edges
(cdr l
))
934 (b1 (cadr l
) (cadr l
)))
935 ((null (cdr l
)) (if (every (lambda (x) x
) total
)
938 (whole-intsubs e a1 b1 ivar
)
941 ;; look for terms with a negative exponent
943 ;; recursively traverses exp in order to find discontinuities such as
944 ;; erfc(1/x-x) at x=0
945 (defun discontinuities-denom (exp ivar
)
947 ((and (eq (caar exp
) 'mexpt
)
948 (not (freeof ivar
(cadr exp
)))
949 (not (member ($sign
(caddr exp
)) '($pos $pz
))))
950 (m^
(cadr exp
) (m- (caddr exp
))))
952 (m*l
(mapcar #'(lambda (e)
953 (discontinuities-denom e ivar
))
956 ;; returns list of places where exp might be discontinuous in ivar.
957 ;; list begins with *ll* and ends with *ul*, and include any values between
959 ;; return '$no or '$unknown if no discontinuities found.
960 (defun discontinuities-in-interval (exp ivar ll ul
)
961 (let* ((denom (discontinuities-denom exp ivar
))
962 (roots (real-roots denom ivar
)))
963 (cond ((eq roots
'$failure
)
967 (t (do ((dummy roots
(cdr dummy
))
972 (sortgreat pole-list
)
975 (let ((soltn (caar dummy
)))
976 ;; (multiplicity (cdar dummy)) ;; not used
977 (if (strictly-in-interval soltn ll ul
)
978 (push soltn pole-list
))))))))
981 ;; Carefully substitute the integration limits A and B into the
983 (defun whole-intsubs (e a b ivar
)
984 (cond ((easy-subs e a b ivar
))
988 (format t
"BEFORE: *ll*, *ul* = ~A ~A ~A ~A~%" *ll
* *ul
* a b
)
989 (multiple-value-setq (*current-assumptions
* new-ll new-ul
)
990 (make-defint-assumptions 'ask ivar a b
)) ;get forceful!
992 (format t
"AFTER: *ll*, *ul* = ~A ~A~%" new-ll new-ul
)
994 (let (($algebraic t
))
995 (setq e
(sratsimp e
))
996 (cond ((limit-subs e a b ivar
))
997 (t (same-sheet-subs e a b ivar
))))))))
999 ;; Try easy substitutions. Return NIL if we can't.
1000 (defun easy-subs (e ll ul ivar
)
1001 (cond ((or (infinityp ll
) (infinityp ul
))
1002 ;; Infinite limits aren't easy
1005 (cond ((or (polyinx e ivar
())
1006 (and (not (involve-var e ivar
'(%log %asin %acos %atan %asinh %acosh %atanh %atan2
1007 %gamma_incomplete %expintegral_ei
)))
1008 (free ($denom e
) ivar
)))
1009 ;; It's easy if we have a polynomial. I (rtoy) think
1010 ;; it's also easy if the denominator is free of the
1011 ;; integration variable and also if the expression
1012 ;; doesn't involve inverse functions.
1014 ;; gamma_incomplete and expintegral_ie
1015 ;; included because of discontinuity in
1016 ;; gamma_incomplete(0, exp(%i*x)) and
1017 ;; expintegral_ei(exp(%i*x))
1019 ;; XXX: Are there other cases we've forgotten about?
1021 ;; So just try to substitute the limits into the
1022 ;; expression. If no errors are produced, we're done.
1023 (let ((ll-val (no-err-sub-var ll e ivar
))
1024 (ul-val (no-err-sub-var ul e ivar
)))
1025 (cond ((or (eq ll-val t
)
1027 ;; no-err-sub has returned T. An error was catched.
1029 ((and ll-val ul-val
)
1034 (defun limit-subs (e ll ul ivar
)
1035 (cond ((involve-var e ivar
'(%atan %gamma_incomplete %expintegral_ei
))
1036 ()) ; functions with discontinuities
1037 (t (setq e
($multthru e
))
1038 (let ((a1 ($limit e ivar ll
'$plus
))
1039 (a2 ($limit e ivar ul
'$minus
)))
1040 (combine-ll-ans-ul-ans a1 a2
)))))
1042 ;; check for divergent integral
1043 (defun combine-ll-ans-ul-ans (a1 a2
)
1044 (cond ((member a1
'($inf $minf $infinity
) :test
#'eq
)
1045 (cond ((member a2
'($inf $minf $infinity
) :test
#'eq
)
1046 (cond ((eq a2 a1
) ())
1049 ((member a2
'($inf $minf $infinity
) :test
#'eq
) (diverg))
1050 ((or (member a1
'($und $ind
) :test
#'eq
)
1051 (member a2
'($und $ind
) :test
#'eq
)) ())
1054 ;;;This function works only on things with ATAN's in them now.
1055 (defun same-sheet-subs (exp ll ul ivar
&aux ll-ans ul-ans
)
1056 ;; POLES-IN-INTERVAL doesn't know about the poles of tan(x). Call
1057 ;; trigsimp to convert tan into sin/cos, which POLES-IN-INTERVAL
1058 ;; knows how to handle.
1060 ;; XXX Should we fix POLES-IN-INTERVAL instead?
1062 ;; XXX Is calling trigsimp too much? Should we just only try to
1063 ;; substitute sin/cos for tan?
1065 ;; XXX Should the result try to convert sin/cos back into tan? (A
1066 ;; call to trigreduce would do it, among other things.)
1067 (let* ((exp (mfuncall '$trigsimp exp
))
1068 (poles (atan-poles exp ll ul ivar
)))
1069 ;;POLES -> ((mlist) ((mequal) ((%atan) foo) replacement) ......)
1070 ;;We can then use $SUBSTITUTE
1071 (setq ll-ans
(limcp exp ivar ll
'$plus
))
1072 (setq exp
(sratsimp ($substitute poles exp
)))
1073 (setq ul-ans
(limcp exp ivar ul
'$minus
))
1076 (combine-ll-ans-ul-ans ll-ans ul-ans
)
1079 (defun atan-poles (exp ll ul ivar
)
1080 `((mlist) ,@(atan-pole1 exp ll ul ivar
)))
1082 (defun atan-pole1 (exp ll ul ivar
&aux ipart
)
1085 ((matanp exp
) ;neglect multiplicity and '$unknowns for now.
1086 (desetq (exp . ipart
) (trisplit exp
))
1088 ((not (equal (sratsimp ipart
) 0)) ())
1089 (t (let ((pole (poles-in-interval (let (($algebraic t
))
1090 (sratsimp (cadr exp
)))
1092 (cond ((and pole
(not (or (eq pole
'$unknown
)
1094 (do ((l pole
(cdr l
)) (llist ()))
1097 ((zerop1 (m- (caar l
) ll
)) t
) ; don't worry about discontinuity
1098 ((zerop1 (m- (caar l
) ul
)) t
) ; at boundary of integration
1099 (t (let ((low-lim ($limit
(cadr exp
) ivar
(caar l
) '$minus
))
1100 (up-lim ($limit
(cadr exp
) ivar
(caar l
) '$plus
)))
1101 (cond ((and (not (eq low-lim up-lim
))
1102 (real-infinityp low-lim
)
1103 (real-infinityp up-lim
))
1104 (let ((change (if (eq low-lim
'$minf
)
1107 (setq llist
(cons `((mequal simp
) ,exp
,(m+ exp change
))
1108 llist
)))))))))))))))
1109 (t (do ((l (cdr exp
) (cdr l
))
1112 (setq llist
(append llist
(atan-pole1 (car l
) ll ul ivar
)))))))
1114 (defun difapply (ivar n d s fn1
)
1115 (prog (k m r $noprincipal
)
1116 (cond ((eq ($asksign
(m+ (deg-var d ivar
) (m- s
) (m- 2.
))) '$neg
)
1118 (setq $noprincipal t
)
1119 (cond ((or (not (mexptp d
))
1120 (not (numberp (setq r
(caddr d
)))))
1123 ;; There are no calls where fn1 is ever equal to
1124 ;; 'mtorat. Hence this case is never true. What is
1125 ;; this testing for?
1127 (equal 1.
(deg-var (cadr d
) ivar
)))
1129 (setq m
(deg-var (setq d
(cadr d
)) ivar
))
1130 (setq k
(m// (m+ s
2.
) m
))
1131 (cond ((eq (ask-integer (m// (m+ s
2.
) m
) '$any
) '$yes
)
1133 (t (setq k
(m+ 1 k
))))
1134 (cond ((eq ($sign
(m+ r
(m- k
))) '$pos
)
1135 (return (diffhk fn1 n d k
(m+ r
(m- k
)) ivar
))))))
1137 (defun diffhk (fn1 n d r m ivar
)
1140 (setq d1
(funcall fn1 n
1142 (m* r
(deg-var d ivar
))))
1143 (cond (d1 (return (difap1 d1 r
'*z
* m
0.
))))))
1145 (defun principal nil
1146 (cond ($noprincipal
(diverg))
1148 (format t
"Principal Value~%")
1149 (setq *pcprntd
* t
))))
1151 ;; e is of form poly(x)*exp(m*%i*x)
1152 ;; s is degree of denominator
1153 ;; adds e to *bptu* or *bptd* according to sign of m
1154 (defun rib (e s ivar
)
1155 (cond ((or (mnump e
) (constant e
))
1156 (setq *bptu
* (cons e
*bptu
*)))
1159 (setq e
(rmconst1 e ivar
))
1163 (multiple-value-setq (e updn
)
1164 (catch 'ptimes%e
(ptimes%e nn nd ivar
)))
1165 (cond ((null e
) nil
)
1166 (t (setq e
(m* c e
))
1167 (cond (updn (setq *bptu
* (cons e
*bptu
*)))
1168 (t (setq *bptd
* (cons e
*bptd
*))))))))))
1170 ;; Check term is of form poly(x)*exp(m*%i*x)
1171 ;; n is degree of denominator.
1172 (defun ptimes%e
(term n ivar
&aux updn
)
1173 (cond ((and (mexptp term
)
1174 (eq (cadr term
) '$%e
)
1175 (polyinx (caddr term
) ivar nil
)
1176 (eq ($sign
(m+ (deg-var ($realpart
(caddr term
)) ivar
) -
1))
1178 (eq ($sign
(m+ (deg-var (setq nn
* ($imagpart
(caddr term
))) ivar
)
1181 ;; Set updn to T if the coefficient of IVAR in the
1182 ;; polynomial is known to be positive. Otherwise set to NIL.
1183 ;; (What does updn really mean?)
1184 (setq updn
(eq ($asksign
(ratdisrep (ratcoef nn
* ivar
))) '$pos
))
1186 ((and (mtimesp term
)
1187 (setq nn
* (polfactors term ivar
))
1188 (or (null (car nn
*))
1189 (eq ($sign
(m+ n
(m- (deg-var (car nn
*) ivar
))))
1191 (not (alike1 (cadr nn
*) term
))
1192 (multiple-value-setq (term updn
)
1193 (ptimes%e
(cadr nn
*) n ivar
))
1196 (t (throw 'ptimes%e nil
))))
1198 (defun csemidown (n d ivar
)
1199 (let ((*pcprntd
* t
)) ;Not sure what to do about PRINCIPAL values here.
1201 (res-var ivar n d
#'lowerhalf
#'(lambda (x)
1202 (cond ((equal ($imagpart x
) 0) t
)
1205 (defun lowerhalf (j)
1206 (eq ($asksign
($imagpart j
)) '$neg
))
1208 (defun upperhalf (j)
1209 (eq ($asksign
($imagpart j
)) '$pos
))
1212 (defun csemiup (n d ivar
)
1213 (let ((*pcprntd
* t
)) ;I'm not sure what to do about PRINCIPAL values here.
1215 (res-var ivar n d
#'upperhalf
#'(lambda (x)
1216 (cond ((equal ($imagpart x
) 0) t
)
1220 (cond ((null n
) nil
)
1221 (t (m*t
'$%i
($rectform
(m+ (cond ((car n
)
1229 ;; exponentialize sin and cos
1230 (defun sconvert (e ivar
)
1232 ((polyinx e ivar nil
) e
)
1233 ((eq (caar e
) '%sin
)
1236 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1237 (m- (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
)))))))
1238 ((eq (caar e
) '%cos
)
1239 (mul* '((rat) 1.
2.
)
1240 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1241 (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
))))))
1243 (cons (list (caar e
)) (mapcar #'(lambda (ee)
1247 (defun polfactors (exp ivar
)
1249 (cond ((mplusp exp
) nil
)
1250 (t (cond ((mtimesp exp
)
1251 (setq exp
(reverse (cdr exp
))))
1252 (t (setq exp
(list exp
))))
1253 (mapc #'(lambda (term)
1254 (cond ((polyinx term ivar nil
)
1256 (t (push term rest
))))
1258 (list (m*l poly
) (m*l rest
))))))
1262 (cond ((atom e
) (return e
))
1263 ((not (among '$%e e
)) (return e
))
1266 (setq d
($imagpart
(caddr e
)))
1267 (return (m* (m^t
'$%e
($realpart
(caddr e
)))
1269 (m*t
'$%i
`((%sin
) ,d
))))))
1270 (t (return (simplify (cons (list (caar e
))
1271 (mapcar #'esap
(cdr e
)))))))))
1273 ;; computes integral from minf to inf for expressions of the form
1274 ;; exp(%i*m*x)*r(x) by residues on either the upper half
1275 ;; plane or the lower half plane, depending on whether
1276 ;; m is positive or negative. [wang p. 77]
1278 ;; exponentializes sin and cos before applying residue method.
1279 ;; can handle some expressions with poles on real line, such as
1281 (defun mtosc (grand ivar
)
1282 (multiple-value-bind (n d
)
1283 (numden-var grand ivar
)
1284 (let (ratterms ratans
1285 plf
*bptu
* *bptd
* s upans downans
)
1286 (cond ((not (or (polyinx d ivar nil
)
1287 (and (setq grand
(%einvolve-var d ivar
))
1289 (polyinx (setq d
(sratsimp (m// d
(m^t
'$%e grand
))))
1292 (setq n
(m// n
(m^t
'$%e grand
)))))) nil
)
1293 ((equal (setq s
(deg-var d ivar
)) 0) nil
)
1294 ;;;Above tests for applicability of this method.
1295 ((and (or (setq plf
(polfactors n ivar
)) t
)
1296 (setq n
($expand
(cond ((car plf
)
1297 (m*t
'x
* (sconvert (cadr plf
) ivar
)))
1298 (t (sconvert n ivar
)))))
1299 (cond ((mplusp n
) (setq n
(cdr n
)))
1300 (t (setq n
(list n
))))
1302 (cond ((polyinx term ivar nil
)
1303 ;; call to $expand can create rational terms
1304 ;; with no exp(m*%i*x)
1305 (setq ratterms
(cons term ratterms
)))
1308 ;;;Function RIB sets up the values of BPTU and BPTD
1310 (setq *bptu
* (subst (car plf
) 'x
* *bptu
*))
1311 (setq *bptd
* (subst (car plf
) 'x
* *bptd
*))
1312 (setq ratterms
(subst (car plf
) 'x
* ratterms
))
1313 t
) ;CROCK, CROCK. This is TERRIBLE code.
1315 ;;;If there is BPTU then CSEMIUP must succeed.
1316 ;;;Likewise for BPTD.
1319 (let (($intanalysis nil
))
1320 ;; The original integrand was already
1321 ;; determined to have no poles by initial-analysis.
1322 ;; If individual terms of the expansion have poles, the poles
1323 ;; must cancel each other out, so we can ignore them.
1324 (try-defint (m// (m+l ratterms
) d
) ivar
'$minf
'$inf
))
1326 ;; if integral of ratterms is divergent, ratans is nil,
1327 ;; and mtosc returns nil
1329 (cond (*bptu
* (setq upans
(csemiup (m+l
*bptu
*) d ivar
)))
1331 (cond (*bptd
* (setq downans
(csemidown (m+l
*bptd
*) d ivar
)))
1332 (t (setq downans
0))))
1334 (sratsimp (m+ ratans
1335 (m* '$%pi
(m+ upans
(m- downans
))))))))))
1338 (defun evenfn (e ivar
)
1339 (let ((temp (m+ (m- e
)
1341 ($substitute
(m- ivar
) ivar e
))
1342 (t ($ratsubst
(m- ivar
) ivar e
))))))
1343 (cond ((zerop1 temp
)
1345 ((zerop1 (sratsimp temp
))
1349 (defun oddfn (e ivar
)
1350 (let ((temp (m+ e
(cond ((atom ivar
)
1351 ($substitute
(m- ivar
) ivar e
))
1352 (t ($ratsubst
(m- ivar
) ivar e
))))))
1353 (cond ((zerop1 temp
)
1355 ((zerop1 (sratsimp temp
))
1359 (defun ztoinf (grand ivar ll ul
)
1360 (prog (n d sn sd varlist
1362 ans r $savefactors
*checkfactors
* temp test-var
1364 (setq $savefactors t sn
(setq sd
(list 1.
)))
1365 (cond ((eq ($sign
(m+ *loopstop
* -
1))
1368 ((setq temp
(or (scaxn grand ivar
)
1369 (ssp grand ivar ll ul
)))
1371 ((involve-var grand ivar
'(%sin %cos %tan
))
1372 (setq grand
(sconvert grand ivar
))
1375 (cond ((polyinx grand ivar nil
)
1377 ((and (ratp grand ivar
)
1379 (andmapcar #'(lambda (e)
1380 (multiple-value-bind (result new-sn new-sd
)
1381 (snumden-var e ivar sn sd
)
1387 (setq nn-var
(m*l sn
)
1389 (setq dn-var
(m*l sd
)
1391 (t (multiple-value-setq (nn-var dn-var
)
1392 (numden-var grand ivar
))))
1395 (setq n
(rmconst1 nn-var ivar
))
1396 (setq d
(rmconst1 dn-var ivar
))
1401 (cond ((polyinx d ivar nil
)
1402 (setq s
(deg-var d ivar
)))
1404 (cond ((and (setq r
(findp n ivar
))
1405 (eq (ask-integer r
'$integer
) '$yes
)
1406 (setq test-var
(bxm d s ivar
))
1407 (setq ans
(apply 'fan
(cons (m+ 1. r
) test-var
))))
1408 (return (m* (m// nc dc
) (sratsimp ans
))))
1409 ((and (ratp grand ivar
)
1410 (setq ans
(zmtorat n
(cond ((mtimesp d
) d
)
1414 (ztorat n d s ivar
))
1416 (return (m* (m// nc dc
) ans
)))
1417 ((and (evenfn d ivar
)
1418 (setq nn-var
(p*lognxp n s ivar
)))
1419 (setq ans
(log*rat
(car nn-var
) d
(cadr nn-var
) ivar
))
1420 (return (m* (m// nc dc
) ans
)))
1421 ((involve-var grand ivar
'(%log
))
1422 (cond ((setq ans
(logquad0 grand ivar
))
1423 (return (m* (m// nc dc
) ans
)))
1426 (cond ((setq temp
(batapp grand ivar ll ul
))
1430 (cond ((let ((*mtoinf
* nil
))
1431 (setq temp
(ggr grand t ivar
)))
1434 (cond ((let ((*nodiverg
* t
))
1435 (setq ans
(catch 'divergent
1436 (andmapcar #'(lambda (g)
1437 (ztoinf g ivar ll ul
))
1439 (cond ((eq ans
'divergent
) nil
)
1440 (t (return (sratsimp (m+l ans
)))))))))
1442 (cond ((and (evenfn grand ivar
)
1443 (setq *loopstop
* (m+ 1 *loopstop
*))
1444 (setq ans
(method-by-limits grand ivar
'$minf
'$inf
)))
1445 (return (m*t
'((rat) 1.
2.
) ans
)))
1448 (defun ztorat (n d s ivar
)
1449 (cond ((and (null *dflag
*)
1450 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1451 (ztorat n d s ivar
)))))
1453 ((setq n
(let ((plogabs ()))
1454 (keyhole (let ((var ivar
))
1455 (declare (special var
))
1456 ;; It's very important here to bind VAR
1457 ;; because the PLOG simplifier checks
1458 ;; for VAR. Without this, the
1459 ;; simplifier converts plog(-x) to
1460 ;; log(x)+%i*%pi, which messes up the
1462 (m* `((%plog
) ,(m- ivar
)) n
))
1467 ;; Let's not signal an error here. Return nil so that we
1468 ;; eventually return a noun form if no other algorithm gives
1471 (merror (intl:gettext
"defint: keyhole integration failed.~%"))
1474 ;;(setq *dflag* nil)
1476 (defun logquad0 (exp ivar
)
1477 (let ((a ()) (b ()) (c ()))
1478 (cond ((setq exp
(logquad exp ivar
))
1479 (setq a
(car exp
) b
(cadr exp
) c
(caddr exp
))
1480 ($asksign b
) ;let the data base know about the sign of B.
1481 (cond ((eq ($asksign c
) '$pos
)
1482 (setq c
(m^
(m// c a
) '((rat) 1.
2.
)))
1484 `((%acos
) ,(add* 'epsilon
(m// b
(mul* 2. a c
))))))
1485 (setq a
(m// (m* b
`((%log
) ,c
))
1486 (mul* a
(simplify `((%sin
) ,b
)) c
)))
1487 (get-limit a
'epsilon
0 '$plus
))))
1490 (defun logquad (exp ivar
)
1491 (let ((varlist (list ivar
)))
1493 (setq exp
(cdr (ratrep* exp
)))
1494 (cond ((and (alike1 (pdis (car exp
))
1496 (not (atom (cdr exp
)))
1497 (equal (cadr (cdr exp
)) 2.
)
1498 (not (equal (ptterm (cddr exp
) 0.
) 0.
)))
1499 (setq exp
(mapcar 'pdis
(cdr (oddelm (cdr exp
)))))))))
1501 (defun mtoinf (grand ivar ll ul
)
1502 (prog (ans ans1 sd sn pp pe n d s nc dc $savefactors
*checkfactors
* temp
1504 (setq $savefactors t
)
1505 (setq sn
(setq sd
(list 1.
)))
1506 (cond ((eq ($sign
(m+ *loopstop
* -
1)) '$pos
)
1508 ((involve-var grand ivar
'(%sin %cos
))
1509 (cond ((and (evenfn grand ivar
)
1510 (or (setq temp
(scaxn grand ivar
))
1511 (setq temp
(ssp grand ivar ll ul
))))
1512 (return (m*t
2. temp
)))
1513 ((setq temp
(mtosc grand ivar
))
1516 ((among '$%i
(%einvolve-var grand ivar
))
1517 (cond ((setq temp
(mtosc grand ivar
))
1520 (setq grand
($exponentialize grand
)) ; exponentializing before numden
1521 (cond ((polyinx grand ivar nil
) ; avoids losing multiplicities [ 1309432 ]
1523 ((and (ratp grand ivar
)
1525 (andmapcar #'(lambda (e)
1526 (multiple-value-bind (result new-sn new-sd
)
1527 (snumden-var e ivar sn sd
)
1533 (setq nn-var
(m*l sn
) sn nil
)
1534 (setq dn-var
(m*l sd
) sd nil
))
1535 (t (multiple-value-setq (nn-var dn-var
)
1536 (numden-var grand ivar
))))
1537 (setq n
(rmconst1 nn-var ivar
))
1538 (setq d
(rmconst1 dn-var ivar
))
1543 (cond ((polyinx d ivar nil
)
1544 (setq s
(deg-var d ivar
))))
1545 (cond ((and (not (%einvolve-var grand ivar
))
1546 (notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
1547 (setq pp
(findp n ivar
))
1548 (eq (ask-integer pp
'$integer
) '$yes
)
1549 (setq pe
(bxm d s ivar
)))
1550 (cond ((and (eq (ask-integer (caddr pe
) '$even
) '$yes
)
1551 (eq (ask-integer pp
'$even
) '$yes
))
1552 (cond ((setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1553 (setq ans
(m*t
2. ans
))
1554 (return (m* (m// nc dc
) ans
)))))
1555 ((equal (car pe
) 1.
)
1556 (cond ((and (setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1557 (setq nn-var
(fan (m+ 1. pp
)
1562 (setq ans
(m+ ans
(m*t
(m^ -
1 pp
) nn-var
)))
1563 (return (m* (m// nc dc
) ans
))))))))
1566 ((pppin%ex
(nd ivar
)
1567 ;; Test to see if exp is of the form p(x)*f(exp(x)). If so, set pp to
1568 ;; be p(x) and set pe to f(exp(x)).
1569 (setq nd
($factor nd
))
1570 (cond ((polyinx nd ivar nil
)
1571 (setq pp
(cons nd pp
)) t
)
1572 ((catch 'pin%ex
(pin%ex nd ivar
))
1573 (setq pe
(cons nd pe
)) t
)
1575 (andmapcar #'(lambda (ex)
1578 (cond ((and (ratp grand ivar
)
1579 (setq ans1
(zmtorat n
1580 (cond ((mtimesp d
) d
) (t ($sqfr d
)))
1583 (mtorat n d s ivar
))
1585 (setq ans
(m*t
'$%pi ans1
))
1586 (return (m* (m// nc dc
) ans
)))
1587 ((and (or (%einvolve-var grand ivar
)
1588 (involve-var grand ivar
'(%sinh %cosh %tanh
)))
1589 (pppin%ex n ivar
) ;setq's P* and PE*...Barf again.
1590 (setq ans
(catch 'pin%ex
(pin%ex d ivar
))))
1591 ;; We have an integral of the form p(x)*F(exp(x)), where
1592 ;; p(x) is a polynomial.
1595 (return (dintexp grand ivar ll ul
)))
1596 ((not (and (zerop1 (get-limit grand ivar
'$inf
))
1597 (zerop1 (get-limit grand ivar
'$minf
))))
1598 ;; These limits must exist for the integral to converge.
1600 ((setq ans
(rectzto%pi2
(m*l pp
) (m*l pe
) d ivar
))
1601 ;; This only handles the case when the F(z) is a
1602 ;; rational function.
1603 (return (m* (m// nc dc
) ans
)))
1604 ((setq ans
(log-transform (m*l pp
) (m*l pe
) d ivar ul
))
1605 ;; If we get here, F(z) is not a rational function.
1606 ;; We transform it using the substitution x=log(y)
1607 ;; which gives us an integral of the form
1608 ;; p(log(y))*F(y)/y, which maxima should be able to
1610 (return (m* (m// nc dc
) ans
)))
1612 ;; Give up. We don't know how to handle this.
1615 (cond ((setq ans
(ggrm grand ivar
))
1617 ((and (evenfn grand ivar
)
1618 (setq *loopstop
* (m+ 1 *loopstop
*))
1619 (setq ans
(method-by-limits grand ivar
0 '$inf
)))
1620 (return (m*t
2. ans
)))
1623 (defun linpower0 (exp ivar
)
1624 (cond ((and (setq exp
(linpower exp ivar
))
1625 (eq (ask-integer (caddr exp
) '$even
)
1627 (ratgreaterp 0.
(car exp
)))
1630 ;;; given (b*x+a)^n+c returns (a b n c)
1631 (defun linpower (exp ivar
)
1632 (let (linpart deg lc c varlist
)
1633 (cond ((not (polyp-var exp ivar
)) nil
)
1634 (t (let ((varlist (list ivar
)))
1636 (setq linpart
(cadr (ratrep* exp
)))
1637 (cond ((atom linpart
)
1639 (t (setq deg
(cadr linpart
))
1640 ;;;get high degree of poly
1641 (setq linpart
($diff exp ivar
(m+ deg -
1)))
1642 ;;;diff down to linear.
1643 (setq lc
(sdiff linpart ivar
))
1644 ;;;all the way to constant.
1645 (setq linpart
(sratsimp (m// linpart lc
)))
1646 (setq lc
(sratsimp (m// lc
`((mfactorial) ,deg
))))
1647 ;;;get rid of factorial from differentiation.
1648 (setq c
(sratsimp (m+ exp
(m* (m- lc
)
1649 (m^ linpart deg
)))))))
1650 ;;;Sees if can be expressed as (a*x+b)^n + part freeof x.
1651 (cond ((not (among ivar c
))
1652 `(,lc
,linpart
,deg
,c
))
1655 (defun mtorat (n d s ivar
)
1656 (let ((*semirat
* t
))
1657 (cond ((and (null *dflag
*)
1658 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1659 (mtorat n d s ivar
)))))
1661 (t (csemiup n d ivar
)))))
1663 (defun zmtorat (n d s fn1 ivar
)
1665 (cond ((eq ($sign
(m+ s
(m+ 1 (setq nn
* (deg-var n ivar
)))))
1668 ((eq ($sign
(m+ s -
4))
1671 (setq d
($factor d
))
1672 (setq c
(rmconst1 d ivar
))
1678 (setq n
(partnum n d ivar
))
1680 (setq n
($xthru
(m+l
1681 (mapcar #'(lambda (a b
)
1682 (let ((foo (funcall fn1
(car a
) b
(deg-var b ivar
))))
1683 (if foo
(m// foo
(cadr a
))
1684 (return-from zmtorat nil
))))
1687 (return (cond (c (m// n c
))
1691 (setq n
(funcall fn1 n d s
))
1692 (return (when n
(sratsimp (cond (c (m// n c
))
1695 (defun pfrnum (f g n n2 ivar
)
1696 (let ((varlist (list ivar
)) genvar
)
1697 (setq f
(polyform f
)
1701 (setq ivar
(caadr (ratrep* ivar
)))
1702 (setq f
(resprog0-var ivar f g n n2
))
1703 (list (list (pdis (cadr f
)) (pdis (cddr f
)))
1704 (list (pdis (caar f
)) (pdis (cdar f
))))))
1709 (setq f
(ratrep* e
))
1710 (and (equal (cddr f
) 1)
1712 (and (equal (length (setq d
(cddr f
))) 3)
1715 (return (list (car d
)
1717 (ptimes (cadr f
) (caddr d
)))))
1718 (merror "defint: bug from PFRNUM in RESIDU.")))
1720 (defun partnum (n dl ivar
)
1721 (let ((n2 1) ans nl
)
1722 (do ((dl dl
(cdr dl
)))
1724 (nconc ans
(ncons (list n n2
))))
1725 (setq nl
(pfrnum (car dl
) (m*l
(cdr dl
)) n n2 ivar
))
1726 (setq ans
(nconc ans
(ncons (car nl
))))
1727 (setq n2
(cadadr nl
) n
(caadr nl
) nl nil
))))
1729 (defun ggrm (e ivar
)
1730 (prog (poly expo
*mtoinf
* mb varlist genvar l c gvar
)
1731 (setq varlist
(list ivar
))
1733 (cond ((and (setq expo
(%einvolve-var e ivar
))
1734 (polyp-var (setq poly
(sratsimp (m// e
(m^t
'$%e expo
)))) ivar
)
1735 (setq l
(catch 'ggrm
(ggr (m^t
'$%e expo
) nil ivar
))))
1737 (setq mb
(m- (subin-var 0.
(cadr l
) ivar
)))
1738 (setq poly
(m+ (subin-var (m+t mb ivar
) poly ivar
)
1739 (subin-var (m+t mb
(m*t -
1 ivar
)) poly ivar
))))
1741 (setq expo
(caddr l
)
1746 (setq poly
(cdr (ratrep* poly
)))
1747 (setq mb
(m^
(pdis (cdr poly
)) -
1)
1749 (setq gvar
(caadr (ratrep* ivar
)))
1750 (cond ((or (atom poly
)
1751 (pointergp gvar
(car poly
)))
1752 (setq poly
(list 0. poly
)))
1753 (t (setq poly
(cdr poly
))))
1754 (return (do ((poly poly
(cddr poly
)))
1756 (mul* (m^t
'$%e c
) (m^t expo -
1) mb
(m+l e
)))
1757 (setq e
(cons (ggrm1 (car poly
) (pdis (cadr poly
)) l expo
)
1760 (defun ggrm1 (d k a b
)
1761 (setq b
(m// (m+t
1. d
) b
))
1762 (m* k
`((%gamma
) ,b
) (m^ a
(m- b
))))
1764 ;; Compute the integral(n/d,x,0,inf) by computing the negative of the
1765 ;; sum of residues of log(-x)*n/d over the poles of n/d inside the
1766 ;; keyhole contour. This contour is basically an disk with a slit
1767 ;; along the positive real axis. n/d must be a rational function.
1768 (defun keyhole (n d ivar
)
1769 (let* ((*semirat
* ())
1770 (res (res-var ivar n d
1772 ;; Ok if not on the positive real axis.
1773 (or (not (equal ($imagpart j
) 0))
1774 (eq ($asksign j
) '$neg
)))
1776 (cond ((eq ($asksign j
) '$pos
)
1781 ($rectform
($multthru
(m+ (cond ((car res
)
1788 ;; Look at an expression e of the form sin(r*x)^k, where k is an
1789 ;; integer. Return the list (1 r k). (Not sure if the first element
1790 ;; of the list is always 1 because I'm not sure what partition is
1791 ;; trying to do here.)
1794 (cond ((atom e
) (return nil
)))
1795 (setq e
(partition e ivar
1))
1798 (cond ((setq r
(sinrx e ivar
))
1799 (return (list m r
1)))
1801 (eq (ask-integer (setq k
(caddr e
)) '$integer
) '$yes
)
1802 (setq r
(sinrx (cadr e
) ivar
)))
1803 (return (list m r k
))))))
1805 ;; Look at an expression e of the form sin(r*x) and return r.
1806 (defun sinrx (e ivar
)
1807 (cond ((and (consp e
) (eq (caar e
) '%sin
))
1808 (cond ((eq (cadr e
) ivar
)
1810 ((and (setq e
(partition (cadr e
) ivar
1))
1816 ;; integrate(a*sc(r*x)^k/x^n,x,0,inf).
1817 (defun ssp (exp ivar ll ul
)
1819 ;; Get the argument of the involved trig function.
1820 (when (null (setq arg
(involve-var exp ivar
'(%sin %cos
))))
1822 ;; I don't think this needs to be special.
1824 (declare (special n
))
1825 ;; Replace (1-cos(arg)^2) with sin(arg)^2.
1826 (setq exp
($substitute
;(m^t `((%sin) ,ivar) 2.)
1827 ;(m+t 1. (m- (m^t `((%cos) ,ivar) 2.)))
1828 ;; The code from above generates expressions with
1829 ;; a missing simp flag. Furthermore, the
1830 ;; substitution has to be done for the complete
1831 ;; argument of the trig function. (DK 02/2010)
1832 `((mexpt simp
) ((%sin simp
) ,arg
) 2)
1833 `((mplus) 1 ((mtimes) -
1 ((mexpt) ((%cos
) ,arg
) 2)))
1835 (multiple-value-bind (u dn
)
1836 (numden-var exp ivar
)
1837 (cond ((and (setq n
(findp dn ivar
))
1838 (eq (ask-integer n
'$integer
) '$yes
))
1839 ;; n is the power of the denominator.
1840 (cond ((setq c
(skr u ivar
))
1842 (return (scmp c n ivar ll ul
)))
1844 (setq c
(andmapcar #'(lambda (uu)
1847 ;; Do this for a sum of such terms.
1848 (return (m+l
(mapcar #'(lambda (j) (scmp j n ivar ll ul
))
1851 ;; We have an integral of the form sin(r*x)^k/x^n. C is the list (1 r k).
1853 ;; The substitution y=r*x converts this integral to
1855 ;; r^(n-1)*integral(sin(y)^k/y^n,y,0,inf)
1857 ;; (If r is negative, we need to negate the result.)
1859 ;; The recursion Wang gives on p. 87 has a typo. The second term
1860 ;; should be subtracted from the first. This formula is given in G&R,
1861 ;; 3.82, formula 12.
1863 ;; integrate(sin(x)^r/x^s,x) =
1864 ;; r*(r-1)/(s-1)/(s-2)*integrate(sin(x)^(r-2)/x^(s-2),x)
1865 ;; - r^2/(s-1)/(s-2)*integrate(sin(x)^r/x^(s-2),x)
1867 ;; (Limits are assumed to be 0 to inf.)
1869 ;; This recursion ends up with integrals with s = 1 or 2 and
1871 ;; integrate(sin(x)^p/x,x,0,inf) = integrate(sin(x)^(p-1),x,0,%pi/2)
1873 ;; with p > 0 and odd. This latter integral is known to maxima, and
1874 ;; it's value is beta(p/2,1/2)/2.
1876 ;; integrate(sin(x)^2/x^2,x,0,inf) = %pi/2*binomial(q-3/2,q-1)
1880 (defun scmp (c n ivar ll ul
)
1881 ;; Compute sign(r)*r^(n-1)*integrate(sin(y)^k/y^n,y,0,inf)
1882 (destructuring-bind (mult r k
)
1884 (let ((recursion (sinsp k n
)))
1890 ;; Recursion failed. Return the integrand
1891 ;; The following code generates expressions with a missing simp flag
1892 ;; for the sin function. Use better simplifying code. (DK 02/2010)
1893 ; (let ((integrand (div (pow `((%sin) ,(m* r ivar))
1896 (let ((integrand (div (power (take '(%sin
) (mul r ivar
))
1900 `((%integrate
) ,integrand
,ivar
,ll
,ul
)))))))
1902 ;; integrate(sin(x)^n/x^2,x,0,inf) = pi/2*binomial(n-3/2,n-1).
1903 ;; Express in terms of Gamma functions, though.
1905 (m* half%pi
($makegamma
`((%binomial
) ,(m+t
(m+ n -
1) '((rat) -
1 2))
1909 ;; integrate(sin(x)^n/x,x,0,inf) = beta((n+1)/2,1/2)/2, for n odd and
1914 (t (bygamma (m+ n -
1) 0.
))))
1916 ;; This implements the recursion for computing
1917 ;; integrate(sin(y)^l/y^k,y,0,inf). (Note the change in notation from
1922 (cond ((eq ($sign
(m+ l
(m- (m+ k -
1))))
1924 ;; Integral diverges if l-(k-1) < 0.
1926 ((not (even1 (m+ l k
)))
1927 ;; If l + k is not even, return NIL. (Is this the right
1931 ;; We have integrate(sin(y)^l/y^2). Use sevn to evaluate.
1934 ;; We have integrate(sin(y)^l/y,y)
1936 ((eq ($sign
(m+ k -
2.
))
1938 (setq i
(m* (m+ k -
1)
1939 (setq j
(m+ k -
2.
))))
1940 ;; j = k-2, i = (k-1)*(k-2)
1943 ;; The main recursion:
1946 ;; = l*(l-1)/(k-1)/(k-2)*i(sin(y)^(l-2)/y^k)
1947 ;; - l^2/(k-1)/(k-1)*i(sin(y)^l/y^(k-2))
1950 (sinsp (m+ l -
2.
) j
))
1955 ;; Returns the fractional part of a?
1959 ;; Why do we return 0 if a is a number? Perhaps we really
1963 ;; If we're here, this basically assumes a is a rational.
1964 ;; Compute the remainder and return the result.
1965 (list (car a
) (rem (cadr a
) (caddr a
)) (caddr a
)))
1966 ((and (atom a
) (abless1 a
)) a
)
1969 (abless1 (caddr a
)))
1972 ;; Doesn't appear to be used anywhere in Maxima. Not sure what this
1973 ;; was intended to do.
1976 (cond ((polyinx e var nil
) 0.
)
1982 (m+l
(mapcar #'thrad e
)))))
1985 ;;; THE FOLLOWING FUNCTION IS FOR TRIG FUNCTIONS OF THE FOLLOWING TYPE:
1986 ;;; LOWER LIMIT=0 B A MULTIPLE OF %PI SCA FUNCTION OF SIN (X) COS (X)
1989 (defun period (p e ivar
)
1990 (and (alike1 (no-err-sub-var ivar e ivar
)
1991 (setq e
(no-err-sub-var (m+ p ivar
) e ivar
)))
1992 ;; means there was no error
1995 ; returns cons of (integer_part . fractional_part) of a
1997 ;; I think we really want to compute how many full periods are in a
1998 ;; and the remainder.
1999 (let* ((q (igprt (div a
(mul 2 '$%pi
))))
2000 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
2003 ; returns cons of (integer_part . fractional_part) of a
2004 (defun lower-infr (a)
2005 ;; I think we really want to compute how many full periods are in a
2006 ;; and the remainder.
2007 (let* (;(q (igprt (div a (mul 2 '$%pi))))
2008 (q (mfuncall '$ceiling
(div a
(mul 2 '$%pi
))))
2009 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
2013 ;; Return the integer part of r.
2016 (mfuncall '$floor r
))
2019 ;;;Try making exp(%i*ivar) --> yy, if result is rational then do integral
2020 ;;;around unit circle. Make corrections for limits of integration if possible.
2021 (defun scrat (sc b ivar
)
2022 (let* ((exp-form (sconvert sc ivar
)) ;Exponentialize
2023 (rat-form (maxima-substitute 'yy
(m^t
'$%e
(m*t
'$%i ivar
))
2024 exp-form
))) ;Try to make Rational fun.
2025 (cond ((and (ratp rat-form
'yy
)
2026 (not (among ivar rat-form
)))
2027 (cond ((alike1 b %pi2
)
2028 (let ((ans (zto%pi2 rat-form
'yy
)))
2032 (evenfn exp-form ivar
))
2033 (let ((ans (zto%pi2 rat-form
'yy
)))
2034 (cond (ans (m*t
'((rat) 1.
2.
) ans
))
2036 ((and (alike1 b half%pi
)
2037 (evenfn exp-form ivar
)
2039 (no-err-sub-var (m+t
'$%pi
(m*t -
1 ivar
))
2042 (let ((ans (zto%pi2 rat-form
'yy
)))
2043 (cond (ans (m*t
'((rat) 1.
4.
) ans
))
2046 ;;; Do integrals of sin and cos. this routine makes sure lower limit
2048 (defun intsc1 (a b e ivar
)
2049 ;; integrate(e,var,a,b)
2050 (let ((trigarg (find-first-trigarg e
))
2053 (*sin-cos-recur
* t
)) ;recursion stopper
2054 (prog (ans d nzp2 l int-zero-to-d int-nzp2 int-zero-to-c limit-diff
)
2055 (let* ((arg (simple-trig-arg trigarg ivar
)) ;; pattern match sin(cc*x + bb)
2058 (new-var (gensym "NEW-VAR-")))
2059 (putprop new-var t
'internal
)
2061 (not (every-trigarg-alike e trigarg
)))
2063 (when (not (and (equal cc
1) (equal bb
0)))
2064 (setq e
(div (maxima-substitute (div (sub new-var bb
) cc
)
2067 (setq ivar new-var
) ;; change of variables to get sin(new-var)
2068 (setq a
(add bb
(mul a cc
)))
2069 (setq b
(add bb
(mul b cc
)))))
2070 (setq limit-diff
(m+ b
(m* -
1 a
)))
2071 (when (or (not (period %pi2 e ivar
))
2072 (member a
*infinities
*)
2073 (member b
*infinities
*)
2074 (not (and ($constantp a
)
2076 ;; Exit if b or a is not a constant or if the integrand
2077 ;; doesn't appear to have a period of 2 pi.
2080 ;; Multiples of 2*%pi in limits.
2081 (cond ((integerp (setq d
(let (($float nil
))
2082 (m// limit-diff %pi2
))))
2083 (cond ((setq ans
(intsc e %pi2 ivar
))
2084 (return (m* d ans
)))
2087 ;; The integral is not over a full period (2*%pi) or multiple
2088 ;; of a full period.
2090 ;; Wang p. 111: The integral integrate(f(x),x,a,b) can be
2093 ;; n * integrate(f,x,0,2*%pi) + integrate(f,x,0,c)
2094 ;; - integrate(f,x,0,d)
2096 ;; for some integer n and d >= 0, c < 2*%pi because there exist
2097 ;; integers p and q such that a = 2 * p *%pi + d and b = 2 * q
2098 ;; * %pi + c. Then n = q - p.
2100 ;; Compute q and c for the upper limit b.
2105 (setq int-zero-to-d
0.
)
2107 ;; Compute p and d for the lower limit a.
2109 ;; avoid an extra trip around the circle - helps skip principal values
2110 (if (ratgreaterp (car b
) (car l
)) ; if q > p
2111 (setq l
(cons (add 1 (car l
)) ; p += 1
2112 (add (mul -
1 %pi2
) (cdr l
))))) ; d -= 2*%pi
2114 ;; Compute -integrate(f,x,0,d)
2116 (cond ((setq ans
(try-intsc e
(cdr l
) ivar
))
2119 ;; Compute n = q - p (stored in nzp2)
2120 (setq nzp2
(m+ (car b
) (m- (car l
))))
2122 ;; Compute n*integrate(f,x,0,2*%pi)
2123 (setq int-nzp2
(cond ((zerop1 nzp2
)
2126 ((setq ans
(try-intsc e %pi2 ivar
))
2127 ;; n is not zero, so compute
2128 ;; integrate(f,x,0,2*%pi)
2130 ;; Unable to compute integrate(f,x,0,2*%pi)
2132 ;; Compute integrate(f,x,0,c)
2133 (setq int-zero-to-c
(try-intsc e
(cdr b
) ivar
))
2135 (return (cond ((and int-zero-to-d int-nzp2 int-zero-to-c
)
2136 ;; All three pieces succeeded.
2137 (add* int-zero-to-d int-nzp2 int-zero-to-c
))
2138 ((ratgreaterp %pi2 limit-diff
)
2139 ;; Less than 1 full period, so intsc can integrate it.
2140 ;; Apply the substitution to make the lower limit 0.
2141 ;; This is last resort because substitution often causes intsc to fail.
2142 (intsc (maxima-substitute (m+ a ivar
) ivar e
)
2147 ;; integrate(sc, var, 0, b), where sc is f(sin(x), cos(x)).
2148 ;; calls intsc with a wrapper to just return nil if integral is divergent,
2149 ;; rather than generating an error.
2150 (defun try-intsc (sc b ivar
)
2151 (let* ((*nodiverg
* t
)
2152 (ans (catch 'divergent
(intsc sc b ivar
))))
2153 (if (eq ans
'divergent
)
2157 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)). I (rtoy)
2158 ;; think this expects b to be less than 2*%pi.
2159 (defun intsc (sc b ivar
)
2162 (multiple-value-bind (b sc
)
2163 (cond ((eq ($sign b
) '$neg
)
2165 (m* -
1 (subin-var (m*t -
1 ivar
) sc ivar
))))
2168 ;; Partition the integrand SC into the factors that do not
2169 ;; contain VAR (the car part) and the parts that do (the cdr
2171 (setq sc
(partition sc ivar
1))
2172 (cond ((setq b
(intsc0 (cdr sc
) b ivar
))
2173 (m* (resimplify (car sc
)) b
))))))
2175 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)).
2176 (defun intsc0 (sc b ivar
)
2177 ;; Determine if sc is a product of sin's and cos's.
2178 (let ((nn* (scprod sc ivar
))
2181 ;; We have a product of sin's and cos's. We handle some
2182 ;; special cases here.
2183 (cond ((alike1 b half%pi
)
2184 ;; Wang p. 110, formula (1):
2185 ;; integrate(sin(x)^m*cos(x)^n, x, 0, %pi/2) =
2186 ;; gamma((m+1)/2)*gamma((n+1)/2)/2/gamma((n+m+2)/2)
2187 (bygamma (car nn
*) (cadr nn
*)))
2189 ;; Wang p. 110, near the bottom, says
2191 ;; int(f(sin(x),cos(x)), x, 0, %pi) =
2192 ;; int(f(sin(x),cos(x)) + f(sin(x),-cos(x)),x,0,%pi/2)
2193 (cond ((eq (real-branch (cadr nn
*) -
1) '$yes
)
2194 (m* (m+ 1.
(m^ -
1 (cadr nn
*)))
2195 (bygamma (car nn
*) (cadr nn
*))))))
2197 (cond ((or (and (eq (ask-integer (car nn
*) '$even
)
2199 (eq (ask-integer (cadr nn
*) '$even
)
2201 (and (ratnump (car nn
*))
2202 (eq (real-branch (car nn
*) -
1)
2204 (ratnump (cadr nn
*))
2205 (eq (real-branch (cadr nn
*) -
1)
2207 (m* 4.
(bygamma (car nn
*) (cadr nn
*))))
2208 ((or (eq (ask-integer (car nn
*) '$odd
) '$yes
)
2209 (eq (ask-integer (cadr nn
*) '$odd
) '$yes
))
2212 ((alike1 b half%pi3
)
2213 ;; Wang, p. 111 says
2215 ;; int(f(sin(x),cos(x)),x,0,3*%pi/2) =
2216 ;; int(f(sin(x),cos(x)),x,0,%pi)
2217 ;; + int(f(-sin(x),-cos(x)),x,0,%pi/2)
2218 (m* (m+ 1.
(m^ -
1 (cadr nn
*)) (m^ -
1 (m+l nn
*)))
2219 (bygamma (car nn
*) (cadr nn
*))))))
2221 ;; We don't have a product of sin's and cos's.
2222 (cond ((and (or (eq b
'$%pi
)
2225 (setq dn
* (scrat sc b ivar
)))
2227 ((setq nn
* (antideriv sc ivar
))
2228 (sin-cos-intsubs nn
* ivar
0. b
))
2231 ;;;Is careful about substitution of limits where the denominator may be zero
2232 ;;;because of various assumptions made.
2233 (defun sin-cos-intsubs (exp ivar ll ul
)
2235 (let ((l (mapcar #'(lambda (e)
2236 (sin-cos-intsubs1 e ivar ll ul
))
2238 (if (not (some #'null l
))
2240 (t (sin-cos-intsubs1 exp ivar ll ul
))))
2242 (defun sin-cos-intsubs1 (exp ivar ll ul
)
2243 (let* ((rat-exp ($rat exp
))
2244 (denom (pdis (cddr rat-exp
))))
2245 (cond ((equal ($csign denom
) '$zero
)
2247 (t (try-intsubs exp ll ul ivar
)))))
2249 (defun try-intsubs (exp ll ul ivar
)
2250 (let* ((*nodiverg
* t
)
2251 (ans (catch 'divergent
(intsubs exp ll ul ivar
))))
2252 (if (eq ans
'divergent
)
2256 (defun try-defint (exp ivar ll ul
)
2257 (let* ((*nodiverg
* t
)
2258 (ans (catch 'divergent
(defint exp ivar ll ul
))))
2259 (if (eq ans
'divergent
)
2263 ;; Determine whether E is of the form sin(x)^m*cos(x)^n and return the
2265 (defun scprod (e ivar
)
2266 (let ((great-minus-1 #'(lambda (temp)
2267 (ratgreaterp temp -
1)))
2270 ((setq m
(powerofx e
`((%sin
) ,ivar
) great-minus-1 ivar
))
2272 ((setq n
(powerofx e
`((%cos
) ,ivar
) great-minus-1 ivar
))
2276 (or (setq m
(powerofx (cadr e
) `((%sin
) ,ivar
) great-minus-1 ivar
))
2277 (setq n
(powerofx (cadr e
) `((%cos
) ,ivar
) great-minus-1 ivar
)))
2280 (setq m
(powerofx (caddr e
) `((%sin
) ,ivar
) great-minus-1 ivar
)))
2281 (t (setq n
(powerofx (caddr e
) `((%cos
) ,ivar
) great-minus-1 ivar
))))
2286 (defun real-branch (exponent value
)
2287 ;; Says whether (m^t value exponent) has at least one real branch.
2288 ;; Only works for values of 1 and -1 now. Returns $yes $no
2290 (cond ((equal value
1.
)
2292 ((eq (ask-integer exponent
'$integer
) '$yes
)
2295 (cond ((eq ($oddp
(caddr exponent
)) t
)
2300 ;; Compute beta((m+1)/2,(n+1)/2)/2.
2301 (defun bygamma (m n
)
2302 (let ((one-half (m//t
1.
2.
)))
2303 (m* one-half
`((%beta
) ,(m* one-half
(m+t
1. m
))
2304 ,(m* one-half
(m+t
1. n
))))))
2306 ;;Seems like Guys who call this don't agree on what it should return.
2307 (defun powerofx (e x p ivar
)
2308 (setq e
(cond ((not (among ivar e
)) nil
)
2313 (not (among ivar
(caddr e
))))
2315 (cond ((null e
) nil
)
2319 ;; Check e for an expression of the form x^kk*(b*x^n+a)^l. If it
2320 ;; matches, Return the two values kk and (list l a n b).
2321 (defun bata0 (e ivar
)
2323 (cond ((atom e
) nil
)
2325 ;; We have f(x)^y. Look to see if f(x) has the desired
2326 ;; form. Then f(x)^y has the desired form too, with
2327 ;; suitably modified values.
2329 ;; XXX: Should we ask for the sign of f(x) if y is not an
2330 ;; integer? This transformation we're going to do requires
2331 ;; that f(x)^y be real.
2332 (destructuring-bind (mexp base power
)
2334 (declare (ignore mexp
))
2335 (multiple-value-bind (kk cc
)
2338 ;; Got a match. Adjust kk and cc appropriately.
2339 (destructuring-bind (l a n b
)
2341 (values (mul kk power
)
2342 (list (mul l power
) a n b
)))))))
2345 (or (and (setq k
(findp (cadr e
) ivar
))
2346 (setq c
(bxm (caddr e
) (polyinx (caddr e
) ivar nil
) ivar
)))
2347 (and (setq k
(findp (caddr e
) ivar
))
2348 (setq c
(bxm (cadr e
) (polyinx (cadr e
) ivar nil
) ivar
)))))
2350 ((setq c
(bxm e
(polyinx e ivar nil
) ivar
))
2357 ;; (COND ((NOT (BATA0 E)) (RETURN NIL))
2358 ;; ((AND (EQUAL -1. (CADDDR C))
2359 ;; (EQ ($askSIGN (SETQ K (m+ 1. K)))
2361 ;; (EQ ($askSIGN (SETQ L (m+ 1. (CAR C))))
2364 ;; (m^ UL (CADDR C)))
2365 ;; (SETQ E (CADR C))
2366 ;; (EQ ($askSIGN (SETQ C (CADDR C))) '$pos))
2367 ;; (RETURN (M// (m* (m^ UL (m+t K (m* C (m+t -1. L))))
2368 ;; `(($BETA) ,(SETQ NN* (M// K C))
2373 ;; Integrals of the form i(log(x)^m*x^k*(a+b*x^n)^l,x,0,ul). There
2374 ;; are two cases to consider: One case has ul>0, b<0, a=-b*ul^n, k>-1,
2375 ;; l>-1, n>0, m a nonnegative integer. The second case has ul=inf, l < 0.
2377 ;; These integrals are essentially partial derivatives of the Beta
2378 ;; function (i.e. the Eulerian integral of the first kind). Note
2379 ;; that, currently, with the default setting intanalysis:true, this
2380 ;; function might not even be called for some of these integrals.
2381 ;; However, this can be palliated by setting intanalysis:false.
2383 (defun zto1 (e ivar ul
)
2384 (when (or (mtimesp e
) (mexptp e
))
2386 (log (list '(%log
) ivar
)))
2389 (find-if #'(lambda (fac)
2390 (powerofx fac log
#'set-m ivar
))
2392 (when (and (freeof ivar m
)
2393 (eq (ask-integer m
'$integer
) '$yes
)
2394 (not (eq ($asksign m
) '$neg
)))
2395 (setq e
(m//t e
(list '(mexpt) log m
)))
2398 (multiple-value-bind (kk s d r cc
)
2400 ;; We have i(x^kk/(d+cc*x^r)^s,x,0,inf) =
2401 ;; beta(aa,bb)/(cc^aa*d^bb*r). Compute this, and then
2402 ;; differentiate it m times to get the log term
2405 (let* ((aa (div (add 1 ivar
) r
))
2407 (m (if (eq ($asksign m
) '$zero
)
2410 (let ((res (div `((%beta
) ,aa
,bb
)
2414 ($at
($diff res ivar m
)
2415 (list '(mequal) ivar kk
)))))))
2417 (multiple-value-bind
2418 (k/n l n b
) (batap-new e ivar ul
)
2420 (let ((beta (ftake* '%beta k
/n l
))
2421 (m (if (eq ($asksign m
) '$zero
) 0 m
)))
2422 ;; The result looks like B(k/n,l) ( ... ).
2423 ;; Perhaps, we should just $factor, instead of
2424 ;; pulling out beta like this.
2430 (m^t
(m-t b
) (m1-t l
))
2431 (m^t ul
(m*t n
(m1-t l
)))
2432 (m^t n
(m-t (m1+t m
)))
2433 ($at
($diff
(m*t
(m^t ul
(m*t n ivar
))
2434 (list '(%beta
) ivar l
))
2436 (list '(mequal) ivar k
/n
)))
2440 ;;; If e is of the form given below, make the obvious change
2441 ;;; of variables (substituting ul*x^(1/n) for x) in order to reduce
2442 ;;; e to the usual form of the integrand in the Eulerian
2443 ;;; integral of the first kind.
2444 ;;; N. B: The old version of ZTO1 completely ignored this
2445 ;;; substitution; the log(x)s were just thrown in, which,
2446 ;;; of course would give wrong results.
2448 (defun batap-new (e ivar ul
)
2450 (multiple-value-bind (k c
)
2453 ;; e=x^k*(a+b*x^n)^l
2454 (destructuring-bind (l a n b
)
2456 (when (and (freeof ivar k
)
2459 (alike1 a
(m-t (m*t b
(m^t ul n
))))
2460 (eq ($asksign b
) '$neg
)
2461 (eq ($asksign
(setq k
(m1+t k
))) '$pos
)
2462 (eq ($asksign
(setq l
(m1+t l
))) '$pos
)
2463 (eq ($asksign n
) '$pos
))
2464 (values (m//t k n
) l n b
))))))
2467 ;; Wang p. 71 gives the following formula for a beta function:
2469 ;; integrate(x^(k-1)/(c*x^r+d)^s,x,0,inf)
2470 ;; = beta(a,b)/(c^a*d^b*r)
2472 ;; where a = k/r > 0, b = s - a > 0, s > k > 0, r > 0, c*d > 0.
2474 ;; This function matches this and returns k-1, d, r, c, a, b. And
2475 ;; also checks that all the conditions hold. If not, NIL is returned.
2477 (defun batap-inf (e ivar
)
2478 (multiple-value-bind (k c
)
2481 (destructuring-bind (l d r cc
)
2483 (let* ((s (mul -
1 l
))
2487 (when (and (freeof ivar k
)
2490 (eq ($asksign kk
) '$pos
)
2491 (eq ($asksign a
) '$pos
)
2492 (eq ($asksign b
) '$pos
)
2493 (eq ($asksign
(sub s k
)) '$pos
)
2494 (eq ($asksign r
) '$pos
)
2495 (eq ($asksign
(mul cc d
)) '$pos
))
2496 (values k s d r cc
)))))))
2499 ;; Handles beta integrals.
2500 (defun batapp (e ivar ll ul
)
2501 (cond ((not (or (equal ll
0)
2503 (setq e
(subin-var (m+ ll ivar
) e ivar
))))
2504 (multiple-value-bind (k c
)
2509 (destructuring-bind (l d al c
)
2511 ;; e = x^k*(d+c*x^al)^l.
2512 (let ((new-k (m// (m+ 1 k
) al
)))
2513 (when (and (ratgreaterp al
0.
)
2514 (eq ($asksign new-k
) '$pos
)
2515 (ratgreaterp (setq l
(m* -
1 l
))
2517 (eq ($asksign
(m* d c
))
2519 (setq l
(m+ l
(m*t -
1 new-k
)))
2520 (m// `((%beta
) ,new-k
,l
)
2521 (mul* al
(m^ c new-k
) (m^ d l
))))))))))
2524 ;; Compute exp(d)*gamma((c+1)/b)/b/a^((c+1)/b). In essence, this is
2525 ;; the value of integrate(x^c*exp(d-a*x^b),x,0,inf).
2526 (defun gamma1 (c a b d
)
2528 (m^
(m* b
(m^ a
(setq c
(m// (m+t c
1) b
)))) -
1)
2531 (defun zto%pi2
(grand ivar
)
2532 (let ((result (unitcir (sratsimp (m// grand ivar
)) ivar
)))
2533 (cond (result (sratsimp (m* (m- '$%i
) result
)))
2536 ;; Evaluates the contour integral of GRAND around the unit circle
2538 (defun unitcir (grand ivar
)
2539 (multiple-value-bind (nn dn
)
2540 (numden-var grand ivar
)
2542 (result (princip (res-var ivar nn dn
2544 ;; Is pt stricly inside the unit circle?
2545 (setq sgn
(let ((limitp nil
))
2546 ($asksign
(m+ -
1 (cabs pt
)))))
2549 (declare (ignore pt
))
2550 ;; Is pt on the unit circle? (Use
2551 ;; the cached value computed
2555 (setq sgn nil
)))))))
2557 (m* '$%pi result
)))))
2560 (defun logx1 (exp ll ul ivar
)
2563 ((and (notinvolve-var exp ivar
'(%sin %cos %tan %atan %asin %acos
))
2564 (setq arg
(involve-var exp ivar
'(%log
))))
2565 (cond ((eq arg ivar
)
2566 (cond ((ratgreaterp 1. ll
)
2567 (cond ((not (eq ul
'$inf
))
2568 (intcv1 (m^t
'$%e
(m- 'yx
)) (m- `((%log
) ,ivar
)) ivar ll ul
))
2569 (t (intcv1 (m^t
'$%e
'yx
) `((%log
) ,ivar
) ivar ll ul
))))))
2570 (t (intcv arg nil ivar ll ul
)))))))
2573 ;; Wang 81-83. Unfortunately, the pdf version has page 82 as all
2574 ;; black, so here is, as best as I can tell, what Wang is doing.
2575 ;; Fortunately, p. 81 has the necessary hints.
2577 ;; First consider integrate(exp(%i*k*x^n),x) around the closed contour
2578 ;; consisting of the real axis from 0 to R, the arc from the angle 0
2579 ;; to %pi/(2*n) and the ray from the arc back to the origin.
2581 ;; There are no poles in this region, so the integral must be zero.
2582 ;; But consider the integral on the three parts. The real axis is the
2583 ;; integral we want. The return ray is
2585 ;; exp(%i*%pi/2/n) * integrate(exp(%i*k*(t*exp(%i*%pi/2/n))^n),t,R,0)
2586 ;; = exp(%i*%pi/2/n) * integrate(exp(%i*k*t^n*exp(%i*%pi/2)),t,R,0)
2587 ;; = -exp(%i*%pi/2/n) * integrate(exp(-k*t^n),t,0,R)
2589 ;; As R -> infinity, this last integral is gamma(1/n)/k^(1/n)/n.
2591 ;; We assume the integral on the circular arc approaches 0 as R ->
2592 ;; infinity. (Need to prove this.)
2596 ;; integrate(exp(%i*k*t^n),t,0,inf)
2597 ;; = exp(%i*%pi/2/n) * gamma(1/n)/k^(1/n)/n.
2599 ;; Equating real and imaginary parts gives us the desired results:
2601 ;; integrate(cos(k*t^n),t,0,inf) = G * cos(%pi/2/n)
2602 ;; integrate(sin(k*t^n),t,0,inf) = G * sin(%pi/2/n)
2604 ;; where G = gamma(1/n)/k^(1/n)/n.
2606 (defun scaxn (e ivar
)
2608 (cond ((atom e
) nil
)
2609 ((and (or (eq (caar e
) '%sin
)
2610 (eq (caar e
) '%cos
))
2612 (setq e
(bx**n
(cadr e
) ivar
)))
2613 ;; Ok, we have cos(b*x^n) or sin(b*x^n), and we set e = (n
2615 (cond ((equal (car e
) 1.
)
2616 ;; n = 1. Give up. (Why not divergent?)
2618 ((zerop (setq s
(let ((sign ($asksign
(cadr e
))))
2619 (cond ((eq sign
'$pos
) 1)
2620 ((eq sign
'$neg
) -
1)
2621 ((eq sign
'$zero
) 0)))))
2622 ;; s is the sign of b. Give up if it's zero.
2624 ((not (eq ($asksign
(m+ -
1 (car e
))) '$pos
))
2625 ;; Give up if n-1 <= 0. (Why give up? Isn't the
2626 ;; integral divergent?)
2629 ;; We can apply our formula now. g = gamma(1/n)/n/b^(1/n)
2630 (setq g
(gamma1 0.
(m* s
(cadr e
)) (car e
) 0.
))
2631 (setq e
(m* g
`((,ind
) ,(m// half%pi
(car e
)))))
2632 (m* (cond ((and (eq ind
'%sin
)
2639 ;; this is the second part of the definite integral package
2641 (defun p*lognxp
(a s ivar
)
2643 (cond ((not (among '%log a
))
2645 ((and (polyinx (setq b
(maxima-substitute 1.
`((%log
) ,ivar
) a
))
2647 (eq ($sign
(m+ s
(m+ 1 (deg-var b ivar
))))
2650 (setq a
(lognxp (sratsimp (m// a b
)) ivar
)))
2653 (defun lognxp (a ivar
)
2654 (cond ((atom a
) nil
)
2655 ((and (eq (caar a
) '%log
)
2660 (lognxp (cadr a
) ivar
))
2663 (defun logcpi0 (n d ivar
)
2664 (prog (polelist dp plm rlm factors pl rl pl1 rl1
)
2666 (polelist-var ivar d
#'upperhalf
#'(lambda (j)
2669 ((equal ($imagpart j
) 0)
2671 (cond ((null polelist
)
2673 (setq factors
(car polelist
)
2674 polelist
(cdr polelist
))
2675 (cond ((or (cadr polelist
)
2677 (setq dp
(sdiff d ivar
))))
2678 (cond ((setq plm
(car polelist
))
2679 (setq rlm
(residue-var ivar
2681 (cond (*leadcoef
* factors
)
2684 (cond ((setq pl
(cadr polelist
))
2685 (setq rl
(res1-var ivar n dp pl
))))
2686 (cond ((setq pl1
(caddr polelist
))
2687 (setq rl1
(res1-var ivar n dp pl1
))))
2692 (list (cond ((setq nn
* (append rl rlm
))
2694 (cond (rl1 (m+l rl1
)))))))
2702 (defun lognx2 (nn dn pl rl
)
2703 (do ((pl pl
(cdr pl
))
2709 (setq ans
(cons (m* dn
(car rl
)
2710 ;; AFAICT, this call to PLOG doesn't need
2712 (m^
`((%plog
) ,(car pl
)) nn
))
2715 (defun logcpj (n d i ivar plm pl rl pl1 rl1
)
2718 (list (mul* (m*t
'$%i %pi2
)
2720 ;; AFAICT, this call to PLOG doesn't need
2721 ;; to bind VAR. An example where this is
2723 ;; integrate(log(x)^2/(1+x^2),x,0,1) =
2726 (m* (m^
`((%plog
) ,ivar
) i
)
2730 (lognx2 i
(m*t
'$%i %pi2
) pl rl
)
2731 (lognx2 i %p%i pl1 rl1
)))
2734 (simplify (m+l n
))))
2736 ;; Handle integral(n(x)/d(x)*log(x)^m,x,0,inf). n and d are
2738 (defun log*rat
(n d m ivar
)
2739 (let ((i-vals (make-array (1+ m
)))
2740 (j-vals (make-array (1+ m
))))
2742 ((logcpi (n d c ivar
)
2745 (m* '((rat) 1 2) (m+ (aref j-vals c
) (m* -
1 (sumi c
))))))
2751 (push (mul* ($makegamma
`((%binomial
) ,c
,k
))
2754 (aref i-vals
(- c k
)))
2756 (setf (aref j-vals
0) 0)
2757 (prog (*leadcoef
* res
)
2758 (dotimes (c m
(return (logcpi n d m ivar
)))
2759 (multiple-value-bind (res plm factors pl rl pl1 rl1
)
2761 (setf (aref i-vals c
) res
)
2762 (setf (aref j-vals c
) (logcpj n factors c ivar plm pl rl pl1 rl1
))))))))
2764 (defun fan (p m a n b
)
2765 (let ((povern (m// p n
))
2768 ((or (eq (ask-integer povern
'$integer
) '$yes
)
2769 (not (equal ($imagpart ab
) 0))) ())
2770 (t (let ((ind ($asksign ab
)))
2771 (cond ((eq ind
'$zero
) nil
)
2772 ((eq ind
'$neg
) nil
)
2773 ((not (ratgreaterp m povern
)) nil
)
2775 ($makegamma
`((%binomial
) ,(m+ -
1 m
(m- povern
))
2777 `((mabs) ,(m^ a
(m+ povern
(m- m
)))))
2780 `((%sin
) ,(m*t
'$%pi povern
)))))))))))
2783 ;;Makes a new poly such that np(x)-np(x+2*%i*%pi)=p(x).
2784 ;;Constructs general POLY of degree one higher than P with
2785 ;;arbitrary coeff. and then solves for coeffs by equating like powers
2786 ;;of the varibale of integration.
2787 ;;Can probably be made simpler now.
2789 (defun makpoly (p ivar
)
2790 (let ((n (deg-var p ivar
)) (ans ()) (varlist ()) (gp ()) (cl ()) (zz ()))
2791 (setq ans
(genpoly (m+ 1 n
) ivar
)) ;Make poly with gensyms of 1 higher deg.
2792 (setq cl
(cdr ans
)) ;Coefficient list
2793 (setq varlist
(append cl
(list ivar
))) ;Make VAR most important.
2794 (setq gp
(car ans
)) ;This is the poly with gensym coeffs.
2795 ;;;Now, poly(x)-poly(x+2*%i*%pi)=p(x), P is the original poly.
2796 (setq ans
(m+ gp
(subin-var (m+t
(m*t
'$%i %pi2
) ivar
) (m- gp
) ivar
) (m- p
)))
2798 (setq ans
(ratrep* ans
)) ;Rational rep with VAR leading.
2799 (setq zz
(coefsolve n cl
(cond ((not (eq (caadr ans
) ;What is Lead Var.
2800 (genfind (car ans
) ivar
)))
2801 (list 0 (cadr ans
))) ;No VAR in ans.
2802 ((cdadr ans
))))) ;The real Poly.
2803 (if (or (null zz
) (null gp
))
2805 ($substitute zz gp
)))) ;Substitute Values for gensyms.
2807 (defun coefsolve (n cl e
)
2809 (eql (ncons (pdis (ptterm e n
))) (cons (pdis (ptterm e m
)) eql
))
2810 (m (m+ n -
1) (m+ m -
1)))
2811 ((signp l m
) (solvex eql cl nil nil
))))
2813 ;; Integrate(p(x)*f(exp(x))/g(exp(x)),x,minf,inf) by applying the
2814 ;; transformation y = exp(x) to get
2815 ;; integrate(p(log(y))*f(y)/g(y)/y,y,0,inf). This should be handled
2817 (defun log-transform (p pe d ivar ul
)
2818 (let ((new-p (subst (list '(%log
) ivar
) ivar p
))
2819 (new-pe (subst ivar
'z
* (catch 'pin%ex
(pin%ex pe ivar
))))
2820 (new-d (subst ivar
'z
* (catch 'pin%ex
(pin%ex d ivar
)))))
2821 (defint (div (div (mul new-p new-pe
) new-d
) ivar
) ivar
0 ul
)))
2823 ;; This implements Wang's algorithm in Chapter 5.2, pp. 98-100.
2825 ;; This is a very brief description of the algorithm. Basically, we
2826 ;; have integrate(R(exp(x))*p(x),x,minf,inf), where R(x) is a rational
2827 ;; function and p(x) is a polynomial.
2829 ;; We find a polynomial q(x) such that q(x) - q(x+2*%i*%pi) = p(x).
2830 ;; Then consider a contour integral of R(exp(z))*q(z) over a
2831 ;; rectangular contour. Opposite corners of the rectangle are (-R,
2832 ;; 2*%i*%pi) and (R, 0).
2834 ;; Wang shows that this contour integral, in the limit, is the
2835 ;; integral of R(exp(x))*q(x)-R(exp(x))*q(x+2*%i*%pi), which is
2836 ;; exactly the integral we're looking for.
2838 ;; Thus, to find the value of the contour integral, we just need the
2839 ;; residues of R(exp(z))*q(z). The only tricky part is that we want
2840 ;; the log function to have an imaginary part between 0 and 2*%pi
2841 ;; instead of -%pi to %pi.
2842 (defun rectzto%pi2
(p pe d ivar
)
2843 ;; We have R(exp(x))*p(x) represented as p(x)*pe(exp(x))/d(exp(x)).
2844 (prog (dp n pl a b c denom-exponential
)
2845 (if (not (and (setq denom-exponential
(catch 'pin%ex
(pin%ex d ivar
)))
2846 (%e-integer-coeff pe ivar
)
2847 (%e-integer-coeff d ivar
)))
2849 ;; At this point denom-exponential has converted d(exp(x)) to the
2850 ;; polynomial d(z), where z = exp(x).
2851 (setq n
(m* (cond ((null p
) -
1)
2852 (t ($expand
(m*t
'$%i %pi2
(makpoly p ivar
)))))
2854 (let ((*leadcoef
* ()))
2855 ;; Find the poles of the denominator. denom-exponential is the
2856 ;; denominator of R(x).
2858 ;; It seems as if polelist returns a list of several items.
2859 ;; The first element is a list consisting of the pole and (z -
2860 ;; pole). We don't care about this, so we take the rest of the
2862 (setq pl
(cdr (polelist-var 'z
* denom-exponential
2864 ;; The imaginary part is nonzero,
2865 ;; or the realpart is negative.
2866 (or (not (equal ($imagpart j
) 0))
2867 (eq ($asksign
($realpart j
)) '$neg
)))
2869 ;; The realpart is not zero.
2870 (not (eq ($asksign
($realpart j
)) '$zero
)))))))
2871 ;; Not sure what this does.
2873 ;; No roots at all, so return
2877 ;; We have simple roots or roots in REGION1
2878 (setq dp
(sdiff d ivar
))))
2880 ;; The cadr of pl is the list of the simple poles of
2881 ;; denom-exponential. Take the log of them to find the
2882 ;; poles of the original expression. Then compute the
2883 ;; residues at each of these poles and sum them up and put
2884 ;; the result in B. (If no simple poles set B to 0.)
2885 (setq b
(mapcar #'log-imag-0-2%pi
(cadr pl
)))
2886 (setq b
(res1-var ivar n dp b
))
2890 ;; I think this handles the case of poles outside the
2891 ;; regions. The sum of these residues are placed in C.
2892 (let ((temp (mapcar #'log-imag-0-2%pi
(caddr pl
))))
2893 (setq c
(append temp
(mapcar #'(lambda (j)
2894 (m+ (m*t
'$%i %pi2
) j
))
2896 (setq c
(res1-var ivar n dp c
))
2900 ;; We have the repeated poles of deonom-exponential, so we
2901 ;; need to convert them to the actual pole values for
2902 ;; R(exp(x)), by taking the log of the value of poles.
2903 (let ((poles (mapcar #'(lambda (p)
2904 (log-imag-0-2%pi
(car p
)))
2906 (exp (m// n
(subst (m^t
'$%e ivar
) 'z
* denom-exponential
))))
2907 ;; Compute the residues at all of these poles and sum
2909 (setq a
(mapcar #'(lambda (j)
2910 ($residue exp ivar j
))
2914 (return (sratsimp (m+ a b
(m* '((rat) 1.
2.
) c
))))))
2916 (defun genpoly (i ivar
)
2917 (do ((i i
(m+ i -
1))
2918 (c (gensym) (gensym))
2922 (cons (m+l ans
) cl
))
2923 (setq ans
(cons (m* c
(m^t ivar i
)) ans
))
2924 (setq cl
(cons c cl
))))
2926 ;; Check to see if each term in exp that is of the form exp(k*x) has
2927 ;; an integer value for k.
2928 (defun %e-integer-coeff
(exp ivar
)
2929 (cond ((mapatom exp
) t
)
2931 (eq (cadr exp
) '$%e
))
2932 (eq (ask-integer ($coeff
(caddr exp
) ivar
) '$integer
)
2934 (t (every #'(lambda (e)
2935 (%e-integer-coeff e ivar
))
2938 (defun wlinearpoly (e ivar
)
2939 (cond ((and (setq e
(polyinx e ivar t
))
2940 (equal (deg-var e ivar
) 1))
2941 (subin-var 1 e ivar
))))
2943 ;; Test to see if exp is of the form f(exp(x)), and if so, replace
2944 ;; exp(x) with 'z*. That is, basically return f(z*).
2945 (defun pin%ex
(exp ivar
)
2946 (pin%ex0
(cond ((notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
2949 (let (($exponentialize t
))
2950 (setq exp
($expand exp
)))))
2953 (defun pin%ex0
(e ivar
)
2954 ;; Does e really need to be special here? Seems to be ok without
2955 ;; it; testsuite works.
2957 (declare (special e
))
2958 (cond ((not (among ivar e
))
2961 (throw 'pin%ex nil
))
2964 (cond ((eq (caddr e
) ivar
)
2966 ((let ((linterm (wlinearpoly (caddr e
) ivar
)))
2968 (m* (subin-var 0 e ivar
) (m^t
'z
* linterm
)))))
2970 (throw 'pin%ex nil
))))
2972 (m*l
(mapcar #'(lambda (ee)
2976 (m+l
(mapcar #'(lambda (ee)
2980 (throw 'pin%ex nil
))))
2982 (defun findsub (p ivar
)
2984 (cond ((findp p ivar
) nil
)
2985 ((setq nd
(bx**n p ivar
))
2986 (m^t ivar
(car nd
)))
2987 ((setq p
(bx**n
+a p ivar
))
2988 (m* (caddr p
) (m^t ivar
(cadr p
)))))))
2990 ;; I think this is looking at f(exp(x)) and tries to find some
2991 ;; rational function R and some number k such that f(exp(x)) =
2993 (defun funclogor%e
(e ivar
)
2994 (prog (ans arg nvar r
)
2995 (cond ((or (ratp e ivar
)
2996 (involve-var e ivar
'(%sin %cos %tan
))
2997 (not (setq arg
(xor (and (setq arg
(involve-var e ivar
'(%log
)))
2999 (%einvolve-var e ivar
)))))
3001 ag
(setq nvar
(cond ((eq r
'%log
) `((%log
) ,arg
))
3002 (t (m^t
'$%e arg
))))
3003 (setq ans
(maxima-substitute (m^t
'yx -
1) (m^t nvar -
1) (maxima-substitute 'yx nvar e
)))
3004 (cond ((not (among ivar ans
)) (return (list (subst ivar
'yx ans
) nvar
)))
3006 (setq arg
(findsub arg ivar
)))
3009 ;; Integration by parts.
3011 ;; integrate(u(x)*diff(v(x),x),x,a,b)
3013 ;; = u(x)*v(x)| - integrate(v(x)*diff(u(x),x))
3016 (defun dintbypart (u v a b ivar
)
3017 ;;;SINCE ONLY CALLED FROM DINTLOG TO get RID OF LOGS - IF LOG REMAINS, QUIT
3018 (let ((ad (antideriv v ivar
)))
3019 (cond ((or (null ad
)
3020 (involve-var ad ivar
'(%log
)))
3022 (t (let ((p1 (m* u ad
))
3023 (p2 (m* ad
(sdiff u ivar
))))
3024 (let ((p1-part1 (get-limit p1 ivar b
'$minus
))
3025 (p1-part2 (get-limit p1 ivar a
'$plus
)))
3026 (cond ((or (null p1-part1
)
3029 (t (let ((p2 (defint p2 ivar a b
)))
3030 (cond (p2 (add* p1-part1
3035 ;; integrate(f(exp(k*x)),x,a,b), where f(z) is rational.
3037 ;; See Wang p. 96-97.
3039 ;; If the limits are minf to inf, we use the substitution y=exp(k*x)
3040 ;; to get integrate(f(y)/y,y,0,inf)/k. If the limits are 0 to inf,
3041 ;; use the substitution s+1=exp(k*x) to get
3042 ;; integrate(f(s+1)/(s+1),s,0,inf).
3043 (defun dintexp (exp ivar ll ul
&aux ans
)
3044 (let ((*dintexp-recur
* t
)) ;recursion stopper
3045 (cond ((and (sinintp exp ivar
) ;To be moved higher in the code.
3046 (setq ans
(antideriv exp ivar
))
3047 (setq ans
(intsubs ans ll ul ivar
)))
3048 ;; If we can integrate it directly, do so and take the
3049 ;; appropriate limits.
3051 ((setq ans
(funclogor%e exp ivar
))
3052 ;; ans is the list (f(x) exp(k*x)).
3053 (cond ((and (equal ll
0.
)
3055 ;; Use the substitution s + 1 = exp(k*x). The
3056 ;; integral becomes integrate(f(s+1)/(s+1),s,0,inf)
3057 (setq ans
(m+t -
1 (cadr ans
))))
3059 ;; Use the substitution y=exp(k*x) because the
3060 ;; limits are minf to inf.
3061 (setq ans
(cadr ans
))))
3062 ;; Apply the substitution and integrate it.
3063 (intcv ans nil ivar ll ul
)))))
3065 ;; integrate(log(g(x))*f(x),x,0,inf)
3066 (defun dintlog (exp arg ivar ll ul
)
3067 (let ((*dintlog-recur
* (1+ *dintlog-recur
*))) ;recursion stopper
3069 (cond ((and (eq ul
'$inf
)
3072 (equal 1 (sratsimp (m// exp
(m* (m- (subin-var (m^t ivar -
1)
3076 ;; Make the substitution y=1/x. If the integrand has
3077 ;; exactly the same form, the answer has to be 0.
3079 ((and (setq ans
(let (($gamma_expand t
)) (logx1 exp ll ul ivar
)))
3082 ((setq ans
(antideriv exp ivar
))
3083 ;; It's easy if we have the antiderivative.
3084 ;; but intsubs sometimes gives results containing %limit
3085 (return (intsubs ans ll ul ivar
))))
3086 ;; Ok, the easy cases didn't work. We now try integration by
3087 ;; parts. Set ANS to f(x).
3088 (setq ans
(m// exp
`((%log
) ,arg
)))
3089 (cond ((involve-var ans ivar
'(%log
))
3090 ;; Bad. f(x) contains a log term, so we give up.
3093 (equal 0.
(no-err-sub-var 0. ans ivar
))
3094 (setq d
(defint (m* ans
(m^t ivar
'*z
*))
3096 ;; The arg of the log function is the same as the
3097 ;; integration variable. We can do something a little
3098 ;; simpler than integration by parts. We have something
3099 ;; like f(x)*log(x). Consider f(x)*x^z. If we
3100 ;; differentiate this wrt to z, the integrand becomes
3101 ;; f(x)*log(x)*x^z. When we evaluate this at z = 0, we
3102 ;; get the desired integrand.
3104 ;; So we need f(0) to be 0 at 0. If we can integrate
3105 ;; f(x)*x^z, then we differentiate the result and
3106 ;; evaluate it at z = 0.
3107 (return (derivat '*z
* 1. d
0.
)))
3108 ((setq ans
(dintbypart `((%log
) ,arg
) ans ll ul ivar
))
3109 ;; Try integration by parts.
3112 ;; Compute diff(e,ivar,n) at the point pt.
3113 (defun derivat (ivar n e pt
)
3114 (subin-var pt
(apply '$diff
(list e ivar n
)) ivar
))
3118 ;; MAYBPC returns (COEF EXPO CONST)
3120 ;; This basically picks off b*x^n+a and returns the list
3122 (defun maybpc (e ivar nd-var
)
3124 (cond (*mtoinf
* (throw 'ggrm
(linpower0 e ivar
)))
3125 ((and (not *mtoinf
*)
3126 (null (setq e
(bx**n
+a e ivar
)))) ;bx**n+a --> (a n b) or nil.
3127 nil
) ;with ivar being x.
3128 ;; At this point, e is of the form (a n b)
3129 ((and (among '$%i
(caddr e
))
3130 (zerop1 ($realpart
(caddr e
)))
3131 (setq zn
($imagpart
(caddr e
)))
3132 (eq ($asksign
(cadr e
)) '$pos
))
3133 ;; If we're here, b is complex, and n > 0. zn = imagpart(b).
3135 ;; Set ivar to the same sign as zn.
3136 (cond ((eq ($asksign zn
) '$neg
)
3140 ;; zd = exp(ivar*%i*%pi*(1+nd)/(2*n). (ZD is special!)
3141 (setq zd
(m^t
'$%e
(m// (mul* ivar
'$%i
'$%pi
(m+t
1 nd-var
))
3143 ;; Return zn, n, a, zd.
3144 (values `(,(caddr e
) ,(cadr e
) ,(car e
)) zd
))
3145 ((and (or (eq (setq ivar
($asksign
($realpart
(caddr e
)))) '$neg
)
3146 (equal ivar
'$zero
))
3147 (equal ($imagpart
(cadr e
)) 0)
3148 (ratgreaterp (cadr e
) 0.
))
3149 ;; We're here if realpart(b) <= 0, and n >= 0. Then return -b, n, a.
3150 `(,(caddr e
) ,(cadr e
) ,(car e
))))))
3152 ;; Integrate x^m*exp(b*x^n+a), with realpart(m) > -1.
3154 ;; See Wang, pp. 84-85.
3156 ;; I believe the formula Wang gives is incorrect. The derivation is
3157 ;; correct except for the last step.
3159 ;; Let J = integrate(x^m*exp(%i*k*x^n),x,0,inf), with real k.
3161 ;; Consider the case for k < 0. Take a sector of a circle bounded by
3162 ;; the real line and the angle -%pi/(2*n), and by the radii, r and R.
3163 ;; Since there are no poles inside this contour, the integral
3165 ;; integrate(z^m*exp(%i*k*z^n),z) = 0
3167 ;; Then J = exp(-%pi*%i*(m+1)/(2*n))*integrate(R^m*exp(k*R^n),R,0,inf)
3169 ;; because the integral along the boundary is zero except for the part
3170 ;; on the real axis. (Proof?)
3172 ;; Wang seems to say this last integral is gamma(s/n/(-k)^s) where s =
3173 ;; (m+1)/n. But that seems wrong. If we use the substitution R =
3174 ;; (y/(-k))^(1/n), we end up with the result:
3176 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n).
3178 ;; or gamma((m+1)/n)/k^((m+1)/n)/n.
3180 ;; Note that this also handles the case of
3182 ;; integrate(x^m*exp(-k*x^n),x,0,inf);
3184 ;; where k is positive real number. A simple change of variables,
3187 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n))
3189 ;; which is the same form above.
3190 (defun ggr (e ind ivar
)
3191 (prog (c zd nn
* dn
* nd-var dosimp $%emode
)
3193 (cond (ind (setq e
($expand e
))
3194 (cond ((and (mplusp e
)
3195 (let ((*nodiverg
* t
))
3196 (setq e
(catch 'divergent
3201 (cond ((eq e
'divergent
) nil
)
3202 (t (return (sratsimp (cons '(mplus) e
)))))))))
3203 (setq e
(rmconst1 e ivar
))
3206 (cond ((multiple-value-setq (e zd
)
3207 (ggr1 e ivar nd-var
))
3208 ;; e = (m b n a). That is, the integral is of the form
3209 ;; x^m*exp(b*x^n+a). I think we want to compute
3210 ;; gamma((m+1)/n)/b^((m+1)/n)/n.
3212 ;; FIXME: If n > m + 1, the integral converges. We need
3213 ;; to check for this.
3214 (destructuring-bind (m b n a
)
3216 (when (and (not (zerop1 ($realpart b
)))
3217 (not (zerop1 ($imagpart b
))))
3218 ;; The derivation only holds if b is purely real or
3219 ;; purely imaginary. Give up if it's not.
3221 ;; Check for convergence. If b is complex, we need n -
3222 ;; m > 1. If b is real, we need b < 0.
3223 (when (and (zerop1 ($imagpart b
))
3224 (not (eq ($asksign b
) '$neg
)))
3226 (when (and (not (zerop1 ($imagpart b
)))
3227 (not (eq ($asksign
(sub n
(add m
1))) '$pos
)))
3230 (setq e
(gamma1 m
(cond ((zerop1 ($imagpart b
))
3231 ;; If we're here, b must be negative.
3234 ;; Complex b. Take the imaginary part
3235 `((mabs) ,($imagpart b
))))
3238 ;; FIXME: Why do we set %emode here? Shouldn't we just
3239 ;; bind it? And why do we want it bound to T anyway?
3240 ;; Shouldn't the user control that? The same goes for
3244 (setq e
(m* zd e
))))))
3245 (cond (e (return (m* c e
))))))
3248 ;; Match x^m*exp(b*x^n+a). If it does, return (list m b n a).
3249 (defun ggr1 (e ivar nd-var
)
3251 (cond ((atom e
) nil
)
3254 ;; We're looking at something like exp(f(ivar)). See if it's
3255 ;; of the form b*x^n+a, and return (list 0 b n a). (The 0 is
3256 ;; so we can graft something onto it if needed.)
3257 (cond ((multiple-value-setq (e zd
)
3258 (maybpc (caddr e
) ivar nd-var
))
3259 (values (cons 0. e
) zd
))))
3261 ;; E should be the product of exactly 2 terms
3263 ;; Check to see if one of the terms is of the form
3264 ;; ivar^p. If so, make sure the realpart of p > -1. If
3265 ;; so, check the other term has the right form via
3266 ;; another call to ggr1.
3267 (or (and (setq dn
* (xtorterm (cadr e
) ivar
))
3268 (ratgreaterp (setq nd-var
($realpart dn
*))
3270 (multiple-value-setq (nn* zd
)
3271 (ggr1 (caddr e
) ivar nd-var
)))
3272 (and (setq dn
* (xtorterm (caddr e
) ivar
))
3273 (ratgreaterp (setq nd-var
($realpart dn
*))
3275 (multiple-value-setq (nn* zd
)
3276 (ggr1 (cadr e
) ivar nd-var
)))))
3277 ;; Both terms have the right form and nn* contains the ivar of
3278 ;; the exponential term. Put dn* as the car of nn*. The
3279 ;; result is something like (m b n a) when we have the
3280 ;; expression x^m*exp(b*x^n+a).
3281 (values (rplaca nn
* dn
*) zd
)))))
3284 ;; Match b*x^n+a. If a match is found, return the list (a n b).
3285 ;; Otherwise, return NIL
3286 (defun bx**n
+a
(e ivar
)
3291 (t (let ((a (no-err-sub-var 0. e ivar
)))
3293 (t (setq e
(m+ e
(m*t -
1 a
)))
3294 (cond ((setq e
(bx**n e ivar
))
3298 ;; Match b*x^n. Return the list (n b) if found or NIL if not.
3299 (defun bx**n
(e ivar
)
3301 (and (setq n
(xexponget e ivar
))
3303 (setq e
(let (($maxposex
1)
3305 ($expand
(m// e
(m^t ivar n
)))))))
3308 ;; nn* should be the value of var. This is only called by bx**n with
3309 ;; the second arg of var.
3310 (defun xexponget (e nn
*)
3311 (cond ((atom e
) (cond ((eq e nn
*) 1.
)))
3315 (not (among nn
* (caddr e
))))
3317 (t (some #'(lambda (j) (xexponget j nn
*)) (cdr e
)))))
3320 ;;; given (b*x^n+a)^m returns (m a n b)
3321 (defun bxm (e ind ivar
)
3325 (involve-var e ivar
'(%log %sin %cos %tan
))
3326 (%einvolve-var e ivar
))
3329 ((mexptp e
) (cond ((among ivar
(caddr e
)) nil
)
3330 ((setq r
(bx**n
+a
(cadr e
) ivar
))
3331 (cons (caddr e
) r
))))
3332 ((setq r
(bx**n
+a e ivar
)) (cons 1. r
))
3334 ;;;Catches Unfactored forms.
3335 (multiple-value-bind (m r
)
3336 (numden-var (m// (sdiff e ivar
) e
)
3339 ((and (setq r
(bx**n
+a
(sratsimp r
) ivar
))
3340 (not (among ivar
(setq m
(m// m
(m* (cadr r
) (caddr r
)
3341 (m^t ivar
(m+t -
1 (cadr r
))))))))
3342 (setq e
(m// (subin-var 0. e ivar
) (m^t
(car r
) m
))))
3345 (t (setq e
(m^ e
(m// 1. m
)))
3346 (list m
(m* e
(car r
)) (cadr r
)
3347 (m* e
(caddr r
)))))))))
3350 ;;;Is E = VAR raised to some power? If so return power or 0.
3351 (defun findp (e ivar
)
3352 (cond ((not (among ivar e
)) 0.
)
3353 (t (xtorterm e ivar
))))
3355 (defun xtorterm (e ivar
)
3356 ;;;Is E = VAR1 raised to some power? If so return power.
3357 (cond ((alike1 e ivar
) 1.
)
3360 (alike1 (cadr e
) ivar
)
3361 (not (among ivar
(caddr e
))))
3365 (m^
(m* (m^
(caddr l
) '((rat) 1 2))
3366 (m+ (cadr l
) (m^
(m* (car l
) (caddr l
))
3370 (defun radbyterm (d l ivar
)
3375 (destructuring-let (((const . integrand
) (rmconst1 (car l
) ivar
)))
3376 (setq ans
(cons (m* const
(dintrad0 integrand d ivar
))
3379 (defun sqdtc (e ind ivar
)
3380 (prog (a b c varlist
)
3381 (setq varlist
(list ivar
))
3383 (setq e
(cdadr (ratrep* e
)))
3384 (setq c
(pdis (ptterm e
0)))
3385 (setq b
(m*t
(m//t
1 2) (pdis (ptterm e
1))))
3386 (setq a
(pdis (ptterm e
2)))
3387 (cond ((and (eq ($asksign
(m+ b
(m^
(m* a c
)
3391 (not (eq ($asksign a
) '$neg
))
3392 (eq ($asksign c
) '$pos
))
3393 (and (eq ($asksign a
) '$pos
)
3394 (not (eq ($asksign c
) '$neg
)))))
3395 (return (list a b c
))))))
3397 (defun difap1 (e pwr ivar m pt
)
3398 (m// (mul* (cond ((eq (ask-integer m
'$even
) '$yes
)
3402 (derivat ivar m e pt
))
3403 `((%gamma
) ,(m+ pwr m
))))
3405 ;; Note: This doesn't seem be called from anywhere.
3406 (defun sqrtinvolve (e ivar
)
3407 (cond ((atom e
) nil
)
3410 (and (mnump (caddr e
))
3411 (not (numberp (caddr e
)))
3412 (equal (caddr (caddr e
)) 2.
))
3413 (among ivar
(cadr e
)))
3415 (t (some #'(lambda (a)
3416 (sqrtinvolve a ivar
))
3419 (defun bydif (r s d ivar
)
3421 (setq d
(m+ (m*t
'*z
* ivar
) d
))
3422 (cond ((or (zerop1 (setq p
(m+ s
(m*t -
1 r
))))
3423 (and (zerop1 (m+ 1 p
))
3425 (difap1 (dintrad0 b
(m^ d
'((rat) 3 2)) ivar
)
3426 '((rat) 3 2) '*z
* r
0))
3427 ((eq ($asksign p
) '$pos
)
3428 (difap1 (difap1 (dintrad0 1 (m^
(m+t
'z
** d
)
3431 '((rat) 3 2) '*z
* r
0)
3432 '((rat) 3 2) 'z
** p
0)))))
3434 (defun dintrad0 (n d ivar
)
3436 (cond ((and (mexptp d
)
3437 (equal (deg-var (cadr d
) ivar
) 2.
))
3438 (cond ((alike1 (caddr d
) '((rat) 3.
2.
))
3439 (cond ((and (equal n
1.
)
3440 (setq l
(sqdtc (cadr d
) t ivar
)))
3443 (setq l
(sqdtc (cadr d
) nil ivar
)))
3444 (tbf (reverse l
)))))
3445 ((and (setq r
(findp n ivar
))
3446 (or (eq ($asksign
(m+ -
1.
(m- r
) (m*t
2.
3450 (setq s
(m+ '((rat) -
3.
2.
) (caddr d
)))
3451 (eq ($asksign s
) '$pos
)
3452 (eq (ask-integer s
'$integer
) '$yes
))
3453 (bydif r s
(cadr d
) ivar
))
3454 ((polyinx n ivar nil
)
3455 (radbyterm d
(cdr n
) ivar
)))))))
3458 ;;;Looks at the IMAGINARY part of a log and puts it in the interval 0 2*%pi.
3459 (defun log-imag-0-2%pi
(x)
3460 (let ((plog (simplify ($rectform
`((%plog
) ,x
)))))
3461 ;; We take the $rectform above to make sure that the log is
3462 ;; expanded out for the situations where simplifying plog itself
3463 ;; doesn't do it. This should probably be considered a bug in the
3464 ;; plog simplifier and should be fixed there.
3465 (cond ((not (free plog
'%plog
))
3466 (subst '%log
'%plog plog
))
3468 (destructuring-let (((real . imag
) (trisplit plog
)))
3469 (cond ((eq ($asksign imag
) '$neg
)
3470 (setq imag
(m+ imag %pi2
)))
3471 ((eq ($asksign
(m- imag %pi2
)) '$pos
)
3472 (setq imag
(m- imag %pi2
)))
3474 (m+ real
(m* '$%i imag
)))))))
3477 ;;; Temporary fix for a lacking in taylor, which loses with %i in denom.
3478 ;;; Besides doesn't seem like a bad thing to do in general.
3479 (defun %i-out-of-denom
(exp)
3480 (let ((denom ($denom exp
)))
3481 (cond ((among '$%i denom
)
3482 ;; Multiply the denominator by it's conjugate to get rid of
3484 (let* ((den-conj (maxima-substitute (m- '$%i
) '$%i denom
))
3486 (new-denom (sratsimp (m* denom den-conj
)))
3487 (new-exp (sratsimp (m// (m* num den-conj
) new-denom
))))
3488 ;; If the new denominator still contains %i, just give up.
3489 (if (among '$%i
($denom new-exp
))
3494 ;;; LL and UL must be real otherwise this routine return $UNKNOWN.
3495 ;;; Returns $no $unknown or a list of poles in the interval (ll ul)
3496 ;;; for exp w.r.t. ivar.
3497 ;;; Form of list ((pole . multiplicity) (pole1 . multiplicity) ....)
3498 (defun poles-in-interval (exp ivar ll ul
)
3499 (let* ((denom (cond ((mplusp exp
)
3500 ($denom
(sratsimp exp
)))
3502 (free (caddr exp
) ivar
)
3503 (eq ($asksign
(caddr exp
)) '$neg
))
3504 (m^
(cadr exp
) (m- (caddr exp
))))
3506 (roots (real-roots denom ivar
))
3507 (ll-pole (limit-pole exp ivar ll
'$plus
))
3508 (ul-pole (limit-pole exp ivar ul
'$minus
)))
3509 (cond ((or (eq roots
'$failure
)
3511 (null ul-pole
)) '$unknown
)
3512 ((and (or (eq roots
'$no
)
3513 (member ($csign denom
) '($pos $neg $pn
)))
3514 ;; this clause handles cases where we can't find the exact roots,
3515 ;; but we know that they occur outside the interval of integration.
3516 ;; example: integrate ((1+exp(t))/sqrt(t+exp(t)), t, 0, 1);
3518 (eq ul-pole
'$no
)) '$no
)
3519 (t (cond ((equal roots
'$no
)
3521 (do ((dummy roots
(cdr dummy
))
3522 (pole-list (cond ((not (eq ll-pole
'$no
))
3526 (cond ((not (eq ul-pole
'$no
))
3527 (sort-poles (push `(,ul .
1) pole-list
)))
3528 ((not (null pole-list
))
3529 (sort-poles pole-list
))
3531 (let* ((soltn (caar dummy
))
3532 ;; (multiplicity (cdar dummy)) (not used? -- cwh)
3533 (root-in-ll-ul (in-interval soltn ll ul
)))
3534 (cond ((eq root-in-ll-ul
'$no
) '$no
)
3535 ((eq root-in-ll-ul
'$yes
)
3536 (let ((lim-ans (is-a-pole exp soltn ivar
)))
3537 (cond ((null lim-ans
)
3541 (t (push (car dummy
)
3542 pole-list
))))))))))))
3545 ;;;Returns $YES if there is no pole and $NO if there is one.
3546 (defun limit-pole (exp ivar limit direction
)
3547 (let ((ans (cond ((member limit
'($minf $inf
) :test
#'eq
)
3548 (cond ((eq (special-convergent-formp exp limit ivar
) '$yes
)
3550 (t (get-limit (m* exp ivar
) ivar limit direction
))))
3552 (cond ((eq ans
'$no
) '$no
)
3554 ((eq ans
'$und
) '$no
)
3555 ((equal ans
0.
) '$no
)
3558 ;;;Takes care of forms that the ratio test fails on.
3559 (defun special-convergent-formp (exp limit ivar
)
3560 (cond ((not (oscip-var exp ivar
)) '$no
)
3561 ((or (eq (sc-converg-form exp limit ivar
) '$yes
)
3562 (eq (exp-converg-form exp limit ivar
) '$yes
))
3566 (defun exp-converg-form (exp limit ivar
)
3568 (setq exparg
(%einvolve-var exp ivar
))
3569 (cond ((or (null exparg
)
3570 (freeof '$%i exparg
))
3576 (sratsimp (m// exp
(m^t
'$%e exparg
))))
3578 (equal (get-limit exp ivar limit
) 0))
3582 (defun sc-converg-form (exp limit ivar
)
3583 (prog (scarg trigpow
)
3584 (setq exp
($expand exp
))
3585 (setq scarg
(involve-var (sin-sq-cos-sq-sub exp
) ivar
'(%sin %cos
)))
3586 (cond ((null scarg
) (return '$no
))
3587 ((and (polyinx scarg ivar
())
3588 (eq ($asksign
(m- ($hipow scarg ivar
) 1)) '$pos
))
3590 ((not (freeof ivar
(sdiff scarg ivar
)))
3592 ((and (setq trigpow
($hipow exp
`((%sin
) ,scarg
)))
3593 (eq (ask-integer trigpow
'$odd
) '$yes
)
3594 (equal (get-limit (m// exp
`((%sin
) ,scarg
)) ivar limit
)
3597 ((and (setq trigpow
($hipow exp
`((%cos
) ,scarg
)))
3598 (eq (ask-integer trigpow
'$odd
) '$yes
)
3599 (equal (get-limit (m// exp
`((%cos
) ,scarg
)) ivar limit
)
3602 (t (return '$no
)))))
3604 (defun is-a-pole (exp soltn ivar
)
3606 (m* (maxima-substitute (m+ 'epsilon soltn
) ivar exp
)
3610 (defun in-interval (place ll ul
)
3611 ;; real values for ll and ul; place can be imaginary.
3612 (let ((order (ask-greateq ul ll
)))
3613 (cond ((eq order
'$yes
))
3614 ((eq order
'$no
) (let ((temp ul
)) (setq ul ll ll temp
)))
3615 (t (merror (intl:gettext
"defint: failed to order limits of integration:~%~M")
3616 (list '(mlist simp
) ll ul
)))))
3617 (if (not (equal ($imagpart place
) 0))
3619 (let ((lesseq-ul (ask-greateq ul place
))
3620 (greateq-ll (ask-greateq place ll
)))
3621 (if (and (eq lesseq-ul
'$yes
) (eq greateq-ll
'$yes
)) '$yes
'$no
))))
3623 ;; returns true or nil
3624 (defun strictly-in-interval (place ll ul
)
3625 ;; real values for ll and ul; place can be imaginary.
3626 (and (equal ($imagpart place
) 0)
3628 (eq ($asksign
(m+ ul
(m- place
))) '$pos
))
3630 (eq ($asksign
(m+ place
(m- ll
))) '$pos
))))
3632 (defun real-roots (exp ivar
)
3633 (let (($solvetrigwarn
(cond (*defintdebug
* t
) ;Rest of the code for
3634 (t ()))) ;TRIGS in denom needed.
3635 ($solveradcan
(cond ((or (among '$%i exp
)
3636 (among '$%e exp
)) t
)
3638 *roots
*failures
) ;special vars for solve.
3639 (cond ((not (among ivar exp
)) '$no
)
3640 (t (solve exp ivar
1)
3641 ;; If *failures is set, we may have missed some roots.
3642 ;; We still return the roots that we have found.
3643 (do ((dummy *roots
(cddr dummy
))
3646 (cond ((not (null rootlist
))
3649 (cond ((equal ($imagpart
(caddar dummy
)) 0)
3652 ($rectform
(caddar dummy
))
3656 (defun ask-greateq (x y
)
3657 ;;; Is x > y. X or Y can be $MINF or $INF, zeroA or zeroB.
3658 (let ((x (cond ((among 'zeroa x
)
3663 (subst 0 'epsilon x
))
3664 ((or (among '$inf x
)
3668 (y (cond ((among 'zeroa y
)
3673 (subst 0 'epsilon y
))
3674 ((or (among '$inf y
)
3686 (t (let ((ans ($asksign
(m+ x
(m- y
)))))
3687 (cond ((member ans
'($zero $pos
) :test
#'eq
)
3693 (defun sort-poles (pole-list)
3694 (sort pole-list
#'(lambda (x y
)
3695 (cond ((eq (ask-greateq (car x
) (car y
))
3700 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3702 ;;; Integrate Definite Integrals involving log and exp functions. The algorithm
3703 ;;; are taken from the paper "Evaluation of CLasses of Definite Integrals ..."
3704 ;;; by K.O.Geddes et. al.
3706 ;;; 1. CASE: Integrals generated by the Gamma function.
3711 ;;; I t log (t) expt(- t ) dt = s signum(s)
3718 ;;; (--- (gamma(z))! )
3724 ;;; The integral converges for:
3725 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3727 ;;; 2. CASE: Integrals generated by the Incomplete Gamma function.
3732 ;;; I t log (t) exp(- t ) dt = (--- (gamma_incomplete(a, x ))! )
3740 ;;; The integral converges for:
3741 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3742 ;;; The shown solution is valid for s>0. For s<0 gamma_incomplete has to be
3743 ;;; replaced by gamma(a) - gamma_incomplete(a,x^s).
3745 ;;; 3. CASE: Integrals generated by the beta function.
3750 ;;; I log (1 - t) (1 - t) t log (t) dt =
3758 ;;; --- (--- (beta(z, w))! )!
3764 ;;; The integral converges for:
3765 ;;; n, m = 0, 1, 2, ..., s > -1 and r > -1.
3766 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3768 (defvar *debug-defint-log
* nil
)
3770 ;;; Recognize c*z^w*log(z)^m*exp(-t^s)
3772 (defun m2-log-exp-1 (expr ivar
)
3773 (when *debug-defint-log
*
3774 (format t
"~&M2-LOG-EXP-1 with ~A~%" expr
))
3778 ((mexpt) (z varp2
,ivar
) (w freevar2
,ivar
))
3779 ((mexpt) $%e
((mtimes) -
1 ((mexpt) (z varp2
,ivar
) (s freevar02
,ivar
))))
3780 ((mexpt) ((%log
) (z varp2
,ivar
)) (m freevar2
,ivar
)))))
3782 ;;; Recognize c*z^r*log(z)^n*(1-z)^s*log(1-z)^m
3784 (defun m2-log-exp-2 (expr ivar
)
3785 (when *debug-defint-log
*
3786 (format t
"~&M2-LOG-EXP-2 with ~A~%" expr
))
3790 ((mexpt) (z varp2
,ivar
) (r freevar2
,ivar
))
3791 ((mexpt) ((%log
) (z varp2
,ivar
)) (n freevar2
,ivar
))
3792 ((mexpt) ((mplus) 1 ((mtimes) -
1 (z varp2
,ivar
))) (s freevar2
,ivar
))
3793 ((mexpt) ((%log
) ((mplus) 1 ((mtimes)-
1 (z varp2
,ivar
)))) (m freevar2
,ivar
)))))
3795 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3797 (defun defint-log-exp (expr ivar ll ul
)
3802 ;; var1 is used as a parameter for differentiation. Add var1>0 to the
3803 ;; database, to get the desired simplification of the differentiation of
3804 ;; the gamma_incomplete function.
3805 (setq *global-defint-assumptions
*
3806 (cons (assume `((mgreaterp) ,var1
0))
3807 *global-defint-assumptions
*))
3811 (setq x
(m2-log-exp-1 expr ivar
)))
3812 ;; The integrand matches the cases 1 and 2.
3813 (let ((c (cdras 'c x
))
3817 ($gamma_expand nil
)) ; No expansion of Gamma functions.
3819 (when *debug-defint-log
*
3820 (format t
"~&DEFINT-LOG-EXP-1:~%")
3821 (format t
"~& : c = ~A~%" c
)
3822 (format t
"~& : w = ~A~%" w
)
3823 (format t
"~& : m = ~A~%" m
)
3824 (format t
"~& : s = ~A~%" s
))
3826 (cond ((and (zerop1 ll
)
3829 (not (eq ($sign s
) '$zero
))
3830 (eq ($sign
(div (add w
1) s
)) '$pos
))
3831 ;; Case 1: Generated by the Gamma function.
3834 (simplify (list '(%signum
) s
))
3835 (power s
(mul -
1 (add m
1)))
3836 ($at
($diff
(list '(%gamma
) var1
) var1 m
)
3839 (div (add w
1) s
))))))
3840 ((and (member ($sign ll
) '($pos $pz
))
3842 (or (= m
0) (= m
1)) ; Exclude m>1, because Maxima can not
3843 ; derivate the involved hypergeometric
3845 (or (and (eq ($sign s
) '$neg
)
3846 (eq ($sign
(div (add 1 w
) s
)) '$pos
))
3847 (and (eq ($sign s
) '$pos
)
3848 (eq ($sign
(div (add 1 w
) s
)) '$pos
))))
3849 ;; Case 2: Generated by the Incomplete Gamma function.
3850 (let ((f (if (eq ($sign s
) '$pos
)
3851 (list '(%gamma_incomplete
) var1
(power ll s
))
3852 (sub (list '(%gamma
) var1
)
3853 (list '(%gamma_incomplete
) var1
(power ll s
))))))
3856 (simplify (list '(%signum
) s
))
3857 (power s
(mul -
1 (add m
1)))
3858 ($at
($diff f var1 m
)
3859 (list '(mequal) var1
(div (add 1 w
) s
)))))))
3861 (setq result nil
)))))
3864 (setq x
(m2-log-exp-2 expr ivar
)))
3865 ;; Case 3: Generated by the Beta function.
3866 (let ((c (cdras 'c x
))
3874 (when *debug-defint-log
*
3875 (format t
"~&DEFINT-LOG-EXP-2:~%")
3876 (format t
"~& : c = ~A~%" c
)
3877 (format t
"~& : r = ~A~%" r
)
3878 (format t
"~& : n = ~A~%" n
)
3879 (format t
"~& : s = ~A~%" s
)
3880 (format t
"~& : m = ~A~%" m
))
3882 (cond ((and (integerp m
)
3886 (eq ($sign
(add 1 r
)) '$pos
)
3887 (eq ($sign
(add 1 s
)) '$pos
))
3890 ($at
($diff
($at
($diff
(list '(%beta
) var1 var2
)
3892 (list '(mequal) var2
(add 1 s
)))
3894 (list '(mequal) var1
(add 1 r
))))))
3896 (setq result nil
)))))
3899 ;; Simplify result and set $gamma_expand to global value
3900 (let (($gamma_expand $gamma_expand
)) (sratsimp result
))))
3902 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;