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 (setq *current-assumptions
* (make-defint-assumptions 'noask ivar
))
426 (let ((exp (resimplify exp
))
427 (ivar (resimplify ivar
))
430 ;; D (not used? -- cwh)
431 ans nn
* dn
* $noprincipal
)
432 (cond ((setq ans
(defint-list exp ivar
*ll
* *ul
*))
437 ((not (among ivar exp
))
438 (cond ((or (member *ul
* '($inf $minf
) :test
#'eq
)
439 (member *ll
* '($inf $minf
) :test
#'eq
))
441 (t (setq ans
(m* exp
(m+ *ul
* (m- *ll
*))))
443 ;; Look for integrals which involve log and exp functions.
444 ;; Maxima has a special algorithm to get general results.
445 ((and (setq ans
(defint-log-exp exp ivar
*ll
* *ul
*)))
447 (let* ((exp (rmconst1 exp ivar
))
449 (exp (%i-out-of-denom
(cdr exp
))))
450 (cond ((and (not $nointegrate
)
452 (or (among 'mqapply exp
)
453 (not (member (caar exp
)
454 '(mexpt mplus mtimes %sin %cos
455 %tan %sinh %cosh %tanh
456 %log %asin %acos %atan
459 %derivative
) :test
#'eq
))))
460 ;; Call ANTIDERIV with logabs disabled,
461 ;; because the Risch algorithm assumes
462 ;; the integral of 1/x is log(x), not log(abs(x)).
463 ;; Why not just assume logabs = false within RISCHINT itself?
464 ;; Well, there's at least one existing result which requires
465 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
466 (cond ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
467 (setq ans
(intsubs ans
*ll
* *ul
* ivar
))
468 (return (cond (ans (m* c ans
)) (t nil
))))
470 (setq exp
(tansc-var exp ivar
))
471 (cond ((setq ans
(initial-analysis exp ivar
*ll
* *ul
*))
472 (return (m* c ans
))))
474 (restore-defint-assumptions old-assumptions
*current-assumptions
*))))
476 (defun defint-list (exp ivar
*ll
* *ul
*)
478 (let ((ans (cons (car exp
)
481 (defint sub-exp ivar
*ll
* *ul
*))
483 (cond (ans (simplify ans
))
487 (defun initial-analysis (exp ivar ll ul
)
488 (let ((pole (cond ((not $intanalysis
)
489 '$no
) ;don't do any checking.
490 (t (poles-in-interval exp ivar ll ul
)))))
491 (cond ((eq pole
'$no
)
492 (cond ((and (oddfn exp ivar
)
493 (or (and (eq ll
'$minf
)
495 (eq ($sign
(m+ ll ul
))
497 (t (parse-integrand exp ivar ll ul
))))
498 ((eq pole
'$unknown
) ())
499 (t (principal-value-integral exp ivar ll ul pole
)))))
501 (defun parse-integrand (exp ivar ll ul
)
503 (cond ((setq ans
(eezz exp ll ul ivar
)) ans
)
504 ((and (ratp exp ivar
)
505 (setq ans
(method-by-limits exp ivar ll ul
)))
508 (setq ans
(intbyterm exp t ivar ll ul
)))
510 ((setq ans
(method-by-limits exp ivar ll ul
)) ans
)
513 (defun rmconst1 (e ivar
)
514 (cond ((not (freeof ivar e
))
515 (partition e ivar
1))
519 (defun method-by-limits (exp ivar
*ll
* *ul
*)
520 (let ((old-assumptions *defint-assumptions
*))
521 (setq *current-assumptions
* (make-defint-assumptions 'noask ivar
))
523 ;;Should be a PROG inside of unwind-protect, but Multics has a compiler
524 ;;bug wrt. and I want to test this code now.
526 (cond ((and (and (eq *ul
* '$inf
)
528 (mtoinf exp ivar
*ll
* *ul
*)))
529 ((and (and (eq *ul
* '$inf
)
531 (ztoinf exp ivar
*ll
* *ul
*)))
532 ;;;This seems((and (and (eq *ul* '$inf)
533 ;;;fairly losing (setq exp (subin (m+ *ll* ivar) exp))
535 ;;; (ztoinf exp ivar)))
536 ((and (equal *ll
* 0.
)
538 (eq ($asksign
*ul
*) '$pos
)
540 ;; ((and (and (equal *ul* 1.)
541 ;; (equal *ll* 0.)) (zto1 exp)))
542 (t (dintegrate exp ivar
*ll
* *ul
*)))
543 (restore-defint-assumptions old-assumptions
*defint-assumptions
*))))
546 (defun dintegrate (exp ivar
*ll
* *ul
*)
547 (let ((ans nil
) (arg nil
) (*scflag
* nil
)
548 (*dflag
* nil
) ($%emode t
))
549 ;;;NOT COMPLETE for sin's and cos's.
550 (cond ((and (not *sin-cos-recur
*)
553 (intsc1 *ll
* *ul
* exp ivar
)))
554 ((and (not *rad-poly-recur
*)
555 (notinvolve-var exp ivar
'(%log
))
556 (not (%einvolve-var exp ivar
))
557 (method-radical-poly exp ivar
*ll
* *ul
*)))
558 ((and (not (equal *dintlog-recur
* 2.
))
559 (setq arg
(involve-var exp ivar
'(%log
)))
560 (dintlog exp arg ivar
*ll
* *ul
*)))
561 ((and (not *dintexp-recur
*)
562 (setq arg
(%einvolve-var exp ivar
))
563 (dintexp exp ivar
*ll
* *ul
*)))
564 ((and (not (ratp exp ivar
))
565 (setq ans
(let (($trigexpandtimes nil
)
568 (setq ans
($expand ans
))
569 (not (alike1 ans exp
))
570 (intbyterm ans t ivar
*ll
* *ul
*)))
571 ;; Call ANTIDERIV with logabs disabled,
572 ;; because the Risch algorithm assumes
573 ;; the integral of 1/x is log(x), not log(abs(x)).
574 ;; Why not just assume logabs = false within RISCHINT itself?
575 ;; Well, there's at least one existing result which requires
576 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
577 ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
578 (intsubs ans
*ll
* *ul
* ivar
))
581 (defun method-radical-poly (exp ivar ll ul
)
583 (let ((*rad-poly-recur
* t
) ;recursion stopper
585 (cond ((and (sinintp exp ivar
)
586 (setq result
(antideriv exp ivar
))
587 (intsubs result ll ul ivar
)))
588 ((and (ratp exp ivar
)
589 (setq result
(ratfnt exp ivar ll ul
))))
594 (setq result
(cv exp ivar ll ul
))))
597 (defun principal-value-integral (exp ivar ll ul poles
)
598 (let ((anti-deriv ()))
599 (cond ((not (null (setq anti-deriv
(antideriv exp ivar
))))
600 (cond ((not (null poles
))
601 (multiple-value-bind (ignore new-ll new-ul
)
602 (order-limits 'ask ivar ll ul
)
603 (declare (ignore ignore
))
604 (cond ((take-principal anti-deriv new-ll new-ul ivar poles
))
607 ;; adds up integrals of ranges between each pair of poles.
608 ;; checks if whole thing is divergent as limits of integration approach poles.
609 (defun take-principal (anti-deriv ll ul ivar poles
&aux ans merged-list
)
610 ;;; calling $logcontract causes antiderivative of 1/(1-x^5) to blow up
611 ;; (setq anti-deriv (cond ((involve anti-deriv '(%log))
612 ;; ($logcontract anti-deriv))
615 (multiple-value-setq (merged-list ll ul
)
616 (interval-list poles ll ul
))
617 (do ((current-pole (cdr merged-list
) (cdr current-pole
))
618 (previous-pole merged-list
(cdr previous-pole
)))
619 ((null current-pole
) t
)
621 (intsubs anti-deriv
(m+ (caar previous-pole
) 'epsilon
)
622 (m+ (caar current-pole
) (m- 'epsilon
))
625 (setq ans
(get-limit (get-limit ans
'epsilon
0 '$plus
) 'prin-inf
'$inf
))
627 (cond ((or (null ans
)
628 (not (free ans
'$infinity
))
629 (not (free ans
'$ind
))) ())
630 ((or (among '$minf ans
)
634 (t (principal) ans
)))
636 ;; I think this takes the pole-list and replaces $MINF with -PRIN-INF
637 ;; and $INF with PRIN-INF. The lower and upper integration limits
638 ;; (ll, ul) can also be modified to be -PRIN-INF and PRIN-INF. These
639 ;; special values are used in TAKE-PRINCIPAL.
640 (defun interval-list (pole-list ll ul
)
641 (let ((first (car (first pole-list
)))
642 (last (caar (last pole-list
))))
645 (setq pole-list
(subst 'prin-inf
'$inf pole-list
))))
648 (setq pole-list
(append pole-list
(list (cons ul
'ignored
))))))
651 (setq pole-list
(subst (m- 'prin-inf
) '$minf pole-list
))))
652 (t (if (eq ll
'$minf
)
653 (setq ll
(m- 'prin-inf
)))
654 (setq pole-list
(append (list (cons ll
'ignored
)) pole-list
)))))
655 (values pole-list ll ul
))
657 ;; Assumes EXP is a rational expression with no polynomial part and
658 ;; converts the finite integration to integration over a half-infinite
659 ;; interval. The substitution y = (x-a)/(b-x) is used. Equivalently,
660 ;; x = (b*y+a)/(y+1).
662 ;; (I'm guessing CV means Change Variable here.)
663 (defun cv (exp ivar ll ul
)
664 (if (not (or (real-infinityp ll
) (real-infinityp ul
)))
665 ;; FIXME! This is a hack. We apply the transformation with
666 ;; symbolic limits and then substitute the actual limits later.
667 ;; That way method-by-limits (usually?) sees a simpler
670 ;; See Bugs 938235 and 941457. These fail because $FACTOR is
671 ;; unable to factor the transformed result. This needs more
672 ;; work (in other places).
673 (let ((trans (integrand-changevar (m// (m+t
'll
(m*t
'ul
'yx
))
676 ;; If the limit is a number, use $substitute so we simplify
677 ;; the result. Do we really want to do this?
678 (setf trans
(if (mnump ll
)
679 ($substitute ll
'll trans
)
680 (subst ll
'll trans
)))
681 (setf trans
(if (mnump ul
)
682 ($substitute ul
'ul trans
)
683 (subst ul
'ul trans
)))
684 (method-by-limits trans
'yx
0.
'$inf
))
687 ;; Integrate rational functions over a finite interval by doing the
688 ;; polynomial part directly, and converting the rational part to an
689 ;; integral from 0 to inf. This is evaluated via residues.
690 (defun ratfnt (exp ivar ll ul
)
691 (let ((e (pqr exp ivar
)))
692 ;; PQR divides the rational expression and returns the quotient
694 (flet ((try-antideriv (e lo hi
)
695 (let ((ans (antideriv e ivar
)))
697 (intsubs ans lo hi ivar
)))))
699 (cond ((equal 0.
(car e
))
700 ;; No polynomial part
701 (let ((ans (try-antideriv exp ll ul
)))
704 (cv exp ivar ll ul
))))
706 ;; Only polynomial part
707 (eezz (car e
) ll ul ivar
))
709 ;; A non-zero quotient and remainder. Combine the results
711 (let ((ans (try-antideriv (m// (cdr e
) dn
*) ll ul
)))
713 (m+t
(eezz (car e
) ll ul ivar
)
716 (m+t
(eezz (car e
) ll ul ivar
)
717 (cv (m// (cdr e
) dn
*) ivar ll ul
))))))))))
719 ;; I think this takes a rational expression E, and finds the
720 ;; polynomial part. A cons is returned. The car is the quotient and
721 ;; the cdr is the remainder.
723 (let ((varlist (list ivar
)))
725 (setq e
(cdr (ratrep* e
)))
726 (setq dn
* (pdis (ratdenominator e
)))
727 (setq e
(pdivide (ratnumerator e
) (ratdenominator e
)))
728 (cons (simplify (rdis (car e
))) (simplify (rdis (cadr e
))))))
731 (defun intbyterm (exp *nodiverg
* ivar
*ll
* *ul
*)
732 (let ((saved-exp exp
))
734 (let ((ans (catch 'divergent
735 (andmapcar #'(lambda (new-exp)
736 (defint new-exp ivar
*ll
* *ul
*))
738 (cond ((null ans
) nil
)
740 (let ((*nodiverg
* nil
))
741 (cond ((setq ans
(antideriv saved-exp ivar
))
742 (intsubs ans
*ll
* *ul
* ivar
))
744 (t (sratsimp (m+l ans
))))))
745 ;;;If leadop isn't plus don't do anything.
748 (defun kindp34 (ivar ll ul
)
749 (let* ((d (nth-value 1 (numden-var exp ivar
)))
750 (a (cond ((and (zerop1 ($limit d ivar ll
'$plus
))
751 (eq (limit-pole (m+ exp
(m+ (m- ll
) ivar
))
756 (b (cond ((and (zerop1 ($limit d ivar ul
'$minus
))
757 (eq (limit-pole (m+ exp
(m+ ul
(m- ivar
)))
765 (cond (*nodiverg
* (throw 'divergent
'divergent
))
766 (t (merror (intl:gettext
"defint: integral is divergent.")))))
768 (defun make-defint-assumptions (ask-or-not ivar
)
770 (multiple-value-setq (result *ll
* *ul
*)
771 (order-limits ask-or-not ivar
*ll
* *ul
*)))
773 (t (mapc 'forget
*defint-assumptions
*)
774 (setq *defint-assumptions
* ())
775 (let ((sign-ll (cond ((eq *ll
* '$inf
) '$pos
)
776 ((eq *ll
* '$minf
) '$neg
)
777 (t ($sign
($limit
*ll
*)))))
778 (sign-ul (cond ((eq *ul
* '$inf
) '$pos
)
779 ((eq *ul
* '$minf
) '$neg
)
780 (t ($sign
($limit
*ul
*)))))
781 (sign-ul-ll (cond ((and (eq *ul
* '$inf
)
782 (not (eq *ll
* '$inf
))) '$pos
)
783 ((and (eq *ul
* '$minf
)
784 (not (eq *ll
* '$minf
))) '$neg
)
785 (t ($sign
($limit
(m+ *ul
* (m- *ll
*))))))))
786 (cond ((eq sign-ul-ll
'$pos
)
787 (setq *defint-assumptions
*
788 `(,(assume `((mgreaterp) ,ivar
,*ll
*))
789 ,(assume `((mgreaterp) ,*ul
* ,ivar
)))))
790 ((eq sign-ul-ll
'$neg
)
791 (setq *defint-assumptions
*
792 `(,(assume `((mgreaterp) ,ivar
,*ul
*))
793 ,(assume `((mgreaterp) ,*ll
* ,ivar
))))))
794 (cond ((and (eq sign-ll
'$pos
)
796 (setq *defint-assumptions
*
797 `(,(assume `((mgreaterp) ,ivar
0))
798 ,@*defint-assumptions
*)))
799 ((and (eq sign-ll
'$neg
)
801 (setq *defint-assumptions
*
802 `(,(assume `((mgreaterp) 0 ,ivar
))
803 ,@*defint-assumptions
*)))
804 (t *defint-assumptions
*))))))
806 (defun restore-defint-assumptions (old-assumptions assumptions
)
807 (do ((llist assumptions
(cdr llist
)))
809 (forget (car llist
)))
810 (do ((llist old-assumptions
(cdr llist
)))
812 (assume (car llist
))))
814 (defun make-global-assumptions ()
815 (setq *global-defint-assumptions
*
816 (cons (assume '((mgreaterp) *z
* 0.
))
817 *global-defint-assumptions
*))
818 ;; *Z* is a "zero parameter" for this package.
819 ;; Its also used to transform.
820 ;; limit(exp,var,val,dir) -- limit(exp,tvar,0,dir)
821 (setq *global-defint-assumptions
*
822 (cons (assume '((mgreaterp) epsilon
0.
))
823 *global-defint-assumptions
*))
824 (setq *global-defint-assumptions
*
825 (cons (assume '((mlessp) epsilon
1.0e-8))
826 *global-defint-assumptions
*))
827 ;; EPSILON is used in principal value code to denote the familiar
828 ;; mathematical entity.
829 (setq *global-defint-assumptions
*
830 (cons (assume '((mgreaterp) prin-inf
1.0e+8))
831 *global-defint-assumptions
*)))
833 ;;; PRIN-INF Is a special symbol in the principal value code used to
834 ;;; denote an end-point which is proceeding to infinity.
836 (defun forget-global-assumptions ()
837 (do ((llist *global-defint-assumptions
* (cdr llist
)))
839 (forget (car llist
)))
840 (cond ((not (null integer-info
))
841 (do ((llist integer-info
(cdr llist
)))
843 (i-$remove
`(,(cadar llist
) ,(caddar llist
)))))))
845 (defun order-limits (ask-or-not ivar ll ul
)
847 (cond ((or (not (equal ($imagpart ll
) 0))
848 (not (equal ($imagpart ul
) 0))) ())
849 (t (cond ((alike1 ll
(m*t -
1 '$inf
))
851 (cond ((alike1 ul
(m*t -
1 '$inf
))
853 (cond ((alike1 ll
(m*t -
1 '$minf
))
855 (cond ((alike1 ul
(m*t -
1 '$minf
))
858 ;; We have minf <= ll = ul <= inf
861 ;; We have minf <= ll < ul = inf
864 ;; We have minf = ll < ul < inf
872 ;; so that minf < ll < ul = inf
873 (setq exp
(subin-var (m- ivar
) exp ivar
))
877 (equal (complm ask-or-not ll ul
) -
1))
878 ;; We have minf <= ul < ll
885 ;; so that minf <= ll < ul
891 (defun complm (ask-or-not ll ul
)
892 (let ((askflag (cond ((eq ask-or-not
'ask
) t
)
895 (cond ((alike1 ul ll
) 0.
)
896 ((eq (setq a
(cond (askflag ($asksign
($limit
(m+t ul
(m- ll
)))))
897 (t ($sign
($limit
(m+t ul
(m- ll
)))))))
903 ;; Substitute a and b into integral e
905 ;; Looks for discontinuties in integral, and works around them.
908 ;; integrate(x^(2*n)*exp(-(x)^2),x) ==>
909 ;; -gamma_incomplete((2*n+1)/2,x^2)*x^(2*n+1)*abs(x)^(-2*n-1)/2
911 ;; the integral has a discontinuity at x=0.
913 (defun intsubs (e a b ivar
)
914 (let ((edges (cond ((not $intanalysis
)
915 '$no
) ;don't do any checking.
916 (t (discontinuities-in-interval
917 (let (($algebraic t
))
921 (cond ((or (eq edges
'$no
)
922 (eq edges
'$unknown
))
923 (whole-intsubs e a b ivar
))
925 (do* ((l edges
(cdr l
))
928 (b1 (cadr l
) (cadr l
)))
929 ((null (cdr l
)) (if (every (lambda (x) x
) total
)
932 (whole-intsubs e a1 b1 ivar
)
935 ;; look for terms with a negative exponent
937 ;; recursively traverses exp in order to find discontinuities such as
938 ;; erfc(1/x-x) at x=0
939 (defun discontinuities-denom (exp ivar
)
941 ((and (eq (caar exp
) 'mexpt
)
942 (not (freeof ivar
(cadr exp
)))
943 (not (member ($sign
(caddr exp
)) '($pos $pz
))))
944 (m^
(cadr exp
) (m- (caddr exp
))))
946 (m*l
(mapcar #'(lambda (e)
947 (discontinuities-denom e ivar
))
950 ;; returns list of places where exp might be discontinuous in ivar.
951 ;; list begins with *ll* and ends with *ul*, and include any values between
953 ;; return '$no or '$unknown if no discontinuities found.
954 (defun discontinuities-in-interval (exp ivar ll ul
)
955 (let* ((denom (discontinuities-denom exp ivar
))
956 (roots (real-roots denom ivar
)))
957 (cond ((eq roots
'$failure
)
961 (t (do ((dummy roots
(cdr dummy
))
966 (sortgreat pole-list
)
969 (let ((soltn (caar dummy
)))
970 ;; (multiplicity (cdar dummy)) ;; not used
971 (if (strictly-in-interval soltn ll ul
)
972 (push soltn pole-list
))))))))
975 ;; Carefully substitute the integration limits A and B into the
977 (defun whole-intsubs (e a b ivar
)
978 (cond ((easy-subs e a b ivar
))
979 (t (setq *current-assumptions
*
980 (make-defint-assumptions 'ask ivar
)) ;get forceful!
981 (let (($algebraic t
))
982 (setq e
(sratsimp e
))
983 (cond ((limit-subs e a b ivar
))
984 (t (same-sheet-subs e a b ivar
)))))))
986 ;; Try easy substitutions. Return NIL if we can't.
987 (defun easy-subs (e ll ul ivar
)
988 (cond ((or (infinityp ll
) (infinityp ul
))
989 ;; Infinite limits aren't easy
992 (cond ((or (polyinx e ivar
())
993 (and (not (involve-var e ivar
'(%log %asin %acos %atan %asinh %acosh %atanh %atan2
994 %gamma_incomplete %expintegral_ei
)))
995 (free ($denom e
) ivar
)))
996 ;; It's easy if we have a polynomial. I (rtoy) think
997 ;; it's also easy if the denominator is free of the
998 ;; integration variable and also if the expression
999 ;; doesn't involve inverse functions.
1001 ;; gamma_incomplete and expintegral_ie
1002 ;; included because of discontinuity in
1003 ;; gamma_incomplete(0, exp(%i*x)) and
1004 ;; expintegral_ei(exp(%i*x))
1006 ;; XXX: Are there other cases we've forgotten about?
1008 ;; So just try to substitute the limits into the
1009 ;; expression. If no errors are produced, we're done.
1010 (let ((ll-val (no-err-sub-var ll e ivar
))
1011 (ul-val (no-err-sub-var ul e ivar
)))
1012 (cond ((or (eq ll-val t
)
1014 ;; no-err-sub has returned T. An error was catched.
1016 ((and ll-val ul-val
)
1021 (defun limit-subs (e ll ul ivar
)
1022 (cond ((involve-var e ivar
'(%atan %gamma_incomplete %expintegral_ei
))
1023 ()) ; functions with discontinuities
1024 (t (setq e
($multthru e
))
1025 (let ((a1 ($limit e ivar ll
'$plus
))
1026 (a2 ($limit e ivar ul
'$minus
)))
1027 (combine-ll-ans-ul-ans a1 a2
)))))
1029 ;; check for divergent integral
1030 (defun combine-ll-ans-ul-ans (a1 a2
)
1031 (cond ((member a1
'($inf $minf $infinity
) :test
#'eq
)
1032 (cond ((member a2
'($inf $minf $infinity
) :test
#'eq
)
1033 (cond ((eq a2 a1
) ())
1036 ((member a2
'($inf $minf $infinity
) :test
#'eq
) (diverg))
1037 ((or (member a1
'($und $ind
) :test
#'eq
)
1038 (member a2
'($und $ind
) :test
#'eq
)) ())
1041 ;;;This function works only on things with ATAN's in them now.
1042 (defun same-sheet-subs (exp ll ul ivar
&aux ll-ans ul-ans
)
1043 ;; POLES-IN-INTERVAL doesn't know about the poles of tan(x). Call
1044 ;; trigsimp to convert tan into sin/cos, which POLES-IN-INTERVAL
1045 ;; knows how to handle.
1047 ;; XXX Should we fix POLES-IN-INTERVAL instead?
1049 ;; XXX Is calling trigsimp too much? Should we just only try to
1050 ;; substitute sin/cos for tan?
1052 ;; XXX Should the result try to convert sin/cos back into tan? (A
1053 ;; call to trigreduce would do it, among other things.)
1054 (let* ((exp (mfuncall '$trigsimp exp
))
1055 (poles (atan-poles exp ll ul ivar
)))
1056 ;;POLES -> ((mlist) ((mequal) ((%atan) foo) replacement) ......)
1057 ;;We can then use $SUBSTITUTE
1058 (setq ll-ans
(limcp exp ivar ll
'$plus
))
1059 (setq exp
(sratsimp ($substitute poles exp
)))
1060 (setq ul-ans
(limcp exp ivar ul
'$minus
))
1063 (combine-ll-ans-ul-ans ll-ans ul-ans
)
1066 (defun atan-poles (exp ll ul ivar
)
1067 `((mlist) ,@(atan-pole1 exp ll ul ivar
)))
1069 (defun atan-pole1 (exp ll ul ivar
&aux ipart
)
1072 ((matanp exp
) ;neglect multiplicity and '$unknowns for now.
1073 (desetq (exp . ipart
) (trisplit exp
))
1075 ((not (equal (sratsimp ipart
) 0)) ())
1076 (t (let ((pole (poles-in-interval (let (($algebraic t
))
1077 (sratsimp (cadr exp
)))
1079 (cond ((and pole
(not (or (eq pole
'$unknown
)
1081 (do ((l pole
(cdr l
)) (llist ()))
1084 ((zerop1 (m- (caar l
) ll
)) t
) ; don't worry about discontinuity
1085 ((zerop1 (m- (caar l
) ul
)) t
) ; at boundary of integration
1086 (t (let ((low-lim ($limit
(cadr exp
) ivar
(caar l
) '$minus
))
1087 (up-lim ($limit
(cadr exp
) ivar
(caar l
) '$plus
)))
1088 (cond ((and (not (eq low-lim up-lim
))
1089 (real-infinityp low-lim
)
1090 (real-infinityp up-lim
))
1091 (let ((change (if (eq low-lim
'$minf
)
1094 (setq llist
(cons `((mequal simp
) ,exp
,(m+ exp change
))
1095 llist
)))))))))))))))
1096 (t (do ((l (cdr exp
) (cdr l
))
1099 (setq llist
(append llist
(atan-pole1 (car l
) ll ul ivar
)))))))
1101 (defun difapply (ivar n d s fn1
)
1102 (prog (k m r $noprincipal
)
1103 (cond ((eq ($asksign
(m+ (deg-var d ivar
) (m- s
) (m- 2.
))) '$neg
)
1105 (setq $noprincipal t
)
1106 (cond ((or (not (mexptp d
))
1107 (not (numberp (setq r
(caddr d
)))))
1110 ;; There are no calls where fn1 is ever equal to
1111 ;; 'mtorat. Hence this case is never true. What is
1112 ;; this testing for?
1114 (equal 1.
(deg-var (cadr d
) ivar
)))
1116 (setq m
(deg-var (setq d
(cadr d
)) ivar
))
1117 (setq k
(m// (m+ s
2.
) m
))
1118 (cond ((eq (ask-integer (m// (m+ s
2.
) m
) '$any
) '$yes
)
1120 (t (setq k
(m+ 1 k
))))
1121 (cond ((eq ($sign
(m+ r
(m- k
))) '$pos
)
1122 (return (diffhk fn1 n d k
(m+ r
(m- k
)) ivar
))))))
1124 (defun diffhk (fn1 n d r m ivar
)
1127 (setq d1
(funcall fn1 n
1129 (m* r
(deg-var d ivar
))))
1130 (cond (d1 (return (difap1 d1 r
'*z
* m
0.
))))))
1132 (defun principal nil
1133 (cond ($noprincipal
(diverg))
1135 (format t
"Principal Value~%")
1136 (setq *pcprntd
* t
))))
1138 ;; e is of form poly(x)*exp(m*%i*x)
1139 ;; s is degree of denominator
1140 ;; adds e to *bptu* or *bptd* according to sign of m
1141 (defun rib (e s ivar
)
1142 (cond ((or (mnump e
) (constant e
))
1143 (setq *bptu
* (cons e
*bptu
*)))
1146 (setq e
(rmconst1 e ivar
))
1150 (multiple-value-setq (e updn
)
1151 (catch 'ptimes%e
(ptimes%e nn nd ivar
)))
1152 (cond ((null e
) nil
)
1153 (t (setq e
(m* c e
))
1154 (cond (updn (setq *bptu
* (cons e
*bptu
*)))
1155 (t (setq *bptd
* (cons e
*bptd
*))))))))))
1157 ;; Check term is of form poly(x)*exp(m*%i*x)
1158 ;; n is degree of denominator.
1159 (defun ptimes%e
(term n ivar
&aux updn
)
1160 (cond ((and (mexptp term
)
1161 (eq (cadr term
) '$%e
)
1162 (polyinx (caddr term
) ivar nil
)
1163 (eq ($sign
(m+ (deg-var ($realpart
(caddr term
)) ivar
) -
1))
1165 (eq ($sign
(m+ (deg-var (setq nn
* ($imagpart
(caddr term
))) ivar
)
1168 ;; Set updn to T if the coefficient of IVAR in the
1169 ;; polynomial is known to be positive. Otherwise set to NIL.
1170 ;; (What does updn really mean?)
1171 (setq updn
(eq ($asksign
(ratdisrep (ratcoef nn
* ivar
))) '$pos
))
1173 ((and (mtimesp term
)
1174 (setq nn
* (polfactors term ivar
))
1175 (or (null (car nn
*))
1176 (eq ($sign
(m+ n
(m- (deg-var (car nn
*) ivar
))))
1178 (not (alike1 (cadr nn
*) term
))
1179 (multiple-value-setq (term updn
)
1180 (ptimes%e
(cadr nn
*) n ivar
))
1183 (t (throw 'ptimes%e nil
))))
1185 (defun csemidown (n d ivar
)
1186 (let ((*pcprntd
* t
)) ;Not sure what to do about PRINCIPAL values here.
1188 (res-var ivar n d
#'lowerhalf
#'(lambda (x)
1189 (cond ((equal ($imagpart x
) 0) t
)
1192 (defun lowerhalf (j)
1193 (eq ($asksign
($imagpart j
)) '$neg
))
1195 (defun upperhalf (j)
1196 (eq ($asksign
($imagpart j
)) '$pos
))
1199 (defun csemiup (n d ivar
)
1200 (let ((*pcprntd
* t
)) ;I'm not sure what to do about PRINCIPAL values here.
1202 (res-var ivar n d
#'upperhalf
#'(lambda (x)
1203 (cond ((equal ($imagpart x
) 0) t
)
1207 (cond ((null n
) nil
)
1208 (t (m*t
'$%i
($rectform
(m+ (cond ((car n
)
1216 ;; exponentialize sin and cos
1217 (defun sconvert (e ivar
)
1219 ((polyinx e ivar nil
) e
)
1220 ((eq (caar e
) '%sin
)
1223 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1224 (m- (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
)))))))
1225 ((eq (caar e
) '%cos
)
1226 (mul* '((rat) 1.
2.
)
1227 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1228 (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
))))))
1230 (cons (list (caar e
)) (mapcar #'(lambda (ee)
1234 (defun polfactors (exp ivar
)
1236 (cond ((mplusp exp
) nil
)
1237 (t (cond ((mtimesp exp
)
1238 (setq exp
(reverse (cdr exp
))))
1239 (t (setq exp
(list exp
))))
1240 (mapc #'(lambda (term)
1241 (cond ((polyinx term ivar nil
)
1243 (t (push term rest
))))
1245 (list (m*l poly
) (m*l rest
))))))
1249 (cond ((atom e
) (return e
))
1250 ((not (among '$%e e
)) (return e
))
1253 (setq d
($imagpart
(caddr e
)))
1254 (return (m* (m^t
'$%e
($realpart
(caddr e
)))
1256 (m*t
'$%i
`((%sin
) ,d
))))))
1257 (t (return (simplify (cons (list (caar e
))
1258 (mapcar #'esap
(cdr e
)))))))))
1260 ;; computes integral from minf to inf for expressions of the form
1261 ;; exp(%i*m*x)*r(x) by residues on either the upper half
1262 ;; plane or the lower half plane, depending on whether
1263 ;; m is positive or negative. [wang p. 77]
1265 ;; exponentializes sin and cos before applying residue method.
1266 ;; can handle some expressions with poles on real line, such as
1268 (defun mtosc (grand ivar
)
1269 (multiple-value-bind (n d
)
1270 (numden-var grand ivar
)
1271 (let (ratterms ratans
1272 plf
*bptu
* *bptd
* s upans downans
)
1273 (cond ((not (or (polyinx d ivar nil
)
1274 (and (setq grand
(%einvolve-var d ivar
))
1276 (polyinx (setq d
(sratsimp (m// d
(m^t
'$%e grand
))))
1279 (setq n
(m// n
(m^t
'$%e grand
)))))) nil
)
1280 ((equal (setq s
(deg-var d ivar
)) 0) nil
)
1281 ;;;Above tests for applicability of this method.
1282 ((and (or (setq plf
(polfactors n ivar
)) t
)
1283 (setq n
($expand
(cond ((car plf
)
1284 (m*t
'x
* (sconvert (cadr plf
) ivar
)))
1285 (t (sconvert n ivar
)))))
1286 (cond ((mplusp n
) (setq n
(cdr n
)))
1287 (t (setq n
(list n
))))
1289 (cond ((polyinx term ivar nil
)
1290 ;; call to $expand can create rational terms
1291 ;; with no exp(m*%i*x)
1292 (setq ratterms
(cons term ratterms
)))
1295 ;;;Function RIB sets up the values of BPTU and BPTD
1297 (setq *bptu
* (subst (car plf
) 'x
* *bptu
*))
1298 (setq *bptd
* (subst (car plf
) 'x
* *bptd
*))
1299 (setq ratterms
(subst (car plf
) 'x
* ratterms
))
1300 t
) ;CROCK, CROCK. This is TERRIBLE code.
1302 ;;;If there is BPTU then CSEMIUP must succeed.
1303 ;;;Likewise for BPTD.
1306 (let (($intanalysis nil
))
1307 ;; The original integrand was already
1308 ;; determined to have no poles by initial-analysis.
1309 ;; If individual terms of the expansion have poles, the poles
1310 ;; must cancel each other out, so we can ignore them.
1311 (try-defint (m// (m+l ratterms
) d
) ivar
'$minf
'$inf
))
1313 ;; if integral of ratterms is divergent, ratans is nil,
1314 ;; and mtosc returns nil
1316 (cond (*bptu
* (setq upans
(csemiup (m+l
*bptu
*) d ivar
)))
1318 (cond (*bptd
* (setq downans
(csemidown (m+l
*bptd
*) d ivar
)))
1319 (t (setq downans
0))))
1321 (sratsimp (m+ ratans
1322 (m* '$%pi
(m+ upans
(m- downans
))))))))))
1325 (defun evenfn (e ivar
)
1326 (let ((temp (m+ (m- e
)
1328 ($substitute
(m- ivar
) ivar e
))
1329 (t ($ratsubst
(m- ivar
) ivar e
))))))
1330 (cond ((zerop1 temp
)
1332 ((zerop1 (sratsimp temp
))
1336 (defun oddfn (e ivar
)
1337 (let ((temp (m+ e
(cond ((atom ivar
)
1338 ($substitute
(m- ivar
) ivar e
))
1339 (t ($ratsubst
(m- ivar
) ivar e
))))))
1340 (cond ((zerop1 temp
)
1342 ((zerop1 (sratsimp temp
))
1346 (defun ztoinf (grand ivar ll ul
)
1347 (prog (n d sn sd varlist
1349 ans r $savefactors
*checkfactors
* temp test-var
1351 (setq $savefactors t sn
(setq sd
(list 1.
)))
1352 (cond ((eq ($sign
(m+ *loopstop
* -
1))
1355 ((setq temp
(or (scaxn grand ivar
)
1356 (ssp grand ivar ll ul
)))
1358 ((involve-var grand ivar
'(%sin %cos %tan
))
1359 (setq grand
(sconvert grand ivar
))
1362 (cond ((polyinx grand ivar nil
)
1364 ((and (ratp grand ivar
)
1366 (andmapcar #'(lambda (e)
1367 (multiple-value-bind (result new-sn new-sd
)
1368 (snumden-var e ivar sn sd
)
1374 (setq nn-var
(m*l sn
)
1376 (setq dn-var
(m*l sd
)
1378 (t (multiple-value-setq (nn-var dn-var
)
1379 (numden-var grand ivar
))))
1382 (setq n
(rmconst1 nn-var ivar
))
1383 (setq d
(rmconst1 dn-var ivar
))
1388 (cond ((polyinx d ivar nil
)
1389 (setq s
(deg-var d ivar
)))
1391 (cond ((and (setq r
(findp n ivar
))
1392 (eq (ask-integer r
'$integer
) '$yes
)
1393 (setq test-var
(bxm d s ivar
))
1394 (setq ans
(apply 'fan
(cons (m+ 1. r
) test-var
))))
1395 (return (m* (m// nc dc
) (sratsimp ans
))))
1396 ((and (ratp grand ivar
)
1397 (setq ans
(zmtorat n
(cond ((mtimesp d
) d
)
1401 (ztorat n d s ivar
))
1403 (return (m* (m// nc dc
) ans
)))
1404 ((and (evenfn d ivar
)
1405 (setq nn-var
(p*lognxp n s ivar
)))
1406 (setq ans
(log*rat
(car nn-var
) d
(cadr nn-var
) ivar
))
1407 (return (m* (m// nc dc
) ans
)))
1408 ((involve-var grand ivar
'(%log
))
1409 (cond ((setq ans
(logquad0 grand ivar
))
1410 (return (m* (m// nc dc
) ans
)))
1413 (cond ((setq temp
(batapp grand ivar ll ul
))
1417 (cond ((let ((*mtoinf
* nil
))
1418 (setq temp
(ggr grand t ivar
)))
1421 (cond ((let ((*nodiverg
* t
))
1422 (setq ans
(catch 'divergent
1423 (andmapcar #'(lambda (g)
1424 (ztoinf g ivar ll ul
))
1426 (cond ((eq ans
'divergent
) nil
)
1427 (t (return (sratsimp (m+l ans
)))))))))
1429 (cond ((and (evenfn grand ivar
)
1430 (setq *loopstop
* (m+ 1 *loopstop
*))
1431 (setq ans
(method-by-limits grand ivar
'$minf
'$inf
)))
1432 (return (m*t
'((rat) 1.
2.
) ans
)))
1435 (defun ztorat (n d s ivar
)
1436 (cond ((and (null *dflag
*)
1437 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1438 (ztorat n d s ivar
)))))
1440 ((setq n
(let ((plogabs ()))
1441 (keyhole (let ((var ivar
))
1442 (declare (special var
))
1443 ;; It's very important here to bind VAR
1444 ;; because the PLOG simplifier checks
1445 ;; for VAR. Without this, the
1446 ;; simplifier converts plog(-x) to
1447 ;; log(x)+%i*%pi, which messes up the
1449 (m* `((%plog
) ,(m- ivar
)) n
))
1454 ;; Let's not signal an error here. Return nil so that we
1455 ;; eventually return a noun form if no other algorithm gives
1458 (merror (intl:gettext
"defint: keyhole integration failed.~%"))
1461 ;;(setq *dflag* nil)
1463 (defun logquad0 (exp ivar
)
1464 (let ((a ()) (b ()) (c ()))
1465 (cond ((setq exp
(logquad exp ivar
))
1466 (setq a
(car exp
) b
(cadr exp
) c
(caddr exp
))
1467 ($asksign b
) ;let the data base know about the sign of B.
1468 (cond ((eq ($asksign c
) '$pos
)
1469 (setq c
(m^
(m// c a
) '((rat) 1.
2.
)))
1471 `((%acos
) ,(add* 'epsilon
(m// b
(mul* 2. a c
))))))
1472 (setq a
(m// (m* b
`((%log
) ,c
))
1473 (mul* a
(simplify `((%sin
) ,b
)) c
)))
1474 (get-limit a
'epsilon
0 '$plus
))))
1477 (defun logquad (exp ivar
)
1478 (let ((varlist (list ivar
)))
1480 (setq exp
(cdr (ratrep* exp
)))
1481 (cond ((and (alike1 (pdis (car exp
))
1483 (not (atom (cdr exp
)))
1484 (equal (cadr (cdr exp
)) 2.
)
1485 (not (equal (ptterm (cddr exp
) 0.
) 0.
)))
1486 (setq exp
(mapcar 'pdis
(cdr (oddelm (cdr exp
)))))))))
1488 (defun mtoinf (grand ivar ll ul
)
1489 (prog (ans ans1 sd sn pp pe n d s nc dc $savefactors
*checkfactors
* temp
1491 (setq $savefactors t
)
1492 (setq sn
(setq sd
(list 1.
)))
1493 (cond ((eq ($sign
(m+ *loopstop
* -
1)) '$pos
)
1495 ((involve-var grand ivar
'(%sin %cos
))
1496 (cond ((and (evenfn grand ivar
)
1497 (or (setq temp
(scaxn grand ivar
))
1498 (setq temp
(ssp grand ivar ll ul
))))
1499 (return (m*t
2. temp
)))
1500 ((setq temp
(mtosc grand ivar
))
1503 ((among '$%i
(%einvolve-var grand ivar
))
1504 (cond ((setq temp
(mtosc grand ivar
))
1507 (setq grand
($exponentialize grand
)) ; exponentializing before numden
1508 (cond ((polyinx grand ivar nil
) ; avoids losing multiplicities [ 1309432 ]
1510 ((and (ratp grand ivar
)
1512 (andmapcar #'(lambda (e)
1513 (multiple-value-bind (result new-sn new-sd
)
1514 (snumden-var e ivar sn sd
)
1520 (setq nn-var
(m*l sn
) sn nil
)
1521 (setq dn-var
(m*l sd
) sd nil
))
1522 (t (multiple-value-setq (nn-var dn-var
)
1523 (numden-var grand ivar
))))
1524 (setq n
(rmconst1 nn-var ivar
))
1525 (setq d
(rmconst1 dn-var ivar
))
1530 (cond ((polyinx d ivar nil
)
1531 (setq s
(deg-var d ivar
))))
1532 (cond ((and (not (%einvolve-var grand ivar
))
1533 (notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
1534 (setq pp
(findp n ivar
))
1535 (eq (ask-integer pp
'$integer
) '$yes
)
1536 (setq pe
(bxm d s ivar
)))
1537 (cond ((and (eq (ask-integer (caddr pe
) '$even
) '$yes
)
1538 (eq (ask-integer pp
'$even
) '$yes
))
1539 (cond ((setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1540 (setq ans
(m*t
2. ans
))
1541 (return (m* (m// nc dc
) ans
)))))
1542 ((equal (car pe
) 1.
)
1543 (cond ((and (setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1544 (setq nn-var
(fan (m+ 1. pp
)
1549 (setq ans
(m+ ans
(m*t
(m^ -
1 pp
) nn-var
)))
1550 (return (m* (m// nc dc
) ans
))))))))
1553 ((pppin%ex
(nd ivar
)
1554 ;; Test to see if exp is of the form p(x)*f(exp(x)). If so, set pp to
1555 ;; be p(x) and set pe to f(exp(x)).
1556 (setq nd
($factor nd
))
1557 (cond ((polyinx nd ivar nil
)
1558 (setq pp
(cons nd pp
)) t
)
1559 ((catch 'pin%ex
(pin%ex nd ivar
))
1560 (setq pe
(cons nd pe
)) t
)
1562 (andmapcar #'(lambda (ex)
1565 (cond ((and (ratp grand ivar
)
1566 (setq ans1
(zmtorat n
1567 (cond ((mtimesp d
) d
) (t ($sqfr d
)))
1570 (mtorat n d s ivar
))
1572 (setq ans
(m*t
'$%pi ans1
))
1573 (return (m* (m// nc dc
) ans
)))
1574 ((and (or (%einvolve-var grand ivar
)
1575 (involve-var grand ivar
'(%sinh %cosh %tanh
)))
1576 (pppin%ex n ivar
) ;setq's P* and PE*...Barf again.
1577 (setq ans
(catch 'pin%ex
(pin%ex d ivar
))))
1578 ;; We have an integral of the form p(x)*F(exp(x)), where
1579 ;; p(x) is a polynomial.
1582 (return (dintexp grand ivar ll ul
)))
1583 ((not (and (zerop1 (get-limit grand ivar
'$inf
))
1584 (zerop1 (get-limit grand ivar
'$minf
))))
1585 ;; These limits must exist for the integral to converge.
1587 ((setq ans
(rectzto%pi2
(m*l pp
) (m*l pe
) d ivar
))
1588 ;; This only handles the case when the F(z) is a
1589 ;; rational function.
1590 (return (m* (m// nc dc
) ans
)))
1591 ((setq ans
(log-transform (m*l pp
) (m*l pe
) d ivar
))
1592 ;; If we get here, F(z) is not a rational function.
1593 ;; We transform it using the substitution x=log(y)
1594 ;; which gives us an integral of the form
1595 ;; p(log(y))*F(y)/y, which maxima should be able to
1597 (return (m* (m// nc dc
) ans
)))
1599 ;; Give up. We don't know how to handle this.
1602 (cond ((setq ans
(ggrm grand ivar
))
1604 ((and (evenfn grand ivar
)
1605 (setq *loopstop
* (m+ 1 *loopstop
*))
1606 (setq ans
(method-by-limits grand ivar
0 '$inf
)))
1607 (return (m*t
2. ans
)))
1610 (defun linpower0 (exp ivar
)
1611 (cond ((and (setq exp
(linpower exp ivar
))
1612 (eq (ask-integer (caddr exp
) '$even
)
1614 (ratgreaterp 0.
(car exp
)))
1617 ;;; given (b*x+a)^n+c returns (a b n c)
1618 (defun linpower (exp ivar
)
1619 (let (linpart deg lc c varlist
)
1620 (cond ((not (polyp-var exp ivar
)) nil
)
1621 (t (let ((varlist (list ivar
)))
1623 (setq linpart
(cadr (ratrep* exp
)))
1624 (cond ((atom linpart
)
1626 (t (setq deg
(cadr linpart
))
1627 ;;;get high degree of poly
1628 (setq linpart
($diff exp ivar
(m+ deg -
1)))
1629 ;;;diff down to linear.
1630 (setq lc
(sdiff linpart ivar
))
1631 ;;;all the way to constant.
1632 (setq linpart
(sratsimp (m// linpart lc
)))
1633 (setq lc
(sratsimp (m// lc
`((mfactorial) ,deg
))))
1634 ;;;get rid of factorial from differentiation.
1635 (setq c
(sratsimp (m+ exp
(m* (m- lc
)
1636 (m^ linpart deg
)))))))
1637 ;;;Sees if can be expressed as (a*x+b)^n + part freeof x.
1638 (cond ((not (among ivar c
))
1639 `(,lc
,linpart
,deg
,c
))
1642 (defun mtorat (n d s ivar
)
1643 (let ((*semirat
* t
))
1644 (cond ((and (null *dflag
*)
1645 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1646 (mtorat n d s ivar
)))))
1648 (t (csemiup n d ivar
)))))
1650 (defun zmtorat (n d s fn1 ivar
)
1652 (cond ((eq ($sign
(m+ s
(m+ 1 (setq nn
* (deg-var n ivar
)))))
1655 ((eq ($sign
(m+ s -
4))
1658 (setq d
($factor d
))
1659 (setq c
(rmconst1 d ivar
))
1665 (setq n
(partnum n d ivar
))
1667 (setq n
($xthru
(m+l
1668 (mapcar #'(lambda (a b
)
1669 (let ((foo (funcall fn1
(car a
) b
(deg-var b ivar
))))
1670 (if foo
(m// foo
(cadr a
))
1671 (return-from zmtorat nil
))))
1674 (return (cond (c (m// n c
))
1678 (setq n
(funcall fn1 n d s
))
1679 (return (when n
(sratsimp (cond (c (m// n c
))
1682 (defun pfrnum (f g n n2 ivar
)
1683 (let ((varlist (list ivar
)) genvar
)
1684 (setq f
(polyform f
)
1688 (setq ivar
(caadr (ratrep* ivar
)))
1689 (setq f
(resprog0-var ivar f g n n2
))
1690 (list (list (pdis (cadr f
)) (pdis (cddr f
)))
1691 (list (pdis (caar f
)) (pdis (cdar f
))))))
1696 (setq f
(ratrep* e
))
1697 (and (equal (cddr f
) 1)
1699 (and (equal (length (setq d
(cddr f
))) 3)
1702 (return (list (car d
)
1704 (ptimes (cadr f
) (caddr d
)))))
1705 (merror "defint: bug from PFRNUM in RESIDU.")))
1707 (defun partnum (n dl ivar
)
1708 (let ((n2 1) ans nl
)
1709 (do ((dl dl
(cdr dl
)))
1711 (nconc ans
(ncons (list n n2
))))
1712 (setq nl
(pfrnum (car dl
) (m*l
(cdr dl
)) n n2 ivar
))
1713 (setq ans
(nconc ans
(ncons (car nl
))))
1714 (setq n2
(cadadr nl
) n
(caadr nl
) nl nil
))))
1716 (defun ggrm (e ivar
)
1717 (prog (poly expo
*mtoinf
* mb varlist genvar l c gvar
)
1718 (setq varlist
(list ivar
))
1720 (cond ((and (setq expo
(%einvolve-var e ivar
))
1721 (polyp-var (setq poly
(sratsimp (m// e
(m^t
'$%e expo
)))) ivar
)
1722 (setq l
(catch 'ggrm
(ggr (m^t
'$%e expo
) nil ivar
))))
1724 (setq mb
(m- (subin-var 0.
(cadr l
) ivar
)))
1725 (setq poly
(m+ (subin-var (m+t mb ivar
) poly ivar
)
1726 (subin-var (m+t mb
(m*t -
1 ivar
)) poly ivar
))))
1728 (setq expo
(caddr l
)
1733 (setq poly
(cdr (ratrep* poly
)))
1734 (setq mb
(m^
(pdis (cdr poly
)) -
1)
1736 (setq gvar
(caadr (ratrep* ivar
)))
1737 (cond ((or (atom poly
)
1738 (pointergp gvar
(car poly
)))
1739 (setq poly
(list 0. poly
)))
1740 (t (setq poly
(cdr poly
))))
1741 (return (do ((poly poly
(cddr poly
)))
1743 (mul* (m^t
'$%e c
) (m^t expo -
1) mb
(m+l e
)))
1744 (setq e
(cons (ggrm1 (car poly
) (pdis (cadr poly
)) l expo
)
1747 (defun ggrm1 (d k a b
)
1748 (setq b
(m// (m+t
1. d
) b
))
1749 (m* k
`((%gamma
) ,b
) (m^ a
(m- b
))))
1751 ;; Compute the integral(n/d,x,0,inf) by computing the negative of the
1752 ;; sum of residues of log(-x)*n/d over the poles of n/d inside the
1753 ;; keyhole contour. This contour is basically an disk with a slit
1754 ;; along the positive real axis. n/d must be a rational function.
1755 (defun keyhole (n d ivar
)
1756 (let* ((*semirat
* ())
1757 (res (res-var ivar n d
1759 ;; Ok if not on the positive real axis.
1760 (or (not (equal ($imagpart j
) 0))
1761 (eq ($asksign j
) '$neg
)))
1763 (cond ((eq ($asksign j
) '$pos
)
1768 ($rectform
($multthru
(m+ (cond ((car res
)
1775 ;; Look at an expression e of the form sin(r*x)^k, where k is an
1776 ;; integer. Return the list (1 r k). (Not sure if the first element
1777 ;; of the list is always 1 because I'm not sure what partition is
1778 ;; trying to do here.)
1781 (cond ((atom e
) (return nil
)))
1782 (setq e
(partition e ivar
1))
1785 (cond ((setq r
(sinrx e ivar
))
1786 (return (list m r
1)))
1788 (eq (ask-integer (setq k
(caddr e
)) '$integer
) '$yes
)
1789 (setq r
(sinrx (cadr e
) ivar
)))
1790 (return (list m r k
))))))
1792 ;; Look at an expression e of the form sin(r*x) and return r.
1793 (defun sinrx (e ivar
)
1794 (cond ((and (consp e
) (eq (caar e
) '%sin
))
1795 (cond ((eq (cadr e
) ivar
)
1797 ((and (setq e
(partition (cadr e
) ivar
1))
1803 ;; integrate(a*sc(r*x)^k/x^n,x,0,inf).
1804 (defun ssp (exp ivar ll ul
)
1806 ;; Get the argument of the involved trig function.
1807 (when (null (setq arg
(involve-var exp ivar
'(%sin %cos
))))
1809 ;; I don't think this needs to be special.
1811 (declare (special n
))
1812 ;; Replace (1-cos(arg)^2) with sin(arg)^2.
1813 (setq exp
($substitute
;(m^t `((%sin) ,ivar) 2.)
1814 ;(m+t 1. (m- (m^t `((%cos) ,ivar) 2.)))
1815 ;; The code from above generates expressions with
1816 ;; a missing simp flag. Furthermore, the
1817 ;; substitution has to be done for the complete
1818 ;; argument of the trig function. (DK 02/2010)
1819 `((mexpt simp
) ((%sin simp
) ,arg
) 2)
1820 `((mplus) 1 ((mtimes) -
1 ((mexpt) ((%cos
) ,arg
) 2)))
1822 (multiple-value-bind (u dn
)
1823 (numden-var exp ivar
)
1824 (cond ((and (setq n
(findp dn ivar
))
1825 (eq (ask-integer n
'$integer
) '$yes
))
1826 ;; n is the power of the denominator.
1827 (cond ((setq c
(skr u ivar
))
1829 (return (scmp c n ivar ll ul
)))
1831 (setq c
(andmapcar #'(lambda (uu)
1834 ;; Do this for a sum of such terms.
1835 (return (m+l
(mapcar #'(lambda (j) (scmp j n ivar ll ul
))
1838 ;; We have an integral of the form sin(r*x)^k/x^n. C is the list (1 r k).
1840 ;; The substitution y=r*x converts this integral to
1842 ;; r^(n-1)*integral(sin(y)^k/y^n,y,0,inf)
1844 ;; (If r is negative, we need to negate the result.)
1846 ;; The recursion Wang gives on p. 87 has a typo. The second term
1847 ;; should be subtracted from the first. This formula is given in G&R,
1848 ;; 3.82, formula 12.
1850 ;; integrate(sin(x)^r/x^s,x) =
1851 ;; r*(r-1)/(s-1)/(s-2)*integrate(sin(x)^(r-2)/x^(s-2),x)
1852 ;; - r^2/(s-1)/(s-2)*integrate(sin(x)^r/x^(s-2),x)
1854 ;; (Limits are assumed to be 0 to inf.)
1856 ;; This recursion ends up with integrals with s = 1 or 2 and
1858 ;; integrate(sin(x)^p/x,x,0,inf) = integrate(sin(x)^(p-1),x,0,%pi/2)
1860 ;; with p > 0 and odd. This latter integral is known to maxima, and
1861 ;; it's value is beta(p/2,1/2)/2.
1863 ;; integrate(sin(x)^2/x^2,x,0,inf) = %pi/2*binomial(q-3/2,q-1)
1867 (defun scmp (c n ivar ll ul
)
1868 ;; Compute sign(r)*r^(n-1)*integrate(sin(y)^k/y^n,y,0,inf)
1869 (destructuring-bind (mult r k
)
1871 (let ((recursion (sinsp k n
)))
1877 ;; Recursion failed. Return the integrand
1878 ;; The following code generates expressions with a missing simp flag
1879 ;; for the sin function. Use better simplifying code. (DK 02/2010)
1880 ; (let ((integrand (div (pow `((%sin) ,(m* r ivar))
1883 (let ((integrand (div (power (take '(%sin
) (mul r ivar
))
1887 `((%integrate
) ,integrand
,ivar
,ll
,ul
)))))))
1889 ;; integrate(sin(x)^n/x^2,x,0,inf) = pi/2*binomial(n-3/2,n-1).
1890 ;; Express in terms of Gamma functions, though.
1892 (m* half%pi
($makegamma
`((%binomial
) ,(m+t
(m+ n -
1) '((rat) -
1 2))
1896 ;; integrate(sin(x)^n/x,x,0,inf) = beta((n+1)/2,1/2)/2, for n odd and
1901 (t (bygamma (m+ n -
1) 0.
))))
1903 ;; This implements the recursion for computing
1904 ;; integrate(sin(y)^l/y^k,y,0,inf). (Note the change in notation from
1909 (cond ((eq ($sign
(m+ l
(m- (m+ k -
1))))
1911 ;; Integral diverges if l-(k-1) < 0.
1913 ((not (even1 (m+ l k
)))
1914 ;; If l + k is not even, return NIL. (Is this the right
1918 ;; We have integrate(sin(y)^l/y^2). Use sevn to evaluate.
1921 ;; We have integrate(sin(y)^l/y,y)
1923 ((eq ($sign
(m+ k -
2.
))
1925 (setq i
(m* (m+ k -
1)
1926 (setq j
(m+ k -
2.
))))
1927 ;; j = k-2, i = (k-1)*(k-2)
1930 ;; The main recursion:
1933 ;; = l*(l-1)/(k-1)/(k-2)*i(sin(y)^(l-2)/y^k)
1934 ;; - l^2/(k-1)/(k-1)*i(sin(y)^l/y^(k-2))
1937 (sinsp (m+ l -
2.
) j
))
1942 ;; Returns the fractional part of a?
1946 ;; Why do we return 0 if a is a number? Perhaps we really
1950 ;; If we're here, this basically assumes a is a rational.
1951 ;; Compute the remainder and return the result.
1952 (list (car a
) (rem (cadr a
) (caddr a
)) (caddr a
)))
1953 ((and (atom a
) (abless1 a
)) a
)
1956 (abless1 (caddr a
)))
1959 ;; Doesn't appear to be used anywhere in Maxima. Not sure what this
1960 ;; was intended to do.
1963 (cond ((polyinx e var nil
) 0.
)
1969 (m+l
(mapcar #'thrad e
)))))
1972 ;;; THE FOLLOWING FUNCTION IS FOR TRIG FUNCTIONS OF THE FOLLOWING TYPE:
1973 ;;; LOWER LIMIT=0 B A MULTIPLE OF %PI SCA FUNCTION OF SIN (X) COS (X)
1976 (defun period (p e ivar
)
1977 (and (alike1 (no-err-sub-var ivar e ivar
)
1978 (setq e
(no-err-sub-var (m+ p ivar
) e ivar
)))
1979 ;; means there was no error
1982 ; returns cons of (integer_part . fractional_part) of a
1984 ;; I think we really want to compute how many full periods are in a
1985 ;; and the remainder.
1986 (let* ((q (igprt (div a
(mul 2 '$%pi
))))
1987 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
1990 ; returns cons of (integer_part . fractional_part) of a
1991 (defun lower-infr (a)
1992 ;; I think we really want to compute how many full periods are in a
1993 ;; and the remainder.
1994 (let* (;(q (igprt (div a (mul 2 '$%pi))))
1995 (q (mfuncall '$ceiling
(div a
(mul 2 '$%pi
))))
1996 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
2000 ;; Return the integer part of r.
2003 (mfuncall '$floor r
))
2006 ;;;Try making exp(%i*ivar) --> yy, if result is rational then do integral
2007 ;;;around unit circle. Make corrections for limits of integration if possible.
2008 (defun scrat (sc b ivar
)
2009 (let* ((exp-form (sconvert sc ivar
)) ;Exponentialize
2010 (rat-form (maxima-substitute 'yy
(m^t
'$%e
(m*t
'$%i ivar
))
2011 exp-form
))) ;Try to make Rational fun.
2012 (cond ((and (ratp rat-form
'yy
)
2013 (not (among ivar rat-form
)))
2014 (cond ((alike1 b %pi2
)
2015 (let ((ans (zto%pi2 rat-form
'yy
)))
2019 (evenfn exp-form ivar
))
2020 (let ((ans (zto%pi2 rat-form
'yy
)))
2021 (cond (ans (m*t
'((rat) 1.
2.
) ans
))
2023 ((and (alike1 b half%pi
)
2024 (evenfn exp-form ivar
)
2026 (no-err-sub-var (m+t
'$%pi
(m*t -
1 ivar
))
2029 (let ((ans (zto%pi2 rat-form
'yy
)))
2030 (cond (ans (m*t
'((rat) 1.
4.
) ans
))
2033 ;;; Do integrals of sin and cos. this routine makes sure lower limit
2035 (defun intsc1 (a b e ivar
)
2036 ;; integrate(e,var,a,b)
2037 (let ((trigarg (find-first-trigarg e
))
2040 (*sin-cos-recur
* t
)) ;recursion stopper
2041 (prog (ans d nzp2 l int-zero-to-d int-nzp2 int-zero-to-c limit-diff
)
2042 (let* ((arg (simple-trig-arg trigarg ivar
)) ;; pattern match sin(cc*x + bb)
2045 (new-var (gensym "NEW-VAR-")))
2046 (putprop new-var t
'internal
)
2048 (not (every-trigarg-alike e trigarg
)))
2050 (when (not (and (equal cc
1) (equal bb
0)))
2051 (setq e
(div (maxima-substitute (div (sub new-var bb
) cc
)
2054 (setq ivar new-var
) ;; change of variables to get sin(new-var)
2055 (setq a
(add bb
(mul a cc
)))
2056 (setq b
(add bb
(mul b cc
)))))
2057 (setq limit-diff
(m+ b
(m* -
1 a
)))
2058 (when (or (not (period %pi2 e ivar
))
2059 (member a
*infinities
*)
2060 (member b
*infinities
*)
2061 (not (and ($constantp a
)
2063 ;; Exit if b or a is not a constant or if the integrand
2064 ;; doesn't appear to have a period of 2 pi.
2067 ;; Multiples of 2*%pi in limits.
2068 (cond ((integerp (setq d
(let (($float nil
))
2069 (m// limit-diff %pi2
))))
2070 (cond ((setq ans
(intsc e %pi2 ivar
))
2071 (return (m* d ans
)))
2074 ;; The integral is not over a full period (2*%pi) or multiple
2075 ;; of a full period.
2077 ;; Wang p. 111: The integral integrate(f(x),x,a,b) can be
2080 ;; n * integrate(f,x,0,2*%pi) + integrate(f,x,0,c)
2081 ;; - integrate(f,x,0,d)
2083 ;; for some integer n and d >= 0, c < 2*%pi because there exist
2084 ;; integers p and q such that a = 2 * p *%pi + d and b = 2 * q
2085 ;; * %pi + c. Then n = q - p.
2087 ;; Compute q and c for the upper limit b.
2092 (setq int-zero-to-d
0.
)
2094 ;; Compute p and d for the lower limit a.
2096 ;; avoid an extra trip around the circle - helps skip principal values
2097 (if (ratgreaterp (car b
) (car l
)) ; if q > p
2098 (setq l
(cons (add 1 (car l
)) ; p += 1
2099 (add (mul -
1 %pi2
) (cdr l
))))) ; d -= 2*%pi
2101 ;; Compute -integrate(f,x,0,d)
2103 (cond ((setq ans
(try-intsc e
(cdr l
) ivar
))
2106 ;; Compute n = q - p (stored in nzp2)
2107 (setq nzp2
(m+ (car b
) (m- (car l
))))
2109 ;; Compute n*integrate(f,x,0,2*%pi)
2110 (setq int-nzp2
(cond ((zerop1 nzp2
)
2113 ((setq ans
(try-intsc e %pi2 ivar
))
2114 ;; n is not zero, so compute
2115 ;; integrate(f,x,0,2*%pi)
2117 ;; Unable to compute integrate(f,x,0,2*%pi)
2119 ;; Compute integrate(f,x,0,c)
2120 (setq int-zero-to-c
(try-intsc e
(cdr b
) ivar
))
2122 (return (cond ((and int-zero-to-d int-nzp2 int-zero-to-c
)
2123 ;; All three pieces succeeded.
2124 (add* int-zero-to-d int-nzp2 int-zero-to-c
))
2125 ((ratgreaterp %pi2 limit-diff
)
2126 ;; Less than 1 full period, so intsc can integrate it.
2127 ;; Apply the substitution to make the lower limit 0.
2128 ;; This is last resort because substitution often causes intsc to fail.
2129 (intsc (maxima-substitute (m+ a ivar
) ivar e
)
2134 ;; integrate(sc, var, 0, b), where sc is f(sin(x), cos(x)).
2135 ;; calls intsc with a wrapper to just return nil if integral is divergent,
2136 ;; rather than generating an error.
2137 (defun try-intsc (sc b ivar
)
2138 (let* ((*nodiverg
* t
)
2139 (ans (catch 'divergent
(intsc sc b ivar
))))
2140 (if (eq ans
'divergent
)
2144 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)). I (rtoy)
2145 ;; think this expects b to be less than 2*%pi.
2146 (defun intsc (sc b ivar
)
2149 (multiple-value-bind (b sc
)
2150 (cond ((eq ($sign b
) '$neg
)
2152 (m* -
1 (subin-var (m*t -
1 ivar
) sc ivar
))))
2155 ;; Partition the integrand SC into the factors that do not
2156 ;; contain VAR (the car part) and the parts that do (the cdr
2158 (setq sc
(partition sc ivar
1))
2159 (cond ((setq b
(intsc0 (cdr sc
) b ivar
))
2160 (m* (resimplify (car sc
)) b
))))))
2162 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)).
2163 (defun intsc0 (sc b ivar
)
2164 ;; Determine if sc is a product of sin's and cos's.
2165 (let ((nn* (scprod sc ivar
))
2168 ;; We have a product of sin's and cos's. We handle some
2169 ;; special cases here.
2170 (cond ((alike1 b half%pi
)
2171 ;; Wang p. 110, formula (1):
2172 ;; integrate(sin(x)^m*cos(x)^n, x, 0, %pi/2) =
2173 ;; gamma((m+1)/2)*gamma((n+1)/2)/2/gamma((n+m+2)/2)
2174 (bygamma (car nn
*) (cadr nn
*)))
2176 ;; Wang p. 110, near the bottom, says
2178 ;; int(f(sin(x),cos(x)), x, 0, %pi) =
2179 ;; int(f(sin(x),cos(x)) + f(sin(x),-cos(x)),x,0,%pi/2)
2180 (cond ((eq (real-branch (cadr nn
*) -
1) '$yes
)
2181 (m* (m+ 1.
(m^ -
1 (cadr nn
*)))
2182 (bygamma (car nn
*) (cadr nn
*))))))
2184 (cond ((or (and (eq (ask-integer (car nn
*) '$even
)
2186 (eq (ask-integer (cadr nn
*) '$even
)
2188 (and (ratnump (car nn
*))
2189 (eq (real-branch (car nn
*) -
1)
2191 (ratnump (cadr nn
*))
2192 (eq (real-branch (cadr nn
*) -
1)
2194 (m* 4.
(bygamma (car nn
*) (cadr nn
*))))
2195 ((or (eq (ask-integer (car nn
*) '$odd
) '$yes
)
2196 (eq (ask-integer (cadr nn
*) '$odd
) '$yes
))
2199 ((alike1 b half%pi3
)
2200 ;; Wang, p. 111 says
2202 ;; int(f(sin(x),cos(x)),x,0,3*%pi/2) =
2203 ;; int(f(sin(x),cos(x)),x,0,%pi)
2204 ;; + int(f(-sin(x),-cos(x)),x,0,%pi/2)
2205 (m* (m+ 1.
(m^ -
1 (cadr nn
*)) (m^ -
1 (m+l nn
*)))
2206 (bygamma (car nn
*) (cadr nn
*))))))
2208 ;; We don't have a product of sin's and cos's.
2209 (cond ((and (or (eq b
'$%pi
)
2212 (setq dn
* (scrat sc b ivar
)))
2214 ((setq nn
* (antideriv sc ivar
))
2215 (sin-cos-intsubs nn
* ivar
0. b
))
2218 ;;;Is careful about substitution of limits where the denominator may be zero
2219 ;;;because of various assumptions made.
2220 (defun sin-cos-intsubs (exp ivar ll ul
)
2222 (let ((l (mapcar #'(lambda (e)
2223 (sin-cos-intsubs1 e ivar ll ul
))
2225 (if (not (some #'null l
))
2227 (t (sin-cos-intsubs1 exp ivar ll ul
))))
2229 (defun sin-cos-intsubs1 (exp ivar ll ul
)
2230 (let* ((rat-exp ($rat exp
))
2231 (denom (pdis (cddr rat-exp
))))
2232 (cond ((equal ($csign denom
) '$zero
)
2234 (t (try-intsubs exp ll ul ivar
)))))
2236 (defun try-intsubs (exp ll ul ivar
)
2237 (let* ((*nodiverg
* t
)
2238 (ans (catch 'divergent
(intsubs exp ll ul ivar
))))
2239 (if (eq ans
'divergent
)
2243 (defun try-defint (exp ivar ll ul
)
2244 (let* ((*nodiverg
* t
)
2245 (ans (catch 'divergent
(defint exp ivar ll ul
))))
2246 (if (eq ans
'divergent
)
2250 ;; Determine whether E is of the form sin(x)^m*cos(x)^n and return the
2252 (defun scprod (e ivar
)
2253 (let ((great-minus-1 #'(lambda (temp)
2254 (ratgreaterp temp -
1)))
2257 ((setq m
(powerofx e
`((%sin
) ,ivar
) great-minus-1 ivar
))
2259 ((setq n
(powerofx e
`((%cos
) ,ivar
) great-minus-1 ivar
))
2263 (or (setq m
(powerofx (cadr e
) `((%sin
) ,ivar
) great-minus-1 ivar
))
2264 (setq n
(powerofx (cadr e
) `((%cos
) ,ivar
) great-minus-1 ivar
)))
2267 (setq m
(powerofx (caddr e
) `((%sin
) ,ivar
) great-minus-1 ivar
)))
2268 (t (setq n
(powerofx (caddr e
) `((%cos
) ,ivar
) great-minus-1 ivar
))))
2273 (defun real-branch (exponent value
)
2274 ;; Says whether (m^t value exponent) has at least one real branch.
2275 ;; Only works for values of 1 and -1 now. Returns $yes $no
2277 (cond ((equal value
1.
)
2279 ((eq (ask-integer exponent
'$integer
) '$yes
)
2282 (cond ((eq ($oddp
(caddr exponent
)) t
)
2287 ;; Compute beta((m+1)/2,(n+1)/2)/2.
2288 (defun bygamma (m n
)
2289 (let ((one-half (m//t
1.
2.
)))
2290 (m* one-half
`((%beta
) ,(m* one-half
(m+t
1. m
))
2291 ,(m* one-half
(m+t
1. n
))))))
2293 ;;Seems like Guys who call this don't agree on what it should return.
2294 (defun powerofx (e x p ivar
)
2295 (setq e
(cond ((not (among ivar e
)) nil
)
2300 (not (among ivar
(caddr e
))))
2302 (cond ((null e
) nil
)
2306 ;; Check e for an expression of the form x^kk*(b*x^n+a)^l. If it
2307 ;; matches, Return the two values kk and (list l a n b).
2308 (defun bata0 (e ivar
)
2310 (cond ((atom e
) nil
)
2312 ;; We have f(x)^y. Look to see if f(x) has the desired
2313 ;; form. Then f(x)^y has the desired form too, with
2314 ;; suitably modified values.
2316 ;; XXX: Should we ask for the sign of f(x) if y is not an
2317 ;; integer? This transformation we're going to do requires
2318 ;; that f(x)^y be real.
2319 (destructuring-bind (mexp base power
)
2321 (declare (ignore mexp
))
2322 (multiple-value-bind (kk cc
)
2325 ;; Got a match. Adjust kk and cc appropriately.
2326 (destructuring-bind (l a n b
)
2328 (values (mul kk power
)
2329 (list (mul l power
) a n b
)))))))
2332 (or (and (setq k
(findp (cadr e
) ivar
))
2333 (setq c
(bxm (caddr e
) (polyinx (caddr e
) ivar nil
) ivar
)))
2334 (and (setq k
(findp (caddr e
) ivar
))
2335 (setq c
(bxm (cadr e
) (polyinx (cadr e
) ivar nil
) ivar
)))))
2337 ((setq c
(bxm e
(polyinx e ivar nil
) ivar
))
2344 ;; (COND ((NOT (BATA0 E)) (RETURN NIL))
2345 ;; ((AND (EQUAL -1. (CADDDR C))
2346 ;; (EQ ($askSIGN (SETQ K (m+ 1. K)))
2348 ;; (EQ ($askSIGN (SETQ L (m+ 1. (CAR C))))
2351 ;; (m^ UL (CADDR C)))
2352 ;; (SETQ E (CADR C))
2353 ;; (EQ ($askSIGN (SETQ C (CADDR C))) '$pos))
2354 ;; (RETURN (M// (m* (m^ UL (m+t K (m* C (m+t -1. L))))
2355 ;; `(($BETA) ,(SETQ NN* (M// K C))
2360 ;; Integrals of the form i(log(x)^m*x^k*(a+b*x^n)^l,x,0,ul). There
2361 ;; are two cases to consider: One case has ul>0, b<0, a=-b*ul^n, k>-1,
2362 ;; l>-1, n>0, m a nonnegative integer. The second case has ul=inf, l < 0.
2364 ;; These integrals are essentially partial derivatives of the Beta
2365 ;; function (i.e. the Eulerian integral of the first kind). Note
2366 ;; that, currently, with the default setting intanalysis:true, this
2367 ;; function might not even be called for some of these integrals.
2368 ;; However, this can be palliated by setting intanalysis:false.
2370 (defun zto1 (e ivar
)
2371 (when (or (mtimesp e
) (mexptp e
))
2373 (log (list '(%log
) ivar
)))
2376 (find-if #'(lambda (fac)
2377 (powerofx fac log
#'set-m ivar
))
2379 (when (and (freeof ivar m
)
2380 (eq (ask-integer m
'$integer
) '$yes
)
2381 (not (eq ($asksign m
) '$neg
)))
2382 (setq e
(m//t e
(list '(mexpt) log m
)))
2385 (multiple-value-bind (kk s d r cc
)
2387 ;; We have i(x^kk/(d+cc*x^r)^s,x,0,inf) =
2388 ;; beta(aa,bb)/(cc^aa*d^bb*r). Compute this, and then
2389 ;; differentiate it m times to get the log term
2392 (let* ((aa (div (add 1 ivar
) r
))
2394 (m (if (eq ($asksign m
) '$zero
)
2397 (let ((res (div `((%beta
) ,aa
,bb
)
2401 ($at
($diff res ivar m
)
2402 (list '(mequal) ivar kk
)))))))
2404 (multiple-value-bind
2405 (k/n l n b
) (batap-new e ivar
)
2407 (let ((beta (ftake* '%beta k
/n l
))
2408 (m (if (eq ($asksign m
) '$zero
) 0 m
)))
2409 ;; The result looks like B(k/n,l) ( ... ).
2410 ;; Perhaps, we should just $factor, instead of
2411 ;; pulling out beta like this.
2417 (m^t
(m-t b
) (m1-t l
))
2418 (m^t
*ul
* (m*t n
(m1-t l
)))
2419 (m^t n
(m-t (m1+t m
)))
2420 ($at
($diff
(m*t
(m^t
*ul
* (m*t n ivar
))
2421 (list '(%beta
) ivar l
))
2423 (list '(mequal) ivar k
/n
)))
2427 ;;; If e is of the form given below, make the obvious change
2428 ;;; of variables (substituting ul*x^(1/n) for x) in order to reduce
2429 ;;; e to the usual form of the integrand in the Eulerian
2430 ;;; integral of the first kind.
2431 ;;; N. B: The old version of ZTO1 completely ignored this
2432 ;;; substitution; the log(x)s were just thrown in, which,
2433 ;;; of course would give wrong results.
2435 (defun batap-new (e ivar
)
2437 (multiple-value-bind (k c
)
2440 ;; e=x^k*(a+b*x^n)^l
2441 (destructuring-bind (l a n b
)
2443 (when (and (freeof ivar k
)
2446 (alike1 a
(m-t (m*t b
(m^t
*ul
* n
))))
2447 (eq ($asksign b
) '$neg
)
2448 (eq ($asksign
(setq k
(m1+t k
))) '$pos
)
2449 (eq ($asksign
(setq l
(m1+t l
))) '$pos
)
2450 (eq ($asksign n
) '$pos
))
2451 (values (m//t k n
) l n b
))))))
2454 ;; Wang p. 71 gives the following formula for a beta function:
2456 ;; integrate(x^(k-1)/(c*x^r+d)^s,x,0,inf)
2457 ;; = beta(a,b)/(c^a*d^b*r)
2459 ;; where a = k/r > 0, b = s - a > 0, s > k > 0, r > 0, c*d > 0.
2461 ;; This function matches this and returns k-1, d, r, c, a, b. And
2462 ;; also checks that all the conditions hold. If not, NIL is returned.
2464 (defun batap-inf (e ivar
)
2465 (multiple-value-bind (k c
)
2468 (destructuring-bind (l d r cc
)
2470 (let* ((s (mul -
1 l
))
2474 (when (and (freeof ivar k
)
2477 (eq ($asksign kk
) '$pos
)
2478 (eq ($asksign a
) '$pos
)
2479 (eq ($asksign b
) '$pos
)
2480 (eq ($asksign
(sub s k
)) '$pos
)
2481 (eq ($asksign r
) '$pos
)
2482 (eq ($asksign
(mul cc d
)) '$pos
))
2483 (values k s d r cc
)))))))
2486 ;; Handles beta integrals.
2487 (defun batapp (e ivar ll ul
)
2488 (cond ((not (or (equal ll
0)
2490 (setq e
(subin-var (m+ ll ivar
) e ivar
))))
2491 (multiple-value-bind (k c
)
2496 (destructuring-bind (l d al c
)
2498 ;; e = x^k*(d+c*x^al)^l.
2499 (let ((new-k (m// (m+ 1 k
) al
)))
2500 (when (and (ratgreaterp al
0.
)
2501 (eq ($asksign new-k
) '$pos
)
2502 (ratgreaterp (setq l
(m* -
1 l
))
2504 (eq ($asksign
(m* d c
))
2506 (setq l
(m+ l
(m*t -
1 new-k
)))
2507 (m// `((%beta
) ,new-k
,l
)
2508 (mul* al
(m^ c new-k
) (m^ d l
))))))))))
2511 ;; Compute exp(d)*gamma((c+1)/b)/b/a^((c+1)/b). In essence, this is
2512 ;; the value of integrate(x^c*exp(d-a*x^b),x,0,inf).
2513 (defun gamma1 (c a b d
)
2515 (m^
(m* b
(m^ a
(setq c
(m// (m+t c
1) b
)))) -
1)
2518 (defun zto%pi2
(grand ivar
)
2519 (let ((result (unitcir (sratsimp (m// grand ivar
)) ivar
)))
2520 (cond (result (sratsimp (m* (m- '$%i
) result
)))
2523 ;; Evaluates the contour integral of GRAND around the unit circle
2525 (defun unitcir (grand ivar
)
2526 (multiple-value-bind (nn dn
)
2527 (numden-var grand ivar
)
2529 (result (princip (res-var ivar nn dn
2531 ;; Is pt stricly inside the unit circle?
2532 (setq sgn
(let ((limitp nil
))
2533 ($asksign
(m+ -
1 (cabs pt
)))))
2536 (declare (ignore pt
))
2537 ;; Is pt on the unit circle? (Use
2538 ;; the cached value computed
2542 (setq sgn nil
)))))))
2544 (m* '$%pi result
)))))
2547 (defun logx1 (exp ll ul ivar
)
2550 ((and (notinvolve-var exp ivar
'(%sin %cos %tan %atan %asin %acos
))
2551 (setq arg
(involve-var exp ivar
'(%log
))))
2552 (cond ((eq arg ivar
)
2553 (cond ((ratgreaterp 1. ll
)
2554 (cond ((not (eq ul
'$inf
))
2555 (intcv1 (m^t
'$%e
(m- 'yx
)) (m- `((%log
) ,ivar
)) ivar ll ul
))
2556 (t (intcv1 (m^t
'$%e
'yx
) `((%log
) ,ivar
) ivar ll ul
))))))
2557 (t (intcv arg nil ivar ll ul
)))))))
2560 ;; Wang 81-83. Unfortunately, the pdf version has page 82 as all
2561 ;; black, so here is, as best as I can tell, what Wang is doing.
2562 ;; Fortunately, p. 81 has the necessary hints.
2564 ;; First consider integrate(exp(%i*k*x^n),x) around the closed contour
2565 ;; consisting of the real axis from 0 to R, the arc from the angle 0
2566 ;; to %pi/(2*n) and the ray from the arc back to the origin.
2568 ;; There are no poles in this region, so the integral must be zero.
2569 ;; But consider the integral on the three parts. The real axis is the
2570 ;; integral we want. The return ray is
2572 ;; exp(%i*%pi/2/n) * integrate(exp(%i*k*(t*exp(%i*%pi/2/n))^n),t,R,0)
2573 ;; = exp(%i*%pi/2/n) * integrate(exp(%i*k*t^n*exp(%i*%pi/2)),t,R,0)
2574 ;; = -exp(%i*%pi/2/n) * integrate(exp(-k*t^n),t,0,R)
2576 ;; As R -> infinity, this last integral is gamma(1/n)/k^(1/n)/n.
2578 ;; We assume the integral on the circular arc approaches 0 as R ->
2579 ;; infinity. (Need to prove this.)
2583 ;; integrate(exp(%i*k*t^n),t,0,inf)
2584 ;; = exp(%i*%pi/2/n) * gamma(1/n)/k^(1/n)/n.
2586 ;; Equating real and imaginary parts gives us the desired results:
2588 ;; integrate(cos(k*t^n),t,0,inf) = G * cos(%pi/2/n)
2589 ;; integrate(sin(k*t^n),t,0,inf) = G * sin(%pi/2/n)
2591 ;; where G = gamma(1/n)/k^(1/n)/n.
2593 (defun scaxn (e ivar
)
2595 (cond ((atom e
) nil
)
2596 ((and (or (eq (caar e
) '%sin
)
2597 (eq (caar e
) '%cos
))
2599 (setq e
(bx**n
(cadr e
) ivar
)))
2600 ;; Ok, we have cos(b*x^n) or sin(b*x^n), and we set e = (n
2602 (cond ((equal (car e
) 1.
)
2603 ;; n = 1. Give up. (Why not divergent?)
2605 ((zerop (setq s
(let ((sign ($asksign
(cadr e
))))
2606 (cond ((eq sign
'$pos
) 1)
2607 ((eq sign
'$neg
) -
1)
2608 ((eq sign
'$zero
) 0)))))
2609 ;; s is the sign of b. Give up if it's zero.
2611 ((not (eq ($asksign
(m+ -
1 (car e
))) '$pos
))
2612 ;; Give up if n-1 <= 0. (Why give up? Isn't the
2613 ;; integral divergent?)
2616 ;; We can apply our formula now. g = gamma(1/n)/n/b^(1/n)
2617 (setq g
(gamma1 0.
(m* s
(cadr e
)) (car e
) 0.
))
2618 (setq e
(m* g
`((,ind
) ,(m// half%pi
(car e
)))))
2619 (m* (cond ((and (eq ind
'%sin
)
2626 ;; this is the second part of the definite integral package
2628 (defun p*lognxp
(a s ivar
)
2630 (cond ((not (among '%log a
))
2632 ((and (polyinx (setq b
(maxima-substitute 1.
`((%log
) ,ivar
) a
))
2634 (eq ($sign
(m+ s
(m+ 1 (deg-var b ivar
))))
2637 (setq a
(lognxp (sratsimp (m// a b
)) ivar
)))
2640 (defun lognxp (a ivar
)
2641 (cond ((atom a
) nil
)
2642 ((and (eq (caar a
) '%log
)
2647 (lognxp (cadr a
) ivar
))
2650 (defun logcpi0 (n d ivar
)
2651 (prog (polelist dp plm rlm factors pl rl pl1 rl1
)
2653 (polelist-var ivar d
#'upperhalf
#'(lambda (j)
2656 ((equal ($imagpart j
) 0)
2658 (cond ((null polelist
)
2660 (setq factors
(car polelist
)
2661 polelist
(cdr polelist
))
2662 (cond ((or (cadr polelist
)
2664 (setq dp
(sdiff d ivar
))))
2665 (cond ((setq plm
(car polelist
))
2666 (setq rlm
(residue-var ivar
2668 (cond (*leadcoef
* factors
)
2671 (cond ((setq pl
(cadr polelist
))
2672 (setq rl
(res1-var ivar n dp pl
))))
2673 (cond ((setq pl1
(caddr polelist
))
2674 (setq rl1
(res1-var ivar n dp pl1
))))
2679 (list (cond ((setq nn
* (append rl rlm
))
2681 (cond (rl1 (m+l rl1
)))))))
2689 (defun lognx2 (nn dn pl rl
)
2690 (do ((pl pl
(cdr pl
))
2696 (setq ans
(cons (m* dn
(car rl
)
2697 ;; AFAICT, this call to PLOG doesn't need
2699 (m^
`((%plog
) ,(car pl
)) nn
))
2702 (defun logcpj (n d i ivar plm pl rl pl1 rl1
)
2705 (list (mul* (m*t
'$%i %pi2
)
2707 ;; AFAICT, this call to PLOG doesn't need
2708 ;; to bind VAR. An example where this is
2710 ;; integrate(log(x)^2/(1+x^2),x,0,1) =
2713 (m* (m^
`((%plog
) ,ivar
) i
)
2717 (lognx2 i
(m*t
'$%i %pi2
) pl rl
)
2718 (lognx2 i %p%i pl1 rl1
)))
2721 (simplify (m+l n
))))
2723 ;; Handle integral(n(x)/d(x)*log(x)^m,x,0,inf). n and d are
2725 (defun log*rat
(n d m ivar
)
2726 (let ((i-vals (make-array (1+ m
)))
2727 (j-vals (make-array (1+ m
))))
2729 ((logcpi (n d c ivar
)
2732 (m* '((rat) 1 2) (m+ (aref j-vals c
) (m* -
1 (sumi c
))))))
2738 (push (mul* ($makegamma
`((%binomial
) ,c
,k
))
2741 (aref i-vals
(- c k
)))
2743 (setf (aref j-vals
0) 0)
2744 (prog (*leadcoef
* res
)
2745 (dotimes (c m
(return (logcpi n d m ivar
)))
2746 (multiple-value-bind (res plm factors pl rl pl1 rl1
)
2748 (setf (aref i-vals c
) res
)
2749 (setf (aref j-vals c
) (logcpj n factors c ivar plm pl rl pl1 rl1
))))))))
2751 (defun fan (p m a n b
)
2752 (let ((povern (m// p n
))
2755 ((or (eq (ask-integer povern
'$integer
) '$yes
)
2756 (not (equal ($imagpart ab
) 0))) ())
2757 (t (let ((ind ($asksign ab
)))
2758 (cond ((eq ind
'$zero
) nil
)
2759 ((eq ind
'$neg
) nil
)
2760 ((not (ratgreaterp m povern
)) nil
)
2762 ($makegamma
`((%binomial
) ,(m+ -
1 m
(m- povern
))
2764 `((mabs) ,(m^ a
(m+ povern
(m- m
)))))
2767 `((%sin
) ,(m*t
'$%pi povern
)))))))))))
2770 ;;Makes a new poly such that np(x)-np(x+2*%i*%pi)=p(x).
2771 ;;Constructs general POLY of degree one higher than P with
2772 ;;arbitrary coeff. and then solves for coeffs by equating like powers
2773 ;;of the varibale of integration.
2774 ;;Can probably be made simpler now.
2776 (defun makpoly (p ivar
)
2777 (let ((n (deg-var p ivar
)) (ans ()) (varlist ()) (gp ()) (cl ()) (zz ()))
2778 (setq ans
(genpoly (m+ 1 n
) ivar
)) ;Make poly with gensyms of 1 higher deg.
2779 (setq cl
(cdr ans
)) ;Coefficient list
2780 (setq varlist
(append cl
(list ivar
))) ;Make VAR most important.
2781 (setq gp
(car ans
)) ;This is the poly with gensym coeffs.
2782 ;;;Now, poly(x)-poly(x+2*%i*%pi)=p(x), P is the original poly.
2783 (setq ans
(m+ gp
(subin-var (m+t
(m*t
'$%i %pi2
) ivar
) (m- gp
) ivar
) (m- p
)))
2785 (setq ans
(ratrep* ans
)) ;Rational rep with VAR leading.
2786 (setq zz
(coefsolve n cl
(cond ((not (eq (caadr ans
) ;What is Lead Var.
2787 (genfind (car ans
) ivar
)))
2788 (list 0 (cadr ans
))) ;No VAR in ans.
2789 ((cdadr ans
))))) ;The real Poly.
2790 (if (or (null zz
) (null gp
))
2792 ($substitute zz gp
)))) ;Substitute Values for gensyms.
2794 (defun coefsolve (n cl e
)
2796 (eql (ncons (pdis (ptterm e n
))) (cons (pdis (ptterm e m
)) eql
))
2797 (m (m+ n -
1) (m+ m -
1)))
2798 ((signp l m
) (solvex eql cl nil nil
))))
2800 ;; Integrate(p(x)*f(exp(x))/g(exp(x)),x,minf,inf) by applying the
2801 ;; transformation y = exp(x) to get
2802 ;; integrate(p(log(y))*f(y)/g(y)/y,y,0,inf). This should be handled
2804 (defun log-transform (p pe d ivar
)
2805 (let ((new-p (subst (list '(%log
) ivar
) ivar p
))
2806 (new-pe (subst ivar
'z
* (catch 'pin%ex
(pin%ex pe ivar
))))
2807 (new-d (subst ivar
'z
* (catch 'pin%ex
(pin%ex d ivar
)))))
2808 (defint (div (div (mul new-p new-pe
) new-d
) ivar
) ivar
0 *ul
*)))
2810 ;; This implements Wang's algorithm in Chapter 5.2, pp. 98-100.
2812 ;; This is a very brief description of the algorithm. Basically, we
2813 ;; have integrate(R(exp(x))*p(x),x,minf,inf), where R(x) is a rational
2814 ;; function and p(x) is a polynomial.
2816 ;; We find a polynomial q(x) such that q(x) - q(x+2*%i*%pi) = p(x).
2817 ;; Then consider a contour integral of R(exp(z))*q(z) over a
2818 ;; rectangular contour. Opposite corners of the rectangle are (-R,
2819 ;; 2*%i*%pi) and (R, 0).
2821 ;; Wang shows that this contour integral, in the limit, is the
2822 ;; integral of R(exp(x))*q(x)-R(exp(x))*q(x+2*%i*%pi), which is
2823 ;; exactly the integral we're looking for.
2825 ;; Thus, to find the value of the contour integral, we just need the
2826 ;; residues of R(exp(z))*q(z). The only tricky part is that we want
2827 ;; the log function to have an imaginary part between 0 and 2*%pi
2828 ;; instead of -%pi to %pi.
2829 (defun rectzto%pi2
(p pe d ivar
)
2830 ;; We have R(exp(x))*p(x) represented as p(x)*pe(exp(x))/d(exp(x)).
2831 (prog (dp n pl a b c denom-exponential
)
2832 (if (not (and (setq denom-exponential
(catch 'pin%ex
(pin%ex d ivar
)))
2833 (%e-integer-coeff pe ivar
)
2834 (%e-integer-coeff d ivar
)))
2836 ;; At this point denom-exponential has converted d(exp(x)) to the
2837 ;; polynomial d(z), where z = exp(x).
2838 (setq n
(m* (cond ((null p
) -
1)
2839 (t ($expand
(m*t
'$%i %pi2
(makpoly p ivar
)))))
2841 (let ((*leadcoef
* ()))
2842 ;; Find the poles of the denominator. denom-exponential is the
2843 ;; denominator of R(x).
2845 ;; It seems as if polelist returns a list of several items.
2846 ;; The first element is a list consisting of the pole and (z -
2847 ;; pole). We don't care about this, so we take the rest of the
2849 (setq pl
(cdr (polelist-var 'z
* denom-exponential
2851 ;; The imaginary part is nonzero,
2852 ;; or the realpart is negative.
2853 (or (not (equal ($imagpart j
) 0))
2854 (eq ($asksign
($realpart j
)) '$neg
)))
2856 ;; The realpart is not zero.
2857 (not (eq ($asksign
($realpart j
)) '$zero
)))))))
2858 ;; Not sure what this does.
2860 ;; No roots at all, so return
2864 ;; We have simple roots or roots in REGION1
2865 (setq dp
(sdiff d ivar
))))
2867 ;; The cadr of pl is the list of the simple poles of
2868 ;; denom-exponential. Take the log of them to find the
2869 ;; poles of the original expression. Then compute the
2870 ;; residues at each of these poles and sum them up and put
2871 ;; the result in B. (If no simple poles set B to 0.)
2872 (setq b
(mapcar #'log-imag-0-2%pi
(cadr pl
)))
2873 (setq b
(res1-var ivar n dp b
))
2877 ;; I think this handles the case of poles outside the
2878 ;; regions. The sum of these residues are placed in C.
2879 (let ((temp (mapcar #'log-imag-0-2%pi
(caddr pl
))))
2880 (setq c
(append temp
(mapcar #'(lambda (j)
2881 (m+ (m*t
'$%i %pi2
) j
))
2883 (setq c
(res1-var ivar n dp c
))
2887 ;; We have the repeated poles of deonom-exponential, so we
2888 ;; need to convert them to the actual pole values for
2889 ;; R(exp(x)), by taking the log of the value of poles.
2890 (let ((poles (mapcar #'(lambda (p)
2891 (log-imag-0-2%pi
(car p
)))
2893 (exp (m// n
(subst (m^t
'$%e ivar
) 'z
* denom-exponential
))))
2894 ;; Compute the residues at all of these poles and sum
2896 (setq a
(mapcar #'(lambda (j)
2897 ($residue exp ivar j
))
2901 (return (sratsimp (m+ a b
(m* '((rat) 1.
2.
) c
))))))
2903 (defun genpoly (i ivar
)
2904 (do ((i i
(m+ i -
1))
2905 (c (gensym) (gensym))
2909 (cons (m+l ans
) cl
))
2910 (setq ans
(cons (m* c
(m^t ivar i
)) ans
))
2911 (setq cl
(cons c cl
))))
2913 ;; Check to see if each term in exp that is of the form exp(k*x) has
2914 ;; an integer value for k.
2915 (defun %e-integer-coeff
(exp ivar
)
2916 (cond ((mapatom exp
) t
)
2918 (eq (cadr exp
) '$%e
))
2919 (eq (ask-integer ($coeff
(caddr exp
) ivar
) '$integer
)
2921 (t (every #'(lambda (e)
2922 (%e-integer-coeff e ivar
))
2925 (defun wlinearpoly (e ivar
)
2926 (cond ((and (setq e
(polyinx e ivar t
))
2927 (equal (deg-var e ivar
) 1))
2928 (subin-var 1 e ivar
))))
2930 ;; Test to see if exp is of the form f(exp(x)), and if so, replace
2931 ;; exp(x) with 'z*. That is, basically return f(z*).
2932 (defun pin%ex
(exp ivar
)
2933 (pin%ex0
(cond ((notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
2936 (let (($exponentialize t
))
2937 (setq exp
($expand exp
)))))
2940 (defun pin%ex0
(e ivar
)
2941 ;; Does e really need to be special here? Seems to be ok without
2942 ;; it; testsuite works.
2944 (declare (special e
))
2945 (cond ((not (among ivar e
))
2948 (throw 'pin%ex nil
))
2951 (cond ((eq (caddr e
) ivar
)
2953 ((let ((linterm (wlinearpoly (caddr e
) ivar
)))
2955 (m* (subin-var 0 e ivar
) (m^t
'z
* linterm
)))))
2957 (throw 'pin%ex nil
))))
2959 (m*l
(mapcar #'(lambda (ee)
2963 (m+l
(mapcar #'(lambda (ee)
2967 (throw 'pin%ex nil
))))
2969 (defun findsub (p ivar
)
2971 (cond ((findp p ivar
) nil
)
2972 ((setq nd
(bx**n p ivar
))
2973 (m^t ivar
(car nd
)))
2974 ((setq p
(bx**n
+a p ivar
))
2975 (m* (caddr p
) (m^t ivar
(cadr p
)))))))
2977 ;; I think this is looking at f(exp(x)) and tries to find some
2978 ;; rational function R and some number k such that f(exp(x)) =
2980 (defun funclogor%e
(e ivar
)
2981 (prog (ans arg nvar r
)
2982 (cond ((or (ratp e ivar
)
2983 (involve-var e ivar
'(%sin %cos %tan
))
2984 (not (setq arg
(xor (and (setq arg
(involve-var e ivar
'(%log
)))
2986 (%einvolve-var e ivar
)))))
2988 ag
(setq nvar
(cond ((eq r
'%log
) `((%log
) ,arg
))
2989 (t (m^t
'$%e arg
))))
2990 (setq ans
(maxima-substitute (m^t
'yx -
1) (m^t nvar -
1) (maxima-substitute 'yx nvar e
)))
2991 (cond ((not (among ivar ans
)) (return (list (subst ivar
'yx ans
) nvar
)))
2993 (setq arg
(findsub arg ivar
)))
2996 ;; Integration by parts.
2998 ;; integrate(u(x)*diff(v(x),x),x,a,b)
3000 ;; = u(x)*v(x)| - integrate(v(x)*diff(u(x),x))
3003 (defun dintbypart (u v a b ivar
)
3004 ;;;SINCE ONLY CALLED FROM DINTLOG TO get RID OF LOGS - IF LOG REMAINS, QUIT
3005 (let ((ad (antideriv v ivar
)))
3006 (cond ((or (null ad
)
3007 (involve-var ad ivar
'(%log
)))
3009 (t (let ((p1 (m* u ad
))
3010 (p2 (m* ad
(sdiff u ivar
))))
3011 (let ((p1-part1 (get-limit p1 ivar b
'$minus
))
3012 (p1-part2 (get-limit p1 ivar a
'$plus
)))
3013 (cond ((or (null p1-part1
)
3016 (t (let ((p2 (defint p2 ivar a b
)))
3017 (cond (p2 (add* p1-part1
3022 ;; integrate(f(exp(k*x)),x,a,b), where f(z) is rational.
3024 ;; See Wang p. 96-97.
3026 ;; If the limits are minf to inf, we use the substitution y=exp(k*x)
3027 ;; to get integrate(f(y)/y,y,0,inf)/k. If the limits are 0 to inf,
3028 ;; use the substitution s+1=exp(k*x) to get
3029 ;; integrate(f(s+1)/(s+1),s,0,inf).
3030 (defun dintexp (exp ivar ll ul
&aux ans
)
3031 (let ((*dintexp-recur
* t
)) ;recursion stopper
3032 (cond ((and (sinintp exp ivar
) ;To be moved higher in the code.
3033 (setq ans
(antideriv exp ivar
))
3034 (setq ans
(intsubs ans ll ul ivar
)))
3035 ;; If we can integrate it directly, do so and take the
3036 ;; appropriate limits.
3038 ((setq ans
(funclogor%e exp ivar
))
3039 ;; ans is the list (f(x) exp(k*x)).
3040 (cond ((and (equal ll
0.
)
3042 ;; Use the substitution s + 1 = exp(k*x). The
3043 ;; integral becomes integrate(f(s+1)/(s+1),s,0,inf)
3044 (setq ans
(m+t -
1 (cadr ans
))))
3046 ;; Use the substitution y=exp(k*x) because the
3047 ;; limits are minf to inf.
3048 (setq ans
(cadr ans
))))
3049 ;; Apply the substitution and integrate it.
3050 (intcv ans nil ivar ll ul
)))))
3052 ;; integrate(log(g(x))*f(x),x,0,inf)
3053 (defun dintlog (exp arg ivar ll ul
)
3054 (let ((*dintlog-recur
* (1+ *dintlog-recur
*))) ;recursion stopper
3056 (cond ((and (eq ul
'$inf
)
3059 (equal 1 (sratsimp (m// exp
(m* (m- (subin-var (m^t ivar -
1)
3063 ;; Make the substitution y=1/x. If the integrand has
3064 ;; exactly the same form, the answer has to be 0.
3066 ((and (setq ans
(let (($gamma_expand t
)) (logx1 exp ll ul ivar
)))
3069 ((setq ans
(antideriv exp ivar
))
3070 ;; It's easy if we have the antiderivative.
3071 ;; but intsubs sometimes gives results containing %limit
3072 (return (intsubs ans ll ul ivar
))))
3073 ;; Ok, the easy cases didn't work. We now try integration by
3074 ;; parts. Set ANS to f(x).
3075 (setq ans
(m// exp
`((%log
) ,arg
)))
3076 (cond ((involve-var ans ivar
'(%log
))
3077 ;; Bad. f(x) contains a log term, so we give up.
3080 (equal 0.
(no-err-sub-var 0. ans ivar
))
3081 (setq d
(defint (m* ans
(m^t ivar
'*z
*))
3083 ;; The arg of the log function is the same as the
3084 ;; integration variable. We can do something a little
3085 ;; simpler than integration by parts. We have something
3086 ;; like f(x)*log(x). Consider f(x)*x^z. If we
3087 ;; differentiate this wrt to z, the integrand becomes
3088 ;; f(x)*log(x)*x^z. When we evaluate this at z = 0, we
3089 ;; get the desired integrand.
3091 ;; So we need f(0) to be 0 at 0. If we can integrate
3092 ;; f(x)*x^z, then we differentiate the result and
3093 ;; evaluate it at z = 0.
3094 (return (derivat '*z
* 1. d
0.
)))
3095 ((setq ans
(dintbypart `((%log
) ,arg
) ans ll ul ivar
))
3096 ;; Try integration by parts.
3099 ;; Compute diff(e,ivar,n) at the point pt.
3100 (defun derivat (ivar n e pt
)
3101 (subin-var pt
(apply '$diff
(list e ivar n
)) ivar
))
3105 ;; MAYBPC returns (COEF EXPO CONST)
3107 ;; This basically picks off b*x^n+a and returns the list
3109 (defun maybpc (e ivar nd-var
)
3111 (cond (*mtoinf
* (throw 'ggrm
(linpower0 e ivar
)))
3112 ((and (not *mtoinf
*)
3113 (null (setq e
(bx**n
+a e ivar
)))) ;bx**n+a --> (a n b) or nil.
3114 nil
) ;with ivar being x.
3115 ;; At this point, e is of the form (a n b)
3116 ((and (among '$%i
(caddr e
))
3117 (zerop1 ($realpart
(caddr e
)))
3118 (setq zn
($imagpart
(caddr e
)))
3119 (eq ($asksign
(cadr e
)) '$pos
))
3120 ;; If we're here, b is complex, and n > 0. zn = imagpart(b).
3122 ;; Set ivar to the same sign as zn.
3123 (cond ((eq ($asksign zn
) '$neg
)
3127 ;; zd = exp(ivar*%i*%pi*(1+nd)/(2*n). (ZD is special!)
3128 (setq zd
(m^t
'$%e
(m// (mul* ivar
'$%i
'$%pi
(m+t
1 nd-var
))
3130 ;; Return zn, n, a, zd.
3131 (values `(,(caddr e
) ,(cadr e
) ,(car e
)) zd
))
3132 ((and (or (eq (setq ivar
($asksign
($realpart
(caddr e
)))) '$neg
)
3133 (equal ivar
'$zero
))
3134 (equal ($imagpart
(cadr e
)) 0)
3135 (ratgreaterp (cadr e
) 0.
))
3136 ;; We're here if realpart(b) <= 0, and n >= 0. Then return -b, n, a.
3137 `(,(caddr e
) ,(cadr e
) ,(car e
))))))
3139 ;; Integrate x^m*exp(b*x^n+a), with realpart(m) > -1.
3141 ;; See Wang, pp. 84-85.
3143 ;; I believe the formula Wang gives is incorrect. The derivation is
3144 ;; correct except for the last step.
3146 ;; Let J = integrate(x^m*exp(%i*k*x^n),x,0,inf), with real k.
3148 ;; Consider the case for k < 0. Take a sector of a circle bounded by
3149 ;; the real line and the angle -%pi/(2*n), and by the radii, r and R.
3150 ;; Since there are no poles inside this contour, the integral
3152 ;; integrate(z^m*exp(%i*k*z^n),z) = 0
3154 ;; Then J = exp(-%pi*%i*(m+1)/(2*n))*integrate(R^m*exp(k*R^n),R,0,inf)
3156 ;; because the integral along the boundary is zero except for the part
3157 ;; on the real axis. (Proof?)
3159 ;; Wang seems to say this last integral is gamma(s/n/(-k)^s) where s =
3160 ;; (m+1)/n. But that seems wrong. If we use the substitution R =
3161 ;; (y/(-k))^(1/n), we end up with the result:
3163 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n).
3165 ;; or gamma((m+1)/n)/k^((m+1)/n)/n.
3167 ;; Note that this also handles the case of
3169 ;; integrate(x^m*exp(-k*x^n),x,0,inf);
3171 ;; where k is positive real number. A simple change of variables,
3174 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n))
3176 ;; which is the same form above.
3177 (defun ggr (e ind ivar
)
3178 (prog (c zd nn
* dn
* nd-var dosimp $%emode
)
3180 (cond (ind (setq e
($expand e
))
3181 (cond ((and (mplusp e
)
3182 (let ((*nodiverg
* t
))
3183 (setq e
(catch 'divergent
3188 (cond ((eq e
'divergent
) nil
)
3189 (t (return (sratsimp (cons '(mplus) e
)))))))))
3190 (setq e
(rmconst1 e ivar
))
3193 (cond ((multiple-value-setq (e zd
)
3194 (ggr1 e ivar nd-var
))
3195 ;; e = (m b n a). That is, the integral is of the form
3196 ;; x^m*exp(b*x^n+a). I think we want to compute
3197 ;; gamma((m+1)/n)/b^((m+1)/n)/n.
3199 ;; FIXME: If n > m + 1, the integral converges. We need
3200 ;; to check for this.
3201 (destructuring-bind (m b n a
)
3203 (when (and (not (zerop1 ($realpart b
)))
3204 (not (zerop1 ($imagpart b
))))
3205 ;; The derivation only holds if b is purely real or
3206 ;; purely imaginary. Give up if it's not.
3208 ;; Check for convergence. If b is complex, we need n -
3209 ;; m > 1. If b is real, we need b < 0.
3210 (when (and (zerop1 ($imagpart b
))
3211 (not (eq ($asksign b
) '$neg
)))
3213 (when (and (not (zerop1 ($imagpart b
)))
3214 (not (eq ($asksign
(sub n
(add m
1))) '$pos
)))
3217 (setq e
(gamma1 m
(cond ((zerop1 ($imagpart b
))
3218 ;; If we're here, b must be negative.
3221 ;; Complex b. Take the imaginary part
3222 `((mabs) ,($imagpart b
))))
3225 ;; FIXME: Why do we set %emode here? Shouldn't we just
3226 ;; bind it? And why do we want it bound to T anyway?
3227 ;; Shouldn't the user control that? The same goes for
3231 (setq e
(m* zd e
))))))
3232 (cond (e (return (m* c e
))))))
3235 ;; Match x^m*exp(b*x^n+a). If it does, return (list m b n a).
3236 (defun ggr1 (e ivar nd-var
)
3238 (cond ((atom e
) nil
)
3241 ;; We're looking at something like exp(f(ivar)). See if it's
3242 ;; of the form b*x^n+a, and return (list 0 b n a). (The 0 is
3243 ;; so we can graft something onto it if needed.)
3244 (cond ((multiple-value-setq (e zd
)
3245 (maybpc (caddr e
) ivar nd-var
))
3246 (values (cons 0. e
) zd
))))
3248 ;; E should be the product of exactly 2 terms
3250 ;; Check to see if one of the terms is of the form
3251 ;; ivar^p. If so, make sure the realpart of p > -1. If
3252 ;; so, check the other term has the right form via
3253 ;; another call to ggr1.
3254 (or (and (setq dn
* (xtorterm (cadr e
) ivar
))
3255 (ratgreaterp (setq nd-var
($realpart dn
*))
3257 (multiple-value-setq (nn* zd
)
3258 (ggr1 (caddr e
) ivar nd-var
)))
3259 (and (setq dn
* (xtorterm (caddr e
) ivar
))
3260 (ratgreaterp (setq nd-var
($realpart dn
*))
3262 (multiple-value-setq (nn* zd
)
3263 (ggr1 (cadr e
) ivar nd-var
)))))
3264 ;; Both terms have the right form and nn* contains the ivar of
3265 ;; the exponential term. Put dn* as the car of nn*. The
3266 ;; result is something like (m b n a) when we have the
3267 ;; expression x^m*exp(b*x^n+a).
3268 (values (rplaca nn
* dn
*) zd
)))))
3271 ;; Match b*x^n+a. If a match is found, return the list (a n b).
3272 ;; Otherwise, return NIL
3273 (defun bx**n
+a
(e ivar
)
3278 (t (let ((a (no-err-sub-var 0. e ivar
)))
3280 (t (setq e
(m+ e
(m*t -
1 a
)))
3281 (cond ((setq e
(bx**n e ivar
))
3285 ;; Match b*x^n. Return the list (n b) if found or NIL if not.
3286 (defun bx**n
(e ivar
)
3288 (and (setq n
(xexponget e ivar
))
3290 (setq e
(let (($maxposex
1)
3292 ($expand
(m// e
(m^t ivar n
)))))))
3295 ;; nn* should be the value of var. This is only called by bx**n with
3296 ;; the second arg of var.
3297 (defun xexponget (e nn
*)
3298 (cond ((atom e
) (cond ((eq e nn
*) 1.
)))
3302 (not (among nn
* (caddr e
))))
3304 (t (some #'(lambda (j) (xexponget j nn
*)) (cdr e
)))))
3307 ;;; given (b*x^n+a)^m returns (m a n b)
3308 (defun bxm (e ind ivar
)
3312 (involve-var e ivar
'(%log %sin %cos %tan
))
3313 (%einvolve-var e ivar
))
3316 ((mexptp e
) (cond ((among ivar
(caddr e
)) nil
)
3317 ((setq r
(bx**n
+a
(cadr e
) ivar
))
3318 (cons (caddr e
) r
))))
3319 ((setq r
(bx**n
+a e ivar
)) (cons 1. r
))
3321 ;;;Catches Unfactored forms.
3322 (multiple-value-bind (m r
)
3323 (numden-var (m// (sdiff e ivar
) e
)
3326 ((and (setq r
(bx**n
+a
(sratsimp r
) ivar
))
3327 (not (among ivar
(setq m
(m// m
(m* (cadr r
) (caddr r
)
3328 (m^t ivar
(m+t -
1 (cadr r
))))))))
3329 (setq e
(m// (subin-var 0. e ivar
) (m^t
(car r
) m
))))
3332 (t (setq e
(m^ e
(m// 1. m
)))
3333 (list m
(m* e
(car r
)) (cadr r
)
3334 (m* e
(caddr r
)))))))))
3337 ;;;Is E = VAR raised to some power? If so return power or 0.
3338 (defun findp (e ivar
)
3339 (cond ((not (among ivar e
)) 0.
)
3340 (t (xtorterm e ivar
))))
3342 (defun xtorterm (e ivar
)
3343 ;;;Is E = VAR1 raised to some power? If so return power.
3344 (cond ((alike1 e ivar
) 1.
)
3347 (alike1 (cadr e
) ivar
)
3348 (not (among ivar
(caddr e
))))
3352 (m^
(m* (m^
(caddr l
) '((rat) 1 2))
3353 (m+ (cadr l
) (m^
(m* (car l
) (caddr l
))
3357 (defun radbyterm (d l ivar
)
3362 (destructuring-let (((const . integrand
) (rmconst1 (car l
) ivar
)))
3363 (setq ans
(cons (m* const
(dintrad0 integrand d ivar
))
3366 (defun sqdtc (e ind ivar
)
3367 (prog (a b c varlist
)
3368 (setq varlist
(list ivar
))
3370 (setq e
(cdadr (ratrep* e
)))
3371 (setq c
(pdis (ptterm e
0)))
3372 (setq b
(m*t
(m//t
1 2) (pdis (ptterm e
1))))
3373 (setq a
(pdis (ptterm e
2)))
3374 (cond ((and (eq ($asksign
(m+ b
(m^
(m* a c
)
3378 (not (eq ($asksign a
) '$neg
))
3379 (eq ($asksign c
) '$pos
))
3380 (and (eq ($asksign a
) '$pos
)
3381 (not (eq ($asksign c
) '$neg
)))))
3382 (return (list a b c
))))))
3384 (defun difap1 (e pwr ivar m pt
)
3385 (m// (mul* (cond ((eq (ask-integer m
'$even
) '$yes
)
3389 (derivat ivar m e pt
))
3390 `((%gamma
) ,(m+ pwr m
))))
3392 ;; Note: This doesn't seem be called from anywhere.
3393 (defun sqrtinvolve (e ivar
)
3394 (cond ((atom e
) nil
)
3397 (and (mnump (caddr e
))
3398 (not (numberp (caddr e
)))
3399 (equal (caddr (caddr e
)) 2.
))
3400 (among ivar
(cadr e
)))
3402 (t (some #'(lambda (a)
3403 (sqrtinvolve a ivar
))
3406 (defun bydif (r s d ivar
)
3408 (setq d
(m+ (m*t
'*z
* ivar
) d
))
3409 (cond ((or (zerop1 (setq p
(m+ s
(m*t -
1 r
))))
3410 (and (zerop1 (m+ 1 p
))
3412 (difap1 (dintrad0 b
(m^ d
'((rat) 3 2)) ivar
)
3413 '((rat) 3 2) '*z
* r
0))
3414 ((eq ($asksign p
) '$pos
)
3415 (difap1 (difap1 (dintrad0 1 (m^
(m+t
'z
** d
)
3418 '((rat) 3 2) '*z
* r
0)
3419 '((rat) 3 2) 'z
** p
0)))))
3421 (defun dintrad0 (n d ivar
)
3423 (cond ((and (mexptp d
)
3424 (equal (deg-var (cadr d
) ivar
) 2.
))
3425 (cond ((alike1 (caddr d
) '((rat) 3.
2.
))
3426 (cond ((and (equal n
1.
)
3427 (setq l
(sqdtc (cadr d
) t ivar
)))
3430 (setq l
(sqdtc (cadr d
) nil ivar
)))
3431 (tbf (reverse l
)))))
3432 ((and (setq r
(findp n ivar
))
3433 (or (eq ($asksign
(m+ -
1.
(m- r
) (m*t
2.
3437 (setq s
(m+ '((rat) -
3.
2.
) (caddr d
)))
3438 (eq ($asksign s
) '$pos
)
3439 (eq (ask-integer s
'$integer
) '$yes
))
3440 (bydif r s
(cadr d
) ivar
))
3441 ((polyinx n ivar nil
)
3442 (radbyterm d
(cdr n
) ivar
)))))))
3445 ;;;Looks at the IMAGINARY part of a log and puts it in the interval 0 2*%pi.
3446 (defun log-imag-0-2%pi
(x)
3447 (let ((plog (simplify ($rectform
`((%plog
) ,x
)))))
3448 ;; We take the $rectform above to make sure that the log is
3449 ;; expanded out for the situations where simplifying plog itself
3450 ;; doesn't do it. This should probably be considered a bug in the
3451 ;; plog simplifier and should be fixed there.
3452 (cond ((not (free plog
'%plog
))
3453 (subst '%log
'%plog plog
))
3455 (destructuring-let (((real . imag
) (trisplit plog
)))
3456 (cond ((eq ($asksign imag
) '$neg
)
3457 (setq imag
(m+ imag %pi2
)))
3458 ((eq ($asksign
(m- imag %pi2
)) '$pos
)
3459 (setq imag
(m- imag %pi2
)))
3461 (m+ real
(m* '$%i imag
)))))))
3464 ;;; Temporary fix for a lacking in taylor, which loses with %i in denom.
3465 ;;; Besides doesn't seem like a bad thing to do in general.
3466 (defun %i-out-of-denom
(exp)
3467 (let ((denom ($denom exp
)))
3468 (cond ((among '$%i denom
)
3469 ;; Multiply the denominator by it's conjugate to get rid of
3471 (let* ((den-conj (maxima-substitute (m- '$%i
) '$%i denom
))
3473 (new-denom (sratsimp (m* denom den-conj
)))
3474 (new-exp (sratsimp (m// (m* num den-conj
) new-denom
))))
3475 ;; If the new denominator still contains %i, just give up.
3476 (if (among '$%i
($denom new-exp
))
3481 ;;; LL and UL must be real otherwise this routine return $UNKNOWN.
3482 ;;; Returns $no $unknown or a list of poles in the interval (ll ul)
3483 ;;; for exp w.r.t. ivar.
3484 ;;; Form of list ((pole . multiplicity) (pole1 . multiplicity) ....)
3485 (defun poles-in-interval (exp ivar ll ul
)
3486 (let* ((denom (cond ((mplusp exp
)
3487 ($denom
(sratsimp exp
)))
3489 (free (caddr exp
) ivar
)
3490 (eq ($asksign
(caddr exp
)) '$neg
))
3491 (m^
(cadr exp
) (m- (caddr exp
))))
3493 (roots (real-roots denom ivar
))
3494 (ll-pole (limit-pole exp ivar ll
'$plus
))
3495 (ul-pole (limit-pole exp ivar ul
'$minus
)))
3496 (cond ((or (eq roots
'$failure
)
3498 (null ul-pole
)) '$unknown
)
3499 ((and (or (eq roots
'$no
)
3500 (member ($csign denom
) '($pos $neg $pn
)))
3501 ;; this clause handles cases where we can't find the exact roots,
3502 ;; but we know that they occur outside the interval of integration.
3503 ;; example: integrate ((1+exp(t))/sqrt(t+exp(t)), t, 0, 1);
3505 (eq ul-pole
'$no
)) '$no
)
3506 (t (cond ((equal roots
'$no
)
3508 (do ((dummy roots
(cdr dummy
))
3509 (pole-list (cond ((not (eq ll-pole
'$no
))
3513 (cond ((not (eq ul-pole
'$no
))
3514 (sort-poles (push `(,ul .
1) pole-list
)))
3515 ((not (null pole-list
))
3516 (sort-poles pole-list
))
3518 (let* ((soltn (caar dummy
))
3519 ;; (multiplicity (cdar dummy)) (not used? -- cwh)
3520 (root-in-ll-ul (in-interval soltn ll ul
)))
3521 (cond ((eq root-in-ll-ul
'$no
) '$no
)
3522 ((eq root-in-ll-ul
'$yes
)
3523 (let ((lim-ans (is-a-pole exp soltn ivar
)))
3524 (cond ((null lim-ans
)
3528 (t (push (car dummy
)
3529 pole-list
))))))))))))
3532 ;;;Returns $YES if there is no pole and $NO if there is one.
3533 (defun limit-pole (exp ivar limit direction
)
3534 (let ((ans (cond ((member limit
'($minf $inf
) :test
#'eq
)
3535 (cond ((eq (special-convergent-formp exp limit ivar
) '$yes
)
3537 (t (get-limit (m* exp ivar
) ivar limit direction
))))
3539 (cond ((eq ans
'$no
) '$no
)
3541 ((eq ans
'$und
) '$no
)
3542 ((equal ans
0.
) '$no
)
3545 ;;;Takes care of forms that the ratio test fails on.
3546 (defun special-convergent-formp (exp limit ivar
)
3547 (cond ((not (oscip-var exp ivar
)) '$no
)
3548 ((or (eq (sc-converg-form exp limit ivar
) '$yes
)
3549 (eq (exp-converg-form exp limit ivar
) '$yes
))
3553 (defun exp-converg-form (exp limit ivar
)
3555 (setq exparg
(%einvolve-var exp ivar
))
3556 (cond ((or (null exparg
)
3557 (freeof '$%i exparg
))
3563 (sratsimp (m// exp
(m^t
'$%e exparg
))))
3565 (equal (get-limit exp ivar limit
) 0))
3569 (defun sc-converg-form (exp limit ivar
)
3570 (prog (scarg trigpow
)
3571 (setq exp
($expand exp
))
3572 (setq scarg
(involve-var (sin-sq-cos-sq-sub exp
) ivar
'(%sin %cos
)))
3573 (cond ((null scarg
) (return '$no
))
3574 ((and (polyinx scarg ivar
())
3575 (eq ($asksign
(m- ($hipow scarg ivar
) 1)) '$pos
))
3577 ((not (freeof ivar
(sdiff scarg ivar
)))
3579 ((and (setq trigpow
($hipow exp
`((%sin
) ,scarg
)))
3580 (eq (ask-integer trigpow
'$odd
) '$yes
)
3581 (equal (get-limit (m// exp
`((%sin
) ,scarg
)) ivar limit
)
3584 ((and (setq trigpow
($hipow exp
`((%cos
) ,scarg
)))
3585 (eq (ask-integer trigpow
'$odd
) '$yes
)
3586 (equal (get-limit (m// exp
`((%cos
) ,scarg
)) ivar limit
)
3589 (t (return '$no
)))))
3591 (defun is-a-pole (exp soltn ivar
)
3593 (m* (maxima-substitute (m+ 'epsilon soltn
) ivar exp
)
3597 (defun in-interval (place ll ul
)
3598 ;; real values for ll and ul; place can be imaginary.
3599 (let ((order (ask-greateq ul ll
)))
3600 (cond ((eq order
'$yes
))
3601 ((eq order
'$no
) (let ((temp ul
)) (setq ul ll ll temp
)))
3602 (t (merror (intl:gettext
"defint: failed to order limits of integration:~%~M")
3603 (list '(mlist simp
) ll ul
)))))
3604 (if (not (equal ($imagpart place
) 0))
3606 (let ((lesseq-ul (ask-greateq ul place
))
3607 (greateq-ll (ask-greateq place ll
)))
3608 (if (and (eq lesseq-ul
'$yes
) (eq greateq-ll
'$yes
)) '$yes
'$no
))))
3610 ;; returns true or nil
3611 (defun strictly-in-interval (place ll ul
)
3612 ;; real values for ll and ul; place can be imaginary.
3613 (and (equal ($imagpart place
) 0)
3615 (eq ($asksign
(m+ ul
(m- place
))) '$pos
))
3617 (eq ($asksign
(m+ place
(m- ll
))) '$pos
))))
3619 (defun real-roots (exp ivar
)
3620 (let (($solvetrigwarn
(cond (*defintdebug
* t
) ;Rest of the code for
3621 (t ()))) ;TRIGS in denom needed.
3622 ($solveradcan
(cond ((or (among '$%i exp
)
3623 (among '$%e exp
)) t
)
3625 *roots
*failures
) ;special vars for solve.
3626 (cond ((not (among ivar exp
)) '$no
)
3627 (t (solve exp ivar
1)
3628 ;; If *failures is set, we may have missed some roots.
3629 ;; We still return the roots that we have found.
3630 (do ((dummy *roots
(cddr dummy
))
3633 (cond ((not (null rootlist
))
3636 (cond ((equal ($imagpart
(caddar dummy
)) 0)
3639 ($rectform
(caddar dummy
))
3643 (defun ask-greateq (x y
)
3644 ;;; Is x > y. X or Y can be $MINF or $INF, zeroA or zeroB.
3645 (let ((x (cond ((among 'zeroa x
)
3650 (subst 0 'epsilon x
))
3651 ((or (among '$inf x
)
3655 (y (cond ((among 'zeroa y
)
3660 (subst 0 'epsilon y
))
3661 ((or (among '$inf y
)
3673 (t (let ((ans ($asksign
(m+ x
(m- y
)))))
3674 (cond ((member ans
'($zero $pos
) :test
#'eq
)
3680 (defun sort-poles (pole-list)
3681 (sort pole-list
#'(lambda (x y
)
3682 (cond ((eq (ask-greateq (car x
) (car y
))
3687 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3689 ;;; Integrate Definite Integrals involving log and exp functions. The algorithm
3690 ;;; are taken from the paper "Evaluation of CLasses of Definite Integrals ..."
3691 ;;; by K.O.Geddes et. al.
3693 ;;; 1. CASE: Integrals generated by the Gamma function.
3698 ;;; I t log (t) expt(- t ) dt = s signum(s)
3705 ;;; (--- (gamma(z))! )
3711 ;;; The integral converges for:
3712 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3714 ;;; 2. CASE: Integrals generated by the Incomplete Gamma function.
3719 ;;; I t log (t) exp(- t ) dt = (--- (gamma_incomplete(a, x ))! )
3727 ;;; The integral converges for:
3728 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3729 ;;; The shown solution is valid for s>0. For s<0 gamma_incomplete has to be
3730 ;;; replaced by gamma(a) - gamma_incomplete(a,x^s).
3732 ;;; 3. CASE: Integrals generated by the beta function.
3737 ;;; I log (1 - t) (1 - t) t log (t) dt =
3745 ;;; --- (--- (beta(z, w))! )!
3751 ;;; The integral converges for:
3752 ;;; n, m = 0, 1, 2, ..., s > -1 and r > -1.
3753 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3755 (defvar *debug-defint-log
* nil
)
3757 ;;; Recognize c*z^w*log(z)^m*exp(-t^s)
3759 (defun m2-log-exp-1 (expr ivar
)
3760 (when *debug-defint-log
*
3761 (format t
"~&M2-LOG-EXP-1 with ~A~%" expr
))
3765 ((mexpt) (z varp2
,ivar
) (w freevar2
,ivar
))
3766 ((mexpt) $%e
((mtimes) -
1 ((mexpt) (z varp2
,ivar
) (s freevar02
,ivar
))))
3767 ((mexpt) ((%log
) (z varp2
,ivar
)) (m freevar2
,ivar
)))))
3769 ;;; Recognize c*z^r*log(z)^n*(1-z)^s*log(1-z)^m
3771 (defun m2-log-exp-2 (expr ivar
)
3772 (when *debug-defint-log
*
3773 (format t
"~&M2-LOG-EXP-2 with ~A~%" expr
))
3777 ((mexpt) (z varp2
,ivar
) (r freevar2
,ivar
))
3778 ((mexpt) ((%log
) (z varp2
,ivar
)) (n freevar2
,ivar
))
3779 ((mexpt) ((mplus) 1 ((mtimes) -
1 (z varp2
,ivar
))) (s freevar2
,ivar
))
3780 ((mexpt) ((%log
) ((mplus) 1 ((mtimes)-
1 (z varp2
,ivar
)))) (m freevar2
,ivar
)))))
3782 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3784 (defun defint-log-exp (expr ivar ll ul
)
3789 ;; var1 is used as a parameter for differentiation. Add var1>0 to the
3790 ;; database, to get the desired simplification of the differentiation of
3791 ;; the gamma_incomplete function.
3792 (setq *global-defint-assumptions
*
3793 (cons (assume `((mgreaterp) ,var1
0))
3794 *global-defint-assumptions
*))
3798 (setq x
(m2-log-exp-1 expr ivar
)))
3799 ;; The integrand matches the cases 1 and 2.
3800 (let ((c (cdras 'c x
))
3804 ($gamma_expand nil
)) ; No expansion of Gamma functions.
3806 (when *debug-defint-log
*
3807 (format t
"~&DEFINT-LOG-EXP-1:~%")
3808 (format t
"~& : c = ~A~%" c
)
3809 (format t
"~& : w = ~A~%" w
)
3810 (format t
"~& : m = ~A~%" m
)
3811 (format t
"~& : s = ~A~%" s
))
3813 (cond ((and (zerop1 ll
)
3816 (not (eq ($sign s
) '$zero
))
3817 (eq ($sign
(div (add w
1) s
)) '$pos
))
3818 ;; Case 1: Generated by the Gamma function.
3821 (simplify (list '(%signum
) s
))
3822 (power s
(mul -
1 (add m
1)))
3823 ($at
($diff
(list '(%gamma
) var1
) var1 m
)
3826 (div (add w
1) s
))))))
3827 ((and (member ($sign ll
) '($pos $pz
))
3829 (or (= m
0) (= m
1)) ; Exclude m>1, because Maxima can not
3830 ; derivate the involved hypergeometric
3832 (or (and (eq ($sign s
) '$neg
)
3833 (eq ($sign
(div (add 1 w
) s
)) '$pos
))
3834 (and (eq ($sign s
) '$pos
)
3835 (eq ($sign
(div (add 1 w
) s
)) '$pos
))))
3836 ;; Case 2: Generated by the Incomplete Gamma function.
3837 (let ((f (if (eq ($sign s
) '$pos
)
3838 (list '(%gamma_incomplete
) var1
(power ll s
))
3839 (sub (list '(%gamma
) var1
)
3840 (list '(%gamma_incomplete
) var1
(power ll s
))))))
3843 (simplify (list '(%signum
) s
))
3844 (power s
(mul -
1 (add m
1)))
3845 ($at
($diff f var1 m
)
3846 (list '(mequal) var1
(div (add 1 w
) s
)))))))
3848 (setq result nil
)))))
3851 (setq x
(m2-log-exp-2 expr ivar
)))
3852 ;; Case 3: Generated by the Beta function.
3853 (let ((c (cdras 'c x
))
3861 (when *debug-defint-log
*
3862 (format t
"~&DEFINT-LOG-EXP-2:~%")
3863 (format t
"~& : c = ~A~%" c
)
3864 (format t
"~& : r = ~A~%" r
)
3865 (format t
"~& : n = ~A~%" n
)
3866 (format t
"~& : s = ~A~%" s
)
3867 (format t
"~& : m = ~A~%" m
))
3869 (cond ((and (integerp m
)
3873 (eq ($sign
(add 1 r
)) '$pos
)
3874 (eq ($sign
(add 1 s
)) '$pos
))
3877 ($at
($diff
($at
($diff
(list '(%beta
) var1 var2
)
3879 (list '(mequal) var2
(add 1 s
)))
3881 (list '(mequal) var1
(add 1 r
))))))
3883 (setq result nil
)))))
3886 ;; Simplify result and set $gamma_expand to global value
3887 (let (($gamma_expand $gamma_expand
)) (sratsimp result
))))
3889 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;