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 *def2
* pcprntd
*mtoinf
*
129 *ul1
* *ll1
* *dflag bptu bptd zn
133 *sin-cos-recur
* *rad-poly-recur
* *dintlog-recur
*
134 *dintexp-recur
* defintdebug
*defint-assumptions
*
135 *current-assumptions
*
136 *global-defint-assumptions
*)
137 ;;;rsn* is in comdenom. does a ratsimp of numerator.
139 (special $intanalysis $noprincipal
)
141 (special *roots
*failures
143 ;;LIMITP T Causes $ASKSIGN to do special things
144 ;;For DEFINT like eliminate epsilon look for prin-inf
145 ;;take realpart and imagpart.
147 ;;If LIMITP is non-null ask-integer conses
148 ;;its assumptions onto this list.
151 (defvar *loopstop
* 0)
153 (defmvar $intanalysis t
154 "When @code{true}, definite integration tries to find poles in the integrand
155 in the interval of integration.")
157 (defmvar defintdebug
() "If true Defint prints out debugging information")
159 (defmfun $defint
(exp ivar
*ll
* *ul
*)
161 ;; Distribute $defint over equations, lists, and matrices.
166 (mapcar #'(lambda (e)
167 (simplify ($defint e ivar
*ll
* *ul
*)))
170 (let ((*global-defint-assumptions
* ())
171 (integer-info ()) (integerl integerl
) (nonintegerl nonintegerl
))
172 (with-new-context (context)
174 (let ((*defint-assumptions
* ()) (*def2
* ()) (*rad-poly-recur
* ())
175 (*sin-cos-recur
* ()) (*dintexp-recur
* ()) (*dintlog-recur
* 0.
)
176 (ans nil
) (orig-exp exp
) (orig-var ivar
)
177 (orig-ll *ll
*) (orig-ul *ul
*)
178 (pcprntd nil
) (*nodiverg nil
) ($logabs t
) ; (limitp t)
180 ($%edispflag nil
) ; to get internal representation
181 ($m1pbranch
())) ;Try this out.
183 (make-global-assumptions) ;sets *global-defint-assumptions*
184 (setq exp
(ratdisrep exp
))
185 (setq ivar
(ratdisrep ivar
))
186 (setq *ll
* (ratdisrep *ll
*))
187 (setq *ul
* (ratdisrep *ul
*))
188 (cond (($constantp ivar
)
189 (merror (intl:gettext
"defint: variable of integration cannot be a constant; found ~M") ivar
))
190 (($subvarp ivar
) (setq ivar
(gensym))
191 (setq exp
($substitute ivar orig-var exp
))))
192 (cond ((not (atom ivar
))
193 (merror (intl:gettext
"defint: variable of integration must be a simple or subscripted variable.~%defint: found ~M") ivar
))
194 ((or (among ivar
*ul
*)
197 (setq exp
($substitute ivar orig-var exp
))))
198 (unless (lenient-extended-realp *ll
*)
199 (merror (intl:gettext
"defint: lower limit of integration must be real; found ~M") *ll
*))
200 (unless (lenient-extended-realp *ul
*)
201 (merror (intl:gettext
"defint: upper limit of integration must be real; found ~M") *ul
*))
203 (cond ((setq ans
(defint exp ivar
*ll
* *ul
*))
204 (setq ans
(subst orig-var ivar ans
))
205 (cond ((atom ans
) ans
)
206 ((and (free ans
'%limit
)
207 (free ans
'%integrate
)
208 (or (not (free ans
'$inf
))
209 (not (free ans
'$minf
))
210 (not (free ans
'$infinity
))))
212 ((not (free ans
'$und
))
213 `((%integrate
) ,orig-exp
,orig-var
,orig-ll
,orig-ul
))
215 (t `((%integrate
) ,orig-exp
,orig-var
,orig-ll
,orig-ul
))))
216 (forget-global-assumptions)))))
218 (defun eezz (exp *ll
* *ul
* ivar
)
219 (cond ((or (polyinx exp ivar nil
)
220 (catch 'pin%ex
(pin%ex exp ivar
)))
221 (setq exp
(antideriv exp ivar
))
222 ;; If antideriv can't do it, returns nil
223 ;; use limit to evaluate every answer returned by antideriv.
224 (cond ((null exp
) nil
)
225 (t (intsubs exp
*ll
* *ul
* ivar
))))))
227 ;;;Hack the expression up for exponentials.
229 (defun sinintp (expr ivar
)
230 ;; Is this expr a candidate for SININT ?
231 (let ((expr (factor expr
))
234 (setq numer
($num expr
))
235 (setq denom
($denom expr
))
236 (cond ((polyinx numer ivar nil
)
237 (cond ((and (polyinx denom ivar nil
)
238 (deg-lessp denom ivar
2))
240 ;;ERF type things go here.
241 ((let ((exponent (%einvolve-var numer ivar
)))
242 (and (polyinx exponent ivar nil
)
243 (deg-lessp exponent ivar
2)))
244 (cond ((free denom ivar
)
247 (defun deg-lessp (expr ivar power
)
248 (cond ((or (atom expr
)
252 (do ((ops (cdr expr
) (cdr ops
)))
254 (cond ((not (deg-lessp (car ops
) ivar power
))
257 (and (or (not (alike1 (cadr expr
) ivar
))
258 (and (numberp (caddr expr
))
259 (not (eq (asksign (m+ power
(m- (caddr expr
))))
261 (deg-lessp (cadr expr
) ivar power
)))
263 (member 'array
(car expr
))
264 (not (eq ivar
(caar expr
))))
265 ;; We have some subscripted variable that's not our variable
266 ;; (I think), so it's deg-lessp.
268 ;; FIXME: Is this the best way to handle this? Are there
269 ;; other cases we're mising here?
272 (defun antideriv (a ivar
)
276 (setq ans
(sinint a ivar
))
277 (cond ((among '%integrate ans
) nil
)
278 (t (simplify ans
)))))
280 ;; This routine tries to take a limit a couple of ways.
281 (defun get-limit (exp ivar val
&optional
(dir '$plus dir?
))
283 (funcall #'limit-no-err exp ivar val dir
)
284 (funcall #'limit-no-err exp ivar val
))))
285 (if (and ans
(not (among '%limit ans
)))
287 (when (member val
'($inf $minf
) :test
#'eq
)
288 (setq ans
(limit-no-err (maxima-substitute (m^t ivar -
1) ivar exp
)
291 (if (eq val
'$inf
) '$plus
'$minus
)))
292 (if (among '%limit ans
) nil ans
)))))
294 (defun limit-no-err (&rest argvec
)
295 (let ((errorsw t
) (ans nil
))
296 (setq ans
(catch 'errorsw
(apply #'$limit argvec
)))
297 (if (eq ans t
) nil ans
)))
299 ;; Test whether fun2 is inverse of fun1 at val.
300 (defun test-inverse (fun1 var1 fun2 var2 val
)
301 (let* ((out1 (no-err-sub-var val fun1 var1
))
302 (out2 (no-err-sub-var out1 fun2 var2
)))
305 ;; integration change of variable
306 (defun intcv (nv flag ivar
)
307 (let ((d (bx**n
+a nv ivar
))
308 (*roots
()) (*failures
()) ($breakup
()))
309 (cond ((and (eq *ul
* '$inf
)
311 (equal (cadr d
) 1)) ())
312 ((eq ivar
'yx
) ; new ivar cannot be same as old ivar
315 ;; This is a hack! If nv is of the form b*x^n+a, we can
316 ;; solve the equation manually instead of using solve.
317 ;; Why? Because solve asks us for the sign of yx and
320 ;; Solve yx = b*x^n+a, for x. Any root will do. So we
321 ;; have x = ((yx-a)/b)^(1/n).
322 (destructuring-bind (a n b
)
324 (let ((root (power* (div (sub 'yx a
) b
) (inv n
))))
327 (cond (flag (intcv2 d nv ivar
))
328 (t (intcv1 d nv ivar
))))
331 (putprop 'yx t
'internal
);; keep ivar from appearing in questions to user
332 (solve (m+t
'yx
(m*t -
1 nv
)) ivar
1.
)
333 (cond ((setq d
;; look for root that is inverse of nv
334 (do* ((roots *roots
(cddr roots
))
335 (root (caddar roots
) (caddar roots
)))
337 (if (and (or (real-infinityp *ll
*)
338 (test-inverse nv ivar root
'yx
*ll
*))
339 (or (real-infinityp *ul
*)
340 (test-inverse nv ivar root
'yx
*ul
*)))
342 (cond (flag (intcv2 d nv ivar
))
343 (t (intcv1 d nv ivar
))))
346 ;; d: original variable (ivar) as a function of 'yx
348 ;; nv: new variable ('yx) as a function of original variable (ivar)
349 (defun intcv1 (d nv ivar
)
350 (cond ((and (intcv2 d nv ivar
)
351 (equal ($imagpart
*ll1
*) 0)
352 (equal ($imagpart
*ul1
*) 0)
353 (not (alike1 *ll1
* *ul1
*)))
355 (defint exp1
'yx
*ll1
* *ul1
*)))))
357 ;; converts limits of integration to values for new variable 'yx
358 (defun intcv2 (d nv ivar
)
360 (and (cond ((and (zerop1 (m+ *ll
* *ul
*))
362 (setq exp1
(m* 2 exp1
)
363 *ll1
* (limcp nv ivar
0 '$plus
)))
364 (t (setq *ll1
* (limcp nv ivar
*ll
* '$plus
))))
365 (setq *ul1
* (limcp nv ivar
*ul
* '$minus
))))
367 ;; wrapper around limit, returns nil if
368 ;; limit not found (nounform returned), or undefined ($und or $ind)
369 (defun limcp (a b c d
)
370 (let ((ans ($limit a b c d
)))
371 (cond ((not (or (null ans
)
377 ;; rewrites exp, the integrand in terms of ivar,
378 ;; into exp1, the integrand in terms of 'yx.
379 (defun intcv3 (d nv ivar
)
380 (setq exp1
(m* (sdiff d
'yx
)
381 (subst d ivar
(subst 'yx nv exp
))))
382 (setq exp1
(sratsimp exp1
)))
384 (defun integrand-changevar (d newvar exp ivar
)
388 (defun defint (exp ivar
*ll
* *ul
*)
389 (let ((old-assumptions *defint-assumptions
*)
390 (*current-assumptions
* ())
394 (setq *current-assumptions
* (make-defint-assumptions 'noask ivar
))
395 (let ((exp (resimplify exp
))
396 (ivar (resimplify ivar
))
399 ;; D (not used? -- cwh)
400 ans nn
* dn
* nd
* $noprincipal
)
401 (cond ((setq ans
(defint-list exp ivar
*ll
* *ul
*))
406 ((not (among ivar exp
))
407 (cond ((or (member *ul
* '($inf $minf
) :test
#'eq
)
408 (member *ll
* '($inf $minf
) :test
#'eq
))
410 (t (setq ans
(m* exp
(m+ *ul
* (m- *ll
*))))
412 ;; Look for integrals which involve log and exp functions.
413 ;; Maxima has a special algorithm to get general results.
414 ((and (setq ans
(defint-log-exp exp ivar
*ll
* *ul
*)))
416 (let* ((exp (rmconst1 exp ivar
))
418 (exp (%i-out-of-denom
(cdr exp
))))
419 (cond ((and (not $nointegrate
)
421 (or (among 'mqapply exp
)
422 (not (member (caar exp
)
423 '(mexpt mplus mtimes %sin %cos
424 %tan %sinh %cosh %tanh
425 %log %asin %acos %atan
428 %derivative
) :test
#'eq
))))
429 ;; Call ANTIDERIV with logabs disabled,
430 ;; because the Risch algorithm assumes
431 ;; the integral of 1/x is log(x), not log(abs(x)).
432 ;; Why not just assume logabs = false within RISCHINT itself?
433 ;; Well, there's at least one existing result which requires
434 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
435 (cond ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
436 (setq ans
(intsubs ans
*ll
* *ul
* ivar
))
437 (return (cond (ans (m* c ans
)) (t nil
))))
439 (setq exp
(tansc-var exp ivar
))
440 (cond ((setq ans
(initial-analysis exp ivar
*ll
* *ul
*))
441 (return (m* c ans
))))
443 (restore-defint-assumptions old-assumptions
*current-assumptions
*))))
445 (defun defint-list (exp ivar
*ll
* *ul
*)
447 (let ((ans (cons (car exp
)
450 (defint sub-exp ivar
*ll
* *ul
*))
452 (cond (ans (simplify ans
))
456 (defun initial-analysis (exp ivar
*ll
* *ul
*)
457 (let ((pole (cond ((not $intanalysis
)
458 '$no
) ;don't do any checking.
459 (t (poles-in-interval exp ivar
*ll
* *ul
*)))))
460 (cond ((eq pole
'$no
)
461 (cond ((and (oddfn exp ivar
)
462 (or (and (eq *ll
* '$minf
)
464 (eq ($sign
(m+ *ll
* *ul
*))
466 (t (parse-integrand exp ivar
*ll
* *ul
*))))
467 ((eq pole
'$unknown
) ())
468 (t (principal-value-integral exp ivar
*ll
* *ul
* pole
)))))
470 (defun parse-integrand (exp ivar
*ll
* *ul
*)
472 (cond ((setq ans
(eezz exp
*ll
* *ul
* ivar
)) ans
)
473 ((and (ratp exp ivar
)
474 (setq ans
(method-by-limits exp ivar
*ll
* *ul
*)))
477 (setq ans
(intbyterm exp t ivar
)))
479 ((setq ans
(method-by-limits exp ivar
*ll
* *ul
*)) ans
)
482 (defun rmconst1 (e ivar
)
483 (cond ((not (freeof ivar e
))
484 (partition e ivar
1))
488 (defun method-by-limits (exp ivar
*ll
* *ul
*)
489 (let ((old-assumptions *defint-assumptions
*))
490 (setq *current-assumptions
* (make-defint-assumptions 'noask ivar
))
491 ;;Should be a PROG inside of unwind-protect, but Multics has a compiler
492 ;;bug wrt. and I want to test this code now.
494 (cond ((and (and (eq *ul
* '$inf
)
497 ((and (and (eq *ul
* '$inf
)
500 ;;;This seems((and (and (eq *ul* '$inf)
501 ;;;fairly losing (setq exp (subin (m+ *ll* ivar) exp))
503 ;;; (ztoinf exp ivar)))
504 ((and (equal *ll
* 0.
)
506 (eq ($asksign
*ul
*) '$pos
)
508 ;; ((and (and (equal *ul* 1.)
509 ;; (equal *ll* 0.)) (zto1 exp)))
510 (t (dintegrate exp ivar
*ll
* *ul
*)))
511 (restore-defint-assumptions old-assumptions
*defint-assumptions
*))))
514 (defun dintegrate (exp ivar
*ll
* *ul
*)
515 (let ((ans nil
) (arg nil
) (*scflag
* nil
)
516 (*dflag nil
) ($%emode t
))
517 ;;;NOT COMPLETE for sin's and cos's.
518 (cond ((and (not *sin-cos-recur
*)
521 (intsc1 *ll
* *ul
* exp ivar
)))
522 ((and (not *rad-poly-recur
*)
523 (notinvolve-var exp ivar
'(%log
))
524 (not (%einvolve-var exp ivar
))
525 (method-radical-poly exp ivar
*ll
* *ul
*)))
526 ((and (not (equal *dintlog-recur
* 2.
))
527 (setq arg
(involve-var exp ivar
'(%log
)))
528 (dintlog exp arg ivar
)))
529 ((and (not *dintexp-recur
*)
530 (setq arg
(%einvolve-var exp ivar
))
532 ((and (not (ratp exp ivar
))
533 (setq ans
(let (($trigexpandtimes nil
)
536 (setq ans
($expand ans
))
537 (not (alike1 ans exp
))
538 (intbyterm ans t ivar
)))
539 ;; Call ANTIDERIV with logabs disabled,
540 ;; because the Risch algorithm assumes
541 ;; the integral of 1/x is log(x), not log(abs(x)).
542 ;; Why not just assume logabs = false within RISCHINT itself?
543 ;; Well, there's at least one existing result which requires
544 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
545 ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
546 (intsubs ans
*ll
* *ul
* ivar
))
549 (defun method-radical-poly (exp ivar
*ll
* *ul
*)
551 (let ((*rad-poly-recur
* t
) ;recursion stopper
553 (cond ((and (sinintp exp ivar
)
554 (setq result
(antideriv exp ivar
))
555 (intsubs result
*ll
* *ul
* ivar
)))
556 ((and (ratp exp ivar
)
557 (setq result
(ratfnt exp ivar
))))
559 (not (eq *ul
* '$inf
))
562 (setq result
(cv exp ivar
))))
565 (defun principal-value-integral (exp ivar
*ll
* *ul
* poles
)
566 (let ((anti-deriv ()))
567 (cond ((not (null (setq anti-deriv
(antideriv exp ivar
))))
568 (cond ((not (null poles
))
569 (order-limits 'ask ivar
)
570 (cond ((take-principal anti-deriv
*ll
* *ul
* ivar poles
))
573 ;; adds up integrals of ranges between each pair of poles.
574 ;; checks if whole thing is divergent as limits of integration approach poles.
575 (defun take-principal (anti-deriv *ll
* *ul
* ivar poles
&aux ans merged-list
)
576 ;;; calling $logcontract causes antiderivative of 1/(1-x^5) to blow up
577 ;; (setq anti-deriv (cond ((involve anti-deriv '(%log))
578 ;; ($logcontract anti-deriv))
581 (setq merged-list
(interval-list poles
*ll
* *ul
*))
582 (do ((current-pole (cdr merged-list
) (cdr current-pole
))
583 (previous-pole merged-list
(cdr previous-pole
)))
584 ((null current-pole
) t
)
586 (intsubs anti-deriv
(m+ (caar previous-pole
) 'epsilon
)
587 (m+ (caar current-pole
) (m- 'epsilon
))
590 (setq ans
(get-limit (get-limit ans
'epsilon
0 '$plus
) 'prin-inf
'$inf
))
592 (cond ((or (null ans
)
593 (not (free ans
'$infinity
))
594 (not (free ans
'$ind
))) ())
595 ((or (among '$minf ans
)
599 (t (principal) ans
)))
601 (defun interval-list (pole-list *ll
* *ul
*)
602 (let ((first (car (first pole-list
)))
603 (last (caar (last pole-list
))))
604 (cond ((eq *ul
* last
)
606 (setq pole-list
(subst 'prin-inf
'$inf pole-list
))))
607 (t (if (eq *ul
* '$inf
)
608 (setq *ul
* 'prin-inf
))
609 (setq pole-list
(append pole-list
(list (cons *ul
* 'ignored
))))))
610 (cond ((eq *ll
* first
)
612 (setq pole-list
(subst (m- 'prin-inf
) '$minf pole-list
))))
613 (t (if (eq *ll
* '$minf
)
614 (setq *ll
* (m- 'prin-inf
)))
615 (setq pole-list
(append (list (cons *ll
* 'ignored
)) pole-list
)))))
618 ;; Assumes EXP is a rational expression with no polynomial part and
619 ;; converts the finite integration to integration over a half-infinite
620 ;; interval. The substitution y = (x-a)/(b-x) is used. Equivalently,
621 ;; x = (b*y+a)/(y+1).
623 ;; (I'm guessing CV means Change Variable here.)
625 (if (not (or (real-infinityp *ll
*) (real-infinityp *ul
*)))
626 ;; FIXME! This is a hack. We apply the transformation with
627 ;; symbolic limits and then substitute the actual limits later.
628 ;; That way method-by-limits (usually?) sees a simpler
631 ;; See Bugs 938235 and 941457. These fail because $FACTOR is
632 ;; unable to factor the transformed result. This needs more
633 ;; work (in other places).
634 (let ((trans (integrand-changevar (m// (m+t
'*ll
* (m*t
'*ul
* 'yx
))
637 ;; If the limit is a number, use $substitute so we simplify
638 ;; the result. Do we really want to do this?
639 (setf trans
(if (mnump *ll
*)
640 ($substitute
*ll
* '*ll
* trans
)
641 (subst *ll
* '*ll
* trans
)))
642 (setf trans
(if (mnump *ul
*)
643 ($substitute
*ul
* '*ul
* trans
)
644 (subst *ul
* '*ul
* trans
)))
645 (method-by-limits trans
'yx
0.
'$inf
))
648 ;; Integrate rational functions over a finite interval by doing the
649 ;; polynomial part directly, and converting the rational part to an
650 ;; integral from 0 to inf. This is evaluated via residues.
651 (defun ratfnt (exp ivar
)
652 (let ((e (pqr exp ivar
)))
653 ;; PQR divides the rational expression and returns the quotient
655 (flet ((try-antideriv (e lo hi
)
656 (let ((ans (antideriv e ivar
)))
658 (intsubs ans lo hi ivar
)))))
660 (cond ((equal 0.
(car e
))
661 ;; No polynomial part
662 (let ((ans (try-antideriv exp
*ll
* *ul
*)))
667 ;; Only polynomial part
668 (eezz (car e
) *ll
* *ul
* ivar
))
670 ;; A non-zero quotient and remainder. Combine the results
672 (let ((ans (try-antideriv (m// (cdr e
) dn
*) *ll
* *ul
*)))
674 (m+t
(eezz (car e
) *ll
* *ul
* ivar
)
677 (m+t
(eezz (car e
) *ll
* *ul
* ivar
)
678 (cv (m// (cdr e
) dn
*) ivar
))))))))))
680 ;; I think this takes a rational expression E, and finds the
681 ;; polynomial part. A cons is returned. The car is the quotient and
682 ;; the cdr is the remainder.
684 (let ((varlist (list ivar
)))
686 (setq e
(cdr (ratrep* e
)))
687 (setq dn
* (pdis (ratdenominator e
)))
688 (setq e
(pdivide (ratnumerator e
) (ratdenominator e
)))
689 (cons (simplify (rdis (car e
))) (simplify (rdis (cadr e
))))))
692 (defun intbyterm (exp *nodiverg ivar
)
693 (let ((saved-exp exp
))
695 (let ((ans (catch 'divergent
696 (andmapcar #'(lambda (new-exp)
698 (defint new-exp ivar
*ll
* *ul
*)))
700 (cond ((null ans
) nil
)
702 (let ((*nodiverg nil
))
703 (cond ((setq ans
(antideriv saved-exp ivar
))
704 (intsubs ans
*ll
* *ul
* ivar
))
706 (t (sratsimp (m+l ans
))))))
707 ;;;If leadop isn't plus don't do anything.
710 (defun kindp34 (ivar)
711 (numden-var exp ivar
)
713 (a (cond ((and (zerop1 ($limit d ivar
*ll
* '$plus
))
714 (eq (limit-pole (m+ exp
(m+ (m- *ll
*) ivar
))
719 (b (cond ((and (zerop1 ($limit d ivar
*ul
* '$minus
))
720 (eq (limit-pole (m+ exp
(m+ *ul
* (m- ivar
)))
728 (cond (*nodiverg
(throw 'divergent
'divergent
))
729 (t (merror (intl:gettext
"defint: integral is divergent.")))))
731 (defun make-defint-assumptions (ask-or-not ivar
)
732 (cond ((null (order-limits ask-or-not ivar
)) ())
733 (t (mapc 'forget
*defint-assumptions
*)
734 (setq *defint-assumptions
* ())
735 (let ((sign-ll (cond ((eq *ll
* '$inf
) '$pos
)
736 ((eq *ll
* '$minf
) '$neg
)
737 (t ($sign
($limit
*ll
*)))))
738 (sign-ul (cond ((eq *ul
* '$inf
) '$pos
)
739 ((eq *ul
* '$minf
) '$neg
)
740 (t ($sign
($limit
*ul
*)))))
741 (sign-ul-ll (cond ((and (eq *ul
* '$inf
)
742 (not (eq *ll
* '$inf
))) '$pos
)
743 ((and (eq *ul
* '$minf
)
744 (not (eq *ll
* '$minf
))) '$neg
)
745 (t ($sign
($limit
(m+ *ul
* (m- *ll
*))))))))
746 (cond ((eq sign-ul-ll
'$pos
)
747 (setq *defint-assumptions
*
748 `(,(assume `((mgreaterp) ,ivar
,*ll
*))
749 ,(assume `((mgreaterp) ,*ul
* ,ivar
)))))
750 ((eq sign-ul-ll
'$neg
)
751 (setq *defint-assumptions
*
752 `(,(assume `((mgreaterp) ,ivar
,*ul
*))
753 ,(assume `((mgreaterp) ,*ll
* ,ivar
))))))
754 (cond ((and (eq sign-ll
'$pos
)
756 (setq *defint-assumptions
*
757 `(,(assume `((mgreaterp) ,ivar
0))
758 ,@*defint-assumptions
*)))
759 ((and (eq sign-ll
'$neg
)
761 (setq *defint-assumptions
*
762 `(,(assume `((mgreaterp) 0 ,ivar
))
763 ,@*defint-assumptions
*)))
764 (t *defint-assumptions
*))))))
766 (defun restore-defint-assumptions (old-assumptions assumptions
)
767 (do ((llist assumptions
(cdr llist
)))
769 (forget (car llist
)))
770 (do ((llist old-assumptions
(cdr llist
)))
772 (assume (car llist
))))
774 (defun make-global-assumptions ()
775 (setq *global-defint-assumptions
*
776 (cons (assume '((mgreaterp) *z
* 0.
))
777 *global-defint-assumptions
*))
778 ;; *Z* is a "zero parameter" for this package.
779 ;; Its also used to transform.
780 ;; limit(exp,var,val,dir) -- limit(exp,tvar,0,dir)
781 (setq *global-defint-assumptions
*
782 (cons (assume '((mgreaterp) epsilon
0.
))
783 *global-defint-assumptions
*))
784 (setq *global-defint-assumptions
*
785 (cons (assume '((mlessp) epsilon
1.0e-8))
786 *global-defint-assumptions
*))
787 ;; EPSILON is used in principal value code to denote the familiar
788 ;; mathematical entity.
789 (setq *global-defint-assumptions
*
790 (cons (assume '((mgreaterp) prin-inf
1.0e+8))
791 *global-defint-assumptions
*)))
793 ;;; PRIN-INF Is a special symbol in the principal value code used to
794 ;;; denote an end-point which is proceeding to infinity.
796 (defun forget-global-assumptions ()
797 (do ((llist *global-defint-assumptions
* (cdr llist
)))
799 (forget (car llist
)))
800 (cond ((not (null integer-info
))
801 (do ((llist integer-info
(cdr llist
)))
803 (i-$remove
`(,(cadar llist
) ,(caddar llist
)))))))
805 (defun order-limits (ask-or-not ivar
)
806 (cond ((or (not (equal ($imagpart
*ll
*) 0))
807 (not (equal ($imagpart
*ul
*) 0))) ())
808 (t (cond ((alike1 *ll
* (m*t -
1 '$inf
))
810 (cond ((alike1 *ul
* (m*t -
1 '$inf
))
812 (cond ((alike1 *ll
* (m*t -
1 '$minf
))
814 (cond ((alike1 *ul
* (m*t -
1 '$minf
))
816 (cond ((eq *ll
* *ul
*)
817 ; We have minf <= *ll* = *ul* <= inf
820 ; We have minf <= *ll* < *ul* = inf
823 ; We have minf = *ll* < *ul* < inf
831 ; so that minf < *ll* < *ul* = inf
832 (setq exp
(subin-var (m- ivar
) exp ivar
))
833 (setq *ll
* (m- *ul
*))
836 (equal (complm ask-or-not
) -
1))
837 ; We have minf <= *ul* < *ll*
844 ; so that minf <= *ll* < *ul*
846 (rotatef *ll
* *ul
*)))
849 (defun complm (ask-or-not)
850 (let ((askflag (cond ((eq ask-or-not
'ask
) t
)
853 (cond ((alike1 *ul
* *ll
*) 0.
)
854 ((eq (setq a
(cond (askflag ($asksign
($limit
(m+t
*ul
* (m- *ll
*)))))
855 (t ($sign
($limit
(m+t
*ul
* (m- *ll
*)))))))
861 ;; Substitute a and b into integral e
863 ;; Looks for discontinuties in integral, and works around them.
866 ;; integrate(x^(2*n)*exp(-(x)^2),x) ==>
867 ;; -gamma_incomplete((2*n+1)/2,x^2)*x^(2*n+1)*abs(x)^(-2*n-1)/2
869 ;; the integral has a discontinuity at x=0.
871 (defun intsubs (e a b ivar
)
872 (let ((edges (cond ((not $intanalysis
)
873 '$no
) ;don't do any checking.
874 (t (discontinuities-in-interval
875 (let (($algebraic t
))
879 (cond ((or (eq edges
'$no
)
880 (eq edges
'$unknown
))
881 (whole-intsubs e a b ivar
))
883 (do* ((l edges
(cdr l
))
886 (b1 (cadr l
) (cadr l
)))
887 ((null (cdr l
)) (if (every (lambda (x) x
) total
)
890 (whole-intsubs e a1 b1 ivar
)
893 ;; look for terms with a negative exponent
895 ;; recursively traverses exp in order to find discontinuities such as
896 ;; erfc(1/x-x) at x=0
897 (defun discontinuities-denom (exp ivar
)
899 ((and (eq (caar exp
) 'mexpt
)
900 (not (freeof ivar
(cadr exp
)))
901 (not (member ($sign
(caddr exp
)) '($pos $pz
))))
902 (m^
(cadr exp
) (m- (caddr exp
))))
904 (m*l
(mapcar #'(lambda (e)
905 (discontinuities-denom e ivar
))
908 ;; returns list of places where exp might be discontinuous in ivar.
909 ;; list begins with *ll* and ends with *ul*, and include any values between
911 ;; return '$no or '$unknown if no discontinuities found.
912 (defun discontinuities-in-interval (exp ivar
*ll
* *ul
*)
913 (let* ((denom (discontinuities-denom exp ivar
))
914 (roots (real-roots denom ivar
)))
915 (cond ((eq roots
'$failure
)
919 (t (do ((dummy roots
(cdr dummy
))
924 (sortgreat pole-list
)
927 (let ((soltn (caar dummy
)))
928 ;; (multiplicity (cdar dummy)) ;; not used
929 (if (strictly-in-interval soltn
*ll
* *ul
*)
930 (push soltn pole-list
))))))))
933 ;; Carefully substitute the integration limits A and B into the
935 (defun whole-intsubs (e a b ivar
)
936 (cond ((easy-subs e a b ivar
))
937 (t (setq *current-assumptions
*
938 (make-defint-assumptions 'ask ivar
)) ;get forceful!
939 (let (($algebraic t
))
940 (setq e
(sratsimp e
))
941 (cond ((limit-subs e a b ivar
))
942 (t (same-sheet-subs e a b ivar
)))))))
944 ;; Try easy substitutions. Return NIL if we can't.
945 (defun easy-subs (e *ll
* *ul
* ivar
)
946 (cond ((or (infinityp *ll
*) (infinityp *ul
*))
947 ;; Infinite limits aren't easy
950 (cond ((or (polyinx e ivar
())
951 (and (not (involve-var e ivar
'(%log %asin %acos %atan %asinh %acosh %atanh %atan2
952 %gamma_incomplete %expintegral_ei
)))
953 (free ($denom e
) ivar
)))
954 ;; It's easy if we have a polynomial. I (rtoy) think
955 ;; it's also easy if the denominator is free of the
956 ;; integration variable and also if the expression
957 ;; doesn't involve inverse functions.
959 ;; gamma_incomplete and expintegral_ie
960 ;; included because of discontinuity in
961 ;; gamma_incomplete(0, exp(%i*x)) and
962 ;; expintegral_ei(exp(%i*x))
964 ;; XXX: Are there other cases we've forgotten about?
966 ;; So just try to substitute the limits into the
967 ;; expression. If no errors are produced, we're done.
968 (let ((ll-val (no-err-sub-var *ll
* e ivar
))
969 (ul-val (no-err-sub-var *ul
* e ivar
)))
970 (cond ((or (eq ll-val t
)
972 ;; no-err-sub has returned T. An error was catched.
979 (defun limit-subs (e *ll
* *ul
* ivar
)
980 (cond ((involve-var e ivar
'(%atan %gamma_incomplete %expintegral_ei
))
981 ()) ; functions with discontinuities
982 (t (setq e
($multthru e
))
983 (let ((a1 ($limit e ivar
*ll
* '$plus
))
984 (a2 ($limit e ivar
*ul
* '$minus
)))
985 (combine-ll-ans-ul-ans a1 a2
)))))
987 ;; check for divergent integral
988 (defun combine-ll-ans-ul-ans (a1 a2
)
989 (cond ((member a1
'($inf $minf $infinity
) :test
#'eq
)
990 (cond ((member a2
'($inf $minf $infinity
) :test
#'eq
)
991 (cond ((eq a2 a1
) ())
994 ((member a2
'($inf $minf $infinity
) :test
#'eq
) (diverg))
995 ((or (member a1
'($und $ind
) :test
#'eq
)
996 (member a2
'($und $ind
) :test
#'eq
)) ())
999 ;;;This function works only on things with ATAN's in them now.
1000 (defun same-sheet-subs (exp *ll
* *ul
* ivar
&aux ll-ans ul-ans
)
1001 ;; POLES-IN-INTERVAL doesn't know about the poles of tan(x). Call
1002 ;; trigsimp to convert tan into sin/cos, which POLES-IN-INTERVAL
1003 ;; knows how to handle.
1005 ;; XXX Should we fix POLES-IN-INTERVAL instead?
1007 ;; XXX Is calling trigsimp too much? Should we just only try to
1008 ;; substitute sin/cos for tan?
1010 ;; XXX Should the result try to convert sin/cos back into tan? (A
1011 ;; call to trigreduce would do it, among other things.)
1012 (let* ((exp (mfuncall '$trigsimp exp
))
1013 (poles (atan-poles exp
*ll
* *ul
* ivar
)))
1014 ;;POLES -> ((mlist) ((mequal) ((%atan) foo) replacement) ......)
1015 ;;We can then use $SUBSTITUTE
1016 (setq ll-ans
(limcp exp ivar
*ll
* '$plus
))
1017 (setq exp
(sratsimp ($substitute poles exp
)))
1018 (setq ul-ans
(limcp exp ivar
*ul
* '$minus
))
1021 (combine-ll-ans-ul-ans ll-ans ul-ans
)
1024 (defun atan-poles (exp *ll
* *ul
* ivar
)
1025 `((mlist) ,@(atan-pole1 exp
*ll
* *ul
* ivar
)))
1027 (defun atan-pole1 (exp *ll
* *ul
* ivar
&aux ipart
)
1030 ((matanp exp
) ;neglect multiplicity and '$unknowns for now.
1031 (desetq (exp . ipart
) (trisplit exp
))
1033 ((not (equal (sratsimp ipart
) 0)) ())
1034 (t (let ((pole (poles-in-interval (let (($algebraic t
))
1035 (sratsimp (cadr exp
)))
1037 (cond ((and pole
(not (or (eq pole
'$unknown
)
1039 (do ((l pole
(cdr l
)) (llist ()))
1042 ((zerop1 (m- (caar l
) *ll
*)) t
) ; don't worry about discontinuity
1043 ((zerop1 (m- (caar l
) *ul
*)) t
) ; at boundary of integration
1044 (t (let ((low-lim ($limit
(cadr exp
) ivar
(caar l
) '$minus
))
1045 (up-lim ($limit
(cadr exp
) ivar
(caar l
) '$plus
)))
1046 (cond ((and (not (eq low-lim up-lim
))
1047 (real-infinityp low-lim
)
1048 (real-infinityp up-lim
))
1049 (let ((change (if (eq low-lim
'$minf
)
1052 (setq llist
(cons `((mequal simp
) ,exp
,(m+ exp change
))
1053 llist
)))))))))))))))
1054 (t (do ((l (cdr exp
) (cdr l
))
1057 (setq llist
(append llist
(atan-pole1 (car l
) *ll
* *ul
* ivar
)))))))
1059 (defun difapply (ivar n d s fn1
)
1060 (prog (k m r $noprincipal
)
1061 (cond ((eq ($asksign
(m+ (deg-var d ivar
) (m- s
) (m- 2.
))) '$neg
)
1063 (setq $noprincipal t
)
1064 (cond ((or (not (mexptp d
))
1065 (not (numberp (setq r
(caddr d
)))))
1068 ;; There are no calls where fn1 is ever equal to
1069 ;; 'mtorat. Hence this case is never true. What is
1070 ;; this testing for?
1072 (equal 1.
(deg-var (cadr d
) ivar
)))
1074 (setq m
(deg-var (setq d
(cadr d
)) ivar
))
1075 (setq k
(m// (m+ s
2.
) m
))
1076 (cond ((eq (ask-integer (m// (m+ s
2.
) m
) '$any
) '$yes
)
1078 (t (setq k
(m+ 1 k
))))
1079 (cond ((eq ($sign
(m+ r
(m- k
))) '$pos
)
1080 (return (diffhk fn1 n d k
(m+ r
(m- k
)) ivar
))))))
1082 (defun diffhk (fn1 n d r m ivar
)
1085 (setq d1
(funcall fn1 n
1087 (m* r
(deg-var d ivar
))))
1088 (cond (d1 (return (difap1 d1 r
'*z
* m
0.
))))))
1090 (defun principal nil
1091 (cond ($noprincipal
(diverg))
1093 (format t
"Principal Value~%")
1096 ;; e is of form poly(x)*exp(m*%i*x)
1097 ;; s is degree of denominator
1098 ;; adds e to bptu or bptd according to sign of m
1099 (defun rib (e s ivar
)
1101 (cond ((or (mnump e
) (constant e
))
1102 (setq bptu
(cons e bptu
)))
1103 (t (setq e
(rmconst1 e ivar
))
1107 (multiple-value-setq (e updn
)
1108 (catch 'ptimes%e
(ptimes%e nn
* nd
* ivar
)))
1109 (cond ((null e
) nil
)
1110 (t (setq e
(m* c e
))
1111 (cond (updn (setq bptu
(cons e bptu
)))
1112 (t (setq bptd
(cons e bptd
))))))))))
1114 ;; Check term is of form poly(x)*exp(m*%i*x)
1115 ;; n is degree of denominator.
1116 (defun ptimes%e
(term n ivar
&aux updn
)
1117 (cond ((and (mexptp term
)
1118 (eq (cadr term
) '$%e
)
1119 (polyinx (caddr term
) ivar nil
)
1120 (eq ($sign
(m+ (deg-var ($realpart
(caddr term
)) ivar
) -
1))
1122 (eq ($sign
(m+ (deg-var (setq nn
* ($imagpart
(caddr term
))) ivar
)
1125 ;; Set updn to T if the coefficient of IVAR in the
1126 ;; polynomial is known to be positive. Otherwise set to NIL.
1127 ;; (What does updn really mean?)
1128 (setq updn
(eq ($asksign
(ratdisrep (ratcoef nn
* ivar
))) '$pos
))
1130 ((and (mtimesp term
)
1131 (setq nn
* (polfactors term ivar
))
1132 (or (null (car nn
*))
1133 (eq ($sign
(m+ n
(m- (deg-var (car nn
*) ivar
))))
1135 (not (alike1 (cadr nn
*) term
))
1136 (multiple-value-setq (term updn
)
1137 (ptimes%e
(cadr nn
*) n ivar
))
1140 (t (throw 'ptimes%e nil
))))
1142 (defun csemidown (n d ivar
)
1143 (let ((pcprntd t
)) ;Not sure what to do about PRINCIPAL values here.
1145 (res-var ivar n d
#'lowerhalf
#'(lambda (x)
1146 (cond ((equal ($imagpart x
) 0) t
)
1149 (defun lowerhalf (j)
1150 (eq ($asksign
($imagpart j
)) '$neg
))
1152 (defun upperhalf (j)
1153 (eq ($asksign
($imagpart j
)) '$pos
))
1156 (defun csemiup (n d ivar
)
1157 (let ((pcprntd t
)) ;I'm not sure what to do about PRINCIPAL values here.
1159 (res-var ivar n d
#'upperhalf
#'(lambda (x)
1160 (cond ((equal ($imagpart x
) 0) t
)
1164 (cond ((null n
) nil
)
1165 (t (m*t
'$%i
($rectform
(m+ (cond ((car n
)
1173 ;; exponentialize sin and cos
1174 (defun sconvert (e ivar
)
1176 ((polyinx e ivar nil
) e
)
1177 ((eq (caar e
) '%sin
)
1180 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1181 (m- (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
)))))))
1182 ((eq (caar e
) '%cos
)
1183 (mul* '((rat) 1.
2.
)
1184 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1185 (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
))))))
1187 (cons (list (caar e
)) (mapcar #'(lambda (ee)
1191 (defun polfactors (exp ivar
)
1193 (cond ((mplusp exp
) nil
)
1194 (t (cond ((mtimesp exp
)
1195 (setq exp
(reverse (cdr exp
))))
1196 (t (setq exp
(list exp
))))
1197 (mapc #'(lambda (term)
1198 (cond ((polyinx term ivar nil
)
1200 (t (push term rest
))))
1202 (list (m*l poly
) (m*l rest
))))))
1206 (cond ((atom e
) (return e
))
1207 ((not (among '$%e e
)) (return e
))
1210 (setq d
($imagpart
(caddr e
)))
1211 (return (m* (m^t
'$%e
($realpart
(caddr e
)))
1213 (m*t
'$%i
`((%sin
) ,d
))))))
1214 (t (return (simplify (cons (list (caar e
))
1215 (mapcar #'esap
(cdr e
)))))))))
1217 ;; computes integral from minf to inf for expressions of the form
1218 ;; exp(%i*m*x)*r(x) by residues on either the upper half
1219 ;; plane or the lower half plane, depending on whether
1220 ;; m is positive or negative. [wang p. 77]
1222 ;; exponentializes sin and cos before applying residue method.
1223 ;; can handle some expressions with poles on real line, such as
1225 (defun mtosc (grand ivar
)
1226 (numden-var grand ivar
)
1230 plf bptu bptd s upans downans
)
1231 (cond ((not (or (polyinx d ivar nil
)
1232 (and (setq grand
(%einvolve-var d ivar
))
1234 (polyinx (setq d
(sratsimp (m// d
(m^t
'$%e grand
))))
1237 (setq n
(m// n
(m^t
'$%e grand
)))))) nil
)
1238 ((equal (setq s
(deg-var d ivar
)) 0) nil
)
1239 ;;;Above tests for applicability of this method.
1240 ((and (or (setq plf
(polfactors n ivar
)) t
)
1241 (setq n
($expand
(cond ((car plf
)
1242 (m*t
'x
* (sconvert (cadr plf
) ivar
)))
1243 (t (sconvert n ivar
)))))
1244 (cond ((mplusp n
) (setq n
(cdr n
)))
1245 (t (setq n
(list n
))))
1247 (cond ((polyinx term ivar nil
)
1248 ;; call to $expand can create rational terms
1249 ;; with no exp(m*%i*x)
1250 (setq ratterms
(cons term ratterms
)))
1253 ;;;Function RIB sets up the values of BPTU and BPTD
1255 (setq bptu
(subst (car plf
) 'x
* bptu
))
1256 (setq bptd
(subst (car plf
) 'x
* bptd
))
1257 (setq ratterms
(subst (car plf
) 'x
* ratterms
))
1258 t
) ;CROCK, CROCK. This is TERRIBLE code.
1260 ;;;If there is BPTU then CSEMIUP must succeed.
1261 ;;;Likewise for BPTD.
1264 (let (($intanalysis nil
))
1265 ;; The original integrand was already
1266 ;; determined to have no poles by initial-analysis.
1267 ;; If individual terms of the expansion have poles, the poles
1268 ;; must cancel each other out, so we can ignore them.
1269 (try-defint (m// (m+l ratterms
) d
) ivar
'$minf
'$inf
))
1271 ;; if integral of ratterms is divergent, ratans is nil,
1272 ;; and mtosc returns nil
1274 (cond (bptu (setq upans
(csemiup (m+l bptu
) d ivar
)))
1276 (cond (bptd (setq downans
(csemidown (m+l bptd
) d ivar
)))
1277 (t (setq downans
0))))
1279 (sratsimp (m+ ratans
1280 (m* '$%pi
(m+ upans
(m- downans
)))))))))
1283 (defun evenfn (e ivar
)
1284 (let ((temp (m+ (m- e
)
1286 ($substitute
(m- ivar
) ivar e
))
1287 (t ($ratsubst
(m- ivar
) ivar e
))))))
1288 (cond ((zerop1 temp
)
1290 ((zerop1 (sratsimp temp
))
1294 (defun oddfn (e ivar
)
1295 (let ((temp (m+ e
(cond ((atom ivar
)
1296 ($substitute
(m- ivar
) ivar e
))
1297 (t ($ratsubst
(m- ivar
) ivar e
))))))
1298 (cond ((zerop1 temp
)
1300 ((zerop1 (sratsimp temp
))
1304 (defun ztoinf (grand ivar
)
1305 (prog (n d sn sd varlist
1307 ans r $savefactors
*checkfactors
* temp test-var
)
1308 (setq $savefactors t sn
(setq sd
(list 1.
)))
1309 (cond ((eq ($sign
(m+ *loopstop
* -
1))
1312 ((setq temp
(or (scaxn grand ivar
)
1315 ((involve-var grand ivar
'(%sin %cos %tan
))
1316 (setq grand
(sconvert grand ivar
))
1319 (cond ((polyinx grand ivar nil
)
1321 ((and (ratp grand ivar
)
1323 (andmapcar #'(lambda (e)
1324 (multiple-value-bind (result new-sn new-sd
)
1325 (snumden-var e ivar sn sd
)
1335 (t (numden-var grand ivar
)))
1338 (setq n
(rmconst1 nn
* ivar
))
1339 (setq d
(rmconst1 dn
* ivar
))
1344 (cond ((polyinx d ivar nil
)
1345 (setq s
(deg-var d ivar
)))
1347 (cond ((and (setq r
(findp n ivar
))
1348 (eq (ask-integer r
'$integer
) '$yes
)
1349 (setq test-var
(bxm d s ivar
))
1350 (setq ans
(apply 'fan
(cons (m+ 1. r
) test-var
))))
1351 (return (m* (m// nc dc
) (sratsimp ans
))))
1352 ((and (ratp grand ivar
)
1353 (setq ans
(zmtorat n
(cond ((mtimesp d
) d
)
1357 (ztorat n d s ivar
))
1359 (return (m* (m// nc dc
) ans
)))
1360 ((and (evenfn d ivar
)
1361 (setq nn
* (p*lognxp n s ivar
)))
1362 (setq ans
(log*rat
(car nn
*) d
(cadr nn
*) ivar
))
1363 (return (m* (m// nc dc
) ans
)))
1364 ((involve-var grand ivar
'(%log
))
1365 (cond ((setq ans
(logquad0 grand ivar
))
1366 (return (m* (m// nc dc
) ans
)))
1369 (cond ((setq temp
(batapp grand ivar
))
1373 (cond ((let ((*mtoinf
* nil
))
1374 (setq temp
(ggr grand t ivar
)))
1377 (cond ((let ((*nodiverg t
))
1378 (setq ans
(catch 'divergent
1379 (andmapcar #'(lambda (g)
1382 (cond ((eq ans
'divergent
) nil
)
1383 (t (return (sratsimp (m+l ans
)))))))))
1385 (cond ((and (evenfn grand ivar
)
1386 (setq *loopstop
* (m+ 1 *loopstop
*))
1387 (setq ans
(method-by-limits grand ivar
'$minf
'$inf
)))
1388 (return (m*t
'((rat) 1.
2.
) ans
)))
1391 (defun ztorat (n d s ivar
)
1392 (cond ((and (null *dflag
)
1393 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1394 (ztorat n d s ivar
)))))
1396 ((setq n
(let ((plogabs ()))
1397 (keyhole (let ((var ivar
))
1398 (declare (special var
))
1399 ;; It's very important here to bind VAR
1400 ;; because the PLOG simplifier checks
1401 ;; for VAR. Without this, the
1402 ;; simplifier converts plog(-x) to
1403 ;; log(x)+%i*%pi, which messes up the
1405 (m* `((%plog
) ,(m- ivar
)) n
))
1410 ;; Let's not signal an error here. Return nil so that we
1411 ;; eventually return a noun form if no other algorithm gives
1414 (merror (intl:gettext
"defint: keyhole integration failed.~%"))
1419 (defun logquad0 (exp ivar
)
1420 (let ((a ()) (b ()) (c ()))
1421 (cond ((setq exp
(logquad exp ivar
))
1422 (setq a
(car exp
) b
(cadr exp
) c
(caddr exp
))
1423 ($asksign b
) ;let the data base know about the sign of B.
1424 (cond ((eq ($asksign c
) '$pos
)
1425 (setq c
(m^
(m// c a
) '((rat) 1.
2.
)))
1427 `((%acos
) ,(add* 'epsilon
(m// b
(mul* 2. a c
))))))
1428 (setq a
(m// (m* b
`((%log
) ,c
))
1429 (mul* a
(simplify `((%sin
) ,b
)) c
)))
1430 (get-limit a
'epsilon
0 '$plus
))))
1433 (defun logquad (exp ivar
)
1434 (let ((varlist (list ivar
)))
1436 (setq exp
(cdr (ratrep* exp
)))
1437 (cond ((and (alike1 (pdis (car exp
))
1439 (not (atom (cdr exp
)))
1440 (equal (cadr (cdr exp
)) 2.
)
1441 (not (equal (ptterm (cddr exp
) 0.
) 0.
)))
1442 (setq exp
(mapcar 'pdis
(cdr (oddelm (cdr exp
)))))))))
1444 (defun mtoinf (grand ivar
)
1445 (prog (ans ans1 sd sn pp pe n d s nc dc $savefactors
*checkfactors
* temp
)
1446 (setq $savefactors t
)
1447 (setq sn
(setq sd
(list 1.
)))
1448 (cond ((eq ($sign
(m+ *loopstop
* -
1)) '$pos
)
1450 ((involve-var grand ivar
'(%sin %cos
))
1451 (cond ((and (evenfn grand ivar
)
1452 (or (setq temp
(scaxn grand ivar
))
1453 (setq temp
(ssp grand ivar
))))
1454 (return (m*t
2. temp
)))
1455 ((setq temp
(mtosc grand ivar
))
1458 ((among '$%i
(%einvolve-var grand ivar
))
1459 (cond ((setq temp
(mtosc grand ivar
))
1462 (setq grand
($exponentialize grand
)) ; exponentializing before numden
1463 (cond ((polyinx grand ivar nil
) ; avoids losing multiplicities [ 1309432 ]
1465 ((and (ratp grand ivar
)
1467 (andmapcar #'(lambda (e)
1468 (multiple-value-bind (result new-sn new-sd
)
1469 (snumden-var e ivar sn sd
)
1475 (setq nn
* (m*l sn
) sn nil
)
1476 (setq dn
* (m*l sd
) sd nil
))
1477 (t (numden-var grand ivar
)))
1478 (setq n
(rmconst1 nn
* ivar
))
1479 (setq d
(rmconst1 dn
* ivar
))
1484 (cond ((polyinx d ivar nil
)
1485 (setq s
(deg-var d ivar
))))
1486 (cond ((and (not (%einvolve-var grand ivar
))
1487 (notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
1488 (setq pp
(findp n ivar
))
1489 (eq (ask-integer pp
'$integer
) '$yes
)
1490 (setq pe
(bxm d s ivar
)))
1491 (cond ((and (eq (ask-integer (caddr pe
) '$even
) '$yes
)
1492 (eq (ask-integer pp
'$even
) '$yes
))
1493 (cond ((setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1494 (setq ans
(m*t
2. ans
))
1495 (return (m* (m// nc dc
) ans
)))))
1496 ((equal (car pe
) 1.
)
1497 (cond ((and (setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1498 (setq nn
* (fan (m+ 1. pp
)
1503 (setq ans
(m+ ans
(m*t
(m^ -
1 pp
) nn
*)))
1504 (return (m* (m// nc dc
) ans
))))))))
1507 ((pppin%ex
(nd* ivar
)
1508 ;; Test to see if exp is of the form p(x)*f(exp(x)). If so, set pp to
1509 ;; be p(x) and set pe to f(exp(x)).
1510 (setq nd
* ($factor nd
*))
1511 (cond ((polyinx nd
* ivar nil
)
1512 (setq pp
(cons nd
* pp
)) t
)
1513 ((catch 'pin%ex
(pin%ex nd
* ivar
))
1514 (setq pe
(cons nd
* pe
)) t
)
1516 (andmapcar #'(lambda (ex)
1519 (cond ((and (ratp grand ivar
)
1520 (setq ans1
(zmtorat n
1521 (cond ((mtimesp d
) d
) (t ($sqfr d
)))
1524 (mtorat n d s ivar
))
1526 (setq ans
(m*t
'$%pi ans1
))
1527 (return (m* (m// nc dc
) ans
)))
1528 ((and (or (%einvolve-var grand ivar
)
1529 (involve-var grand ivar
'(%sinh %cosh %tanh
)))
1530 (pppin%ex n ivar
) ;setq's P* and PE*...Barf again.
1531 (setq ans
(catch 'pin%ex
(pin%ex d ivar
))))
1532 ;; We have an integral of the form p(x)*F(exp(x)), where
1533 ;; p(x) is a polynomial.
1536 (return (dintexp grand ivar
)))
1537 ((not (and (zerop1 (get-limit grand ivar
'$inf
))
1538 (zerop1 (get-limit grand ivar
'$minf
))))
1539 ;; These limits must exist for the integral to converge.
1541 ((setq ans
(rectzto%pi2
(m*l pp
) (m*l pe
) d ivar
))
1542 ;; This only handles the case when the F(z) is a
1543 ;; rational function.
1544 (return (m* (m// nc dc
) ans
)))
1545 ((setq ans
(log-transform (m*l pp
) (m*l pe
) d ivar
))
1546 ;; If we get here, F(z) is not a rational function.
1547 ;; We transform it using the substitution x=log(y)
1548 ;; which gives us an integral of the form
1549 ;; p(log(y))*F(y)/y, which maxima should be able to
1551 (return (m* (m// nc dc
) ans
)))
1553 ;; Give up. We don't know how to handle this.
1556 (cond ((setq ans
(ggrm grand ivar
))
1558 ((and (evenfn grand ivar
)
1559 (setq *loopstop
* (m+ 1 *loopstop
*))
1560 (setq ans
(method-by-limits grand ivar
0 '$inf
)))
1561 (return (m*t
2. ans
)))
1564 (defun linpower0 (exp ivar
)
1565 (cond ((and (setq exp
(linpower exp ivar
))
1566 (eq (ask-integer (caddr exp
) '$even
)
1568 (ratgreaterp 0.
(car exp
)))
1571 ;;; given (b*x+a)^n+c returns (a b n c)
1572 (defun linpower (exp ivar
)
1573 (let (linpart deg lc c varlist
)
1574 (cond ((not (polyp-var exp ivar
)) nil
)
1575 (t (let ((varlist (list ivar
)))
1577 (setq linpart
(cadr (ratrep* exp
)))
1578 (cond ((atom linpart
)
1580 (t (setq deg
(cadr linpart
))
1581 ;;;get high degree of poly
1582 (setq linpart
($diff exp ivar
(m+ deg -
1)))
1583 ;;;diff down to linear.
1584 (setq lc
(sdiff linpart ivar
))
1585 ;;;all the way to constant.
1586 (setq linpart
(sratsimp (m// linpart lc
)))
1587 (setq lc
(sratsimp (m// lc
`((mfactorial) ,deg
))))
1588 ;;;get rid of factorial from differentiation.
1589 (setq c
(sratsimp (m+ exp
(m* (m- lc
)
1590 (m^ linpart deg
)))))))
1591 ;;;Sees if can be expressed as (a*x+b)^n + part freeof x.
1592 (cond ((not (among ivar c
))
1593 `(,lc
,linpart
,deg
,c
))
1596 (defun mtorat (n d s ivar
)
1597 (let ((*semirat
* t
))
1598 (cond ((and (null *dflag
)
1599 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1600 (mtorat n d s ivar
)))))
1602 (t (csemiup n d ivar
)))))
1604 (defun zmtorat (n d s fn1 ivar
)
1606 (cond ((eq ($sign
(m+ s
(m+ 1 (setq nn
* (deg-var n ivar
)))))
1609 ((eq ($sign
(m+ s -
4))
1612 (setq d
($factor d
))
1613 (setq c
(rmconst1 d ivar
))
1619 (setq n
(partnum n d ivar
))
1621 (setq n
($xthru
(m+l
1622 (mapcar #'(lambda (a b
)
1623 (let ((foo (funcall fn1
(car a
) b
(deg-var b ivar
))))
1624 (if foo
(m// foo
(cadr a
))
1625 (return-from zmtorat nil
))))
1628 (return (cond (c (m// n c
))
1632 (setq n
(funcall fn1 n d s
))
1633 (return (when n
(sratsimp (cond (c (m// n c
))
1636 (defun pfrnum (f g n n2 ivar
)
1637 (let ((varlist (list ivar
)) genvar
)
1638 (setq f
(polyform f
)
1642 (setq ivar
(caadr (ratrep* ivar
)))
1643 (setq f
(resprog0-var ivar f g n n2
))
1644 (list (list (pdis (cadr f
)) (pdis (cddr f
)))
1645 (list (pdis (caar f
)) (pdis (cdar f
))))))
1650 (setq f
(ratrep* e
))
1651 (and (equal (cddr f
) 1)
1653 (and (equal (length (setq d
(cddr f
))) 3)
1656 (return (list (car d
)
1658 (ptimes (cadr f
) (caddr d
)))))
1659 (merror "defint: bug from PFRNUM in RESIDU.")))
1661 (defun partnum (n dl ivar
)
1662 (let ((n2 1) ans nl
)
1663 (do ((dl dl
(cdr dl
)))
1665 (nconc ans
(ncons (list n n2
))))
1666 (setq nl
(pfrnum (car dl
) (m*l
(cdr dl
)) n n2 ivar
))
1667 (setq ans
(nconc ans
(ncons (car nl
))))
1668 (setq n2
(cadadr nl
) n
(caadr nl
) nl nil
))))
1670 (defun ggrm (e ivar
)
1671 (prog (poly expo
*mtoinf
* mb varlist genvar l c gvar
)
1672 (setq varlist
(list ivar
))
1674 (cond ((and (setq expo
(%einvolve-var e ivar
))
1675 (polyp-var (setq poly
(sratsimp (m// e
(m^t
'$%e expo
)))) ivar
)
1676 (setq l
(catch 'ggrm
(ggr (m^t
'$%e expo
) nil ivar
))))
1678 (setq mb
(m- (subin-var 0.
(cadr l
) ivar
)))
1679 (setq poly
(m+ (subin-var (m+t mb ivar
) poly ivar
)
1680 (subin-var (m+t mb
(m*t -
1 ivar
)) poly ivar
))))
1682 (setq expo
(caddr l
)
1687 (setq poly
(cdr (ratrep* poly
)))
1688 (setq mb
(m^
(pdis (cdr poly
)) -
1)
1690 (setq gvar
(caadr (ratrep* ivar
)))
1691 (cond ((or (atom poly
)
1692 (pointergp gvar
(car poly
)))
1693 (setq poly
(list 0. poly
)))
1694 (t (setq poly
(cdr poly
))))
1695 (return (do ((poly poly
(cddr poly
)))
1697 (mul* (m^t
'$%e c
) (m^t expo -
1) mb
(m+l e
)))
1698 (setq e
(cons (ggrm1 (car poly
) (pdis (cadr poly
)) l expo
)
1701 (defun ggrm1 (d k a b
)
1702 (setq b
(m// (m+t
1. d
) b
))
1703 (m* k
`((%gamma
) ,b
) (m^ a
(m- b
))))
1705 ;; Compute the integral(n/d,x,0,inf) by computing the negative of the
1706 ;; sum of residues of log(-x)*n/d over the poles of n/d inside the
1707 ;; keyhole contour. This contour is basically an disk with a slit
1708 ;; along the positive real axis. n/d must be a rational function.
1709 (defun keyhole (n d ivar
)
1710 (let* ((*semirat
* ())
1711 (res (res-var ivar n d
1713 ;; Ok if not on the positive real axis.
1714 (or (not (equal ($imagpart j
) 0))
1715 (eq ($asksign j
) '$neg
)))
1717 (cond ((eq ($asksign j
) '$pos
)
1722 ($rectform
($multthru
(m+ (cond ((car res
)
1729 ;; Look at an expression e of the form sin(r*x)^k, where k is an
1730 ;; integer. Return the list (1 r k). (Not sure if the first element
1731 ;; of the list is always 1 because I'm not sure what partition is
1732 ;; trying to do here.)
1735 (cond ((atom e
) (return nil
)))
1736 (setq e
(partition e ivar
1))
1739 (cond ((setq r
(sinrx e ivar
))
1740 (return (list m r
1)))
1742 (eq (ask-integer (setq k
(caddr e
)) '$integer
) '$yes
)
1743 (setq r
(sinrx (cadr e
) ivar
)))
1744 (return (list m r k
))))))
1746 ;; Look at an expression e of the form sin(r*x) and return r.
1747 (defun sinrx (e ivar
)
1748 (cond ((and (consp e
) (eq (caar e
) '%sin
))
1749 (cond ((eq (cadr e
) ivar
)
1751 ((and (setq e
(partition (cadr e
) ivar
1))
1757 ;; integrate(a*sc(r*x)^k/x^n,x,0,inf).
1758 (defun ssp (exp ivar
)
1760 ;; Get the argument of the involved trig function.
1761 (when (null (setq arg
(involve-var exp ivar
'(%sin %cos
))))
1763 ;; I don't think this needs to be special.
1765 (declare (special n
))
1766 ;; Replace (1-cos(arg)^2) with sin(arg)^2.
1767 (setq exp
($substitute
;(m^t `((%sin) ,ivar) 2.)
1768 ;(m+t 1. (m- (m^t `((%cos) ,ivar) 2.)))
1769 ;; The code from above generates expressions with
1770 ;; a missing simp flag. Furthermore, the
1771 ;; substitution has to be done for the complete
1772 ;; argument of the trig function. (DK 02/2010)
1773 `((mexpt simp
) ((%sin simp
) ,arg
) 2)
1774 `((mplus) 1 ((mtimes) -
1 ((mexpt) ((%cos
) ,arg
) 2)))
1776 (numden-var exp ivar
)
1778 (cond ((and (setq n
(findp dn
* ivar
))
1779 (eq (ask-integer n
'$integer
) '$yes
))
1780 ;; n is the power of the denominator.
1781 (cond ((setq c
(skr u ivar
))
1783 (return (scmp c n ivar
)))
1785 (setq c
(andmapcar #'(lambda (uu)
1788 ;; Do this for a sum of such terms.
1789 (return (m+l
(mapcar #'(lambda (j) (scmp j n ivar
))
1792 ;; We have an integral of the form sin(r*x)^k/x^n. C is the list (1 r k).
1794 ;; The substitution y=r*x converts this integral to
1796 ;; r^(n-1)*integral(sin(y)^k/y^n,y,0,inf)
1798 ;; (If r is negative, we need to negate the result.)
1800 ;; The recursion Wang gives on p. 87 has a typo. The second term
1801 ;; should be subtracted from the first. This formula is given in G&R,
1802 ;; 3.82, formula 12.
1804 ;; integrate(sin(x)^r/x^s,x) =
1805 ;; r*(r-1)/(s-1)/(s-2)*integrate(sin(x)^(r-2)/x^(s-2),x)
1806 ;; - r^2/(s-1)/(s-2)*integrate(sin(x)^r/x^(s-2),x)
1808 ;; (Limits are assumed to be 0 to inf.)
1810 ;; This recursion ends up with integrals with s = 1 or 2 and
1812 ;; integrate(sin(x)^p/x,x,0,inf) = integrate(sin(x)^(p-1),x,0,%pi/2)
1814 ;; with p > 0 and odd. This latter integral is known to maxima, and
1815 ;; it's value is beta(p/2,1/2)/2.
1817 ;; integrate(sin(x)^2/x^2,x,0,inf) = %pi/2*binomial(q-3/2,q-1)
1821 (defun scmp (c n ivar
)
1822 ;; Compute sign(r)*r^(n-1)*integrate(sin(y)^k/y^n,y,0,inf)
1823 (destructuring-bind (mult r k
)
1825 (let ((recursion (sinsp k n
)))
1831 ;; Recursion failed. Return the integrand
1832 ;; The following code generates expressions with a missing simp flag
1833 ;; for the sin function. Use better simplifying code. (DK 02/2010)
1834 ; (let ((integrand (div (pow `((%sin) ,(m* r ivar))
1837 (let ((integrand (div (power (take '(%sin
) (mul r ivar
))
1841 `((%integrate
) ,integrand
,ivar
,*ll
* ,*ul
*)))))))
1843 ;; integrate(sin(x)^n/x^2,x,0,inf) = pi/2*binomial(n-3/2,n-1).
1844 ;; Express in terms of Gamma functions, though.
1846 (m* half%pi
($makegamma
`((%binomial
) ,(m+t
(m+ n -
1) '((rat) -
1 2))
1850 ;; integrate(sin(x)^n/x,x,0,inf) = beta((n+1)/2,1/2)/2, for n odd and
1855 (t (bygamma (m+ n -
1) 0.
))))
1857 ;; This implements the recursion for computing
1858 ;; integrate(sin(y)^l/y^k,y,0,inf). (Note the change in notation from
1863 (cond ((eq ($sign
(m+ l
(m- (m+ k -
1))))
1865 ;; Integral diverges if l-(k-1) < 0.
1867 ((not (even1 (m+ l k
)))
1868 ;; If l + k is not even, return NIL. (Is this the right
1872 ;; We have integrate(sin(y)^l/y^2). Use sevn to evaluate.
1875 ;; We have integrate(sin(y)^l/y,y)
1877 ((eq ($sign
(m+ k -
2.
))
1879 (setq i
(m* (m+ k -
1)
1880 (setq j
(m+ k -
2.
))))
1881 ;; j = k-2, i = (k-1)*(k-2)
1884 ;; The main recursion:
1887 ;; = l*(l-1)/(k-1)/(k-2)*i(sin(y)^(l-2)/y^k)
1888 ;; - l^2/(k-1)/(k-1)*i(sin(y)^l/y^(k-2))
1891 (sinsp (m+ l -
2.
) j
))
1896 ;; Returns the fractional part of a?
1900 ;; Why do we return 0 if a is a number? Perhaps we really
1904 ;; If we're here, this basically assumes a is a rational.
1905 ;; Compute the remainder and return the result.
1906 (list (car a
) (rem (cadr a
) (caddr a
)) (caddr a
)))
1907 ((and (atom a
) (abless1 a
)) a
)
1910 (abless1 (caddr a
)))
1913 ;; Doesn't appear to be used anywhere in Maxima. Not sure what this
1914 ;; was intended to do.
1917 (cond ((polyinx e var nil
) 0.
)
1923 (m+l
(mapcar #'thrad e
)))))
1926 ;;; THE FOLLOWING FUNCTION IS FOR TRIG FUNCTIONS OF THE FOLLOWING TYPE:
1927 ;;; LOWER LIMIT=0 B A MULTIPLE OF %PI SCA FUNCTION OF SIN (X) COS (X)
1930 (defun period (p e ivar
)
1931 (and (alike1 (no-err-sub-var ivar e ivar
)
1932 (setq e
(no-err-sub-var (m+ p ivar
) e ivar
)))
1933 ;; means there was no error
1936 ; returns cons of (integer_part . fractional_part) of a
1938 ;; I think we really want to compute how many full periods are in a
1939 ;; and the remainder.
1940 (let* ((q (igprt (div a
(mul 2 '$%pi
))))
1941 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
1944 ; returns cons of (integer_part . fractional_part) of a
1945 (defun lower-infr (a)
1946 ;; I think we really want to compute how many full periods are in a
1947 ;; and the remainder.
1948 (let* (;(q (igprt (div a (mul 2 '$%pi))))
1949 (q (mfuncall '$ceiling
(div a
(mul 2 '$%pi
))))
1950 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
1954 ;; Return the integer part of r.
1957 (mfuncall '$floor r
))
1960 ;;;Try making exp(%i*ivar) --> yy, if result is rational then do integral
1961 ;;;around unit circle. Make corrections for limits of integration if possible.
1962 (defun scrat (sc b ivar
)
1963 (let* ((exp-form (sconvert sc ivar
)) ;Exponentialize
1964 (rat-form (maxima-substitute 'yy
(m^t
'$%e
(m*t
'$%i ivar
))
1965 exp-form
))) ;Try to make Rational fun.
1966 (cond ((and (ratp rat-form
'yy
)
1967 (not (among ivar rat-form
)))
1968 (cond ((alike1 b %pi2
)
1969 (let ((ans (zto%pi2 rat-form
'yy
)))
1973 (evenfn exp-form ivar
))
1974 (let ((ans (zto%pi2 rat-form
'yy
)))
1975 (cond (ans (m*t
'((rat) 1.
2.
) ans
))
1977 ((and (alike1 b half%pi
)
1978 (evenfn exp-form ivar
)
1980 (no-err-sub-var (m+t
'$%pi
(m*t -
1 ivar
))
1983 (let ((ans (zto%pi2 rat-form
'yy
)))
1984 (cond (ans (m*t
'((rat) 1.
4.
) ans
))
1987 ;;; Do integrals of sin and cos. this routine makes sure lower limit
1989 (defun intsc1 (a b e ivar
)
1990 ;; integrate(e,var,a,b)
1991 (let ((trigarg (find-first-trigarg e
))
1994 (*sin-cos-recur
* t
)) ;recursion stopper
1995 (prog (ans d nzp2 l int-zero-to-d int-nzp2 int-zero-to-c limit-diff
)
1996 (let* ((arg (simple-trig-arg trigarg ivar
)) ;; pattern match sin(cc*x + bb)
1999 (new-var (gensym "NEW-VAR-")))
2000 (putprop new-var t
'internal
)
2002 (not (every-trigarg-alike e trigarg
)))
2004 (when (not (and (equal cc
1) (equal bb
0)))
2005 (setq e
(div (maxima-substitute (div (sub new-var bb
) cc
)
2008 (setq ivar new-var
) ;; change of variables to get sin(new-var)
2009 (setq a
(add bb
(mul a cc
)))
2010 (setq b
(add bb
(mul b cc
)))))
2011 (setq limit-diff
(m+ b
(m* -
1 a
)))
2012 (when (or (not (period %pi2 e ivar
))
2013 (member a
*infinities
*)
2014 (member b
*infinities
*)
2015 (not (and ($constantp a
)
2017 ;; Exit if b or a is not a constant or if the integrand
2018 ;; doesn't appear to have a period of 2 pi.
2021 ;; Multiples of 2*%pi in limits.
2022 (cond ((integerp (setq d
(let (($float nil
))
2023 (m// limit-diff %pi2
))))
2024 (cond ((setq ans
(intsc e %pi2 ivar
))
2025 (return (m* d ans
)))
2028 ;; The integral is not over a full period (2*%pi) or multiple
2029 ;; of a full period.
2031 ;; Wang p. 111: The integral integrate(f(x),x,a,b) can be
2034 ;; n * integrate(f,x,0,2*%pi) + integrate(f,x,0,c)
2035 ;; - integrate(f,x,0,d)
2037 ;; for some integer n and d >= 0, c < 2*%pi because there exist
2038 ;; integers p and q such that a = 2 * p *%pi + d and b = 2 * q
2039 ;; * %pi + c. Then n = q - p.
2041 ;; Compute q and c for the upper limit b.
2046 (setq int-zero-to-d
0.
)
2048 ;; Compute p and d for the lower limit a.
2050 ;; avoid an extra trip around the circle - helps skip principal values
2051 (if (ratgreaterp (car b
) (car l
)) ; if q > p
2052 (setq l
(cons (add 1 (car l
)) ; p += 1
2053 (add (mul -
1 %pi2
) (cdr l
))))) ; d -= 2*%pi
2055 ;; Compute -integrate(f,x,0,d)
2057 (cond ((setq ans
(try-intsc e
(cdr l
) ivar
))
2060 ;; Compute n = q - p (stored in nzp2)
2061 (setq nzp2
(m+ (car b
) (m- (car l
))))
2063 ;; Compute n*integrate(f,x,0,2*%pi)
2064 (setq int-nzp2
(cond ((zerop1 nzp2
)
2067 ((setq ans
(try-intsc e %pi2 ivar
))
2068 ;; n is not zero, so compute
2069 ;; integrate(f,x,0,2*%pi)
2071 ;; Unable to compute integrate(f,x,0,2*%pi)
2073 ;; Compute integrate(f,x,0,c)
2074 (setq int-zero-to-c
(try-intsc e
(cdr b
) ivar
))
2076 (return (cond ((and int-zero-to-d int-nzp2 int-zero-to-c
)
2077 ;; All three pieces succeeded.
2078 (add* int-zero-to-d int-nzp2 int-zero-to-c
))
2079 ((ratgreaterp %pi2 limit-diff
)
2080 ;; Less than 1 full period, so intsc can integrate it.
2081 ;; Apply the substitution to make the lower limit 0.
2082 ;; This is last resort because substitution often causes intsc to fail.
2083 (intsc (maxima-substitute (m+ a ivar
) ivar e
)
2088 ;; integrate(sc, var, 0, b), where sc is f(sin(x), cos(x)).
2089 ;; calls intsc with a wrapper to just return nil if integral is divergent,
2090 ;; rather than generating an error.
2091 (defun try-intsc (sc b ivar
)
2092 (let* ((*nodiverg t
)
2093 (ans (catch 'divergent
(intsc sc b ivar
))))
2094 (if (eq ans
'divergent
)
2098 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)). I (rtoy)
2099 ;; think this expects b to be less than 2*%pi.
2100 (defun intsc (sc b ivar
)
2103 (multiple-value-bind (b sc
)
2104 (cond ((eq ($sign b
) '$neg
)
2106 (m* -
1 (subin-var (m*t -
1 ivar
) sc ivar
))))
2109 ;; Partition the integrand SC into the factors that do not
2110 ;; contain VAR (the car part) and the parts that do (the cdr
2112 (setq sc
(partition sc ivar
1))
2113 (cond ((setq b
(intsc0 (cdr sc
) b ivar
))
2114 (m* (resimplify (car sc
)) b
))))))
2116 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)).
2117 (defun intsc0 (sc b ivar
)
2118 ;; Determine if sc is a product of sin's and cos's.
2119 (let ((nn* (scprod sc ivar
))
2122 ;; We have a product of sin's and cos's. We handle some
2123 ;; special cases here.
2124 (cond ((alike1 b half%pi
)
2125 ;; Wang p. 110, formula (1):
2126 ;; integrate(sin(x)^m*cos(x)^n, x, 0, %pi/2) =
2127 ;; gamma((m+1)/2)*gamma((n+1)/2)/2/gamma((n+m+2)/2)
2128 (bygamma (car nn
*) (cadr nn
*)))
2130 ;; Wang p. 110, near the bottom, says
2132 ;; int(f(sin(x),cos(x)), x, 0, %pi) =
2133 ;; int(f(sin(x),cos(x)) + f(sin(x),-cos(x)),x,0,%pi/2)
2134 (cond ((eq (real-branch (cadr nn
*) -
1) '$yes
)
2135 (m* (m+ 1.
(m^ -
1 (cadr nn
*)))
2136 (bygamma (car nn
*) (cadr nn
*))))))
2138 (cond ((or (and (eq (ask-integer (car nn
*) '$even
)
2140 (eq (ask-integer (cadr nn
*) '$even
)
2142 (and (ratnump (car nn
*))
2143 (eq (real-branch (car nn
*) -
1)
2145 (ratnump (cadr nn
*))
2146 (eq (real-branch (cadr nn
*) -
1)
2148 (m* 4.
(bygamma (car nn
*) (cadr nn
*))))
2149 ((or (eq (ask-integer (car nn
*) '$odd
) '$yes
)
2150 (eq (ask-integer (cadr nn
*) '$odd
) '$yes
))
2153 ((alike1 b half%pi3
)
2154 ;; Wang, p. 111 says
2156 ;; int(f(sin(x),cos(x)),x,0,3*%pi/2) =
2157 ;; int(f(sin(x),cos(x)),x,0,%pi)
2158 ;; + int(f(-sin(x),-cos(x)),x,0,%pi/2)
2159 (m* (m+ 1.
(m^ -
1 (cadr nn
*)) (m^ -
1 (m+l nn
*)))
2160 (bygamma (car nn
*) (cadr nn
*))))))
2162 ;; We don't have a product of sin's and cos's.
2163 (cond ((and (or (eq b
'$%pi
)
2166 (setq dn
* (scrat sc b ivar
)))
2168 ((setq nn
* (antideriv sc ivar
))
2169 (sin-cos-intsubs nn
* ivar
0. b
))
2172 ;;;Is careful about substitution of limits where the denominator may be zero
2173 ;;;because of various assumptions made.
2174 (defun sin-cos-intsubs (exp ivar
*ll
* *ul
*)
2176 (let ((l (mapcar #'(lambda (e)
2177 (sin-cos-intsubs1 e ivar
))
2179 (if (not (some #'null l
))
2181 (t (sin-cos-intsubs1 exp ivar
))))
2183 (defun sin-cos-intsubs1 (exp ivar
)
2184 (let* ((rat-exp ($rat exp
))
2185 (denom (pdis (cddr rat-exp
))))
2186 (cond ((equal ($csign denom
) '$zero
)
2188 (t (try-intsubs exp
*ll
* *ul
* ivar
)))))
2190 (defun try-intsubs (exp *ll
* *ul
* ivar
)
2191 (let* ((*nodiverg t
)
2192 (ans (catch 'divergent
(intsubs exp
*ll
* *ul
* ivar
))))
2193 (if (eq ans
'divergent
)
2197 (defun try-defint (exp ivar
*ll
* *ul
*)
2198 (let* ((*nodiverg t
)
2199 (ans (catch 'divergent
(defint exp ivar
*ll
* *ul
*))))
2200 (if (eq ans
'divergent
)
2204 ;; Determine whether E is of the form sin(x)^m*cos(x)^n and return the
2206 (defun scprod (e ivar
)
2207 (let ((great-minus-1 #'(lambda (temp)
2208 (ratgreaterp temp -
1)))
2211 ((setq m
(powerofx e
`((%sin
) ,ivar
) great-minus-1 ivar
))
2213 ((setq n
(powerofx e
`((%cos
) ,ivar
) great-minus-1 ivar
))
2217 (or (setq m
(powerofx (cadr e
) `((%sin
) ,ivar
) great-minus-1 ivar
))
2218 (setq n
(powerofx (cadr e
) `((%cos
) ,ivar
) great-minus-1 ivar
)))
2221 (setq m
(powerofx (caddr e
) `((%sin
) ,ivar
) great-minus-1 ivar
)))
2222 (t (setq n
(powerofx (caddr e
) `((%cos
) ,ivar
) great-minus-1 ivar
))))
2227 (defun real-branch (exponent value
)
2228 ;; Says whether (m^t value exponent) has at least one real branch.
2229 ;; Only works for values of 1 and -1 now. Returns $yes $no
2231 (cond ((equal value
1.
)
2233 ((eq (ask-integer exponent
'$integer
) '$yes
)
2236 (cond ((eq ($oddp
(caddr exponent
)) t
)
2241 ;; Compute beta((m+1)/2,(n+1)/2)/2.
2242 (defun bygamma (m n
)
2243 (let ((one-half (m//t
1.
2.
)))
2244 (m* one-half
`((%beta
) ,(m* one-half
(m+t
1. m
))
2245 ,(m* one-half
(m+t
1. n
))))))
2247 ;;Seems like Guys who call this don't agree on what it should return.
2248 (defun powerofx (e x p ivar
)
2249 (setq e
(cond ((not (among ivar e
)) nil
)
2254 (not (among ivar
(caddr e
))))
2256 (cond ((null e
) nil
)
2260 ;; Check e for an expression of the form x^kk*(b*x^n+a)^l. If it
2261 ;; matches, Return the two values kk and (list l a n b).
2262 (defun bata0 (e ivar
)
2264 (cond ((atom e
) nil
)
2266 ;; We have f(x)^y. Look to see if f(x) has the desired
2267 ;; form. Then f(x)^y has the desired form too, with
2268 ;; suitably modified values.
2270 ;; XXX: Should we ask for the sign of f(x) if y is not an
2271 ;; integer? This transformation we're going to do requires
2272 ;; that f(x)^y be real.
2273 (destructuring-bind (mexp base power
)
2275 (declare (ignore mexp
))
2276 (multiple-value-bind (kk cc
)
2279 ;; Got a match. Adjust kk and cc appropriately.
2280 (destructuring-bind (l a n b
)
2282 (values (mul kk power
)
2283 (list (mul l power
) a n b
)))))))
2286 (or (and (setq k
(findp (cadr e
) ivar
))
2287 (setq c
(bxm (caddr e
) (polyinx (caddr e
) ivar nil
) ivar
)))
2288 (and (setq k
(findp (caddr e
) ivar
))
2289 (setq c
(bxm (cadr e
) (polyinx (cadr e
) ivar nil
) ivar
)))))
2291 ((setq c
(bxm e
(polyinx e ivar nil
) ivar
))
2298 ;; (COND ((NOT (BATA0 E)) (RETURN NIL))
2299 ;; ((AND (EQUAL -1. (CADDDR C))
2300 ;; (EQ ($askSIGN (SETQ K (m+ 1. K)))
2302 ;; (EQ ($askSIGN (SETQ L (m+ 1. (CAR C))))
2305 ;; (m^ UL (CADDR C)))
2306 ;; (SETQ E (CADR C))
2307 ;; (EQ ($askSIGN (SETQ C (CADDR C))) '$pos))
2308 ;; (RETURN (M// (m* (m^ UL (m+t K (m* C (m+t -1. L))))
2309 ;; `(($BETA) ,(SETQ NN* (M// K C))
2314 ;; Integrals of the form i(log(x)^m*x^k*(a+b*x^n)^l,x,0,ul). There
2315 ;; are two cases to consider: One case has ul>0, b<0, a=-b*ul^n, k>-1,
2316 ;; l>-1, n>0, m a nonnegative integer. The second case has ul=inf, l < 0.
2318 ;; These integrals are essentially partial derivatives of the Beta
2319 ;; function (i.e. the Eulerian integral of the first kind). Note
2320 ;; that, currently, with the default setting intanalysis:true, this
2321 ;; function might not even be called for some of these integrals.
2322 ;; However, this can be palliated by setting intanalysis:false.
2324 (defun zto1 (e ivar
)
2325 (when (or (mtimesp e
) (mexptp e
))
2327 (log (list '(%log
) ivar
)))
2330 (find-if #'(lambda (fac)
2331 (powerofx fac log
#'set-m ivar
))
2333 (when (and (freeof ivar m
)
2334 (eq (ask-integer m
'$integer
) '$yes
)
2335 (not (eq ($asksign m
) '$neg
)))
2336 (setq e
(m//t e
(list '(mexpt) log m
)))
2339 (multiple-value-bind (kk s d r cc
)
2341 ;; We have i(x^kk/(d+cc*x^r)^s,x,0,inf) =
2342 ;; beta(aa,bb)/(cc^aa*d^bb*r). Compute this, and then
2343 ;; differentiate it m times to get the log term
2346 (let* ((aa (div (add 1 ivar
) r
))
2348 (m (if (eq ($asksign m
) '$zero
)
2351 (let ((res (div `((%beta
) ,aa
,bb
)
2355 ($at
($diff res ivar m
)
2356 (list '(mequal) ivar kk
)))))))
2358 (multiple-value-bind
2359 (k/n l n b
) (batap-new e ivar
)
2361 (let ((beta (ftake* '%beta k
/n l
))
2362 (m (if (eq ($asksign m
) '$zero
) 0 m
)))
2363 ;; The result looks like B(k/n,l) ( ... ).
2364 ;; Perhaps, we should just $factor, instead of
2365 ;; pulling out beta like this.
2371 (m^t
(m-t b
) (m1-t l
))
2372 (m^t
*ul
* (m*t n
(m1-t l
)))
2373 (m^t n
(m-t (m1+t m
)))
2374 ($at
($diff
(m*t
(m^t
*ul
* (m*t n ivar
))
2375 (list '(%beta
) ivar l
))
2377 (list '(mequal) ivar k
/n
)))
2381 ;;; If e is of the form given below, make the obvious change
2382 ;;; of variables (substituting ul*x^(1/n) for x) in order to reduce
2383 ;;; e to the usual form of the integrand in the Eulerian
2384 ;;; integral of the first kind.
2385 ;;; N. B: The old version of ZTO1 completely ignored this
2386 ;;; substitution; the log(x)s were just thrown in, which,
2387 ;;; of course would give wrong results.
2389 (defun batap-new (e ivar
)
2391 (multiple-value-bind (k c
)
2394 ;; e=x^k*(a+b*x^n)^l
2395 (destructuring-bind (l a n b
)
2397 (when (and (freeof ivar k
)
2400 (alike1 a
(m-t (m*t b
(m^t
*ul
* n
))))
2401 (eq ($asksign b
) '$neg
)
2402 (eq ($asksign
(setq k
(m1+t k
))) '$pos
)
2403 (eq ($asksign
(setq l
(m1+t l
))) '$pos
)
2404 (eq ($asksign n
) '$pos
))
2405 (values (m//t k n
) l n b
))))))
2408 ;; Wang p. 71 gives the following formula for a beta function:
2410 ;; integrate(x^(k-1)/(c*x^r+d)^s,x,0,inf)
2411 ;; = beta(a,b)/(c^a*d^b*r)
2413 ;; where a = k/r > 0, b = s - a > 0, s > k > 0, r > 0, c*d > 0.
2415 ;; This function matches this and returns k-1, d, r, c, a, b. And
2416 ;; also checks that all the conditions hold. If not, NIL is returned.
2418 (defun batap-inf (e ivar
)
2419 (multiple-value-bind (k c
)
2422 (destructuring-bind (l d r cc
)
2424 (let* ((s (mul -
1 l
))
2428 (when (and (freeof ivar k
)
2431 (eq ($asksign kk
) '$pos
)
2432 (eq ($asksign a
) '$pos
)
2433 (eq ($asksign b
) '$pos
)
2434 (eq ($asksign
(sub s k
)) '$pos
)
2435 (eq ($asksign r
) '$pos
)
2436 (eq ($asksign
(mul cc d
)) '$pos
))
2437 (values k s d r cc
)))))))
2440 ;; Handles beta integrals.
2441 (defun batapp (e ivar
)
2442 (cond ((not (or (equal *ll
* 0)
2444 (setq e
(subin-var (m+ *ll
* ivar
) e ivar
))))
2445 (multiple-value-bind (k c
)
2450 (destructuring-bind (l d al c
)
2452 ;; e = x^k*(d+c*x^al)^l.
2453 (let ((new-k (m// (m+ 1 k
) al
)))
2454 (when (and (ratgreaterp al
0.
)
2455 (eq ($asksign new-k
) '$pos
)
2456 (ratgreaterp (setq l
(m* -
1 l
))
2458 (eq ($asksign
(m* d c
))
2460 (setq l
(m+ l
(m*t -
1 new-k
)))
2461 (m// `((%beta
) ,new-k
,l
)
2462 (mul* al
(m^ c new-k
) (m^ d l
))))))))))
2465 ;; Compute exp(d)*gamma((c+1)/b)/b/a^((c+1)/b). In essence, this is
2466 ;; the value of integrate(x^c*exp(d-a*x^b),x,0,inf).
2467 (defun gamma1 (c a b d
)
2469 (m^
(m* b
(m^ a
(setq c
(m// (m+t c
1) b
)))) -
1)
2472 (defun zto%pi2
(grand ivar
)
2473 (let ((result (unitcir (sratsimp (m// grand ivar
)) ivar
)))
2474 (cond (result (sratsimp (m* (m- '$%i
) result
)))
2477 ;; Evaluates the contour integral of GRAND around the unit circle
2479 (defun unitcir (grand ivar
)
2480 (numden-var grand ivar
)
2482 (result (princip (res-var ivar nn
* dn
*
2484 ;; Is pt stricly inside the unit circle?
2485 (setq sgn
(let ((limitp nil
))
2486 ($asksign
(m+ -
1 (cabs pt
)))))
2489 (declare (ignore pt
))
2490 ;; Is pt on the unit circle? (Use
2491 ;; the cached value computed
2495 (setq sgn nil
)))))))
2497 (m* '$%pi result
))))
2500 (defun logx1 (exp *ll
* *ul
* ivar
)
2503 ((and (notinvolve-var exp ivar
'(%sin %cos %tan %atan %asin %acos
))
2504 (setq arg
(involve-var exp ivar
'(%log
))))
2505 (cond ((eq arg ivar
)
2506 (cond ((ratgreaterp 1.
*ll
*)
2507 (cond ((not (eq *ul
* '$inf
))
2508 (intcv1 (m^t
'$%e
(m- 'yx
)) (m- `((%log
) ,ivar
)) ivar
))
2509 (t (intcv1 (m^t
'$%e
'yx
) `((%log
) ,ivar
) ivar
))))))
2510 (t (intcv arg nil ivar
)))))))
2513 ;; Wang 81-83. Unfortunately, the pdf version has page 82 as all
2514 ;; black, so here is, as best as I can tell, what Wang is doing.
2515 ;; Fortunately, p. 81 has the necessary hints.
2517 ;; First consider integrate(exp(%i*k*x^n),x) around the closed contour
2518 ;; consisting of the real axis from 0 to R, the arc from the angle 0
2519 ;; to %pi/(2*n) and the ray from the arc back to the origin.
2521 ;; There are no poles in this region, so the integral must be zero.
2522 ;; But consider the integral on the three parts. The real axis is the
2523 ;; integral we want. The return ray is
2525 ;; exp(%i*%pi/2/n) * integrate(exp(%i*k*(t*exp(%i*%pi/2/n))^n),t,R,0)
2526 ;; = exp(%i*%pi/2/n) * integrate(exp(%i*k*t^n*exp(%i*%pi/2)),t,R,0)
2527 ;; = -exp(%i*%pi/2/n) * integrate(exp(-k*t^n),t,0,R)
2529 ;; As R -> infinity, this last integral is gamma(1/n)/k^(1/n)/n.
2531 ;; We assume the integral on the circular arc approaches 0 as R ->
2532 ;; infinity. (Need to prove this.)
2536 ;; integrate(exp(%i*k*t^n),t,0,inf)
2537 ;; = exp(%i*%pi/2/n) * gamma(1/n)/k^(1/n)/n.
2539 ;; Equating real and imaginary parts gives us the desired results:
2541 ;; integrate(cos(k*t^n),t,0,inf) = G * cos(%pi/2/n)
2542 ;; integrate(sin(k*t^n),t,0,inf) = G * sin(%pi/2/n)
2544 ;; where G = gamma(1/n)/k^(1/n)/n.
2546 (defun scaxn (e ivar
)
2548 (cond ((atom e
) nil
)
2549 ((and (or (eq (caar e
) '%sin
)
2550 (eq (caar e
) '%cos
))
2552 (setq e
(bx**n
(cadr e
) ivar
)))
2553 ;; Ok, we have cos(b*x^n) or sin(b*x^n), and we set e = (n
2555 (cond ((equal (car e
) 1.
)
2556 ;; n = 1. Give up. (Why not divergent?)
2558 ((zerop (setq s
(let ((sign ($asksign
(cadr e
))))
2559 (cond ((eq sign
'$pos
) 1)
2560 ((eq sign
'$neg
) -
1)
2561 ((eq sign
'$zero
) 0)))))
2562 ;; s is the sign of b. Give up if it's zero.
2564 ((not (eq ($asksign
(m+ -
1 (car e
))) '$pos
))
2565 ;; Give up if n-1 <= 0. (Why give up? Isn't the
2566 ;; integral divergent?)
2569 ;; We can apply our formula now. g = gamma(1/n)/n/b^(1/n)
2570 (setq g
(gamma1 0.
(m* s
(cadr e
)) (car e
) 0.
))
2571 (setq e
(m* g
`((,ind
) ,(m// half%pi
(car e
)))))
2572 (m* (cond ((and (eq ind
'%sin
)
2579 ;; this is the second part of the definite integral package
2581 (defun p*lognxp
(a s ivar
)
2583 (cond ((not (among '%log a
))
2585 ((and (polyinx (setq b
(maxima-substitute 1.
`((%log
) ,ivar
) a
))
2587 (eq ($sign
(m+ s
(m+ 1 (deg-var b ivar
))))
2590 (setq a
(lognxp (sratsimp (m// a b
)) ivar
)))
2593 (defun lognxp (a ivar
)
2594 (cond ((atom a
) nil
)
2595 ((and (eq (caar a
) '%log
)
2600 (lognxp (cadr a
) ivar
))
2603 (defun logcpi0 (n d ivar
)
2604 (prog (polelist dp plm rlm factors pl rl pl1 rl1
)
2606 (polelist-var ivar d
#'upperhalf
#'(lambda (j)
2609 ((equal ($imagpart j
) 0)
2611 (cond ((null polelist
)
2613 (setq factors
(car polelist
)
2614 polelist
(cdr polelist
))
2615 (cond ((or (cadr polelist
)
2617 (setq dp
(sdiff d ivar
))))
2618 (cond ((setq plm
(car polelist
))
2619 (setq rlm
(residue-var ivar
2621 (cond (*leadcoef
* factors
)
2624 (cond ((setq pl
(cadr polelist
))
2625 (setq rl
(res1-var ivar n dp pl
))))
2626 (cond ((setq pl1
(caddr polelist
))
2627 (setq rl1
(res1-var ivar n dp pl1
))))
2632 (list (cond ((setq nn
* (append rl rlm
))
2634 (cond (rl1 (m+l rl1
)))))))
2642 (defun lognx2 (nn dn pl rl
)
2643 (do ((pl pl
(cdr pl
))
2649 (setq ans
(cons (m* dn
(car rl
)
2650 ;; AFAICT, this call to PLOG doesn't need
2652 (m^
`((%plog
) ,(car pl
)) nn
))
2655 (defun logcpj (n d i ivar plm pl rl pl1 rl1
)
2658 (list (mul* (m*t
'$%i %pi2
)
2660 ;; AFAICT, this call to PLOG doesn't need
2661 ;; to bind VAR. An example where this is
2663 ;; integrate(log(x)^2/(1+x^2),x,0,1) =
2666 (m* (m^
`((%plog
) ,ivar
) i
)
2670 (lognx2 i
(m*t
'$%i %pi2
) pl rl
)
2671 (lognx2 i %p%i pl1 rl1
)))
2674 (simplify (m+l n
))))
2676 ;; Handle integral(n(x)/d(x)*log(x)^m,x,0,inf). n and d are
2678 (defun log*rat
(n d m ivar
)
2679 (let ((i-vals (make-array (1+ m
)))
2680 (j-vals (make-array (1+ m
))))
2682 ((logcpi (n d c ivar
)
2685 (m* '((rat) 1 2) (m+ (aref j-vals c
) (m* -
1 (sumi c
))))))
2691 (push (mul* ($makegamma
`((%binomial
) ,c
,k
))
2694 (aref i-vals
(- c k
)))
2696 (setf (aref j-vals
0) 0)
2697 (prog (*leadcoef
* res
)
2698 (dotimes (c m
(return (logcpi n d m ivar
)))
2699 (multiple-value-bind (res plm factors pl rl pl1 rl1
)
2701 (setf (aref i-vals c
) res
)
2702 (setf (aref j-vals c
) (logcpj n factors c ivar plm pl rl pl1 rl1
))))))))
2704 (defun fan (p m a n b
)
2705 (let ((povern (m// p n
))
2708 ((or (eq (ask-integer povern
'$integer
) '$yes
)
2709 (not (equal ($imagpart ab
) 0))) ())
2710 (t (let ((ind ($asksign ab
)))
2711 (cond ((eq ind
'$zero
) nil
)
2712 ((eq ind
'$neg
) nil
)
2713 ((not (ratgreaterp m povern
)) nil
)
2715 ($makegamma
`((%binomial
) ,(m+ -
1 m
(m- povern
))
2717 `((mabs) ,(m^ a
(m+ povern
(m- m
)))))
2720 `((%sin
) ,(m*t
'$%pi povern
)))))))))))
2723 ;;Makes a new poly such that np(x)-np(x+2*%i*%pi)=p(x).
2724 ;;Constructs general POLY of degree one higher than P with
2725 ;;arbitrary coeff. and then solves for coeffs by equating like powers
2726 ;;of the varibale of integration.
2727 ;;Can probably be made simpler now.
2729 (defun makpoly (p ivar
)
2730 (let ((n (deg-var p ivar
)) (ans ()) (varlist ()) (gp ()) (cl ()) (zz ()))
2731 (setq ans
(genpoly (m+ 1 n
) ivar
)) ;Make poly with gensyms of 1 higher deg.
2732 (setq cl
(cdr ans
)) ;Coefficient list
2733 (setq varlist
(append cl
(list ivar
))) ;Make VAR most important.
2734 (setq gp
(car ans
)) ;This is the poly with gensym coeffs.
2735 ;;;Now, poly(x)-poly(x+2*%i*%pi)=p(x), P is the original poly.
2736 (setq ans
(m+ gp
(subin-var (m+t
(m*t
'$%i %pi2
) ivar
) (m- gp
) ivar
) (m- p
)))
2738 (setq ans
(ratrep* ans
)) ;Rational rep with VAR leading.
2739 (setq zz
(coefsolve n cl
(cond ((not (eq (caadr ans
) ;What is Lead Var.
2740 (genfind (car ans
) ivar
)))
2741 (list 0 (cadr ans
))) ;No VAR in ans.
2742 ((cdadr ans
))))) ;The real Poly.
2743 (if (or (null zz
) (null gp
))
2745 ($substitute zz gp
)))) ;Substitute Values for gensyms.
2747 (defun coefsolve (n cl e
)
2749 (eql (ncons (pdis (ptterm e n
))) (cons (pdis (ptterm e m
)) eql
))
2750 (m (m+ n -
1) (m+ m -
1)))
2751 ((signp l m
) (solvex eql cl nil nil
))))
2753 ;; Integrate(p(x)*f(exp(x))/g(exp(x)),x,minf,inf) by applying the
2754 ;; transformation y = exp(x) to get
2755 ;; integrate(p(log(y))*f(y)/g(y)/y,y,0,inf). This should be handled
2757 (defun log-transform (p pe d ivar
)
2758 (let ((new-p (subst (list '(%log
) ivar
) ivar p
))
2759 (new-pe (subst ivar
'z
* (catch 'pin%ex
(pin%ex pe ivar
))))
2760 (new-d (subst ivar
'z
* (catch 'pin%ex
(pin%ex d ivar
)))))
2761 (defint (div (div (mul new-p new-pe
) new-d
) ivar
) ivar
0 *ul
*)))
2763 ;; This implements Wang's algorithm in Chapter 5.2, pp. 98-100.
2765 ;; This is a very brief description of the algorithm. Basically, we
2766 ;; have integrate(R(exp(x))*p(x),x,minf,inf), where R(x) is a rational
2767 ;; function and p(x) is a polynomial.
2769 ;; We find a polynomial q(x) such that q(x) - q(x+2*%i*%pi) = p(x).
2770 ;; Then consider a contour integral of R(exp(z))*q(z) over a
2771 ;; rectangular contour. Opposite corners of the rectangle are (-R,
2772 ;; 2*%i*%pi) and (R, 0).
2774 ;; Wang shows that this contour integral, in the limit, is the
2775 ;; integral of R(exp(x))*q(x)-R(exp(x))*q(x+2*%i*%pi), which is
2776 ;; exactly the integral we're looking for.
2778 ;; Thus, to find the value of the contour integral, we just need the
2779 ;; residues of R(exp(z))*q(z). The only tricky part is that we want
2780 ;; the log function to have an imaginary part between 0 and 2*%pi
2781 ;; instead of -%pi to %pi.
2782 (defun rectzto%pi2
(p pe d ivar
)
2783 ;; We have R(exp(x))*p(x) represented as p(x)*pe(exp(x))/d(exp(x)).
2784 (prog (dp n pl a b c denom-exponential
)
2785 (if (not (and (setq denom-exponential
(catch 'pin%ex
(pin%ex d ivar
)))
2786 (%e-integer-coeff pe ivar
)
2787 (%e-integer-coeff d ivar
)))
2789 ;; At this point denom-exponential has converted d(exp(x)) to the
2790 ;; polynomial d(z), where z = exp(x).
2791 (setq n
(m* (cond ((null p
) -
1)
2792 (t ($expand
(m*t
'$%i %pi2
(makpoly p ivar
)))))
2794 (let ((*leadcoef
* ()))
2795 ;; Find the poles of the denominator. denom-exponential is the
2796 ;; denominator of R(x).
2798 ;; It seems as if polelist returns a list of several items.
2799 ;; The first element is a list consisting of the pole and (z -
2800 ;; pole). We don't care about this, so we take the rest of the
2802 (setq pl
(cdr (polelist-var 'z
* denom-exponential
2804 ;; The imaginary part is nonzero,
2805 ;; or the realpart is negative.
2806 (or (not (equal ($imagpart j
) 0))
2807 (eq ($asksign
($realpart j
)) '$neg
)))
2809 ;; The realpart is not zero.
2810 (not (eq ($asksign
($realpart j
)) '$zero
)))))))
2811 ;; Not sure what this does.
2813 ;; No roots at all, so return
2817 ;; We have simple roots or roots in REGION1
2818 (setq dp
(sdiff d ivar
))))
2820 ;; The cadr of pl is the list of the simple poles of
2821 ;; denom-exponential. Take the log of them to find the
2822 ;; poles of the original expression. Then compute the
2823 ;; residues at each of these poles and sum them up and put
2824 ;; the result in B. (If no simple poles set B to 0.)
2825 (setq b
(mapcar #'log-imag-0-2%pi
(cadr pl
)))
2826 (setq b
(res1-var ivar n dp b
))
2830 ;; I think this handles the case of poles outside the
2831 ;; regions. The sum of these residues are placed in C.
2832 (let ((temp (mapcar #'log-imag-0-2%pi
(caddr pl
))))
2833 (setq c
(append temp
(mapcar #'(lambda (j)
2834 (m+ (m*t
'$%i %pi2
) j
))
2836 (setq c
(res1-var ivar n dp c
))
2840 ;; We have the repeated poles of deonom-exponential, so we
2841 ;; need to convert them to the actual pole values for
2842 ;; R(exp(x)), by taking the log of the value of poles.
2843 (let ((poles (mapcar #'(lambda (p)
2844 (log-imag-0-2%pi
(car p
)))
2846 (exp (m// n
(subst (m^t
'$%e ivar
) 'z
* denom-exponential
))))
2847 ;; Compute the residues at all of these poles and sum
2849 (setq a
(mapcar #'(lambda (j)
2850 ($residue exp ivar j
))
2854 (return (sratsimp (m+ a b
(m* '((rat) 1.
2.
) c
))))))
2856 (defun genpoly (i ivar
)
2857 (do ((i i
(m+ i -
1))
2858 (c (gensym) (gensym))
2862 (cons (m+l ans
) cl
))
2863 (setq ans
(cons (m* c
(m^t ivar i
)) ans
))
2864 (setq cl
(cons c cl
))))
2866 ;; Check to see if each term in exp that is of the form exp(k*x) has
2867 ;; an integer value for k.
2868 (defun %e-integer-coeff
(exp ivar
)
2869 (cond ((mapatom exp
) t
)
2871 (eq (cadr exp
) '$%e
))
2872 (eq (ask-integer ($coeff
(caddr exp
) ivar
) '$integer
)
2874 (t (every #'(lambda (e)
2875 (%e-integer-coeff e ivar
))
2878 (defun wlinearpoly (e ivar
)
2879 (cond ((and (setq e
(polyinx e ivar t
))
2880 (equal (deg-var e ivar
) 1))
2881 (subin-var 1 e ivar
))))
2883 ;; Test to see if exp is of the form f(exp(x)), and if so, replace
2884 ;; exp(x) with 'z*. That is, basically return f(z*).
2885 (defun pin%ex
(exp ivar
)
2886 (pin%ex0
(cond ((notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
2889 (let (($exponentialize t
))
2890 (setq exp
($expand exp
)))))
2893 (defun pin%ex0
(e ivar
)
2894 ;; Does e really need to be special here? Seems to be ok without
2895 ;; it; testsuite works.
2897 (declare (special e
))
2898 (cond ((not (among ivar e
))
2901 (throw 'pin%ex nil
))
2904 (cond ((eq (caddr e
) ivar
)
2906 ((let ((linterm (wlinearpoly (caddr e
) ivar
)))
2908 (m* (subin-var 0 e ivar
) (m^t
'z
* linterm
)))))
2910 (throw 'pin%ex nil
))))
2912 (m*l
(mapcar #'(lambda (ee)
2916 (m+l
(mapcar #'(lambda (ee)
2920 (throw 'pin%ex nil
))))
2922 (defun findsub (p ivar
)
2923 (cond ((findp p ivar
) nil
)
2924 ((setq nd
* (bx**n p ivar
))
2925 (m^t ivar
(car nd
*)))
2926 ((setq p
(bx**n
+a p ivar
))
2927 (m* (caddr p
) (m^t ivar
(cadr p
))))))
2929 ;; I think this is looking at f(exp(x)) and tries to find some
2930 ;; rational function R and some number k such that f(exp(x)) =
2932 (defun funclogor%e
(e ivar
)
2933 (prog (ans arg nvar r
)
2934 (cond ((or (ratp e ivar
)
2935 (involve-var e ivar
'(%sin %cos %tan
))
2936 (not (setq arg
(xor (and (setq arg
(involve-var e ivar
'(%log
)))
2938 (%einvolve-var e ivar
)))))
2940 ag
(setq nvar
(cond ((eq r
'%log
) `((%log
) ,arg
))
2941 (t (m^t
'$%e arg
))))
2942 (setq ans
(maxima-substitute (m^t
'yx -
1) (m^t nvar -
1) (maxima-substitute 'yx nvar e
)))
2943 (cond ((not (among ivar ans
)) (return (list (subst ivar
'yx ans
) nvar
)))
2945 (setq arg
(findsub arg ivar
)))
2948 ;; Integration by parts.
2950 ;; integrate(u(x)*diff(v(x),x),x,a,b)
2952 ;; = u(x)*v(x)| - integrate(v(x)*diff(u(x),x))
2955 (defun dintbypart (u v a b ivar
)
2956 ;;;SINCE ONLY CALLED FROM DINTLOG TO get RID OF LOGS - IF LOG REMAINS, QUIT
2957 (let ((ad (antideriv v ivar
)))
2958 (cond ((or (null ad
)
2959 (involve-var ad ivar
'(%log
)))
2961 (t (let ((p1 (m* u ad
))
2962 (p2 (m* ad
(sdiff u ivar
))))
2963 (let ((p1-part1 (get-limit p1 ivar b
'$minus
))
2964 (p1-part2 (get-limit p1 ivar a
'$plus
)))
2965 (cond ((or (null p1-part1
)
2968 (t (let ((p2 (let ((*def2
* t
))
2969 (defint p2 ivar a b
))))
2970 (cond (p2 (add* p1-part1
2975 ;; integrate(f(exp(k*x)),x,a,b), where f(z) is rational.
2977 ;; See Wang p. 96-97.
2979 ;; If the limits are minf to inf, we use the substitution y=exp(k*x)
2980 ;; to get integrate(f(y)/y,y,0,inf)/k. If the limits are 0 to inf,
2981 ;; use the substitution s+1=exp(k*x) to get
2982 ;; integrate(f(s+1)/(s+1),s,0,inf).
2983 (defun dintexp (exp ivar
&aux ans
)
2984 (let ((*dintexp-recur
* t
)) ;recursion stopper
2985 (cond ((and (sinintp exp ivar
) ;To be moved higher in the code.
2986 (setq ans
(antideriv exp ivar
))
2987 (setq ans
(intsubs ans
*ll
* *ul
* ivar
)))
2988 ;; If we can integrate it directly, do so and take the
2989 ;; appropriate limits.
2991 ((setq ans
(funclogor%e exp ivar
))
2992 ;; ans is the list (f(x) exp(k*x)).
2993 (cond ((and (equal *ll
* 0.
)
2995 ;; Use the substitution s + 1 = exp(k*x). The
2996 ;; integral becomes integrate(f(s+1)/(s+1),s,0,inf)
2997 (setq ans
(m+t -
1 (cadr ans
))))
2999 ;; Use the substitution y=exp(k*x) because the
3000 ;; limits are minf to inf.
3001 (setq ans
(cadr ans
))))
3002 ;; Apply the substitution and integrate it.
3003 (intcv ans nil ivar
)))))
3005 ;; integrate(log(g(x))*f(x),x,0,inf)
3006 (defun dintlog (exp arg ivar
)
3007 (let ((*dintlog-recur
* (1+ *dintlog-recur
*))) ;recursion stopper
3009 (cond ((and (eq *ul
* '$inf
)
3012 (equal 1 (sratsimp (m// exp
(m* (m- (subin-var (m^t ivar -
1)
3016 ;; Make the substitution y=1/x. If the integrand has
3017 ;; exactly the same form, the answer has to be 0.
3019 ((and (setq ans
(let (($gamma_expand t
)) (logx1 exp
*ll
* *ul
* ivar
)))
3022 ((setq ans
(antideriv exp ivar
))
3023 ;; It's easy if we have the antiderivative.
3024 ;; but intsubs sometimes gives results containing %limit
3025 (return (intsubs ans
*ll
* *ul
* ivar
))))
3026 ;; Ok, the easy cases didn't work. We now try integration by
3027 ;; parts. Set ANS to f(x).
3028 (setq ans
(m// exp
`((%log
) ,arg
)))
3029 (cond ((involve-var ans ivar
'(%log
))
3030 ;; Bad. f(x) contains a log term, so we give up.
3033 (equal 0.
(no-err-sub-var 0. ans ivar
))
3034 (setq d
(let ((*def2
* t
))
3035 (defint (m* ans
(m^t ivar
'*z
*))
3037 ;; The arg of the log function is the same as the
3038 ;; integration variable. We can do something a little
3039 ;; simpler than integration by parts. We have something
3040 ;; like f(x)*log(x). Consider f(x)*x^z. If we
3041 ;; differentiate this wrt to z, the integrand becomes
3042 ;; f(x)*log(x)*x^z. When we evaluate this at z = 0, we
3043 ;; get the desired integrand.
3045 ;; So we need f(0) to be 0 at 0. If we can integrate
3046 ;; f(x)*x^z, then we differentiate the result and
3047 ;; evaluate it at z = 0.
3048 (return (derivat '*z
* 1. d
0.
)))
3049 ((setq ans
(dintbypart `((%log
) ,arg
) ans
*ll
* *ul
* ivar
))
3050 ;; Try integration by parts.
3053 ;; Compute diff(e,ivar,n) at the point pt.
3054 (defun derivat (ivar n e pt
)
3055 (subin-var pt
(apply '$diff
(list e ivar n
)) ivar
))
3059 ;; MAYBPC returns (COEF EXPO CONST)
3061 ;; This basically picks off b*x^n+a and returns the list
3062 ;; (b n a). It may also set the global *zd*.
3063 (defun maybpc (e ivar
)
3065 (cond (*mtoinf
* (throw 'ggrm
(linpower0 e ivar
)))
3066 ((and (not *mtoinf
*)
3067 (null (setq e
(bx**n
+a e ivar
)))) ;bx**n+a --> (a n b) or nil.
3068 nil
) ;with ivar being x.
3069 ;; At this point, e is of the form (a n b)
3070 ((and (among '$%i
(caddr e
))
3071 (zerop1 ($realpart
(caddr e
)))
3072 (setq zn
($imagpart
(caddr e
)))
3073 (eq ($asksign
(cadr e
)) '$pos
))
3074 ;; If we're here, b is complex, and n > 0. zn = imagpart(b).
3076 ;; Set ivar to the same sign as zn.
3077 (cond ((eq ($asksign zn
) '$neg
)
3081 ;; zd = exp(ivar*%i*%pi*(1+nd)/(2*n). (ZD is special!)
3082 (setq zd
(m^t
'$%e
(m// (mul* ivar
'$%i
'$%pi
(m+t
1 nd
*))
3084 ;; Return zn, n, a, zd.
3085 (values `(,(caddr e
) ,(cadr e
) ,(car e
)) zd
))
3086 ((and (or (eq (setq ivar
($asksign
($realpart
(caddr e
)))) '$neg
)
3087 (equal ivar
'$zero
))
3088 (equal ($imagpart
(cadr e
)) 0)
3089 (ratgreaterp (cadr e
) 0.
))
3090 ;; We're here if realpart(b) <= 0, and n >= 0. Then return -b, n, a.
3091 `(,(caddr e
) ,(cadr e
) ,(car e
))))))
3093 ;; Integrate x^m*exp(b*x^n+a), with realpart(m) > -1.
3095 ;; See Wang, pp. 84-85.
3097 ;; I believe the formula Wang gives is incorrect. The derivation is
3098 ;; correct except for the last step.
3100 ;; Let J = integrate(x^m*exp(%i*k*x^n),x,0,inf), with real k.
3102 ;; Consider the case for k < 0. Take a sector of a circle bounded by
3103 ;; the real line and the angle -%pi/(2*n), and by the radii, r and R.
3104 ;; Since there are no poles inside this contour, the integral
3106 ;; integrate(z^m*exp(%i*k*z^n),z) = 0
3108 ;; Then J = exp(-%pi*%i*(m+1)/(2*n))*integrate(R^m*exp(k*R^n),R,0,inf)
3110 ;; because the integral along the boundary is zero except for the part
3111 ;; on the real axis. (Proof?)
3113 ;; Wang seems to say this last integral is gamma(s/n/(-k)^s) where s =
3114 ;; (m+1)/n. But that seems wrong. If we use the substitution R =
3115 ;; (y/(-k))^(1/n), we end up with the result:
3117 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n).
3119 ;; or gamma((m+1)/n)/k^((m+1)/n)/n.
3121 ;; Note that this also handles the case of
3123 ;; integrate(x^m*exp(-k*x^n),x,0,inf);
3125 ;; where k is positive real number. A simple change of variables,
3128 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n))
3130 ;; which is the same form above.
3131 (defun ggr (e ind ivar
)
3132 (prog (c zd zn nn
* dn
* nd
* dosimp $%emode
)
3134 (cond (ind (setq e
($expand e
))
3135 (cond ((and (mplusp e
)
3136 (let ((*nodiverg t
))
3137 (setq e
(catch 'divergent
3142 (cond ((eq e
'divergent
) nil
)
3143 (t (return (sratsimp (cons '(mplus) e
)))))))))
3144 (setq e
(rmconst1 e ivar
))
3147 (cond ((multiple-value-setq (e zd
)
3149 ;; e = (m b n a). That is, the integral is of the form
3150 ;; x^m*exp(b*x^n+a). I think we want to compute
3151 ;; gamma((m+1)/n)/b^((m+1)/n)/n.
3153 ;; FIXME: If n > m + 1, the integral converges. We need
3154 ;; to check for this.
3155 (destructuring-bind (m b n a
)
3157 (when (and (not (zerop1 ($realpart b
)))
3158 (not (zerop1 ($imagpart b
))))
3159 ;; The derivation only holds if b is purely real or
3160 ;; purely imaginary. Give up if it's not.
3162 ;; Check for convergence. If b is complex, we need n -
3163 ;; m > 1. If b is real, we need b < 0.
3164 (when (and (zerop1 ($imagpart b
))
3165 (not (eq ($asksign b
) '$neg
)))
3167 (when (and (not (zerop1 ($imagpart b
)))
3168 (not (eq ($asksign
(sub n
(add m
1))) '$pos
)))
3171 (setq e
(gamma1 m
(cond ((zerop1 ($imagpart b
))
3172 ;; If we're here, b must be negative.
3175 ;; Complex b. Take the imaginary part
3176 `((mabs) ,($imagpart b
))))
3179 ;; FIXME: Why do we set %emode here? Shouldn't we just
3180 ;; bind it? And why do we want it bound to T anyway?
3181 ;; Shouldn't the user control that? The same goes for
3185 (setq e
(m* zd e
))))))
3186 (cond (e (return (m* c e
))))))
3189 ;; Match x^m*exp(b*x^n+a). If it does, return (list m b n a).
3190 (defun ggr1 (e ivar
)
3192 (cond ((atom e
) nil
)
3195 ;; We're looking at something like exp(f(ivar)). See if it's
3196 ;; of the form b*x^n+a, and return (list 0 b n a). (The 0 is
3197 ;; so we can graft something onto it if needed.)
3198 (cond ((multiple-value-setq (e zd
)
3199 (maybpc (caddr e
) ivar
))
3200 (values (cons 0. e
) zd
))))
3202 ;; E should be the product of exactly 2 terms
3204 ;; Check to see if one of the terms is of the form
3205 ;; ivar^p. If so, make sure the realpart of p > -1. If
3206 ;; so, check the other term has the right form via
3207 ;; another call to ggr1.
3208 (or (and (setq dn
* (xtorterm (cadr e
) ivar
))
3209 (ratgreaterp (setq nd
* ($realpart dn
*))
3211 (multiple-value-setq (nn* zd
)
3212 (ggr1 (caddr e
) ivar
)))
3213 (and (setq dn
* (xtorterm (caddr e
) ivar
))
3214 (ratgreaterp (setq nd
* ($realpart dn
*))
3216 (multiple-value-setq (nn* zd
)
3217 (ggr1 (cadr e
) ivar
)))))
3218 ;; Both terms have the right form and nn* contains the ivar of
3219 ;; the exponential term. Put dn* as the car of nn*. The
3220 ;; result is something like (m b n a) when we have the
3221 ;; expression x^m*exp(b*x^n+a).
3222 (values (rplaca nn
* dn
*) zd
)))))
3225 ;; Match b*x^n+a. If a match is found, return the list (a n b).
3226 ;; Otherwise, return NIL
3227 (defun bx**n
+a
(e ivar
)
3232 (t (let ((a (no-err-sub-var 0. e ivar
)))
3234 (t (setq e
(m+ e
(m*t -
1 a
)))
3235 (cond ((setq e
(bx**n e ivar
))
3239 ;; Match b*x^n. Return the list (n b) if found or NIL if not.
3240 (defun bx**n
(e ivar
)
3242 (and (setq n
(xexponget e ivar
))
3244 (setq e
(let (($maxposex
1)
3246 ($expand
(m// e
(m^t ivar n
)))))))
3249 ;; nn* should be the value of var. This is only called by bx**n with
3250 ;; the second arg of var.
3251 (defun xexponget (e nn
*)
3252 (cond ((atom e
) (cond ((eq e nn
*) 1.
)))
3256 (not (among nn
* (caddr e
))))
3258 (t (some #'(lambda (j) (xexponget j nn
*)) (cdr e
)))))
3261 ;;; given (b*x^n+a)^m returns (m a n b)
3262 (defun bxm (e ind ivar
)
3266 (involve-var e ivar
'(%log %sin %cos %tan
))
3267 (%einvolve-var e ivar
))
3270 ((mexptp e
) (cond ((among ivar
(caddr e
)) nil
)
3271 ((setq r
(bx**n
+a
(cadr e
) ivar
))
3272 (cons (caddr e
) r
))))
3273 ((setq r
(bx**n
+a e ivar
)) (cons 1. r
))
3275 ;;;Catches Unfactored forms.
3276 (setq m
(m// (sdiff e ivar
) e
))
3281 ((and (setq r
(bx**n
+a
(sratsimp r
) ivar
))
3282 (not (among ivar
(setq m
(m// m
(m* (cadr r
) (caddr r
)
3283 (m^t ivar
(m+t -
1 (cadr r
))))))))
3284 (setq e
(m// (subin-var 0. e ivar
) (m^t
(car r
) m
))))
3287 (t (setq e
(m^ e
(m// 1. m
)))
3288 (list m
(m* e
(car r
)) (cadr r
)
3289 (m* e
(caddr r
))))))))
3292 ;;;Is E = VAR raised to some power? If so return power or 0.
3293 (defun findp (e ivar
)
3294 (cond ((not (among ivar e
)) 0.
)
3295 (t (xtorterm e ivar
))))
3297 (defun xtorterm (e ivar
)
3298 ;;;Is E = VAR1 raised to some power? If so return power.
3299 (cond ((alike1 e ivar
) 1.
)
3302 (alike1 (cadr e
) ivar
)
3303 (not (among ivar
(caddr e
))))
3307 (m^
(m* (m^
(caddr l
) '((rat) 1 2))
3308 (m+ (cadr l
) (m^
(m* (car l
) (caddr l
))
3312 (defun radbyterm (d l ivar
)
3317 (destructuring-let (((const . integrand
) (rmconst1 (car l
) ivar
)))
3318 (setq ans
(cons (m* const
(dintrad0 integrand d ivar
))
3321 (defun sqdtc (e ind ivar
)
3322 (prog (a b c varlist
)
3323 (setq varlist
(list ivar
))
3325 (setq e
(cdadr (ratrep* e
)))
3326 (setq c
(pdis (ptterm e
0)))
3327 (setq b
(m*t
(m//t
1 2) (pdis (ptterm e
1))))
3328 (setq a
(pdis (ptterm e
2)))
3329 (cond ((and (eq ($asksign
(m+ b
(m^
(m* a c
)
3333 (not (eq ($asksign a
) '$neg
))
3334 (eq ($asksign c
) '$pos
))
3335 (and (eq ($asksign a
) '$pos
)
3336 (not (eq ($asksign c
) '$neg
)))))
3337 (return (list a b c
))))))
3339 (defun difap1 (e pwr ivar m pt
)
3340 (m// (mul* (cond ((eq (ask-integer m
'$even
) '$yes
)
3344 (derivat ivar m e pt
))
3345 `((%gamma
) ,(m+ pwr m
))))
3347 ;; Note: This doesn't seem be called from anywhere.
3348 (defun sqrtinvolve (e ivar
)
3349 (cond ((atom e
) nil
)
3352 (and (mnump (caddr e
))
3353 (not (numberp (caddr e
)))
3354 (equal (caddr (caddr e
)) 2.
))
3355 (among ivar
(cadr e
)))
3357 (t (some #'(lambda (a)
3358 (sqrtinvolve a ivar
))
3361 (defun bydif (r s d ivar
)
3363 (setq d
(m+ (m*t
'*z
* ivar
) d
))
3364 (cond ((or (zerop1 (setq p
(m+ s
(m*t -
1 r
))))
3365 (and (zerop1 (m+ 1 p
))
3367 (difap1 (dintrad0 b
(m^ d
'((rat) 3 2)) ivar
)
3368 '((rat) 3 2) '*z
* r
0))
3369 ((eq ($asksign p
) '$pos
)
3370 (difap1 (difap1 (dintrad0 1 (m^
(m+t
'z
** d
)
3373 '((rat) 3 2) '*z
* r
0)
3374 '((rat) 3 2) 'z
** p
0)))))
3376 (defun dintrad0 (n d ivar
)
3378 (cond ((and (mexptp d
)
3379 (equal (deg-var (cadr d
) ivar
) 2.
))
3380 (cond ((alike1 (caddr d
) '((rat) 3.
2.
))
3381 (cond ((and (equal n
1.
)
3382 (setq l
(sqdtc (cadr d
) t ivar
)))
3385 (setq l
(sqdtc (cadr d
) nil ivar
)))
3386 (tbf (reverse l
)))))
3387 ((and (setq r
(findp n ivar
))
3388 (or (eq ($asksign
(m+ -
1.
(m- r
) (m*t
2.
3392 (setq s
(m+ '((rat) -
3.
2.
) (caddr d
)))
3393 (eq ($asksign s
) '$pos
)
3394 (eq (ask-integer s
'$integer
) '$yes
))
3395 (bydif r s
(cadr d
) ivar
))
3396 ((polyinx n ivar nil
)
3397 (radbyterm d
(cdr n
) ivar
)))))))
3400 ;;;Looks at the IMAGINARY part of a log and puts it in the interval 0 2*%pi.
3401 (defun log-imag-0-2%pi
(x)
3402 (let ((plog (simplify ($rectform
`((%plog
) ,x
)))))
3403 ;; We take the $rectform above to make sure that the log is
3404 ;; expanded out for the situations where simplifying plog itself
3405 ;; doesn't do it. This should probably be considered a bug in the
3406 ;; plog simplifier and should be fixed there.
3407 (cond ((not (free plog
'%plog
))
3408 (subst '%log
'%plog plog
))
3410 (destructuring-let (((real . imag
) (trisplit plog
)))
3411 (cond ((eq ($asksign imag
) '$neg
)
3412 (setq imag
(m+ imag %pi2
)))
3413 ((eq ($asksign
(m- imag %pi2
)) '$pos
)
3414 (setq imag
(m- imag %pi2
)))
3416 (m+ real
(m* '$%i imag
)))))))
3419 ;;; Temporary fix for a lacking in taylor, which loses with %i in denom.
3420 ;;; Besides doesn't seem like a bad thing to do in general.
3421 (defun %i-out-of-denom
(exp)
3422 (let ((denom ($denom exp
)))
3423 (cond ((among '$%i denom
)
3424 ;; Multiply the denominator by it's conjugate to get rid of
3426 (let* ((den-conj (maxima-substitute (m- '$%i
) '$%i denom
))
3428 (new-denom (sratsimp (m* denom den-conj
)))
3429 (new-exp (sratsimp (m// (m* num den-conj
) new-denom
))))
3430 ;; If the new denominator still contains %i, just give up.
3431 (if (among '$%i
($denom new-exp
))
3436 ;;; LL and UL must be real otherwise this routine return $UNKNOWN.
3437 ;;; Returns $no $unknown or a list of poles in the interval (*ll* *ul*)
3438 ;;; for exp w.r.t. ivar.
3439 ;;; Form of list ((pole . multiplicity) (pole1 . multiplicity) ....)
3440 (defun poles-in-interval (exp ivar
*ll
* *ul
*)
3441 (let* ((denom (cond ((mplusp exp
)
3442 ($denom
(sratsimp exp
)))
3444 (free (caddr exp
) ivar
)
3445 (eq ($asksign
(caddr exp
)) '$neg
))
3446 (m^
(cadr exp
) (m- (caddr exp
))))
3448 (roots (real-roots denom ivar
))
3449 (ll-pole (limit-pole exp ivar
*ll
* '$plus
))
3450 (ul-pole (limit-pole exp ivar
*ul
* '$minus
)))
3451 (cond ((or (eq roots
'$failure
)
3453 (null ul-pole
)) '$unknown
)
3454 ((and (or (eq roots
'$no
)
3455 (member ($csign denom
) '($pos $neg $pn
)))
3456 ;; this clause handles cases where we can't find the exact roots,
3457 ;; but we know that they occur outside the interval of integration.
3458 ;; example: integrate ((1+exp(t))/sqrt(t+exp(t)), t, 0, 1);
3460 (eq ul-pole
'$no
)) '$no
)
3461 (t (cond ((equal roots
'$no
)
3463 (do ((dummy roots
(cdr dummy
))
3464 (pole-list (cond ((not (eq ll-pole
'$no
))
3468 (cond ((not (eq ul-pole
'$no
))
3469 (sort-poles (push `(,*ul
* .
1) pole-list
)))
3470 ((not (null pole-list
))
3471 (sort-poles pole-list
))
3473 (let* ((soltn (caar dummy
))
3474 ;; (multiplicity (cdar dummy)) (not used? -- cwh)
3475 (root-in-ll-ul (in-interval soltn
*ll
* *ul
*)))
3476 (cond ((eq root-in-ll-ul
'$no
) '$no
)
3477 ((eq root-in-ll-ul
'$yes
)
3478 (let ((lim-ans (is-a-pole exp soltn ivar
)))
3479 (cond ((null lim-ans
)
3483 (t (push (car dummy
)
3484 pole-list
))))))))))))
3487 ;;;Returns $YES if there is no pole and $NO if there is one.
3488 (defun limit-pole (exp ivar limit direction
)
3489 (let ((ans (cond ((member limit
'($minf $inf
) :test
#'eq
)
3490 (cond ((eq (special-convergent-formp exp limit ivar
) '$yes
)
3492 (t (get-limit (m* exp ivar
) ivar limit direction
))))
3494 (cond ((eq ans
'$no
) '$no
)
3496 ((eq ans
'$und
) '$no
)
3497 ((equal ans
0.
) '$no
)
3500 ;;;Takes care of forms that the ratio test fails on.
3501 (defun special-convergent-formp (exp limit ivar
)
3502 (cond ((not (oscip-var exp ivar
)) '$no
)
3503 ((or (eq (sc-converg-form exp limit ivar
) '$yes
)
3504 (eq (exp-converg-form exp limit ivar
) '$yes
))
3508 (defun exp-converg-form (exp limit ivar
)
3510 (setq exparg
(%einvolve-var exp ivar
))
3511 (cond ((or (null exparg
)
3512 (freeof '$%i exparg
))
3518 (sratsimp (m// exp
(m^t
'$%e exparg
))))
3520 (equal (get-limit exp ivar limit
) 0))
3524 (defun sc-converg-form (exp limit ivar
)
3525 (prog (scarg trigpow
)
3526 (setq exp
($expand exp
))
3527 (setq scarg
(involve-var (sin-sq-cos-sq-sub exp
) ivar
'(%sin %cos
)))
3528 (cond ((null scarg
) (return '$no
))
3529 ((and (polyinx scarg ivar
())
3530 (eq ($asksign
(m- ($hipow scarg ivar
) 1)) '$pos
))
3532 ((not (freeof ivar
(sdiff scarg ivar
)))
3534 ((and (setq trigpow
($hipow exp
`((%sin
) ,scarg
)))
3535 (eq (ask-integer trigpow
'$odd
) '$yes
)
3536 (equal (get-limit (m// exp
`((%sin
) ,scarg
)) ivar limit
)
3539 ((and (setq trigpow
($hipow exp
`((%cos
) ,scarg
)))
3540 (eq (ask-integer trigpow
'$odd
) '$yes
)
3541 (equal (get-limit (m// exp
`((%cos
) ,scarg
)) ivar limit
)
3544 (t (return '$no
)))))
3546 (defun is-a-pole (exp soltn ivar
)
3548 (m* (maxima-substitute (m+ 'epsilon soltn
) ivar exp
)
3552 (defun in-interval (place *ll
* *ul
*)
3553 ;; real values for *ll* and *ul*; place can be imaginary.
3554 (let ((order (ask-greateq *ul
* *ll
*)))
3555 (cond ((eq order
'$yes
))
3556 ((eq order
'$no
) (let ((temp *ul
*)) (setq *ul
* *ll
* *ll
* temp
)))
3557 (t (merror (intl:gettext
"defint: failed to order limits of integration:~%~M")
3558 (list '(mlist simp
) *ll
* *ul
*)))))
3559 (if (not (equal ($imagpart place
) 0))
3561 (let ((lesseq-ul (ask-greateq *ul
* place
))
3562 (greateq-ll (ask-greateq place
*ll
*)))
3563 (if (and (eq lesseq-ul
'$yes
) (eq greateq-ll
'$yes
)) '$yes
'$no
))))
3565 ;; returns true or nil
3566 (defun strictly-in-interval (place *ll
* *ul
*)
3567 ;; real values for *ll* and *ul*; place can be imaginary.
3568 (and (equal ($imagpart place
) 0)
3570 (eq ($asksign
(m+ *ul
* (m- place
))) '$pos
))
3571 (or (eq *ll
* '$minf
)
3572 (eq ($asksign
(m+ place
(m- *ll
*))) '$pos
))))
3574 (defun real-roots (exp ivar
)
3575 (let (($solvetrigwarn
(cond (defintdebug t
) ;Rest of the code for
3576 (t ()))) ;TRIGS in denom needed.
3577 ($solveradcan
(cond ((or (among '$%i exp
)
3578 (among '$%e exp
)) t
)
3580 *roots
*failures
) ;special vars for solve.
3581 (cond ((not (among ivar exp
)) '$no
)
3582 (t (solve exp ivar
1)
3583 ;; If *failures is set, we may have missed some roots.
3584 ;; We still return the roots that we have found.
3585 (do ((dummy *roots
(cddr dummy
))
3588 (cond ((not (null rootlist
))
3591 (cond ((equal ($imagpart
(caddar dummy
)) 0)
3594 ($rectform
(caddar dummy
))
3598 (defun ask-greateq (x y
)
3599 ;;; Is x > y. X or Y can be $MINF or $INF, zeroA or zeroB.
3600 (let ((x (cond ((among 'zeroa x
)
3605 (subst 0 'epsilon x
))
3606 ((or (among '$inf x
)
3610 (y (cond ((among 'zeroa y
)
3615 (subst 0 'epsilon y
))
3616 ((or (among '$inf y
)
3628 (t (let ((ans ($asksign
(m+ x
(m- y
)))))
3629 (cond ((member ans
'($zero $pos
) :test
#'eq
)
3635 (defun sort-poles (pole-list)
3636 (sort pole-list
#'(lambda (x y
)
3637 (cond ((eq (ask-greateq (car x
) (car y
))
3642 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3644 ;;; Integrate Definite Integrals involving log and exp functions. The algorithm
3645 ;;; are taken from the paper "Evaluation of CLasses of Definite Integrals ..."
3646 ;;; by K.O.Geddes et. al.
3648 ;;; 1. CASE: Integrals generated by the Gamma function.
3653 ;;; I t log (t) expt(- t ) dt = s signum(s)
3660 ;;; (--- (gamma(z))! )
3666 ;;; The integral converges for:
3667 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3669 ;;; 2. CASE: Integrals generated by the Incomplete Gamma function.
3674 ;;; I t log (t) exp(- t ) dt = (--- (gamma_incomplete(a, x ))! )
3682 ;;; The integral converges for:
3683 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3684 ;;; The shown solution is valid for s>0. For s<0 gamma_incomplete has to be
3685 ;;; replaced by gamma(a) - gamma_incomplete(a,x^s).
3687 ;;; 3. CASE: Integrals generated by the beta function.
3692 ;;; I log (1 - t) (1 - t) t log (t) dt =
3700 ;;; --- (--- (beta(z, w))! )!
3706 ;;; The integral converges for:
3707 ;;; n, m = 0, 1, 2, ..., s > -1 and r > -1.
3708 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3710 (defvar *debug-defint-log
* nil
)
3712 ;;; Recognize c*z^w*log(z)^m*exp(-t^s)
3714 (defun m2-log-exp-1 (expr ivar
)
3715 (when *debug-defint-log
*
3716 (format t
"~&M2-LOG-EXP-1 with ~A~%" expr
))
3720 ((mexpt) (z varp2
,ivar
) (w freevar2
,ivar
))
3721 ((mexpt) $%e
((mtimes) -
1 ((mexpt) (z varp2
,ivar
) (s freevar02
,ivar
))))
3722 ((mexpt) ((%log
) (z varp2
,ivar
)) (m freevar2
,ivar
)))))
3724 ;;; Recognize c*z^r*log(z)^n*(1-z)^s*log(1-z)^m
3726 (defun m2-log-exp-2 (expr ivar
)
3727 (when *debug-defint-log
*
3728 (format t
"~&M2-LOG-EXP-2 with ~A~%" expr
))
3732 ((mexpt) (z varp2
,ivar
) (r freevar2
,ivar
))
3733 ((mexpt) ((%log
) (z varp2
,ivar
)) (n freevar2
,ivar
))
3734 ((mexpt) ((mplus) 1 ((mtimes) -
1 (z varp2
,ivar
))) (s freevar2
,ivar
))
3735 ((mexpt) ((%log
) ((mplus) 1 ((mtimes)-
1 (z varp2
,ivar
)))) (m freevar2
,ivar
)))))
3737 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3739 (defun defint-log-exp (expr ivar
*ll
* *ul
*)
3744 ;; var1 is used as a parameter for differentiation. Add var1>0 to the
3745 ;; database, to get the desired simplification of the differentiation of
3746 ;; the gamma_incomplete function.
3747 (setq *global-defint-assumptions
*
3748 (cons (assume `((mgreaterp) ,var1
0))
3749 *global-defint-assumptions
*))
3752 ((and (eq *ul
* '$inf
)
3753 (setq x
(m2-log-exp-1 expr ivar
)))
3754 ;; The integrand matches the cases 1 and 2.
3755 (let ((c (cdras 'c x
))
3759 ($gamma_expand nil
)) ; No expansion of Gamma functions.
3761 (when *debug-defint-log
*
3762 (format t
"~&DEFINT-LOG-EXP-1:~%")
3763 (format t
"~& : c = ~A~%" c
)
3764 (format t
"~& : w = ~A~%" w
)
3765 (format t
"~& : m = ~A~%" m
)
3766 (format t
"~& : s = ~A~%" s
))
3768 (cond ((and (zerop1 *ll
*)
3771 (not (eq ($sign s
) '$zero
))
3772 (eq ($sign
(div (add w
1) s
)) '$pos
))
3773 ;; Case 1: Generated by the Gamma function.
3776 (simplify (list '(%signum
) s
))
3777 (power s
(mul -
1 (add m
1)))
3778 ($at
($diff
(list '(%gamma
) var1
) var1 m
)
3781 (div (add w
1) s
))))))
3782 ((and (member ($sign
*ll
*) '($pos $pz
))
3784 (or (= m
0) (= m
1)) ; Exclude m>1, because Maxima can not
3785 ; derivate the involved hypergeometric
3787 (or (and (eq ($sign s
) '$neg
)
3788 (eq ($sign
(div (add 1 w
) s
)) '$pos
))
3789 (and (eq ($sign s
) '$pos
)
3790 (eq ($sign
(div (add 1 w
) s
)) '$pos
))))
3791 ;; Case 2: Generated by the Incomplete Gamma function.
3792 (let ((f (if (eq ($sign s
) '$pos
)
3793 (list '(%gamma_incomplete
) var1
(power *ll
* s
))
3794 (sub (list '(%gamma
) var1
)
3795 (list '(%gamma_incomplete
) var1
(power *ll
* s
))))))
3798 (simplify (list '(%signum
) s
))
3799 (power s
(mul -
1 (add m
1)))
3800 ($at
($diff f var1 m
)
3801 (list '(mequal) var1
(div (add 1 w
) s
)))))))
3803 (setq result nil
)))))
3806 (setq x
(m2-log-exp-2 expr ivar
)))
3807 ;; Case 3: Generated by the Beta function.
3808 (let ((c (cdras 'c x
))
3816 (when *debug-defint-log
*
3817 (format t
"~&DEFINT-LOG-EXP-2:~%")
3818 (format t
"~& : c = ~A~%" c
)
3819 (format t
"~& : r = ~A~%" r
)
3820 (format t
"~& : n = ~A~%" n
)
3821 (format t
"~& : s = ~A~%" s
)
3822 (format t
"~& : m = ~A~%" m
))
3824 (cond ((and (integerp m
)
3828 (eq ($sign
(add 1 r
)) '$pos
)
3829 (eq ($sign
(add 1 s
)) '$pos
))
3832 ($at
($diff
($at
($diff
(list '(%beta
) var1 var2
)
3834 (list '(mequal) var2
(add 1 s
)))
3836 (list '(mequal) var1
(add 1 r
))))))
3838 (setq result nil
)))))
3841 ;; Simplify result and set $gamma_expand to global value
3842 (let (($gamma_expand $gamma_expand
)) (sratsimp result
))))
3844 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;