1 ;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancements. ;;;;;
5 ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
6 ;;; All rights reserved ;;;;;
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; (c) copyright 1982 massachusetts institute of technology ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 (macsyma-module defint
)
15 ;;; this is the definite integration package.
16 ;; defint does definite integration by trying to find an
17 ;;appropriate method for the integral in question. the first thing that
18 ;;is looked at is the endpoints of the problem.
20 ;; i(grand,var,a,b) will be used for integrate(grand,var,a,b)
22 ;; References are to "Evaluation of Definite Integrals by Symbolic
23 ;; Manipulation", by Paul S. Wang,
24 ;; (http://www.lcs.mit.edu/publications/pubs/pdf/MIT-LCS-TR-092.pdf;
25 ;; a better copy might be: https://maxima.sourceforge.io/misc/Paul_Wang_dissertation.pdf)
27 ;; nointegrate is a macsyma level flag which inhibits indefinite
29 ;; abconv is a macsyma level flag which inhibits the absolute
32 ;; $defint is the top level function that takes the user input
33 ;;and does minor changes to make the integrand ready for the package.
35 ;; next comes defint, which is the function that does the
36 ;;integration. it is often called recursively from the bowels of the
37 ;;package. defint does some of the easy cases and dispatches to:
39 ;; dintegrate. this program first sees if the limits of
40 ;;integration are 0,inf or minf,inf. if so it sends the problem to
41 ;;ztoinf or mtoinf, respectively.
42 ;; else, dintegrate tries:
44 ;; intsc1 - does integrals of sin's or cos's or exp(%i var)'s
45 ;; when the interval is 0,2 %pi or 0,%pi.
46 ;; method is conversion to rational function and find
47 ;; residues in the unit circle. [wang, pp 107-109]
49 ;; ratfnt - does rational functions over finite interval by
50 ;; doing polynomial part directly, and converting
51 ;; the rational part to an integral on 0,inf and finding
52 ;; the answer by residues.
54 ;; zto1 - i(x^(k-1)*(1-x)^(l-1),x,0,1) = beta(k,l) or
55 ;; i(log(x)*x^(x-1)*(1-x)^(l-1),x,0,1) = psi...
58 ;; dintrad- i(x^m/(a*x^2+b*x+c)^(n+3/2),x,0,inf) [wang, p 74]
60 ;; dintlog- i(log(g(x))*f(x),x,0,inf) = 0 (by symmetry) or
61 ;; tries an integration by parts. (only routine to
62 ;; try integration by parts) [wang, pp 93-95]
64 ;; dintexp- i(f(exp(k*x)),x,a,inf) = i(f(x+1)/(x+1),x,0,inf)
65 ;; or i(f(x)/x,x,0,inf)/k. First case hold for a=0;
66 ;; the second for a=minf. [wang 96-97]
68 ;;dintegrate also tries indefinite integration based on certain
69 ;;predicates (such as abconv) and tries breaking up the integrand
70 ;;over a sum or tries a change of variable.
72 ;; ztoinf is the routine for doing integrals over the range 0,inf.
73 ;; it goes over a series of routines and sees if any will work:
75 ;; scaxn - sc(b*x^n) (sc stands for sin or cos) [wang, pp 81-83]
77 ;; ssp - a*sc^n(r*x)/x^m [wang, pp 86,87]
79 ;; zmtorat- rational function. done by multiplication by plog(-x)
80 ;; and finding the residues over the keyhole contour
83 ;; log*rat- r(x)*log^n(x) [wang, pp 89-92]
85 ;; logquad0 log(x)/(a*x^2+b*x+c) uses formula
86 ;; i(log(x)/(x^2+2*x*a*cos(t)+a^2),x,0,inf) =
87 ;; t*log(a)/sin(t). a better formula might be
88 ;; i(log(x)/(x+b)/(x+c),x,0,inf) =
89 ;; (log^2(b)-log^2(c))/(2*(b-c))
91 ;; batapp - x^(p-1)/(b*x^n+a)^m uses formula related to the beta
92 ;; function [wang, p 71]
93 ;; there is also a special case when m=1 and a*b<0
96 ;; sinnu - x^-a*n(x)/d(x) [wang, pp 69-70]
98 ;; ggr - x^r*exp(a*x^n+b)
100 ;; dintexp- see dintegrate
102 ;; ztoinf also tries 1/2*mtoinf if the integrand is an even function
104 ;; mtoinf is the routine for doing integrals on minf,inf.
105 ;; it too tries a series of routines and sees if any succeed.
107 ;; scaxn - when the integrand is an even function, see ztoinf
109 ;; mtosc - exp(%i*m*x)*r(x) by residues on either the upper half
110 ;; plane or the lower half plane, depending on whether
111 ;; m is positive or negative.
113 ;; zmtorat- does rational function by finding residues in upper
116 ;; dintexp- see dintegrate
118 ;; rectzto%pi2 - poly(x)*rat(exp(x)) by finding residues in
119 ;; rectangle [wang, pp98-100]
121 ;; ggrm - x^r*exp((x+a)^n+b)
123 ;; mtoinf also tries 2*ztoinf if the integrand is an even function.
125 (load-macsyma-macros rzmac
)
127 (declare-top (special *mtoinf
*
130 *current-assumptions
*
131 *global-defint-assumptions
*)
132 ;;;rsn* is in comdenom. does a ratsimp of numerator.
134 (special $noprincipal
)
136 (special *roots
*failures
138 ;;LIMITP T Causes $ASKSIGN to do special things
139 ;;For DEFINT like eliminate epsilon look for prin-inf
140 ;;take realpart and imagpart.
142 ;;If LIMITP is non-null ask-integer conses
143 ;;its assumptions onto this list.
146 (defvar *loopstop
* 0)
148 (defmvar $intanalysis t
149 "When @code{true}, definite integration tries to find poles in the integrand
150 in the interval of integration.")
152 ;; Currently, if true, $solvetrigwarn is set to true. No additional
153 ;; debugging information is displayed.
154 (defvar *defintdebug
* ()
155 "If true Defint prints out some debugging information.")
159 "When NIL, print a message that the principal value of the integral has
164 "When non-NIL, a divergent integral will throw to `divergent.
165 Otherwise, an error is signaled that the integral is divergent.")
172 ;; Set to true when OSCIP-VAR returns true in DINTEGRATE.
173 (defvar *scflag
* nil
)
175 (defvar *sin-cos-recur
* nil
176 "Prevents recursion of integrals of sin and cos in intsc1.")
178 (defvar *rad-poly-recur
* nil
179 "Prevents recursion in method-radical-poly.")
181 (defvar *dintlog-recur
* nil
182 "Prevents recursion in dintlog.")
184 (defvar *dintexp-recur
* nil
185 "Prevents recursion in dintexp.")
188 (defmfun $defint
(exp ivar
*ll
* *ul
*)
190 ;; Distribute $defint over equations, lists, and matrices.
195 (mapcar #'(lambda (e)
196 (simplify ($defint e ivar
*ll
* *ul
*)))
199 (let ((*global-defint-assumptions
* ())
200 (integer-info ()) (integerl integerl
) (nonintegerl nonintegerl
))
201 (with-new-context (context)
203 (let ((*defint-assumptions
* ()) (*rad-poly-recur
* ())
204 (*sin-cos-recur
* ()) (*dintexp-recur
* ()) (*dintlog-recur
* 0.
)
205 (ans nil
) (orig-exp exp
) (orig-var ivar
)
206 (orig-ll *ll
*) (orig-ul *ul
*)
207 (*pcprntd
* nil
) (*nodiverg
* nil
) ($logabs t
) ; (limitp t)
209 ($%edispflag nil
) ; to get internal representation
210 ($m1pbranch
())) ;Try this out.
212 (make-global-assumptions) ;sets *global-defint-assumptions*
213 (setq exp
(ratdisrep exp
))
214 (setq ivar
(ratdisrep ivar
))
215 (setq *ll
* (ratdisrep *ll
*))
216 (setq *ul
* (ratdisrep *ul
*))
217 (cond (($constantp ivar
)
218 (merror (intl:gettext
"defint: variable of integration cannot be a constant; found ~M") ivar
))
219 (($subvarp ivar
) (setq ivar
(gensym))
220 (setq exp
($substitute ivar orig-var exp
))))
221 (cond ((not (atom ivar
))
222 (merror (intl:gettext
"defint: variable of integration must be a simple or subscripted variable.~%defint: found ~M") ivar
))
223 ((or (among ivar
*ul
*)
226 (setq exp
($substitute ivar orig-var exp
))))
227 (unless (lenient-extended-realp *ll
*)
228 (merror (intl:gettext
"defint: lower limit of integration must be real; found ~M") *ll
*))
229 (unless (lenient-extended-realp *ul
*)
230 (merror (intl:gettext
"defint: upper limit of integration must be real; found ~M") *ul
*))
232 (cond ((setq ans
(defint exp ivar
*ll
* *ul
*))
233 (setq ans
(subst orig-var ivar ans
))
234 (cond ((atom ans
) ans
)
235 ((and (free ans
'%limit
)
236 (free ans
'%integrate
)
237 (or (not (free ans
'$inf
))
238 (not (free ans
'$minf
))
239 (not (free ans
'$infinity
))))
241 ((not (free ans
'$und
))
242 `((%integrate
) ,orig-exp
,orig-var
,orig-ll
,orig-ul
))
244 (t `((%integrate
) ,orig-exp
,orig-var
,orig-ll
,orig-ul
))))
245 (forget-global-assumptions)))))
247 (defun eezz (exp ll ul ivar
)
248 (cond ((or (polyinx exp ivar nil
)
249 (catch 'pin%ex
(pin%ex exp ivar
)))
250 (setq exp
(antideriv exp ivar
))
251 ;; If antideriv can't do it, returns nil
252 ;; use limit to evaluate every answer returned by antideriv.
253 (cond ((null exp
) nil
)
254 (t (intsubs exp ll ul ivar
))))))
256 ;;;Hack the expression up for exponentials.
258 (defun sinintp (expr ivar
)
259 ;; Is this expr a candidate for SININT ?
260 (let ((expr (factor expr
))
263 (setq numer
($num expr
))
264 (setq denom
($denom expr
))
265 (cond ((polyinx numer ivar nil
)
266 (cond ((and (polyinx denom ivar nil
)
267 (deg-lessp denom ivar
2))
269 ;;ERF type things go here.
270 ((let ((exponent (%einvolve-var numer ivar
)))
271 (and (polyinx exponent ivar nil
)
272 (deg-lessp exponent ivar
2)))
273 (cond ((free denom ivar
)
276 (defun deg-lessp (expr ivar power
)
277 (cond ((or (atom expr
)
281 (do ((ops (cdr expr
) (cdr ops
)))
283 (cond ((not (deg-lessp (car ops
) ivar power
))
286 (and (or (not (alike1 (cadr expr
) ivar
))
287 (and (numberp (caddr expr
))
288 (not (eq (asksign (m+ power
(m- (caddr expr
))))
290 (deg-lessp (cadr expr
) ivar power
)))
292 (member 'array
(car expr
))
293 (not (eq ivar
(caar expr
))))
294 ;; We have some subscripted variable that's not our variable
295 ;; (I think), so it's deg-lessp.
297 ;; FIXME: Is this the best way to handle this? Are there
298 ;; other cases we're mising here?
301 (defun antideriv (a ivar
)
305 (setq ans
(sinint a ivar
))
306 (cond ((among '%integrate ans
) nil
)
307 (t (simplify ans
)))))
309 ;; This routine tries to take a limit a couple of ways.
310 (defun get-limit (exp ivar val
&optional
(dir '$plus dir?
))
312 (funcall #'limit-no-err exp ivar val dir
)
313 (funcall #'limit-no-err exp ivar val
))))
314 (if (and ans
(not (among '%limit ans
)))
316 (when (member val
'($inf $minf
) :test
#'eq
)
317 (setq ans
(limit-no-err (maxima-substitute (m^t ivar -
1) ivar exp
)
320 (if (eq val
'$inf
) '$plus
'$minus
)))
321 (if (among '%limit ans
) nil ans
)))))
323 (defun limit-no-err (&rest argvec
)
324 (let ((errorsw t
) (ans nil
))
325 (setq ans
(catch 'errorsw
(apply #'$limit argvec
)))
326 (if (eq ans t
) nil ans
)))
328 ;; Test whether fun2 is inverse of fun1 at val.
329 (defun test-inverse (fun1 var1 fun2 var2 val
)
330 (let* ((out1 (no-err-sub-var val fun1 var1
))
331 (out2 (no-err-sub-var out1 fun2 var2
)))
334 ;; integration change of variable
335 (defun intcv (nv flag ivar ll ul
)
336 (let ((d (bx**n
+a nv ivar
))
337 (*roots
()) (*failures
()) ($breakup
()))
338 (cond ((and (eq ul
'$inf
)
340 (equal (cadr d
) 1)) ())
341 ((eq ivar
'yx
) ; new ivar cannot be same as old ivar
344 ;; This is a hack! If nv is of the form b*x^n+a, we can
345 ;; solve the equation manually instead of using solve.
346 ;; Why? Because solve asks us for the sign of yx and
349 ;; Solve yx = b*x^n+a, for x. Any root will do. So we
350 ;; have x = ((yx-a)/b)^(1/n).
351 (destructuring-bind (a n b
)
353 (let ((root (power* (div (sub 'yx a
) b
) (inv n
))))
356 (cond (flag (intcv2 d nv ivar ll ul
))
357 (t (intcv1 d nv ivar ll ul
))))
360 (putprop 'yx t
'internal
);; keep ivar from appearing in questions to user
361 (solve (m+t
'yx
(m*t -
1 nv
)) ivar
1.
)
362 (cond ((setq d
;; look for root that is inverse of nv
363 (do* ((roots *roots
(cddr roots
))
364 (root (caddar roots
) (caddar roots
)))
366 (if (and (or (real-infinityp ll
)
367 (test-inverse nv ivar root
'yx ll
))
368 (or (real-infinityp ul
)
369 (test-inverse nv ivar root
'yx ul
)))
371 (cond (flag (intcv2 d nv ivar ll ul
))
372 (t (intcv1 d nv ivar ll ul
))))
375 ;; d: original variable (ivar) as a function of 'yx
377 ;; nv: new variable ('yx) as a function of original variable (ivar)
378 (defun intcv1 (d nv ivar ll ul
)
379 (multiple-value-bind (exp-yx ll1 ul1
)
380 (intcv2 d nv ivar ll ul
)
381 (cond ((and (equal ($imagpart ll1
) 0)
382 (equal ($imagpart ul1
) 0)
383 (not (alike1 ll1 ul1
)))
384 (defint exp-yx
'yx ll1 ul1
)))))
386 ;; converts limits of integration to values for new variable 'yx
387 (defun intcv2 (d nv ivar ll ul
)
388 (flet ((intcv3 (d nv ivar
)
389 ;; rewrites exp, the integrand in terms of ivar, the
390 ;; integrand in terms of 'yx, and returns the new
392 (let ((exp-yx (m* (sdiff d
'yx
)
393 (subst d ivar
(subst 'yx nv exp
)))))
395 (let ((exp-yx (intcv3 d nv ivar
))
397 (and (cond ((and (zerop1 (m+ ll ul
))
399 (setq exp-yx
(m* 2 exp-yx
)
400 ll1
(limcp nv ivar
0 '$plus
)))
401 (t (setq ll1
(limcp nv ivar ll
'$plus
))))
402 (setq ul1
(limcp nv ivar ul
'$minus
))
403 (values exp-yx ll1 ul1
)))))
405 ;; wrapper around limit, returns nil if
406 ;; limit not found (nounform returned), or undefined ($und or $ind)
407 (defun limcp (a b c d
)
408 (let ((ans ($limit a b c d
)))
409 (cond ((not (or (null ans
)
415 (defun integrand-changevar (d newvar exp ivar
)
419 (defun defint (exp ivar
*ll
* *ul
*)
420 (let ((old-assumptions *defint-assumptions
*)
421 (*current-assumptions
* ())
425 (setq *current-assumptions
* (make-defint-assumptions 'noask ivar
))
426 (let ((exp (resimplify exp
))
427 (ivar (resimplify ivar
))
430 ;; D (not used? -- cwh)
431 ans nn
* dn
* $noprincipal
)
432 (cond ((setq ans
(defint-list exp ivar
*ll
* *ul
*))
437 ((not (among ivar exp
))
438 (cond ((or (member *ul
* '($inf $minf
) :test
#'eq
)
439 (member *ll
* '($inf $minf
) :test
#'eq
))
441 (t (setq ans
(m* exp
(m+ *ul
* (m- *ll
*))))
443 ;; Look for integrals which involve log and exp functions.
444 ;; Maxima has a special algorithm to get general results.
445 ((and (setq ans
(defint-log-exp exp ivar
*ll
* *ul
*)))
447 (let* ((exp (rmconst1 exp ivar
))
449 (exp (%i-out-of-denom
(cdr exp
))))
450 (cond ((and (not $nointegrate
)
452 (or (among 'mqapply exp
)
453 (not (member (caar exp
)
454 '(mexpt mplus mtimes %sin %cos
455 %tan %sinh %cosh %tanh
456 %log %asin %acos %atan
459 %derivative
) :test
#'eq
))))
460 ;; Call ANTIDERIV with logabs disabled,
461 ;; because the Risch algorithm assumes
462 ;; the integral of 1/x is log(x), not log(abs(x)).
463 ;; Why not just assume logabs = false within RISCHINT itself?
464 ;; Well, there's at least one existing result which requires
465 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
466 (cond ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
467 (setq ans
(intsubs ans
*ll
* *ul
* ivar
))
468 (return (cond (ans (m* c ans
)) (t nil
))))
470 (setq exp
(tansc-var exp ivar
))
471 (cond ((setq ans
(initial-analysis exp ivar
*ll
* *ul
*))
472 (return (m* c ans
))))
474 (restore-defint-assumptions old-assumptions
*current-assumptions
*))))
476 (defun defint-list (exp ivar
*ll
* *ul
*)
478 (let ((ans (cons (car exp
)
481 (defint sub-exp ivar
*ll
* *ul
*))
483 (cond (ans (simplify ans
))
487 (defun initial-analysis (exp ivar
*ll
* *ul
*)
488 (let ((pole (cond ((not $intanalysis
)
489 '$no
) ;don't do any checking.
490 (t (poles-in-interval exp ivar
*ll
* *ul
*)))))
491 (cond ((eq pole
'$no
)
492 (cond ((and (oddfn exp ivar
)
493 (or (and (eq *ll
* '$minf
)
495 (eq ($sign
(m+ *ll
* *ul
*))
497 (t (parse-integrand exp ivar
*ll
* *ul
*))))
498 ((eq pole
'$unknown
) ())
499 (t (principal-value-integral exp ivar
*ll
* *ul
* pole
)))))
501 (defun parse-integrand (exp ivar ll ul
)
503 (cond ((setq ans
(eezz exp ll ul ivar
)) ans
)
504 ((and (ratp exp ivar
)
505 (setq ans
(method-by-limits exp ivar ll ul
)))
508 (setq ans
(intbyterm exp t ivar ll ul
)))
510 ((setq ans
(method-by-limits exp ivar ll ul
)) ans
)
513 (defun rmconst1 (e ivar
)
514 (cond ((not (freeof ivar e
))
515 (partition e ivar
1))
519 (defun method-by-limits (exp ivar
*ll
* *ul
*)
520 (let ((old-assumptions *defint-assumptions
*))
521 (setq *current-assumptions
* (make-defint-assumptions 'noask ivar
))
522 ;;Should be a PROG inside of unwind-protect, but Multics has a compiler
523 ;;bug wrt. and I want to test this code now.
525 (cond ((and (and (eq *ul
* '$inf
)
527 (mtoinf exp ivar
*ll
* *ul
*)))
528 ((and (and (eq *ul
* '$inf
)
530 (ztoinf exp ivar
*ll
* *ul
*)))
531 ;;;This seems((and (and (eq *ul* '$inf)
532 ;;;fairly losing (setq exp (subin (m+ *ll* ivar) exp))
534 ;;; (ztoinf exp ivar)))
535 ((and (equal *ll
* 0.
)
537 (eq ($asksign
*ul
*) '$pos
)
539 ;; ((and (and (equal *ul* 1.)
540 ;; (equal *ll* 0.)) (zto1 exp)))
541 (t (dintegrate exp ivar
*ll
* *ul
*)))
542 (restore-defint-assumptions old-assumptions
*defint-assumptions
*))))
545 (defun dintegrate (exp ivar
*ll
* *ul
*)
546 (let ((ans nil
) (arg nil
) (*scflag
* nil
)
547 (*dflag
* nil
) ($%emode t
))
548 ;;;NOT COMPLETE for sin's and cos's.
549 (cond ((and (not *sin-cos-recur
*)
552 (intsc1 *ll
* *ul
* exp ivar
)))
553 ((and (not *rad-poly-recur
*)
554 (notinvolve-var exp ivar
'(%log
))
555 (not (%einvolve-var exp ivar
))
556 (method-radical-poly exp ivar
*ll
* *ul
*)))
557 ((and (not (equal *dintlog-recur
* 2.
))
558 (setq arg
(involve-var exp ivar
'(%log
)))
559 (dintlog exp arg ivar
*ll
* *ul
*)))
560 ((and (not *dintexp-recur
*)
561 (setq arg
(%einvolve-var exp ivar
))
562 (dintexp exp ivar
*ll
* *ul
*)))
563 ((and (not (ratp exp ivar
))
564 (setq ans
(let (($trigexpandtimes nil
)
567 (setq ans
($expand ans
))
568 (not (alike1 ans exp
))
569 (intbyterm ans t ivar
*ll
* *ul
*)))
570 ;; Call ANTIDERIV with logabs disabled,
571 ;; because the Risch algorithm assumes
572 ;; the integral of 1/x is log(x), not log(abs(x)).
573 ;; Why not just assume logabs = false within RISCHINT itself?
574 ;; Well, there's at least one existing result which requires
575 ;; logabs = true in RISCHINT, so try to make a minimal change here instead.
576 ((setq ans
(let ($logabs
) (antideriv exp ivar
)))
577 (intsubs ans
*ll
* *ul
* ivar
))
580 (defun method-radical-poly (exp ivar ll ul
)
582 (let ((*rad-poly-recur
* t
) ;recursion stopper
584 (cond ((and (sinintp exp ivar
)
585 (setq result
(antideriv exp ivar
))
586 (intsubs result ll ul ivar
)))
587 ((and (ratp exp ivar
)
588 (setq result
(ratfnt exp ivar ll ul
))))
593 (setq result
(cv exp ivar ll ul
))))
596 (defun principal-value-integral (exp ivar
*ll
* *ul
* poles
)
597 (let ((anti-deriv ()))
598 (cond ((not (null (setq anti-deriv
(antideriv exp ivar
))))
599 (cond ((not (null poles
))
600 (order-limits 'ask ivar
)
601 (cond ((take-principal anti-deriv
*ll
* *ul
* ivar poles
))
604 ;; adds up integrals of ranges between each pair of poles.
605 ;; checks if whole thing is divergent as limits of integration approach poles.
606 (defun take-principal (anti-deriv *ll
* *ul
* ivar poles
&aux ans merged-list
)
607 ;;; calling $logcontract causes antiderivative of 1/(1-x^5) to blow up
608 ;; (setq anti-deriv (cond ((involve anti-deriv '(%log))
609 ;; ($logcontract anti-deriv))
612 (setq merged-list
(interval-list poles
*ll
* *ul
*))
613 (do ((current-pole (cdr merged-list
) (cdr current-pole
))
614 (previous-pole merged-list
(cdr previous-pole
)))
615 ((null current-pole
) t
)
617 (intsubs anti-deriv
(m+ (caar previous-pole
) 'epsilon
)
618 (m+ (caar current-pole
) (m- 'epsilon
))
621 (setq ans
(get-limit (get-limit ans
'epsilon
0 '$plus
) 'prin-inf
'$inf
))
623 (cond ((or (null ans
)
624 (not (free ans
'$infinity
))
625 (not (free ans
'$ind
))) ())
626 ((or (among '$minf ans
)
630 (t (principal) ans
)))
632 (defun interval-list (pole-list *ll
* *ul
*)
633 (let ((first (car (first pole-list
)))
634 (last (caar (last pole-list
))))
635 (cond ((eq *ul
* last
)
637 (setq pole-list
(subst 'prin-inf
'$inf pole-list
))))
638 (t (if (eq *ul
* '$inf
)
639 (setq *ul
* 'prin-inf
))
640 (setq pole-list
(append pole-list
(list (cons *ul
* 'ignored
))))))
641 (cond ((eq *ll
* first
)
643 (setq pole-list
(subst (m- 'prin-inf
) '$minf pole-list
))))
644 (t (if (eq *ll
* '$minf
)
645 (setq *ll
* (m- 'prin-inf
)))
646 (setq pole-list
(append (list (cons *ll
* 'ignored
)) pole-list
)))))
649 ;; Assumes EXP is a rational expression with no polynomial part and
650 ;; converts the finite integration to integration over a half-infinite
651 ;; interval. The substitution y = (x-a)/(b-x) is used. Equivalently,
652 ;; x = (b*y+a)/(y+1).
654 ;; (I'm guessing CV means Change Variable here.)
655 (defun cv (exp ivar ll ul
)
656 (if (not (or (real-infinityp ll
) (real-infinityp ul
)))
657 ;; FIXME! This is a hack. We apply the transformation with
658 ;; symbolic limits and then substitute the actual limits later.
659 ;; That way method-by-limits (usually?) sees a simpler
662 ;; See Bugs 938235 and 941457. These fail because $FACTOR is
663 ;; unable to factor the transformed result. This needs more
664 ;; work (in other places).
665 (let ((trans (integrand-changevar (m// (m+t
'll
(m*t
'ul
'yx
))
668 ;; If the limit is a number, use $substitute so we simplify
669 ;; the result. Do we really want to do this?
670 (setf trans
(if (mnump ll
)
671 ($substitute ll
'll trans
)
672 (subst ll
'll trans
)))
673 (setf trans
(if (mnump ul
)
674 ($substitute ul
'ul trans
)
675 (subst ul
'ul trans
)))
676 (method-by-limits trans
'yx
0.
'$inf
))
679 ;; Integrate rational functions over a finite interval by doing the
680 ;; polynomial part directly, and converting the rational part to an
681 ;; integral from 0 to inf. This is evaluated via residues.
682 (defun ratfnt (exp ivar ll ul
)
683 (let ((e (pqr exp ivar
)))
684 ;; PQR divides the rational expression and returns the quotient
686 (flet ((try-antideriv (e lo hi
)
687 (let ((ans (antideriv e ivar
)))
689 (intsubs ans lo hi ivar
)))))
691 (cond ((equal 0.
(car e
))
692 ;; No polynomial part
693 (let ((ans (try-antideriv exp ll ul
)))
696 (cv exp ivar ll ul
))))
698 ;; Only polynomial part
699 (eezz (car e
) ll ul ivar
))
701 ;; A non-zero quotient and remainder. Combine the results
703 (let ((ans (try-antideriv (m// (cdr e
) dn
*) ll ul
)))
705 (m+t
(eezz (car e
) ll ul ivar
)
708 (m+t
(eezz (car e
) ll ul ivar
)
709 (cv (m// (cdr e
) dn
*) ivar ll ul
))))))))))
711 ;; I think this takes a rational expression E, and finds the
712 ;; polynomial part. A cons is returned. The car is the quotient and
713 ;; the cdr is the remainder.
715 (let ((varlist (list ivar
)))
717 (setq e
(cdr (ratrep* e
)))
718 (setq dn
* (pdis (ratdenominator e
)))
719 (setq e
(pdivide (ratnumerator e
) (ratdenominator e
)))
720 (cons (simplify (rdis (car e
))) (simplify (rdis (cadr e
))))))
723 (defun intbyterm (exp *nodiverg
* ivar
*ll
* *ul
*)
724 (let ((saved-exp exp
))
726 (let ((ans (catch 'divergent
727 (andmapcar #'(lambda (new-exp)
728 (defint new-exp ivar
*ll
* *ul
*))
730 (cond ((null ans
) nil
)
732 (let ((*nodiverg
* nil
))
733 (cond ((setq ans
(antideriv saved-exp ivar
))
734 (intsubs ans
*ll
* *ul
* ivar
))
736 (t (sratsimp (m+l ans
))))))
737 ;;;If leadop isn't plus don't do anything.
740 (defun kindp34 (ivar ll ul
)
741 (let* ((d (nth-value 1 (numden-var exp ivar
)))
742 (a (cond ((and (zerop1 ($limit d ivar ll
'$plus
))
743 (eq (limit-pole (m+ exp
(m+ (m- ll
) ivar
))
748 (b (cond ((and (zerop1 ($limit d ivar ul
'$minus
))
749 (eq (limit-pole (m+ exp
(m+ ul
(m- ivar
)))
757 (cond (*nodiverg
* (throw 'divergent
'divergent
))
758 (t (merror (intl:gettext
"defint: integral is divergent.")))))
760 (defun make-defint-assumptions (ask-or-not ivar
)
761 (cond ((null (order-limits ask-or-not ivar
)) ())
762 (t (mapc 'forget
*defint-assumptions
*)
763 (setq *defint-assumptions
* ())
764 (let ((sign-ll (cond ((eq *ll
* '$inf
) '$pos
)
765 ((eq *ll
* '$minf
) '$neg
)
766 (t ($sign
($limit
*ll
*)))))
767 (sign-ul (cond ((eq *ul
* '$inf
) '$pos
)
768 ((eq *ul
* '$minf
) '$neg
)
769 (t ($sign
($limit
*ul
*)))))
770 (sign-ul-ll (cond ((and (eq *ul
* '$inf
)
771 (not (eq *ll
* '$inf
))) '$pos
)
772 ((and (eq *ul
* '$minf
)
773 (not (eq *ll
* '$minf
))) '$neg
)
774 (t ($sign
($limit
(m+ *ul
* (m- *ll
*))))))))
775 (cond ((eq sign-ul-ll
'$pos
)
776 (setq *defint-assumptions
*
777 `(,(assume `((mgreaterp) ,ivar
,*ll
*))
778 ,(assume `((mgreaterp) ,*ul
* ,ivar
)))))
779 ((eq sign-ul-ll
'$neg
)
780 (setq *defint-assumptions
*
781 `(,(assume `((mgreaterp) ,ivar
,*ul
*))
782 ,(assume `((mgreaterp) ,*ll
* ,ivar
))))))
783 (cond ((and (eq sign-ll
'$pos
)
785 (setq *defint-assumptions
*
786 `(,(assume `((mgreaterp) ,ivar
0))
787 ,@*defint-assumptions
*)))
788 ((and (eq sign-ll
'$neg
)
790 (setq *defint-assumptions
*
791 `(,(assume `((mgreaterp) 0 ,ivar
))
792 ,@*defint-assumptions
*)))
793 (t *defint-assumptions
*))))))
795 (defun restore-defint-assumptions (old-assumptions assumptions
)
796 (do ((llist assumptions
(cdr llist
)))
798 (forget (car llist
)))
799 (do ((llist old-assumptions
(cdr llist
)))
801 (assume (car llist
))))
803 (defun make-global-assumptions ()
804 (setq *global-defint-assumptions
*
805 (cons (assume '((mgreaterp) *z
* 0.
))
806 *global-defint-assumptions
*))
807 ;; *Z* is a "zero parameter" for this package.
808 ;; Its also used to transform.
809 ;; limit(exp,var,val,dir) -- limit(exp,tvar,0,dir)
810 (setq *global-defint-assumptions
*
811 (cons (assume '((mgreaterp) epsilon
0.
))
812 *global-defint-assumptions
*))
813 (setq *global-defint-assumptions
*
814 (cons (assume '((mlessp) epsilon
1.0e-8))
815 *global-defint-assumptions
*))
816 ;; EPSILON is used in principal value code to denote the familiar
817 ;; mathematical entity.
818 (setq *global-defint-assumptions
*
819 (cons (assume '((mgreaterp) prin-inf
1.0e+8))
820 *global-defint-assumptions
*)))
822 ;;; PRIN-INF Is a special symbol in the principal value code used to
823 ;;; denote an end-point which is proceeding to infinity.
825 (defun forget-global-assumptions ()
826 (do ((llist *global-defint-assumptions
* (cdr llist
)))
828 (forget (car llist
)))
829 (cond ((not (null integer-info
))
830 (do ((llist integer-info
(cdr llist
)))
832 (i-$remove
`(,(cadar llist
) ,(caddar llist
)))))))
834 (defun order-limits (ask-or-not ivar
)
835 (cond ((or (not (equal ($imagpart
*ll
*) 0))
836 (not (equal ($imagpart
*ul
*) 0))) ())
837 (t (cond ((alike1 *ll
* (m*t -
1 '$inf
))
839 (cond ((alike1 *ul
* (m*t -
1 '$inf
))
841 (cond ((alike1 *ll
* (m*t -
1 '$minf
))
843 (cond ((alike1 *ul
* (m*t -
1 '$minf
))
845 (cond ((eq *ll
* *ul
*)
846 ; We have minf <= *ll* = *ul* <= inf
849 ; We have minf <= *ll* < *ul* = inf
852 ; We have minf = *ll* < *ul* < inf
860 ; so that minf < *ll* < *ul* = inf
861 (setq exp
(subin-var (m- ivar
) exp ivar
))
862 (setq *ll
* (m- *ul
*))
865 (equal (complm ask-or-not
*ll
* *ul
*) -
1))
866 ; We have minf <= *ul* < *ll*
873 ; so that minf <= *ll* < *ul*
875 (rotatef *ll
* *ul
*)))
878 (defun complm (ask-or-not ll ul
)
879 (let ((askflag (cond ((eq ask-or-not
'ask
) t
)
882 (cond ((alike1 ul ll
) 0.
)
883 ((eq (setq a
(cond (askflag ($asksign
($limit
(m+t ul
(m- ll
)))))
884 (t ($sign
($limit
(m+t ul
(m- ll
)))))))
890 ;; Substitute a and b into integral e
892 ;; Looks for discontinuties in integral, and works around them.
895 ;; integrate(x^(2*n)*exp(-(x)^2),x) ==>
896 ;; -gamma_incomplete((2*n+1)/2,x^2)*x^(2*n+1)*abs(x)^(-2*n-1)/2
898 ;; the integral has a discontinuity at x=0.
900 (defun intsubs (e a b ivar
)
901 (let ((edges (cond ((not $intanalysis
)
902 '$no
) ;don't do any checking.
903 (t (discontinuities-in-interval
904 (let (($algebraic t
))
908 (cond ((or (eq edges
'$no
)
909 (eq edges
'$unknown
))
910 (whole-intsubs e a b ivar
))
912 (do* ((l edges
(cdr l
))
915 (b1 (cadr l
) (cadr l
)))
916 ((null (cdr l
)) (if (every (lambda (x) x
) total
)
919 (whole-intsubs e a1 b1 ivar
)
922 ;; look for terms with a negative exponent
924 ;; recursively traverses exp in order to find discontinuities such as
925 ;; erfc(1/x-x) at x=0
926 (defun discontinuities-denom (exp ivar
)
928 ((and (eq (caar exp
) 'mexpt
)
929 (not (freeof ivar
(cadr exp
)))
930 (not (member ($sign
(caddr exp
)) '($pos $pz
))))
931 (m^
(cadr exp
) (m- (caddr exp
))))
933 (m*l
(mapcar #'(lambda (e)
934 (discontinuities-denom e ivar
))
937 ;; returns list of places where exp might be discontinuous in ivar.
938 ;; list begins with *ll* and ends with *ul*, and include any values between
940 ;; return '$no or '$unknown if no discontinuities found.
941 (defun discontinuities-in-interval (exp ivar ll ul
)
942 (let* ((denom (discontinuities-denom exp ivar
))
943 (roots (real-roots denom ivar
)))
944 (cond ((eq roots
'$failure
)
948 (t (do ((dummy roots
(cdr dummy
))
953 (sortgreat pole-list
)
956 (let ((soltn (caar dummy
)))
957 ;; (multiplicity (cdar dummy)) ;; not used
958 (if (strictly-in-interval soltn ll ul
)
959 (push soltn pole-list
))))))))
962 ;; Carefully substitute the integration limits A and B into the
964 (defun whole-intsubs (e a b ivar
)
965 (cond ((easy-subs e a b ivar
))
966 (t (setq *current-assumptions
*
967 (make-defint-assumptions 'ask ivar
)) ;get forceful!
968 (let (($algebraic t
))
969 (setq e
(sratsimp e
))
970 (cond ((limit-subs e a b ivar
))
971 (t (same-sheet-subs e a b ivar
)))))))
973 ;; Try easy substitutions. Return NIL if we can't.
974 (defun easy-subs (e ll ul ivar
)
975 (cond ((or (infinityp ll
) (infinityp ul
))
976 ;; Infinite limits aren't easy
979 (cond ((or (polyinx e ivar
())
980 (and (not (involve-var e ivar
'(%log %asin %acos %atan %asinh %acosh %atanh %atan2
981 %gamma_incomplete %expintegral_ei
)))
982 (free ($denom e
) ivar
)))
983 ;; It's easy if we have a polynomial. I (rtoy) think
984 ;; it's also easy if the denominator is free of the
985 ;; integration variable and also if the expression
986 ;; doesn't involve inverse functions.
988 ;; gamma_incomplete and expintegral_ie
989 ;; included because of discontinuity in
990 ;; gamma_incomplete(0, exp(%i*x)) and
991 ;; expintegral_ei(exp(%i*x))
993 ;; XXX: Are there other cases we've forgotten about?
995 ;; So just try to substitute the limits into the
996 ;; expression. If no errors are produced, we're done.
997 (let ((ll-val (no-err-sub-var ll e ivar
))
998 (ul-val (no-err-sub-var ul e ivar
)))
999 (cond ((or (eq ll-val t
)
1001 ;; no-err-sub has returned T. An error was catched.
1003 ((and ll-val ul-val
)
1008 (defun limit-subs (e *ll
* *ul
* ivar
)
1009 (cond ((involve-var e ivar
'(%atan %gamma_incomplete %expintegral_ei
))
1010 ()) ; functions with discontinuities
1011 (t (setq e
($multthru e
))
1012 (let ((a1 ($limit e ivar
*ll
* '$plus
))
1013 (a2 ($limit e ivar
*ul
* '$minus
)))
1014 (combine-ll-ans-ul-ans a1 a2
)))))
1016 ;; check for divergent integral
1017 (defun combine-ll-ans-ul-ans (a1 a2
)
1018 (cond ((member a1
'($inf $minf $infinity
) :test
#'eq
)
1019 (cond ((member a2
'($inf $minf $infinity
) :test
#'eq
)
1020 (cond ((eq a2 a1
) ())
1023 ((member a2
'($inf $minf $infinity
) :test
#'eq
) (diverg))
1024 ((or (member a1
'($und $ind
) :test
#'eq
)
1025 (member a2
'($und $ind
) :test
#'eq
)) ())
1028 ;;;This function works only on things with ATAN's in them now.
1029 (defun same-sheet-subs (exp *ll
* *ul
* ivar
&aux ll-ans ul-ans
)
1030 ;; POLES-IN-INTERVAL doesn't know about the poles of tan(x). Call
1031 ;; trigsimp to convert tan into sin/cos, which POLES-IN-INTERVAL
1032 ;; knows how to handle.
1034 ;; XXX Should we fix POLES-IN-INTERVAL instead?
1036 ;; XXX Is calling trigsimp too much? Should we just only try to
1037 ;; substitute sin/cos for tan?
1039 ;; XXX Should the result try to convert sin/cos back into tan? (A
1040 ;; call to trigreduce would do it, among other things.)
1041 (let* ((exp (mfuncall '$trigsimp exp
))
1042 (poles (atan-poles exp
*ll
* *ul
* ivar
)))
1043 ;;POLES -> ((mlist) ((mequal) ((%atan) foo) replacement) ......)
1044 ;;We can then use $SUBSTITUTE
1045 (setq ll-ans
(limcp exp ivar
*ll
* '$plus
))
1046 (setq exp
(sratsimp ($substitute poles exp
)))
1047 (setq ul-ans
(limcp exp ivar
*ul
* '$minus
))
1050 (combine-ll-ans-ul-ans ll-ans ul-ans
)
1053 (defun atan-poles (exp *ll
* *ul
* ivar
)
1054 `((mlist) ,@(atan-pole1 exp
*ll
* *ul
* ivar
)))
1056 (defun atan-pole1 (exp *ll
* *ul
* ivar
&aux ipart
)
1059 ((matanp exp
) ;neglect multiplicity and '$unknowns for now.
1060 (desetq (exp . ipart
) (trisplit exp
))
1062 ((not (equal (sratsimp ipart
) 0)) ())
1063 (t (let ((pole (poles-in-interval (let (($algebraic t
))
1064 (sratsimp (cadr exp
)))
1066 (cond ((and pole
(not (or (eq pole
'$unknown
)
1068 (do ((l pole
(cdr l
)) (llist ()))
1071 ((zerop1 (m- (caar l
) *ll
*)) t
) ; don't worry about discontinuity
1072 ((zerop1 (m- (caar l
) *ul
*)) t
) ; at boundary of integration
1073 (t (let ((low-lim ($limit
(cadr exp
) ivar
(caar l
) '$minus
))
1074 (up-lim ($limit
(cadr exp
) ivar
(caar l
) '$plus
)))
1075 (cond ((and (not (eq low-lim up-lim
))
1076 (real-infinityp low-lim
)
1077 (real-infinityp up-lim
))
1078 (let ((change (if (eq low-lim
'$minf
)
1081 (setq llist
(cons `((mequal simp
) ,exp
,(m+ exp change
))
1082 llist
)))))))))))))))
1083 (t (do ((l (cdr exp
) (cdr l
))
1086 (setq llist
(append llist
(atan-pole1 (car l
) *ll
* *ul
* ivar
)))))))
1088 (defun difapply (ivar n d s fn1
)
1089 (prog (k m r $noprincipal
)
1090 (cond ((eq ($asksign
(m+ (deg-var d ivar
) (m- s
) (m- 2.
))) '$neg
)
1092 (setq $noprincipal t
)
1093 (cond ((or (not (mexptp d
))
1094 (not (numberp (setq r
(caddr d
)))))
1097 ;; There are no calls where fn1 is ever equal to
1098 ;; 'mtorat. Hence this case is never true. What is
1099 ;; this testing for?
1101 (equal 1.
(deg-var (cadr d
) ivar
)))
1103 (setq m
(deg-var (setq d
(cadr d
)) ivar
))
1104 (setq k
(m// (m+ s
2.
) m
))
1105 (cond ((eq (ask-integer (m// (m+ s
2.
) m
) '$any
) '$yes
)
1107 (t (setq k
(m+ 1 k
))))
1108 (cond ((eq ($sign
(m+ r
(m- k
))) '$pos
)
1109 (return (diffhk fn1 n d k
(m+ r
(m- k
)) ivar
))))))
1111 (defun diffhk (fn1 n d r m ivar
)
1114 (setq d1
(funcall fn1 n
1116 (m* r
(deg-var d ivar
))))
1117 (cond (d1 (return (difap1 d1 r
'*z
* m
0.
))))))
1119 (defun principal nil
1120 (cond ($noprincipal
(diverg))
1122 (format t
"Principal Value~%")
1123 (setq *pcprntd
* t
))))
1125 ;; e is of form poly(x)*exp(m*%i*x)
1126 ;; s is degree of denominator
1127 ;; adds e to *bptu* or *bptd* according to sign of m
1128 (defun rib (e s ivar
)
1129 (cond ((or (mnump e
) (constant e
))
1130 (setq *bptu
* (cons e
*bptu
*)))
1133 (setq e
(rmconst1 e ivar
))
1137 (multiple-value-setq (e updn
)
1138 (catch 'ptimes%e
(ptimes%e nn nd ivar
)))
1139 (cond ((null e
) nil
)
1140 (t (setq e
(m* c e
))
1141 (cond (updn (setq *bptu
* (cons e
*bptu
*)))
1142 (t (setq *bptd
* (cons e
*bptd
*))))))))))
1144 ;; Check term is of form poly(x)*exp(m*%i*x)
1145 ;; n is degree of denominator.
1146 (defun ptimes%e
(term n ivar
&aux updn
)
1147 (cond ((and (mexptp term
)
1148 (eq (cadr term
) '$%e
)
1149 (polyinx (caddr term
) ivar nil
)
1150 (eq ($sign
(m+ (deg-var ($realpart
(caddr term
)) ivar
) -
1))
1152 (eq ($sign
(m+ (deg-var (setq nn
* ($imagpart
(caddr term
))) ivar
)
1155 ;; Set updn to T if the coefficient of IVAR in the
1156 ;; polynomial is known to be positive. Otherwise set to NIL.
1157 ;; (What does updn really mean?)
1158 (setq updn
(eq ($asksign
(ratdisrep (ratcoef nn
* ivar
))) '$pos
))
1160 ((and (mtimesp term
)
1161 (setq nn
* (polfactors term ivar
))
1162 (or (null (car nn
*))
1163 (eq ($sign
(m+ n
(m- (deg-var (car nn
*) ivar
))))
1165 (not (alike1 (cadr nn
*) term
))
1166 (multiple-value-setq (term updn
)
1167 (ptimes%e
(cadr nn
*) n ivar
))
1170 (t (throw 'ptimes%e nil
))))
1172 (defun csemidown (n d ivar
)
1173 (let ((*pcprntd
* t
)) ;Not sure what to do about PRINCIPAL values here.
1175 (res-var ivar n d
#'lowerhalf
#'(lambda (x)
1176 (cond ((equal ($imagpart x
) 0) t
)
1179 (defun lowerhalf (j)
1180 (eq ($asksign
($imagpart j
)) '$neg
))
1182 (defun upperhalf (j)
1183 (eq ($asksign
($imagpart j
)) '$pos
))
1186 (defun csemiup (n d ivar
)
1187 (let ((*pcprntd
* t
)) ;I'm not sure what to do about PRINCIPAL values here.
1189 (res-var ivar n d
#'upperhalf
#'(lambda (x)
1190 (cond ((equal ($imagpart x
) 0) t
)
1194 (cond ((null n
) nil
)
1195 (t (m*t
'$%i
($rectform
(m+ (cond ((car n
)
1203 ;; exponentialize sin and cos
1204 (defun sconvert (e ivar
)
1206 ((polyinx e ivar nil
) e
)
1207 ((eq (caar e
) '%sin
)
1210 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1211 (m- (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
)))))))
1212 ((eq (caar e
) '%cos
)
1213 (mul* '((rat) 1.
2.
)
1214 (m+t
(m^t
'$%e
(m*t
'$%i
(cadr e
)))
1215 (m^t
'$%e
(m*t
(m- '$%i
) (cadr e
))))))
1217 (cons (list (caar e
)) (mapcar #'(lambda (ee)
1221 (defun polfactors (exp ivar
)
1223 (cond ((mplusp exp
) nil
)
1224 (t (cond ((mtimesp exp
)
1225 (setq exp
(reverse (cdr exp
))))
1226 (t (setq exp
(list exp
))))
1227 (mapc #'(lambda (term)
1228 (cond ((polyinx term ivar nil
)
1230 (t (push term rest
))))
1232 (list (m*l poly
) (m*l rest
))))))
1236 (cond ((atom e
) (return e
))
1237 ((not (among '$%e e
)) (return e
))
1240 (setq d
($imagpart
(caddr e
)))
1241 (return (m* (m^t
'$%e
($realpart
(caddr e
)))
1243 (m*t
'$%i
`((%sin
) ,d
))))))
1244 (t (return (simplify (cons (list (caar e
))
1245 (mapcar #'esap
(cdr e
)))))))))
1247 ;; computes integral from minf to inf for expressions of the form
1248 ;; exp(%i*m*x)*r(x) by residues on either the upper half
1249 ;; plane or the lower half plane, depending on whether
1250 ;; m is positive or negative. [wang p. 77]
1252 ;; exponentializes sin and cos before applying residue method.
1253 ;; can handle some expressions with poles on real line, such as
1255 (defun mtosc (grand ivar
)
1256 (multiple-value-bind (n d
)
1257 (numden-var grand ivar
)
1258 (let (ratterms ratans
1259 plf
*bptu
* *bptd
* s upans downans
)
1260 (cond ((not (or (polyinx d ivar nil
)
1261 (and (setq grand
(%einvolve-var d ivar
))
1263 (polyinx (setq d
(sratsimp (m// d
(m^t
'$%e grand
))))
1266 (setq n
(m// n
(m^t
'$%e grand
)))))) nil
)
1267 ((equal (setq s
(deg-var d ivar
)) 0) nil
)
1268 ;;;Above tests for applicability of this method.
1269 ((and (or (setq plf
(polfactors n ivar
)) t
)
1270 (setq n
($expand
(cond ((car plf
)
1271 (m*t
'x
* (sconvert (cadr plf
) ivar
)))
1272 (t (sconvert n ivar
)))))
1273 (cond ((mplusp n
) (setq n
(cdr n
)))
1274 (t (setq n
(list n
))))
1276 (cond ((polyinx term ivar nil
)
1277 ;; call to $expand can create rational terms
1278 ;; with no exp(m*%i*x)
1279 (setq ratterms
(cons term ratterms
)))
1282 ;;;Function RIB sets up the values of BPTU and BPTD
1284 (setq *bptu
* (subst (car plf
) 'x
* *bptu
*))
1285 (setq *bptd
* (subst (car plf
) 'x
* *bptd
*))
1286 (setq ratterms
(subst (car plf
) 'x
* ratterms
))
1287 t
) ;CROCK, CROCK. This is TERRIBLE code.
1289 ;;;If there is BPTU then CSEMIUP must succeed.
1290 ;;;Likewise for BPTD.
1293 (let (($intanalysis nil
))
1294 ;; The original integrand was already
1295 ;; determined to have no poles by initial-analysis.
1296 ;; If individual terms of the expansion have poles, the poles
1297 ;; must cancel each other out, so we can ignore them.
1298 (try-defint (m// (m+l ratterms
) d
) ivar
'$minf
'$inf
))
1300 ;; if integral of ratterms is divergent, ratans is nil,
1301 ;; and mtosc returns nil
1303 (cond (*bptu
* (setq upans
(csemiup (m+l
*bptu
*) d ivar
)))
1305 (cond (*bptd
* (setq downans
(csemidown (m+l
*bptd
*) d ivar
)))
1306 (t (setq downans
0))))
1308 (sratsimp (m+ ratans
1309 (m* '$%pi
(m+ upans
(m- downans
))))))))))
1312 (defun evenfn (e ivar
)
1313 (let ((temp (m+ (m- e
)
1315 ($substitute
(m- ivar
) ivar e
))
1316 (t ($ratsubst
(m- ivar
) ivar e
))))))
1317 (cond ((zerop1 temp
)
1319 ((zerop1 (sratsimp temp
))
1323 (defun oddfn (e ivar
)
1324 (let ((temp (m+ e
(cond ((atom ivar
)
1325 ($substitute
(m- ivar
) ivar e
))
1326 (t ($ratsubst
(m- ivar
) ivar e
))))))
1327 (cond ((zerop1 temp
)
1329 ((zerop1 (sratsimp temp
))
1333 (defun ztoinf (grand ivar
*ll
* *ul
*)
1334 (prog (n d sn sd varlist
1336 ans r $savefactors
*checkfactors
* temp test-var
1338 (setq $savefactors t sn
(setq sd
(list 1.
)))
1339 (cond ((eq ($sign
(m+ *loopstop
* -
1))
1342 ((setq temp
(or (scaxn grand ivar
)
1343 (ssp grand ivar
*ll
* *ul
*)))
1345 ((involve-var grand ivar
'(%sin %cos %tan
))
1346 (setq grand
(sconvert grand ivar
))
1349 (cond ((polyinx grand ivar nil
)
1351 ((and (ratp grand ivar
)
1353 (andmapcar #'(lambda (e)
1354 (multiple-value-bind (result new-sn new-sd
)
1355 (snumden-var e ivar sn sd
)
1361 (setq nn-var
(m*l sn
)
1363 (setq dn-var
(m*l sd
)
1365 (t (multiple-value-setq (nn-var dn-var
)
1366 (numden-var grand ivar
))))
1369 (setq n
(rmconst1 nn-var ivar
))
1370 (setq d
(rmconst1 dn-var ivar
))
1375 (cond ((polyinx d ivar nil
)
1376 (setq s
(deg-var d ivar
)))
1378 (cond ((and (setq r
(findp n ivar
))
1379 (eq (ask-integer r
'$integer
) '$yes
)
1380 (setq test-var
(bxm d s ivar
))
1381 (setq ans
(apply 'fan
(cons (m+ 1. r
) test-var
))))
1382 (return (m* (m// nc dc
) (sratsimp ans
))))
1383 ((and (ratp grand ivar
)
1384 (setq ans
(zmtorat n
(cond ((mtimesp d
) d
)
1388 (ztorat n d s ivar
))
1390 (return (m* (m// nc dc
) ans
)))
1391 ((and (evenfn d ivar
)
1392 (setq nn-var
(p*lognxp n s ivar
)))
1393 (setq ans
(log*rat
(car nn-var
) d
(cadr nn-var
) ivar
))
1394 (return (m* (m// nc dc
) ans
)))
1395 ((involve-var grand ivar
'(%log
))
1396 (cond ((setq ans
(logquad0 grand ivar
))
1397 (return (m* (m// nc dc
) ans
)))
1400 (cond ((setq temp
(batapp grand ivar
*ll
* *ul
*))
1404 (cond ((let ((*mtoinf
* nil
))
1405 (setq temp
(ggr grand t ivar
)))
1408 (cond ((let ((*nodiverg
* t
))
1409 (setq ans
(catch 'divergent
1410 (andmapcar #'(lambda (g)
1411 (ztoinf g ivar
*ll
* *ul
*))
1413 (cond ((eq ans
'divergent
) nil
)
1414 (t (return (sratsimp (m+l ans
)))))))))
1416 (cond ((and (evenfn grand ivar
)
1417 (setq *loopstop
* (m+ 1 *loopstop
*))
1418 (setq ans
(method-by-limits grand ivar
'$minf
'$inf
)))
1419 (return (m*t
'((rat) 1.
2.
) ans
)))
1422 (defun ztorat (n d s ivar
)
1423 (cond ((and (null *dflag
*)
1424 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1425 (ztorat n d s ivar
)))))
1427 ((setq n
(let ((plogabs ()))
1428 (keyhole (let ((var ivar
))
1429 (declare (special var
))
1430 ;; It's very important here to bind VAR
1431 ;; because the PLOG simplifier checks
1432 ;; for VAR. Without this, the
1433 ;; simplifier converts plog(-x) to
1434 ;; log(x)+%i*%pi, which messes up the
1436 (m* `((%plog
) ,(m- ivar
)) n
))
1441 ;; Let's not signal an error here. Return nil so that we
1442 ;; eventually return a noun form if no other algorithm gives
1445 (merror (intl:gettext
"defint: keyhole integration failed.~%"))
1448 ;;(setq *dflag* nil)
1450 (defun logquad0 (exp ivar
)
1451 (let ((a ()) (b ()) (c ()))
1452 (cond ((setq exp
(logquad exp ivar
))
1453 (setq a
(car exp
) b
(cadr exp
) c
(caddr exp
))
1454 ($asksign b
) ;let the data base know about the sign of B.
1455 (cond ((eq ($asksign c
) '$pos
)
1456 (setq c
(m^
(m// c a
) '((rat) 1.
2.
)))
1458 `((%acos
) ,(add* 'epsilon
(m// b
(mul* 2. a c
))))))
1459 (setq a
(m// (m* b
`((%log
) ,c
))
1460 (mul* a
(simplify `((%sin
) ,b
)) c
)))
1461 (get-limit a
'epsilon
0 '$plus
))))
1464 (defun logquad (exp ivar
)
1465 (let ((varlist (list ivar
)))
1467 (setq exp
(cdr (ratrep* exp
)))
1468 (cond ((and (alike1 (pdis (car exp
))
1470 (not (atom (cdr exp
)))
1471 (equal (cadr (cdr exp
)) 2.
)
1472 (not (equal (ptterm (cddr exp
) 0.
) 0.
)))
1473 (setq exp
(mapcar 'pdis
(cdr (oddelm (cdr exp
)))))))))
1475 (defun mtoinf (grand ivar
*ll
* *ul
*)
1476 (prog (ans ans1 sd sn pp pe n d s nc dc $savefactors
*checkfactors
* temp
1478 (setq $savefactors t
)
1479 (setq sn
(setq sd
(list 1.
)))
1480 (cond ((eq ($sign
(m+ *loopstop
* -
1)) '$pos
)
1482 ((involve-var grand ivar
'(%sin %cos
))
1483 (cond ((and (evenfn grand ivar
)
1484 (or (setq temp
(scaxn grand ivar
))
1485 (setq temp
(ssp grand ivar
*ll
* *ul
*))))
1486 (return (m*t
2. temp
)))
1487 ((setq temp
(mtosc grand ivar
))
1490 ((among '$%i
(%einvolve-var grand ivar
))
1491 (cond ((setq temp
(mtosc grand ivar
))
1494 (setq grand
($exponentialize grand
)) ; exponentializing before numden
1495 (cond ((polyinx grand ivar nil
) ; avoids losing multiplicities [ 1309432 ]
1497 ((and (ratp grand ivar
)
1499 (andmapcar #'(lambda (e)
1500 (multiple-value-bind (result new-sn new-sd
)
1501 (snumden-var e ivar sn sd
)
1507 (setq nn-var
(m*l sn
) sn nil
)
1508 (setq dn-var
(m*l sd
) sd nil
))
1509 (t (multiple-value-setq (nn-var dn-var
)
1510 (numden-var grand ivar
))))
1511 (setq n
(rmconst1 nn-var ivar
))
1512 (setq d
(rmconst1 dn-var ivar
))
1517 (cond ((polyinx d ivar nil
)
1518 (setq s
(deg-var d ivar
))))
1519 (cond ((and (not (%einvolve-var grand ivar
))
1520 (notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
1521 (setq pp
(findp n ivar
))
1522 (eq (ask-integer pp
'$integer
) '$yes
)
1523 (setq pe
(bxm d s ivar
)))
1524 (cond ((and (eq (ask-integer (caddr pe
) '$even
) '$yes
)
1525 (eq (ask-integer pp
'$even
) '$yes
))
1526 (cond ((setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1527 (setq ans
(m*t
2. ans
))
1528 (return (m* (m// nc dc
) ans
)))))
1529 ((equal (car pe
) 1.
)
1530 (cond ((and (setq ans
(apply 'fan
(cons (m+ 1. pp
) pe
)))
1531 (setq nn-var
(fan (m+ 1. pp
)
1536 (setq ans
(m+ ans
(m*t
(m^ -
1 pp
) nn-var
)))
1537 (return (m* (m// nc dc
) ans
))))))))
1540 ((pppin%ex
(nd ivar
)
1541 ;; Test to see if exp is of the form p(x)*f(exp(x)). If so, set pp to
1542 ;; be p(x) and set pe to f(exp(x)).
1543 (setq nd
($factor nd
))
1544 (cond ((polyinx nd ivar nil
)
1545 (setq pp
(cons nd pp
)) t
)
1546 ((catch 'pin%ex
(pin%ex nd ivar
))
1547 (setq pe
(cons nd pe
)) t
)
1549 (andmapcar #'(lambda (ex)
1552 (cond ((and (ratp grand ivar
)
1553 (setq ans1
(zmtorat n
1554 (cond ((mtimesp d
) d
) (t ($sqfr d
)))
1557 (mtorat n d s ivar
))
1559 (setq ans
(m*t
'$%pi ans1
))
1560 (return (m* (m// nc dc
) ans
)))
1561 ((and (or (%einvolve-var grand ivar
)
1562 (involve-var grand ivar
'(%sinh %cosh %tanh
)))
1563 (pppin%ex n ivar
) ;setq's P* and PE*...Barf again.
1564 (setq ans
(catch 'pin%ex
(pin%ex d ivar
))))
1565 ;; We have an integral of the form p(x)*F(exp(x)), where
1566 ;; p(x) is a polynomial.
1569 (return (dintexp grand ivar
*ll
* *ul
*)))
1570 ((not (and (zerop1 (get-limit grand ivar
'$inf
))
1571 (zerop1 (get-limit grand ivar
'$minf
))))
1572 ;; These limits must exist for the integral to converge.
1574 ((setq ans
(rectzto%pi2
(m*l pp
) (m*l pe
) d ivar
))
1575 ;; This only handles the case when the F(z) is a
1576 ;; rational function.
1577 (return (m* (m// nc dc
) ans
)))
1578 ((setq ans
(log-transform (m*l pp
) (m*l pe
) d ivar
))
1579 ;; If we get here, F(z) is not a rational function.
1580 ;; We transform it using the substitution x=log(y)
1581 ;; which gives us an integral of the form
1582 ;; p(log(y))*F(y)/y, which maxima should be able to
1584 (return (m* (m// nc dc
) ans
)))
1586 ;; Give up. We don't know how to handle this.
1589 (cond ((setq ans
(ggrm grand ivar
))
1591 ((and (evenfn grand ivar
)
1592 (setq *loopstop
* (m+ 1 *loopstop
*))
1593 (setq ans
(method-by-limits grand ivar
0 '$inf
)))
1594 (return (m*t
2. ans
)))
1597 (defun linpower0 (exp ivar
)
1598 (cond ((and (setq exp
(linpower exp ivar
))
1599 (eq (ask-integer (caddr exp
) '$even
)
1601 (ratgreaterp 0.
(car exp
)))
1604 ;;; given (b*x+a)^n+c returns (a b n c)
1605 (defun linpower (exp ivar
)
1606 (let (linpart deg lc c varlist
)
1607 (cond ((not (polyp-var exp ivar
)) nil
)
1608 (t (let ((varlist (list ivar
)))
1610 (setq linpart
(cadr (ratrep* exp
)))
1611 (cond ((atom linpart
)
1613 (t (setq deg
(cadr linpart
))
1614 ;;;get high degree of poly
1615 (setq linpart
($diff exp ivar
(m+ deg -
1)))
1616 ;;;diff down to linear.
1617 (setq lc
(sdiff linpart ivar
))
1618 ;;;all the way to constant.
1619 (setq linpart
(sratsimp (m// linpart lc
)))
1620 (setq lc
(sratsimp (m// lc
`((mfactorial) ,deg
))))
1621 ;;;get rid of factorial from differentiation.
1622 (setq c
(sratsimp (m+ exp
(m* (m- lc
)
1623 (m^ linpart deg
)))))))
1624 ;;;Sees if can be expressed as (a*x+b)^n + part freeof x.
1625 (cond ((not (among ivar c
))
1626 `(,lc
,linpart
,deg
,c
))
1629 (defun mtorat (n d s ivar
)
1630 (let ((*semirat
* t
))
1631 (cond ((and (null *dflag
*)
1632 (setq s
(difapply ivar n d s
#'(lambda (n d s
)
1633 (mtorat n d s ivar
)))))
1635 (t (csemiup n d ivar
)))))
1637 (defun zmtorat (n d s fn1 ivar
)
1639 (cond ((eq ($sign
(m+ s
(m+ 1 (setq nn
* (deg-var n ivar
)))))
1642 ((eq ($sign
(m+ s -
4))
1645 (setq d
($factor d
))
1646 (setq c
(rmconst1 d ivar
))
1652 (setq n
(partnum n d ivar
))
1654 (setq n
($xthru
(m+l
1655 (mapcar #'(lambda (a b
)
1656 (let ((foo (funcall fn1
(car a
) b
(deg-var b ivar
))))
1657 (if foo
(m// foo
(cadr a
))
1658 (return-from zmtorat nil
))))
1661 (return (cond (c (m// n c
))
1665 (setq n
(funcall fn1 n d s
))
1666 (return (when n
(sratsimp (cond (c (m// n c
))
1669 (defun pfrnum (f g n n2 ivar
)
1670 (let ((varlist (list ivar
)) genvar
)
1671 (setq f
(polyform f
)
1675 (setq ivar
(caadr (ratrep* ivar
)))
1676 (setq f
(resprog0-var ivar f g n n2
))
1677 (list (list (pdis (cadr f
)) (pdis (cddr f
)))
1678 (list (pdis (caar f
)) (pdis (cdar f
))))))
1683 (setq f
(ratrep* e
))
1684 (and (equal (cddr f
) 1)
1686 (and (equal (length (setq d
(cddr f
))) 3)
1689 (return (list (car d
)
1691 (ptimes (cadr f
) (caddr d
)))))
1692 (merror "defint: bug from PFRNUM in RESIDU.")))
1694 (defun partnum (n dl ivar
)
1695 (let ((n2 1) ans nl
)
1696 (do ((dl dl
(cdr dl
)))
1698 (nconc ans
(ncons (list n n2
))))
1699 (setq nl
(pfrnum (car dl
) (m*l
(cdr dl
)) n n2 ivar
))
1700 (setq ans
(nconc ans
(ncons (car nl
))))
1701 (setq n2
(cadadr nl
) n
(caadr nl
) nl nil
))))
1703 (defun ggrm (e ivar
)
1704 (prog (poly expo
*mtoinf
* mb varlist genvar l c gvar
)
1705 (setq varlist
(list ivar
))
1707 (cond ((and (setq expo
(%einvolve-var e ivar
))
1708 (polyp-var (setq poly
(sratsimp (m// e
(m^t
'$%e expo
)))) ivar
)
1709 (setq l
(catch 'ggrm
(ggr (m^t
'$%e expo
) nil ivar
))))
1711 (setq mb
(m- (subin-var 0.
(cadr l
) ivar
)))
1712 (setq poly
(m+ (subin-var (m+t mb ivar
) poly ivar
)
1713 (subin-var (m+t mb
(m*t -
1 ivar
)) poly ivar
))))
1715 (setq expo
(caddr l
)
1720 (setq poly
(cdr (ratrep* poly
)))
1721 (setq mb
(m^
(pdis (cdr poly
)) -
1)
1723 (setq gvar
(caadr (ratrep* ivar
)))
1724 (cond ((or (atom poly
)
1725 (pointergp gvar
(car poly
)))
1726 (setq poly
(list 0. poly
)))
1727 (t (setq poly
(cdr poly
))))
1728 (return (do ((poly poly
(cddr poly
)))
1730 (mul* (m^t
'$%e c
) (m^t expo -
1) mb
(m+l e
)))
1731 (setq e
(cons (ggrm1 (car poly
) (pdis (cadr poly
)) l expo
)
1734 (defun ggrm1 (d k a b
)
1735 (setq b
(m// (m+t
1. d
) b
))
1736 (m* k
`((%gamma
) ,b
) (m^ a
(m- b
))))
1738 ;; Compute the integral(n/d,x,0,inf) by computing the negative of the
1739 ;; sum of residues of log(-x)*n/d over the poles of n/d inside the
1740 ;; keyhole contour. This contour is basically an disk with a slit
1741 ;; along the positive real axis. n/d must be a rational function.
1742 (defun keyhole (n d ivar
)
1743 (let* ((*semirat
* ())
1744 (res (res-var ivar n d
1746 ;; Ok if not on the positive real axis.
1747 (or (not (equal ($imagpart j
) 0))
1748 (eq ($asksign j
) '$neg
)))
1750 (cond ((eq ($asksign j
) '$pos
)
1755 ($rectform
($multthru
(m+ (cond ((car res
)
1762 ;; Look at an expression e of the form sin(r*x)^k, where k is an
1763 ;; integer. Return the list (1 r k). (Not sure if the first element
1764 ;; of the list is always 1 because I'm not sure what partition is
1765 ;; trying to do here.)
1768 (cond ((atom e
) (return nil
)))
1769 (setq e
(partition e ivar
1))
1772 (cond ((setq r
(sinrx e ivar
))
1773 (return (list m r
1)))
1775 (eq (ask-integer (setq k
(caddr e
)) '$integer
) '$yes
)
1776 (setq r
(sinrx (cadr e
) ivar
)))
1777 (return (list m r k
))))))
1779 ;; Look at an expression e of the form sin(r*x) and return r.
1780 (defun sinrx (e ivar
)
1781 (cond ((and (consp e
) (eq (caar e
) '%sin
))
1782 (cond ((eq (cadr e
) ivar
)
1784 ((and (setq e
(partition (cadr e
) ivar
1))
1790 ;; integrate(a*sc(r*x)^k/x^n,x,0,inf).
1791 (defun ssp (exp ivar
*ll
* *ul
*)
1793 ;; Get the argument of the involved trig function.
1794 (when (null (setq arg
(involve-var exp ivar
'(%sin %cos
))))
1796 ;; I don't think this needs to be special.
1798 (declare (special n
))
1799 ;; Replace (1-cos(arg)^2) with sin(arg)^2.
1800 (setq exp
($substitute
;(m^t `((%sin) ,ivar) 2.)
1801 ;(m+t 1. (m- (m^t `((%cos) ,ivar) 2.)))
1802 ;; The code from above generates expressions with
1803 ;; a missing simp flag. Furthermore, the
1804 ;; substitution has to be done for the complete
1805 ;; argument of the trig function. (DK 02/2010)
1806 `((mexpt simp
) ((%sin simp
) ,arg
) 2)
1807 `((mplus) 1 ((mtimes) -
1 ((mexpt) ((%cos
) ,arg
) 2)))
1809 (multiple-value-bind (u dn
)
1810 (numden-var exp ivar
)
1811 (cond ((and (setq n
(findp dn ivar
))
1812 (eq (ask-integer n
'$integer
) '$yes
))
1813 ;; n is the power of the denominator.
1814 (cond ((setq c
(skr u ivar
))
1816 (return (scmp c n ivar
*ll
* *ul
*)))
1818 (setq c
(andmapcar #'(lambda (uu)
1821 ;; Do this for a sum of such terms.
1822 (return (m+l
(mapcar #'(lambda (j) (scmp j n ivar
*ll
* *ul
*))
1825 ;; We have an integral of the form sin(r*x)^k/x^n. C is the list (1 r k).
1827 ;; The substitution y=r*x converts this integral to
1829 ;; r^(n-1)*integral(sin(y)^k/y^n,y,0,inf)
1831 ;; (If r is negative, we need to negate the result.)
1833 ;; The recursion Wang gives on p. 87 has a typo. The second term
1834 ;; should be subtracted from the first. This formula is given in G&R,
1835 ;; 3.82, formula 12.
1837 ;; integrate(sin(x)^r/x^s,x) =
1838 ;; r*(r-1)/(s-1)/(s-2)*integrate(sin(x)^(r-2)/x^(s-2),x)
1839 ;; - r^2/(s-1)/(s-2)*integrate(sin(x)^r/x^(s-2),x)
1841 ;; (Limits are assumed to be 0 to inf.)
1843 ;; This recursion ends up with integrals with s = 1 or 2 and
1845 ;; integrate(sin(x)^p/x,x,0,inf) = integrate(sin(x)^(p-1),x,0,%pi/2)
1847 ;; with p > 0 and odd. This latter integral is known to maxima, and
1848 ;; it's value is beta(p/2,1/2)/2.
1850 ;; integrate(sin(x)^2/x^2,x,0,inf) = %pi/2*binomial(q-3/2,q-1)
1854 (defun scmp (c n ivar
*ll
* *ul
*)
1855 ;; Compute sign(r)*r^(n-1)*integrate(sin(y)^k/y^n,y,0,inf)
1856 (destructuring-bind (mult r k
)
1858 (let ((recursion (sinsp k n
)))
1864 ;; Recursion failed. Return the integrand
1865 ;; The following code generates expressions with a missing simp flag
1866 ;; for the sin function. Use better simplifying code. (DK 02/2010)
1867 ; (let ((integrand (div (pow `((%sin) ,(m* r ivar))
1870 (let ((integrand (div (power (take '(%sin
) (mul r ivar
))
1874 `((%integrate
) ,integrand
,ivar
,*ll
* ,*ul
*)))))))
1876 ;; integrate(sin(x)^n/x^2,x,0,inf) = pi/2*binomial(n-3/2,n-1).
1877 ;; Express in terms of Gamma functions, though.
1879 (m* half%pi
($makegamma
`((%binomial
) ,(m+t
(m+ n -
1) '((rat) -
1 2))
1883 ;; integrate(sin(x)^n/x,x,0,inf) = beta((n+1)/2,1/2)/2, for n odd and
1888 (t (bygamma (m+ n -
1) 0.
))))
1890 ;; This implements the recursion for computing
1891 ;; integrate(sin(y)^l/y^k,y,0,inf). (Note the change in notation from
1896 (cond ((eq ($sign
(m+ l
(m- (m+ k -
1))))
1898 ;; Integral diverges if l-(k-1) < 0.
1900 ((not (even1 (m+ l k
)))
1901 ;; If l + k is not even, return NIL. (Is this the right
1905 ;; We have integrate(sin(y)^l/y^2). Use sevn to evaluate.
1908 ;; We have integrate(sin(y)^l/y,y)
1910 ((eq ($sign
(m+ k -
2.
))
1912 (setq i
(m* (m+ k -
1)
1913 (setq j
(m+ k -
2.
))))
1914 ;; j = k-2, i = (k-1)*(k-2)
1917 ;; The main recursion:
1920 ;; = l*(l-1)/(k-1)/(k-2)*i(sin(y)^(l-2)/y^k)
1921 ;; - l^2/(k-1)/(k-1)*i(sin(y)^l/y^(k-2))
1924 (sinsp (m+ l -
2.
) j
))
1929 ;; Returns the fractional part of a?
1933 ;; Why do we return 0 if a is a number? Perhaps we really
1937 ;; If we're here, this basically assumes a is a rational.
1938 ;; Compute the remainder and return the result.
1939 (list (car a
) (rem (cadr a
) (caddr a
)) (caddr a
)))
1940 ((and (atom a
) (abless1 a
)) a
)
1943 (abless1 (caddr a
)))
1946 ;; Doesn't appear to be used anywhere in Maxima. Not sure what this
1947 ;; was intended to do.
1950 (cond ((polyinx e var nil
) 0.
)
1956 (m+l
(mapcar #'thrad e
)))))
1959 ;;; THE FOLLOWING FUNCTION IS FOR TRIG FUNCTIONS OF THE FOLLOWING TYPE:
1960 ;;; LOWER LIMIT=0 B A MULTIPLE OF %PI SCA FUNCTION OF SIN (X) COS (X)
1963 (defun period (p e ivar
)
1964 (and (alike1 (no-err-sub-var ivar e ivar
)
1965 (setq e
(no-err-sub-var (m+ p ivar
) e ivar
)))
1966 ;; means there was no error
1969 ; returns cons of (integer_part . fractional_part) of a
1971 ;; I think we really want to compute how many full periods are in a
1972 ;; and the remainder.
1973 (let* ((q (igprt (div a
(mul 2 '$%pi
))))
1974 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
1977 ; returns cons of (integer_part . fractional_part) of a
1978 (defun lower-infr (a)
1979 ;; I think we really want to compute how many full periods are in a
1980 ;; and the remainder.
1981 (let* (;(q (igprt (div a (mul 2 '$%pi))))
1982 (q (mfuncall '$ceiling
(div a
(mul 2 '$%pi
))))
1983 (r (add a
(mul -
1 (mul q
2 '$%pi
)))))
1987 ;; Return the integer part of r.
1990 (mfuncall '$floor r
))
1993 ;;;Try making exp(%i*ivar) --> yy, if result is rational then do integral
1994 ;;;around unit circle. Make corrections for limits of integration if possible.
1995 (defun scrat (sc b ivar
)
1996 (let* ((exp-form (sconvert sc ivar
)) ;Exponentialize
1997 (rat-form (maxima-substitute 'yy
(m^t
'$%e
(m*t
'$%i ivar
))
1998 exp-form
))) ;Try to make Rational fun.
1999 (cond ((and (ratp rat-form
'yy
)
2000 (not (among ivar rat-form
)))
2001 (cond ((alike1 b %pi2
)
2002 (let ((ans (zto%pi2 rat-form
'yy
)))
2006 (evenfn exp-form ivar
))
2007 (let ((ans (zto%pi2 rat-form
'yy
)))
2008 (cond (ans (m*t
'((rat) 1.
2.
) ans
))
2010 ((and (alike1 b half%pi
)
2011 (evenfn exp-form ivar
)
2013 (no-err-sub-var (m+t
'$%pi
(m*t -
1 ivar
))
2016 (let ((ans (zto%pi2 rat-form
'yy
)))
2017 (cond (ans (m*t
'((rat) 1.
4.
) ans
))
2020 ;;; Do integrals of sin and cos. this routine makes sure lower limit
2022 (defun intsc1 (a b e ivar
)
2023 ;; integrate(e,var,a,b)
2024 (let ((trigarg (find-first-trigarg e
))
2027 (*sin-cos-recur
* t
)) ;recursion stopper
2028 (prog (ans d nzp2 l int-zero-to-d int-nzp2 int-zero-to-c limit-diff
)
2029 (let* ((arg (simple-trig-arg trigarg ivar
)) ;; pattern match sin(cc*x + bb)
2032 (new-var (gensym "NEW-VAR-")))
2033 (putprop new-var t
'internal
)
2035 (not (every-trigarg-alike e trigarg
)))
2037 (when (not (and (equal cc
1) (equal bb
0)))
2038 (setq e
(div (maxima-substitute (div (sub new-var bb
) cc
)
2041 (setq ivar new-var
) ;; change of variables to get sin(new-var)
2042 (setq a
(add bb
(mul a cc
)))
2043 (setq b
(add bb
(mul b cc
)))))
2044 (setq limit-diff
(m+ b
(m* -
1 a
)))
2045 (when (or (not (period %pi2 e ivar
))
2046 (member a
*infinities
*)
2047 (member b
*infinities
*)
2048 (not (and ($constantp a
)
2050 ;; Exit if b or a is not a constant or if the integrand
2051 ;; doesn't appear to have a period of 2 pi.
2054 ;; Multiples of 2*%pi in limits.
2055 (cond ((integerp (setq d
(let (($float nil
))
2056 (m// limit-diff %pi2
))))
2057 (cond ((setq ans
(intsc e %pi2 ivar
))
2058 (return (m* d ans
)))
2061 ;; The integral is not over a full period (2*%pi) or multiple
2062 ;; of a full period.
2064 ;; Wang p. 111: The integral integrate(f(x),x,a,b) can be
2067 ;; n * integrate(f,x,0,2*%pi) + integrate(f,x,0,c)
2068 ;; - integrate(f,x,0,d)
2070 ;; for some integer n and d >= 0, c < 2*%pi because there exist
2071 ;; integers p and q such that a = 2 * p *%pi + d and b = 2 * q
2072 ;; * %pi + c. Then n = q - p.
2074 ;; Compute q and c for the upper limit b.
2079 (setq int-zero-to-d
0.
)
2081 ;; Compute p and d for the lower limit a.
2083 ;; avoid an extra trip around the circle - helps skip principal values
2084 (if (ratgreaterp (car b
) (car l
)) ; if q > p
2085 (setq l
(cons (add 1 (car l
)) ; p += 1
2086 (add (mul -
1 %pi2
) (cdr l
))))) ; d -= 2*%pi
2088 ;; Compute -integrate(f,x,0,d)
2090 (cond ((setq ans
(try-intsc e
(cdr l
) ivar
))
2093 ;; Compute n = q - p (stored in nzp2)
2094 (setq nzp2
(m+ (car b
) (m- (car l
))))
2096 ;; Compute n*integrate(f,x,0,2*%pi)
2097 (setq int-nzp2
(cond ((zerop1 nzp2
)
2100 ((setq ans
(try-intsc e %pi2 ivar
))
2101 ;; n is not zero, so compute
2102 ;; integrate(f,x,0,2*%pi)
2104 ;; Unable to compute integrate(f,x,0,2*%pi)
2106 ;; Compute integrate(f,x,0,c)
2107 (setq int-zero-to-c
(try-intsc e
(cdr b
) ivar
))
2109 (return (cond ((and int-zero-to-d int-nzp2 int-zero-to-c
)
2110 ;; All three pieces succeeded.
2111 (add* int-zero-to-d int-nzp2 int-zero-to-c
))
2112 ((ratgreaterp %pi2 limit-diff
)
2113 ;; Less than 1 full period, so intsc can integrate it.
2114 ;; Apply the substitution to make the lower limit 0.
2115 ;; This is last resort because substitution often causes intsc to fail.
2116 (intsc (maxima-substitute (m+ a ivar
) ivar e
)
2121 ;; integrate(sc, var, 0, b), where sc is f(sin(x), cos(x)).
2122 ;; calls intsc with a wrapper to just return nil if integral is divergent,
2123 ;; rather than generating an error.
2124 (defun try-intsc (sc b ivar
)
2125 (let* ((*nodiverg
* t
)
2126 (ans (catch 'divergent
(intsc sc b ivar
))))
2127 (if (eq ans
'divergent
)
2131 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)). I (rtoy)
2132 ;; think this expects b to be less than 2*%pi.
2133 (defun intsc (sc b ivar
)
2136 (multiple-value-bind (b sc
)
2137 (cond ((eq ($sign b
) '$neg
)
2139 (m* -
1 (subin-var (m*t -
1 ivar
) sc ivar
))))
2142 ;; Partition the integrand SC into the factors that do not
2143 ;; contain VAR (the car part) and the parts that do (the cdr
2145 (setq sc
(partition sc ivar
1))
2146 (cond ((setq b
(intsc0 (cdr sc
) b ivar
))
2147 (m* (resimplify (car sc
)) b
))))))
2149 ;; integrate(sc, ivar, 0, b), where sc is f(sin(x), cos(x)).
2150 (defun intsc0 (sc b ivar
)
2151 ;; Determine if sc is a product of sin's and cos's.
2152 (let ((nn* (scprod sc ivar
))
2155 ;; We have a product of sin's and cos's. We handle some
2156 ;; special cases here.
2157 (cond ((alike1 b half%pi
)
2158 ;; Wang p. 110, formula (1):
2159 ;; integrate(sin(x)^m*cos(x)^n, x, 0, %pi/2) =
2160 ;; gamma((m+1)/2)*gamma((n+1)/2)/2/gamma((n+m+2)/2)
2161 (bygamma (car nn
*) (cadr nn
*)))
2163 ;; Wang p. 110, near the bottom, says
2165 ;; int(f(sin(x),cos(x)), x, 0, %pi) =
2166 ;; int(f(sin(x),cos(x)) + f(sin(x),-cos(x)),x,0,%pi/2)
2167 (cond ((eq (real-branch (cadr nn
*) -
1) '$yes
)
2168 (m* (m+ 1.
(m^ -
1 (cadr nn
*)))
2169 (bygamma (car nn
*) (cadr nn
*))))))
2171 (cond ((or (and (eq (ask-integer (car nn
*) '$even
)
2173 (eq (ask-integer (cadr nn
*) '$even
)
2175 (and (ratnump (car nn
*))
2176 (eq (real-branch (car nn
*) -
1)
2178 (ratnump (cadr nn
*))
2179 (eq (real-branch (cadr nn
*) -
1)
2181 (m* 4.
(bygamma (car nn
*) (cadr nn
*))))
2182 ((or (eq (ask-integer (car nn
*) '$odd
) '$yes
)
2183 (eq (ask-integer (cadr nn
*) '$odd
) '$yes
))
2186 ((alike1 b half%pi3
)
2187 ;; Wang, p. 111 says
2189 ;; int(f(sin(x),cos(x)),x,0,3*%pi/2) =
2190 ;; int(f(sin(x),cos(x)),x,0,%pi)
2191 ;; + int(f(-sin(x),-cos(x)),x,0,%pi/2)
2192 (m* (m+ 1.
(m^ -
1 (cadr nn
*)) (m^ -
1 (m+l nn
*)))
2193 (bygamma (car nn
*) (cadr nn
*))))))
2195 ;; We don't have a product of sin's and cos's.
2196 (cond ((and (or (eq b
'$%pi
)
2199 (setq dn
* (scrat sc b ivar
)))
2201 ((setq nn
* (antideriv sc ivar
))
2202 (sin-cos-intsubs nn
* ivar
0. b
))
2205 ;;;Is careful about substitution of limits where the denominator may be zero
2206 ;;;because of various assumptions made.
2207 (defun sin-cos-intsubs (exp ivar
*ll
* *ul
*)
2209 (let ((l (mapcar #'(lambda (e)
2210 (sin-cos-intsubs1 e ivar
*ll
* *ul
*))
2212 (if (not (some #'null l
))
2214 (t (sin-cos-intsubs1 exp ivar
*ll
* *ul
*))))
2216 (defun sin-cos-intsubs1 (exp ivar
*ll
* *ul
*)
2217 (let* ((rat-exp ($rat exp
))
2218 (denom (pdis (cddr rat-exp
))))
2219 (cond ((equal ($csign denom
) '$zero
)
2221 (t (try-intsubs exp
*ll
* *ul
* ivar
)))))
2223 (defun try-intsubs (exp *ll
* *ul
* ivar
)
2224 (let* ((*nodiverg
* t
)
2225 (ans (catch 'divergent
(intsubs exp
*ll
* *ul
* ivar
))))
2226 (if (eq ans
'divergent
)
2230 (defun try-defint (exp ivar
*ll
* *ul
*)
2231 (let* ((*nodiverg
* t
)
2232 (ans (catch 'divergent
(defint exp ivar
*ll
* *ul
*))))
2233 (if (eq ans
'divergent
)
2237 ;; Determine whether E is of the form sin(x)^m*cos(x)^n and return the
2239 (defun scprod (e ivar
)
2240 (let ((great-minus-1 #'(lambda (temp)
2241 (ratgreaterp temp -
1)))
2244 ((setq m
(powerofx e
`((%sin
) ,ivar
) great-minus-1 ivar
))
2246 ((setq n
(powerofx e
`((%cos
) ,ivar
) great-minus-1 ivar
))
2250 (or (setq m
(powerofx (cadr e
) `((%sin
) ,ivar
) great-minus-1 ivar
))
2251 (setq n
(powerofx (cadr e
) `((%cos
) ,ivar
) great-minus-1 ivar
)))
2254 (setq m
(powerofx (caddr e
) `((%sin
) ,ivar
) great-minus-1 ivar
)))
2255 (t (setq n
(powerofx (caddr e
) `((%cos
) ,ivar
) great-minus-1 ivar
))))
2260 (defun real-branch (exponent value
)
2261 ;; Says whether (m^t value exponent) has at least one real branch.
2262 ;; Only works for values of 1 and -1 now. Returns $yes $no
2264 (cond ((equal value
1.
)
2266 ((eq (ask-integer exponent
'$integer
) '$yes
)
2269 (cond ((eq ($oddp
(caddr exponent
)) t
)
2274 ;; Compute beta((m+1)/2,(n+1)/2)/2.
2275 (defun bygamma (m n
)
2276 (let ((one-half (m//t
1.
2.
)))
2277 (m* one-half
`((%beta
) ,(m* one-half
(m+t
1. m
))
2278 ,(m* one-half
(m+t
1. n
))))))
2280 ;;Seems like Guys who call this don't agree on what it should return.
2281 (defun powerofx (e x p ivar
)
2282 (setq e
(cond ((not (among ivar e
)) nil
)
2287 (not (among ivar
(caddr e
))))
2289 (cond ((null e
) nil
)
2293 ;; Check e for an expression of the form x^kk*(b*x^n+a)^l. If it
2294 ;; matches, Return the two values kk and (list l a n b).
2295 (defun bata0 (e ivar
)
2297 (cond ((atom e
) nil
)
2299 ;; We have f(x)^y. Look to see if f(x) has the desired
2300 ;; form. Then f(x)^y has the desired form too, with
2301 ;; suitably modified values.
2303 ;; XXX: Should we ask for the sign of f(x) if y is not an
2304 ;; integer? This transformation we're going to do requires
2305 ;; that f(x)^y be real.
2306 (destructuring-bind (mexp base power
)
2308 (declare (ignore mexp
))
2309 (multiple-value-bind (kk cc
)
2312 ;; Got a match. Adjust kk and cc appropriately.
2313 (destructuring-bind (l a n b
)
2315 (values (mul kk power
)
2316 (list (mul l power
) a n b
)))))))
2319 (or (and (setq k
(findp (cadr e
) ivar
))
2320 (setq c
(bxm (caddr e
) (polyinx (caddr e
) ivar nil
) ivar
)))
2321 (and (setq k
(findp (caddr e
) ivar
))
2322 (setq c
(bxm (cadr e
) (polyinx (cadr e
) ivar nil
) ivar
)))))
2324 ((setq c
(bxm e
(polyinx e ivar nil
) ivar
))
2331 ;; (COND ((NOT (BATA0 E)) (RETURN NIL))
2332 ;; ((AND (EQUAL -1. (CADDDR C))
2333 ;; (EQ ($askSIGN (SETQ K (m+ 1. K)))
2335 ;; (EQ ($askSIGN (SETQ L (m+ 1. (CAR C))))
2338 ;; (m^ UL (CADDR C)))
2339 ;; (SETQ E (CADR C))
2340 ;; (EQ ($askSIGN (SETQ C (CADDR C))) '$pos))
2341 ;; (RETURN (M// (m* (m^ UL (m+t K (m* C (m+t -1. L))))
2342 ;; `(($BETA) ,(SETQ NN* (M// K C))
2347 ;; Integrals of the form i(log(x)^m*x^k*(a+b*x^n)^l,x,0,ul). There
2348 ;; are two cases to consider: One case has ul>0, b<0, a=-b*ul^n, k>-1,
2349 ;; l>-1, n>0, m a nonnegative integer. The second case has ul=inf, l < 0.
2351 ;; These integrals are essentially partial derivatives of the Beta
2352 ;; function (i.e. the Eulerian integral of the first kind). Note
2353 ;; that, currently, with the default setting intanalysis:true, this
2354 ;; function might not even be called for some of these integrals.
2355 ;; However, this can be palliated by setting intanalysis:false.
2357 (defun zto1 (e ivar
)
2358 (when (or (mtimesp e
) (mexptp e
))
2360 (log (list '(%log
) ivar
)))
2363 (find-if #'(lambda (fac)
2364 (powerofx fac log
#'set-m ivar
))
2366 (when (and (freeof ivar m
)
2367 (eq (ask-integer m
'$integer
) '$yes
)
2368 (not (eq ($asksign m
) '$neg
)))
2369 (setq e
(m//t e
(list '(mexpt) log m
)))
2372 (multiple-value-bind (kk s d r cc
)
2374 ;; We have i(x^kk/(d+cc*x^r)^s,x,0,inf) =
2375 ;; beta(aa,bb)/(cc^aa*d^bb*r). Compute this, and then
2376 ;; differentiate it m times to get the log term
2379 (let* ((aa (div (add 1 ivar
) r
))
2381 (m (if (eq ($asksign m
) '$zero
)
2384 (let ((res (div `((%beta
) ,aa
,bb
)
2388 ($at
($diff res ivar m
)
2389 (list '(mequal) ivar kk
)))))))
2391 (multiple-value-bind
2392 (k/n l n b
) (batap-new e ivar
)
2394 (let ((beta (ftake* '%beta k
/n l
))
2395 (m (if (eq ($asksign m
) '$zero
) 0 m
)))
2396 ;; The result looks like B(k/n,l) ( ... ).
2397 ;; Perhaps, we should just $factor, instead of
2398 ;; pulling out beta like this.
2404 (m^t
(m-t b
) (m1-t l
))
2405 (m^t
*ul
* (m*t n
(m1-t l
)))
2406 (m^t n
(m-t (m1+t m
)))
2407 ($at
($diff
(m*t
(m^t
*ul
* (m*t n ivar
))
2408 (list '(%beta
) ivar l
))
2410 (list '(mequal) ivar k
/n
)))
2414 ;;; If e is of the form given below, make the obvious change
2415 ;;; of variables (substituting ul*x^(1/n) for x) in order to reduce
2416 ;;; e to the usual form of the integrand in the Eulerian
2417 ;;; integral of the first kind.
2418 ;;; N. B: The old version of ZTO1 completely ignored this
2419 ;;; substitution; the log(x)s were just thrown in, which,
2420 ;;; of course would give wrong results.
2422 (defun batap-new (e ivar
)
2424 (multiple-value-bind (k c
)
2427 ;; e=x^k*(a+b*x^n)^l
2428 (destructuring-bind (l a n b
)
2430 (when (and (freeof ivar k
)
2433 (alike1 a
(m-t (m*t b
(m^t
*ul
* n
))))
2434 (eq ($asksign b
) '$neg
)
2435 (eq ($asksign
(setq k
(m1+t k
))) '$pos
)
2436 (eq ($asksign
(setq l
(m1+t l
))) '$pos
)
2437 (eq ($asksign n
) '$pos
))
2438 (values (m//t k n
) l n b
))))))
2441 ;; Wang p. 71 gives the following formula for a beta function:
2443 ;; integrate(x^(k-1)/(c*x^r+d)^s,x,0,inf)
2444 ;; = beta(a,b)/(c^a*d^b*r)
2446 ;; where a = k/r > 0, b = s - a > 0, s > k > 0, r > 0, c*d > 0.
2448 ;; This function matches this and returns k-1, d, r, c, a, b. And
2449 ;; also checks that all the conditions hold. If not, NIL is returned.
2451 (defun batap-inf (e ivar
)
2452 (multiple-value-bind (k c
)
2455 (destructuring-bind (l d r cc
)
2457 (let* ((s (mul -
1 l
))
2461 (when (and (freeof ivar k
)
2464 (eq ($asksign kk
) '$pos
)
2465 (eq ($asksign a
) '$pos
)
2466 (eq ($asksign b
) '$pos
)
2467 (eq ($asksign
(sub s k
)) '$pos
)
2468 (eq ($asksign r
) '$pos
)
2469 (eq ($asksign
(mul cc d
)) '$pos
))
2470 (values k s d r cc
)))))))
2473 ;; Handles beta integrals.
2474 (defun batapp (e ivar ll ul
)
2475 (cond ((not (or (equal ll
0)
2477 (setq e
(subin-var (m+ ll ivar
) e ivar
))))
2478 (multiple-value-bind (k c
)
2483 (destructuring-bind (l d al c
)
2485 ;; e = x^k*(d+c*x^al)^l.
2486 (let ((new-k (m// (m+ 1 k
) al
)))
2487 (when (and (ratgreaterp al
0.
)
2488 (eq ($asksign new-k
) '$pos
)
2489 (ratgreaterp (setq l
(m* -
1 l
))
2491 (eq ($asksign
(m* d c
))
2493 (setq l
(m+ l
(m*t -
1 new-k
)))
2494 (m// `((%beta
) ,new-k
,l
)
2495 (mul* al
(m^ c new-k
) (m^ d l
))))))))))
2498 ;; Compute exp(d)*gamma((c+1)/b)/b/a^((c+1)/b). In essence, this is
2499 ;; the value of integrate(x^c*exp(d-a*x^b),x,0,inf).
2500 (defun gamma1 (c a b d
)
2502 (m^
(m* b
(m^ a
(setq c
(m// (m+t c
1) b
)))) -
1)
2505 (defun zto%pi2
(grand ivar
)
2506 (let ((result (unitcir (sratsimp (m// grand ivar
)) ivar
)))
2507 (cond (result (sratsimp (m* (m- '$%i
) result
)))
2510 ;; Evaluates the contour integral of GRAND around the unit circle
2512 (defun unitcir (grand ivar
)
2513 (multiple-value-bind (nn dn
)
2514 (numden-var grand ivar
)
2516 (result (princip (res-var ivar nn dn
2518 ;; Is pt stricly inside the unit circle?
2519 (setq sgn
(let ((limitp nil
))
2520 ($asksign
(m+ -
1 (cabs pt
)))))
2523 (declare (ignore pt
))
2524 ;; Is pt on the unit circle? (Use
2525 ;; the cached value computed
2529 (setq sgn nil
)))))))
2531 (m* '$%pi result
)))))
2534 (defun logx1 (exp ll ul ivar
)
2537 ((and (notinvolve-var exp ivar
'(%sin %cos %tan %atan %asin %acos
))
2538 (setq arg
(involve-var exp ivar
'(%log
))))
2539 (cond ((eq arg ivar
)
2540 (cond ((ratgreaterp 1. ll
)
2541 (cond ((not (eq ul
'$inf
))
2542 (intcv1 (m^t
'$%e
(m- 'yx
)) (m- `((%log
) ,ivar
)) ivar ll ul
))
2543 (t (intcv1 (m^t
'$%e
'yx
) `((%log
) ,ivar
) ivar ll ul
))))))
2544 (t (intcv arg nil ivar ll ul
)))))))
2547 ;; Wang 81-83. Unfortunately, the pdf version has page 82 as all
2548 ;; black, so here is, as best as I can tell, what Wang is doing.
2549 ;; Fortunately, p. 81 has the necessary hints.
2551 ;; First consider integrate(exp(%i*k*x^n),x) around the closed contour
2552 ;; consisting of the real axis from 0 to R, the arc from the angle 0
2553 ;; to %pi/(2*n) and the ray from the arc back to the origin.
2555 ;; There are no poles in this region, so the integral must be zero.
2556 ;; But consider the integral on the three parts. The real axis is the
2557 ;; integral we want. The return ray is
2559 ;; exp(%i*%pi/2/n) * integrate(exp(%i*k*(t*exp(%i*%pi/2/n))^n),t,R,0)
2560 ;; = exp(%i*%pi/2/n) * integrate(exp(%i*k*t^n*exp(%i*%pi/2)),t,R,0)
2561 ;; = -exp(%i*%pi/2/n) * integrate(exp(-k*t^n),t,0,R)
2563 ;; As R -> infinity, this last integral is gamma(1/n)/k^(1/n)/n.
2565 ;; We assume the integral on the circular arc approaches 0 as R ->
2566 ;; infinity. (Need to prove this.)
2570 ;; integrate(exp(%i*k*t^n),t,0,inf)
2571 ;; = exp(%i*%pi/2/n) * gamma(1/n)/k^(1/n)/n.
2573 ;; Equating real and imaginary parts gives us the desired results:
2575 ;; integrate(cos(k*t^n),t,0,inf) = G * cos(%pi/2/n)
2576 ;; integrate(sin(k*t^n),t,0,inf) = G * sin(%pi/2/n)
2578 ;; where G = gamma(1/n)/k^(1/n)/n.
2580 (defun scaxn (e ivar
)
2582 (cond ((atom e
) nil
)
2583 ((and (or (eq (caar e
) '%sin
)
2584 (eq (caar e
) '%cos
))
2586 (setq e
(bx**n
(cadr e
) ivar
)))
2587 ;; Ok, we have cos(b*x^n) or sin(b*x^n), and we set e = (n
2589 (cond ((equal (car e
) 1.
)
2590 ;; n = 1. Give up. (Why not divergent?)
2592 ((zerop (setq s
(let ((sign ($asksign
(cadr e
))))
2593 (cond ((eq sign
'$pos
) 1)
2594 ((eq sign
'$neg
) -
1)
2595 ((eq sign
'$zero
) 0)))))
2596 ;; s is the sign of b. Give up if it's zero.
2598 ((not (eq ($asksign
(m+ -
1 (car e
))) '$pos
))
2599 ;; Give up if n-1 <= 0. (Why give up? Isn't the
2600 ;; integral divergent?)
2603 ;; We can apply our formula now. g = gamma(1/n)/n/b^(1/n)
2604 (setq g
(gamma1 0.
(m* s
(cadr e
)) (car e
) 0.
))
2605 (setq e
(m* g
`((,ind
) ,(m// half%pi
(car e
)))))
2606 (m* (cond ((and (eq ind
'%sin
)
2613 ;; this is the second part of the definite integral package
2615 (defun p*lognxp
(a s ivar
)
2617 (cond ((not (among '%log a
))
2619 ((and (polyinx (setq b
(maxima-substitute 1.
`((%log
) ,ivar
) a
))
2621 (eq ($sign
(m+ s
(m+ 1 (deg-var b ivar
))))
2624 (setq a
(lognxp (sratsimp (m// a b
)) ivar
)))
2627 (defun lognxp (a ivar
)
2628 (cond ((atom a
) nil
)
2629 ((and (eq (caar a
) '%log
)
2634 (lognxp (cadr a
) ivar
))
2637 (defun logcpi0 (n d ivar
)
2638 (prog (polelist dp plm rlm factors pl rl pl1 rl1
)
2640 (polelist-var ivar d
#'upperhalf
#'(lambda (j)
2643 ((equal ($imagpart j
) 0)
2645 (cond ((null polelist
)
2647 (setq factors
(car polelist
)
2648 polelist
(cdr polelist
))
2649 (cond ((or (cadr polelist
)
2651 (setq dp
(sdiff d ivar
))))
2652 (cond ((setq plm
(car polelist
))
2653 (setq rlm
(residue-var ivar
2655 (cond (*leadcoef
* factors
)
2658 (cond ((setq pl
(cadr polelist
))
2659 (setq rl
(res1-var ivar n dp pl
))))
2660 (cond ((setq pl1
(caddr polelist
))
2661 (setq rl1
(res1-var ivar n dp pl1
))))
2666 (list (cond ((setq nn
* (append rl rlm
))
2668 (cond (rl1 (m+l rl1
)))))))
2676 (defun lognx2 (nn dn pl rl
)
2677 (do ((pl pl
(cdr pl
))
2683 (setq ans
(cons (m* dn
(car rl
)
2684 ;; AFAICT, this call to PLOG doesn't need
2686 (m^
`((%plog
) ,(car pl
)) nn
))
2689 (defun logcpj (n d i ivar plm pl rl pl1 rl1
)
2692 (list (mul* (m*t
'$%i %pi2
)
2694 ;; AFAICT, this call to PLOG doesn't need
2695 ;; to bind VAR. An example where this is
2697 ;; integrate(log(x)^2/(1+x^2),x,0,1) =
2700 (m* (m^
`((%plog
) ,ivar
) i
)
2704 (lognx2 i
(m*t
'$%i %pi2
) pl rl
)
2705 (lognx2 i %p%i pl1 rl1
)))
2708 (simplify (m+l n
))))
2710 ;; Handle integral(n(x)/d(x)*log(x)^m,x,0,inf). n and d are
2712 (defun log*rat
(n d m ivar
)
2713 (let ((i-vals (make-array (1+ m
)))
2714 (j-vals (make-array (1+ m
))))
2716 ((logcpi (n d c ivar
)
2719 (m* '((rat) 1 2) (m+ (aref j-vals c
) (m* -
1 (sumi c
))))))
2725 (push (mul* ($makegamma
`((%binomial
) ,c
,k
))
2728 (aref i-vals
(- c k
)))
2730 (setf (aref j-vals
0) 0)
2731 (prog (*leadcoef
* res
)
2732 (dotimes (c m
(return (logcpi n d m ivar
)))
2733 (multiple-value-bind (res plm factors pl rl pl1 rl1
)
2735 (setf (aref i-vals c
) res
)
2736 (setf (aref j-vals c
) (logcpj n factors c ivar plm pl rl pl1 rl1
))))))))
2738 (defun fan (p m a n b
)
2739 (let ((povern (m// p n
))
2742 ((or (eq (ask-integer povern
'$integer
) '$yes
)
2743 (not (equal ($imagpart ab
) 0))) ())
2744 (t (let ((ind ($asksign ab
)))
2745 (cond ((eq ind
'$zero
) nil
)
2746 ((eq ind
'$neg
) nil
)
2747 ((not (ratgreaterp m povern
)) nil
)
2749 ($makegamma
`((%binomial
) ,(m+ -
1 m
(m- povern
))
2751 `((mabs) ,(m^ a
(m+ povern
(m- m
)))))
2754 `((%sin
) ,(m*t
'$%pi povern
)))))))))))
2757 ;;Makes a new poly such that np(x)-np(x+2*%i*%pi)=p(x).
2758 ;;Constructs general POLY of degree one higher than P with
2759 ;;arbitrary coeff. and then solves for coeffs by equating like powers
2760 ;;of the varibale of integration.
2761 ;;Can probably be made simpler now.
2763 (defun makpoly (p ivar
)
2764 (let ((n (deg-var p ivar
)) (ans ()) (varlist ()) (gp ()) (cl ()) (zz ()))
2765 (setq ans
(genpoly (m+ 1 n
) ivar
)) ;Make poly with gensyms of 1 higher deg.
2766 (setq cl
(cdr ans
)) ;Coefficient list
2767 (setq varlist
(append cl
(list ivar
))) ;Make VAR most important.
2768 (setq gp
(car ans
)) ;This is the poly with gensym coeffs.
2769 ;;;Now, poly(x)-poly(x+2*%i*%pi)=p(x), P is the original poly.
2770 (setq ans
(m+ gp
(subin-var (m+t
(m*t
'$%i %pi2
) ivar
) (m- gp
) ivar
) (m- p
)))
2772 (setq ans
(ratrep* ans
)) ;Rational rep with VAR leading.
2773 (setq zz
(coefsolve n cl
(cond ((not (eq (caadr ans
) ;What is Lead Var.
2774 (genfind (car ans
) ivar
)))
2775 (list 0 (cadr ans
))) ;No VAR in ans.
2776 ((cdadr ans
))))) ;The real Poly.
2777 (if (or (null zz
) (null gp
))
2779 ($substitute zz gp
)))) ;Substitute Values for gensyms.
2781 (defun coefsolve (n cl e
)
2783 (eql (ncons (pdis (ptterm e n
))) (cons (pdis (ptterm e m
)) eql
))
2784 (m (m+ n -
1) (m+ m -
1)))
2785 ((signp l m
) (solvex eql cl nil nil
))))
2787 ;; Integrate(p(x)*f(exp(x))/g(exp(x)),x,minf,inf) by applying the
2788 ;; transformation y = exp(x) to get
2789 ;; integrate(p(log(y))*f(y)/g(y)/y,y,0,inf). This should be handled
2791 (defun log-transform (p pe d ivar
)
2792 (let ((new-p (subst (list '(%log
) ivar
) ivar p
))
2793 (new-pe (subst ivar
'z
* (catch 'pin%ex
(pin%ex pe ivar
))))
2794 (new-d (subst ivar
'z
* (catch 'pin%ex
(pin%ex d ivar
)))))
2795 (defint (div (div (mul new-p new-pe
) new-d
) ivar
) ivar
0 *ul
*)))
2797 ;; This implements Wang's algorithm in Chapter 5.2, pp. 98-100.
2799 ;; This is a very brief description of the algorithm. Basically, we
2800 ;; have integrate(R(exp(x))*p(x),x,minf,inf), where R(x) is a rational
2801 ;; function and p(x) is a polynomial.
2803 ;; We find a polynomial q(x) such that q(x) - q(x+2*%i*%pi) = p(x).
2804 ;; Then consider a contour integral of R(exp(z))*q(z) over a
2805 ;; rectangular contour. Opposite corners of the rectangle are (-R,
2806 ;; 2*%i*%pi) and (R, 0).
2808 ;; Wang shows that this contour integral, in the limit, is the
2809 ;; integral of R(exp(x))*q(x)-R(exp(x))*q(x+2*%i*%pi), which is
2810 ;; exactly the integral we're looking for.
2812 ;; Thus, to find the value of the contour integral, we just need the
2813 ;; residues of R(exp(z))*q(z). The only tricky part is that we want
2814 ;; the log function to have an imaginary part between 0 and 2*%pi
2815 ;; instead of -%pi to %pi.
2816 (defun rectzto%pi2
(p pe d ivar
)
2817 ;; We have R(exp(x))*p(x) represented as p(x)*pe(exp(x))/d(exp(x)).
2818 (prog (dp n pl a b c denom-exponential
)
2819 (if (not (and (setq denom-exponential
(catch 'pin%ex
(pin%ex d ivar
)))
2820 (%e-integer-coeff pe ivar
)
2821 (%e-integer-coeff d ivar
)))
2823 ;; At this point denom-exponential has converted d(exp(x)) to the
2824 ;; polynomial d(z), where z = exp(x).
2825 (setq n
(m* (cond ((null p
) -
1)
2826 (t ($expand
(m*t
'$%i %pi2
(makpoly p ivar
)))))
2828 (let ((*leadcoef
* ()))
2829 ;; Find the poles of the denominator. denom-exponential is the
2830 ;; denominator of R(x).
2832 ;; It seems as if polelist returns a list of several items.
2833 ;; The first element is a list consisting of the pole and (z -
2834 ;; pole). We don't care about this, so we take the rest of the
2836 (setq pl
(cdr (polelist-var 'z
* denom-exponential
2838 ;; The imaginary part is nonzero,
2839 ;; or the realpart is negative.
2840 (or (not (equal ($imagpart j
) 0))
2841 (eq ($asksign
($realpart j
)) '$neg
)))
2843 ;; The realpart is not zero.
2844 (not (eq ($asksign
($realpart j
)) '$zero
)))))))
2845 ;; Not sure what this does.
2847 ;; No roots at all, so return
2851 ;; We have simple roots or roots in REGION1
2852 (setq dp
(sdiff d ivar
))))
2854 ;; The cadr of pl is the list of the simple poles of
2855 ;; denom-exponential. Take the log of them to find the
2856 ;; poles of the original expression. Then compute the
2857 ;; residues at each of these poles and sum them up and put
2858 ;; the result in B. (If no simple poles set B to 0.)
2859 (setq b
(mapcar #'log-imag-0-2%pi
(cadr pl
)))
2860 (setq b
(res1-var ivar n dp b
))
2864 ;; I think this handles the case of poles outside the
2865 ;; regions. The sum of these residues are placed in C.
2866 (let ((temp (mapcar #'log-imag-0-2%pi
(caddr pl
))))
2867 (setq c
(append temp
(mapcar #'(lambda (j)
2868 (m+ (m*t
'$%i %pi2
) j
))
2870 (setq c
(res1-var ivar n dp c
))
2874 ;; We have the repeated poles of deonom-exponential, so we
2875 ;; need to convert them to the actual pole values for
2876 ;; R(exp(x)), by taking the log of the value of poles.
2877 (let ((poles (mapcar #'(lambda (p)
2878 (log-imag-0-2%pi
(car p
)))
2880 (exp (m// n
(subst (m^t
'$%e ivar
) 'z
* denom-exponential
))))
2881 ;; Compute the residues at all of these poles and sum
2883 (setq a
(mapcar #'(lambda (j)
2884 ($residue exp ivar j
))
2888 (return (sratsimp (m+ a b
(m* '((rat) 1.
2.
) c
))))))
2890 (defun genpoly (i ivar
)
2891 (do ((i i
(m+ i -
1))
2892 (c (gensym) (gensym))
2896 (cons (m+l ans
) cl
))
2897 (setq ans
(cons (m* c
(m^t ivar i
)) ans
))
2898 (setq cl
(cons c cl
))))
2900 ;; Check to see if each term in exp that is of the form exp(k*x) has
2901 ;; an integer value for k.
2902 (defun %e-integer-coeff
(exp ivar
)
2903 (cond ((mapatom exp
) t
)
2905 (eq (cadr exp
) '$%e
))
2906 (eq (ask-integer ($coeff
(caddr exp
) ivar
) '$integer
)
2908 (t (every #'(lambda (e)
2909 (%e-integer-coeff e ivar
))
2912 (defun wlinearpoly (e ivar
)
2913 (cond ((and (setq e
(polyinx e ivar t
))
2914 (equal (deg-var e ivar
) 1))
2915 (subin-var 1 e ivar
))))
2917 ;; Test to see if exp is of the form f(exp(x)), and if so, replace
2918 ;; exp(x) with 'z*. That is, basically return f(z*).
2919 (defun pin%ex
(exp ivar
)
2920 (pin%ex0
(cond ((notinvolve-var exp ivar
'(%sinh %cosh %tanh
))
2923 (let (($exponentialize t
))
2924 (setq exp
($expand exp
)))))
2927 (defun pin%ex0
(e ivar
)
2928 ;; Does e really need to be special here? Seems to be ok without
2929 ;; it; testsuite works.
2931 (declare (special e
))
2932 (cond ((not (among ivar e
))
2935 (throw 'pin%ex nil
))
2938 (cond ((eq (caddr e
) ivar
)
2940 ((let ((linterm (wlinearpoly (caddr e
) ivar
)))
2942 (m* (subin-var 0 e ivar
) (m^t
'z
* linterm
)))))
2944 (throw 'pin%ex nil
))))
2946 (m*l
(mapcar #'(lambda (ee)
2950 (m+l
(mapcar #'(lambda (ee)
2954 (throw 'pin%ex nil
))))
2956 (defun findsub (p ivar
)
2958 (cond ((findp p ivar
) nil
)
2959 ((setq nd
(bx**n p ivar
))
2960 (m^t ivar
(car nd
)))
2961 ((setq p
(bx**n
+a p ivar
))
2962 (m* (caddr p
) (m^t ivar
(cadr p
)))))))
2964 ;; I think this is looking at f(exp(x)) and tries to find some
2965 ;; rational function R and some number k such that f(exp(x)) =
2967 (defun funclogor%e
(e ivar
)
2968 (prog (ans arg nvar r
)
2969 (cond ((or (ratp e ivar
)
2970 (involve-var e ivar
'(%sin %cos %tan
))
2971 (not (setq arg
(xor (and (setq arg
(involve-var e ivar
'(%log
)))
2973 (%einvolve-var e ivar
)))))
2975 ag
(setq nvar
(cond ((eq r
'%log
) `((%log
) ,arg
))
2976 (t (m^t
'$%e arg
))))
2977 (setq ans
(maxima-substitute (m^t
'yx -
1) (m^t nvar -
1) (maxima-substitute 'yx nvar e
)))
2978 (cond ((not (among ivar ans
)) (return (list (subst ivar
'yx ans
) nvar
)))
2980 (setq arg
(findsub arg ivar
)))
2983 ;; Integration by parts.
2985 ;; integrate(u(x)*diff(v(x),x),x,a,b)
2987 ;; = u(x)*v(x)| - integrate(v(x)*diff(u(x),x))
2990 (defun dintbypart (u v a b ivar
)
2991 ;;;SINCE ONLY CALLED FROM DINTLOG TO get RID OF LOGS - IF LOG REMAINS, QUIT
2992 (let ((ad (antideriv v ivar
)))
2993 (cond ((or (null ad
)
2994 (involve-var ad ivar
'(%log
)))
2996 (t (let ((p1 (m* u ad
))
2997 (p2 (m* ad
(sdiff u ivar
))))
2998 (let ((p1-part1 (get-limit p1 ivar b
'$minus
))
2999 (p1-part2 (get-limit p1 ivar a
'$plus
)))
3000 (cond ((or (null p1-part1
)
3003 (t (let ((p2 (defint p2 ivar a b
)))
3004 (cond (p2 (add* p1-part1
3009 ;; integrate(f(exp(k*x)),x,a,b), where f(z) is rational.
3011 ;; See Wang p. 96-97.
3013 ;; If the limits are minf to inf, we use the substitution y=exp(k*x)
3014 ;; to get integrate(f(y)/y,y,0,inf)/k. If the limits are 0 to inf,
3015 ;; use the substitution s+1=exp(k*x) to get
3016 ;; integrate(f(s+1)/(s+1),s,0,inf).
3017 (defun dintexp (exp ivar ll ul
&aux ans
)
3018 (let ((*dintexp-recur
* t
)) ;recursion stopper
3019 (cond ((and (sinintp exp ivar
) ;To be moved higher in the code.
3020 (setq ans
(antideriv exp ivar
))
3021 (setq ans
(intsubs ans ll ul ivar
)))
3022 ;; If we can integrate it directly, do so and take the
3023 ;; appropriate limits.
3025 ((setq ans
(funclogor%e exp ivar
))
3026 ;; ans is the list (f(x) exp(k*x)).
3027 (cond ((and (equal ll
0.
)
3029 ;; Use the substitution s + 1 = exp(k*x). The
3030 ;; integral becomes integrate(f(s+1)/(s+1),s,0,inf)
3031 (setq ans
(m+t -
1 (cadr ans
))))
3033 ;; Use the substitution y=exp(k*x) because the
3034 ;; limits are minf to inf.
3035 (setq ans
(cadr ans
))))
3036 ;; Apply the substitution and integrate it.
3037 (intcv ans nil ivar ll ul
)))))
3039 ;; integrate(log(g(x))*f(x),x,0,inf)
3040 (defun dintlog (exp arg ivar ll ul
)
3041 (let ((*dintlog-recur
* (1+ *dintlog-recur
*))) ;recursion stopper
3043 (cond ((and (eq ul
'$inf
)
3046 (equal 1 (sratsimp (m// exp
(m* (m- (subin-var (m^t ivar -
1)
3050 ;; Make the substitution y=1/x. If the integrand has
3051 ;; exactly the same form, the answer has to be 0.
3053 ((and (setq ans
(let (($gamma_expand t
)) (logx1 exp ll ul ivar
)))
3056 ((setq ans
(antideriv exp ivar
))
3057 ;; It's easy if we have the antiderivative.
3058 ;; but intsubs sometimes gives results containing %limit
3059 (return (intsubs ans ll ul ivar
))))
3060 ;; Ok, the easy cases didn't work. We now try integration by
3061 ;; parts. Set ANS to f(x).
3062 (setq ans
(m// exp
`((%log
) ,arg
)))
3063 (cond ((involve-var ans ivar
'(%log
))
3064 ;; Bad. f(x) contains a log term, so we give up.
3067 (equal 0.
(no-err-sub-var 0. ans ivar
))
3068 (setq d
(defint (m* ans
(m^t ivar
'*z
*))
3070 ;; The arg of the log function is the same as the
3071 ;; integration variable. We can do something a little
3072 ;; simpler than integration by parts. We have something
3073 ;; like f(x)*log(x). Consider f(x)*x^z. If we
3074 ;; differentiate this wrt to z, the integrand becomes
3075 ;; f(x)*log(x)*x^z. When we evaluate this at z = 0, we
3076 ;; get the desired integrand.
3078 ;; So we need f(0) to be 0 at 0. If we can integrate
3079 ;; f(x)*x^z, then we differentiate the result and
3080 ;; evaluate it at z = 0.
3081 (return (derivat '*z
* 1. d
0.
)))
3082 ((setq ans
(dintbypart `((%log
) ,arg
) ans ll ul ivar
))
3083 ;; Try integration by parts.
3086 ;; Compute diff(e,ivar,n) at the point pt.
3087 (defun derivat (ivar n e pt
)
3088 (subin-var pt
(apply '$diff
(list e ivar n
)) ivar
))
3092 ;; MAYBPC returns (COEF EXPO CONST)
3094 ;; This basically picks off b*x^n+a and returns the list
3096 (defun maybpc (e ivar nd-var
)
3098 (cond (*mtoinf
* (throw 'ggrm
(linpower0 e ivar
)))
3099 ((and (not *mtoinf
*)
3100 (null (setq e
(bx**n
+a e ivar
)))) ;bx**n+a --> (a n b) or nil.
3101 nil
) ;with ivar being x.
3102 ;; At this point, e is of the form (a n b)
3103 ((and (among '$%i
(caddr e
))
3104 (zerop1 ($realpart
(caddr e
)))
3105 (setq zn
($imagpart
(caddr e
)))
3106 (eq ($asksign
(cadr e
)) '$pos
))
3107 ;; If we're here, b is complex, and n > 0. zn = imagpart(b).
3109 ;; Set ivar to the same sign as zn.
3110 (cond ((eq ($asksign zn
) '$neg
)
3114 ;; zd = exp(ivar*%i*%pi*(1+nd)/(2*n). (ZD is special!)
3115 (setq zd
(m^t
'$%e
(m// (mul* ivar
'$%i
'$%pi
(m+t
1 nd-var
))
3117 ;; Return zn, n, a, zd.
3118 (values `(,(caddr e
) ,(cadr e
) ,(car e
)) zd
))
3119 ((and (or (eq (setq ivar
($asksign
($realpart
(caddr e
)))) '$neg
)
3120 (equal ivar
'$zero
))
3121 (equal ($imagpart
(cadr e
)) 0)
3122 (ratgreaterp (cadr e
) 0.
))
3123 ;; We're here if realpart(b) <= 0, and n >= 0. Then return -b, n, a.
3124 `(,(caddr e
) ,(cadr e
) ,(car e
))))))
3126 ;; Integrate x^m*exp(b*x^n+a), with realpart(m) > -1.
3128 ;; See Wang, pp. 84-85.
3130 ;; I believe the formula Wang gives is incorrect. The derivation is
3131 ;; correct except for the last step.
3133 ;; Let J = integrate(x^m*exp(%i*k*x^n),x,0,inf), with real k.
3135 ;; Consider the case for k < 0. Take a sector of a circle bounded by
3136 ;; the real line and the angle -%pi/(2*n), and by the radii, r and R.
3137 ;; Since there are no poles inside this contour, the integral
3139 ;; integrate(z^m*exp(%i*k*z^n),z) = 0
3141 ;; Then J = exp(-%pi*%i*(m+1)/(2*n))*integrate(R^m*exp(k*R^n),R,0,inf)
3143 ;; because the integral along the boundary is zero except for the part
3144 ;; on the real axis. (Proof?)
3146 ;; Wang seems to say this last integral is gamma(s/n/(-k)^s) where s =
3147 ;; (m+1)/n. But that seems wrong. If we use the substitution R =
3148 ;; (y/(-k))^(1/n), we end up with the result:
3150 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n).
3152 ;; or gamma((m+1)/n)/k^((m+1)/n)/n.
3154 ;; Note that this also handles the case of
3156 ;; integrate(x^m*exp(-k*x^n),x,0,inf);
3158 ;; where k is positive real number. A simple change of variables,
3161 ;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n))
3163 ;; which is the same form above.
3164 (defun ggr (e ind ivar
)
3165 (prog (c zd nn
* dn
* nd-var dosimp $%emode
)
3167 (cond (ind (setq e
($expand e
))
3168 (cond ((and (mplusp e
)
3169 (let ((*nodiverg
* t
))
3170 (setq e
(catch 'divergent
3175 (cond ((eq e
'divergent
) nil
)
3176 (t (return (sratsimp (cons '(mplus) e
)))))))))
3177 (setq e
(rmconst1 e ivar
))
3180 (cond ((multiple-value-setq (e zd
)
3181 (ggr1 e ivar nd-var
))
3182 ;; e = (m b n a). That is, the integral is of the form
3183 ;; x^m*exp(b*x^n+a). I think we want to compute
3184 ;; gamma((m+1)/n)/b^((m+1)/n)/n.
3186 ;; FIXME: If n > m + 1, the integral converges. We need
3187 ;; to check for this.
3188 (destructuring-bind (m b n a
)
3190 (when (and (not (zerop1 ($realpart b
)))
3191 (not (zerop1 ($imagpart b
))))
3192 ;; The derivation only holds if b is purely real or
3193 ;; purely imaginary. Give up if it's not.
3195 ;; Check for convergence. If b is complex, we need n -
3196 ;; m > 1. If b is real, we need b < 0.
3197 (when (and (zerop1 ($imagpart b
))
3198 (not (eq ($asksign b
) '$neg
)))
3200 (when (and (not (zerop1 ($imagpart b
)))
3201 (not (eq ($asksign
(sub n
(add m
1))) '$pos
)))
3204 (setq e
(gamma1 m
(cond ((zerop1 ($imagpart b
))
3205 ;; If we're here, b must be negative.
3208 ;; Complex b. Take the imaginary part
3209 `((mabs) ,($imagpart b
))))
3212 ;; FIXME: Why do we set %emode here? Shouldn't we just
3213 ;; bind it? And why do we want it bound to T anyway?
3214 ;; Shouldn't the user control that? The same goes for
3218 (setq e
(m* zd e
))))))
3219 (cond (e (return (m* c e
))))))
3222 ;; Match x^m*exp(b*x^n+a). If it does, return (list m b n a).
3223 (defun ggr1 (e ivar nd-var
)
3225 (cond ((atom e
) nil
)
3228 ;; We're looking at something like exp(f(ivar)). See if it's
3229 ;; of the form b*x^n+a, and return (list 0 b n a). (The 0 is
3230 ;; so we can graft something onto it if needed.)
3231 (cond ((multiple-value-setq (e zd
)
3232 (maybpc (caddr e
) ivar nd-var
))
3233 (values (cons 0. e
) zd
))))
3235 ;; E should be the product of exactly 2 terms
3237 ;; Check to see if one of the terms is of the form
3238 ;; ivar^p. If so, make sure the realpart of p > -1. If
3239 ;; so, check the other term has the right form via
3240 ;; another call to ggr1.
3241 (or (and (setq dn
* (xtorterm (cadr e
) ivar
))
3242 (ratgreaterp (setq nd-var
($realpart dn
*))
3244 (multiple-value-setq (nn* zd
)
3245 (ggr1 (caddr e
) ivar nd-var
)))
3246 (and (setq dn
* (xtorterm (caddr e
) ivar
))
3247 (ratgreaterp (setq nd-var
($realpart dn
*))
3249 (multiple-value-setq (nn* zd
)
3250 (ggr1 (cadr e
) ivar nd-var
)))))
3251 ;; Both terms have the right form and nn* contains the ivar of
3252 ;; the exponential term. Put dn* as the car of nn*. The
3253 ;; result is something like (m b n a) when we have the
3254 ;; expression x^m*exp(b*x^n+a).
3255 (values (rplaca nn
* dn
*) zd
)))))
3258 ;; Match b*x^n+a. If a match is found, return the list (a n b).
3259 ;; Otherwise, return NIL
3260 (defun bx**n
+a
(e ivar
)
3265 (t (let ((a (no-err-sub-var 0. e ivar
)))
3267 (t (setq e
(m+ e
(m*t -
1 a
)))
3268 (cond ((setq e
(bx**n e ivar
))
3272 ;; Match b*x^n. Return the list (n b) if found or NIL if not.
3273 (defun bx**n
(e ivar
)
3275 (and (setq n
(xexponget e ivar
))
3277 (setq e
(let (($maxposex
1)
3279 ($expand
(m// e
(m^t ivar n
)))))))
3282 ;; nn* should be the value of var. This is only called by bx**n with
3283 ;; the second arg of var.
3284 (defun xexponget (e nn
*)
3285 (cond ((atom e
) (cond ((eq e nn
*) 1.
)))
3289 (not (among nn
* (caddr e
))))
3291 (t (some #'(lambda (j) (xexponget j nn
*)) (cdr e
)))))
3294 ;;; given (b*x^n+a)^m returns (m a n b)
3295 (defun bxm (e ind ivar
)
3299 (involve-var e ivar
'(%log %sin %cos %tan
))
3300 (%einvolve-var e ivar
))
3303 ((mexptp e
) (cond ((among ivar
(caddr e
)) nil
)
3304 ((setq r
(bx**n
+a
(cadr e
) ivar
))
3305 (cons (caddr e
) r
))))
3306 ((setq r
(bx**n
+a e ivar
)) (cons 1. r
))
3308 ;;;Catches Unfactored forms.
3309 (multiple-value-bind (m r
)
3310 (numden-var (m// (sdiff e ivar
) e
)
3313 ((and (setq r
(bx**n
+a
(sratsimp r
) ivar
))
3314 (not (among ivar
(setq m
(m// m
(m* (cadr r
) (caddr r
)
3315 (m^t ivar
(m+t -
1 (cadr r
))))))))
3316 (setq e
(m// (subin-var 0. e ivar
) (m^t
(car r
) m
))))
3319 (t (setq e
(m^ e
(m// 1. m
)))
3320 (list m
(m* e
(car r
)) (cadr r
)
3321 (m* e
(caddr r
)))))))))
3324 ;;;Is E = VAR raised to some power? If so return power or 0.
3325 (defun findp (e ivar
)
3326 (cond ((not (among ivar e
)) 0.
)
3327 (t (xtorterm e ivar
))))
3329 (defun xtorterm (e ivar
)
3330 ;;;Is E = VAR1 raised to some power? If so return power.
3331 (cond ((alike1 e ivar
) 1.
)
3334 (alike1 (cadr e
) ivar
)
3335 (not (among ivar
(caddr e
))))
3339 (m^
(m* (m^
(caddr l
) '((rat) 1 2))
3340 (m+ (cadr l
) (m^
(m* (car l
) (caddr l
))
3344 (defun radbyterm (d l ivar
)
3349 (destructuring-let (((const . integrand
) (rmconst1 (car l
) ivar
)))
3350 (setq ans
(cons (m* const
(dintrad0 integrand d ivar
))
3353 (defun sqdtc (e ind ivar
)
3354 (prog (a b c varlist
)
3355 (setq varlist
(list ivar
))
3357 (setq e
(cdadr (ratrep* e
)))
3358 (setq c
(pdis (ptterm e
0)))
3359 (setq b
(m*t
(m//t
1 2) (pdis (ptterm e
1))))
3360 (setq a
(pdis (ptterm e
2)))
3361 (cond ((and (eq ($asksign
(m+ b
(m^
(m* a c
)
3365 (not (eq ($asksign a
) '$neg
))
3366 (eq ($asksign c
) '$pos
))
3367 (and (eq ($asksign a
) '$pos
)
3368 (not (eq ($asksign c
) '$neg
)))))
3369 (return (list a b c
))))))
3371 (defun difap1 (e pwr ivar m pt
)
3372 (m// (mul* (cond ((eq (ask-integer m
'$even
) '$yes
)
3376 (derivat ivar m e pt
))
3377 `((%gamma
) ,(m+ pwr m
))))
3379 ;; Note: This doesn't seem be called from anywhere.
3380 (defun sqrtinvolve (e ivar
)
3381 (cond ((atom e
) nil
)
3384 (and (mnump (caddr e
))
3385 (not (numberp (caddr e
)))
3386 (equal (caddr (caddr e
)) 2.
))
3387 (among ivar
(cadr e
)))
3389 (t (some #'(lambda (a)
3390 (sqrtinvolve a ivar
))
3393 (defun bydif (r s d ivar
)
3395 (setq d
(m+ (m*t
'*z
* ivar
) d
))
3396 (cond ((or (zerop1 (setq p
(m+ s
(m*t -
1 r
))))
3397 (and (zerop1 (m+ 1 p
))
3399 (difap1 (dintrad0 b
(m^ d
'((rat) 3 2)) ivar
)
3400 '((rat) 3 2) '*z
* r
0))
3401 ((eq ($asksign p
) '$pos
)
3402 (difap1 (difap1 (dintrad0 1 (m^
(m+t
'z
** d
)
3405 '((rat) 3 2) '*z
* r
0)
3406 '((rat) 3 2) 'z
** p
0)))))
3408 (defun dintrad0 (n d ivar
)
3410 (cond ((and (mexptp d
)
3411 (equal (deg-var (cadr d
) ivar
) 2.
))
3412 (cond ((alike1 (caddr d
) '((rat) 3.
2.
))
3413 (cond ((and (equal n
1.
)
3414 (setq l
(sqdtc (cadr d
) t ivar
)))
3417 (setq l
(sqdtc (cadr d
) nil ivar
)))
3418 (tbf (reverse l
)))))
3419 ((and (setq r
(findp n ivar
))
3420 (or (eq ($asksign
(m+ -
1.
(m- r
) (m*t
2.
3424 (setq s
(m+ '((rat) -
3.
2.
) (caddr d
)))
3425 (eq ($asksign s
) '$pos
)
3426 (eq (ask-integer s
'$integer
) '$yes
))
3427 (bydif r s
(cadr d
) ivar
))
3428 ((polyinx n ivar nil
)
3429 (radbyterm d
(cdr n
) ivar
)))))))
3432 ;;;Looks at the IMAGINARY part of a log and puts it in the interval 0 2*%pi.
3433 (defun log-imag-0-2%pi
(x)
3434 (let ((plog (simplify ($rectform
`((%plog
) ,x
)))))
3435 ;; We take the $rectform above to make sure that the log is
3436 ;; expanded out for the situations where simplifying plog itself
3437 ;; doesn't do it. This should probably be considered a bug in the
3438 ;; plog simplifier and should be fixed there.
3439 (cond ((not (free plog
'%plog
))
3440 (subst '%log
'%plog plog
))
3442 (destructuring-let (((real . imag
) (trisplit plog
)))
3443 (cond ((eq ($asksign imag
) '$neg
)
3444 (setq imag
(m+ imag %pi2
)))
3445 ((eq ($asksign
(m- imag %pi2
)) '$pos
)
3446 (setq imag
(m- imag %pi2
)))
3448 (m+ real
(m* '$%i imag
)))))))
3451 ;;; Temporary fix for a lacking in taylor, which loses with %i in denom.
3452 ;;; Besides doesn't seem like a bad thing to do in general.
3453 (defun %i-out-of-denom
(exp)
3454 (let ((denom ($denom exp
)))
3455 (cond ((among '$%i denom
)
3456 ;; Multiply the denominator by it's conjugate to get rid of
3458 (let* ((den-conj (maxima-substitute (m- '$%i
) '$%i denom
))
3460 (new-denom (sratsimp (m* denom den-conj
)))
3461 (new-exp (sratsimp (m// (m* num den-conj
) new-denom
))))
3462 ;; If the new denominator still contains %i, just give up.
3463 (if (among '$%i
($denom new-exp
))
3468 ;;; LL and UL must be real otherwise this routine return $UNKNOWN.
3469 ;;; Returns $no $unknown or a list of poles in the interval (*ll* *ul*)
3470 ;;; for exp w.r.t. ivar.
3471 ;;; Form of list ((pole . multiplicity) (pole1 . multiplicity) ....)
3472 (defun poles-in-interval (exp ivar ll ul
)
3473 (let* ((denom (cond ((mplusp exp
)
3474 ($denom
(sratsimp exp
)))
3476 (free (caddr exp
) ivar
)
3477 (eq ($asksign
(caddr exp
)) '$neg
))
3478 (m^
(cadr exp
) (m- (caddr exp
))))
3480 (roots (real-roots denom ivar
))
3481 (ll-pole (limit-pole exp ivar ll
'$plus
))
3482 (ul-pole (limit-pole exp ivar ul
'$minus
)))
3483 (cond ((or (eq roots
'$failure
)
3485 (null ul-pole
)) '$unknown
)
3486 ((and (or (eq roots
'$no
)
3487 (member ($csign denom
) '($pos $neg $pn
)))
3488 ;; this clause handles cases where we can't find the exact roots,
3489 ;; but we know that they occur outside the interval of integration.
3490 ;; example: integrate ((1+exp(t))/sqrt(t+exp(t)), t, 0, 1);
3492 (eq ul-pole
'$no
)) '$no
)
3493 (t (cond ((equal roots
'$no
)
3495 (do ((dummy roots
(cdr dummy
))
3496 (pole-list (cond ((not (eq ll-pole
'$no
))
3500 (cond ((not (eq ul-pole
'$no
))
3501 (sort-poles (push `(,ul .
1) pole-list
)))
3502 ((not (null pole-list
))
3503 (sort-poles pole-list
))
3505 (let* ((soltn (caar dummy
))
3506 ;; (multiplicity (cdar dummy)) (not used? -- cwh)
3507 (root-in-ll-ul (in-interval soltn ll ul
)))
3508 (cond ((eq root-in-ll-ul
'$no
) '$no
)
3509 ((eq root-in-ll-ul
'$yes
)
3510 (let ((lim-ans (is-a-pole exp soltn ivar
)))
3511 (cond ((null lim-ans
)
3515 (t (push (car dummy
)
3516 pole-list
))))))))))))
3519 ;;;Returns $YES if there is no pole and $NO if there is one.
3520 (defun limit-pole (exp ivar limit direction
)
3521 (let ((ans (cond ((member limit
'($minf $inf
) :test
#'eq
)
3522 (cond ((eq (special-convergent-formp exp limit ivar
) '$yes
)
3524 (t (get-limit (m* exp ivar
) ivar limit direction
))))
3526 (cond ((eq ans
'$no
) '$no
)
3528 ((eq ans
'$und
) '$no
)
3529 ((equal ans
0.
) '$no
)
3532 ;;;Takes care of forms that the ratio test fails on.
3533 (defun special-convergent-formp (exp limit ivar
)
3534 (cond ((not (oscip-var exp ivar
)) '$no
)
3535 ((or (eq (sc-converg-form exp limit ivar
) '$yes
)
3536 (eq (exp-converg-form exp limit ivar
) '$yes
))
3540 (defun exp-converg-form (exp limit ivar
)
3542 (setq exparg
(%einvolve-var exp ivar
))
3543 (cond ((or (null exparg
)
3544 (freeof '$%i exparg
))
3550 (sratsimp (m// exp
(m^t
'$%e exparg
))))
3552 (equal (get-limit exp ivar limit
) 0))
3556 (defun sc-converg-form (exp limit ivar
)
3557 (prog (scarg trigpow
)
3558 (setq exp
($expand exp
))
3559 (setq scarg
(involve-var (sin-sq-cos-sq-sub exp
) ivar
'(%sin %cos
)))
3560 (cond ((null scarg
) (return '$no
))
3561 ((and (polyinx scarg ivar
())
3562 (eq ($asksign
(m- ($hipow scarg ivar
) 1)) '$pos
))
3564 ((not (freeof ivar
(sdiff scarg ivar
)))
3566 ((and (setq trigpow
($hipow exp
`((%sin
) ,scarg
)))
3567 (eq (ask-integer trigpow
'$odd
) '$yes
)
3568 (equal (get-limit (m// exp
`((%sin
) ,scarg
)) ivar limit
)
3571 ((and (setq trigpow
($hipow exp
`((%cos
) ,scarg
)))
3572 (eq (ask-integer trigpow
'$odd
) '$yes
)
3573 (equal (get-limit (m// exp
`((%cos
) ,scarg
)) ivar limit
)
3576 (t (return '$no
)))))
3578 (defun is-a-pole (exp soltn ivar
)
3580 (m* (maxima-substitute (m+ 'epsilon soltn
) ivar exp
)
3584 (defun in-interval (place *ll
* *ul
*)
3585 ;; real values for *ll* and *ul*; place can be imaginary.
3586 (let ((order (ask-greateq *ul
* *ll
*)))
3587 (cond ((eq order
'$yes
))
3588 ((eq order
'$no
) (let ((temp *ul
*)) (setq *ul
* *ll
* *ll
* temp
)))
3589 (t (merror (intl:gettext
"defint: failed to order limits of integration:~%~M")
3590 (list '(mlist simp
) *ll
* *ul
*)))))
3591 (if (not (equal ($imagpart place
) 0))
3593 (let ((lesseq-ul (ask-greateq *ul
* place
))
3594 (greateq-ll (ask-greateq place
*ll
*)))
3595 (if (and (eq lesseq-ul
'$yes
) (eq greateq-ll
'$yes
)) '$yes
'$no
))))
3597 ;; returns true or nil
3598 (defun strictly-in-interval (place ll ul
)
3599 ;; real values for ll and ul; place can be imaginary.
3600 (and (equal ($imagpart place
) 0)
3602 (eq ($asksign
(m+ ul
(m- place
))) '$pos
))
3604 (eq ($asksign
(m+ place
(m- ll
))) '$pos
))))
3606 (defun real-roots (exp ivar
)
3607 (let (($solvetrigwarn
(cond (*defintdebug
* t
) ;Rest of the code for
3608 (t ()))) ;TRIGS in denom needed.
3609 ($solveradcan
(cond ((or (among '$%i exp
)
3610 (among '$%e exp
)) t
)
3612 *roots
*failures
) ;special vars for solve.
3613 (cond ((not (among ivar exp
)) '$no
)
3614 (t (solve exp ivar
1)
3615 ;; If *failures is set, we may have missed some roots.
3616 ;; We still return the roots that we have found.
3617 (do ((dummy *roots
(cddr dummy
))
3620 (cond ((not (null rootlist
))
3623 (cond ((equal ($imagpart
(caddar dummy
)) 0)
3626 ($rectform
(caddar dummy
))
3630 (defun ask-greateq (x y
)
3631 ;;; Is x > y. X or Y can be $MINF or $INF, zeroA or zeroB.
3632 (let ((x (cond ((among 'zeroa x
)
3637 (subst 0 'epsilon x
))
3638 ((or (among '$inf x
)
3642 (y (cond ((among 'zeroa y
)
3647 (subst 0 'epsilon y
))
3648 ((or (among '$inf y
)
3660 (t (let ((ans ($asksign
(m+ x
(m- y
)))))
3661 (cond ((member ans
'($zero $pos
) :test
#'eq
)
3667 (defun sort-poles (pole-list)
3668 (sort pole-list
#'(lambda (x y
)
3669 (cond ((eq (ask-greateq (car x
) (car y
))
3674 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3676 ;;; Integrate Definite Integrals involving log and exp functions. The algorithm
3677 ;;; are taken from the paper "Evaluation of CLasses of Definite Integrals ..."
3678 ;;; by K.O.Geddes et. al.
3680 ;;; 1. CASE: Integrals generated by the Gamma function.
3685 ;;; I t log (t) expt(- t ) dt = s signum(s)
3692 ;;; (--- (gamma(z))! )
3698 ;;; The integral converges for:
3699 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3701 ;;; 2. CASE: Integrals generated by the Incomplete Gamma function.
3706 ;;; I t log (t) exp(- t ) dt = (--- (gamma_incomplete(a, x ))! )
3714 ;;; The integral converges for:
3715 ;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0.
3716 ;;; The shown solution is valid for s>0. For s<0 gamma_incomplete has to be
3717 ;;; replaced by gamma(a) - gamma_incomplete(a,x^s).
3719 ;;; 3. CASE: Integrals generated by the beta function.
3724 ;;; I log (1 - t) (1 - t) t log (t) dt =
3732 ;;; --- (--- (beta(z, w))! )!
3738 ;;; The integral converges for:
3739 ;;; n, m = 0, 1, 2, ..., s > -1 and r > -1.
3740 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3742 (defvar *debug-defint-log
* nil
)
3744 ;;; Recognize c*z^w*log(z)^m*exp(-t^s)
3746 (defun m2-log-exp-1 (expr ivar
)
3747 (when *debug-defint-log
*
3748 (format t
"~&M2-LOG-EXP-1 with ~A~%" expr
))
3752 ((mexpt) (z varp2
,ivar
) (w freevar2
,ivar
))
3753 ((mexpt) $%e
((mtimes) -
1 ((mexpt) (z varp2
,ivar
) (s freevar02
,ivar
))))
3754 ((mexpt) ((%log
) (z varp2
,ivar
)) (m freevar2
,ivar
)))))
3756 ;;; Recognize c*z^r*log(z)^n*(1-z)^s*log(1-z)^m
3758 (defun m2-log-exp-2 (expr ivar
)
3759 (when *debug-defint-log
*
3760 (format t
"~&M2-LOG-EXP-2 with ~A~%" expr
))
3764 ((mexpt) (z varp2
,ivar
) (r freevar2
,ivar
))
3765 ((mexpt) ((%log
) (z varp2
,ivar
)) (n freevar2
,ivar
))
3766 ((mexpt) ((mplus) 1 ((mtimes) -
1 (z varp2
,ivar
))) (s freevar2
,ivar
))
3767 ((mexpt) ((%log
) ((mplus) 1 ((mtimes)-
1 (z varp2
,ivar
)))) (m freevar2
,ivar
)))))
3769 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3771 (defun defint-log-exp (expr ivar ll ul
)
3776 ;; var1 is used as a parameter for differentiation. Add var1>0 to the
3777 ;; database, to get the desired simplification of the differentiation of
3778 ;; the gamma_incomplete function.
3779 (setq *global-defint-assumptions
*
3780 (cons (assume `((mgreaterp) ,var1
0))
3781 *global-defint-assumptions
*))
3785 (setq x
(m2-log-exp-1 expr ivar
)))
3786 ;; The integrand matches the cases 1 and 2.
3787 (let ((c (cdras 'c x
))
3791 ($gamma_expand nil
)) ; No expansion of Gamma functions.
3793 (when *debug-defint-log
*
3794 (format t
"~&DEFINT-LOG-EXP-1:~%")
3795 (format t
"~& : c = ~A~%" c
)
3796 (format t
"~& : w = ~A~%" w
)
3797 (format t
"~& : m = ~A~%" m
)
3798 (format t
"~& : s = ~A~%" s
))
3800 (cond ((and (zerop1 ll
)
3803 (not (eq ($sign s
) '$zero
))
3804 (eq ($sign
(div (add w
1) s
)) '$pos
))
3805 ;; Case 1: Generated by the Gamma function.
3808 (simplify (list '(%signum
) s
))
3809 (power s
(mul -
1 (add m
1)))
3810 ($at
($diff
(list '(%gamma
) var1
) var1 m
)
3813 (div (add w
1) s
))))))
3814 ((and (member ($sign ll
) '($pos $pz
))
3816 (or (= m
0) (= m
1)) ; Exclude m>1, because Maxima can not
3817 ; derivate the involved hypergeometric
3819 (or (and (eq ($sign s
) '$neg
)
3820 (eq ($sign
(div (add 1 w
) s
)) '$pos
))
3821 (and (eq ($sign s
) '$pos
)
3822 (eq ($sign
(div (add 1 w
) s
)) '$pos
))))
3823 ;; Case 2: Generated by the Incomplete Gamma function.
3824 (let ((f (if (eq ($sign s
) '$pos
)
3825 (list '(%gamma_incomplete
) var1
(power ll s
))
3826 (sub (list '(%gamma
) var1
)
3827 (list '(%gamma_incomplete
) var1
(power ll s
))))))
3830 (simplify (list '(%signum
) s
))
3831 (power s
(mul -
1 (add m
1)))
3832 ($at
($diff f var1 m
)
3833 (list '(mequal) var1
(div (add 1 w
) s
)))))))
3835 (setq result nil
)))))
3838 (setq x
(m2-log-exp-2 expr ivar
)))
3839 ;; Case 3: Generated by the Beta function.
3840 (let ((c (cdras 'c x
))
3848 (when *debug-defint-log
*
3849 (format t
"~&DEFINT-LOG-EXP-2:~%")
3850 (format t
"~& : c = ~A~%" c
)
3851 (format t
"~& : r = ~A~%" r
)
3852 (format t
"~& : n = ~A~%" n
)
3853 (format t
"~& : s = ~A~%" s
)
3854 (format t
"~& : m = ~A~%" m
))
3856 (cond ((and (integerp m
)
3860 (eq ($sign
(add 1 r
)) '$pos
)
3861 (eq ($sign
(add 1 s
)) '$pos
))
3864 ($at
($diff
($at
($diff
(list '(%beta
) var1 var2
)
3866 (list '(mequal) var2
(add 1 s
)))
3868 (list '(mequal) var1
(add 1 r
))))))
3870 (setq result nil
)))))
3873 ;; Simplify result and set $gamma_expand to global value
3874 (let (($gamma_expand $gamma_expand
)) (sratsimp result
))))
3876 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;