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.
143 (defvar *loopstop
* 0)
145 (defmvar $intanalysis t
146 "When @code{true}, definite integration tries to find poles in the integrand
147 in the interval of integration.")
149 ;; Currently, if true, $solvetrigwarn is set to true. No additional
150 ;; debugging information is displayed.
151 (defvar *defintdebug
* ()
152 "If true Defint prints out some debugging information.")
156 "When NIL, print a message that the principal value of the integral has
161 "When non-NIL, a divergent integral will throw to `divergent.
162 Otherwise, an error is signaled that the integral is divergent.")
169 ;; Set to true when OSCIP-VAR returns true in DINTEGRATE.
170 (defvar *scflag
* nil
)
172 (defvar *sin-cos-recur
* nil
173 "Prevents recursion of integrals of sin and cos in intsc1.")
175 (defvar *rad-poly-recur
* nil
176 "Prevents recursion in method-radical-poly.")
178 (defvar *dintlog-recur
* nil
179 "Prevents recursion in dintlog.")
181 (defvar *dintexp-recur
* nil
182 "Prevents recursion in dintexp.")
185 (defmfun $defint
(exp ivar ll ul
)
187 ;; Distribute $defint over equations, lists, and matrices.
192 (mapcar #'(lambda (e)
193 (simplify ($defint e ivar ll ul
)))
196 (let ((*global-defint-assumptions
* ())
197 (*integer-info
* ()) (integerl integerl
) (nonintegerl nonintegerl
))
198 (with-new-context (context)
200 (let ((*defint-assumptions
* ()) (*rad-poly-recur
* ())
201 (*sin-cos-recur
* ()) (*dintexp-recur
* ()) (*dintlog-recur
* 0.
)
202 (ans nil
) (orig-exp exp
) (orig-var ivar
)
203 (orig-ll ll
) (orig-ul ul
)
204 (*pcprntd
* nil
) (*nodiverg
* nil
) ($logabs t
) ; (limitp t)
206 ($%edispflag nil
) ; to get internal representation
207 ($m1pbranch
())) ;Try this out.
209 (make-global-assumptions) ;sets *global-defint-assumptions*
210 (setq exp
(ratdisrep exp
))
211 (setq ivar
(ratdisrep ivar
))
212 (setq ll
(ratdisrep ll
))
213 (setq ul
(ratdisrep ul
))
214 (cond (($constantp ivar
)
215 (merror (intl:gettext
"defint: variable of integration cannot be a constant; found ~M") ivar
))
216 (($subvarp ivar
) (setq ivar
(gensym))
217 (setq exp
($substitute ivar orig-var exp
))))
218 (cond ((not (atom ivar
))
219 (merror (intl:gettext
"defint: variable of integration must be a simple or subscripted variable.~%defint: found ~M") ivar
))
223 (setq exp
($substitute ivar orig-var exp
))))
224 (unless (lenient-extended-realp ll
)
225 (merror (intl:gettext
"defint: lower limit of integration must be real; found ~M") ll
))
226 (unless (lenient-extended-realp ul
)
227 (merror (intl:gettext
"defint: upper limit of integration must be real; found ~M") ul
))
229 (cond ((setq ans
(defint exp ivar ll ul
))
230 (setq ans
(subst orig-var ivar ans
))
231 (cond ((atom ans
) ans
)
232 ((and (free ans
'%limit
)
233 (free ans
'%integrate
)
234 (or (not (free ans
'$inf
))
235 (not (free ans
'$minf
))
236 (not (free ans
'$infinity
))))
238 ((not (free ans
'$und
))
239 `((%integrate
) ,orig-exp
,orig-var
,orig-ll
,orig-ul
))
241 (t `((%integrate
) ,orig-exp
,orig-var
,orig-ll
,orig-ul
))))
242 (forget-global-assumptions)))))
244 (defun eezz (exp ll ul ivar
)
245 (cond ((or (polyinx exp ivar nil
)
246 (catch 'pin%ex
(pin%ex exp ivar
)))
247 (setq exp
(antideriv exp ivar
))
248 ;; If antideriv can't do it, returns nil
249 ;; use limit to evaluate every answer returned by antideriv.
250 (cond ((null exp
) nil
)
251 (t (intsubs exp ll ul ivar
))))))
253 ;;;Hack the expression up for exponentials.
255 (defun sinintp (expr ivar
)
256 ;; Is this expr a candidate for SININT ?
257 (let ((expr (factor expr
))
260 (setq numer
($num expr
))
261 (setq denom
($denom expr
))
262 (cond ((polyinx numer ivar nil
)
263 (cond ((and (polyinx denom ivar nil
)
264 (deg-lessp denom ivar
2))
266 ;;ERF type things go here.
267 ((let ((exponent (%einvolve-var numer ivar
)))
268 (and (polyinx exponent ivar nil
)
269 (deg-lessp exponent ivar
2)))
270 (cond ((free denom ivar
)
273 (defun deg-lessp (expr ivar power
)
274 (cond ((or (atom expr
)
278 (do ((ops (cdr expr
) (cdr ops
)))
280 (cond ((not (deg-lessp (car ops
) ivar power
))
283 (and (or (not (alike1 (cadr expr
) ivar
))
284 (and (numberp (caddr expr
))
285 (not (eq (asksign (m+ power
(m- (caddr expr
))))
287 (deg-lessp (cadr expr
) ivar power
)))
289 (member 'array
(car expr
))
290 (not (eq ivar
(caar expr
))))
291 ;; We have some subscripted variable that's not our variable
292 ;; (I think), so it's deg-lessp.
294 ;; FIXME: Is this the best way to handle this? Are there
295 ;; other cases we're mising here?
298 (defun antideriv (a ivar
)
302 (setq ans
(sinint a ivar
))
303 (cond ((among '%integrate ans
) nil
)
304 (t (simplify ans
)))))
306 ;; This routine tries to take a limit a couple of ways.
307 (defun get-limit (exp ivar val
&optional
(dir '$plus dir?
))
309 (funcall #'limit-no-err exp ivar val dir
)
310 (funcall #'limit-no-err exp ivar val
))))
311 (if (and ans
(not (among '%limit ans
)))
313 (when (member val
'($inf $minf
) :test
#'eq
)
314 (setq ans
(limit-no-err (maxima-substitute (m^t ivar -
1) ivar exp
)
317 (if (eq val
'$inf
) '$plus
'$minus
)))
318 (if (among '%limit ans
) nil ans
)))))
320 (defun limit-no-err (&rest argvec
)
321 (let ((errorsw t
) (ans nil
))
322 (setq ans
(catch 'errorsw
(apply #'$limit argvec
)))
323 (if (eq ans t
) nil ans
)))
325 ;; Test whether fun2 is inverse of fun1 at val.
326 (defun test-inverse (fun1 var1 fun2 var2 val
)
327 (let* ((out1 (no-err-sub-var val fun1 var1
))
328 (out2 (no-err-sub-var out1 fun2 var2
)))
331 ;; integration change of variable
332 (defun intcv (nv flag ivar ll ul
)
333 (let ((d (bx**n
+a nv ivar
))
334 (*roots
()) (*failures
()) ($breakup
()))
335 (cond ((and (eq ul
'$inf
)
337 (equal (cadr d
) 1)) ())
338 ((eq ivar
'yx
) ; new ivar cannot be same as old ivar
341 ;; This is a hack! If nv is of the form b*x^n+a, we can
342 ;; solve the equation manually instead of using solve.
343 ;; Why? Because solve asks us for the sign of yx and
346 ;; Solve yx = b*x^n+a, for x. Any root will do. So we
347 ;; have x = ((yx-a)/b)^(1/n).
348 (destructuring-bind (a n b
)
350 (let ((root (power* (div (sub 'yx a
) b
) (inv n
))))
353 (cond (flag (intcv2 d nv ivar ll ul
))
354 (t (intcv1 d nv ivar ll ul
))))
357 (putprop 'yx t
'internal
);; keep ivar from appearing in questions to user
358 (solve (m+t
'yx
(m*t -
1 nv
)) ivar
1.
)
359 (cond ((setq d
;; look for root that is inverse of nv
360 (do* ((roots *roots
(cddr roots
))
361 (root (caddar roots
) (caddar roots
)))
363 (if (and (or (real-infinityp ll
)
364 (test-inverse nv ivar root
'yx ll
))
365 (or (real-infinityp ul
)
366 (test-inverse nv ivar root
'yx ul
)))
368 (cond (flag (intcv2 d nv ivar ll ul
))
369 (t (intcv1 d nv ivar ll ul
))))
372 ;; d: original variable (ivar) as a function of 'yx
374 ;; nv: new variable ('yx) as a function of original variable (ivar)
375 (defun intcv1 (d nv ivar ll ul
)
376 (multiple-value-bind (exp-yx ll1 ul1
)
377 (intcv2 d nv ivar ll ul
)
378 (cond ((and (equal ($imagpart ll1
) 0)
379 (equal ($imagpart ul1
) 0)
380 (not (alike1 ll1 ul1
)))
381 (defint exp-yx
'yx ll1 ul1
)))))
383 ;; converts limits of integration to values for new variable 'yx
384 (defun intcv2 (d nv ivar ll ul
)
385 (flet ((intcv3 (d nv ivar
)
386 ;; rewrites exp, the integrand in terms of ivar, the
387 ;; integrand in terms of 'yx, and returns the new
389 (let ((exp-yx (m* (sdiff d
'yx
)
390 (subst d ivar
(subst 'yx nv exp
)))))
392 (let ((exp-yx (intcv3 d nv ivar
))
394 (and (cond ((and (zerop1 (m+ ll ul
))
396 (setq exp-yx
(m* 2 exp-yx
)
397 ll1
(limcp nv ivar
0 '$plus
)))
398 (t (setq ll1
(limcp nv ivar ll
'$plus
))))
399 (setq ul1
(limcp nv ivar ul
'$minus
))
400 (values exp-yx ll1 ul1
)))))
402 ;; wrapper around limit, returns nil if
403 ;; limit not found (nounform returned), or undefined ($und or $ind)
404 (defun limcp (a b c d
)
405 (let ((ans ($limit a b c d
)))
406 (cond ((not (or (null ans
)
412 (defun integrand-changevar (d newvar exp ivar
)
416 (defun defint (exp ivar ll ul
)
417 (let ((old-assumptions *defint-assumptions
*)
418 (*current-assumptions
* ())
422 (multiple-value-setq (*current-assumptions
* ll ul
)
423 (make-defint-assumptions 'noask ivar ll ul
))
424 (let ((exp (resimplify exp
))
425 (ivar (resimplify ivar
))
428 ;; D (not used? -- cwh)
429 ans nn
* dn
* $noprincipal
)
430 (cond ((setq ans
(defint-list exp ivar ll ul
))
435 ((not (among ivar exp
))
436 (cond ((or (member ul
'($inf $minf
) :test
#'eq
)
437 (member ll
'($inf $minf
) :test
#'eq
))
439 (t (setq ans
(m* exp
(m+ ul
(m- ll
))))
441 ;; Look for integrals which involve log and exp functions.
442 ;; Maxima has a special algorithm to get general results.
443 ((and (setq ans
(defint-log-exp exp ivar ll ul
)))
445 (let* ((exp (rmconst1 exp ivar
))
447 (exp (%i-out-of-denom
(cdr exp
))))
448 (cond ((and (not $nointegrate
)
450 (or (among 'mqapply exp
)
451 (not (member (caar exp
)
452 '(mexpt mplus mtimes %sin %cos
453 %tan %sinh %cosh %tanh
454 %log %asin %acos %atan
457 %derivative
) :test
#'eq
))))
458 ;; Call ANTIDERIV with logabs disabled,
459 ;; because the Risch algorithm assumes
460 ;; the integral of 1/x is log(x), not log(abs(x)).
461 ;; Why not just assume logabs = false within RISCHINT itself?
462 ;; Well, there's at least one existing result which requires
463 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
464 (cond ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
465 (setq ans
(intsubs ans ll ul ivar
))
466 (return (cond (ans (m* c ans
)) (t nil
))))
468 (setq exp
(tansc-var exp ivar
))
469 (cond ((setq ans
(initial-analysis exp ivar ll ul
))
470 (return (m* c ans
))))
472 (restore-defint-assumptions old-assumptions
*current-assumptions
*))))
474 (defun defint-list (exp ivar ll ul
)
476 (let ((ans (cons (car exp
)
479 (defint sub-exp ivar ll ul
))
481 (cond (ans (simplify ans
))
485 (defun initial-analysis (exp ivar ll ul
)
486 (let ((pole (cond ((not $intanalysis
)
487 '$no
) ;don't do any checking.
488 (t (poles-in-interval exp ivar ll ul
)))))
489 (cond ((eq pole
'$no
)
490 (cond ((and (oddfn exp ivar
)
491 (or (and (eq ll
'$minf
)
493 (eq ($sign
(m+ ll ul
))
495 (t (parse-integrand exp ivar ll ul
))))
496 ((eq pole
'$unknown
) ())
497 (t (principal-value-integral exp ivar ll ul pole
)))))
499 (defun parse-integrand (exp ivar ll ul
)
501 (cond ((setq ans
(eezz exp ll ul ivar
)) ans
)
502 ((and (ratp exp ivar
)
503 (setq ans
(method-by-limits exp ivar ll ul
)))
506 (setq ans
(intbyterm exp t ivar ll ul
)))
508 ((setq ans
(method-by-limits exp ivar ll ul
)) ans
)
511 (defun rmconst1 (e ivar
)
512 (cond ((not (freeof ivar e
))
513 (partition e ivar
1))
517 (defun method-by-limits (exp ivar ll ul
)
518 (let ((old-assumptions *defint-assumptions
*))
519 (multiple-value-bind (*current-assumptions
* ll ul
)
520 (make-defint-assumptions 'noask ivar ll ul
))
522 ;;Should be a PROG inside of unwind-protect, but Multics has a compiler
523 ;;bug wrt. and I want to test this code now.
525 (cond ((and (and (eq ul
'$inf
)
527 (mtoinf exp ivar ll ul
)))
528 ((and (and (eq ul
'$inf
)
530 (ztoinf exp ivar ll ul
)))
531 ;;;This seems((and (and (eq ul '$inf)
532 ;;;fairly losing (setq exp (subin (m+ ll ivar) exp))
534 ;;; (ztoinf exp ivar)))
537 (eq ($asksign ul
) '$pos
)
539 ;; ((and (and (equal ul 1.)
540 ;; (equal ll 0.)) (zto1 exp)))
541 (t (dintegrate exp ivar ll ul
)))
542 (restore-defint-assumptions old-assumptions
*defint-assumptions
*))))
545 (defun dintegrate (exp ivar ll ul
)
546 (let ((ans nil
) (arg nil
) (*scflag
* nil
)
547 (*dflag
* nil
) ($%emode t
))
548 ;;;NOT COMPLETE for sin's and cos's.
549 (cond ((and (not *sin-cos-recur
*)
552 (intsc1 ll ul exp ivar
)))
553 ((and (not *rad-poly-recur
*)
554 (notinvolve-var exp ivar
'(%log
))
555 (not (%einvolve-var exp ivar
))
556 (method-radical-poly exp ivar ll ul
)))
557 ((and (not (equal *dintlog-recur
* 2.
))
558 (setq arg
(involve-var exp ivar
'(%log
)))
559 (dintlog exp arg ivar ll ul
)))
560 ((and (not *dintexp-recur
*)
561 (setq arg
(%einvolve-var exp ivar
))
562 (dintexp exp ivar ll ul
)))
563 ((and (not (ratp exp ivar
))
564 (setq ans
(let (($trigexpandtimes nil
)
567 (setq ans
($expand ans
))
568 (not (alike1 ans exp
))
569 (intbyterm ans t ivar ll ul
)))
570 ;; Call ANTIDERIV with logabs disabled,
571 ;; because the Risch algorithm assumes
572 ;; the integral of 1/x is log(x), not log(abs(x)).
573 ;; Why not just assume logabs = false within RISCHINT itself?
574 ;; Well, there's at least one existing result which requires
575 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
576 ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
577 (intsubs ans ll ul ivar
))
580 (defun method-radical-poly (exp ivar ll ul
)
582 (let ((*rad-poly-recur
* t
) ;recursion stopper
584 (cond ((and (sinintp exp ivar
)
585 (setq result
(antideriv exp ivar
))
586 (intsubs result ll ul ivar
)))
587 ((and (ratp exp ivar
)
588 (setq result
(ratfnt exp ivar ll ul
))))
593 (setq result
(cv exp ivar ll ul
))))
596 (defun principal-value-integral (exp ivar ll ul poles
)
597 (let ((anti-deriv ()))
598 (cond ((not (null (setq anti-deriv
(antideriv exp ivar
))))
599 (cond ((not (null poles
))
600 (multiple-value-bind (ignore new-ll new-ul
)
601 (order-limits 'ask ivar ll ul
)
602 (declare (ignore ignore
))
603 (cond ((take-principal anti-deriv new-ll new-ul ivar poles
))
606 ;; adds up integrals of ranges between each pair of poles.
607 ;; checks if whole thing is divergent as limits of integration approach poles.
608 (defun take-principal (anti-deriv ll ul ivar poles
&aux ans merged-list
)
609 ;;; calling $logcontract causes antiderivative of 1/(1-x^5) to blow up
610 ;; (setq anti-deriv (cond ((involve anti-deriv '(%log))
611 ;; ($logcontract anti-deriv))
614 (multiple-value-setq (merged-list ll ul
)
615 (interval-list poles ll ul
))
616 (do ((current-pole (cdr merged-list
) (cdr current-pole
))
617 (previous-pole merged-list
(cdr previous-pole
)))
618 ((null current-pole
) t
)
620 (intsubs anti-deriv
(m+ (caar previous-pole
) 'epsilon
)
621 (m+ (caar current-pole
) (m- 'epsilon
))
624 (setq ans
(get-limit (get-limit ans
'epsilon
0 '$plus
) 'prin-inf
'$inf
))
626 (cond ((or (null ans
)
627 (not (free ans
'$infinity
))
628 (not (free ans
'$ind
))) ())
629 ((or (among '$minf ans
)
633 (t (principal) ans
)))
635 ;; I think this takes the pole-list and replaces $MINF with -PRIN-INF
636 ;; and $INF with PRIN-INF. The lower and upper integration limits
637 ;; (ll, ul) can also be modified to be -PRIN-INF and PRIN-INF. These
638 ;; special values are used in TAKE-PRINCIPAL.
639 (defun interval-list (pole-list ll ul
)
640 (let ((first (car (first pole-list
)))
641 (last (caar (last pole-list
))))
644 (setq pole-list
(subst 'prin-inf
'$inf pole-list
))))
647 (setq pole-list
(append pole-list
(list (cons ul
'ignored
))))))
650 (setq pole-list
(subst (m- 'prin-inf
) '$minf pole-list
))))
651 (t (if (eq ll
'$minf
)
652 (setq ll
(m- 'prin-inf
)))
653 (setq pole-list
(append (list (cons ll
'ignored
)) pole-list
)))))
654 (values pole-list ll ul
))
656 ;; Assumes EXP is a rational expression with no polynomial part and
657 ;; converts the finite integration to integration over a half-infinite
658 ;; interval. The substitution y = (x-a)/(b-x) is used. Equivalently,
659 ;; x = (b*y+a)/(y+1).
661 ;; (I'm guessing CV means Change Variable here.)
662 (defun cv (exp ivar ll ul
)
663 (if (not (or (real-infinityp ll
) (real-infinityp ul
)))
664 ;; FIXME! This is a hack. We apply the transformation with
665 ;; symbolic limits and then substitute the actual limits later.
666 ;; That way method-by-limits (usually?) sees a simpler
669 ;; See Bugs 938235 and 941457. These fail because $FACTOR is
670 ;; unable to factor the transformed result. This needs more
671 ;; work (in other places).
672 (let ((trans (integrand-changevar (m// (m+t
'll
(m*t
'ul
'yx
))
675 ;; If the limit is a number, use $substitute so we simplify
676 ;; the result. Do we really want to do this?
677 (setf trans
(if (mnump ll
)
678 ($substitute ll
'll trans
)
679 (subst ll
'll trans
)))
680 (setf trans
(if (mnump ul
)
681 ($substitute ul
'ul trans
)
682 (subst ul
'ul trans
)))
683 (method-by-limits trans
'yx
0.
'$inf
))
686 ;; Integrate rational functions over a finite interval by doing the
687 ;; polynomial part directly, and converting the rational part to an
688 ;; integral from 0 to inf. This is evaluated via residues.
689 (defun ratfnt (exp ivar ll ul
)
690 (let ((e (pqr exp ivar
)))
691 ;; PQR divides the rational expression and returns the quotient
693 (flet ((try-antideriv (e lo hi
)
694 (let ((ans (antideriv e ivar
)))
696 (intsubs ans lo hi ivar
)))))
698 (cond ((equal 0.
(car e
))
699 ;; No polynomial part
700 (let ((ans (try-antideriv exp ll ul
)))
703 (cv exp ivar ll ul
))))
705 ;; Only polynomial part
706 (eezz (car e
) ll ul ivar
))
708 ;; A non-zero quotient and remainder. Combine the results
710 (let ((ans (try-antideriv (m// (cdr e
) dn
*) ll ul
)))
712 (m+t
(eezz (car e
) ll ul ivar
)
715 (m+t
(eezz (car e
) ll ul ivar
)
716 (cv (m// (cdr e
) dn
*) ivar ll ul
))))))))))
718 ;; I think this takes a rational expression E, and finds the
719 ;; polynomial part. A cons is returned. The car is the quotient and
720 ;; the cdr is the remainder.
722 (let ((varlist (list ivar
)))
724 (setq e
(cdr (ratrep* e
)))
725 (setq dn
* (pdis (ratdenominator e
)))
726 (setq e
(pdivide (ratnumerator e
) (ratdenominator e
)))
727 (cons (simplify (rdis (car e
))) (simplify (rdis (cadr e
))))))
730 (defun intbyterm (exp *nodiverg
* ivar ll ul
)
731 (let ((saved-exp exp
))
733 (let ((ans (catch 'divergent
734 (andmapcar #'(lambda (new-exp)
735 (defint new-exp ivar ll ul
))
737 (cond ((null ans
) nil
)
739 (let ((*nodiverg
* nil
))
740 (cond ((setq ans
(antideriv saved-exp ivar
))
741 (intsubs ans ll ul ivar
))
743 (t (sratsimp (m+l ans
))))))
744 ;;;If leadop isn't plus don't do anything.
747 (defun kindp34 (ivar ll ul
)
748 (let* ((d (nth-value 1 (numden-var exp ivar
)))
749 (a (cond ((and (zerop1 ($limit d ivar ll
'$plus
))
750 (eq (limit-pole (m+ exp
(m+ (m- ll
) ivar
))
755 (b (cond ((and (zerop1 ($limit d ivar ul
'$minus
))
756 (eq (limit-pole (m+ exp
(m+ ul
(m- ivar
)))
764 (cond (*nodiverg
* (throw 'divergent
'divergent
))
765 (t (merror (intl:gettext
"defint: integral is divergent.")))))
767 ;; May reorder the limits LL and UL so that LL <= UL. (See
768 ;; ORDER-LIMITS.) Hence, this function also returns the possibly
769 ;; updated values of LL and UL as additional values.
770 (defun make-defint-assumptions (ask-or-not ivar ll ul
)
773 (multiple-value-setq (result ll ul
)
774 (order-limits ask-or-not ivar ll ul
)))
776 (t (mapc 'forget
*defint-assumptions
*)
777 (setq *defint-assumptions
* ())
778 (let ((sign-ll (cond ((eq ll
'$inf
) '$pos
)
779 ((eq ll
'$minf
) '$neg
)
780 (t ($sign
($limit ll
)))))
781 (sign-ul (cond ((eq ul
'$inf
) '$pos
)
782 ((eq ul
'$minf
) '$neg
)
783 (t ($sign
($limit ul
)))))
784 (sign-ul-ll (cond ((and (eq ul
'$inf
)
785 (not (eq ll
'$inf
))) '$pos
)
787 (not (eq ll
'$minf
))) '$neg
)
788 (t ($sign
($limit
(m+ ul
(m- ll
))))))))
789 (cond ((eq sign-ul-ll
'$pos
)
790 (setq *defint-assumptions
*
791 `(,(assume `((mgreaterp) ,ivar
,ll
))
792 ,(assume `((mgreaterp) ,ul
,ivar
)))))
793 ((eq sign-ul-ll
'$neg
)
794 (setq *defint-assumptions
*
795 `(,(assume `((mgreaterp) ,ivar
,ul
))
796 ,(assume `((mgreaterp) ,ll
,ivar
))))))
797 (cond ((and (eq sign-ll
'$pos
)
799 (setq *defint-assumptions
*
800 `(,(assume `((mgreaterp) ,ivar
0))
801 ,@*defint-assumptions
*)))
802 ((and (eq sign-ll
'$neg
)
804 (setq *defint-assumptions
*
805 `(,(assume `((mgreaterp) 0 ,ivar
))
806 ,@*defint-assumptions
*)))
807 (t *defint-assumptions
*)))))
810 (defun restore-defint-assumptions (old-assumptions assumptions
)
811 (do ((llist assumptions
(cdr llist
)))
813 (forget (car llist
)))
814 (do ((llist old-assumptions
(cdr llist
)))
816 (assume (car llist
))))
818 (defun make-global-assumptions ()
819 (setq *global-defint-assumptions
*
820 (cons (assume '((mgreaterp) *z
* 0.
))
821 *global-defint-assumptions
*))
822 ;; *Z* is a "zero parameter" for this package.
823 ;; Its also used to transform.
824 ;; limit(exp,var,val,dir) -- limit(exp,tvar,0,dir)
825 (setq *global-defint-assumptions
*
826 (cons (assume '((mgreaterp) epsilon
0.
))
827 *global-defint-assumptions
*))
828 (setq *global-defint-assumptions
*
829 (cons (assume '((mlessp) epsilon
1.0e-8))
830 *global-defint-assumptions
*))
831 ;; EPSILON is used in principal value code to denote the familiar
832 ;; mathematical entity.
833 (setq *global-defint-assumptions
*
834 (cons (assume '((mgreaterp) prin-inf
1.0e+8))
835 *global-defint-assumptions
*)))
837 ;;; PRIN-INF Is a special symbol in the principal value code used to
838 ;;; denote an end-point which is proceeding to infinity.
840 (defun forget-global-assumptions ()
841 (do ((llist *global-defint-assumptions
* (cdr llist
)))
843 (forget (car llist
)))
844 (cond ((not (null *integer-info
*))
845 (do ((llist *integer-info
* (cdr llist
)))
847 (i-$remove
`(,(cadar llist
) ,(caddar llist
)))))))
849 ;; Order the limits LL and UL so that LL <= UL, as expected. Of
850 ;; course, this changes the sign of the integrand (in EXP), so that's
851 ;; also updated as well. Since the order can be changed, the possibly
852 ;; updated values of LL and UL are returned as additional values of
854 (defun order-limits (ask-or-not ivar ll ul
)
856 (cond ((or (not (equal ($imagpart ll
) 0))
857 (not (equal ($imagpart ul
) 0))) ())
858 (t (cond ((alike1 ll
(m*t -
1 '$inf
))
860 (cond ((alike1 ul
(m*t -
1 '$inf
))
862 (cond ((alike1 ll
(m*t -
1 '$minf
))
864 (cond ((alike1 ul
(m*t -
1 '$minf
))
867 ;; We have minf <= ll = ul <= inf
870 ;; We have minf <= ll < ul = inf
873 ;; We have minf = ll < ul < inf
881 ;; so that minf < ll < ul = inf
882 (setq exp
(subin-var (m- ivar
) exp ivar
))
886 (equal (complm ask-or-not ll ul
) -
1))
887 ;; We have minf <= ul < ll
894 ;; so that minf <= ll < ul
900 (defun complm (ask-or-not ll ul
)
901 (let ((askflag (cond ((eq ask-or-not
'ask
) t
)
904 (cond ((alike1 ul ll
) 0.
)
905 ((eq (setq a
(cond (askflag ($asksign
($limit
(m+t ul
(m- ll
)))))
906 (t ($sign
($limit
(m+t ul
(m- ll
)))))))
912 ;; Substitute a and b into integral e
914 ;; Looks for discontinuties in integral, and works around them.
917 ;; integrate(x^(2*n)*exp(-(x)^2),x) ==>
918 ;; -gamma_incomplete((2*n+1)/2,x^2)*x^(2*n+1)*abs(x)^(-2*n-1)/2
920 ;; the integral has a discontinuity at x=0.
922 (defun intsubs (e a b ivar
)
923 (let ((edges (cond ((not $intanalysis
)
924 '$no
) ;don't do any checking.
925 (t (discontinuities-in-interval
926 (let (($algebraic t
))
930 (cond ((or (eq edges
'$no
)
931 (eq edges
'$unknown
))
932 (whole-intsubs e a b ivar
))
934 (do* ((l edges
(cdr l
))
937 (b1 (cadr l
) (cadr l
)))
938 ((null (cdr l
)) (if (every (lambda (x) x
) total
)
941 (whole-intsubs e a1 b1 ivar
)
944 ;; look for terms with a negative exponent
946 ;; recursively traverses exp in order to find discontinuities such as
947 ;; erfc(1/x-x) at x=0
948 (defun discontinuities-denom (exp ivar
)
950 ((and (eq (caar exp
) 'mexpt
)
951 (not (freeof ivar
(cadr exp
)))
952 (not (member ($sign
(caddr exp
)) '($pos $pz
))))
953 (m^
(cadr exp
) (m- (caddr exp
))))
955 (m*l
(mapcar #'(lambda (e)
956 (discontinuities-denom e ivar
))
959 ;; returns list of places where exp might be discontinuous in ivar.
960 ;; list begins with ll and ends with ul, and include any values between
962 ;; return '$no or '$unknown if no discontinuities found.
963 (defun discontinuities-in-interval (exp ivar ll ul
)
964 (let* ((denom (discontinuities-denom exp ivar
))
965 (roots (real-roots denom ivar
)))
966 (cond ((eq roots
'$failure
)
970 (t (do ((dummy roots
(cdr dummy
))
975 (sortgreat pole-list
)
978 (let ((soltn (caar dummy
)))
979 ;; (multiplicity (cdar dummy)) ;; not used
980 (if (strictly-in-interval soltn ll ul
)
981 (push soltn pole-list
))))))))
984 ;; Carefully substitute the integration limits A and B into the
986 (defun whole-intsubs (e a b ivar
)
987 (cond ((easy-subs e a b ivar
))
990 ;; Note: MAKE-DEFINT-ASSUMPTIONS may reorder the limits A
991 ;; and B, but I (rtoy) don't think that's should ever
992 ;; happen because the limits should already be in the
993 ;; correct order when this function is called. We don't
994 ;; check for that, though.
995 (multiple-value-setq (*current-assumptions
* new-ll new-ul
)
996 (make-defint-assumptions 'ask ivar a b
)) ;get forceful!
998 (let (($algebraic t
))
999 (setq e
(sratsimp e
))
1000 (cond ((limit-subs e a b ivar
))
1001 (t (same-sheet-subs e a b ivar
))))))))
1003 ;; Try easy substitutions. Return NIL if we can't.
1004 (defun easy-subs (e ll ul ivar
)
1005 (cond ((or (infinityp ll
) (infinityp ul
))
1006 ;; Infinite limits aren't easy
1009 (cond ((or (polyinx e ivar
())
1010 (and (not (involve-var e ivar
'(%log %asin %acos %atan %asinh %acosh %atanh %atan2
1011 %gamma_incomplete %expintegral_ei
)))
1012 (free ($denom e
) ivar
)))
1013 ;; It's easy if we have a polynomial. I (rtoy) think
1014 ;; it's also easy if the denominator is free of the
1015 ;; integration variable and also if the expression
1016 ;; doesn't involve inverse functions.
1018 ;; gamma_incomplete and expintegral_ie
1019 ;; included because of discontinuity in
1020 ;; gamma_incomplete(0, exp(%i*x)) and
1021 ;; expintegral_ei(exp(%i*x))
1023 ;; XXX: Are there other cases we've forgotten about?
1025 ;; So just try to substitute the limits into the
1026 ;; expression. If no errors are produced, we're done.
1027 (let ((ll-val (no-err-sub-var ll e ivar
))
1028 (ul-val (no-err-sub-var ul e ivar
)))
1029 (cond ((or (eq ll-val t
)
1031 ;; no-err-sub has returned T. An error was catched.
1033 ((and ll-val ul-val
)
1038 (defun limit-subs (e ll ul ivar
)
1039 (cond ((involve-var e ivar
'(%atan %gamma_incomplete %expintegral_ei
))
1040 ()) ; functions with discontinuities
1041 (t (setq e
($multthru e
))
1042 (let ((a1 ($limit e ivar ll
'$plus
))
1043 (a2 ($limit e ivar ul
'$minus
)))
1044 (combine-ll-ans-ul-ans a1 a2
)))))
1046 ;; check for divergent integral
1047 (defun combine-ll-ans-ul-ans (a1 a2
)
1048 (cond ((member a1
'($inf $minf $infinity
) :test
#'eq
)
1049 (cond ((member a2
'($inf $minf $infinity
) :test
#'eq
)
1050 (cond ((eq a2 a1
) ())
1053 ((member a2
'($inf $minf $infinity
) :test
#'eq
) (diverg))
1054 ((or (member a1
'($und $ind
) :test
#'eq
)
1055 (member a2
'($und $ind
) :test
#'eq
)) ())
1058 ;;;This function works only on things with ATAN's in them now.
1059 (defun same-sheet-subs (exp ll ul ivar
&aux ll-ans ul-ans
)
1060 ;; POLES-IN-INTERVAL doesn't know about the poles of tan(x). Call
1061 ;; trigsimp to convert tan into sin/cos, which POLES-IN-INTERVAL
1062 ;; knows how to handle.
1064 ;; XXX Should we fix POLES-IN-INTERVAL instead?
1066 ;; XXX Is calling trigsimp too much? Should we just only try to
1067 ;; substitute sin/cos for tan?
1069 ;; XXX Should the result try to convert sin/cos back into tan? (A
1070 ;; call to trigreduce would do it, among other things.)
1071 (let* ((exp (mfuncall '$trigsimp exp
))
1072 (poles (atan-poles exp ll ul ivar
)))
1073 ;;POLES -> ((mlist) ((mequal) ((%atan) foo) replacement) ......)
1074 ;;We can then use $SUBSTITUTE
1075 (setq ll-ans
(limcp exp ivar ll
'$plus
))
1076 (setq exp
(sratsimp ($substitute poles exp
)))
1077 (setq ul-ans
(limcp exp ivar ul
'$minus
))
1080 (combine-ll-ans-ul-ans ll-ans ul-ans
)
1083 (defun atan-poles (exp ll ul ivar
)
1084 `((mlist) ,@(atan-pole1 exp ll ul ivar
)))
1086 (defun atan-pole1 (exp ll ul ivar
&aux ipart
)
1089 ((matanp exp
) ;neglect multiplicity and '$unknowns for now.
1090 (desetq (exp . ipart
) (trisplit exp
))
1092 ((not (equal (sratsimp ipart
) 0)) ())
1093 (t (let ((pole (poles-in-interval (let (($algebraic t
))
1094 (sratsimp (cadr exp
)))
1096 (cond ((and pole
(not (or (eq pole
'$unknown
)
1098 (do ((l pole
(cdr l
)) (llist ()))
1101 ((zerop1 (m- (caar l
) ll
)) t
) ; don't worry about discontinuity
1102 ((zerop1 (m- (caar l
) ul
)) t
) ; at boundary of integration
1103 (t (let ((low-lim ($limit
(cadr exp
) ivar
(caar l
) '$minus
))
1104 (up-lim ($limit
(cadr exp
) ivar
(caar l
) '$plus
)))
1105 (cond ((and (not (eq low-lim up-lim
))
1106 (real-infinityp low-lim
)
1107 (real-infinityp up-lim
))
1108 (let ((change (if (eq low-lim
'$minf
)
1111 (setq llist
(cons `((mequal simp
) ,exp
,(m+ exp change
))
1112 llist
)))))))))))))))
1113 (t (do ((l (cdr exp
) (cdr l
))
1116 (setq llist
(append llist
(atan-pole1 (car l
) ll ul ivar
)))))))
1118 (defun difapply (ivar n d s fn1
)
1119 (prog (k m r $noprincipal
)
1120 (cond ((eq ($asksign
(m+ (deg-var d ivar
) (m- s
) (m- 2.
))) '$neg
)
1122 (setq $noprincipal t
)
1123 (cond ((or (not (mexptp d
))
1124 (not (numberp (setq r
(caddr d
)))))
1127 ;; There are no calls where fn1 is ever equal to
1128 ;; 'mtorat. Hence this case is never true. What is
1129 ;; this testing for?
1131 (equal 1.
(deg-var (cadr d
) ivar
)))
1133 (setq m
(deg-var (setq d
(cadr d
)) ivar
))
1134 (setq k
(m// (m+ s
2.
) m
))
1135 (cond ((eq (ask-integer (m// (m+ s
2.
) m
) '$any
) '$yes
)
1137 (t (setq k
(m+ 1 k
))))
1138 (cond ((eq ($sign
(m+ r
(m- k
))) '$pos
)
1139 (return (diffhk fn1 n d k
(m+ r
(m- k
)) ivar
))))))
1141 (defun diffhk (fn1 n d r m ivar
)
1144 (setq d1
(funcall fn1 n
1146 (m* r
(deg-var d ivar
))))
1147 (cond (d1 (return (difap1 d1 r
'*z
* m
0.
))))))
1149 (defun principal nil
1150 (cond ($noprincipal
(diverg))
1152 (format t
"Principal Value~%")
1153 (setq *pcprntd
* t
))))
1155 ;; e is of form poly(x)*exp(m*%i*x)
1156 ;; s is degree of denominator
1157 ;; adds e to *bptu* or *bptd* according to sign of m
1158 (defun rib (e s ivar
)
1159 (cond ((or (mnump e
) (constant e
))
1160 (setq *bptu
* (cons e
*bptu
*)))
1163 (setq e
(rmconst1 e ivar
))
1167 (multiple-value-setq (e updn
)
1168 (catch 'ptimes%e
(ptimes%e nn nd ivar
)))
1169 (cond ((null e
) nil
)
1170 (t (setq e
(m* c e
))
1171 (cond (updn (setq *bptu
* (cons e
*bptu
*)))
1172 (t (setq *bptd
* (cons e
*bptd
*))))))))))
1174 ;; Check term is of form poly(x)*exp(m*%i*x)
1175 ;; n is degree of denominator.
1176 (defun ptimes%e
(term n ivar
&aux updn
)
1177 (cond ((and (mexptp term
)
1178 (eq (cadr term
) '$%e
)
1179 (polyinx (caddr term
) ivar nil
)
1180 (eq ($sign
(m+ (deg-var ($realpart
(caddr term
)) ivar
) -
1))
1182 (eq ($sign
(m+ (deg-var (setq nn
* ($imagpart
(caddr term
))) ivar
)
1185 ;; Set updn to T if the coefficient of IVAR in the
1186 ;; polynomial is known to be positive. Otherwise set to NIL.
1187 ;; (What does updn really mean?)
1188 (setq updn
(eq ($asksign
(ratdisrep (ratcoef nn
* ivar
))) '$pos
))
1190 ((and (mtimesp term
)
1191 (setq nn
* (polfactors term ivar
))
1192 (or (null (car nn
*))
1193 (eq ($sign
(m+ n
(m- (deg-var (car nn
*) ivar
))))
1195 (not (alike1 (cadr nn
*) term
))
1196 (multiple-value-setq (term updn
)
1197 (ptimes%e
(cadr nn
*) n ivar
))
1200 (t (throw 'ptimes%e nil
))))
1202 (defun csemidown (n d ivar
)
1203 (let ((*pcprntd
* t
)) ;Not sure what to do about PRINCIPAL values here.
1205 (res-var ivar n d
#'lowerhalf
#'(lambda (x)
1206 (cond ((equal ($imagpart x
) 0) t
)
1209 (defun lowerhalf (j)
1210 (eq ($asksign
($imagpart j
)) '$neg
))
1212 (defun upperhalf (j)
1213 (eq ($asksign
($imagpart j
)) '$pos
))
1216 (defun csemiup (n d ivar
)
1217 (let ((*pcprntd
* t
)) ;I'm not sure what to do about PRINCIPAL values here.
1219 (res-var ivar n d
#'upperhalf
#'(lambda (x)
1220 (cond ((equal ($imagpart x
) 0) t
)
1224 (cond ((null n
) nil
)
1225 (t (m*t
'$%i
($rectform
(m+ (cond ((car n
)
1233 ;; exponentialize sin and cos
1234 (defun sconvert (e ivar
)
1236 ((polyinx e ivar nil
) e
)
1237 ((eq (caar e
) '%sin
)
1240 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1241 (m- (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
)))))))
1242 ((eq (caar e
) '%cos
)
1243 (mul* '((rat) 1.
2.
)
1244 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1245 (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
))))))
1247 (cons (list (caar e
)) (mapcar #'(lambda (ee)
1251 (defun polfactors (exp ivar
)
1253 (cond ((mplusp exp
) nil
)
1254 (t (cond ((mtimesp exp
)
1255 (setq exp
(reverse (cdr exp
))))
1256 (t (setq exp
(list exp
))))
1257 (mapc #'(lambda (term)
1258 (cond ((polyinx term ivar nil
)
1260 (t (push term rest
))))
1262 (list (m*l poly
) (m*l rest
))))))
1266 (cond ((atom e
) (return e
))
1267 ((not (among '$%e e
)) (return e
))
1270 (setq d
($imagpart
(caddr e
)))
1271 (return (m* (m^t
'$%e
($realpart
(caddr e
)))
1273 (m*t
'$%i
`((%sin
) ,d
))))))
1274 (t (return (simplify (cons (list (caar e
))
1275 (mapcar #'esap
(cdr e
)))))))))
1277 ;; computes integral from minf to inf for expressions of the form
1278 ;; exp(%i*m*x)*r(x) by residues on either the upper half
1279 ;; plane or the lower half plane, depending on whether
1280 ;; m is positive or negative. [wang p. 77]
1282 ;; exponentializes sin and cos before applying residue method.
1283 ;; can handle some expressions with poles on real line, such as
1285 (defun mtosc (grand ivar
)
1286 (multiple-value-bind (n d
)
1287 (numden-var grand ivar
)
1288 (let (ratterms ratans
1289 plf
*bptu
* *bptd
* s upans downans
)
1290 (cond ((not (or (polyinx d ivar nil
)
1291 (and (setq grand
(%einvolve-var d ivar
))
1293 (polyinx (setq d
(sratsimp (m// d
(m^t
'$%e grand
))))
1296 (setq n
(m// n
(m^t
'$%e grand
)))))) nil
)
1297 ((equal (setq s
(deg-var d ivar
)) 0) nil
)
1298 ;;;Above tests for applicability of this method.
1299 ((and (or (setq plf
(polfactors n ivar
)) t
)
1300 (setq n
($expand
(cond ((car plf
)
1301 (m*t
'x
* (sconvert (cadr plf
) ivar
)))
1302 (t (sconvert n ivar
)))))
1303 (cond ((mplusp n
) (setq n
(cdr n
)))
1304 (t (setq n
(list n
))))
1306 (cond ((polyinx term ivar nil
)
1307 ;; call to $expand can create rational terms
1308 ;; with no exp(m*%i*x)
1309 (setq ratterms
(cons term ratterms
)))
1312 ;;;Function RIB sets up the values of BPTU and BPTD
1314 (setq *bptu
* (subst (car plf
) 'x
* *bptu
*))
1315 (setq *bptd
* (subst (car plf
) 'x
* *bptd
*))
1316 (setq ratterms
(subst (car plf
) 'x
* ratterms
))
1317 t
) ;CROCK, CROCK. This is TERRIBLE code.
1319 ;;;If there is BPTU then CSEMIUP must succeed.
1320 ;;;Likewise for BPTD.
1323 (let (($intanalysis nil
))
1324 ;; The original integrand was already
1325 ;; determined to have no poles by initial-analysis.
1326 ;; If individual terms of the expansion have poles, the poles
1327 ;; must cancel each other out, so we can ignore them.
1328 (try-defint (m// (m+l ratterms
) d
) ivar
'$minf
'$inf
))
1330 ;; if integral of ratterms is divergent, ratans is nil,
1331 ;; and mtosc returns nil
1333 (cond (*bptu
* (setq upans
(csemiup (m+l
*bptu
*) d ivar
)))
1335 (cond (*bptd
* (setq downans
(csemidown (m+l
*bptd
*) d ivar
)))
1336 (t (setq downans
0))))
1338 (sratsimp (m+ ratans
1339 (m* '$%pi
(m+ upans
(m- downans
))))))))))
1342 (defun evenfn (e ivar
)
1343 (let ((temp (m+ (m- e
)
1345 ($substitute
(m- ivar
) ivar e
))
1346 (t ($ratsubst
(m- ivar
) ivar e
))))))
1347 (cond ((zerop1 temp
)
1349 ((zerop1 (sratsimp temp
))
1353 (defun oddfn (e ivar
)
1354 (let ((temp (m+ e
(cond ((atom ivar
)
1355 ($substitute
(m- ivar
) ivar e
))
1356 (t ($ratsubst
(m- ivar
) ivar e
))))))
1357 (cond ((zerop1 temp
)
1359 ((zerop1 (sratsimp temp
))
1363 (defun ztoinf (grand ivar ll ul
)
1364 (prog (n d sn sd varlist
1366 ans r $savefactors
*checkfactors
* temp test-var
1368 (setq $savefactors t sn
(setq sd
(list 1.
)))
1369 (cond ((eq ($sign
(m+ *loopstop
* -
1))
1372 ((setq temp
(or (scaxn grand ivar
)
1373 (ssp grand ivar ll ul
)))
1375 ((involve-var grand ivar
'(%sin %cos %tan
))
1376 (setq grand
(sconvert grand ivar
))
1379 (cond ((polyinx grand ivar nil
)
1381 ((and (ratp grand ivar
)
1383 (andmapcar #'(lambda (e)
1384 (multiple-value-bind (result new-sn new-sd
)
1385 (snumden-var e ivar sn sd
)
1391 (setq nn-var
(m*l sn
)
1393 (setq dn-var
(m*l sd
)
1395 (t (multiple-value-setq (nn-var dn-var
)
1396 (numden-var grand ivar
))))
1399 (setq n
(rmconst1 nn-var ivar
))
1400 (setq d
(rmconst1 dn-var ivar
))
1405 (cond ((polyinx d ivar nil
)
1406 (setq s
(deg-var d ivar
)))
1408 (cond ((and (setq r
(findp n ivar
))
1409 (eq (ask-integer r
'$integer
) '$yes
)
1410 (setq test-var
(bxm d s ivar
))
1411 (setq ans
(apply 'fan
(cons (m+ 1. r
) test-var
))))
1412 (return (m* (m// nc dc
) (sratsimp ans
))))
1413 ((and (ratp grand ivar
)
1414 (setq ans
(zmtorat n
(cond ((mtimesp d
) d
)
1418 (ztorat n d s ivar
))
1420 (return (m* (m// nc dc
) ans
)))
1421 ((and (evenfn d ivar
)
1422 (setq nn-var
(p*lognxp n s ivar
)))
1423 (setq ans
(log*rat
(car nn-var
) d
(cadr nn-var
) ivar
))
1424 (return (m* (m// nc dc
) ans
)))
1425 ((involve-var grand ivar
'(%log
))
1426 (cond ((setq ans
(logquad0 grand ivar
))
1427 (return (m* (m// nc dc
) ans
)))
1430 (cond ((setq temp
(batapp grand ivar ll ul
))
1434 (cond ((let ((*mtoinf
* nil
))
1435 (setq temp
(ggr grand t ivar
)))
1438 (cond ((let ((*nodiverg
* t
))
1439 (setq ans
(catch 'divergent
1440 (andmapcar #'(lambda (g)
1441 (ztoinf g ivar ll ul
))
1443 (cond ((eq ans
'divergent
) nil
)
1444 (t (return (sratsimp (m+l ans
)))))))))
1446 (cond ((and (evenfn grand ivar
)
1447 (setq *loopstop
* (m+ 1 *loopstop
*))
1448 (setq ans
(method-by-limits grand ivar
'$minf
'$inf
)))
1449 (return (m*t
'((rat) 1.
2.
) ans
)))
1452 (defun ztorat (n d s ivar
)
1453 (cond ((and (null *dflag
*)
1454 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1455 (ztorat n d s ivar
)))))
1457 ((setq n
(let ((plogabs ()))
1458 (keyhole (let ((var ivar
))
1459 (declare (special var
))
1460 ;; It's very important here to bind VAR
1461 ;; because the PLOG simplifier checks
1462 ;; for VAR. Without this, the
1463 ;; simplifier converts plog(-x) to
1464 ;; log(x)+%i*%pi, which messes up the
1466 (m* `((%plog
) ,(m- ivar
)) n
))
1471 ;; Let's not signal an error here. Return nil so that we
1472 ;; eventually return a noun form if no other algorithm gives
1475 (merror (intl:gettext
"defint: keyhole integration failed.~%"))
1478 ;;(setq *dflag* nil)
1480 (defun logquad0 (exp ivar
)
1481 (let ((a ()) (b ()) (c ()))
1482 (cond ((setq exp
(logquad exp ivar
))
1483 (setq a
(car exp
) b
(cadr exp
) c
(caddr exp
))
1484 ($asksign b
) ;let the data base know about the sign of B.
1485 (cond ((eq ($asksign c
) '$pos
)
1486 (setq c
(m^
(m// c a
) '((rat) 1.
2.
)))
1488 `((%acos
) ,(add* 'epsilon
(m// b
(mul* 2. a c
))))))
1489 (setq a
(m// (m* b
`((%log
) ,c
))
1490 (mul* a
(simplify `((%sin
) ,b
)) c
)))
1491 (get-limit a
'epsilon
0 '$plus
))))
1494 (defun logquad (exp ivar
)
1495 (let ((varlist (list ivar
)))
1497 (setq exp
(cdr (ratrep* exp
)))
1498 (cond ((and (alike1 (pdis (car exp
))
1500 (not (atom (cdr exp
)))
1501 (equal (cadr (cdr exp
)) 2.
)
1502 (not (equal (ptterm (cddr exp
) 0.
) 0.
)))
1503 (setq exp
(mapcar 'pdis
(cdr (oddelm (cdr exp
)))))))))
1505 (defun mtoinf (grand ivar ll ul
)
1506 (prog (ans ans1 sd sn pp pe n d s nc dc $savefactors
*checkfactors
* temp
1508 (setq $savefactors t
)
1509 (setq sn
(setq sd
(list 1.
)))
1510 (cond ((eq ($sign
(m+ *loopstop
* -
1)) '$pos
)
1512 ((involve-var grand ivar
'(%sin %cos
))
1513 (cond ((and (evenfn grand ivar
)
1514 (or (setq temp
(scaxn grand ivar
))
1515 (setq temp
(ssp grand ivar ll ul
))))
1516 (return (m*t
2. temp
)))
1517 ((setq temp
(mtosc grand ivar
))
1520 ((among '$%i
(%einvolve-var grand ivar
))
1521 (cond ((setq temp
(mtosc grand ivar
))
1524 (setq grand
($exponentialize grand
)) ; exponentializing before numden
1525 (cond ((polyinx grand ivar nil
) ; avoids losing multiplicities [ 1309432 ]
1527 ((and (ratp grand ivar
)
1529 (andmapcar #'(lambda (e)
1530 (multiple-value-bind (result new-sn new-sd
)
1531 (snumden-var e ivar sn sd
)
1537 (setq nn-var
(m*l sn
) sn nil
)
1538 (setq dn-var
(m*l sd
) sd nil
))
1539 (t (multiple-value-setq (nn-var dn-var
)
1540 (numden-var grand ivar
))))
1541 (setq n
(rmconst1 nn-var ivar
))
1542 (setq d
(rmconst1 dn-var ivar
))
1547 (cond ((polyinx d ivar nil
)
1548 (setq s
(deg-var d ivar
))))
1549 (cond ((and (not (%einvolve-var grand ivar
))
1550 (notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
1551 (setq pp
(findp n ivar
))
1552 (eq (ask-integer pp
'$integer
) '$yes
)
1553 (setq pe
(bxm d s ivar
)))
1554 (cond ((and (eq (ask-integer (caddr pe
) '$even
) '$yes
)
1555 (eq (ask-integer pp
'$even
) '$yes
))
1556 (cond ((setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1557 (setq ans
(m*t
2. ans
))
1558 (return (m* (m// nc dc
) ans
)))))
1559 ((equal (car pe
) 1.
)
1560 (cond ((and (setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1561 (setq nn-var
(fan (m+ 1. pp
)
1566 (setq ans
(m+ ans
(m*t
(m^ -
1 pp
) nn-var
)))
1567 (return (m* (m// nc dc
) ans
))))))))
1570 ((pppin%ex
(nd ivar
)
1571 ;; Test to see if exp is of the form p(x)*f(exp(x)). If so, set pp to
1572 ;; be p(x) and set pe to f(exp(x)).
1573 (setq nd
($factor nd
))
1574 (cond ((polyinx nd ivar nil
)
1575 (setq pp
(cons nd pp
)) t
)
1576 ((catch 'pin%ex
(pin%ex nd ivar
))
1577 (setq pe
(cons nd pe
)) t
)
1579 (andmapcar #'(lambda (ex)
1582 (cond ((and (ratp grand ivar
)
1583 (setq ans1
(zmtorat n
1584 (cond ((mtimesp d
) d
) (t ($sqfr d
)))
1587 (mtorat n d s ivar
))
1589 (setq ans
(m*t
'$%pi ans1
))
1590 (return (m* (m// nc dc
) ans
)))
1591 ((and (or (%einvolve-var grand ivar
)
1592 (involve-var grand ivar
'(%sinh %cosh %tanh
)))
1593 (pppin%ex n ivar
) ;setq's P* and PE*...Barf again.
1594 (setq ans
(catch 'pin%ex
(pin%ex d ivar
))))
1595 ;; We have an integral of the form p(x)*F(exp(x)), where
1596 ;; p(x) is a polynomial.
1599 (return (dintexp grand ivar ll ul
)))
1600 ((not (and (zerop1 (get-limit grand ivar
'$inf
))
1601 (zerop1 (get-limit grand ivar
'$minf
))))
1602 ;; These limits must exist for the integral to converge.
1604 ((setq ans
(rectzto%pi2
(m*l pp
) (m*l pe
) d ivar
))
1605 ;; This only handles the case when the F(z) is a
1606 ;; rational function.
1607 (return (m* (m// nc dc
) ans
)))
1608 ((setq ans
(log-transform (m*l pp
) (m*l pe
) d ivar ul
))
1609 ;; If we get here, F(z) is not a rational function.
1610 ;; We transform it using the substitution x=log(y)
1611 ;; which gives us an integral of the form
1612 ;; p(log(y))*F(y)/y, which maxima should be able to
1614 (return (m* (m// nc dc
) ans
)))
1616 ;; Give up. We don't know how to handle this.
1619 (cond ((setq ans
(ggrm grand ivar
))
1621 ((and (evenfn grand ivar
)
1622 (setq *loopstop
* (m+ 1 *loopstop
*))
1623 (setq ans
(method-by-limits grand ivar
0 '$inf
)))
1624 (return (m*t
2. ans
)))
1627 (defun linpower0 (exp ivar
)
1628 (cond ((and (setq exp
(linpower exp ivar
))
1629 (eq (ask-integer (caddr exp
) '$even
)
1631 (ratgreaterp 0.
(car exp
)))
1634 ;;; given (b*x+a)^n+c returns (a b n c)
1635 (defun linpower (exp ivar
)
1636 (let (linpart deg lc c varlist
)
1637 (cond ((not (polyp-var exp ivar
)) nil
)
1638 (t (let ((varlist (list ivar
)))
1640 (setq linpart
(cadr (ratrep* exp
)))
1641 (cond ((atom linpart
)
1643 (t (setq deg
(cadr linpart
))
1644 ;;;get high degree of poly
1645 (setq linpart
($diff exp ivar
(m+ deg -
1)))
1646 ;;;diff down to linear.
1647 (setq lc
(sdiff linpart ivar
))
1648 ;;;all the way to constant.
1649 (setq linpart
(sratsimp (m// linpart lc
)))
1650 (setq lc
(sratsimp (m// lc
`((mfactorial) ,deg
))))
1651 ;;;get rid of factorial from differentiation.
1652 (setq c
(sratsimp (m+ exp
(m* (m- lc
)
1653 (m^ linpart deg
)))))))
1654 ;;;Sees if can be expressed as (a*x+b)^n + part freeof x.
1655 (cond ((not (among ivar c
))
1656 `(,lc
,linpart
,deg
,c
))
1659 (defun mtorat (n d s ivar
)
1660 (let ((*semirat
* t
))
1661 (cond ((and (null *dflag
*)
1662 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1663 (mtorat n d s ivar
)))))
1665 (t (csemiup n d ivar
)))))
1667 (defun zmtorat (n d s fn1 ivar
)
1669 (cond ((eq ($sign
(m+ s
(m+ 1 (setq nn
* (deg-var n ivar
)))))
1672 ((eq ($sign
(m+ s -
4))
1675 (setq d
($factor d
))
1676 (setq c
(rmconst1 d ivar
))
1682 (setq n
(partnum n d ivar
))
1684 (setq n
($xthru
(m+l
1685 (mapcar #'(lambda (a b
)
1686 (let ((foo (funcall fn1
(car a
) b
(deg-var b ivar
))))
1687 (if foo
(m// foo
(cadr a
))
1688 (return-from zmtorat nil
))))
1691 (return (cond (c (m// n c
))
1695 (setq n
(funcall fn1 n d s
))
1696 (return (when n
(sratsimp (cond (c (m// n c
))
1699 (defun pfrnum (f g n n2 ivar
)
1700 (let ((varlist (list ivar
)) genvar
)
1701 (setq f
(polyform f
)
1705 (setq ivar
(caadr (ratrep* ivar
)))
1706 (setq f
(resprog0-var ivar f g n n2
))
1707 (list (list (pdis (cadr f
)) (pdis (cddr f
)))
1708 (list (pdis (caar f
)) (pdis (cdar f
))))))
1713 (setq f
(ratrep* e
))
1714 (and (equal (cddr f
) 1)
1716 (and (equal (length (setq d
(cddr f
))) 3)
1719 (return (list (car d
)
1721 (ptimes (cadr f
) (caddr d
)))))
1722 (merror "defint: bug from PFRNUM in RESIDU.")))
1724 (defun partnum (n dl ivar
)
1725 (let ((n2 1) ans nl
)
1726 (do ((dl dl
(cdr dl
)))
1728 (nconc ans
(ncons (list n n2
))))
1729 (setq nl
(pfrnum (car dl
) (m*l
(cdr dl
)) n n2 ivar
))
1730 (setq ans
(nconc ans
(ncons (car nl
))))
1731 (setq n2
(cadadr nl
) n
(caadr nl
) nl nil
))))
1733 (defun ggrm (e ivar
)
1734 (prog (poly expo
*mtoinf
* mb varlist genvar l c gvar
)
1735 (setq varlist
(list ivar
))
1737 (cond ((and (setq expo
(%einvolve-var e ivar
))
1738 (polyp-var (setq poly
(sratsimp (m// e
(m^t
'$%e expo
)))) ivar
)
1739 (setq l
(catch 'ggrm
(ggr (m^t
'$%e expo
) nil ivar
))))
1741 (setq mb
(m- (subin-var 0.
(cadr l
) ivar
)))
1742 (setq poly
(m+ (subin-var (m+t mb ivar
) poly ivar
)
1743 (subin-var (m+t mb
(m*t -
1 ivar
)) poly ivar
))))
1745 (setq expo
(caddr l
)
1750 (setq poly
(cdr (ratrep* poly
)))
1751 (setq mb
(m^
(pdis (cdr poly
)) -
1)
1753 (setq gvar
(caadr (ratrep* ivar
)))
1754 (cond ((or (atom poly
)
1755 (pointergp gvar
(car poly
)))
1756 (setq poly
(list 0. poly
)))
1757 (t (setq poly
(cdr poly
))))
1758 (return (do ((poly poly
(cddr poly
)))
1760 (mul* (m^t
'$%e c
) (m^t expo -
1) mb
(m+l e
)))
1761 (setq e
(cons (ggrm1 (car poly
) (pdis (cadr poly
)) l expo
)
1764 (defun ggrm1 (d k a b
)
1765 (setq b
(m// (m+t
1. d
) b
))
1766 (m* k
`((%gamma
) ,b
) (m^ a
(m- b
))))
1768 ;; Compute the integral(n/d,x,0,inf) by computing the negative of the
1769 ;; sum of residues of log(-x)*n/d over the poles of n/d inside the
1770 ;; keyhole contour. This contour is basically an disk with a slit
1771 ;; along the positive real axis. n/d must be a rational function.
1772 (defun keyhole (n d ivar
)
1773 (let* ((*semirat
* ())
1774 (res (res-var ivar n d
1776 ;; Ok if not on the positive real axis.
1777 (or (not (equal ($imagpart j
) 0))
1778 (eq ($asksign j
) '$neg
)))
1780 (cond ((eq ($asksign j
) '$pos
)
1785 ($rectform
($multthru
(m+ (cond ((car res
)
1792 ;; Look at an expression e of the form sin(r*x)^k, where k is an
1793 ;; integer. Return the list (1 r k). (Not sure if the first element
1794 ;; of the list is always 1 because I'm not sure what partition is
1795 ;; trying to do here.)
1798 (cond ((atom e
) (return nil
)))
1799 (setq e
(partition e ivar
1))
1802 (cond ((setq r
(sinrx e ivar
))
1803 (return (list m r
1)))
1805 (eq (ask-integer (setq k
(caddr e
)) '$integer
) '$yes
)
1806 (setq r
(sinrx (cadr e
) ivar
)))
1807 (return (list m r k
))))))
1809 ;; Look at an expression e of the form sin(r*x) and return r.
1810 (defun sinrx (e ivar
)
1811 (cond ((and (consp e
) (eq (caar e
) '%sin
))
1812 (cond ((eq (cadr e
) ivar
)
1814 ((and (setq e
(partition (cadr e
) ivar
1))
1820 ;; integrate(a*sc(r*x)^k/x^n,x,0,inf).
1821 (defun ssp (exp ivar ll ul
)
1823 ;; Get the argument of the involved trig function.
1824 (when (null (setq arg
(involve-var exp ivar
'(%sin %cos
))))
1826 ;; I don't think this needs to be special.
1828 (declare (special n
))
1829 ;; Replace (1-cos(arg)^2) with sin(arg)^2.
1830 (setq exp
($substitute
;(m^t `((%sin) ,ivar) 2.)
1831 ;(m+t 1. (m- (m^t `((%cos) ,ivar) 2.)))
1832 ;; The code from above generates expressions with
1833 ;; a missing simp flag. Furthermore, the
1834 ;; substitution has to be done for the complete
1835 ;; argument of the trig function. (DK 02/2010)
1836 `((mexpt simp
) ((%sin simp
) ,arg
) 2)
1837 `((mplus) 1 ((mtimes) -
1 ((mexpt) ((%cos
) ,arg
) 2)))
1839 (multiple-value-bind (u dn
)
1840 (numden-var exp ivar
)
1841 (cond ((and (setq n
(findp dn ivar
))
1842 (eq (ask-integer n
'$integer
) '$yes
))
1843 ;; n is the power of the denominator.
1844 (cond ((setq c
(skr u ivar
))
1846 (return (scmp c n ivar ll ul
)))
1848 (setq c
(andmapcar #'(lambda (uu)
1851 ;; Do this for a sum of such terms.
1852 (return (m+l
(mapcar #'(lambda (j) (scmp j n ivar ll ul
))
1855 ;; We have an integral of the form sin(r*x)^k/x^n. C is the list (1 r k).
1857 ;; The substitution y=r*x converts this integral to
1859 ;; r^(n-1)*integral(sin(y)^k/y^n,y,0,inf)
1861 ;; (If r is negative, we need to negate the result.)
1863 ;; The recursion Wang gives on p. 87 has a typo. The second term
1864 ;; should be subtracted from the first. This formula is given in G&R,
1865 ;; 3.82, formula 12.
1867 ;; integrate(sin(x)^r/x^s,x) =
1868 ;; r*(r-1)/(s-1)/(s-2)*integrate(sin(x)^(r-2)/x^(s-2),x)
1869 ;; - r^2/(s-1)/(s-2)*integrate(sin(x)^r/x^(s-2),x)
1871 ;; (Limits are assumed to be 0 to inf.)
1873 ;; This recursion ends up with integrals with s = 1 or 2 and
1875 ;; integrate(sin(x)^p/x,x,0,inf) = integrate(sin(x)^(p-1),x,0,%pi/2)
1877 ;; with p > 0 and odd. This latter integral is known to maxima, and
1878 ;; it's value is beta(p/2,1/2)/2.
1880 ;; integrate(sin(x)^2/x^2,x,0,inf) = %pi/2*binomial(q-3/2,q-1)
1884 (defun scmp (c n ivar ll ul
)
1885 ;; Compute sign(r)*r^(n-1)*integrate(sin(y)^k/y^n,y,0,inf)
1886 (destructuring-bind (mult r k
)
1888 (let ((recursion (sinsp k n
)))
1894 ;; Recursion failed. Return the integrand
1895 ;; The following code generates expressions with a missing simp flag
1896 ;; for the sin function. Use better simplifying code. (DK 02/2010)
1897 ; (let ((integrand (div (pow `((%sin) ,(m* r ivar))
1900 (let ((integrand (div (power (take '(%sin
) (mul r ivar
))
1904 `((%integrate
) ,integrand
,ivar
,ll
,ul
)))))))
1906 ;; integrate(sin(x)^n/x^2,x,0,inf) = pi/2*binomial(n-3/2,n-1).
1907 ;; Express in terms of Gamma functions, though.
1909 (m* half%pi
($makegamma
`((%binomial
) ,(m+t
(m+ n -
1) '((rat) -
1 2))
1913 ;; integrate(sin(x)^n/x,x,0,inf) = beta((n+1)/2,1/2)/2, for n odd and
1918 (t (bygamma (m+ n -
1) 0.
))))
1920 ;; This implements the recursion for computing
1921 ;; integrate(sin(y)^l/y^k,y,0,inf). (Note the change in notation from
1926 (cond ((eq ($sign
(m+ l
(m- (m+ k -
1))))
1928 ;; Integral diverges if l-(k-1) < 0.
1930 ((not (even1 (m+ l k
)))
1931 ;; If l + k is not even, return NIL. (Is this the right
1935 ;; We have integrate(sin(y)^l/y^2). Use sevn to evaluate.
1938 ;; We have integrate(sin(y)^l/y,y)
1940 ((eq ($sign
(m+ k -
2.
))
1942 (setq i
(m* (m+ k -
1)
1943 (setq j
(m+ k -
2.
))))
1944 ;; j = k-2, i = (k-1)*(k-2)
1947 ;; The main recursion:
1950 ;; = l*(l-1)/(k-1)/(k-2)*i(sin(y)^(l-2)/y^k)
1951 ;; - l^2/(k-1)/(k-1)*i(sin(y)^l/y^(k-2))
1954 (sinsp (m+ l -
2.
) j
))
1959 ;; Returns the fractional part of a?
1963 ;; Why do we return 0 if a is a number? Perhaps we really
1967 ;; If we're here, this basically assumes a is a rational.
1968 ;; Compute the remainder and return the result.
1969 (list (car a
) (rem (cadr a
) (caddr a
)) (caddr a
)))
1970 ((and (atom a
) (abless1 a
)) a
)
1973 (abless1 (caddr a
)))
1976 ;; Doesn't appear to be used anywhere in Maxima. Not sure what this
1977 ;; was intended to do.
1980 (cond ((polyinx e var nil
) 0.
)
1986 (m+l
(mapcar #'thrad e
)))))
1989 ;;; THE FOLLOWING FUNCTION IS FOR TRIG FUNCTIONS OF THE FOLLOWING TYPE:
1990 ;;; LOWER LIMIT=0 B A MULTIPLE OF %PI SCA FUNCTION OF SIN (X) COS (X)
1993 (defun period (p e ivar
)
1994 (and (alike1 (no-err-sub-var ivar e ivar
)
1995 (setq e
(no-err-sub-var (m+ p ivar
) e ivar
)))
1996 ;; means there was no error
1999 ; returns cons of (integer_part . fractional_part) of a
2001 ;; I think we really want to compute how many full periods are in a
2002 ;; and the remainder.
2003 (let* ((q (igprt (div a
(mul 2 '$%pi
))))
2004 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
2007 ; returns cons of (integer_part . fractional_part) of a
2008 (defun lower-infr (a)
2009 ;; I think we really want to compute how many full periods are in a
2010 ;; and the remainder.
2011 (let* (;(q (igprt (div a (mul 2 '$%pi))))
2012 (q (mfuncall '$ceiling
(div a
(mul 2 '$%pi
))))
2013 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
2017 ;; Return the integer part of r.
2020 (mfuncall '$floor r
))
2023 ;;;Try making exp(%i*ivar) --> yy, if result is rational then do integral
2024 ;;;around unit circle. Make corrections for limits of integration if possible.
2025 (defun scrat (sc b ivar
)
2026 (let* ((exp-form (sconvert sc ivar
)) ;Exponentialize
2027 (rat-form (maxima-substitute 'yy
(m^t
'$%e
(m*t
'$%i ivar
))
2028 exp-form
))) ;Try to make Rational fun.
2029 (cond ((and (ratp rat-form
'yy
)
2030 (not (among ivar rat-form
)))
2031 (cond ((alike1 b %pi2
)
2032 (let ((ans (zto%pi2 rat-form
'yy
)))
2036 (evenfn exp-form ivar
))
2037 (let ((ans (zto%pi2 rat-form
'yy
)))
2038 (cond (ans (m*t
'((rat) 1.
2.
) ans
))
2040 ((and (alike1 b half%pi
)
2041 (evenfn exp-form ivar
)
2043 (no-err-sub-var (m+t
'$%pi
(m*t -
1 ivar
))
2046 (let ((ans (zto%pi2 rat-form
'yy
)))
2047 (cond (ans (m*t
'((rat) 1.
4.
) ans
))
2050 ;;; Do integrals of sin and cos. this routine makes sure lower limit
2052 (defun intsc1 (a b e ivar
)
2053 ;; integrate(e,var,a,b)
2054 (let ((trigarg (find-first-trigarg e
))
2057 (*sin-cos-recur
* t
)) ;recursion stopper
2058 (prog (ans d nzp2 l int-zero-to-d int-nzp2 int-zero-to-c limit-diff
)
2059 (let* ((arg (simple-trig-arg trigarg ivar
)) ;; pattern match sin(cc*x + bb)
2062 (new-var (gensym "NEW-VAR-")))
2063 (putprop new-var t
'internal
)
2065 (not (every-trigarg-alike e trigarg
)))
2067 (when (not (and (equal cc
1) (equal bb
0)))
2068 (setq e
(div (maxima-substitute (div (sub new-var bb
) cc
)
2071 (setq ivar new-var
) ;; change of variables to get sin(new-var)
2072 (setq a
(add bb
(mul a cc
)))
2073 (setq b
(add bb
(mul b cc
)))))
2074 (setq limit-diff
(m+ b
(m* -
1 a
)))
2075 (when (or (not (period %pi2 e ivar
))
2076 (member a
*infinities
*)
2077 (member b
*infinities
*)
2078 (not (and ($constantp a
)
2080 ;; Exit if b or a is not a constant or if the integrand
2081 ;; doesn't appear to have a period of 2 pi.
2084 ;; Multiples of 2*%pi in limits.
2085 (cond ((integerp (setq d
(let (($float nil
))
2086 (m// limit-diff %pi2
))))
2087 (cond ((setq ans
(intsc e %pi2 ivar
))
2088 (return (m* d ans
)))
2091 ;; The integral is not over a full period (2*%pi) or multiple
2092 ;; of a full period.
2094 ;; Wang p. 111: The integral integrate(f(x),x,a,b) can be
2097 ;; n * integrate(f,x,0,2*%pi) + integrate(f,x,0,c)
2098 ;; - integrate(f,x,0,d)
2100 ;; for some integer n and d >= 0, c < 2*%pi because there exist
2101 ;; integers p and q such that a = 2 * p *%pi + d and b = 2 * q
2102 ;; * %pi + c. Then n = q - p.
2104 ;; Compute q and c for the upper limit b.
2109 (setq int-zero-to-d
0.
)
2111 ;; Compute p and d for the lower limit a.
2113 ;; avoid an extra trip around the circle - helps skip principal values
2114 (if (ratgreaterp (car b
) (car l
)) ; if q > p
2115 (setq l
(cons (add 1 (car l
)) ; p += 1
2116 (add (mul -
1 %pi2
) (cdr l
))))) ; d -= 2*%pi
2118 ;; Compute -integrate(f,x,0,d)
2120 (cond ((setq ans
(try-intsc e
(cdr l
) ivar
))
2123 ;; Compute n = q - p (stored in nzp2)
2124 (setq nzp2
(m+ (car b
) (m- (car l
))))
2126 ;; Compute n*integrate(f,x,0,2*%pi)
2127 (setq int-nzp2
(cond ((zerop1 nzp2
)
2130 ((setq ans
(try-intsc e %pi2 ivar
))
2131 ;; n is not zero, so compute
2132 ;; integrate(f,x,0,2*%pi)
2134 ;; Unable to compute integrate(f,x,0,2*%pi)
2136 ;; Compute integrate(f,x,0,c)
2137 (setq int-zero-to-c
(try-intsc e
(cdr b
) ivar
))
2139 (return (cond ((and int-zero-to-d int-nzp2 int-zero-to-c
)
2140 ;; All three pieces succeeded.
2141 (add* int-zero-to-d int-nzp2 int-zero-to-c
))
2142 ((ratgreaterp %pi2 limit-diff
)
2143 ;; Less than 1 full period, so intsc can integrate it.
2144 ;; Apply the substitution to make the lower limit 0.
2145 ;; This is last resort because substitution often causes intsc to fail.
2146 (intsc (maxima-substitute (m+ a ivar
) ivar e
)
2151 ;; integrate(sc, var, 0, b), where sc is f(sin(x), cos(x)).
2152 ;; calls intsc with a wrapper to just return nil if integral is divergent,
2153 ;; rather than generating an error.
2154 (defun try-intsc (sc b ivar
)
2155 (let* ((*nodiverg
* t
)
2156 (ans (catch 'divergent
(intsc sc b ivar
))))
2157 (if (eq ans
'divergent
)
2161 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)). I (rtoy)
2162 ;; think this expects b to be less than 2*%pi.
2163 (defun intsc (sc b ivar
)
2166 (multiple-value-bind (b sc
)
2167 (cond ((eq ($sign b
) '$neg
)
2169 (m* -
1 (subin-var (m*t -
1 ivar
) sc ivar
))))
2172 ;; Partition the integrand SC into the factors that do not
2173 ;; contain VAR (the car part) and the parts that do (the cdr
2175 (setq sc
(partition sc ivar
1))
2176 (cond ((setq b
(intsc0 (cdr sc
) b ivar
))
2177 (m* (resimplify (car sc
)) b
))))))
2179 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)).
2180 (defun intsc0 (sc b ivar
)
2181 ;; Determine if sc is a product of sin's and cos's.
2182 (let ((nn* (scprod sc ivar
))
2185 ;; We have a product of sin's and cos's. We handle some
2186 ;; special cases here.
2187 (cond ((alike1 b half%pi
)
2188 ;; Wang p. 110, formula (1):
2189 ;; integrate(sin(x)^m*cos(x)^n, x, 0, %pi/2) =
2190 ;; gamma((m+1)/2)*gamma((n+1)/2)/2/gamma((n+m+2)/2)
2191 (bygamma (car nn
*) (cadr nn
*)))
2193 ;; Wang p. 110, near the bottom, says
2195 ;; int(f(sin(x),cos(x)), x, 0, %pi) =
2196 ;; int(f(sin(x),cos(x)) + f(sin(x),-cos(x)),x,0,%pi/2)
2197 (cond ((eq (real-branch (cadr nn
*) -
1) '$yes
)
2198 (m* (m+ 1.
(m^ -
1 (cadr nn
*)))
2199 (bygamma (car nn
*) (cadr nn
*))))))
2201 (cond ((or (and (eq (ask-integer (car nn
*) '$even
)
2203 (eq (ask-integer (cadr nn
*) '$even
)
2205 (and (ratnump (car nn
*))
2206 (eq (real-branch (car nn
*) -
1)
2208 (ratnump (cadr nn
*))
2209 (eq (real-branch (cadr nn
*) -
1)
2211 (m* 4.
(bygamma (car nn
*) (cadr nn
*))))
2212 ((or (eq (ask-integer (car nn
*) '$odd
) '$yes
)
2213 (eq (ask-integer (cadr nn
*) '$odd
) '$yes
))
2216 ((alike1 b half%pi3
)
2217 ;; Wang, p. 111 says
2219 ;; int(f(sin(x),cos(x)),x,0,3*%pi/2) =
2220 ;; int(f(sin(x),cos(x)),x,0,%pi)
2221 ;; + int(f(-sin(x),-cos(x)),x,0,%pi/2)
2222 (m* (m+ 1.
(m^ -
1 (cadr nn
*)) (m^ -
1 (m+l nn
*)))
2223 (bygamma (car nn
*) (cadr nn
*))))))
2225 ;; We don't have a product of sin's and cos's.
2226 (cond ((and (or (eq b
'$%pi
)
2229 (setq dn
* (scrat sc b ivar
)))
2231 ((setq nn
* (antideriv sc ivar
))
2232 (sin-cos-intsubs nn
* ivar
0. b
))
2235 ;;;Is careful about substitution of limits where the denominator may be zero
2236 ;;;because of various assumptions made.
2237 (defun sin-cos-intsubs (exp ivar ll ul
)
2239 (let ((l (mapcar #'(lambda (e)
2240 (sin-cos-intsubs1 e ivar ll ul
))
2242 (if (not (some #'null l
))
2244 (t (sin-cos-intsubs1 exp ivar ll ul
))))
2246 (defun sin-cos-intsubs1 (exp ivar ll ul
)
2247 (let* ((rat-exp ($rat exp
))
2248 (denom (pdis (cddr rat-exp
))))
2249 (cond ((equal ($csign denom
) '$zero
)
2251 (t (try-intsubs exp ll ul ivar
)))))
2253 (defun try-intsubs (exp ll ul ivar
)
2254 (let* ((*nodiverg
* t
)
2255 (ans (catch 'divergent
(intsubs exp ll ul ivar
))))
2256 (if (eq ans
'divergent
)
2260 (defun try-defint (exp ivar ll ul
)
2261 (let* ((*nodiverg
* t
)
2262 (ans (catch 'divergent
(defint exp ivar ll ul
))))
2263 (if (eq ans
'divergent
)
2267 ;; Determine whether E is of the form sin(x)^m*cos(x)^n and return the
2269 (defun scprod (e ivar
)
2270 (let ((great-minus-1 #'(lambda (temp)
2271 (ratgreaterp temp -
1)))
2274 ((setq m
(powerofx e
`((%sin
) ,ivar
) great-minus-1 ivar
))
2276 ((setq n
(powerofx e
`((%cos
) ,ivar
) great-minus-1 ivar
))
2280 (or (setq m
(powerofx (cadr e
) `((%sin
) ,ivar
) great-minus-1 ivar
))
2281 (setq n
(powerofx (cadr e
) `((%cos
) ,ivar
) great-minus-1 ivar
)))
2284 (setq m
(powerofx (caddr e
) `((%sin
) ,ivar
) great-minus-1 ivar
)))
2285 (t (setq n
(powerofx (caddr e
) `((%cos
) ,ivar
) great-minus-1 ivar
))))
2290 (defun real-branch (exponent value
)
2291 ;; Says whether (m^t value exponent) has at least one real branch.
2292 ;; Only works for values of 1 and -1 now. Returns $yes $no
2294 (cond ((equal value
1.
)
2296 ((eq (ask-integer exponent
'$integer
) '$yes
)
2299 (cond ((eq ($oddp
(caddr exponent
)) t
)
2304 ;; Compute beta((m+1)/2,(n+1)/2)/2.
2305 (defun bygamma (m n
)
2306 (let ((one-half (m//t
1.
2.
)))
2307 (m* one-half
`((%beta
) ,(m* one-half
(m+t
1. m
))
2308 ,(m* one-half
(m+t
1. n
))))))
2310 ;;Seems like Guys who call this don't agree on what it should return.
2311 (defun powerofx (e x p ivar
)
2312 (setq e
(cond ((not (among ivar e
)) nil
)
2317 (not (among ivar
(caddr e
))))
2319 (cond ((null e
) nil
)
2323 ;; Check e for an expression of the form x^kk*(b*x^n+a)^l. If it
2324 ;; matches, Return the two values kk and (list l a n b).
2325 (defun bata0 (e ivar
)
2327 (cond ((atom e
) nil
)
2329 ;; We have f(x)^y. Look to see if f(x) has the desired
2330 ;; form. Then f(x)^y has the desired form too, with
2331 ;; suitably modified values.
2333 ;; XXX: Should we ask for the sign of f(x) if y is not an
2334 ;; integer? This transformation we're going to do requires
2335 ;; that f(x)^y be real.
2336 (destructuring-bind (mexp base power
)
2338 (declare (ignore mexp
))
2339 (multiple-value-bind (kk cc
)
2342 ;; Got a match. Adjust kk and cc appropriately.
2343 (destructuring-bind (l a n b
)
2345 (values (mul kk power
)
2346 (list (mul l power
) a n b
)))))))
2349 (or (and (setq k
(findp (cadr e
) ivar
))
2350 (setq c
(bxm (caddr e
) (polyinx (caddr e
) ivar nil
) ivar
)))
2351 (and (setq k
(findp (caddr e
) ivar
))
2352 (setq c
(bxm (cadr e
) (polyinx (cadr e
) ivar nil
) ivar
)))))
2354 ((setq c
(bxm e
(polyinx e ivar nil
) ivar
))
2361 ;; (COND ((NOT (BATA0 E)) (RETURN NIL))
2362 ;; ((AND (EQUAL -1. (CADDDR C))
2363 ;; (EQ ($askSIGN (SETQ K (m+ 1. K)))
2365 ;; (EQ ($askSIGN (SETQ L (m+ 1. (CAR C))))
2368 ;; (m^ UL (CADDR C)))
2369 ;; (SETQ E (CADR C))
2370 ;; (EQ ($askSIGN (SETQ C (CADDR C))) '$pos))
2371 ;; (RETURN (M// (m* (m^ UL (m+t K (m* C (m+t -1. L))))
2372 ;; `(($BETA) ,(SETQ NN* (M// K C))
2377 ;; Integrals of the form i(log(x)^m*x^k*(a+b*x^n)^l,x,0,ul). There
2378 ;; are two cases to consider: One case has ul>0, b<0, a=-b*ul^n, k>-1,
2379 ;; l>-1, n>0, m a nonnegative integer. The second case has ul=inf, l < 0.
2381 ;; These integrals are essentially partial derivatives of the Beta
2382 ;; function (i.e. the Eulerian integral of the first kind). Note
2383 ;; that, currently, with the default setting intanalysis:true, this
2384 ;; function might not even be called for some of these integrals.
2385 ;; However, this can be palliated by setting intanalysis:false.
2387 (defun zto1 (e ivar ul
)
2388 (when (or (mtimesp e
) (mexptp e
))
2390 (log (list '(%log
) ivar
)))
2393 (find-if #'(lambda (fac)
2394 (powerofx fac log
#'set-m ivar
))
2396 (when (and (freeof ivar m
)
2397 (eq (ask-integer m
'$integer
) '$yes
)
2398 (not (eq ($asksign m
) '$neg
)))
2399 (setq e
(m//t e
(list '(mexpt) log m
)))
2402 (multiple-value-bind (kk s d r cc
)
2404 ;; We have i(x^kk/(d+cc*x^r)^s,x,0,inf) =
2405 ;; beta(aa,bb)/(cc^aa*d^bb*r). Compute this, and then
2406 ;; differentiate it m times to get the log term
2409 (let* ((aa (div (add 1 ivar
) r
))
2411 (m (if (eq ($asksign m
) '$zero
)
2414 (let ((res (div `((%beta
) ,aa
,bb
)
2418 ($at
($diff res ivar m
)
2419 (list '(mequal) ivar kk
)))))))
2421 (multiple-value-bind
2422 (k/n l n b
) (batap-new e ivar ul
)
2424 (let ((beta (ftake* '%beta k
/n l
))
2425 (m (if (eq ($asksign m
) '$zero
) 0 m
)))
2426 ;; The result looks like B(k/n,l) ( ... ).
2427 ;; Perhaps, we should just $factor, instead of
2428 ;; pulling out beta like this.
2434 (m^t
(m-t b
) (m1-t l
))
2435 (m^t ul
(m*t n
(m1-t l
)))
2436 (m^t n
(m-t (m1+t m
)))
2437 ($at
($diff
(m*t
(m^t ul
(m*t n ivar
))
2438 (list '(%beta
) ivar l
))
2440 (list '(mequal) ivar k
/n
)))
2444 ;;; If e is of the form given below, make the obvious change
2445 ;;; of variables (substituting ul*x^(1/n) for x) in order to reduce
2446 ;;; e to the usual form of the integrand in the Eulerian
2447 ;;; integral of the first kind.
2448 ;;; N. B: The old version of ZTO1 completely ignored this
2449 ;;; substitution; the log(x)s were just thrown in, which,
2450 ;;; of course would give wrong results.
2452 (defun batap-new (e ivar ul
)
2454 (multiple-value-bind (k c
)
2457 ;; e=x^k*(a+b*x^n)^l
2458 (destructuring-bind (l a n b
)
2460 (when (and (freeof ivar k
)
2463 (alike1 a
(m-t (m*t b
(m^t ul n
))))
2464 (eq ($asksign b
) '$neg
)
2465 (eq ($asksign
(setq k
(m1+t k
))) '$pos
)
2466 (eq ($asksign
(setq l
(m1+t l
))) '$pos
)
2467 (eq ($asksign n
) '$pos
))
2468 (values (m//t k n
) l n b
))))))
2471 ;; Wang p. 71 gives the following formula for a beta function:
2473 ;; integrate(x^(k-1)/(c*x^r+d)^s,x,0,inf)
2474 ;; = beta(a,b)/(c^a*d^b*r)
2476 ;; where a = k/r > 0, b = s - a > 0, s > k > 0, r > 0, c*d > 0.
2478 ;; This function matches this and returns k-1, d, r, c, a, b. And
2479 ;; also checks that all the conditions hold. If not, NIL is returned.
2481 (defun batap-inf (e ivar
)
2482 (multiple-value-bind (k c
)
2485 (destructuring-bind (l d r cc
)
2487 (let* ((s (mul -
1 l
))
2491 (when (and (freeof ivar k
)
2494 (eq ($asksign kk
) '$pos
)
2495 (eq ($asksign a
) '$pos
)
2496 (eq ($asksign b
) '$pos
)
2497 (eq ($asksign
(sub s k
)) '$pos
)
2498 (eq ($asksign r
) '$pos
)
2499 (eq ($asksign
(mul cc d
)) '$pos
))
2500 (values k s d r cc
)))))))
2503 ;; Handles beta integrals.
2504 (defun batapp (e ivar ll ul
)
2505 (cond ((not (or (equal ll
0)
2507 (setq e
(subin-var (m+ ll ivar
) e ivar
))))
2508 (multiple-value-bind (k c
)
2513 (destructuring-bind (l d al c
)
2515 ;; e = x^k*(d+c*x^al)^l.
2516 (let ((new-k (m// (m+ 1 k
) al
)))
2517 (when (and (ratgreaterp al
0.
)
2518 (eq ($asksign new-k
) '$pos
)
2519 (ratgreaterp (setq l
(m* -
1 l
))
2521 (eq ($asksign
(m* d c
))
2523 (setq l
(m+ l
(m*t -
1 new-k
)))
2524 (m// `((%beta
) ,new-k
,l
)
2525 (mul* al
(m^ c new-k
) (m^ d l
))))))))))
2528 ;; Compute exp(d)*gamma((c+1)/b)/b/a^((c+1)/b). In essence, this is
2529 ;; the value of integrate(x^c*exp(d-a*x^b),x,0,inf).
2530 (defun gamma1 (c a b d
)
2532 (m^
(m* b
(m^ a
(setq c
(m// (m+t c
1) b
)))) -
1)
2535 (defun zto%pi2
(grand ivar
)
2536 (let ((result (unitcir (sratsimp (m// grand ivar
)) ivar
)))
2537 (cond (result (sratsimp (m* (m- '$%i
) result
)))
2540 ;; Evaluates the contour integral of GRAND around the unit circle
2542 (defun unitcir (grand ivar
)
2543 (multiple-value-bind (nn dn
)
2544 (numden-var grand ivar
)
2546 (result (princip (res-var ivar nn dn
2548 ;; Is pt stricly inside the unit circle?
2549 (setq sgn
(let ((limitp nil
))
2550 ($asksign
(m+ -
1 (cabs pt
)))))
2553 (declare (ignore pt
))
2554 ;; Is pt on the unit circle? (Use
2555 ;; the cached value computed
2559 (setq sgn nil
)))))))
2561 (m* '$%pi result
)))))
2564 (defun logx1 (exp ll ul ivar
)
2567 ((and (notinvolve-var exp ivar
'(%sin %cos %tan %atan %asin %acos
))
2568 (setq arg
(involve-var exp ivar
'(%log
))))
2569 (cond ((eq arg ivar
)
2570 (cond ((ratgreaterp 1. ll
)
2571 (cond ((not (eq ul
'$inf
))
2572 (intcv1 (m^t
'$%e
(m- 'yx
)) (m- `((%log
) ,ivar
)) ivar ll ul
))
2573 (t (intcv1 (m^t
'$%e
'yx
) `((%log
) ,ivar
) ivar ll ul
))))))
2574 (t (intcv arg nil ivar ll ul
)))))))
2577 ;; Wang 81-83. Unfortunately, the pdf version has page 82 as all
2578 ;; black, so here is, as best as I can tell, what Wang is doing.
2579 ;; Fortunately, p. 81 has the necessary hints.
2581 ;; First consider integrate(exp(%i*k*x^n),x) around the closed contour
2582 ;; consisting of the real axis from 0 to R, the arc from the angle 0
2583 ;; to %pi/(2*n) and the ray from the arc back to the origin.
2585 ;; There are no poles in this region, so the integral must be zero.
2586 ;; But consider the integral on the three parts. The real axis is the
2587 ;; integral we want. The return ray is
2589 ;; exp(%i*%pi/2/n) * integrate(exp(%i*k*(t*exp(%i*%pi/2/n))^n),t,R,0)
2590 ;; = exp(%i*%pi/2/n) * integrate(exp(%i*k*t^n*exp(%i*%pi/2)),t,R,0)
2591 ;; = -exp(%i*%pi/2/n) * integrate(exp(-k*t^n),t,0,R)
2593 ;; As R -> infinity, this last integral is gamma(1/n)/k^(1/n)/n.
2595 ;; We assume the integral on the circular arc approaches 0 as R ->
2596 ;; infinity. (Need to prove this.)
2600 ;; integrate(exp(%i*k*t^n),t,0,inf)
2601 ;; = exp(%i*%pi/2/n) * gamma(1/n)/k^(1/n)/n.
2603 ;; Equating real and imaginary parts gives us the desired results:
2605 ;; integrate(cos(k*t^n),t,0,inf) = G * cos(%pi/2/n)
2606 ;; integrate(sin(k*t^n),t,0,inf) = G * sin(%pi/2/n)
2608 ;; where G = gamma(1/n)/k^(1/n)/n.
2610 (defun scaxn (e ivar
)
2612 (cond ((atom e
) nil
)
2613 ((and (or (eq (caar e
) '%sin
)
2614 (eq (caar e
) '%cos
))
2616 (setq e
(bx**n
(cadr e
) ivar
)))
2617 ;; Ok, we have cos(b*x^n) or sin(b*x^n), and we set e = (n
2619 (cond ((equal (car e
) 1.
)
2620 ;; n = 1. Give up. (Why not divergent?)
2622 ((zerop (setq s
(let ((sign ($asksign
(cadr e
))))
2623 (cond ((eq sign
'$pos
) 1)
2624 ((eq sign
'$neg
) -
1)
2625 ((eq sign
'$zero
) 0)))))
2626 ;; s is the sign of b. Give up if it's zero.
2628 ((not (eq ($asksign
(m+ -
1 (car e
))) '$pos
))
2629 ;; Give up if n-1 <= 0. (Why give up? Isn't the
2630 ;; integral divergent?)
2633 ;; We can apply our formula now. g = gamma(1/n)/n/b^(1/n)
2634 (setq g
(gamma1 0.
(m* s
(cadr e
)) (car e
) 0.
))
2635 (setq e
(m* g
`((,ind
) ,(m// half%pi
(car e
)))))
2636 (m* (cond ((and (eq ind
'%sin
)
2643 ;; this is the second part of the definite integral package
2645 (defun p*lognxp
(a s ivar
)
2647 (cond ((not (among '%log a
))
2649 ((and (polyinx (setq b
(maxima-substitute 1.
`((%log
) ,ivar
) a
))
2651 (eq ($sign
(m+ s
(m+ 1 (deg-var b ivar
))))
2654 (setq a
(lognxp (sratsimp (m// a b
)) ivar
)))
2657 (defun lognxp (a ivar
)
2658 (cond ((atom a
) nil
)
2659 ((and (eq (caar a
) '%log
)
2664 (lognxp (cadr a
) ivar
))
2667 (defun logcpi0 (n d ivar
)
2668 (prog (polelist dp plm rlm factors pl rl pl1 rl1
)
2670 (polelist-var ivar d
#'upperhalf
#'(lambda (j)
2673 ((equal ($imagpart j
) 0)
2675 (cond ((null polelist
)
2677 (setq factors
(car polelist
)
2678 polelist
(cdr polelist
))
2679 (cond ((or (cadr polelist
)
2681 (setq dp
(sdiff d ivar
))))
2682 (cond ((setq plm
(car polelist
))
2683 (setq rlm
(residue-var ivar
2685 (cond (*leadcoef
* factors
)
2688 (cond ((setq pl
(cadr polelist
))
2689 (setq rl
(res1-var ivar n dp pl
))))
2690 (cond ((setq pl1
(caddr polelist
))
2691 (setq rl1
(res1-var ivar n dp pl1
))))
2696 (list (cond ((setq nn
* (append rl rlm
))
2698 (cond (rl1 (m+l rl1
)))))))
2706 (defun lognx2 (nn dn pl rl
)
2707 (do ((pl pl
(cdr pl
))
2713 (setq ans
(cons (m* dn
(car rl
)
2714 ;; AFAICT, this call to PLOG doesn't need
2716 (m^
`((%plog
) ,(car pl
)) nn
))
2719 (defun logcpj (n d i ivar plm pl rl pl1 rl1
)
2722 (list (mul* (m*t
'$%i %pi2
)
2724 ;; AFAICT, this call to PLOG doesn't need
2725 ;; to bind VAR. An example where this is
2727 ;; integrate(log(x)^2/(1+x^2),x,0,1) =
2730 (m* (m^
`((%plog
) ,ivar
) i
)
2734 (lognx2 i
(m*t
'$%i %pi2
) pl rl
)
2735 (lognx2 i %p%i pl1 rl1
)))
2738 (simplify (m+l n
))))
2740 ;; Handle integral(n(x)/d(x)*log(x)^m,x,0,inf). n and d are
2742 (defun log*rat
(n d m ivar
)
2743 (let ((i-vals (make-array (1+ m
)))
2744 (j-vals (make-array (1+ m
))))
2746 ((logcpi (n d c ivar
)
2749 (m* '((rat) 1 2) (m+ (aref j-vals c
) (m* -
1 (sumi c
))))))
2755 (push (mul* ($makegamma
`((%binomial
) ,c
,k
))
2758 (aref i-vals
(- c k
)))
2760 (setf (aref j-vals
0) 0)
2761 (prog (*leadcoef
* res
)
2762 (dotimes (c m
(return (logcpi n d m ivar
)))
2763 (multiple-value-bind (res plm factors pl rl pl1 rl1
)
2765 (setf (aref i-vals c
) res
)
2766 (setf (aref j-vals c
) (logcpj n factors c ivar plm pl rl pl1 rl1
))))))))
2768 (defun fan (p m a n b
)
2769 (let ((povern (m// p n
))
2772 ((or (eq (ask-integer povern
'$integer
) '$yes
)
2773 (not (equal ($imagpart ab
) 0))) ())
2774 (t (let ((ind ($asksign ab
)))
2775 (cond ((eq ind
'$zero
) nil
)
2776 ((eq ind
'$neg
) nil
)
2777 ((not (ratgreaterp m povern
)) nil
)
2779 ($makegamma
`((%binomial
) ,(m+ -
1 m
(m- povern
))
2781 `((mabs) ,(m^ a
(m+ povern
(m- m
)))))
2784 `((%sin
) ,(m*t
'$%pi povern
)))))))))))
2787 ;;Makes a new poly such that np(x)-np(x+2*%i*%pi)=p(x).
2788 ;;Constructs general POLY of degree one higher than P with
2789 ;;arbitrary coeff. and then solves for coeffs by equating like powers
2790 ;;of the varibale of integration.
2791 ;;Can probably be made simpler now.
2793 (defun makpoly (p ivar
)
2794 (let ((n (deg-var p ivar
)) (ans ()) (varlist ()) (gp ()) (cl ()) (zz ()))
2795 (setq ans
(genpoly (m+ 1 n
) ivar
)) ;Make poly with gensyms of 1 higher deg.
2796 (setq cl
(cdr ans
)) ;Coefficient list
2797 (setq varlist
(append cl
(list ivar
))) ;Make VAR most important.
2798 (setq gp
(car ans
)) ;This is the poly with gensym coeffs.
2799 ;;;Now, poly(x)-poly(x+2*%i*%pi)=p(x), P is the original poly.
2800 (setq ans
(m+ gp
(subin-var (m+t
(m*t
'$%i %pi2
) ivar
) (m- gp
) ivar
) (m- p
)))
2802 (setq ans
(ratrep* ans
)) ;Rational rep with VAR leading.
2803 (setq zz
(coefsolve n cl
(cond ((not (eq (caadr ans
) ;What is Lead Var.
2804 (genfind (car ans
) ivar
)))
2805 (list 0 (cadr ans
))) ;No VAR in ans.
2806 ((cdadr ans
))))) ;The real Poly.
2807 (if (or (null zz
) (null gp
))
2809 ($substitute zz gp
)))) ;Substitute Values for gensyms.
2811 (defun coefsolve (n cl e
)
2813 (eql (ncons (pdis (ptterm e n
))) (cons (pdis (ptterm e m
)) eql
))
2814 (m (m+ n -
1) (m+ m -
1)))
2815 ((signp l m
) (solvex eql cl nil nil
))))
2817 ;; Integrate(p(x)*f(exp(x))/g(exp(x)),x,minf,inf) by applying the
2818 ;; transformation y = exp(x) to get
2819 ;; integrate(p(log(y))*f(y)/g(y)/y,y,0,inf). This should be handled
2821 (defun log-transform (p pe d ivar ul
)
2822 (let ((new-p (subst (list '(%log
) ivar
) ivar p
))
2823 (new-pe (subst ivar
'z
* (catch 'pin%ex
(pin%ex pe ivar
))))
2824 (new-d (subst ivar
'z
* (catch 'pin%ex
(pin%ex d ivar
)))))
2825 (defint (div (div (mul new-p new-pe
) new-d
) ivar
) ivar
0 ul
)))
2827 ;; This implements Wang's algorithm in Chapter 5.2, pp. 98-100.
2829 ;; This is a very brief description of the algorithm. Basically, we
2830 ;; have integrate(R(exp(x))*p(x),x,minf,inf), where R(x) is a rational
2831 ;; function and p(x) is a polynomial.
2833 ;; We find a polynomial q(x) such that q(x) - q(x+2*%i*%pi) = p(x).
2834 ;; Then consider a contour integral of R(exp(z))*q(z) over a
2835 ;; rectangular contour. Opposite corners of the rectangle are (-R,
2836 ;; 2*%i*%pi) and (R, 0).
2838 ;; Wang shows that this contour integral, in the limit, is the
2839 ;; integral of R(exp(x))*q(x)-R(exp(x))*q(x+2*%i*%pi), which is
2840 ;; exactly the integral we're looking for.
2842 ;; Thus, to find the value of the contour integral, we just need the
2843 ;; residues of R(exp(z))*q(z). The only tricky part is that we want
2844 ;; the log function to have an imaginary part between 0 and 2*%pi
2845 ;; instead of -%pi to %pi.
2846 (defun rectzto%pi2
(p pe d ivar
)
2847 ;; We have R(exp(x))*p(x) represented as p(x)*pe(exp(x))/d(exp(x)).
2848 (prog (dp n pl a b c denom-exponential
)
2849 (if (not (and (setq denom-exponential
(catch 'pin%ex
(pin%ex d ivar
)))
2850 (%e-integer-coeff pe ivar
)
2851 (%e-integer-coeff d ivar
)))
2853 ;; At this point denom-exponential has converted d(exp(x)) to the
2854 ;; polynomial d(z), where z = exp(x).
2855 (setq n
(m* (cond ((null p
) -
1)
2856 (t ($expand
(m*t
'$%i %pi2
(makpoly p ivar
)))))
2858 (let ((*leadcoef
* ()))
2859 ;; Find the poles of the denominator. denom-exponential is the
2860 ;; denominator of R(x).
2862 ;; It seems as if polelist returns a list of several items.
2863 ;; The first element is a list consisting of the pole and (z -
2864 ;; pole). We don't care about this, so we take the rest of the
2866 (setq pl
(cdr (polelist-var 'z
* denom-exponential
2868 ;; The imaginary part is nonzero,
2869 ;; or the realpart is negative.
2870 (or (not (equal ($imagpart j
) 0))
2871 (eq ($asksign
($realpart j
)) '$neg
)))
2873 ;; The realpart is not zero.
2874 (not (eq ($asksign
($realpart j
)) '$zero
)))))))
2875 ;; Not sure what this does.
2877 ;; No roots at all, so return
2881 ;; We have simple roots or roots in REGION1
2882 (setq dp
(sdiff d ivar
))))
2884 ;; The cadr of pl is the list of the simple poles of
2885 ;; denom-exponential. Take the log of them to find the
2886 ;; poles of the original expression. Then compute the
2887 ;; residues at each of these poles and sum them up and put
2888 ;; the result in B. (If no simple poles set B to 0.)
2889 (setq b
(mapcar #'log-imag-0-2%pi
(cadr pl
)))
2890 (setq b
(res1-var ivar n dp b
))
2894 ;; I think this handles the case of poles outside the
2895 ;; regions. The sum of these residues are placed in C.
2896 (let ((temp (mapcar #'log-imag-0-2%pi
(caddr pl
))))
2897 (setq c
(append temp
(mapcar #'(lambda (j)
2898 (m+ (m*t
'$%i %pi2
) j
))
2900 (setq c
(res1-var ivar n dp c
))
2904 ;; We have the repeated poles of deonom-exponential, so we
2905 ;; need to convert them to the actual pole values for
2906 ;; R(exp(x)), by taking the log of the value of poles.
2907 (let ((poles (mapcar #'(lambda (p)
2908 (log-imag-0-2%pi
(car p
)))
2910 (exp (m// n
(subst (m^t
'$%e ivar
) 'z
* denom-exponential
))))
2911 ;; Compute the residues at all of these poles and sum
2913 (setq a
(mapcar #'(lambda (j)
2914 ($residue exp ivar j
))
2918 (return (sratsimp (m+ a b
(m* '((rat) 1.
2.
) c
))))))
2920 (defun genpoly (i ivar
)
2921 (do ((i i
(m+ i -
1))
2922 (c (gensym) (gensym))
2926 (cons (m+l ans
) cl
))
2927 (setq ans
(cons (m* c
(m^t ivar i
)) ans
))
2928 (setq cl
(cons c cl
))))
2930 ;; Check to see if each term in exp that is of the form exp(k*x) has
2931 ;; an integer value for k.
2932 (defun %e-integer-coeff
(exp ivar
)
2933 (cond ((mapatom exp
) t
)
2935 (eq (cadr exp
) '$%e
))
2936 (eq (ask-integer ($coeff
(caddr exp
) ivar
) '$integer
)
2938 (t (every #'(lambda (e)
2939 (%e-integer-coeff e ivar
))
2942 (defun wlinearpoly (e ivar
)
2943 (cond ((and (setq e
(polyinx e ivar t
))
2944 (equal (deg-var e ivar
) 1))
2945 (subin-var 1 e ivar
))))
2947 ;; Test to see if exp is of the form f(exp(x)), and if so, replace
2948 ;; exp(x) with 'z*. That is, basically return f(z*).
2949 (defun pin%ex
(exp ivar
)
2950 (pin%ex0
(cond ((notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
2953 (let (($exponentialize t
))
2954 (setq exp
($expand exp
)))))
2957 (defun pin%ex0
(e ivar
)
2958 ;; Does e really need to be special here? Seems to be ok without
2959 ;; it; testsuite works.
2961 (declare (special e
))
2962 (cond ((not (among ivar e
))
2965 (throw 'pin%ex nil
))
2968 (cond ((eq (caddr e
) ivar
)
2970 ((let ((linterm (wlinearpoly (caddr e
) ivar
)))
2972 (m* (subin-var 0 e ivar
) (m^t
'z
* linterm
)))))
2974 (throw 'pin%ex nil
))))
2976 (m*l
(mapcar #'(lambda (ee)
2980 (m+l
(mapcar #'(lambda (ee)
2984 (throw 'pin%ex nil
))))
2986 (defun findsub (p ivar
)
2988 (cond ((findp p ivar
) nil
)
2989 ((setq nd
(bx**n p ivar
))
2990 (m^t ivar
(car nd
)))
2991 ((setq p
(bx**n
+a p ivar
))
2992 (m* (caddr p
) (m^t ivar
(cadr p
)))))))
2994 ;; I think this is looking at f(exp(x)) and tries to find some
2995 ;; rational function R and some number k such that f(exp(x)) =
2997 (defun funclogor%e
(e ivar
)
2998 (prog (ans arg nvar r
)
2999 (cond ((or (ratp e ivar
)
3000 (involve-var e ivar
'(%sin %cos %tan
))
3001 (not (setq arg
(xor (and (setq arg
(involve-var e ivar
'(%log
)))
3003 (%einvolve-var e ivar
)))))
3005 ag
(setq nvar
(cond ((eq r
'%log
) `((%log
) ,arg
))
3006 (t (m^t
'$%e arg
))))
3007 (setq ans
(maxima-substitute (m^t
'yx -
1) (m^t nvar -
1) (maxima-substitute 'yx nvar e
)))
3008 (cond ((not (among ivar ans
)) (return (list (subst ivar
'yx ans
) nvar
)))
3010 (setq arg
(findsub arg ivar
)))
3013 ;; Integration by parts.
3015 ;; integrate(u(x)*diff(v(x),x),x,a,b)
3017 ;; = u(x)*v(x)| - integrate(v(x)*diff(u(x),x))
3020 (defun dintbypart (u v a b ivar
)
3021 ;;;SINCE ONLY CALLED FROM DINTLOG TO get RID OF LOGS - IF LOG REMAINS, QUIT
3022 (let ((ad (antideriv v ivar
)))
3023 (cond ((or (null ad
)
3024 (involve-var ad ivar
'(%log
)))
3026 (t (let ((p1 (m* u ad
))
3027 (p2 (m* ad
(sdiff u ivar
))))
3028 (let ((p1-part1 (get-limit p1 ivar b
'$minus
))
3029 (p1-part2 (get-limit p1 ivar a
'$plus
)))
3030 (cond ((or (null p1-part1
)
3033 (t (let ((p2 (defint p2 ivar a b
)))
3034 (cond (p2 (add* p1-part1
3039 ;; integrate(f(exp(k*x)),x,a,b), where f(z) is rational.
3041 ;; See Wang p. 96-97.
3043 ;; If the limits are minf to inf, we use the substitution y=exp(k*x)
3044 ;; to get integrate(f(y)/y,y,0,inf)/k. If the limits are 0 to inf,
3045 ;; use the substitution s+1=exp(k*x) to get
3046 ;; integrate(f(s+1)/(s+1),s,0,inf).
3047 (defun dintexp (exp ivar ll ul
&aux ans
)
3048 (let ((*dintexp-recur
* t
)) ;recursion stopper
3049 (cond ((and (sinintp exp ivar
) ;To be moved higher in the code.
3050 (setq ans
(antideriv exp ivar
))
3051 (setq ans
(intsubs ans ll ul ivar
)))
3052 ;; If we can integrate it directly, do so and take the
3053 ;; appropriate limits.
3055 ((setq ans
(funclogor%e exp ivar
))
3056 ;; ans is the list (f(x) exp(k*x)).
3057 (cond ((and (equal ll
0.
)
3059 ;; Use the substitution s + 1 = exp(k*x). The
3060 ;; integral becomes integrate(f(s+1)/(s+1),s,0,inf)
3061 (setq ans
(m+t -
1 (cadr ans
))))
3063 ;; Use the substitution y=exp(k*x) because the
3064 ;; limits are minf to inf.
3065 (setq ans
(cadr ans
))))
3066 ;; Apply the substitution and integrate it.
3067 (intcv ans nil ivar ll ul
)))))
3069 ;; integrate(log(g(x))*f(x),x,0,inf)
3070 (defun dintlog (exp arg ivar ll ul
)
3071 (let ((*dintlog-recur
* (1+ *dintlog-recur
*))) ;recursion stopper
3073 (cond ((and (eq ul
'$inf
)
3076 (equal 1 (sratsimp (m// exp
(m* (m- (subin-var (m^t ivar -
1)
3080 ;; Make the substitution y=1/x. If the integrand has
3081 ;; exactly the same form, the answer has to be 0.
3083 ((and (setq ans
(let (($gamma_expand t
)) (logx1 exp ll ul ivar
)))
3086 ((setq ans
(antideriv exp ivar
))
3087 ;; It's easy if we have the antiderivative.
3088 ;; but intsubs sometimes gives results containing %limit
3089 (return (intsubs ans ll ul ivar
))))
3090 ;; Ok, the easy cases didn't work. We now try integration by
3091 ;; parts. Set ANS to f(x).
3092 (setq ans
(m// exp
`((%log
) ,arg
)))
3093 (cond ((involve-var ans ivar
'(%log
))
3094 ;; Bad. f(x) contains a log term, so we give up.
3097 (equal 0.
(no-err-sub-var 0. ans ivar
))
3098 (setq d
(defint (m* ans
(m^t ivar
'*z
*))
3100 ;; The arg of the log function is the same as the
3101 ;; integration variable. We can do something a little
3102 ;; simpler than integration by parts. We have something
3103 ;; like f(x)*log(x). Consider f(x)*x^z. If we
3104 ;; differentiate this wrt to z, the integrand becomes
3105 ;; f(x)*log(x)*x^z. When we evaluate this at z = 0, we
3106 ;; get the desired integrand.
3108 ;; So we need f(0) to be 0 at 0. If we can integrate
3109 ;; f(x)*x^z, then we differentiate the result and
3110 ;; evaluate it at z = 0.
3111 (return (derivat '*z
* 1. d
0.
)))
3112 ((setq ans
(dintbypart `((%log
) ,arg
) ans ll ul ivar
))
3113 ;; Try integration by parts.
3116 ;; Compute diff(e,ivar,n) at the point pt.
3117 (defun derivat (ivar n e pt
)
3118 (subin-var pt
(apply '$diff
(list e ivar n
)) ivar
))
3122 ;; MAYBPC returns (COEF EXPO CONST)
3124 ;; This basically picks off b*x^n+a and returns the list
3126 (defun maybpc (e ivar nd-var
)
3128 (cond (*mtoinf
* (throw 'ggrm
(linpower0 e ivar
)))
3129 ((and (not *mtoinf
*)
3130 (null (setq e
(bx**n
+a e ivar
)))) ;bx**n+a --> (a n b) or nil.
3131 nil
) ;with ivar being x.
3132 ;; At this point, e is of the form (a n b)
3133 ((and (among '$%i
(caddr e
))
3134 (zerop1 ($realpart
(caddr e
)))
3135 (setq zn
($imagpart
(caddr e
)))
3136 (eq ($asksign
(cadr e
)) '$pos
))
3137 ;; If we're here, b is complex, and n > 0. zn = imagpart(b).
3139 ;; Set ivar to the same sign as zn.
3140 (cond ((eq ($asksign zn
) '$neg
)
3144 ;; zd = exp(ivar*%i*%pi*(1+nd)/(2*n). (ZD is special!)
3145 (setq zd
(m^t
'$%e
(m// (mul* ivar
'$%i
'$%pi
(m+t
1 nd-var
))
3147 ;; Return zn, n, a, zd.
3148 (values `(,(caddr e
) ,(cadr e
) ,(car e
)) zd
))
3149 ((and (or (eq (setq ivar
($asksign
($realpart
(caddr e
)))) '$neg
)
3150 (equal ivar
'$zero
))
3151 (equal ($imagpart
(cadr e
)) 0)
3152 (ratgreaterp (cadr e
) 0.
))
3153 ;; We're here if realpart(b) <= 0, and n >= 0. Then return -b, n, a.
3154 `(,(caddr e
) ,(cadr e
) ,(car e
))))))
3156 ;; Integrate x^m*exp(b*x^n+a), with realpart(m) > -1.
3158 ;; See Wang, pp. 84-85.
3160 ;; I believe the formula Wang gives is incorrect. The derivation is
3161 ;; correct except for the last step.
3163 ;; Let J = integrate(x^m*exp(%i*k*x^n),x,0,inf), with real k.
3165 ;; Consider the case for k < 0. Take a sector of a circle bounded by
3166 ;; the real line and the angle -%pi/(2*n), and by the radii, r and R.
3167 ;; Since there are no poles inside this contour, the integral
3169 ;; integrate(z^m*exp(%i*k*z^n),z) = 0
3171 ;; Then J = exp(-%pi*%i*(m+1)/(2*n))*integrate(R^m*exp(k*R^n),R,0,inf)
3173 ;; because the integral along the boundary is zero except for the part
3174 ;; on the real axis. (Proof?)
3176 ;; Wang seems to say this last integral is gamma(s/n/(-k)^s) where s =
3177 ;; (m+1)/n. But that seems wrong. If we use the substitution R =
3178 ;; (y/(-k))^(1/n), we end up with the result:
3180 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n).
3182 ;; or gamma((m+1)/n)/k^((m+1)/n)/n.
3184 ;; Note that this also handles the case of
3186 ;; integrate(x^m*exp(-k*x^n),x,0,inf);
3188 ;; where k is positive real number. A simple change of variables,
3191 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n))
3193 ;; which is the same form above.
3194 (defun ggr (e ind ivar
)
3195 (prog (c zd nn
* dn
* nd-var dosimp $%emode
)
3197 (cond (ind (setq e
($expand e
))
3198 (cond ((and (mplusp e
)
3199 (let ((*nodiverg
* t
))
3200 (setq e
(catch 'divergent
3205 (cond ((eq e
'divergent
) nil
)
3206 (t (return (sratsimp (cons '(mplus) e
)))))))))
3207 (setq e
(rmconst1 e ivar
))
3210 (cond ((multiple-value-setq (e zd
)
3211 (ggr1 e ivar nd-var
))
3212 ;; e = (m b n a). That is, the integral is of the form
3213 ;; x^m*exp(b*x^n+a). I think we want to compute
3214 ;; gamma((m+1)/n)/b^((m+1)/n)/n.
3216 ;; FIXME: If n > m + 1, the integral converges. We need
3217 ;; to check for this.
3218 (destructuring-bind (m b n a
)
3220 (when (and (not (zerop1 ($realpart b
)))
3221 (not (zerop1 ($imagpart b
))))
3222 ;; The derivation only holds if b is purely real or
3223 ;; purely imaginary. Give up if it's not.
3225 ;; Check for convergence. If b is complex, we need n -
3226 ;; m > 1. If b is real, we need b < 0.
3227 (when (and (zerop1 ($imagpart b
))
3228 (not (eq ($asksign b
) '$neg
)))
3230 (when (and (not (zerop1 ($imagpart b
)))
3231 (not (eq ($asksign
(sub n
(add m
1))) '$pos
)))
3234 (setq e
(gamma1 m
(cond ((zerop1 ($imagpart b
))
3235 ;; If we're here, b must be negative.
3238 ;; Complex b. Take the imaginary part
3239 `((mabs) ,($imagpart b
))))
3242 ;; FIXME: Why do we set %emode here? Shouldn't we just
3243 ;; bind it? And why do we want it bound to T anyway?
3244 ;; Shouldn't the user control that? The same goes for
3248 (setq e
(m* zd e
))))))
3249 (cond (e (return (m* c e
))))))
3252 ;; Match x^m*exp(b*x^n+a). If it does, return (list m b n a).
3253 (defun ggr1 (e ivar nd-var
)
3255 (cond ((atom e
) nil
)
3258 ;; We're looking at something like exp(f(ivar)). See if it's
3259 ;; of the form b*x^n+a, and return (list 0 b n a). (The 0 is
3260 ;; so we can graft something onto it if needed.)
3261 (cond ((multiple-value-setq (e zd
)
3262 (maybpc (caddr e
) ivar nd-var
))
3263 (values (cons 0. e
) zd
))))
3265 ;; E should be the product of exactly 2 terms
3267 ;; Check to see if one of the terms is of the form
3268 ;; ivar^p. If so, make sure the realpart of p > -1. If
3269 ;; so, check the other term has the right form via
3270 ;; another call to ggr1.
3271 (or (and (setq dn
* (xtorterm (cadr e
) ivar
))
3272 (ratgreaterp (setq nd-var
($realpart dn
*))
3274 (multiple-value-setq (nn* zd
)
3275 (ggr1 (caddr e
) ivar nd-var
)))
3276 (and (setq dn
* (xtorterm (caddr e
) ivar
))
3277 (ratgreaterp (setq nd-var
($realpart dn
*))
3279 (multiple-value-setq (nn* zd
)
3280 (ggr1 (cadr e
) ivar nd-var
)))))
3281 ;; Both terms have the right form and nn* contains the ivar of
3282 ;; the exponential term. Put dn* as the car of nn*. The
3283 ;; result is something like (m b n a) when we have the
3284 ;; expression x^m*exp(b*x^n+a).
3285 (values (rplaca nn
* dn
*) zd
)))))
3288 ;; Match b*x^n+a. If a match is found, return the list (a n b).
3289 ;; Otherwise, return NIL
3290 (defun bx**n
+a
(e ivar
)
3295 (t (let ((a (no-err-sub-var 0. e ivar
)))
3297 (t (setq e
(m+ e
(m*t -
1 a
)))
3298 (cond ((setq e
(bx**n e ivar
))
3302 ;; Match b*x^n. Return the list (n b) if found or NIL if not.
3303 (defun bx**n
(e ivar
)
3305 (and (setq n
(xexponget e ivar
))
3307 (setq e
(let (($maxposex
1)
3309 ($expand
(m// e
(m^t ivar n
)))))))
3312 ;; nn* should be the value of var. This is only called by bx**n with
3313 ;; the second arg of var.
3314 (defun xexponget (e nn
*)
3315 (cond ((atom e
) (cond ((eq e nn
*) 1.
)))
3319 (not (among nn
* (caddr e
))))
3321 (t (some #'(lambda (j) (xexponget j nn
*)) (cdr e
)))))
3324 ;;; given (b*x^n+a)^m returns (m a n b)
3325 (defun bxm (e ind ivar
)
3329 (involve-var e ivar
'(%log %sin %cos %tan
))
3330 (%einvolve-var e ivar
))
3333 ((mexptp e
) (cond ((among ivar
(caddr e
)) nil
)
3334 ((setq r
(bx**n
+a
(cadr e
) ivar
))
3335 (cons (caddr e
) r
))))
3336 ((setq r
(bx**n
+a e ivar
)) (cons 1. r
))
3338 ;;;Catches Unfactored forms.
3339 (multiple-value-bind (m r
)
3340 (numden-var (m// (sdiff e ivar
) e
)
3343 ((and (setq r
(bx**n
+a
(sratsimp r
) ivar
))
3344 (not (among ivar
(setq m
(m// m
(m* (cadr r
) (caddr r
)
3345 (m^t ivar
(m+t -
1 (cadr r
))))))))
3346 (setq e
(m// (subin-var 0. e ivar
) (m^t
(car r
) m
))))
3349 (t (setq e
(m^ e
(m// 1. m
)))
3350 (list m
(m* e
(car r
)) (cadr r
)
3351 (m* e
(caddr r
)))))))))
3354 ;;;Is E = VAR raised to some power? If so return power or 0.
3355 (defun findp (e ivar
)
3356 (cond ((not (among ivar e
)) 0.
)
3357 (t (xtorterm e ivar
))))
3359 (defun xtorterm (e ivar
)
3360 ;;;Is E = VAR1 raised to some power? If so return power.
3361 (cond ((alike1 e ivar
) 1.
)
3364 (alike1 (cadr e
) ivar
)
3365 (not (among ivar
(caddr e
))))
3369 (m^
(m* (m^
(caddr l
) '((rat) 1 2))
3370 (m+ (cadr l
) (m^
(m* (car l
) (caddr l
))
3374 (defun radbyterm (d l ivar
)
3379 (destructuring-let (((const . integrand
) (rmconst1 (car l
) ivar
)))
3380 (setq ans
(cons (m* const
(dintrad0 integrand d ivar
))
3383 (defun sqdtc (e ind ivar
)
3384 (prog (a b c varlist
)
3385 (setq varlist
(list ivar
))
3387 (setq e
(cdadr (ratrep* e
)))
3388 (setq c
(pdis (ptterm e
0)))
3389 (setq b
(m*t
(m//t
1 2) (pdis (ptterm e
1))))
3390 (setq a
(pdis (ptterm e
2)))
3391 (cond ((and (eq ($asksign
(m+ b
(m^
(m* a c
)
3395 (not (eq ($asksign a
) '$neg
))
3396 (eq ($asksign c
) '$pos
))
3397 (and (eq ($asksign a
) '$pos
)
3398 (not (eq ($asksign c
) '$neg
)))))
3399 (return (list a b c
))))))
3401 (defun difap1 (e pwr ivar m pt
)
3402 (m// (mul* (cond ((eq (ask-integer m
'$even
) '$yes
)
3406 (derivat ivar m e pt
))
3407 `((%gamma
) ,(m+ pwr m
))))
3409 ;; Note: This doesn't seem be called from anywhere.
3410 (defun sqrtinvolve (e ivar
)
3411 (cond ((atom e
) nil
)
3414 (and (mnump (caddr e
))
3415 (not (numberp (caddr e
)))
3416 (equal (caddr (caddr e
)) 2.
))
3417 (among ivar
(cadr e
)))
3419 (t (some #'(lambda (a)
3420 (sqrtinvolve a ivar
))
3423 (defun bydif (r s d ivar
)
3425 (setq d
(m+ (m*t
'*z
* ivar
) d
))
3426 (cond ((or (zerop1 (setq p
(m+ s
(m*t -
1 r
))))
3427 (and (zerop1 (m+ 1 p
))
3429 (difap1 (dintrad0 b
(m^ d
'((rat) 3 2)) ivar
)
3430 '((rat) 3 2) '*z
* r
0))
3431 ((eq ($asksign p
) '$pos
)
3432 (difap1 (difap1 (dintrad0 1 (m^
(m+t
'z
** d
)
3435 '((rat) 3 2) '*z
* r
0)
3436 '((rat) 3 2) 'z
** p
0)))))
3438 (defun dintrad0 (n d ivar
)
3440 (cond ((and (mexptp d
)
3441 (equal (deg-var (cadr d
) ivar
) 2.
))
3442 (cond ((alike1 (caddr d
) '((rat) 3.
2.
))
3443 (cond ((and (equal n
1.
)
3444 (setq l
(sqdtc (cadr d
) t ivar
)))
3447 (setq l
(sqdtc (cadr d
) nil ivar
)))
3448 (tbf (reverse l
)))))
3449 ((and (setq r
(findp n ivar
))
3450 (or (eq ($asksign
(m+ -
1.
(m- r
) (m*t
2.
3454 (setq s
(m+ '((rat) -
3.
2.
) (caddr d
)))
3455 (eq ($asksign s
) '$pos
)
3456 (eq (ask-integer s
'$integer
) '$yes
))
3457 (bydif r s
(cadr d
) ivar
))
3458 ((polyinx n ivar nil
)
3459 (radbyterm d
(cdr n
) ivar
)))))))
3462 ;;;Looks at the IMAGINARY part of a log and puts it in the interval 0 2*%pi.
3463 (defun log-imag-0-2%pi
(x)
3464 (let ((plog (simplify ($rectform
`((%plog
) ,x
)))))
3465 ;; We take the $rectform above to make sure that the log is
3466 ;; expanded out for the situations where simplifying plog itself
3467 ;; doesn't do it. This should probably be considered a bug in the
3468 ;; plog simplifier and should be fixed there.
3469 (cond ((not (free plog
'%plog
))
3470 (subst '%log
'%plog plog
))
3472 (destructuring-let (((real . imag
) (trisplit plog
)))
3473 (cond ((eq ($asksign imag
) '$neg
)
3474 (setq imag
(m+ imag %pi2
)))
3475 ((eq ($asksign
(m- imag %pi2
)) '$pos
)
3476 (setq imag
(m- imag %pi2
)))
3478 (m+ real
(m* '$%i imag
)))))))
3481 ;;; Temporary fix for a lacking in taylor, which loses with %i in denom.
3482 ;;; Besides doesn't seem like a bad thing to do in general.
3483 (defun %i-out-of-denom
(exp)
3484 (let ((denom ($denom exp
)))
3485 (cond ((among '$%i denom
)
3486 ;; Multiply the denominator by it's conjugate to get rid of
3488 (let* ((den-conj (maxima-substitute (m- '$%i
) '$%i denom
))
3490 (new-denom (sratsimp (m* denom den-conj
)))
3491 (new-exp (sratsimp (m// (m* num den-conj
) new-denom
))))
3492 ;; If the new denominator still contains %i, just give up.
3493 (if (among '$%i
($denom new-exp
))
3498 ;;; LL and UL must be real otherwise this routine return $UNKNOWN.
3499 ;;; Returns $no $unknown or a list of poles in the interval (ll ul)
3500 ;;; for exp w.r.t. ivar.
3501 ;;; Form of list ((pole . multiplicity) (pole1 . multiplicity) ....)
3502 (defun poles-in-interval (exp ivar ll ul
)
3503 (let* ((denom (cond ((mplusp exp
)
3504 ($denom
(sratsimp exp
)))
3506 (free (caddr exp
) ivar
)
3507 (eq ($asksign
(caddr exp
)) '$neg
))
3508 (m^
(cadr exp
) (m- (caddr exp
))))
3510 (roots (real-roots denom ivar
))
3511 (ll-pole (limit-pole exp ivar ll
'$plus
))
3512 (ul-pole (limit-pole exp ivar ul
'$minus
)))
3513 (cond ((or (eq roots
'$failure
)
3515 (null ul-pole
)) '$unknown
)
3516 ((and (or (eq roots
'$no
)
3517 (member ($csign denom
) '($pos $neg $pn
)))
3518 ;; this clause handles cases where we can't find the exact roots,
3519 ;; but we know that they occur outside the interval of integration.
3520 ;; example: integrate ((1+exp(t))/sqrt(t+exp(t)), t, 0, 1);
3522 (eq ul-pole
'$no
)) '$no
)
3523 (t (cond ((equal roots
'$no
)
3525 (do ((dummy roots
(cdr dummy
))
3526 (pole-list (cond ((not (eq ll-pole
'$no
))
3530 (cond ((not (eq ul-pole
'$no
))
3531 (sort-poles (push `(,ul .
1) pole-list
)))
3532 ((not (null pole-list
))
3533 (sort-poles pole-list
))
3535 (let* ((soltn (caar dummy
))
3536 ;; (multiplicity (cdar dummy)) (not used? -- cwh)
3537 (root-in-ll-ul (in-interval soltn ll ul
)))
3538 (cond ((eq root-in-ll-ul
'$no
) '$no
)
3539 ((eq root-in-ll-ul
'$yes
)
3540 (let ((lim-ans (is-a-pole exp soltn ivar
)))
3541 (cond ((null lim-ans
)
3545 (t (push (car dummy
)
3546 pole-list
))))))))))))
3549 ;;;Returns $YES if there is no pole and $NO if there is one.
3550 (defun limit-pole (exp ivar limit direction
)
3551 (let ((ans (cond ((member limit
'($minf $inf
) :test
#'eq
)
3552 (cond ((eq (special-convergent-formp exp limit ivar
) '$yes
)
3554 (t (get-limit (m* exp ivar
) ivar limit direction
))))
3556 (cond ((eq ans
'$no
) '$no
)
3558 ((eq ans
'$und
) '$no
)
3559 ((equal ans
0.
) '$no
)
3562 ;;;Takes care of forms that the ratio test fails on.
3563 (defun special-convergent-formp (exp limit ivar
)
3564 (cond ((not (oscip-var exp ivar
)) '$no
)
3565 ((or (eq (sc-converg-form exp limit ivar
) '$yes
)
3566 (eq (exp-converg-form exp limit ivar
) '$yes
))
3570 (defun exp-converg-form (exp limit ivar
)
3572 (setq exparg
(%einvolve-var exp ivar
))
3573 (cond ((or (null exparg
)
3574 (freeof '$%i exparg
))
3580 (sratsimp (m// exp
(m^t
'$%e exparg
))))
3582 (equal (get-limit exp ivar limit
) 0))
3586 (defun sc-converg-form (exp limit ivar
)
3587 (prog (scarg trigpow
)
3588 (setq exp
($expand exp
))
3589 (setq scarg
(involve-var (sin-sq-cos-sq-sub exp
) ivar
'(%sin %cos
)))
3590 (cond ((null scarg
) (return '$no
))
3591 ((and (polyinx scarg ivar
())
3592 (eq ($asksign
(m- ($hipow scarg ivar
) 1)) '$pos
))
3594 ((not (freeof ivar
(sdiff scarg ivar
)))
3596 ((and (setq trigpow
($hipow exp
`((%sin
) ,scarg
)))
3597 (eq (ask-integer trigpow
'$odd
) '$yes
)
3598 (equal (get-limit (m// exp
`((%sin
) ,scarg
)) ivar limit
)
3601 ((and (setq trigpow
($hipow exp
`((%cos
) ,scarg
)))
3602 (eq (ask-integer trigpow
'$odd
) '$yes
)
3603 (equal (get-limit (m// exp
`((%cos
) ,scarg
)) ivar limit
)
3606 (t (return '$no
)))))
3608 (defun is-a-pole (exp soltn ivar
)
3610 (m* (maxima-substitute (m+ 'epsilon soltn
) ivar exp
)
3614 (defun in-interval (place ll ul
)
3615 ;; real values for ll and ul; place can be imaginary.
3616 (let ((order (ask-greateq ul ll
)))
3617 (cond ((eq order
'$yes
))
3618 ((eq order
'$no
) (let ((temp ul
)) (setq ul ll ll temp
)))
3619 (t (merror (intl:gettext
"defint: failed to order limits of integration:~%~M")
3620 (list '(mlist simp
) ll ul
)))))
3621 (if (not (equal ($imagpart place
) 0))
3623 (let ((lesseq-ul (ask-greateq ul place
))
3624 (greateq-ll (ask-greateq place ll
)))
3625 (if (and (eq lesseq-ul
'$yes
) (eq greateq-ll
'$yes
)) '$yes
'$no
))))
3627 ;; returns true or nil
3628 (defun strictly-in-interval (place ll ul
)
3629 ;; real values for ll and ul; place can be imaginary.
3630 (and (equal ($imagpart place
) 0)
3632 (eq ($asksign
(m+ ul
(m- place
))) '$pos
))
3634 (eq ($asksign
(m+ place
(m- ll
))) '$pos
))))
3636 (defun real-roots (exp ivar
)
3637 (let (($solvetrigwarn
(cond (*defintdebug
* t
) ;Rest of the code for
3638 (t ()))) ;TRIGS in denom needed.
3639 ($solveradcan
(cond ((or (among '$%i exp
)
3640 (among '$%e exp
)) t
)
3642 *roots
*failures
) ;special vars for solve.
3643 (cond ((not (among ivar exp
)) '$no
)
3644 (t (solve exp ivar
1)
3645 ;; If *failures is set, we may have missed some roots.
3646 ;; We still return the roots that we have found.
3647 (do ((dummy *roots
(cddr dummy
))
3650 (cond ((not (null rootlist
))
3653 (cond ((equal ($imagpart
(caddar dummy
)) 0)
3656 ($rectform
(caddar dummy
))
3660 (defun ask-greateq (x y
)
3661 ;;; Is x > y. X or Y can be $MINF or $INF, zeroA or zeroB.
3662 (let ((x (cond ((among 'zeroa x
)
3667 (subst 0 'epsilon x
))
3668 ((or (among '$inf x
)
3672 (y (cond ((among 'zeroa y
)
3677 (subst 0 'epsilon y
))
3678 ((or (among '$inf y
)
3690 (t (let ((ans ($asksign
(m+ x
(m- y
)))))
3691 (cond ((member ans
'($zero $pos
) :test
#'eq
)
3697 (defun sort-poles (pole-list)
3698 (sort pole-list
#'(lambda (x y
)
3699 (cond ((eq (ask-greateq (car x
) (car y
))
3704 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3706 ;;; Integrate Definite Integrals involving log and exp functions. The algorithm
3707 ;;; are taken from the paper "Evaluation of CLasses of Definite Integrals ..."
3708 ;;; by K.O.Geddes et. al.
3710 ;;; 1. CASE: Integrals generated by the Gamma function.
3715 ;;; I t log (t) expt(- t ) dt = s signum(s)
3722 ;;; (--- (gamma(z))! )
3728 ;;; The integral converges for:
3729 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3731 ;;; 2. CASE: Integrals generated by the Incomplete Gamma function.
3736 ;;; I t log (t) exp(- t ) dt = (--- (gamma_incomplete(a, x ))! )
3744 ;;; The integral converges for:
3745 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3746 ;;; The shown solution is valid for s>0. For s<0 gamma_incomplete has to be
3747 ;;; replaced by gamma(a) - gamma_incomplete(a,x^s).
3749 ;;; 3. CASE: Integrals generated by the beta function.
3754 ;;; I log (1 - t) (1 - t) t log (t) dt =
3762 ;;; --- (--- (beta(z, w))! )!
3768 ;;; The integral converges for:
3769 ;;; n, m = 0, 1, 2, ..., s > -1 and r > -1.
3770 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3772 (defvar *debug-defint-log
* nil
)
3774 ;;; Recognize c*z^w*log(z)^m*exp(-t^s)
3776 (defun m2-log-exp-1 (expr ivar
)
3777 (when *debug-defint-log
*
3778 (format t
"~&M2-LOG-EXP-1 with ~A~%" expr
))
3782 ((mexpt) (z varp2
,ivar
) (w freevar2
,ivar
))
3783 ((mexpt) $%e
((mtimes) -
1 ((mexpt) (z varp2
,ivar
) (s freevar02
,ivar
))))
3784 ((mexpt) ((%log
) (z varp2
,ivar
)) (m freevar2
,ivar
)))))
3786 ;;; Recognize c*z^r*log(z)^n*(1-z)^s*log(1-z)^m
3788 (defun m2-log-exp-2 (expr ivar
)
3789 (when *debug-defint-log
*
3790 (format t
"~&M2-LOG-EXP-2 with ~A~%" expr
))
3794 ((mexpt) (z varp2
,ivar
) (r freevar2
,ivar
))
3795 ((mexpt) ((%log
) (z varp2
,ivar
)) (n freevar2
,ivar
))
3796 ((mexpt) ((mplus) 1 ((mtimes) -
1 (z varp2
,ivar
))) (s freevar2
,ivar
))
3797 ((mexpt) ((%log
) ((mplus) 1 ((mtimes)-
1 (z varp2
,ivar
)))) (m freevar2
,ivar
)))))
3799 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3801 (defun defint-log-exp (expr ivar ll ul
)
3806 ;; var1 is used as a parameter for differentiation. Add var1>0 to the
3807 ;; database, to get the desired simplification of the differentiation of
3808 ;; the gamma_incomplete function.
3809 (setq *global-defint-assumptions
*
3810 (cons (assume `((mgreaterp) ,var1
0))
3811 *global-defint-assumptions
*))
3815 (setq x
(m2-log-exp-1 expr ivar
)))
3816 ;; The integrand matches the cases 1 and 2.
3817 (let ((c (cdras 'c x
))
3821 ($gamma_expand nil
)) ; No expansion of Gamma functions.
3823 (when *debug-defint-log
*
3824 (format t
"~&DEFINT-LOG-EXP-1:~%")
3825 (format t
"~& : c = ~A~%" c
)
3826 (format t
"~& : w = ~A~%" w
)
3827 (format t
"~& : m = ~A~%" m
)
3828 (format t
"~& : s = ~A~%" s
))
3830 (cond ((and (zerop1 ll
)
3833 (not (eq ($sign s
) '$zero
))
3834 (eq ($sign
(div (add w
1) s
)) '$pos
))
3835 ;; Case 1: Generated by the Gamma function.
3838 (simplify (list '(%signum
) s
))
3839 (power s
(mul -
1 (add m
1)))
3840 ($at
($diff
(list '(%gamma
) var1
) var1 m
)
3843 (div (add w
1) s
))))))
3844 ((and (member ($sign ll
) '($pos $pz
))
3846 (or (= m
0) (= m
1)) ; Exclude m>1, because Maxima can not
3847 ; derivate the involved hypergeometric
3849 (or (and (eq ($sign s
) '$neg
)
3850 (eq ($sign
(div (add 1 w
) s
)) '$pos
))
3851 (and (eq ($sign s
) '$pos
)
3852 (eq ($sign
(div (add 1 w
) s
)) '$pos
))))
3853 ;; Case 2: Generated by the Incomplete Gamma function.
3854 (let ((f (if (eq ($sign s
) '$pos
)
3855 (list '(%gamma_incomplete
) var1
(power ll s
))
3856 (sub (list '(%gamma
) var1
)
3857 (list '(%gamma_incomplete
) var1
(power ll s
))))))
3860 (simplify (list '(%signum
) s
))
3861 (power s
(mul -
1 (add m
1)))
3862 ($at
($diff f var1 m
)
3863 (list '(mequal) var1
(div (add 1 w
) s
)))))))
3865 (setq result nil
)))))
3868 (setq x
(m2-log-exp-2 expr ivar
)))
3869 ;; Case 3: Generated by the Beta function.
3870 (let ((c (cdras 'c x
))
3878 (when *debug-defint-log
*
3879 (format t
"~&DEFINT-LOG-EXP-2:~%")
3880 (format t
"~& : c = ~A~%" c
)
3881 (format t
"~& : r = ~A~%" r
)
3882 (format t
"~& : n = ~A~%" n
)
3883 (format t
"~& : s = ~A~%" s
)
3884 (format t
"~& : m = ~A~%" m
))
3886 (cond ((and (integerp m
)
3890 (eq ($sign
(add 1 r
)) '$pos
)
3891 (eq ($sign
(add 1 s
)) '$pos
))
3894 ($at
($diff
($at
($diff
(list '(%beta
) var1 var2
)
3896 (list '(mequal) var2
(add 1 s
)))
3898 (list '(mequal) var1
(add 1 r
))))))
3900 (setq result nil
)))))
3903 ;; Simplify result and set $gamma_expand to global value
3904 (let (($gamma_expand $gamma_expand
)) (sratsimp result
))))
3906 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;