1;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;; 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;; The data in this file contains enhancments. ;;;;; 4;;; ;;;;; 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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 11(in-package :maxima) 12 13(macsyma-module defint) 14 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. 19;; 20;; i(grand,var,a,b) will be used for integrate(grand,var,a,b) 21 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;; 26;; nointegrate is a macsyma level flag which inhibits indefinite 27;;integration. 28;; abconv is a macsyma level flag which inhibits the absolute 29;;convergence test. 30;; 31;; $defint is the top level function that takes the user input 32;;and does minor changes to make the integrand ready for the package. 33;; 34;; next comes defint, which is the function that does the 35;;integration. it is often called recursively from the bowels of the 36;;package. defint does some of the easy cases and dispatches to: 37;; 38;; dintegrate. this program first sees if the limits of 39;;integration are 0,inf or minf,inf. if so it sends the problem to 40;;ztoinf or mtoinf, respectively. 41;; else, dintegrate tries: 42;; 43;; intsc1 - does integrals of sin's or cos's or exp(%i var)'s 44;; when the interval is 0,2 %pi or 0,%pi. 45;; method is conversion to rational function and find 46;; residues in the unit circle. [wang, pp 107-109] 47;; 48;; ratfnt - does rational functions over finite interval by 49;; doing polynomial part directly, and converting 50;; the rational part to an integral on 0,inf and finding 51;; the answer by residues. 52;; 53;; zto1 - i(x^(k-1)*(1-x)^(l-1),x,0,1) = beta(k,l) or 54;; i(log(x)*x^(x-1)*(1-x)^(l-1),x,0,1) = psi... 55;; [wang, pp 116,117] 56;; 57;; dintrad- i(x^m/(a*x^2+b*x+c)^(n+3/2),x,0,inf) [wang, p 74] 58;; 59;; dintlog- i(log(g(x))*f(x),x,0,inf) = 0 (by symmetry) or 60;; tries an integration by parts. (only routine to 61;; try integration by parts) [wang, pp 93-95] 62;; 63;; dintexp- i(f(exp(k*x)),x,a,inf) = i(f(x+1)/(x+1),x,0,inf) 64;; or i(f(x)/x,x,0,inf)/k. First case hold for a=0; 65;; the second for a=minf. [wang 96-97] 66;; 67;;dintegrate also tries indefinite integration based on certain 68;;predicates (such as abconv) and tries breaking up the integrand 69;;over a sum or tries a change of variable. 70;; 71;; ztoinf is the routine for doing integrals over the range 0,inf. 72;; it goes over a series of routines and sees if any will work: 73;; 74;; scaxn - sc(b*x^n) (sc stands for sin or cos) [wang, pp 81-83] 75;; 76;; ssp - a*sc^n(r*x)/x^m [wang, pp 86,87] 77;; 78;; zmtorat- rational function. done by multiplication by plog(-x) 79;; and finding the residues over the keyhole contour 80;; [wang, pp 59-61] 81;; 82;; log*rat- r(x)*log^n(x) [wang, pp 89-92] 83;; 84;; logquad0 log(x)/(a*x^2+b*x+c) uses formula 85;; i(log(x)/(x^2+2*x*a*cos(t)+a^2),x,0,inf) = 86;; t*log(a)/sin(t). a better formula might be 87;; i(log(x)/(x+b)/(x+c),x,0,inf) = 88;; (log^2(b)-log^2(c))/(2*(b-c)) 89;; 90;; batapp - x^(p-1)/(b*x^n+a)^m uses formula related to the beta 91;; function [wang, p 71] 92;; there is also a special case when m=1 and a*b<0 93;; see [wang, p 65] 94;; 95;; sinnu - x^-a*n(x)/d(x) [wang, pp 69-70] 96;; 97;; ggr - x^r*exp(a*x^n+b) 98;; 99;; dintexp- see dintegrate 100;; 101;; ztoinf also tries 1/2*mtoinf if the integrand is an even function 102;; 103;; mtoinf is the routine for doing integrals on minf,inf. 104;; it too tries a series of routines and sees if any succeed. 105;; 106;; scaxn - when the integrand is an even function, see ztoinf 107;; 108;; mtosc - exp(%i*m*x)*r(x) by residues on either the upper half 109;; plane or the lower half plane, depending on whether 110;; m is positive or negative. 111;; 112;; zmtorat- does rational function by finding residues in upper 113;; half plane 114;; 115;; dintexp- see dintegrate 116;; 117;; rectzto%pi2 - poly(x)*rat(exp(x)) by finding residues in 118;; rectangle [wang, pp98-100] 119;; 120;; ggrm - x^r*exp((x+a)^n+b) 121;; 122;; mtoinf also tries 2*ztoinf if the integrand is an even function. 123 124(load-macsyma-macros rzmac) 125 126(declare-top (special *def2* pcprntd *mtoinf* rsn* 127 sn* sd* leadcoef checkfactors 128 *nodiverg exp1 129 *ul1* *ll1* *dflag bptu bptd plm* zn 130 *updn ul ll exp pe* pl* rl* pl*1 rl*1 131 loopstop* var nn* nd* dn* p* 132 factors rlm* 133 $trigexpandplus $trigexpandtimes 134 plogabs *scflag* 135 *sin-cos-recur* *rad-poly-recur* *dintlog-recur* 136 *dintexp-recur* defintdebug *defint-assumptions* 137 *current-assumptions* 138 *global-defint-assumptions*) 139;;;rsn* is in comdenom. does a ratsimp of numerator. 140 ;expvar 141 (special $intanalysis $abconvtest $noprincipal $nointegrate) 142 ;impvar 143 (special $solveradcan $solvetrigwarn *roots *failures 144 $logabs $tlimswitch $maxposex $maxnegex 145 $trigsign $savefactors $radexpand $breakup $%emode 146 $float $exptsubst dosimp context rp-polylogp 147 %p%i half%pi %pi2 half%pi3 varlist genvar 148 $domain $m1pbranch errorsw 149 limitp $algebraic 150 ;;LIMITP T Causes $ASKSIGN to do special things 151 ;;For DEFINT like eliminate epsilon look for prin-inf 152 ;;take realpart and imagpart. 153 integer-info 154 ;;If LIMITP is non-null ask-integer conses 155 ;;its assumptions onto this list. 156 generate-atan2)) 157 ;If this switch is () then RPART returns ATAN's 158 ;instead of ATAN2's 159 160(declare-top (special infinities real-infinities infinitesimals)) 161 162;;These are really defined in LIMIT but DEFINT uses them also. 163(cond ((not (boundp 'infinities)) 164 (setq infinities '($inf $minf $infinity)) 165 (setq real-infinities '($inf $minf)) 166 (setq infinitesimals '($zeroa $zerob)))) 167 168(defmvar $intanalysis t 169 "When @code{true}, definite integration tries to find poles in the integrand 170in the interval of integration.") 171 172(defmvar defintdebug () "If true Defint prints out debugging information") 173 174(defmvar integerl nil 175 "An integer-list for non-atoms found out to be `integer's") 176 177(defmvar nonintegerl nil 178 "A non-integer-list for non-atoms found out to be `noninteger's") 179 180;; Not really sure what this is meant to do, but it's used by MTORAT, 181;; KEYHOLE, and POLELIST. 182(defvar *semirat* nil) 183 184(defmfun $defint (exp var ll ul) 185 186 ;; Distribute $defint over equations, lists, and matrices. 187 (cond ((mbagp exp) 188 (return-from $defint 189 (simplify 190 (cons (car exp) 191 (mapcar #'(lambda (e) 192 (simplify ($defint e var ll ul))) 193 (cdr exp))))))) 194 195 (let ((*global-defint-assumptions* ()) 196 (integer-info ()) (integerl integerl) (nonintegerl nonintegerl)) 197 (with-new-context (context) 198 (unwind-protect 199 (let ((*defint-assumptions* ()) (*def2* ()) (*rad-poly-recur* ()) 200 (*sin-cos-recur* ()) (*dintexp-recur* ()) (*dintlog-recur* 0.) 201 (ans nil) (orig-exp exp) (orig-var var) 202 (orig-ll ll) (orig-ul ul) 203 (pcprntd nil) (*nodiverg nil) ($logabs t) ; (limitp t) 204 (rp-polylogp ()) 205 ($%edispflag nil) ; to get internal representation 206 ($m1pbranch ())) ;Try this out. 207 208 (make-global-assumptions) ;sets *global-defint-assumptions* 209 (setq exp (ratdisrep exp)) 210 (setq var (ratdisrep var)) 211 (setq ll (ratdisrep ll)) 212 (setq ul (ratdisrep ul)) 213 (cond (($constantp var) 214 (merror (intl:gettext "defint: variable of integration cannot be a constant; found ~M") var)) 215 (($subvarp var) (setq var (gensym)) 216 (setq exp ($substitute var orig-var exp)))) 217 (cond ((not (atom var)) 218 (merror (intl:gettext "defint: variable of integration must be a simple or subscripted variable.~%defint: found ~M") var)) 219 ((or (among var ul) 220 (among var ll)) 221 (setq var (gensym)) 222 (setq exp ($substitute var orig-var exp)))) 223 (unless (lenient-extended-realp ll) 224 (merror (intl:gettext "defint: lower limit of integration must be real; found ~M") ll)) 225 (unless (lenient-extended-realp ul) 226 (merror (intl:gettext "defint: upper limit of integration must be real; found ~M") ul)) 227 228 (cond ((setq ans (defint exp var ll ul)) 229 (setq ans (subst orig-var var ans)) 230 (cond ((atom ans) ans) 231 ((and (free ans '%limit) 232 (free ans '%integrate) 233 (or (not (free ans '$inf)) 234 (not (free ans '$minf)) 235 (not (free ans '$infinity)))) 236 (diverg)) 237 ((not (free ans '$und)) 238 `((%integrate) ,orig-exp ,orig-var ,orig-ll ,orig-ul)) 239 (t ans))) 240 (t `((%integrate) ,orig-exp ,orig-var ,orig-ll ,orig-ul)))) 241 (forget-global-assumptions))))) 242 243(defun eezz (exp ll ul) 244 (cond ((or (polyinx exp var nil) 245 (catch 'pin%ex (pin%ex exp))) 246 (setq exp (antideriv exp)) 247 ;; If antideriv can't do it, returns nil 248 ;; use limit to evaluate every answer returned by antideriv. 249 (cond ((null exp) nil) 250 (t (intsubs exp ll ul)))))) 251;;;Hack the expression up for exponentials. 252 253(defun sinintp (expr var) 254 ;; Is this expr a candidate for SININT ? 255 (let ((expr (factor expr)) 256 (numer nil) 257 (denom nil)) 258 (setq numer ($num expr)) 259 (setq denom ($denom expr)) 260 (cond ((polyinx numer var nil) 261 (cond ((and (polyinx denom var nil) 262 (deg-lessp denom var 2)) 263 t))) 264 ;;ERF type things go here. 265 ((let ((exponent (%einvolve numer))) 266 (and (polyinx exponent var nil) 267 (deg-lessp exponent var 2))) 268 (cond ((free denom var) 269 t)))))) 270 271(defun deg-lessp (expr var power) 272 (cond ((or (atom expr) 273 (mnump expr)) t) 274 ((or (mtimesp expr) 275 (mplusp expr)) 276 (do ((ops (cdr expr) (cdr ops))) 277 ((null ops) t) 278 (cond ((not (deg-lessp (car ops) var power)) 279 (return ()))))) 280 ((mexptp expr) 281 (and (or (not (alike1 (cadr expr) var)) 282 (and (numberp (caddr expr)) 283 (not (eq (asksign (m+ power (m- (caddr expr)))) 284 '$negative)))) 285 (deg-lessp (cadr expr) var power))) 286 ((and (consp expr) 287 (member 'array (car expr)) 288 (not (eq var (caar expr)))) 289 ;; We have some subscripted variable that's not our variable 290 ;; (I think), so it's deg-lessp. 291 ;; 292 ;; FIXME: Is this the best way to handle this? Are there 293 ;; other cases we're mising here? 294 t))) 295 296(defun antideriv (a) 297 (let ((limitp ()) 298 (ans ()) 299 (generate-atan2 ())) 300 (setq ans (sinint a var)) 301 (cond ((among '%integrate ans) nil) 302 (t (simplify ans))))) 303 304;; This routine tries to take a limit a couple of ways. 305(defun get-limit (exp var val &optional (dir '$plus dir?)) 306 (let ((ans (if dir? 307 (funcall #'limit-no-err exp var val dir) 308 (funcall #'limit-no-err exp var val)))) 309 (if (and ans (not (among '%limit ans))) 310 ans 311 (when (member val '($inf $minf) :test #'eq) 312 (setq ans (limit-no-err (maxima-substitute (m^t var -1) var exp) 313 var 314 0 315 (if (eq val '$inf) '$plus '$minus))) 316 (if (among '%limit ans) nil ans))))) 317 318(defun limit-no-err (&rest argvec) 319 (declare (special errorsw)) 320 (let ((errorsw t) (ans nil)) 321 (setq ans (catch 'errorsw (apply #'$limit argvec))) 322 (if (eq ans t) nil ans))) 323 324;; test whether fun2 is inverse of fun1 at val 325(defun test-inverse (fun1 var1 fun2 var2 val) 326 (let* ((out1 (let ((var var1)) 327 (no-err-sub val fun1))) 328 (out2 (let ((var var2)) 329 (no-err-sub out1 fun2)))) 330 (alike1 val out2))) 331 332;; integration change of variable 333(defun intcv (nv flag) 334 (let ((d (bx**n+a nv)) 335 (*roots ()) (*failures ()) ($breakup ())) 336 (cond ((and (eq ul '$inf) 337 (equal ll 0) 338 (equal (cadr d) 1)) ()) 339 ((eq var 'yx) ; new var cannot be same as old var 340 ()) 341 (t 342 ;; This is a hack! If nv is of the form b*x^n+a, we can 343 ;; solve the equation manually instead of using solve. 344 ;; Why? Because solve asks us for the sign of yx and 345 ;; that's bogus. 346 (cond (d 347 ;; Solve yx = b*x^n+a, for x. Any root will do. So we 348 ;; have x = ((yx-a)/b)^(1/n). 349 (destructuring-bind (a n b) 350 d 351 (let ((root (power* (div (sub 'yx a) b) (inv n)))) 352 (cond (t 353 (setq d root) 354 (cond (flag (intcv2 d nv)) 355 (t (intcv1 d nv)))) 356 )))) 357 (t 358 (putprop 'yx t 'internal);; keep var from appearing in questions to user 359 (solve (m+t 'yx (m*t -1 nv)) var 1.) 360 (cond ((setq d ;; look for root that is inverse of nv 361 (do* ((roots *roots (cddr roots)) 362 (root (caddar roots) (caddar roots))) 363 ((null root) nil) 364 (if (and (or (real-infinityp ll) 365 (test-inverse nv var root 'yx ll)) 366 (or (real-infinityp ul) 367 (test-inverse nv var root 'yx ul))) 368 (return root)))) 369 (cond (flag (intcv2 d nv)) 370 (t (intcv1 d nv)))) 371 (t ())))))))) 372 373;; d: original variable (var) as a function of 'yx 374;; ind: boolean flag 375;; nv: new variable ('yx) as a function of original variable (var) 376(defun intcv1 (d nv) 377 (cond ((and (intcv2 d nv) 378 (equal ($imagpart *ll1*) 0) 379 (equal ($imagpart *ul1*) 0) 380 (not (alike1 *ll1* *ul1*))) 381 (let ((*def2* t)) 382 (defint exp1 'yx *ll1* *ul1*))))) 383 384;; converts limits of integration to values for new variable 'yx 385(defun intcv2 (d nv) 386 (intcv3 d nv) 387 (and (cond ((and (zerop1 (m+ ll ul)) 388 (evenfn nv var)) 389 (setq exp1 (m* 2 exp1) 390 *ll1* (limcp nv var 0 '$plus))) 391 (t (setq *ll1* (limcp nv var ll '$plus)))) 392 (setq *ul1* (limcp nv var ul '$minus)))) 393 394;; wrapper around limit, returns nil if 395;; limit not found (nounform returned), or undefined ($und or $ind) 396(defun limcp (a b c d) 397 (let ((ans ($limit a b c d))) 398 (cond ((not (or (null ans) 399 (among '%limit ans) 400 (among '$ind ans) 401 (among '$und ans))) 402 ans)))) 403 404;; rewrites exp, the integrand in terms of var, 405;; into exp1, the integrand in terms of 'yx. 406(defun intcv3 (d nv) 407 (setq exp1 (m* (sdiff d 'yx) 408 (subst d var (subst 'yx nv exp)))) 409 (setq exp1 (sratsimp exp1))) 410 411(defun integrand-changevar (d newvar exp var) 412 (m* (sdiff d newvar) 413 (subst d var exp))) 414 415(defun defint (exp var ll ul) 416 (let ((old-assumptions *defint-assumptions*) 417 (*current-assumptions* ()) 418 (limitp t)) 419 (unwind-protect 420 (prog () 421 (setq *current-assumptions* (make-defint-assumptions 'noask)) 422 (let ((exp (resimplify exp)) 423 (var (resimplify var)) 424 ($exptsubst t) 425 (loopstop* 0) 426 ;; D (not used? -- cwh) 427 ans nn* dn* nd* $noprincipal) 428 (cond ((setq ans (defint-list exp var ll ul)) 429 (return ans)) 430 ((or (zerop1 exp) 431 (alike1 ul ll)) 432 (return 0.)) 433 ((not (among var exp)) 434 (cond ((or (member ul '($inf $minf) :test #'eq) 435 (member ll '($inf $minf) :test #'eq)) 436 (diverg)) 437 (t (setq ans (m* exp (m+ ul (m- ll)))) 438 (return ans)))) 439 ;; Look for integrals which involve log and exp functions. 440 ;; Maxima has a special algorithm to get general results. 441 ((and (setq ans (defint-log-exp exp var ll ul))) 442 (return ans))) 443 (let* ((exp (rmconst1 exp)) 444 (c (car exp)) 445 (exp (%i-out-of-denom (cdr exp)))) 446 (cond ((and (not $nointegrate) 447 (not (atom exp)) 448 (or (among 'mqapply exp) 449 (not (member (caar exp) 450 '(mexpt mplus mtimes %sin %cos 451 %tan %sinh %cosh %tanh 452 %log %asin %acos %atan 453 %cot %acot %sec 454 %asec %csc %acsc 455 %derivative) :test #'eq)))) 456 (cond ((setq ans (antideriv exp)) 457 (setq ans (intsubs ans ll ul)) 458 (return (cond (ans (m* c ans)) (t nil)))) 459 (t (return nil))))) 460 (setq exp (tansc exp)) 461 (cond ((setq ans (initial-analysis exp var ll ul)) 462 (return (m* c ans)))) 463 (return nil)))) 464 (restore-defint-assumptions old-assumptions *current-assumptions*)))) 465 466(defun defint-list (exp var ll ul) 467 (cond ((mbagp exp) 468 (let ((ans (cons (car exp) 469 (mapcar 470 #'(lambda (sub-exp) 471 (defint sub-exp var ll ul)) 472 (cdr exp))))) 473 (cond (ans (simplify ans)) 474 (t nil)))) 475 (t nil))) 476 477(defun initial-analysis (exp var ll ul) 478 (let ((pole (cond ((not $intanalysis) 479 '$no) ;don't do any checking. 480 (t (poles-in-interval exp var ll ul))))) 481 (cond ((eq pole '$no) 482 (cond ((and (oddfn exp var) 483 (or (and (eq ll '$minf) 484 (eq ul '$inf)) 485 (eq ($sign (m+ ll ul)) 486 '$zero))) 0) 487 (t (parse-integrand exp var ll ul)))) 488 ((eq pole '$unknown) ()) 489 (t (principal-value-integral exp var ll ul pole))))) 490 491(defun parse-integrand (exp var ll ul) 492 (let (ans) 493 (cond ((setq ans (eezz exp ll ul)) ans) 494 ((and (ratp exp var) 495 (setq ans (method-by-limits exp var ll ul))) ans) 496 ((and (mplusp exp) 497 (setq ans (intbyterm exp t))) ans) 498 ((setq ans (method-by-limits exp var ll ul)) ans) 499 (t ())))) 500 501(defun rmconst1 (e) 502 (cond ((not (freeof var e)) 503 (partition e var 1)) 504 (t (cons e 1)))) 505 506 507(defun method-by-limits (exp var ll ul) 508 (let ((old-assumptions *defint-assumptions*)) 509 (setq *current-assumptions* (make-defint-assumptions 'noask)) 510 ;;Should be a PROG inside of unwind-protect, but Multics has a compiler 511 ;;bug wrt. and I want to test this code now. 512 (unwind-protect 513 (cond ((and (and (eq ul '$inf) 514 (eq ll '$minf)) 515 (mtoinf exp var))) 516 ((and (and (eq ul '$inf) 517 (equal ll 0.)) 518 (ztoinf exp var))) 519;;;This seems((and (and (eq ul '$inf) 520;;;fairly losing (setq exp (subin (m+ ll var) exp)) 521;;; (setq ll 0.)) 522;;; (ztoinf exp var))) 523 ((and (equal ll 0.) 524 (freeof var ul) 525 (eq ($asksign ul) '$pos) 526 (zto1 exp))) 527 ;; ((and (and (equal ul 1.) 528 ;; (equal ll 0.)) (zto1 exp))) 529 (t (dintegrate exp var ll ul))) 530 (restore-defint-assumptions old-assumptions *defint-assumptions*)))) 531 532 533(defun dintegrate (exp var ll ul) 534 (let ((ans nil) (arg nil) (*scflag* nil) 535 (*dflag nil) ($%emode t)) 536;;;NOT COMPLETE for sin's and cos's. 537 (cond ((and (not *sin-cos-recur*) 538 (oscip exp) 539 (setq *scflag* t) 540 (intsc1 ll ul exp))) 541 ((and (not *rad-poly-recur*) 542 (notinvolve exp '(%log)) 543 (not (%einvolve exp)) 544 (method-radical-poly exp var ll ul))) 545 ((and (not (equal *dintlog-recur* 2.)) 546 (setq arg (involve exp '(%log))) 547 (dintlog exp arg))) 548 ((and (not *dintexp-recur*) 549 (setq arg (%einvolve exp)) 550 (dintexp exp var))) 551 ((and (not (ratp exp var)) 552 (setq ans (let (($trigexpandtimes nil) 553 ($trigexpandplus t)) 554 ($trigexpand exp))) 555 (setq ans ($expand ans)) 556 (not (alike1 ans exp)) 557 (intbyterm ans t))) 558 ((setq ans (antideriv exp)) 559 (intsubs ans ll ul)) 560 (t nil)))) 561 562(defun method-radical-poly (exp var ll ul) 563;;;Recursion stopper 564 (let ((*rad-poly-recur* t) ;recursion stopper 565 (result ())) 566 (cond ((and (sinintp exp var) 567 (setq result (antideriv exp)) 568 (intsubs result ll ul))) 569 ((and (ratp exp var) 570 (setq result (ratfnt exp)))) 571 ((and (not *scflag*) 572 (not (eq ul '$inf)) 573 (radicalp exp var) 574 (kindp34) 575 (setq result (cv exp)))) 576 (t ())))) 577 578(defun principal-value-integral (exp var ll ul poles) 579 (let ((anti-deriv ())) 580 (cond ((not (null (setq anti-deriv (antideriv exp)))) 581 (cond ((not (null poles)) 582 (order-limits 'ask) 583 (cond ((take-principal anti-deriv ll ul poles)) 584 (t ())))))))) 585 586;; adds up integrals of ranges between each pair of poles. 587;; checks if whole thing is divergent as limits of integration approach poles. 588(defun take-principal (anti-deriv ll ul poles &aux ans merged-list) 589 ;;; calling $logcontract causes antiderivative of 1/(1-x^5) to blow up 590 ;; (setq anti-deriv (cond ((involve anti-deriv '(%log)) 591 ;; ($logcontract anti-deriv)) 592 ;; (t anti-deriv))) 593 (setq ans 0.) 594 (setq merged-list (interval-list poles ll ul)) 595 (do ((current-pole (cdr merged-list) (cdr current-pole)) 596 (previous-pole merged-list (cdr previous-pole))) 597 ((null current-pole) t) 598 (setq ans (m+ ans 599 (intsubs anti-deriv (m+ (caar previous-pole) 'epsilon) 600 (m+ (caar current-pole) (m- 'epsilon)))))) 601 602 (setq ans (get-limit (get-limit ans 'epsilon 0 '$plus) 'prin-inf '$inf)) 603 ;;Return section. 604 (cond ((or (null ans) 605 (not (free ans '$infinity)) 606 (not (free ans '$ind))) ()) 607 ((or (among '$minf ans) 608 (among '$inf ans) 609 (among '$und ans)) 610 (diverg)) 611 (t (principal) ans))) 612 613(defun interval-list (pole-list ll ul) 614 (let ((first (car (first pole-list))) 615 (last (caar (last pole-list)))) 616 (cond ((eq ul last) 617 (if (eq ul '$inf) 618 (setq pole-list (subst 'prin-inf '$inf pole-list)))) 619 (t (if (eq ul '$inf) 620 (setq ul 'prin-inf)) 621 (setq pole-list (append pole-list (list (cons ul 'ignored)))))) 622 (cond ((eq ll first) 623 (if (eq ll '$minf) 624 (setq pole-list (subst (m- 'prin-inf) '$minf pole-list)))) 625 (t (if (eq ll '$minf) 626 (setq ll (m- 'prin-inf))) 627 (setq pole-list (append (list (cons ll 'ignored)) pole-list))))) 628 pole-list) 629 630;; Assumes EXP is a rational expression with no polynomial part and 631;; converts the finite integration to integration over a half-infinite 632;; interval. The substitution y = (x-a)/(b-x) is used. Equivalently, 633;; x = (b*y+a)/(y+1). 634;; 635;; (I'm guessing CV means Change Variable here.) 636(defun cv (exp) 637 (if (not (or (real-infinityp ll) (real-infinityp ul))) 638 ;; FIXME! This is a hack. We apply the transformation with 639 ;; symbolic limits and then substitute the actual limits later. 640 ;; That way method-by-limits (usually?) sees a simpler 641 ;; integrand. 642 ;; 643 ;; See Bugs 938235 and 941457. These fail because $FACTOR is 644 ;; unable to factor the transformed result. This needs more 645 ;; work (in other places). 646 (let ((trans (integrand-changevar (m// (m+t 'll (m*t 'ul 'yx)) 647 (m+t 1. 'yx)) 648 'yx exp var))) 649 ;; If the limit is a number, use $substitute so we simplify 650 ;; the result. Do we really want to do this? 651 (setf trans (if (mnump ll) 652 ($substitute ll 'll trans) 653 (subst ll 'll trans))) 654 (setf trans (if (mnump ul) 655 ($substitute ul 'ul trans) 656 (subst ul 'ul trans))) 657 (method-by-limits trans 'yx 0. '$inf)) 658 ())) 659 660;; Integrate rational functions over a finite interval by doing the 661;; polynomial part directly, and converting the rational part to an 662;; integral from 0 to inf. This is evaluated via residues. 663(defun ratfnt (exp) 664 (let ((e (pqr exp))) 665 ;; PQR divides the rational expression and returns the quotient 666 ;; and remainder 667 (flet ((try-antideriv (e lo hi) 668 (let ((ans (antideriv e))) 669 (when ans 670 (intsubs ans lo hi))))) 671 672 (cond ((equal 0. (car e)) 673 ;; No polynomial part 674 (let ((ans (try-antideriv exp ll ul))) 675 (if ans 676 ans 677 (cv exp)))) 678 ((equal 0. (cdr e)) 679 ;; Only polynomial part 680 (eezz (car e) ll ul)) 681 (t 682 ;; A non-zero quotient and remainder. Combine the results 683 ;; together. 684 (let ((ans (try-antideriv (m// (cdr e) dn*) ll ul))) 685 (cond (ans 686 (m+t (eezz (car e) ll ul) 687 ans)) 688 (t 689 (m+t (eezz (car e) ll ul) 690 (cv (m// (cdr e) dn*))))))))))) 691 692;; I think this takes a rational expression E, and finds the 693;; polynomial part. A cons is returned. The car is the quotient and 694;; the cdr is the remainder. 695(defun pqr (e) 696 (let ((varlist (list var))) 697 (newvar e) 698 (setq e (cdr (ratrep* e))) 699 (setq dn* (pdis (ratdenominator e))) 700 (setq e (pdivide (ratnumerator e) (ratdenominator e))) 701 (cons (simplify (rdis (car e))) (simplify (rdis (cadr e)))))) 702 703 704(defun intbyterm (exp *nodiverg) 705 (let ((saved-exp exp)) 706 (cond ((mplusp exp) 707 (let ((ans (catch 'divergent 708 (andmapcar #'(lambda (new-exp) 709 (let ((*def2* t)) 710 (defint new-exp var ll ul))) 711 (cdr exp))))) 712 (cond ((null ans) nil) 713 ((eq ans 'divergent) 714 (let ((*nodiverg nil)) 715 (cond ((setq ans (antideriv saved-exp)) 716 (intsubs ans ll ul)) 717 (t nil)))) 718 (t (sratsimp (m+l ans)))))) 719;;;If leadop isn't plus don't do anything. 720 (t nil)))) 721 722(defun kindp34 nil 723 (numden exp) 724 (let* ((d dn*) 725 (a (cond ((and (zerop1 ($limit d var ll '$plus)) 726 (eq (limit-pole (m+ exp (m+ (m- ll) var)) 727 var ll '$plus) 728 '$yes)) 729 t) 730 (t nil))) 731 (b (cond ((and (zerop1 ($limit d var ul '$minus)) 732 (eq (limit-pole (m+ exp (m+ ul (m- var))) 733 var ul '$minus) 734 '$yes)) 735 t) 736 (t nil)))) 737 (or a b))) 738 739(defun diverg nil 740 (cond (*nodiverg (throw 'divergent 'divergent)) 741 (t (merror (intl:gettext "defint: integral is divergent."))))) 742 743(defun make-defint-assumptions (ask-or-not) 744 (cond ((null (order-limits ask-or-not)) ()) 745 (t (mapc 'forget *defint-assumptions*) 746 (setq *defint-assumptions* ()) 747 (let ((sign-ll (cond ((eq ll '$inf) '$pos) 748 ((eq ll '$minf) '$neg) 749 (t ($sign ($limit ll))))) 750 (sign-ul (cond ((eq ul '$inf) '$pos) 751 ((eq ul '$minf) '$neg) 752 (t ($sign ($limit ul))))) 753 (sign-ul-ll (cond ((and (eq ul '$inf) 754 (not (eq ll '$inf))) '$pos) 755 ((and (eq ul '$minf) 756 (not (eq ll '$minf))) '$neg) 757 (t ($sign ($limit (m+ ul (m- ll)))))))) 758 (cond ((eq sign-ul-ll '$pos) 759 (setq *defint-assumptions* 760 `(,(assume `((mgreaterp) ,var ,ll)) 761 ,(assume `((mgreaterp) ,ul ,var))))) 762 ((eq sign-ul-ll '$neg) 763 (setq *defint-assumptions* 764 `(,(assume `((mgreaterp) ,var ,ul)) 765 ,(assume `((mgreaterp) ,ll ,var)))))) 766 (cond ((and (eq sign-ll '$pos) 767 (eq sign-ul '$pos)) 768 (setq *defint-assumptions* 769 `(,(assume `((mgreaterp) ,var 0)) 770 ,@*defint-assumptions*))) 771 ((and (eq sign-ll '$neg) 772 (eq sign-ul '$neg)) 773 (setq *defint-assumptions* 774 `(,(assume `((mgreaterp) 0 ,var)) 775 ,@*defint-assumptions*))) 776 (t *defint-assumptions*)))))) 777 778(defun restore-defint-assumptions (old-assumptions assumptions) 779 (do ((llist assumptions (cdr llist))) 780 ((null llist) t) 781 (forget (car llist))) 782 (do ((llist old-assumptions (cdr llist))) 783 ((null llist) t) 784 (assume (car llist)))) 785 786(defun make-global-assumptions () 787 (setq *global-defint-assumptions* 788 (cons (assume '((mgreaterp) *z* 0.)) 789 *global-defint-assumptions*)) 790 ;; *Z* is a "zero parameter" for this package. 791 ;; Its also used to transform. 792 ;; limit(exp,var,val,dir) -- limit(exp,tvar,0,dir) 793 (setq *global-defint-assumptions* 794 (cons (assume '((mgreaterp) epsilon 0.)) 795 *global-defint-assumptions*)) 796 (setq *global-defint-assumptions* 797 (cons (assume '((mlessp) epsilon 1.0e-8)) 798 *global-defint-assumptions*)) 799 ;; EPSILON is used in principal value code to denote the familiar 800 ;; mathematical entity. 801 (setq *global-defint-assumptions* 802 (cons (assume '((mgreaterp) prin-inf 1.0e+8)) 803 *global-defint-assumptions*))) 804 805;;; PRIN-INF Is a special symbol in the principal value code used to 806;;; denote an end-point which is proceeding to infinity. 807 808(defun forget-global-assumptions () 809 (do ((llist *global-defint-assumptions* (cdr llist))) 810 ((null llist) t) 811 (forget (car llist))) 812 (cond ((not (null integer-info)) 813 (do ((llist integer-info (cdr llist))) 814 ((null llist) t) 815 (i-$remove `(,(cadar llist) ,(caddar llist))))))) 816 817(defun order-limits (ask-or-not) 818 (cond ((or (not (equal ($imagpart ll) 0)) 819 (not (equal ($imagpart ul) 0))) ()) 820 (t (cond ((alike1 ll (m*t -1 '$inf)) 821 (setq ll '$minf))) 822 (cond ((alike1 ul (m*t -1 '$inf)) 823 (setq ul '$minf))) 824 (cond ((alike1 ll (m*t -1 '$minf)) 825 (setq ll '$inf))) 826 (cond ((alike1 ul (m*t -1 '$minf)) 827 (setq ul '$inf))) 828 (cond ((eq ll ul) 829 ; We have minf <= ll = ul <= inf 830 ) 831 ((eq ul '$inf) 832 ; We have minf <= ll < ul = inf 833 ) 834 ((eq ll '$minf) 835 ; We have minf = ll < ul < inf 836 ; 837 ; Now substitute 838 ; 839 ; var -> -var 840 ; ll -> -ul 841 ; ul -> inf 842 ; 843 ; so that minf < ll < ul = inf 844 (setq exp (subin (m- var) exp)) 845 (setq ll (m- ul)) 846 (setq ul '$inf)) 847 ((or (eq ll '$inf) 848 (equal (complm ask-or-not) -1)) 849 ; We have minf <= ul < ll 850 ; 851 ; Now substitute 852 ; 853 ; exp -> -exp 854 ; ll <-> ul 855 ; 856 ; so that minf <= ll < ul 857 (setq exp (m- exp)) 858 (rotatef ll ul))) 859 t))) 860 861(defun complm (ask-or-not) 862 (let ((askflag (cond ((eq ask-or-not 'ask) t) 863 (t nil))) 864 (a ())) 865 (cond ((alike1 ul ll) 0.) 866 ((eq (setq a (cond (askflag ($asksign ($limit (m+t ul (m- ll))))) 867 (t ($sign ($limit (m+t ul (m- ll))))))) 868 '$pos) 869 1.) 870 ((eq a '$neg) -1) 871 (t 1.)))) 872 873;; Substitute a and b into integral e 874;; 875;; Looks for discontinuties in integral, and works around them. 876;; For example, in 877;; 878;; integrate(x^(2*n)*exp(-(x)^2),x) ==> 879;; -gamma_incomplete((2*n+1)/2,x^2)*x^(2*n+1)*abs(x)^(-2*n-1)/2 880;; 881;; the integral has a discontinuity at x=0. 882;; 883(defun intsubs (e a b) 884 (let ((edges (cond ((not $intanalysis) 885 '$no) ;don't do any checking. 886 (t (discontinuities-in-interval 887 (let (($algebraic t)) 888 (sratsimp e)) 889 var a b))))) 890 891 (cond ((or (eq edges '$no) 892 (eq edges '$unknown)) 893 (whole-intsubs e a b)) 894 (t 895 (do* ((l edges (cdr l)) 896 (total nil) 897 (a1 (car l) (car l)) 898 (b1 (cadr l) (cadr l))) 899 ((null (cdr l)) (if (every (lambda (x) x) total) 900 (m+l total))) 901 (push 902 (whole-intsubs e a1 b1) 903 total)))))) 904 905;; look for terms with a negative exponent 906;; 907;; recursively traverses exp in order to find discontinuities such as 908;; erfc(1/x-x) at x=0 909(defun discontinuities-denom (exp) 910 (cond ((atom exp) 1) 911 ((and (eq (caar exp) 'mexpt) 912 (not (freeof var (cadr exp))) 913 (not (member ($sign (caddr exp)) '($pos $pz)))) 914 (m^ (cadr exp) (m- (caddr exp)))) 915 (t 916 (m*l (mapcar #'discontinuities-denom (cdr exp)))))) 917 918;; returns list of places where exp might be discontinuous in var. 919;; list begins with ll and ends with ul, and include any values between 920;; ll and ul. 921;; return '$no or '$unknown if no discontinuities found. 922(defun discontinuities-in-interval (exp var ll ul) 923 (let* ((denom (discontinuities-denom exp)) 924 (roots (real-roots denom var))) 925 (cond ((eq roots '$failure) 926 '$unknown) 927 ((eq roots '$no) 928 '$no) 929 (t (do ((dummy roots (cdr dummy)) 930 (pole-list nil)) 931 ((null dummy) 932 (cond (pole-list 933 (append (list ll) 934 (sortgreat pole-list) 935 (list ul))) 936 (t '$no))) 937 (let ((soltn (caar dummy))) 938 ;; (multiplicity (cdar dummy)) ;; not used 939 (if (strictly-in-interval soltn ll ul) 940 (push soltn pole-list)))))))) 941 942 943;; Carefully substitute the integration limits A and B into the 944;; expression E. 945(defun whole-intsubs (e a b) 946 (cond ((easy-subs e a b)) 947 (t (setq *current-assumptions* 948 (make-defint-assumptions 'ask)) ;get forceful! 949 (let (($algebraic t)) 950 (setq e (sratsimp e)) 951 (cond ((limit-subs e a b)) 952 (t (same-sheet-subs e a b))))))) 953 954;; Try easy substitutions. Return NIL if we can't. 955(defun easy-subs (e ll ul) 956 (cond ((or (infinityp ll) (infinityp ul)) 957 ;; Infinite limits aren't easy 958 nil) 959 (t 960 (cond ((or (polyinx e var ()) 961 (and (not (involve e '(%log %asin %acos %atan %asinh %acosh %atanh %atan2 962 %gamma_incomplete %expintegral_ei))) 963 (free ($denom e) var))) 964 ;; It's easy if we have a polynomial. I (rtoy) think 965 ;; it's also easy if the denominator is free of the 966 ;; integration variable and also if the expression 967 ;; doesn't involve inverse functions. 968 ;; 969 ;; gamma_incomplete and expintegral_ie 970 ;; included because of discontinuity in 971 ;; gamma_incomplete(0, exp(%i*x)) and 972 ;; expintegral_ei(exp(%i*x)) 973 ;; 974 ;; XXX: Are there other cases we've forgotten about? 975 ;; 976 ;; So just try to substitute the limits into the 977 ;; expression. If no errors are produced, we're done. 978 (let ((ll-val (no-err-sub ll e)) 979 (ul-val (no-err-sub ul e))) 980 (cond ((or (eq ll-val t) 981 (eq ul-val t)) 982 ;; no-err-sub has returned T. An error was catched. 983 nil) 984 ((and ll-val ul-val) 985 (m- ul-val ll-val)) 986 (t nil)))) 987 (t nil))))) 988 989(defun limit-subs (e ll ul) 990 (cond ((involve e '(%atan %gamma_incomplete %expintegral_ei)) 991 ()) ; functions with discontinuities 992 (t (setq e ($multthru e)) 993 (let ((a1 ($limit e var ll '$plus)) 994 (a2 ($limit e var ul '$minus))) 995 (combine-ll-ans-ul-ans a1 a2))))) 996 997;; check for divergent integral 998(defun combine-ll-ans-ul-ans (a1 a2) 999 (cond ((member a1 '($inf $minf $infinity ) :test #'eq) 1000 (cond ((member a2 '($inf $minf $infinity) :test #'eq) 1001 (cond ((eq a2 a1) ()) 1002 (t (diverg)))) 1003 (t (diverg)))) 1004 ((member a2 '($inf $minf $infinity) :test #'eq) (diverg)) 1005 ((or (member a1 '($und $ind) :test #'eq) 1006 (member a2 '($und $ind) :test #'eq)) ()) 1007 (t (m- a2 a1)))) 1008 1009;;;This function works only on things with ATAN's in them now. 1010(defun same-sheet-subs (exp ll ul &aux ll-ans ul-ans) 1011 ;; POLES-IN-INTERVAL doesn't know about the poles of tan(x). Call 1012 ;; trigsimp to convert tan into sin/cos, which POLES-IN-INTERVAL 1013 ;; knows how to handle. 1014 ;; 1015 ;; XXX Should we fix POLES-IN-INTERVAL instead? 1016 ;; 1017 ;; XXX Is calling trigsimp too much? Should we just only try to 1018 ;; substitute sin/cos for tan? 1019 ;; 1020 ;; XXX Should the result try to convert sin/cos back into tan? (A 1021 ;; call to trigreduce would do it, among other things.) 1022 (let* ((exp (mfuncall '$trigsimp exp)) 1023 (poles (atan-poles exp ll ul))) 1024 ;;POLES -> ((mlist) ((mequal) ((%atan) foo) replacement) ......) 1025 ;;We can then use $SUBSTITUTE 1026 (setq ll-ans (limcp exp var ll '$plus)) 1027 (setq exp (sratsimp ($substitute poles exp))) 1028 (setq ul-ans (limcp exp var ul '$minus)) 1029 (if (and ll-ans 1030 ul-ans) 1031 (combine-ll-ans-ul-ans ll-ans ul-ans) 1032 nil))) 1033 1034(defun atan-poles (exp ll ul) 1035 `((mlist) ,@(atan-pole1 exp ll ul))) 1036 1037(defun atan-pole1 (exp ll ul &aux ipart) 1038 (cond 1039 ((mapatom exp) ()) 1040 ((matanp exp) ;neglect multiplicity and '$unknowns for now. 1041 (desetq (exp . ipart) (trisplit exp)) 1042 (cond 1043 ((not (equal (sratsimp ipart) 0)) ()) 1044 (t (let ((pole (poles-in-interval (let (($algebraic t)) 1045 (sratsimp (cadr exp))) 1046 var ll ul))) 1047 (cond ((and pole (not (or (eq pole '$unknown) 1048 (eq pole '$no)))) 1049 (do ((l pole (cdr l)) (llist ())) 1050 ((null l) llist) 1051 (cond 1052 ((zerop1 (m- (caar l) ll)) t) ; don't worry about discontinuity 1053 ((zerop1 (m- (caar l) ul)) t) ; at boundary of integration 1054 (t (let ((low-lim ($limit (cadr exp) var (caar l) '$minus)) 1055 (up-lim ($limit (cadr exp) var (caar l) '$plus))) 1056 (cond ((and (not (eq low-lim up-lim)) 1057 (real-infinityp low-lim) 1058 (real-infinityp up-lim)) 1059 (let ((change (if (eq low-lim '$minf) 1060 (m- '$%pi) 1061 '$%pi))) 1062 (setq llist (cons `((mequal simp) ,exp ,(m+ exp change)) 1063 llist))))))))))))))) 1064 (t (do ((l (cdr exp) (cdr l)) 1065 (llist ())) 1066 ((null l) llist) 1067 (setq llist (append llist (atan-pole1 (car l) ll ul))))))) 1068 1069(defun difapply (n d s fn1) 1070 (prog (k m r $noprincipal) 1071 (cond ((eq ($asksign (m+ (deg d) (m- s) (m- 2.))) '$neg) 1072 (return nil))) 1073 (setq $noprincipal t) 1074 (cond ((or (not (mexptp d)) 1075 (not (numberp (setq r (caddr d))))) 1076 (return nil)) 1077 ((and (equal n 1.) 1078 (eq fn1 'mtorat) 1079 (equal 1. (deg (cadr d)))) 1080 (return 0.))) 1081 (setq m (deg (setq d (cadr d)))) 1082 (setq k (m// (m+ s 2.) m)) 1083 (cond ((eq (ask-integer (m// (m+ s 2.) m) '$any) '$yes) 1084 nil) 1085 (t (setq k (m+ 1 k)))) 1086 (cond ((eq ($sign (m+ r (m- k))) '$pos) 1087 (return (diffhk fn1 n d k (m+ r (m- k)))))))) 1088 1089(defun diffhk (fn1 n d r m) 1090 (prog (d1 *dflag) 1091 (setq *dflag t) 1092 (setq d1 (funcall fn1 n 1093 (m^ (m+t '*z* d) r) 1094 (m* r (deg d)))) 1095 (cond (d1 (return (difap1 d1 r '*z* m 0.)))))) 1096 1097(defun principal nil 1098 (cond ($noprincipal (diverg)) 1099 ((not pcprntd) 1100 (format t "Principal Value~%") 1101 (setq pcprntd t)))) 1102 1103;; e is of form poly(x)*exp(m*%i*x) 1104;; s is degree of denominator 1105;; adds e to bptu or bptd according to sign of m 1106(defun rib (e s) 1107 (let (*updn c) 1108 (cond ((or (mnump e) (constant e)) 1109 (setq bptu (cons e bptu))) 1110 (t (setq e (rmconst1 e)) 1111 (setq c (car e)) 1112 (setq nn* (cdr e)) 1113 (setq nd* s) 1114 (setq e (catch 'ptimes%e (ptimes%e nn* nd*))) 1115 (cond ((null e) nil) 1116 (t (setq e (m* c e)) 1117 (cond (*updn (setq bptu (cons e bptu))) 1118 (t (setq bptd (cons e bptd)))))))))) 1119 1120;; check term is of form poly(x)*exp(m*%i*x) 1121;; n is degree of denominator 1122(defun ptimes%e (term n) 1123 (cond ((and (mexptp term) 1124 (eq (cadr term) '$%e) 1125 (polyinx (caddr term) var nil) 1126 (eq ($sign (m+ (deg ($realpart (caddr term))) -1)) 1127 '$neg) 1128 (eq ($sign (m+ (deg (setq nn* ($imagpart (caddr term)))) 1129 -2.)) 1130 '$neg)) 1131 (cond ((eq ($asksign (ratdisrep (ratcoef nn* var))) '$pos) 1132 (setq *updn t)) 1133 (t (setq *updn nil))) 1134 term) 1135 ((and (mtimesp term) 1136 (setq nn* (polfactors term)) 1137 (or (null (car nn*)) 1138 (eq ($sign (m+ n (m- (deg (car nn*))))) 1139 '$pos)) 1140 (not (alike1 (cadr nn*) term)) 1141 (ptimes%e (cadr nn*) n) 1142 term)) 1143 (t (throw 'ptimes%e nil)))) 1144 1145(defun csemidown (n d var) 1146 (let ((pcprntd t)) ;Not sure what to do about PRINCIPAL values here. 1147 (princip (res n d #'lowerhalf #'(lambda (x) 1148 (cond ((equal ($imagpart x) 0) t) 1149 (t ()))))))) 1150 1151(defun lowerhalf (j) 1152 (eq ($asksign ($imagpart j)) '$neg)) 1153 1154(defun upperhalf (j) 1155 (eq ($asksign ($imagpart j)) '$pos)) 1156 1157 1158(defun csemiup (n d var) 1159 (let ((pcprntd t)) ;I'm not sure what to do about PRINCIPAL values here. 1160 (princip (res n d #'upperhalf #'(lambda (x) 1161 (cond ((equal ($imagpart x) 0) t) 1162 (t ()))))))) 1163 1164(defun princip (n) 1165 (cond ((null n) nil) 1166 (t (m*t '$%i ($rectform (m+ (cond ((car n) 1167 (m*t 2. (car n))) 1168 (t 0.)) 1169 (cond ((cadr n) 1170 (principal) 1171 (cadr n)) 1172 (t 0.)))))))) 1173 1174;; exponentialize sin and cos 1175(defun sconvert (e) 1176 (cond ((atom e) e) 1177 ((polyinx e var nil) e) 1178 ((eq (caar e) '%sin) 1179 (m* '((rat) -1 2) 1180 '$%i 1181 (m+t (m^t '$%e (m*t '$%i (cadr e))) 1182 (m- (m^t '$%e (m*t (m- '$%i) (cadr e))))))) 1183 ((eq (caar e) '%cos) 1184 (mul* '((rat) 1. 2.) 1185 (m+t (m^t '$%e (m*t '$%i (cadr e))) 1186 (m^t '$%e (m*t (m- '$%i) (cadr e)))))) 1187 (t (simplify 1188 (cons (list (caar e)) (mapcar #'sconvert (cdr e))))))) 1189 1190(defun polfactors (exp) 1191 (let (poly rest) 1192 (cond ((mplusp exp) nil) 1193 (t (cond ((mtimesp exp) 1194 (setq exp (reverse (cdr exp)))) 1195 (t (setq exp (list exp)))) 1196 (mapc #'(lambda (term) 1197 (cond ((polyinx term var nil) 1198 (push term poly)) 1199 (t (push term rest)))) 1200 exp) 1201 (list (m*l poly) (m*l rest)))))) 1202 1203(defun esap (e) 1204 (prog (d) 1205 (cond ((atom e) (return e)) 1206 ((not (among '$%e e)) (return e)) 1207 ((and (mexptp e) 1208 (eq (cadr e) '$%e)) 1209 (setq d ($imagpart (caddr e))) 1210 (return (m* (m^t '$%e ($realpart (caddr e))) 1211 (m+ `((%cos) ,d) 1212 (m*t '$%i `((%sin) ,d)))))) 1213 (t (return (simplify (cons (list (caar e)) 1214 (mapcar #'esap (cdr e))))))))) 1215 1216;; computes integral from minf to inf for expressions of the form 1217;; exp(%i*m*x)*r(x) by residues on either the upper half 1218;; plane or the lower half plane, depending on whether 1219;; m is positive or negative. [wang p. 77] 1220;; 1221;; exponentializes sin and cos before applying residue method. 1222;; can handle some expressions with poles on real line, such as 1223;; sin(x)*cos(x)/x. 1224(defun mtosc (grand) 1225 (numden grand) 1226 (let ((n nn*) 1227 (d dn*) 1228 ratterms ratans 1229 plf bptu bptd s upans downans) 1230 (cond ((not (or (polyinx d var nil) 1231 (and (setq grand (%einvolve d)) 1232 (among '$%i grand) 1233 (polyinx (setq d (sratsimp (m// d (m^t '$%e grand)))) 1234 var 1235 nil) 1236 (setq n (m// n (m^t '$%e grand)))))) nil) 1237 ((equal (setq s (deg d)) 0) nil) 1238;;;Above tests for applicability of this method. 1239 ((and (or (setq plf (polfactors n)) t) 1240 (setq n ($expand (cond ((car plf) 1241 (m*t 'x* (sconvert (cadr plf)))) 1242 (t (sconvert n))))) 1243 (cond ((mplusp n) (setq n (cdr n))) 1244 (t (setq n (list n)))) 1245 (dolist (term n t) 1246 (cond ((polyinx term var nil) 1247 ;; call to $expand can create rational terms 1248 ;; with no exp(m*%i*x) 1249 (setq ratterms (cons term ratterms))) 1250 ((rib term s)) 1251 (t (return nil)))) 1252;;;Function RIB sets up the values of BPTU and BPTD 1253 (cond ((car plf) 1254 (setq bptu (subst (car plf) 'x* bptu)) 1255 (setq bptd (subst (car plf) 'x* bptd)) 1256 (setq ratterms (subst (car plf) 'x* ratterms)) 1257 t) ;CROCK, CROCK. This is TERRIBLE code. 1258 (t t)) 1259;;;If there is BPTU then CSEMIUP must succeed. 1260;;;Likewise for BPTD. 1261 (setq ratans 1262 (if ratterms 1263 (let (($intanalysis nil)) 1264 ;; The original integrand was already 1265 ;; determined to have no poles by initial-analysis. 1266 ;; If individual terms of the expansion have poles, the poles 1267 ;; must cancel each other out, so we can ignore them. 1268 (try-defint (m// (m+l ratterms) d) var '$minf '$inf)) 1269 0)) 1270 ;; if integral of ratterms is divergent, ratans is nil, 1271 ;; and mtosc returns nil 1272 1273 (cond (bptu (setq upans (csemiup (m+l bptu) d var))) 1274 (t (setq upans 0))) 1275 (cond (bptd (setq downans (csemidown (m+l bptd) d var))) 1276 (t (setq downans 0)))) 1277 1278 (sratsimp (m+ ratans 1279 (m* '$%pi (m+ upans (m- downans))))))))) 1280 1281 1282(defun evenfn (e var) 1283 (let ((temp (m+ (m- e) 1284 (cond ((atom var) 1285 ($substitute (m- var) var e)) 1286 (t ($ratsubst (m- var) var e)))))) 1287 (cond ((zerop1 temp) 1288 t) 1289 ((zerop1 (sratsimp temp)) 1290 t) 1291 (t nil)))) 1292 1293(defun oddfn (e var) 1294 (let ((temp (m+ e (cond ((atom var) 1295 ($substitute (m- var) var e)) 1296 (t ($ratsubst (m- var) var e)))))) 1297 (cond ((zerop1 temp) 1298 t) 1299 ((zerop1 (sratsimp temp)) 1300 t) 1301 (t nil)))) 1302 1303(defun ztoinf (grand var) 1304 (prog (n d sn* sd* varlist 1305 s nc dc 1306 ans r $savefactors checkfactors temp test-var) 1307 (setq $savefactors t sn* (setq sd* (list 1.))) 1308 (cond ((eq ($sign (m+ loopstop* -1)) 1309 '$pos) 1310 (return nil)) 1311 ((setq temp (or (scaxn grand) 1312 (ssp grand))) 1313 (return temp)) 1314 ((involve grand '(%sin %cos %tan)) 1315 (setq grand (sconvert grand)) 1316 (go on))) 1317 1318 (cond ((polyinx grand var nil) 1319 (diverg)) 1320 ((and (ratp grand var) 1321 (mtimesp grand) 1322 (andmapcar #'snumden (cdr grand))) 1323 (setq nn* (m*l sn*) 1324 sn* nil) 1325 (setq dn* (m*l sd*) 1326 sd* nil)) 1327 (t (numden grand))) 1328;;; 1329;;;New section. 1330 (setq n (rmconst1 nn*)) 1331 (setq d (rmconst1 dn*)) 1332 (setq nc (car n)) 1333 (setq n (cdr n)) 1334 (setq dc (car d)) 1335 (setq d (cdr d)) 1336 (cond ((polyinx d var nil) 1337 (setq s (deg d))) 1338 (t (go findout))) 1339 (cond ((and (setq r (findp n)) 1340 (eq (ask-integer r '$integer) '$yes) 1341 (setq test-var (bxm d s)) 1342 (setq ans (apply 'fan (cons (m+ 1. r) test-var)))) 1343 (return (m* (m// nc dc) (sratsimp ans)))) 1344 ((and (ratp grand var) 1345 (setq ans (zmtorat n (cond ((mtimesp d) d) 1346 (t ($sqfr d))) 1347 s #'ztorat))) 1348 (return (m* (m// nc dc) ans))) 1349 ((and (evenfn d var) 1350 (setq nn* (p*lognxp n s))) 1351 (setq ans (log*rat (car nn*) d (cadr nn*))) 1352 (return (m* (m// nc dc) ans))) 1353 ((involve grand '(%log)) 1354 (cond ((setq ans (logquad0 grand)) 1355 (return (m* (m// nc dc) ans))) 1356 (t (return nil))))) 1357 findout 1358 (cond ((setq temp (batapp grand)) 1359 (return temp)) 1360 (t nil)) 1361 on 1362 (cond ((let ((*mtoinf* nil)) 1363 (setq temp (ggr grand t))) 1364 (return temp)) 1365 ((mplusp grand) 1366 (cond ((let ((*nodiverg t)) 1367 (setq ans (catch 'divergent 1368 (andmapcar #'(lambda (g) 1369 (ztoinf g var)) 1370 (cdr grand))))) 1371 (cond ((eq ans 'divergent) nil) 1372 (t (return (sratsimp (m+l ans))))))))) 1373 1374 (cond ((and (evenfn grand var) 1375 (setq loopstop* (m+ 1 loopstop*)) 1376 (setq ans (method-by-limits grand var '$minf '$inf))) 1377 (return (m*t '((rat) 1. 2.) ans))) 1378 (t (return nil))))) 1379 1380(defun ztorat (n d s) 1381 (cond ((and (null *dflag) 1382 (setq s (difapply n d s #'ztorat))) 1383 s) 1384 ((setq n (let ((plogabs ())) 1385 (keyhole (m* `((%plog) ,(m- var)) n) d var))) 1386 (m- n)) 1387 (t 1388 ;; Let's not signal an error here. Return nil so that we 1389 ;; eventually return a noun form if no other algorithm gives 1390 ;; a result. 1391 #+(or) 1392 (merror (intl:gettext "defint: keyhole integration failed.~%")) 1393 nil))) 1394 1395(setq *dflag nil) 1396 1397(defun logquad0 (exp) 1398 (let ((a ()) (b ()) (c ())) 1399 (cond ((setq exp (logquad exp)) 1400 (setq a (car exp) b (cadr exp) c (caddr exp)) 1401 ($asksign b) ;let the data base know about the sign of B. 1402 (cond ((eq ($asksign c) '$pos) 1403 (setq c (m^ (m// c a) '((rat) 1. 2.))) 1404 (setq b (simplify 1405 `((%acos) ,(add* 'epsilon (m// b (mul* 2. a c)))))) 1406 (setq a (m// (m* b `((%log) ,c)) 1407 (mul* a (simplify `((%sin) ,b)) c))) 1408 (get-limit a 'epsilon 0 '$plus)))) 1409 (t ())))) 1410 1411(defun logquad (exp) 1412 (let ((varlist (list var))) 1413 (newvar exp) 1414 (setq exp (cdr (ratrep* exp))) 1415 (cond ((and (alike1 (pdis (car exp)) 1416 `((%log) ,var)) 1417 (not (atom (cdr exp))) 1418 (equal (cadr (cdr exp)) 2.) 1419 (not (equal (ptterm (cddr exp) 0.) 0.))) 1420 (setq exp (mapcar 'pdis (cdr (oddelm (cdr exp))))))))) 1421 1422(defun mtoinf (grand var) 1423 (prog (ans ans1 sd* sn* p* pe* n d s nc dc $savefactors checkfactors temp) 1424 (setq $savefactors t) 1425 (setq sn* (setq sd* (list 1.))) 1426 (cond ((eq ($sign (m+ loopstop* -1)) '$pos) 1427 (return nil)) 1428 ((involve grand '(%sin %cos)) 1429 (cond ((and (evenfn grand var) 1430 (or (setq temp (scaxn grand)) 1431 (setq temp (ssp grand)))) 1432 (return (m*t 2. temp))) 1433 ((setq temp (mtosc grand)) 1434 (return temp)) 1435 (t (go en)))) 1436 ((among '$%i (%einvolve grand)) 1437 (cond ((setq temp (mtosc grand)) 1438 (return temp)) 1439 (t (go en))))) 1440 (setq grand ($exponentialize grand)) ; exponentializing before numden 1441 (cond ((polyinx grand var nil) ; avoids losing multiplicities [ 1309432 ] 1442 (diverg)) 1443 ((and (ratp grand var) 1444 (mtimesp grand) 1445 (andmapcar #'snumden (cdr grand))) 1446 (setq nn* (m*l sn*) sn* nil) 1447 (setq dn* (m*l sd*) sd* nil)) 1448 (t (numden grand))) 1449 (setq n (rmconst1 nn*)) 1450 (setq d (rmconst1 dn*)) 1451 (setq nc (car n)) 1452 (setq n (cdr n)) 1453 (setq dc (car d)) 1454 (setq d (cdr d)) 1455 (cond ((polyinx d var nil) 1456 (setq s (deg d)))) 1457 (cond ((and (not (%einvolve grand)) 1458 (notinvolve exp '(%sinh %cosh %tanh)) 1459 (setq p* (findp n)) 1460 (eq (ask-integer p* '$integer) '$yes) 1461 (setq pe* (bxm d s))) 1462 (cond ((and (eq (ask-integer (caddr pe*) '$even) '$yes) 1463 (eq (ask-integer p* '$even) '$yes)) 1464 (cond ((setq ans (apply 'fan (cons (m+ 1. p*) pe*))) 1465 (setq ans (m*t 2. ans)) 1466 (return (m* (m// nc dc) ans))))) 1467 ((equal (car pe*) 1.) 1468 (cond ((and (setq ans (apply 'fan (cons (m+ 1. p*) pe*))) 1469 (setq nn* (fan (m+ 1. p*) 1470 (car pe*) 1471 (m* -1 (cadr pe*)) 1472 (caddr pe*) 1473 (cadddr pe*)))) 1474 (setq ans (m+ ans (m*t (m^ -1 p*) nn*))) 1475 (return (m* (m// nc dc) ans)))))))) 1476 (cond 1477 ((and (ratp grand var) 1478 (setq ans1 (zmtorat n (cond ((mtimesp d) d) (t ($sqfr d))) s #'mtorat))) 1479 (setq ans (m*t '$%pi ans1)) 1480 (return (m* (m// nc dc) ans))) 1481 ((and (or (%einvolve grand) 1482 (involve grand '(%sinh %cosh %tanh))) 1483 (p*pin%ex n) ;setq's P* and PE*...Barf again. 1484 (setq ans (catch 'pin%ex (pin%ex d)))) 1485 ;; We have an integral of the form p(x)*F(exp(x)), where 1486 ;; p(x) is a polynomial. 1487 (cond ((null p*) 1488 ;; No polynomial 1489 (return (dintexp grand var))) 1490 ((not (and (zerop1 (get-limit grand var '$inf)) 1491 (zerop1 (get-limit grand var '$minf)))) 1492 ;; These limits must exist for the integral to converge. 1493 (diverg)) 1494 ((setq ans (rectzto%pi2 (m*l p*) (m*l pe*) d)) 1495 ;; This only handles the case when the F(z) is a 1496 ;; rational function. 1497 (return (m* (m// nc dc) ans))) 1498 ((setq ans (log-transform (m*l p*) (m*l pe*) d)) 1499 ;; If we get here, F(z) is not a rational function. 1500 ;; We transform it using the substitution x=log(y) 1501 ;; which gives us an integral of the form 1502 ;; p(log(y))*F(y)/y, which maxima should be able to 1503 ;; handle. 1504 (return (m* (m// nc dc) ans))) 1505 (t 1506 ;; Give up. We don't know how to handle this. 1507 (return nil))))) 1508 en 1509 (cond ((setq ans (ggrm grand)) 1510 (return ans)) 1511 ((and (evenfn grand var) 1512 (setq loopstop* (m+ 1 loopstop*)) 1513 (setq ans (method-by-limits grand var 0 '$inf))) 1514 (return (m*t 2. ans))) 1515 (t (return nil))))) 1516 1517(defun linpower0 (exp var) 1518 (cond ((and (setq exp (linpower exp var)) 1519 (eq (ask-integer (caddr exp) '$even) 1520 '$yes) 1521 (ratgreaterp 0. (car exp))) 1522 exp))) 1523 1524;;; given (b*x+a)^n+c returns (a b n c) 1525(defun linpower (exp var) 1526 (let (linpart deg lc c varlist) 1527 (cond ((not (polyp exp)) nil) 1528 (t (let ((varlist (list var))) 1529 (newvar exp) 1530 (setq linpart (cadr (ratrep* exp))) 1531 (cond ((atom linpart) 1532 nil) 1533 (t (setq deg (cadr linpart)) 1534;;;get high degree of poly 1535 (setq linpart ($diff exp var (m+ deg -1))) 1536;;;diff down to linear. 1537 (setq lc (sdiff linpart var)) 1538;;;all the way to constant. 1539 (setq linpart (sratsimp (m// linpart lc))) 1540 (setq lc (sratsimp (m// lc `((mfactorial) ,deg)))) 1541;;;get rid of factorial from differentiation. 1542 (setq c (sratsimp (m+ exp (m* (m- lc) 1543 (m^ linpart deg))))))) 1544;;;Sees if can be expressed as (a*x+b)^n + part freeof x. 1545 (cond ((not (among var c)) 1546 `(,lc ,linpart ,deg ,c)) 1547 (t nil))))))) 1548 1549(defun mtorat (n d s) 1550 (let ((*semirat* t)) 1551 (cond ((and (null *dflag) 1552 (setq s (difapply n d s #'mtorat))) 1553 s) 1554 (t (csemiup n d var))))) 1555 1556(defun zmtorat (n d s fn1) 1557 (prog (c) 1558 (cond ((eq ($sign (m+ s (m+ 1 (setq nn* (deg n))))) 1559 '$neg) 1560 (diverg)) 1561 ((eq ($sign (m+ s -4)) 1562 '$neg) 1563 (go on))) 1564 (setq d ($factor d)) 1565 (setq c (rmconst1 d)) 1566 (setq d (cdr c)) 1567 (setq c (car c)) 1568 (cond 1569 ((mtimesp d) 1570 (setq d (cdr d)) 1571 (setq n (partnum n d)) 1572 (let ((rsn* t)) 1573 (setq n ($xthru (m+l 1574 (mapcar #'(lambda (a b) 1575 (let ((foo (funcall fn1 (car a) b (deg b)))) 1576 (if foo (m// foo (cadr a)) 1577 (return-from zmtorat nil)))) 1578 n 1579 d))))) 1580 (return (cond (c (m// n c)) 1581 (t n))))) 1582 on 1583 1584 (setq n (funcall fn1 n d s)) 1585 (return (when n (sratsimp (cond (c (m// n c)) 1586 (t n))))))) 1587 1588(defun pfrnum (f g n n2 var) 1589 (let ((varlist (list var)) genvar) 1590 (setq f (polyform f) 1591 g (polyform g) 1592 n (polyform n) 1593 n2 (polyform n2)) 1594 (setq var (caadr (ratrep* var))) 1595 (setq f (resprog0 f g n n2)) 1596 (list (list (pdis (cadr f)) (pdis (cddr f))) 1597 (list (pdis (caar f)) (pdis (cdar f)))))) 1598 1599(defun polyform (e) 1600 (prog (f d) 1601 (newvar e) 1602 (setq f (ratrep* e)) 1603 (and (equal (cddr f) 1) 1604 (return (cadr f))) 1605 (and (equal (length (setq d (cddr f))) 3) 1606 (not (among (car d) 1607 (cadr f))) 1608 (return (list (car d) 1609 (- (cadr d)) 1610 (ptimes (cadr f) (caddr d))))) 1611 (merror "defint: bug from PFRNUM in RESIDU."))) 1612 1613(defun partnum (n dl) 1614 (let ((n2 1) ans nl) 1615 (do ((dl dl (cdr dl))) 1616 ((null (cdr dl)) 1617 (nconc ans (ncons (list n n2)))) 1618 (setq nl (pfrnum (car dl) (m*l (cdr dl)) n n2 var)) 1619 (setq ans (nconc ans (ncons (car nl)))) 1620 (setq n2 (cadadr nl) n (caadr nl) nl nil)))) 1621 1622(defun ggrm (e) 1623 (prog (poly expo *mtoinf* mb varlist genvar l c gvar) 1624 (setq varlist (list var)) 1625 (setq *mtoinf* t) 1626 (cond ((and (setq expo (%einvolve e)) 1627 (polyp (setq poly (sratsimp (m// e (m^t '$%e expo))))) 1628 (setq l (catch 'ggrm (ggr (m^t '$%e expo) nil)))) 1629 (setq *mtoinf* nil) 1630 (setq mb (m- (subin 0. (cadr l)))) 1631 (setq poly (m+ (subin (m+t mb var) poly) 1632 (subin (m+t mb (m*t -1 var)) poly)))) 1633 (t (return nil))) 1634 (setq expo (caddr l) 1635 c (cadddr l) 1636 l (m* -1 (car l)) 1637 e nil) 1638 (newvar poly) 1639 (setq poly (cdr (ratrep* poly))) 1640 (setq mb (m^ (pdis (cdr poly)) -1) 1641 poly (car poly)) 1642 (setq gvar (caadr (ratrep* var))) 1643 (cond ((or (atom poly) 1644 (pointergp gvar (car poly))) 1645 (setq poly (list 0. poly))) 1646 (t (setq poly (cdr poly)))) 1647 (return (do ((poly poly (cddr poly))) 1648 ((null poly) 1649 (mul* (m^t '$%e c) (m^t expo -1) mb (m+l e))) 1650 (setq e (cons (ggrm1 (car poly) (pdis (cadr poly)) l expo) 1651 e)))))) 1652 1653(defun ggrm1 (d k a b) 1654 (setq b (m// (m+t 1. d) b)) 1655 (m* k `((%gamma) ,b) (m^ a (m- b)))) 1656 1657;; Compute the integral(n/d,x,0,inf) by computing the negative of the 1658;; sum of residues of log(-x)*n/d over the poles of n/d inside the 1659;; keyhole contour. This contour is basically an disk with a slit 1660;; along the positive real axis. n/d must be a rational function. 1661(defun keyhole (n d var) 1662 (let* ((*semirat* ()) 1663 (res (res n d 1664 #'(lambda (j) 1665 ;; Ok if not on the positive real axis. 1666 (or (not (equal ($imagpart j) 0)) 1667 (eq ($asksign j) '$neg))) 1668 #'(lambda (j) 1669 (cond ((eq ($asksign j) '$pos) 1670 t) 1671 (t (diverg))))))) 1672 (when res 1673 (let ((rsn* t)) 1674 ($rectform ($multthru (m+ (cond ((car res) 1675 (car res)) 1676 (t 0.)) 1677 (cond ((cadr res) 1678 (cadr res)) 1679 (t 0.))))))))) 1680 1681;; Look at an expression e of the form sin(r*x)^k, where k is an 1682;; integer. Return the list (1 r k). (Not sure if the first element 1683;; of the list is always 1 because I'm not sure what partition is 1684;; trying to do here.) 1685(defun skr (e) 1686 (prog (m r k) 1687 (cond ((atom e) (return nil))) 1688 (setq e (partition e var 1)) 1689 (setq m (car e)) 1690 (setq e (cdr e)) 1691 (cond ((setq r (sinrx e)) 1692 (return (list m r 1))) 1693 ((and (mexptp e) 1694 (eq (ask-integer (setq k (caddr e)) '$integer) '$yes) 1695 (setq r (sinrx (cadr e)))) 1696 (return (list m r k)))))) 1697 1698;; Look at an expression e of the form sin(r*x) and return r. 1699(defun sinrx (e) 1700 (cond ((and (consp e) (eq (caar e) '%sin)) 1701 (cond ((eq (cadr e) var) 1702 1.) 1703 ((and (setq e (partition (cadr e) var 1)) 1704 (eq (cdr e) var)) 1705 (car e)))))) 1706 1707 1708 1709;; integrate(a*sc(r*x)^k/x^n,x,0,inf). 1710(defun ssp (exp) 1711 (prog (u n c arg) 1712 ;; Get the argument of the involved trig function. 1713 (when (null (setq arg (involve exp '(%sin %cos)))) 1714 (return nil)) 1715 ;; I don't think this needs to be special. 1716 #+nil 1717 (declare (special n)) 1718 ;; Replace (1-cos(arg)^2) with sin(arg)^2. 1719 (setq exp ($substitute ;(m^t `((%sin) ,var) 2.) 1720 ;(m+t 1. (m- (m^t `((%cos) ,var) 2.))) 1721 ;; The code from above generates expressions with 1722 ;; a missing simp flag. Furthermore, the 1723 ;; substitution has to be done for the complete 1724 ;; argument of the trig function. (DK 02/2010) 1725 `((mexpt simp) ((%sin simp) ,arg) 2) 1726 `((mplus) 1 ((mtimes) -1 ((mexpt) ((%cos) ,arg) 2))) 1727 exp)) 1728 (numden exp) 1729 (setq u nn*) 1730 (cond ((and (setq n (findp dn*)) 1731 (eq (ask-integer n '$integer) '$yes)) 1732 ;; n is the power of the denominator. 1733 (cond ((setq c (skr u)) 1734 ;; The simple case. 1735 (return (scmp c n))) 1736 ((and (mplusp u) 1737 (setq c (andmapcar #'skr (cdr u)))) 1738 ;; Do this for a sum of such terms. 1739 (return (m+l (mapcar #'(lambda (j) (scmp j n)) 1740 c))))))))) 1741 1742;; We have an integral of the form sin(r*x)^k/x^n. C is the list (1 r k). 1743;; 1744;; The substitution y=r*x converts this integral to 1745;; 1746;; r^(n-1)*integral(sin(y)^k/y^n,y,0,inf) 1747;; 1748;; (If r is negative, we need to negate the result.) 1749;; 1750;; The recursion Wang gives on p. 87 has a typo. The second term 1751;; should be subtracted from the first. This formula is given in G&R, 1752;; 3.82, formula 12. 1753;; 1754;; integrate(sin(x)^r/x^s,x) = 1755;; r*(r-1)/(s-1)/(s-2)*integrate(sin(x)^(r-2)/x^(s-2),x) 1756;; - r^2/(s-1)/(s-2)*integrate(sin(x)^r/x^(s-2),x) 1757;; 1758;; (Limits are assumed to be 0 to inf.) 1759;; 1760;; This recursion ends up with integrals with s = 1 or 2 and 1761;; 1762;; integrate(sin(x)^p/x,x,0,inf) = integrate(sin(x)^(p-1),x,0,%pi/2) 1763;; 1764;; with p > 0 and odd. This latter integral is known to maxima, and 1765;; it's value is beta(p/2,1/2)/2. 1766;; 1767;; integrate(sin(x)^2/x^2,x,0,inf) = %pi/2*binomial(q-3/2,q-1) 1768;; 1769;; where q >= 2. 1770;; 1771(defun scmp (c n) 1772 ;; Compute sign(r)*r^(n-1)*integrate(sin(y)^k/y^n,y,0,inf) 1773 (destructuring-bind (mult r k) 1774 c 1775 (let ((recursion (sinsp k n))) 1776 (if recursion 1777 (m* mult 1778 (m^ r (m+ n -1)) 1779 `((%signum) ,r) 1780 recursion) 1781 ;; Recursion failed. Return the integrand 1782 ;; The following code generates expressions with a missing simp flag 1783 ;; for the sin function. Use better simplifying code. (DK 02/2010) 1784; (let ((integrand (div (pow `((%sin) ,(m* r var)) 1785; k) 1786; (pow var n)))) 1787 (let ((integrand (div (power (take '(%sin) (mul r var)) 1788 k) 1789 (power var n)))) 1790 (m* mult 1791 `((%integrate) ,integrand ,var ,ll ,ul))))))) 1792 1793;; integrate(sin(x)^n/x^2,x,0,inf) = pi/2*binomial(n-3/2,n-1). 1794;; Express in terms of Gamma functions, though. 1795(defun sevn (n) 1796 (m* half%pi ($makegamma `((%binomial) ,(m+t (m+ n -1) '((rat) -1 2)) 1797 ,(m+ n -1))))) 1798 1799 1800;; integrate(sin(x)^n/x,x,0,inf) = beta((n+1)/2,1/2)/2, for n odd and 1801;; n > 0. 1802(defun sforx (n) 1803 (cond ((equal n 1.) 1804 half%pi) 1805 (t (bygamma (m+ n -1) 0.)))) 1806 1807;; This implements the recursion for computing 1808;; integrate(sin(y)^l/y^k,y,0,inf). (Note the change in notation from 1809;; the above!) 1810(defun sinsp (l k) 1811 (let ((i ()) 1812 (j ())) 1813 (cond ((eq ($sign (m+ l (m- (m+ k -1)))) 1814 '$neg) 1815 ;; Integral diverges if l-(k-1) < 0. 1816 (diverg)) 1817 ((not (even1 (m+ l k))) 1818 ;; If l + k is not even, return NIL. (Is this the right 1819 ;; thing to do?) 1820 nil) 1821 ((equal k 2.) 1822 ;; We have integrate(sin(y)^l/y^2). Use sevn to evaluate. 1823 (sevn (m// l 2.))) 1824 ((equal k 1.) 1825 ;; We have integrate(sin(y)^l/y,y) 1826 (sforx l)) 1827 ((eq ($sign (m+ k -2.)) 1828 '$pos) 1829 (setq i (m* (m+ k -1) 1830 (setq j (m+ k -2.)))) 1831 ;; j = k-2, i = (k-1)*(k-2) 1832 ;; 1833 ;; 1834 ;; The main recursion: 1835 ;; 1836 ;; i(sin(y)^l/y^k) 1837 ;; = l*(l-1)/(k-1)/(k-2)*i(sin(y)^(l-2)/y^k) 1838 ;; - l^2/(k-1)/(k-1)*i(sin(y)^l/y^(k-2)) 1839 (m+ (m* l (m+ l -1) 1840 (m^t i -1) 1841 (sinsp (m+ l -2.) j)) 1842 (m* (m- (m^ l 2)) 1843 (m^t i -1) 1844 (sinsp l j))))))) 1845 1846;; Returns the fractional part of a? 1847(defun fpart (a) 1848 (cond ((null a) 0.) 1849 ((numberp a) 1850 ;; Why do we return 0 if a is a number? Perhaps we really 1851 ;; mean integer? 1852 0.) 1853 ((mnump a) 1854 ;; If we're here, this basically assumes a is a rational. 1855 ;; Compute the remainder and return the result. 1856 (list (car a) (rem (cadr a) (caddr a)) (caddr a))) 1857 ((and (atom a) (abless1 a)) a) 1858 ((and (mplusp a) 1859 (null (cdddr a)) 1860 (abless1 (caddr a))) 1861 (caddr a)))) 1862 1863(defun thrad (e) 1864 (cond ((polyinx e var nil) 0.) 1865 ((and (mexptp e) 1866 (eq (cadr e) var) 1867 (mnump (caddr e))) 1868 (fpart (caddr e))) 1869 ((mtimesp e) 1870 (m+l (mapcar #'thrad e))))) 1871 1872 1873;;; THE FOLLOWING FUNCTION IS FOR TRIG FUNCTIONS OF THE FOLLOWING TYPE: 1874;;; LOWER LIMIT=0 B A MULTIPLE OF %PI SCA FUNCTION OF SIN (X) COS (X) 1875;;; B<=%PI2 1876 1877(defun period (p e var) 1878 (and (alike1 (no-err-sub var e) (setq e (no-err-sub (m+ p var) e))) 1879 ;; means there was no error 1880 (not (eq e t)))) 1881 1882; returns cons of (integer_part . fractional_part) of a 1883(defun infr (a) 1884 ;; I think we really want to compute how many full periods are in a 1885 ;; and the remainder. 1886 (let* ((q (igprt (div a (mul 2 '$%pi)))) 1887 (r (add a (mul -1 (mul q 2 '$%pi))))) 1888 (cons q r))) 1889 1890; returns cons of (integer_part . fractional_part) of a 1891(defun lower-infr (a) 1892 ;; I think we really want to compute how many full periods are in a 1893 ;; and the remainder. 1894 (let* (;(q (igprt (div a (mul 2 '$%pi)))) 1895 (q (mfuncall '$ceiling (div a (mul 2 '$%pi)))) 1896 (r (add a (mul -1 (mul q 2 '$%pi))))) 1897 (cons q r))) 1898 1899 1900;; Return the integer part of r. 1901(defun igprt (r) 1902 ;; r - fpart(r) 1903 (mfuncall '$floor r)) 1904 1905 1906;;;Try making exp(%i*var) --> yy, if result is rational then do integral 1907;;;around unit circle. Make corrections for limits of integration if possible. 1908(defun scrat (sc b) 1909 (let* ((exp-form (sconvert sc)) ;Exponentialize 1910 (rat-form (maxima-substitute 'yy (m^t '$%e (m*t '$%i var)) 1911 exp-form))) ;Try to make Rational fun. 1912 (cond ((and (ratp rat-form 'yy) 1913 (not (among var rat-form))) 1914 (cond ((alike1 b %pi2) 1915 (let ((ans (zto%pi2 rat-form 'yy))) 1916 (cond (ans ans) 1917 (t nil)))) 1918 ((and (eq b '$%pi) 1919 (evenfn exp-form var)) 1920 (let ((ans (zto%pi2 rat-form 'yy))) 1921 (cond (ans (m*t '((rat) 1. 2.) ans)) 1922 (t nil)))) 1923 ((and (alike1 b half%pi) 1924 (evenfn exp-form var) 1925 (alike1 rat-form 1926 (no-err-sub (m+t '$%pi (m*t -1 var)) 1927 rat-form))) 1928 (let ((ans (zto%pi2 rat-form 'yy))) 1929 (cond (ans (m*t '((rat) 1. 4.) ans)) 1930 (t nil))))))))) 1931 1932;;; Do integrals of sin and cos. this routine makes sure lower limit 1933;;; is zero. 1934(defun intsc1 (a b e) 1935 ;; integrate(e,var,a,b) 1936 (let ((trigarg (find-first-trigarg e)) 1937 (var var) 1938 ($%emode t) 1939 ($trigsign t) 1940 (*sin-cos-recur* t)) ;recursion stopper 1941 (prog (ans d nzp2 l int-zero-to-d int-nzp2 int-zero-to-c limit-diff) 1942 (let* ((arg (simple-trig-arg trigarg)) ;; pattern match sin(cc*x + bb) 1943 (cc (cdras 'c arg)) 1944 (bb (cdras 'b arg)) 1945 (new-var (gensym "NEW-VAR-"))) 1946 (when (or (not arg) 1947 (not (every-trigarg-alike e trigarg))) 1948 (return nil)) 1949 (when (not (and (equal cc 1) (equal bb 0))) 1950 (setq e (div (maxima-substitute (div (sub new-var bb) cc) 1951 var e) 1952 cc)) 1953 (setq var new-var) ;; change of variables to get sin(new-var) 1954 (setq a (add bb (mul a cc))) 1955 (setq b (add bb (mul b cc))))) 1956 (setq limit-diff (m+ b (m* -1 a))) 1957 (when (or (not (period %pi2 e var)) 1958 (not (and ($constantp a) 1959 ($constantp b)))) 1960 ;; Exit if b or a is not a constant or if the integrand 1961 ;; doesn't appear to have a period of 2 pi. 1962 (return nil)) 1963 1964 ;; Multiples of 2*%pi in limits. 1965 (cond ((integerp (setq d (let (($float nil)) 1966 (m// limit-diff %pi2)))) 1967 (cond ((setq ans (intsc e %pi2 var)) 1968 (return (m* d ans))) 1969 (t (return nil))))) 1970 1971 ;; The integral is not over a full period (2*%pi) or multiple 1972 ;; of a full period. 1973 1974 ;; Wang p. 111: The integral integrate(f(x),x,a,b) can be 1975 ;; written as: 1976 ;; 1977 ;; n * integrate(f,x,0,2*%pi) + integrate(f,x,0,c) 1978 ;; - integrate(f,x,0,d) 1979 ;; 1980 ;; for some integer n and d >= 0, c < 2*%pi because there exist 1981 ;; integers p and q such that a = 2 * p *%pi + d and b = 2 * q 1982 ;; * %pi + c. Then n = q - p. 1983 1984 ;; Compute q and c for the upper limit b. 1985 (setq b (infr b)) 1986 (setq l a) 1987 (cond ((null l) 1988 (setq nzp2 (car b)) 1989 (setq int-zero-to-d 0.) 1990 (go out))) 1991 ;; Compute p and d for the lower limit a. 1992 (setq l (infr l)) 1993 ;; avoid an extra trip around the circle - helps skip principal values 1994 (if (ratgreaterp (car b) (car l)) ; if q > p 1995 (setq l (cons (add 1 (car l)) ; p += 1 1996 (add (mul -1 %pi2) (cdr l))))) ; d -= 2*%pi 1997 1998 ;; Compute -integrate(f,x,0,d) 1999 (setq int-zero-to-d 2000 (cond ((setq ans (try-intsc e (cdr l) var)) 2001 (m*t -1 ans)) 2002 (t nil))) 2003 ;; Compute n = q - p (stored in nzp2) 2004 (setq nzp2 (m+ (car b) (m- (car l)))) 2005 out 2006 ;; Compute n*integrate(f,x,0,2*%pi) 2007 (setq int-nzp2 (cond ((zerop1 nzp2) 2008 ;; n = 0 2009 0.) 2010 ((setq ans (try-intsc e %pi2 var)) 2011 ;; n is not zero, so compute 2012 ;; integrate(f,x,0,2*%pi) 2013 (m*t nzp2 ans)) 2014 ;; Unable to compute integrate(f,x,0,2*%pi) 2015 (t nil))) 2016 ;; Compute integrate(f,x,0,c) 2017 (setq int-zero-to-c (try-intsc e (cdr b) var)) 2018 2019 (return (cond ((and int-zero-to-d int-nzp2 int-zero-to-c) 2020 ;; All three pieces succeeded. 2021 (add* int-zero-to-d int-nzp2 int-zero-to-c)) 2022 ((ratgreaterp %pi2 limit-diff) 2023 ;; Less than 1 full period, so intsc can integrate it. 2024 ;; Apply the substitution to make the lower limit 0. 2025 ;; This is last resort because substitution often causes intsc to fail. 2026 (intsc (maxima-substitute (m+ a var) var e) 2027 limit-diff var)) 2028 ;; nothing worked 2029 (t nil)))))) 2030 2031;; integrate(sc, var, 0, b), where sc is f(sin(x), cos(x)). 2032;; calls intsc with a wrapper to just return nil if integral is divergent, 2033;; rather than generating an error. 2034(defun try-intsc (sc b var) 2035 (let* ((*nodiverg t) 2036 (ans (catch 'divergent (intsc sc b var)))) 2037 (if (eq ans 'divergent) 2038 nil 2039 ans))) 2040 2041;; integrate(sc, var, 0, b), where sc is f(sin(x), cos(x)). I (rtoy) 2042;; think this expects b to be less than 2*%pi. 2043(defun intsc (sc b var) 2044 (if (zerop1 b) 2045 0 2046 (multiple-value-bind (b sc) 2047 (cond ((eq ($sign b) '$neg) 2048 (values (m*t -1 b) 2049 (m* -1 (subin (m*t -1 var) sc)))) 2050 (t 2051 (values b sc))) 2052 ;; Partition the integrand SC into the factors that do not 2053 ;; contain VAR (the car part) and the parts that do (the cdr 2054 ;; part). 2055 (setq sc (partition sc var 1)) 2056 (cond ((setq b (intsc0 (cdr sc) b var)) 2057 (m* (resimplify (car sc)) b)))))) 2058 2059;; integrate(sc, var, 0, b), where sc is f(sin(x), cos(x)). 2060(defun intsc0 (sc b var) 2061 ;; Determine if sc is a product of sin's and cos's. 2062 (let ((nn* (scprod sc)) 2063 (dn* ())) 2064 (cond (nn* 2065 ;; We have a product of sin's and cos's. We handle some 2066 ;; special cases here. 2067 (cond ((alike1 b half%pi) 2068 ;; Wang p. 110, formula (1): 2069 ;; integrate(sin(x)^m*cos(x)^n, x, 0, %pi/2) = 2070 ;; gamma((m+1)/2)*gamma((n+1)/2)/2/gamma((n+m+2)/2) 2071 (bygamma (car nn*) (cadr nn*))) 2072 ((eq b '$%pi) 2073 ;; Wang p. 110, near the bottom, says 2074 ;; 2075 ;; int(f(sin(x),cos(x)), x, 0, %pi) = 2076 ;; int(f(sin(x),cos(x)) + f(sin(x),-cos(x)),x,0,%pi/2) 2077 (cond ((eq (real-branch (cadr nn*) -1) '$yes) 2078 (m* (m+ 1. (m^ -1 (cadr nn*))) 2079 (bygamma (car nn*) (cadr nn*)))))) 2080 ((alike1 b %pi2) 2081 (cond ((or (and (eq (ask-integer (car nn*) '$even) 2082 '$yes) 2083 (eq (ask-integer (cadr nn*) '$even) 2084 '$yes)) 2085 (and (ratnump (car nn*)) 2086 (eq (real-branch (car nn*) -1) 2087 '$yes) 2088 (ratnump (cadr nn*)) 2089 (eq (real-branch (cadr nn*) -1) 2090 '$yes))) 2091 (m* 4. (bygamma (car nn*) (cadr nn*)))) 2092 ((or (eq (ask-integer (car nn*) '$odd) '$yes) 2093 (eq (ask-integer (cadr nn*) '$odd) '$yes)) 2094 0.) 2095 (t nil))) 2096 ((alike1 b half%pi3) 2097 ;; Wang, p. 111 says 2098 ;; 2099 ;; int(f(sin(x),cos(x)),x,0,3*%pi/2) = 2100 ;; int(f(sin(x),cos(x)),x,0,%pi) 2101 ;; + int(f(-sin(x),-cos(x)),x,0,%pi/2) 2102 (m* (m+ 1. (m^ -1 (cadr nn*)) (m^ -1 (m+l nn*))) 2103 (bygamma (car nn*) (cadr nn*)))))) 2104 (t 2105 ;; We don't have a product of sin's and cos's. 2106 (cond ((and (or (eq b '$%pi) 2107 (alike1 b %pi2) 2108 (alike1 b half%pi)) 2109 (setq dn* (scrat sc b))) 2110 dn*) 2111 ((setq nn* (antideriv sc)) 2112 (sin-cos-intsubs nn* var 0. b)) 2113 (t ())))))) 2114 2115;;;Is careful about substitution of limits where the denominator may be zero 2116;;;because of various assumptions made. 2117(defun sin-cos-intsubs (exp var ll ul) 2118 (cond ((mplusp exp) 2119 (let ((l (mapcar #'sin-cos-intsubs1 (cdr exp)))) 2120 (if (not (some #'null l)) 2121 (m+l l)))) 2122 (t (sin-cos-intsubs1 exp)))) 2123 2124(defun sin-cos-intsubs1 (exp) 2125 (let* ((rat-exp ($rat exp)) 2126 (denom (pdis (cddr rat-exp)))) 2127 (cond ((equal ($csign denom) '$zero) 2128 '$und) 2129 (t (try-intsubs exp ll ul))))) 2130 2131(defun try-intsubs (exp ll ul) 2132 (let* ((*nodiverg t) 2133 (ans (catch 'divergent (intsubs exp ll ul)))) 2134 (if (eq ans 'divergent) 2135 nil 2136 ans))) 2137 2138(defun try-defint (exp var ll ul) 2139 (let* ((*nodiverg t) 2140 (ans (catch 'divergent (defint exp var ll ul)))) 2141 (if (eq ans 'divergent) 2142 nil 2143 ans))) 2144 2145;; Determine whether E is of the form sin(x)^m*cos(x)^n and return the 2146;; list (m n). 2147(defun scprod (e) 2148 (let ((great-minus-1 #'(lambda (temp) 2149 (ratgreaterp temp -1))) 2150 m n) 2151 (cond 2152 ((setq m (powerofx e `((%sin) ,var) great-minus-1 var)) 2153 (list m 0.)) 2154 ((setq n (powerofx e `((%cos) ,var) great-minus-1 var)) 2155 (setq m 0.) 2156 (list 0. n)) 2157 ((and (mtimesp e) 2158 (or (setq m (powerofx (cadr e) `((%sin) ,var) great-minus-1 var)) 2159 (setq n (powerofx (cadr e) `((%cos) ,var) great-minus-1 var))) 2160 (cond 2161 ((null m) 2162 (setq m (powerofx (caddr e) `((%sin) ,var) great-minus-1 var))) 2163 (t (setq n (powerofx (caddr e) `((%cos) ,var) great-minus-1 var)))) 2164 (null (cdddr e))) 2165 (list m n)) 2166 (t ())))) 2167 2168(defun real-branch (exponent value) 2169 ;; Says wether (m^t value exponent) has at least one real branch. 2170 ;; Only works for values of 1 and -1 now. Returns $yes $no 2171 ;; $unknown. 2172 (cond ((equal value 1.) 2173 '$yes) 2174 ((eq (ask-integer exponent '$integer) '$yes) 2175 '$yes) 2176 ((ratnump exponent) 2177 (cond ((eq ($oddp (caddr exponent)) t) 2178 '$yes) 2179 (t '$no))) 2180 (t '$unknown))) 2181 2182;; Compute beta((m+1)/2,(n+1)/2)/2. 2183(defun bygamma (m n) 2184 (let ((one-half (m//t 1. 2.))) 2185 (m* one-half `(($beta) ,(m* one-half (m+t 1. m)) 2186 ,(m* one-half (m+t 1. n)))))) 2187 2188;;Seems like Guys who call this don't agree on what it should return. 2189(defun powerofx (e x p var) 2190 (setq e (cond ((not (among var e)) nil) 2191 ((alike1 e x) 1.) 2192 ((atom e) nil) 2193 ((and (mexptp e) 2194 (alike1 (cadr e) x) 2195 (not (among var (caddr e)))) 2196 (caddr e)))) 2197 (cond ((null e) nil) 2198 ((funcall p e) e))) 2199 2200 2201;; Check e for an expression of the form x^kk*(b*x^n+a)^l. If it 2202;; matches, Return the two values kk and (list l a n b). 2203(defun bata0 (e) 2204 (let (k c) 2205 (cond ((atom e) nil) 2206 ((mexptp e) 2207 ;; We have f(x)^y. Look to see if f(x) has the desired 2208 ;; form. Then f(x)^y has the desired form too, with 2209 ;; suitably modified values. 2210 ;; 2211 ;; XXX: Should we ask for the sign of f(x) if y is not an 2212 ;; integer? This transformation we're going to do requires 2213 ;; that f(x)^y be real. 2214 (destructuring-bind (mexp base power) 2215 e 2216 (declare (ignore mexp)) 2217 (multiple-value-bind (kk cc) 2218 (bata0 base) 2219 (when kk 2220 ;; Got a match. Adjust kk and cc appropriately. 2221 (destructuring-bind (l a n b) 2222 cc 2223 (values (mul kk power) 2224 (list (mul l power) a n b))))))) 2225 ((and (mtimesp e) 2226 (null (cdddr e)) 2227 (or (and (setq k (findp (cadr e))) 2228 (setq c (bxm (caddr e) (polyinx (caddr e) var nil)))) 2229 (and (setq k (findp (caddr e))) 2230 (setq c (bxm (cadr e) (polyinx (cadr e) var nil)))))) 2231 (values k c)) 2232 ((setq c (bxm e (polyinx e var nil))) 2233 (setq k 0.) 2234 (values k c))))) 2235 2236 2237;;(DEFUN BATAP (E) 2238;; (PROG (K C L) 2239;; (COND ((NOT (BATA0 E)) (RETURN NIL)) 2240;; ((AND (EQUAL -1. (CADDDR C)) 2241;; (EQ ($askSIGN (SETQ K (m+ 1. K))) 2242;; '$pos) 2243;; (EQ ($askSIGN (SETQ L (m+ 1. (CAR C)))) 2244;; '$pos) 2245;; (ALIKE1 (CADR C) 2246;; (m^ UL (CADDR C))) 2247;; (SETQ E (CADR C)) 2248;; (EQ ($askSIGN (SETQ C (CADDR C))) '$pos)) 2249;; (RETURN (M// (m* (m^ UL (m+t K (m* C (m+t -1. L)))) 2250;; `(($BETA) ,(SETQ NN* (M// K C)) 2251;; ,(SETQ DN* L))) 2252;; C)))))) 2253 2254 2255;; Integrals of the form i(log(x)^m*x^k*(a+b*x^n)^l,x,0,ul). There 2256;; are two cases to consider: One case has ul>0, b<0, a=-b*ul^n, k>-1, 2257;; l>-1, n>0, m a nonnegative integer. The second case has ul=inf, l < 0. 2258;; 2259;; These integrals are essentially partial derivatives of the Beta 2260;; function (i.e. the Eulerian integral of the first kind). Note 2261;; that, currently, with the default setting intanalysis:true, this 2262;; function might not even be called for some of these integrals. 2263;; However, this can be palliated by setting intanalysis:false. 2264 2265(defun zto1 (e) 2266 (when (or (mtimesp e) (mexptp e)) 2267 (let ((m 0) 2268 (log (list '(%log) var))) 2269 (flet ((set-m (p) 2270 (setq m p))) 2271 (find-if #'(lambda (fac) 2272 (powerofx fac log #'set-m var)) 2273 (cdr e))) 2274 (when (and (freeof var m) 2275 (eq (ask-integer m '$integer) '$yes) 2276 (not (eq ($asksign m) '$neg))) 2277 (setq e (m//t e (list '(mexpt) log m))) 2278 (cond 2279 ((eq ul '$inf) 2280 (multiple-value-bind (kk s d r cc) 2281 (batap-inf e) 2282 ;; We have i(x^kk/(d+cc*x^r)^s,x,0,inf) = 2283 ;; beta(aa,bb)/(cc^aa*d^bb*r). Compute this, and then 2284 ;; differentiate it m times to get the log term 2285 ;; incorporated. 2286 (when kk 2287 (let* ((aa (div (add 1 var) r)) 2288 (bb (sub s aa)) 2289 (m (if (eq ($asksign m) '$zero) 2290 0 2291 m))) 2292 (let ((res (div `(($beta) ,aa ,bb) 2293 (mul (m^t cc aa) 2294 (m^t d bb) 2295 r)))) 2296 ($at ($diff res var m) 2297 (list '(mequal) var kk))))))) 2298 (t 2299 (multiple-value-bind 2300 (k/n l n b) (batap-new e) 2301 (when k/n 2302 (let ((beta (simplify (list '($beta) k/n l))) 2303 (m (if (eq ($asksign m) '$zero) 0 m))) 2304 ;; The result looks like B(k/n,l) ( ... ). 2305 ;; Perhaps, we should just $factor, instead of 2306 ;; pulling out beta like this. 2307 (m*t 2308 beta 2309 ($fullratsimp 2310 (m//t 2311 (m*t 2312 (m^t (m-t b) (m1-t l)) 2313 (m^t ul (m*t n (m1-t l))) 2314 (m^t n (m-t (m1+t m))) 2315 ($at ($diff (m*t (m^t ul (m*t n var)) 2316 (list '($beta) var l)) 2317 var m) 2318 (list '(mequal) var k/n))) 2319 beta)))))))))))) 2320 2321 2322;;; If e is of the form given below, make the obvious change 2323;;; of variables (substituting ul*x^(1/n) for x) in order to reduce 2324;;; e to the usual form of the integrand in the Eulerian 2325;;; integral of the first kind. 2326;;; N. B: The old version of ZTO1 completely ignored this 2327;;; substitution; the log(x)s were just thrown in, which, 2328;;; of course would give wrong results. 2329 2330(defun batap-new (e) 2331 ;; Parse e 2332 (multiple-value-bind (k c) 2333 (bata0 e) 2334 (when k 2335 ;; e=x^k*(a+b*x^n)^l 2336 (destructuring-bind (l a n b) 2337 c 2338 (when (and (freeof var k) 2339 (freeof var n) 2340 (freeof var l) 2341 (alike1 a (m-t (m*t b (m^t ul n)))) 2342 (eq ($asksign b) '$neg) 2343 (eq ($asksign (setq k (m1+t k))) '$pos) 2344 (eq ($asksign (setq l (m1+t l))) '$pos) 2345 (eq ($asksign n) '$pos)) 2346 (values (m//t k n) l n b)))))) 2347 2348 2349;; Wang p. 71 gives the following formula for a beta function: 2350;; 2351;; integrate(x^(k-1)/(c*x^r+d)^s,x,0,inf) 2352;; = beta(a,b)/(c^a*d^b*r) 2353;; 2354;; where a = k/r > 0, b = s - a > 0, s > k > 0, r > 0, c*d > 0. 2355;; 2356;; This function matches this and returns k-1, d, r, c, a, b. And 2357;; also checks that all the conditions hold. If not, NIL is returned. 2358;; 2359(defun batap-inf (e) 2360 (multiple-value-bind (k c) 2361 (bata0 e) 2362 (when k 2363 (destructuring-bind (l d r cc) 2364 c 2365 (let* ((s (mul -1 l)) 2366 (kk (add k 1)) 2367 (a (div kk r)) 2368 (b (sub s a))) 2369 (when (and (freeof var k) 2370 (freeof var r) 2371 (freeof var l) 2372 (eq ($asksign kk) '$pos) 2373 (eq ($asksign a) '$pos) 2374 (eq ($asksign b) '$pos) 2375 (eq ($asksign (sub s k)) '$pos) 2376 (eq ($asksign r) '$pos) 2377 (eq ($asksign (mul cc d)) '$pos)) 2378 (values k s d r cc))))))) 2379 2380 2381;; Handles beta integrals. 2382(defun batapp (e) 2383 (cond ((not (or (equal ll 0) 2384 (eq ll '$minf))) 2385 (setq e (subin (m+ ll var) e)))) 2386 (multiple-value-bind (k c) 2387 (bata0 e) 2388 (cond ((null k) 2389 nil) 2390 (t 2391 (destructuring-bind (l d al c) 2392 c 2393 ;; e = x^k*(d+c*x^al)^l. 2394 (let ((new-k (m// (m+ 1 k) al))) 2395 (when (and (ratgreaterp al 0.) 2396 (eq ($asksign new-k) '$pos) 2397 (ratgreaterp (setq l (m* -1 l)) 2398 new-k) 2399 (eq ($asksign (m* d c)) 2400 '$pos)) 2401 (setq l (m+ l (m*t -1 new-k))) 2402 (m// `(($beta) ,new-k ,l) 2403 (mul* al (m^ c new-k) (m^ d l)))))))))) 2404 2405 2406;; Compute exp(d)*gamma((c+1)/b)/b/a^((c+1)/b). In essence, this is 2407;; the value of integrate(x^c*exp(d-a*x^b),x,0,inf). 2408(defun gamma1 (c a b d) 2409 (m* (m^t '$%e d) 2410 (m^ (m* b (m^ a (setq c (m// (m+t c 1) b)))) -1) 2411 `((%gamma) ,c))) 2412 2413(defun zto%pi2 (grand var) 2414 (let ((result (unitcir (sratsimp (m// grand var)) var))) 2415 (cond (result (sratsimp (m* (m- '$%i) result))) 2416 (t nil)))) 2417 2418;; Evaluates the contour integral of GRAND around the unit circle 2419;; using residues. 2420(defun unitcir (grand var) 2421 (numden grand) 2422 (let* ((sgn nil) 2423 (result (princip (res nn* dn* 2424 #'(lambda (pt) 2425 ;; Is pt stricly inside the unit circle? 2426 (setq sgn (let ((limitp nil)) 2427 ($asksign (m+ -1 (cabs pt))))) 2428 (eq sgn '$neg)) 2429 #'(lambda (pt) 2430 (declare (ignore pt)) 2431 ;; Is pt on the unit circle? (Use 2432 ;; the cached value computed 2433 ;; above.) 2434 (prog1 2435 (eq sgn '$zero) 2436 (setq sgn nil))))))) 2437 (when result 2438 (m* '$%pi result)))) 2439 2440 2441(defun logx1 (exp ll ul) 2442 (let ((arg nil)) 2443 (cond 2444 ((and (notinvolve exp '(%sin %cos %tan %atan %asin %acos)) 2445 (setq arg (involve exp '(%log)))) 2446 (cond ((eq arg var) 2447 (cond ((ratgreaterp 1. ll) 2448 (cond ((not (eq ul '$inf)) 2449 (intcv1 (m^t '$%e (m- 'yx)) (m- `((%log) ,var)))) 2450 (t (intcv1 (m^t '$%e 'yx) `((%log) ,var))))))) 2451 (t (intcv arg nil))))))) 2452 2453 2454;; Wang 81-83. Unfortunately, the pdf version has page 82 as all 2455;; black, so here is, as best as I can tell, what Wang is doing. 2456;; Fortunately, p. 81 has the necessary hints. 2457;; 2458;; First consider integrate(exp(%i*k*x^n),x) around the closed contour 2459;; consisting of the real axis from 0 to R, the arc from the angle 0 2460;; to %pi/(2*n) and the ray from the arc back to the origin. 2461;; 2462;; There are no poles in this region, so the integral must be zero. 2463;; But consider the integral on the three parts. The real axis is the 2464;; integral we want. The return ray is 2465;; 2466;; exp(%i*%pi/2/n) * integrate(exp(%i*k*(t*exp(%i*%pi/2/n))^n),t,R,0) 2467;; = exp(%i*%pi/2/n) * integrate(exp(%i*k*t^n*exp(%i*%pi/2)),t,R,0) 2468;; = -exp(%i*%pi/2/n) * integrate(exp(-k*t^n),t,0,R) 2469;; 2470;; As R -> infinity, this last integral is gamma(1/n)/k^(1/n)/n. 2471;; 2472;; We assume the integral on the circular arc approaches 0 as R -> 2473;; infinity. (Need to prove this.) 2474;; 2475;; Thus, we have 2476;; 2477;; integrate(exp(%i*k*t^n),t,0,inf) 2478;; = exp(%i*%pi/2/n) * gamma(1/n)/k^(1/n)/n. 2479;; 2480;; Equating real and imaginary parts gives us the desired results: 2481;; 2482;; integrate(cos(k*t^n),t,0,inf) = G * cos(%pi/2/n) 2483;; integrate(sin(k*t^n),t,0,inf) = G * sin(%pi/2/n) 2484;; 2485;; where G = gamma(1/n)/k^(1/n)/n. 2486;; 2487(defun scaxn (e) 2488 (let (ind s g) 2489 (cond ((atom e) nil) 2490 ((and (or (eq (caar e) '%sin) 2491 (eq (caar e) '%cos)) 2492 (setq ind (caar e)) 2493 (setq e (bx**n (cadr e)))) 2494 ;; Ok, we have cos(b*x^n) or sin(b*x^n), and we set e = (n 2495 ;; b) 2496 (cond ((equal (car e) 1.) 2497 ;; n = 1. Give up. (Why not divergent?) 2498 nil) 2499 ((zerop (setq s (let ((sign ($asksign (cadr e)))) 2500 (cond ((eq sign '$pos) 1) 2501 ((eq sign '$neg) -1) 2502 ((eq sign '$zero) 0))))) 2503 ;; s is the sign of b. Give up if it's zero. 2504 nil) 2505 ((not (eq ($asksign (m+ -1 (car e))) '$pos)) 2506 ;; Give up if n-1 <= 0. (Why give up? Isn't the 2507 ;; integral divergent?) 2508 nil) 2509 (t 2510 ;; We can apply our formula now. g = gamma(1/n)/n/b^(1/n) 2511 (setq g (gamma1 0. (m* s (cadr e)) (car e) 0.)) 2512 (setq e (m* g `((,ind) ,(m// half%pi (car e))))) 2513 (m* (cond ((and (eq ind '%sin) 2514 (equal s -1)) 2515 -1) 2516 (t 1)) 2517 e))))))) 2518 2519 2520;; this is the second part of the definite integral package 2521 2522(declare-top(special var plm* pl* rl* pl*1 rl*1)) 2523 2524(defun p*lognxp (a s) 2525 (let (b) 2526 (cond ((not (among '%log a)) 2527 ()) 2528 ((and (polyinx (setq b (maxima-substitute 1. `((%log) ,var) a)) 2529 var t) 2530 (eq ($sign (m+ s (m+ 1 (deg b)))) 2531 '$pos) 2532 (evenfn b var) 2533 (setq a (lognxp (sratsimp (m// a b))))) 2534 (list b a))))) 2535 2536(defun lognxp (a) 2537 (cond ((atom a) nil) 2538 ((and (eq (caar a) '%log) 2539 (eq (cadr a) var)) 1.) 2540 ((and (mexptp a) 2541 (numberp (caddr a)) 2542 (lognxp (cadr a))) 2543 (caddr a)))) 2544 2545(defun logcpi0 (n d) 2546 (prog (pl dp) 2547 (setq pl (polelist d #'upperhalf #'(lambda (j) 2548 (cond ((zerop1 j) nil) 2549 ((equal ($imagpart j) 0) 2550 t))))) 2551 (cond ((null pl) 2552 (return nil))) 2553 (setq factors (car pl) 2554 pl (cdr pl)) 2555 (cond ((or (cadr pl) 2556 (caddr pl)) 2557 (setq dp (sdiff d var)))) 2558 (cond ((setq plm* (car pl)) 2559 (setq rlm* (residue n (cond (leadcoef factors) 2560 (t d)) 2561 plm*)))) 2562 (cond ((setq pl* (cadr pl)) 2563 (setq rl* (res1 n dp pl*)))) 2564 (cond ((setq pl*1 (caddr pl)) 2565 (setq rl*1 (res1 n dp pl*1)))) 2566 (return (m*t (m//t 1. 2.) 2567 (m*t '$%pi 2568 (princip 2569 (list (cond ((setq nn* (append rl* rlm*)) 2570 (m+l nn*))) 2571 (cond (rl*1 (m+l rl*1)))))))))) 2572 2573(defun lognx2 (nn dn pl rl) 2574 (do ((pl pl (cdr pl)) 2575 (rl rl (cdr rl)) 2576 (ans ())) 2577 ((or (null pl) 2578 (null rl)) ans) 2579 (setq ans (cons (m* dn (car rl) (m^ `((%plog) ,(car pl)) nn)) 2580 ans)))) 2581 2582(defun logcpj (n d i) 2583 (setq n (append 2584 (if plm* 2585 (list (mul* (m*t '$%i %pi2) 2586 (m+l 2587 (residue (m* (m^ `((%plog) ,var) i) n) 2588 d 2589 plm*))))) 2590 (lognx2 i (m*t '$%i %pi2) pl* rl*) 2591 (lognx2 i %p%i pl*1 rl*1))) 2592 (if (null n) 2593 0 2594 (simplify (m+l n)))) 2595 2596;; Handle integral(n(x)/d(x)*log(x)^m,x,0,inf). n and d are 2597;; polynomials. 2598(defun log*rat (n d m) 2599 (declare (special *i* *j*)) 2600 (setq *i* (make-array (1+ m))) 2601 (setq *j* (make-array (1+ m))) 2602 (setf (aref *j* 0) 0) 2603 (prog (leadcoef factors plm* pl* rl* pl*1 rl*1 rlm*) 2604 (dotimes (c m (return (logcpi n d m))) 2605 (setf (aref *i* c) (logcpi n d c)) 2606 (setf (aref *j* c) (logcpj n factors c))))) 2607 2608(defun logcpi (n d c) 2609 (declare (special *j*)) 2610 (if (zerop c) 2611 (logcpi0 n d) 2612 (m* '((rat) 1 2) (m+ (aref *j* c) (m* -1 (sumi c)))))) 2613 2614(defun sumi (c) 2615 (declare (special *i*)) 2616 (do ((k 1 (1+ k)) 2617 (ans ())) 2618 ((= k c) 2619 (m+l ans)) 2620 (push (mul* ($makegamma `((%binomial) ,c ,k)) 2621 (m^t '$%pi k) 2622 (m^t '$%i k) 2623 (aref *i* (- c k))) 2624 ans))) 2625 2626(defun fan (p m a n b) 2627 (let ((povern (m// p n)) 2628 (ab (m// a b))) 2629 (cond 2630 ((or (eq (ask-integer povern '$integer) '$yes) 2631 (not (equal ($imagpart ab) 0))) ()) 2632 (t (let ((ind ($asksign ab))) 2633 (cond ((eq ind '$zero) nil) 2634 ((eq ind '$neg) nil) 2635 ((not (ratgreaterp m povern)) nil) 2636 (t (m// (m* '$%pi 2637 ($makegamma `((%binomial) ,(m+ -1 m (m- povern)) 2638 ,(m+t -1 m))) 2639 `((mabs) ,(m^ a (m+ povern (m- m))))) 2640 (m* (m^ b povern) 2641 n 2642 `((%sin) ,(m*t '$%pi povern))))))))))) 2643 2644 2645;;Makes a new poly such that np(x)-np(x+2*%i*%pi)=p(x). 2646;;Constructs general POLY of degree one higher than P with 2647;;arbitrary coeff. and then solves for coeffs by equating like powers 2648;;of the varibale of integration. 2649;;Can probably be made simpler now. 2650 2651(defun makpoly (p) 2652 (let ((n (deg p)) (ans ()) (varlist ()) (gp ()) (cl ()) (zz ())) 2653 (setq ans (genpoly (m+ 1 n))) ;Make poly with gensyms of 1 higher deg. 2654 (setq cl (cdr ans)) ;Coefficient list 2655 (setq varlist (append cl (list var))) ;Make VAR most important. 2656 (setq gp (car ans)) ;This is the poly with gensym coeffs. 2657;;;Now, poly(x)-poly(x+2*%i*%pi)=p(x), P is the original poly. 2658 (setq ans (m+ gp (subin (m+t (m*t '$%i %pi2) var) (m- gp)) (m- p))) 2659 (newvar ans) 2660 (setq ans (ratrep* ans)) ;Rational rep with VAR leading. 2661 (setq zz (coefsolve n cl (cond ((not (eq (caadr ans) ;What is Lead Var. 2662 (genfind (car ans) var))) 2663 (list 0 (cadr ans))) ;No VAR in ans. 2664 ((cdadr ans))))) ;The real Poly. 2665 (if (or (null zz) (null gp)) 2666 -1 2667 ($substitute zz gp)))) ;Substitute Values for gensyms. 2668 2669(defun coefsolve (n cl e) 2670 (do (($breakup) 2671 (eql (ncons (pdis (ptterm e n))) (cons (pdis (ptterm e m)) eql)) 2672 (m (m+ n -1) (m+ m -1))) 2673 ((signp l m) (solvex eql cl nil nil)))) 2674 2675;; Integrate(p(x)*f(exp(x))/g(exp(x)),x,minf,inf) by applying the 2676;; transformation y = exp(x) to get 2677;; integrate(p(log(y))*f(y)/g(y)/y,y,0,inf). This should be handled 2678;; by dintlog. 2679(defun log-transform (p pe d) 2680 (let ((new-p (subst (list '(%log) var) var p)) 2681 (new-pe (subst var 'z* (catch 'pin%ex (pin%ex pe)))) 2682 (new-d (subst var 'z* (catch 'pin%ex (pin%ex d))))) 2683 (defint (div (div (mul new-p new-pe) new-d) var) var 0 ul))) 2684 2685;; This implements Wang's algorithm in Chapter 5.2, pp. 98-100. 2686;; 2687;; This is a very brief description of the algorithm. Basically, we 2688;; have integrate(R(exp(x))*p(x),x,minf,inf), where R(x) is a rational 2689;; function and p(x) is a polynomial. 2690;; 2691;; We find a polynomial q(x) such that q(x) - q(x+2*%i*%pi) = p(x). 2692;; Then consider a contour integral of R(exp(z))*q(z) over a 2693;; rectangular contour. Opposite corners of the rectangle are (-R, 2694;; 2*%i*%pi) and (R, 0). 2695;; 2696;; Wang shows that this contour integral, in the limit, is the 2697;; integral of R(exp(x))*q(x)-R(exp(x))*q(x+2*%i*%pi), which is 2698;; exactly the integral we're looking for. 2699;; 2700;; Thus, to find the value of the contour integral, we just need the 2701;; residues of R(exp(z))*q(z). The only tricky part is that we want 2702;; the log function to have an imaginary part between 0 and 2*%pi 2703;; instead of -%pi to %pi. 2704(defun rectzto%pi2 (p pe d) 2705 ;; We have R(exp(x))*p(x) represented as p(x)*pe(exp(x))/d(exp(x)). 2706 (prog (dp n pl a b c denom-exponential) 2707 (if (not (and (setq denom-exponential (catch 'pin%ex (pin%ex d))) 2708 (%e-integer-coeff pe) 2709 (%e-integer-coeff d))) 2710 (return ())) 2711 ;; At this point denom-exponential has converted d(exp(x)) to the 2712 ;; polynomial d(z), where z = exp(x). 2713 (setq n (m* (cond ((null p) -1) 2714 (t ($expand (m*t '$%i %pi2 (makpoly p))))) 2715 pe)) 2716 (let ((var 'z*) 2717 (leadcoef ())) 2718 ;; Find the poles of the denominator. denom-exponential is the 2719 ;; denominator of R(x). 2720 ;; 2721 ;; It seems as if polelist returns a list of several items. 2722 ;; The first element is a list consisting of the pole and (z - 2723 ;; pole). We don't care about this, so we take the rest of the 2724 ;; result. 2725 (setq pl (cdr (polelist denom-exponential 2726 #'(lambda (j) 2727 ;; The imaginary part is nonzero, 2728 ;; or the realpart is negative. 2729 (or (not (equal ($imagpart j) 0)) 2730 (eq ($asksign ($realpart j)) '$neg))) 2731 #'(lambda (j) 2732 ;; The realpart is not zero. 2733 (not (eq ($asksign ($realpart j)) '$zero))))))) 2734 ;; Not sure what this does. 2735 (cond ((null pl) 2736 ;; No roots at all, so return 2737 (return nil)) 2738 ((or (cadr pl) 2739 (caddr pl)) 2740 ;; We have simple roots or roots in REGION1 2741 (setq dp (sdiff d var)))) 2742 (cond ((cadr pl) 2743 ;; The cadr of pl is the list of the simple poles of 2744 ;; denom-exponential. Take the log of them to find the 2745 ;; poles of the original expression. Then compute the 2746 ;; residues at each of these poles and sum them up and put 2747 ;; the result in B. (If no simple poles set B to 0.) 2748 (setq b (mapcar #'log-imag-0-2%pi (cadr pl))) 2749 (setq b (res1 n dp b)) 2750 (setq b (m+l b))) 2751 (t (setq b 0.))) 2752 (cond ((caddr pl) 2753 ;; I think this handles the case of poles outside the 2754 ;; regions. The sum of these residues are placed in C. 2755 (let ((temp (mapcar #'log-imag-0-2%pi (caddr pl)))) 2756 (setq c (append temp (mapcar #'(lambda (j) 2757 (m+ (m*t '$%i %pi2) j)) 2758 temp))) 2759 (setq c (res1 n dp c)) 2760 (setq c (m+l c)))) 2761 (t (setq c 0.))) 2762 (cond ((car pl) 2763 ;; We have the repeated poles of deonom-exponential, so we 2764 ;; need to convert them to the actual pole values for 2765 ;; R(exp(x)), by taking the log of the value of poles. 2766 (let ((poles (mapcar #'(lambda (p) 2767 (log-imag-0-2%pi (car p))) 2768 (car pl))) 2769 (exp (m// n (subst (m^t '$%e var) 'z* denom-exponential)))) 2770 ;; Compute the residues at all of these poles and sum 2771 ;; them up. 2772 (setq a (mapcar #'(lambda (j) 2773 ($residue exp var j)) 2774 poles)) 2775 (setq a (m+l a)))) 2776 (t (setq a 0.))) 2777 (return (sratsimp (m+ a b (m* '((rat) 1. 2.) c)))))) 2778 2779(defun genpoly (i) 2780 (do ((i i (m+ i -1)) 2781 (c (gensym) (gensym)) 2782 (cl ()) 2783 (ans ())) 2784 ((zerop i) 2785 (cons (m+l ans) cl)) 2786 (setq ans (cons (m* c (m^t var i)) ans)) 2787 (setq cl (cons c cl)))) 2788 2789;; Check to see if each term in exp that is of the form exp(k*x) has 2790;; an integer value for k. 2791(defun %e-integer-coeff (exp) 2792 (cond ((mapatom exp) t) 2793 ((and (mexptp exp) 2794 (eq (cadr exp) '$%e)) 2795 (eq (ask-integer ($coeff (caddr exp) var) '$integer) 2796 '$yes)) 2797 (t (every '%e-integer-coeff (cdr exp))))) 2798 2799(defun wlinearpoly (e var) 2800 (cond ((and (setq e (polyinx e var t)) 2801 (equal (deg e) 1)) 2802 (subin 1 e)))) 2803 2804;; Test to see if exp is of the form f(exp(x)), and if so, replace 2805;; exp(x) with 'z*. That is, basically return f(z*). 2806(defun pin%ex (exp) 2807 (declare (special $exponentialize)) 2808 (pin%ex0 (cond ((notinvolve exp '(%sinh %cosh %tanh)) 2809 exp) 2810 (t 2811 (let (($exponentialize t)) 2812 (setq exp ($expand exp))))))) 2813 2814(defun pin%ex0 (e) 2815 ;; Does e really need to be special here? Seems to be ok without 2816 ;; it; testsuite works. 2817 #+nil 2818 (declare (special e)) 2819 (cond ((not (among var e)) 2820 e) 2821 ((atom e) 2822 (throw 'pin%ex nil)) 2823 ((and (mexptp e) 2824 (eq (cadr e) '$%e)) 2825 (cond ((eq (caddr e) var) 2826 'z*) 2827 ((let ((linterm (wlinearpoly (caddr e) var))) 2828 (and linterm 2829 (m* (subin 0 e) (m^t 'z* linterm))))) 2830 (t 2831 (throw 'pin%ex nil)))) 2832 ((mtimesp e) 2833 (m*l (mapcar #'pin%ex0 (cdr e)))) 2834 ((mplusp e) 2835 (m+l (mapcar #'pin%ex0 (cdr e)))) 2836 (t 2837 (throw 'pin%ex nil)))) 2838 2839;; Test to see if exp is of the form p(x)*f(exp(x)). If so, set p* to 2840;; be p(x) and set pe* to f(exp(x)). 2841(defun p*pin%ex (nd*) 2842 (setq nd* ($factor nd*)) 2843 (cond ((polyinx nd* var nil) 2844 (setq p* (cons nd* p*)) t) 2845 ((catch 'pin%ex (pin%ex nd*)) 2846 (setq pe* (cons nd* pe*)) t) 2847 ((mtimesp nd*) 2848 (andmapcar #'p*pin%ex (cdr nd*))))) 2849 2850(defun findsub (p) 2851 (cond ((findp p) nil) 2852 ((setq nd* (bx**n p)) 2853 (m^t var (car nd*))) 2854 ((setq p (bx**n+a p)) 2855 (m* (caddr p) (m^t var (cadr p)))))) 2856 2857;; I think this is looking at f(exp(x)) and tries to find some 2858;; rational function R and some number k such that f(exp(x)) = 2859;; R(exp(k*x)). 2860(defun funclogor%e (e) 2861 (prog (ans arg nvar r) 2862 (cond ((or (ratp e var) 2863 (involve e '(%sin %cos %tan)) 2864 (not (setq arg (xor (and (setq arg (involve e '(%log))) 2865 (setq r '%log)) 2866 (%einvolve e))))) 2867 (return nil))) 2868 ag (setq nvar (cond ((eq r '%log) `((%log) ,arg)) 2869 (t (m^t '$%e arg)))) 2870 (setq ans (maxima-substitute (m^t 'yx -1) (m^t nvar -1) (maxima-substitute 'yx nvar e))) 2871 (cond ((not (among var ans)) (return (list (subst var 'yx ans) nvar))) 2872 ((and (null r) 2873 (setq arg (findsub arg))) 2874 (go ag))))) 2875 2876;; Integration by parts. 2877;; 2878;; integrate(u(x)*diff(v(x),x),x,a,b) 2879;; |b 2880;; = u(x)*v(x)| - integrate(v(x)*diff(u(x),x)) 2881;; |a 2882;; 2883(defun dintbypart (u v a b) 2884;;;SINCE ONLY CALLED FROM DINTLOG TO get RID OF LOGS - IF LOG REMAINS, QUIT 2885 (let ((ad (antideriv v))) 2886 (cond ((or (null ad) 2887 (involve ad '(%log))) 2888 nil) 2889 (t (let ((p1 (m* u ad)) 2890 (p2 (m* ad (sdiff u var)))) 2891 (let ((p1-part1 (get-limit p1 var b '$minus)) 2892 (p1-part2 (get-limit p1 var a '$plus))) 2893 (cond ((or (null p1-part1) 2894 (null p1-part2)) 2895 nil) 2896 (t (let ((p2 (let ((*def2* t)) 2897 (defint p2 var a b)))) 2898 (cond (p2 (add* p1-part1 2899 (m- p1-part2) 2900 (m- p2))) 2901 (t nil))))))))))) 2902 2903;; integrate(f(exp(k*x)),x,a,b), where f(z) is rational. 2904;; 2905;; See Wang p. 96-97. 2906;; 2907;; If the limits are minf to inf, we use the substitution y=exp(k*x) 2908;; to get integrate(f(y)/y,y,0,inf)/k. If the limits are 0 to inf, 2909;; use the substitution s+1=exp(k*x) to get 2910;; integrate(f(s+1)/(s+1),s,0,inf). 2911(defun dintexp (exp ignored &aux ans) 2912 (declare (ignore ignored)) 2913 (let ((*dintexp-recur* t)) ;recursion stopper 2914 (cond ((and (sinintp exp var) ;To be moved higher in the code. 2915 (setq ans (antideriv exp)) 2916 (setq ans (intsubs ans ll ul))) 2917 ;; If we can integrate it directly, do so and take the 2918 ;; appropriate limits. 2919 ) 2920 ((setq ans (funclogor%e exp)) 2921 ;; ans is the list (f(x) exp(k*x)). 2922 (cond ((and (equal ll 0.) 2923 (eq ul '$inf)) 2924 ;; Use the substitution s + 1 = exp(k*x). The 2925 ;; integral becomes integrate(f(s+1)/(s+1),s,0,inf) 2926 (setq ans (m+t -1 (cadr ans)))) 2927 (t 2928 ;; Use the substitution y=exp(k*x) because the 2929 ;; limits are minf to inf. 2930 (setq ans (cadr ans)))) 2931 ;; Apply the substitution and integrate it. 2932 (intcv ans nil))))) 2933 2934;; integrate(log(g(x))*f(x),x,0,inf) 2935(defun dintlog (exp arg) 2936 (let ((*dintlog-recur* (1+ *dintlog-recur*))) ;recursion stopper 2937 (prog (ans d) 2938 (cond ((and (eq ul '$inf) 2939 (equal ll 0.) 2940 (eq arg var) 2941 (equal 1 (sratsimp (m// exp (m* (m- (subin (m^t var -1) 2942 exp)) 2943 (m^t var -2)))))) 2944 ;; Make the substitution y=1/x. If the integrand has 2945 ;; exactly the same form, the answer has to be 0. 2946 (return 0.)) 2947 ((and (setq ans (let (($gamma_expand t)) (logx1 exp ll ul))) 2948 (free ans '%limit)) 2949 (return ans)) 2950 ((setq ans (antideriv exp)) 2951 ;; It's easy if we have the antiderivative. 2952 ;; but intsubs sometimes gives results containing %limit 2953 (return (intsubs ans ll ul)))) 2954 ;; Ok, the easy cases didn't work. We now try integration by 2955 ;; parts. Set ANS to f(x). 2956 (setq ans (m// exp `((%log) ,arg))) 2957 (cond ((involve ans '(%log)) 2958 ;; Bad. f(x) contains a log term, so we give up. 2959 (return nil)) 2960 ((and (eq arg var) 2961 (equal 0. (no-err-sub 0. ans)) 2962 (setq d (let ((*def2* t)) 2963 (defint (m* ans (m^t var '*z*)) 2964 var ll ul)))) 2965 ;; The arg of the log function is the same as the 2966 ;; integration variable. We can do something a little 2967 ;; simpler than integration by parts. We have something 2968 ;; like f(x)*log(x). Consider f(x)*x^z. If we 2969 ;; differentiate this wrt to z, the integrand becomes 2970 ;; f(x)*log(x)*x^z. When we evaluate this at z = 0, we 2971 ;; get the desired integrand. 2972 ;; 2973 ;; So we need f(0) to be 0 at 0. If we can integrate 2974 ;; f(x)*x^z, then we differentiate the result and 2975 ;; evaluate it at z = 0. 2976 (return (derivat '*z* 1. d 0.))) 2977 ((setq ans (dintbypart `((%log) ,arg) ans ll ul)) 2978 ;; Try integration by parts. 2979 (return ans)))))) 2980 2981;; Compute diff(e,var,n) at the point pt. 2982(defun derivat (var n e pt) 2983 (subin pt (apply '$diff (list e var n)))) 2984 2985;;; GGR and friends 2986 2987;; MAYBPC returns (COEF EXPO CONST) 2988;; 2989;; This basically picks off b*x^n+a and returns the list 2990;; (b n a). It may also set the global *zd*. 2991(defun maybpc (e var) 2992 (declare (special *zd*)) 2993 (cond (*mtoinf* (throw 'ggrm (linpower0 e var))) 2994 ((and (not *mtoinf*) 2995 (null (setq e (bx**n+a e)))) ;bx**n+a --> (a n b) or nil. 2996 nil) ;with var being x. 2997 ;; At this point, e is of the form (a n b) 2998 ((and (among '$%i (caddr e)) 2999 (zerop1 ($realpart (caddr e))) 3000 (setq zn ($imagpart (caddr e))) 3001 (eq ($asksign (cadr e)) '$pos)) 3002 ;; If we're here, b is complex, and n > 0. zn = imagpart(b). 3003 ;; 3004 ;; Set var to the same sign as zn. 3005 (cond ((eq ($asksign zn) '$neg) 3006 (setq var -1) 3007 (setq zn (m- zn))) 3008 (t (setq var 1))) 3009 ;; zd = exp(var*%i*%pi*(1+nd)/(2*n). (ZD is special!) 3010 (setq *zd* (m^t '$%e (m// (mul* var '$%i '$%pi (m+t 1 nd*)) 3011 (m*t 2 (cadr e))))) 3012 ;; Return zn, n, a. 3013 `(,(caddr e) ,(cadr e) ,(car e))) 3014 ((and (or (eq (setq var ($asksign ($realpart (caddr e)))) '$neg) 3015 (equal var '$zero)) 3016 (equal ($imagpart (cadr e)) 0) 3017 (ratgreaterp (cadr e) 0.)) 3018 ;; We're here if realpart(b) <= 0, and n >= 0. Then return -b, n, a. 3019 `(,(caddr e) ,(cadr e) ,(car e))))) 3020 3021;; Integrate x^m*exp(b*x^n+a), with realpart(m) > -1. 3022;; 3023;; See Wang, pp. 84-85. 3024;; 3025;; I believe the formula Wang gives is incorrect. The derivation is 3026;; correct except for the last step. 3027;; 3028;; Let J = integrate(x^m*exp(%i*k*x^n),x,0,inf), with real k. 3029;; 3030;; Consider the case for k < 0. Take a sector of a circle bounded by 3031;; the real line and the angle -%pi/(2*n), and by the radii, r and R. 3032;; Since there are no poles inside this contour, the integral 3033;; 3034;; integrate(z^m*exp(%i*k*z^n),z) = 0 3035;; 3036;; Then J = exp(-%pi*%i*(m+1)/(2*n))*integrate(R^m*exp(k*R^n),R,0,inf) 3037;; 3038;; because the integral along the boundary is zero except for the part 3039;; on the real axis. (Proof?) 3040;; 3041;; Wang seems to say this last integral is gamma(s/n/(-k)^s) where s = 3042;; (m+1)/n. But that seems wrong. If we use the substitution R = 3043;; (y/(-k))^(1/n), we end up with the result: 3044;; 3045;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n). 3046;; 3047;; or gamma((m+1)/n)/k^((m+1)/n)/n. 3048;; 3049;; Note that this also handles the case of 3050;; 3051;; integrate(x^m*exp(-k*x^n),x,0,inf); 3052;; 3053;; where k is positive real number. A simple change of variables, 3054;; y=k*x^n, gives 3055;; 3056;; integrate(y^((m+1)/n-1)*exp(-y),y,0,inf)/(n*k^((m+1)/n)) 3057;; 3058;; which is the same form above. 3059(defun ggr (e ind) 3060 (prog (c *zd* zn nn* dn* nd* dosimp $%emode) 3061 (declare (special *zd*)) 3062 (setq nd* 0.) 3063 (cond (ind (setq e ($expand e)) 3064 (cond ((and (mplusp e) 3065 (let ((*nodiverg t)) 3066 (setq e (catch 'divergent 3067 (andmapcar 3068 #'(lambda (j) 3069 (ggr j nil)) 3070 (cdr e)))))) 3071 (cond ((eq e 'divergent) nil) 3072 (t (return (sratsimp (cons '(mplus) e))))))))) 3073 (setq e (rmconst1 e)) 3074 (setq c (car e)) 3075 (setq e (cdr e)) 3076 (cond ((setq e (ggr1 e var)) 3077 ;; e = (m b n a). That is, the integral is of the form 3078 ;; x^m*exp(b*x^n+a). I think we want to compute 3079 ;; gamma((m+1)/n)/b^((m+1)/n)/n. 3080 ;; 3081 ;; FIXME: If n > m + 1, the integral converges. We need 3082 ;; to check for this. 3083 (destructuring-bind (m b n a) 3084 e 3085 (when (and (not (zerop1 ($realpart b))) 3086 (not (zerop1 ($imagpart b)))) 3087 ;; The derivation only holds if b is purely real or 3088 ;; purely imaginary. Give up if it's not. 3089 (return nil)) 3090 ;; Check for convergence. If b is complex, we need n - 3091 ;; m > 1. If b is real, we need b < 0. 3092 (when (and (zerop1 ($imagpart b)) 3093 (not (eq ($asksign b) '$neg))) 3094 (diverg)) 3095 (when (and (not (zerop1 ($imagpart b))) 3096 (not (eq ($asksign (sub n (add m 1))) '$pos))) 3097 (diverg)) 3098 3099 (setq e (gamma1 m (cond ((zerop1 ($imagpart b)) 3100 ;; If we're here, b must be negative. 3101 (neg b)) 3102 (t 3103 ;; Complex b. Take the imaginary part 3104 `((mabs) ,($imagpart b)))) 3105 n a)) 3106 ;; NOTE: *zd* (Ick!) is special and might be set by maybpc. 3107 (when *zd* 3108 ;; FIXME: Why do we set %emode here? Shouldn't we just 3109 ;; bind it? And why do we want it bound to T anyway? 3110 ;; Shouldn't the user control that? The same goes for 3111 ;; dosimp. 3112 ;;(setq $%emode t) 3113 (setq dosimp t) 3114 (setq e (m* *zd* e)))))) 3115 (cond (e (return (m* c e)))))) 3116 3117 3118;; Match x^m*exp(b*x^n+a). If it does, return (list m b n a). 3119(defun ggr1 (e var) 3120 (cond ((atom e) nil) 3121 ((and (mexptp e) 3122 (eq (cadr e) '$%e)) 3123 ;; We're looking at something like exp(f(var)). See if it's 3124 ;; of the form b*x^n+a, and return (list 0 b n a). (The 0 is 3125 ;; so we can graft something onto it if needed.) 3126 (cond ((setq e (maybpc (caddr e) var)) 3127 (cons 0. e)))) 3128 ((and (mtimesp e) 3129 ;; E should be the product of exactly 2 terms 3130 (null (cdddr e)) 3131 ;; Check to see if one of the terms is of the form 3132 ;; var^p. If so, make sure the realpart of p > -1. If 3133 ;; so, check the other term has the right form via 3134 ;; another call to ggr1. 3135 (or (and (setq dn* (xtorterm (cadr e) var)) 3136 (ratgreaterp (setq nd* ($realpart dn*)) 3137 -1.) 3138 (setq nn* (ggr1 (caddr e) var))) 3139 (and (setq dn* (xtorterm (caddr e) var)) 3140 (ratgreaterp (setq nd* ($realpart dn*)) 3141 -1.) 3142 (setq nn* (ggr1 (cadr e) var))))) 3143 ;; Both terms have the right form and nn* contains the arg of 3144 ;; the exponential term. Put dn* as the car of nn*. The 3145 ;; result is something like (m b n a) when we have the 3146 ;; expression x^m*exp(b*x^n+a). 3147 (rplaca nn* dn*)))) 3148 3149 3150;; Match b*x^n+a. If a match is found, return the list (a n b). 3151;; Otherwise, return NIL 3152(defun bx**n+a (e) 3153 (cond ((eq e var) 3154 (list 0 1 1)) 3155 ((or (atom e) 3156 (mnump e)) ()) 3157 (t (let ((a (no-err-sub 0. e))) 3158 (cond ((null a) ()) 3159 (t (setq e (m+ e (m*t -1 a))) 3160 (cond ((setq e (bx**n e)) 3161 (cons a e)) 3162 (t ())))))))) 3163 3164;; Match b*x^n. Return the list (n b) if found or NIL if not. 3165(defun bx**n (e) 3166 (let ((n ())) 3167 (and (setq n (xexponget e var)) 3168 (not (among var 3169 (setq e (let (($maxposex 1) 3170 ($maxnegex 1)) 3171 ($expand (m// e (m^t var n))))))) 3172 (list n e)))) 3173 3174(defun xexponget (e nn*) 3175 (cond ((atom e) (cond ((eq e var) 1.))) 3176 ((mnump e) nil) 3177 ((and (mexptp e) 3178 (eq (cadr e) nn*) 3179 (not (among nn* (caddr e)))) 3180 (caddr e)) 3181 (t (some #'(lambda (j) (xexponget j nn*)) (cdr e))))) 3182 3183 3184;;; given (b*x^n+a)^m returns (m a n b) 3185(defun bxm (e ind) 3186 (let (m r) 3187 (cond ((or (atom e) 3188 (mnump e) 3189 (involve e '(%log %sin %cos %tan)) 3190 (%einvolve e)) nil) 3191 ((mtimesp e) nil) 3192 ((mexptp e) (cond ((among var (caddr e)) nil) 3193 ((setq r (bx**n+a (cadr e))) 3194 (cons (caddr e) r)))) 3195 ((setq r (bx**n+a e)) (cons 1. r)) 3196 ((not (null ind)) 3197;;;Catches Unfactored forms. 3198 (setq m (m// (sdiff e var) e)) 3199 (numden m) 3200 (setq m nn*) 3201 (setq r dn*) 3202 (cond 3203 ((and (setq r (bx**n+a (sratsimp r))) 3204 (not (among var (setq m (m// m (m* (cadr r) (caddr r) 3205 (m^t var (m+t -1 (cadr r)))))))) 3206 (setq e (m// (subin 0. e) (m^t (car r) m)))) 3207 (cond ((equal e 1.) 3208 (cons m r)) 3209 (t (setq e (m^ e (m// 1. m))) 3210 (list m (m* e (car r)) (cadr r) 3211 (m* e (caddr r)))))))) 3212 (t ())))) 3213 3214;;;Is E = VAR raised to some power? If so return power or 0. 3215(defun findp (e) 3216 (cond ((not (among var e)) 0.) 3217 (t (xtorterm e var)))) 3218 3219(defun xtorterm (e var1) 3220;;;Is E = VAR1 raised to some power? If so return power. 3221 (cond ((alike1 e var1) 1.) 3222 ((atom e) nil) 3223 ((and (mexptp e) 3224 (alike1 (cadr e) var1) 3225 (not (among var (caddr e)))) 3226 (caddr e)))) 3227 3228(defun tbf (l) 3229 (m^ (m* (m^ (caddr l) '((rat) 1 2)) 3230 (m+ (cadr l) (m^ (m* (car l) (caddr l)) 3231 '((rat) 1 2)))) 3232 -1)) 3233 3234(defun radbyterm (d l) 3235 (do ((l l (cdr l)) 3236 (ans ())) 3237 ((null l) 3238 (m+l ans)) 3239 (destructuring-let (((const . integrand) (rmconst1 (car l)))) 3240 (setq ans (cons (m* const (dintrad0 integrand d)) 3241 ans))))) 3242 3243(defun sqdtc (e ind) 3244 (prog (a b c varlist) 3245 (setq varlist (list var)) 3246 (newvar e) 3247 (setq e (cdadr (ratrep* e))) 3248 (setq c (pdis (ptterm e 0))) 3249 (setq b (m*t (m//t 1 2) (pdis (ptterm e 1)))) 3250 (setq a (pdis (ptterm e 2))) 3251 (cond ((and (eq ($asksign (m+ b (m^ (m* a c) 3252 '((rat) 1 2)))) 3253 '$pos) 3254 (or (and ind 3255 (not (eq ($asksign a) '$neg)) 3256 (eq ($asksign c) '$pos)) 3257 (and (eq ($asksign a) '$pos) 3258 (not (eq ($asksign c) '$neg))))) 3259 (return (list a b c)))))) 3260 3261(defun difap1 (e pwr var m pt) 3262 (m// (mul* (cond ((eq (ask-integer m '$even) '$yes) 3263 1) 3264 (t -1)) 3265 `((%gamma) ,pwr) 3266 (derivat var m e pt)) 3267 `((%gamma) ,(m+ pwr m)))) 3268 3269(defun sqrtinvolve (e) 3270 (cond ((atom e) nil) 3271 ((mnump e) nil) 3272 ((and (mexptp e) 3273 (and (mnump (caddr e)) 3274 (not (numberp (caddr e))) 3275 (equal (caddr (caddr e)) 2.)) 3276 (among var (cadr e))) 3277 (cadr e)) 3278 (t (some #'sqrtinvolve (cdr e))))) 3279 3280(defun bydif (r s d) 3281 (let ((b 1) p) 3282 (setq d (m+ (m*t '*z* var) d)) 3283 (cond ((or (zerop1 (setq p (m+ s (m*t -1 r)))) 3284 (and (zerop1 (m+ 1 p)) 3285 (setq b var))) 3286 (difap1 (dintrad0 b (m^ d '((rat) 3 2))) 3287 '((rat) 3 2) '*z* r 0)) 3288 ((eq ($asksign p) '$pos) 3289 (difap1 (difap1 (dintrad0 1 (m^ (m+t 'z** d) 3290 '((rat) 3 2))) 3291 '((rat) 3 2) '*z* r 0) 3292 '((rat) 3 2) 'z** p 0))))) 3293 3294(defun dintrad0 (n d) 3295 (let (l r s) 3296 (cond ((and (mexptp d) 3297 (equal (deg (cadr d)) 2.)) 3298 (cond ((alike1 (caddr d) '((rat) 3. 2.)) 3299 (cond ((and (equal n 1.) 3300 (setq l (sqdtc (cadr d) t))) 3301 (tbf l)) 3302 ((and (eq n var) 3303 (setq l (sqdtc (cadr d) nil))) 3304 (tbf (reverse l))))) 3305 ((and (setq r (findp n)) 3306 (or (eq ($asksign (m+ -1. (m- r) (m*t 2. 3307 (caddr d)))) 3308 '$pos) 3309 (diverg)) 3310 (setq s (m+ '((rat) -3. 2.) (caddr d))) 3311 (eq ($asksign s) '$pos) 3312 (eq (ask-integer s '$integer) '$yes)) 3313 (bydif r s (cadr d))) 3314 ((polyinx n var nil) 3315 (radbyterm d (cdr n)))))))) 3316 3317 3318;;;Looks at the IMAGINARY part of a log and puts it in the interval 0 2*%pi. 3319(defun log-imag-0-2%pi (x) 3320 (let ((plog (simplify ($rectform `((%plog) ,x))))) 3321 ;; We take the $rectform above to make sure that the log is 3322 ;; expanded out for the situations where simplifying plog itself 3323 ;; doesn't do it. This should probably be considered a bug in the 3324 ;; plog simplifier and should be fixed there. 3325 (cond ((not (free plog '%plog)) 3326 (subst '%log '%plog plog)) 3327 (t 3328 (destructuring-let (((real . imag) (trisplit plog))) 3329 (cond ((eq ($asksign imag) '$neg) 3330 (setq imag (m+ imag %pi2))) 3331 ((eq ($asksign (m- imag %pi2)) '$pos) 3332 (setq imag (m- imag %pi2))) 3333 (t t)) 3334 (m+ real (m* '$%i imag))))))) 3335 3336 3337;;; Temporary fix for a lacking in taylor, which loses with %i in denom. 3338;;; Besides doesn't seem like a bad thing to do in general. 3339(defun %i-out-of-denom (exp) 3340 (let ((denom ($denom exp))) 3341 (cond ((among '$%i denom) 3342 ;; Multiply the denominator by it's conjugate to get rid of 3343 ;; %i. 3344 (let* ((den-conj (maxima-substitute (m- '$%i) '$%i denom)) 3345 (num ($num exp)) 3346 (new-denom (sratsimp (m* denom den-conj)))) 3347 ;; If the new denominator still contains %i, just give 3348 ;; up. Otherwise, multiply the numerator by the 3349 ;; conjugate and divide by the new denominator. 3350 (if (among '$%i new-denom) 3351 exp 3352 (setq exp (m// (m* num den-conj) new-denom))))) 3353 (t exp)))) 3354 3355;;; LL and UL must be real otherwise this routine return $UNKNOWN. 3356;;; Returns $no $unknown or a list of poles in the interval (ll ul) 3357;;; for exp w.r.t. var. 3358;;; Form of list ((pole . multiplicity) (pole1 . multiplicity) ....) 3359(defun poles-in-interval (exp var ll ul) 3360 (let* ((denom (cond ((mplusp exp) 3361 ($denom (sratsimp exp))) 3362 ((and (mexptp exp) 3363 (free (caddr exp) var) 3364 (eq ($asksign (caddr exp)) '$neg)) 3365 (m^ (cadr exp) (m- (caddr exp)))) 3366 (t ($denom exp)))) 3367 (roots (real-roots denom var)) 3368 (ll-pole (limit-pole exp var ll '$plus)) 3369 (ul-pole (limit-pole exp var ul '$minus))) 3370 (cond ((or (eq roots '$failure) 3371 (null ll-pole) 3372 (null ul-pole)) '$unknown) 3373 ((and (or (eq roots '$no) 3374 (member ($csign denom) '($pos $neg $pn))) 3375 ;; this clause handles cases where we can't find the exact roots, 3376 ;; but we know that they occur outside the interval of integration. 3377 ;; example: integrate ((1+exp(t))/sqrt(t+exp(t)), t, 0, 1); 3378 (eq ll-pole '$no) 3379 (eq ul-pole '$no)) '$no) 3380 (t (cond ((equal roots '$no) 3381 (setq roots ()))) 3382 (do ((dummy roots (cdr dummy)) 3383 (pole-list (cond ((not (eq ll-pole '$no)) 3384 `((,ll . 1))) 3385 (t nil)))) 3386 ((null dummy) 3387 (cond ((not (eq ul-pole '$no)) 3388 (sort-poles (push `(,ul . 1) pole-list))) 3389 ((not (null pole-list)) 3390 (sort-poles pole-list)) 3391 (t '$no))) 3392 (let* ((soltn (caar dummy)) 3393 ;; (multiplicity (cdar dummy)) (not used? -- cwh) 3394 (root-in-ll-ul (in-interval soltn ll ul))) 3395 (cond ((eq root-in-ll-ul '$no) '$no) 3396 ((eq root-in-ll-ul '$yes) 3397 (let ((lim-ans (is-a-pole exp soltn))) 3398 (cond ((null lim-ans) 3399 (return '$unknown)) 3400 ((equal lim-ans 0) 3401 '$no) 3402 (t (push (car dummy) 3403 pole-list)))))))))))) 3404 3405 3406;;;Returns $YES if there is no pole and $NO if there is one. 3407(defun limit-pole (exp var limit direction) 3408 (let ((ans (cond ((member limit '($minf $inf) :test #'eq) 3409 (cond ((eq (special-convergent-formp exp limit) '$yes) 3410 '$no) 3411 (t (get-limit (m* exp var) var limit direction)))) 3412 (t '$no)))) 3413 (cond ((eq ans '$no) '$no) 3414 ((null ans) nil) 3415 ((eq ans '$und) '$no) 3416 ((equal ans 0.) '$no) 3417 (t '$yes)))) 3418 3419;;;Takes care of forms that the ratio test fails on. 3420(defun special-convergent-formp (exp limit) 3421 (cond ((not (oscip exp)) '$no) 3422 ((or (eq (sc-converg-form exp limit) '$yes) 3423 (eq (exp-converg-form exp limit) '$yes)) 3424 '$yes) 3425 (t '$no))) 3426 3427(defun exp-converg-form (exp limit) 3428 (let (exparg) 3429 (setq exparg (%einvolve exp)) 3430 (cond ((or (null exparg) 3431 (freeof '$%i exparg)) 3432 '$no) 3433 (t (cond 3434 ((and (freeof '$%i 3435 (%einvolve 3436 (setq exp 3437 (sratsimp (m// exp (m^t '$%e exparg)))))) 3438 (equal (get-limit exp var limit) 0)) 3439 '$yes) 3440 (t '$no)))))) 3441 3442(defun sc-converg-form (exp limit) 3443 (prog (scarg trigpow) 3444 (setq exp ($expand exp)) 3445 (setq scarg (involve (sin-sq-cos-sq-sub exp) '(%sin %cos))) 3446 (cond ((null scarg) (return '$no)) 3447 ((and (polyinx scarg var ()) 3448 (eq ($asksign (m- ($hipow scarg var) 1)) '$pos)) (return '$yes)) 3449 ((not (freeof var (sdiff scarg var))) 3450 (return '$no)) 3451 ((and (setq trigpow ($hipow exp `((%sin) ,scarg))) 3452 (eq (ask-integer trigpow '$odd) '$yes) 3453 (equal (get-limit (m// exp `((%sin) ,scarg)) var limit) 3454 0)) 3455 (return '$yes)) 3456 ((and (setq trigpow ($hipow exp `((%cos) ,scarg))) 3457 (eq (ask-integer trigpow '$odd) '$yes) 3458 (equal (get-limit (m// exp `((%cos) ,scarg)) var limit) 3459 0)) 3460 (return '$yes)) 3461 (t (return '$no))))) 3462 3463(defun is-a-pole (exp soltn) 3464 (get-limit ($radcan 3465 (m* (maxima-substitute (m+ 'epsilon soltn) var exp) 3466 'epsilon)) 3467 'epsilon 0 '$plus)) 3468 3469(defun in-interval (place ll ul) 3470 ;; real values for ll and ul; place can be imaginary. 3471 (let ((order (ask-greateq ul ll))) 3472 (cond ((eq order '$yes)) 3473 ((eq order '$no) (let ((temp ul)) (setq ul ll ll temp))) 3474 (t (merror (intl:gettext "defint: failed to order limits of integration:~%~M") 3475 (list '(mlist simp) ll ul))))) 3476 (if (not (equal ($imagpart place) 0)) 3477 '$no 3478 (let ((lesseq-ul (ask-greateq ul place)) 3479 (greateq-ll (ask-greateq place ll))) 3480 (if (and (eq lesseq-ul '$yes) (eq greateq-ll '$yes)) '$yes '$no)))) 3481 3482;; returns true or nil 3483(defun strictly-in-interval (place ll ul) 3484 ;; real values for ll and ul; place can be imaginary. 3485 (and (equal ($imagpart place) 0) 3486 (or (eq ul '$inf) 3487 (eq ($asksign (m+ ul (m- place))) '$pos)) 3488 (or (eq ll '$minf) 3489 (eq ($asksign (m+ place (m- ll))) '$pos)))) 3490 3491(defun real-roots (exp var) 3492 (let (($solvetrigwarn (cond (defintdebug t) ;Rest of the code for 3493 (t ()))) ;TRIGS in denom needed. 3494 ($solveradcan (cond ((or (among '$%i exp) 3495 (among '$%e exp)) t) 3496 (t nil))) 3497 *roots *failures) ;special vars for solve. 3498 (cond ((not (among var exp)) '$no) 3499 (t (solve exp var 1) 3500 ;; If *failures is set, we may have missed some roots. 3501 ;; We still return the roots that we have found. 3502 (do ((dummy *roots (cddr dummy)) 3503 (rootlist)) 3504 ((null dummy) 3505 (cond ((not (null rootlist)) 3506 rootlist) 3507 (t '$no))) 3508 (cond ((equal ($imagpart (caddar dummy)) 0) 3509 (setq rootlist 3510 (cons (cons 3511 ($rectform (caddar dummy)) 3512 (cadr dummy)) 3513 rootlist))))))))) 3514 3515(defun ask-greateq (x y) 3516;;; Is x > y. X or Y can be $MINF or $INF, zeroA or zeroB. 3517 (let ((x (cond ((among 'zeroa x) 3518 (subst 0 'zeroa x)) 3519 ((among 'zerob x) 3520 (subst 0 'zerob x)) 3521 ((among 'epsilon x) 3522 (subst 0 'epsilon x)) 3523 ((or (among '$inf x) 3524 (among '$minf x)) 3525 ($limit x)) 3526 (t x))) 3527 (y (cond ((among 'zeroa y) 3528 (subst 0 'zeroa y)) 3529 ((among 'zerob y) 3530 (subst 0 'zerob y)) 3531 ((among 'epsilon y) 3532 (subst 0 'epsilon y)) 3533 ((or (among '$inf y) 3534 (among '$minf y)) 3535 ($limit y)) 3536 (t y)))) 3537 (cond ((eq x '$inf) 3538 '$yes) 3539 ((eq x '$minf) 3540 '$no) 3541 ((eq y '$inf) 3542 '$no) 3543 ((eq y '$minf) 3544 '$yes) 3545 (t (let ((ans ($asksign (m+ x (m- y))))) 3546 (cond ((member ans '($zero $pos) :test #'eq) 3547 '$yes) 3548 ((eq ans '$neg) 3549 '$no) 3550 (t '$unknown))))))) 3551 3552(defun sort-poles (pole-list) 3553 (sort pole-list #'(lambda (x y) 3554 (cond ((eq (ask-greateq (car x) (car y)) 3555 '$yes) 3556 nil) 3557 (t t))))) 3558 3559;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3560;;; 3561;;; Integrate Definite Integrals involving log and exp functions. The algorithm 3562;;; are taken from the paper "Evaluation of CLasses of Definite Integrals ..." 3563;;; by K.O.Geddes et. al. 3564;;; 3565;;; 1. CASE: Integrals generated by the Gamma function. 3566;;; 3567;;; inf 3568;;; / 3569;;; [ w m s - m - 1 3570;;; I t log (t) expt(- t ) dt = s signum(s) 3571;;; ] 3572;;; / 3573;;; 0 3574;;; ! 3575;;; m ! 3576;;; d ! 3577;;; (--- (gamma(z))! ) 3578;;; m ! 3579;;; dz ! w + 1 3580;;; !z = ----- 3581;;; s 3582;;; 3583;;; The integral converges for: 3584;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0. 3585;;; 3586;;; 2. CASE: Integrals generated by the Incomplete Gamma function. 3587;;; 3588;;; inf ! 3589;;; / m ! 3590;;; [ w m s d s ! 3591;;; I t log (t) exp(- t ) dt = (--- (gamma_incomplete(a, x ))! ) 3592;;; ] m ! 3593;;; / da ! w + 1 3594;;; x !z = ----- 3595;;; s 3596;;; - m - 1 3597;;; s signum(s) 3598;;; 3599;;; The integral converges for: 3600;;; s # 0, m = 0, 1, 2, ... and realpart((w+1)/s) > 0. 3601;;; The shown solution is valid for s>0. For s<0 gamma_incomplete has to be 3602;;; replaced by gamma(a) - gamma_incomplete(a,x^s). 3603;;; 3604;;; 3. CASE: Integrals generated by the beta function. 3605;;; 3606;;; 1 3607;;; / 3608;;; [ m s r n 3609;;; I log (1 - t) (1 - t) t log (t) dt = 3610;;; ] 3611;;; / 3612;;; 0 3613;;; ! 3614;;; ! ! 3615;;; n m ! ! 3616;;; d d ! ! 3617;;; --- (--- (beta(z, w))! )! 3618;;; n m ! ! 3619;;; dz dw ! ! 3620;;; !w = s + 1 ! 3621;;; !z = r + 1 3622;;; 3623;;; The integral converges for: 3624;;; n, m = 0, 1, 2, ..., s > -1 and r > -1. 3625;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3626 3627(defvar *debug-defint-log* nil) 3628 3629;;; Recognize c*z^w*log(z)^m*exp(-t^s) 3630 3631(defun m2-log-exp-1 (expr) 3632 (when *debug-defint-log* 3633 (format t "~&M2-LOG-EXP-1 with ~A~%" expr)) 3634 (m2 expr 3635 '((mtimes) 3636 (c freevar) 3637 ((mexpt) (z varp) (w freevar)) 3638 ((mexpt) $%e ((mtimes) -1 ((mexpt) (z varp) (s freevar0)))) 3639 ((mexpt) ((%log) (z varp)) (m freevar))))) 3640 3641;;; Recognize c*z^r*log(z)^n*(1-z)^s*log(1-z)^m 3642 3643(defun m2-log-exp-2 (expr) 3644 (when *debug-defint-log* 3645 (format t "~&M2-LOG-EXP-2 with ~A~%" expr)) 3646 (m2 expr 3647 '((mtimes) 3648 (c freevar) 3649 ((mexpt) (z varp) (r freevar)) 3650 ((mexpt) ((%log) (z varp)) (n freevar)) 3651 ((mexpt) ((mplus) 1 ((mtimes) -1 (z varp))) (s freevar)) 3652 ((mexpt) ((%log) ((mplus) 1 ((mtimes)-1 (z varp)))) (m freevar))))) 3653 3654;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3655 3656(defun defint-log-exp (expr var ll ul) 3657 (let ((x nil) 3658 (result nil) 3659 (var1 (gensym))) 3660 3661 ;; var1 is used as a parameter for differentiation. Add var1>0 to the 3662 ;; database, to get the desired simplification of the differentiation of 3663 ;; the gamma_incomplete function. 3664 (setq *global-defint-assumptions* 3665 (cons (assume `((mgreaterp) ,var1 0)) 3666 *global-defint-assumptions*)) 3667 3668 (cond 3669 ((and (eq ul '$inf) 3670 (setq x (m2-log-exp-1 expr))) 3671 ;; The integrand matches the cases 1 and 2. 3672 (let ((c (cdras 'c x)) 3673 (w (cdras 'w x)) 3674 (m (cdras 'm x)) 3675 (s (cdras 's x)) 3676 ($gamma_expand nil)) ; No expansion of Gamma functions. 3677 3678 (when *debug-defint-log* 3679 (format t "~&DEFINT-LOG-EXP-1:~%") 3680 (format t "~& : c = ~A~%" c) 3681 (format t "~& : w = ~A~%" w) 3682 (format t "~& : m = ~A~%" m) 3683 (format t "~& : s = ~A~%" s)) 3684 3685 (cond ((and (zerop1 ll) 3686 (integerp m) 3687 (>= m 0) 3688 (not (eq ($sign s) '$zero)) 3689 (eq ($sign (div (add w 1) s)) '$pos)) 3690 ;; Case 1: Generated by the Gamma function. 3691 (setq result 3692 (mul c 3693 (simplify (list '(%signum) s)) 3694 (power s (mul -1 (add m 1))) 3695 ($at ($diff (list '(%gamma) var1) var1 m) 3696 (list '(mequal) 3697 var1 3698 (div (add w 1) s)))))) 3699 ((and (member ($sign ll) '($pos $pz)) 3700 (integerp m) 3701 (or (= m 0) (= m 1)) ; Exclude m>1, because Maxima can not 3702 ; derivate the involved hypergeometric 3703 ; functions. 3704 (or (and (eq ($sign s) '$neg) 3705 (eq ($sign (div (add 1 w) s)) '$pos)) 3706 (and (eq ($sign s) '$pos) 3707 (eq ($sign (div (add 1 w) s)) '$pos)))) 3708 ;; Case 2: Generated by the Incomplete Gamma function. 3709 (let ((f (if (eq ($sign s) '$pos) 3710 (list '(%gamma_incomplete) var1 (power ll s)) 3711 (sub (list '(%gamma) var1) 3712 (list '(%gamma_incomplete) var1 (power ll s)))))) 3713 (setq result 3714 (mul c 3715 (simplify (list '(%signum) s)) 3716 (power s (mul -1 (add m 1))) 3717 ($at ($diff f var1 m) 3718 (list '(mequal) var1 (div (add 1 w) s))))))) 3719 (t 3720 (setq result nil))))) 3721 ((and (zerop1 ll) 3722 (onep1 ul) 3723 (setq x (m2-log-exp-2 expr))) 3724 ;; Case 3: Generated by the Beta function. 3725 (let ((c (cdras 'c x)) 3726 (r (cdras 'r x)) 3727 (n (cdras 'n x)) 3728 (s (cdras 's x)) 3729 (m (cdras 'm x)) 3730 (var1 (gensym)) 3731 (var2 (gensym))) 3732 3733 (when *debug-defint-log* 3734 (format t "~&DEFINT-LOG-EXP-2:~%") 3735 (format t "~& : c = ~A~%" c) 3736 (format t "~& : r = ~A~%" r) 3737 (format t "~& : n = ~A~%" n) 3738 (format t "~& : s = ~A~%" s) 3739 (format t "~& : m = ~A~%" m)) 3740 3741 (cond ((and (integerp m) 3742 (>= m 0) 3743 (integerp n) 3744 (>= n 0) 3745 (eq ($sign (add 1 r)) '$pos) 3746 (eq ($sign (add 1 s)) '$pos)) 3747 (setq result 3748 (mul c 3749 ($at ($diff ($at ($diff (list '($beta) var1 var2) 3750 var2 m) 3751 (list '(mequal) var2 (add 1 s))) 3752 var1 n) 3753 (list '(mequal) var1 (add 1 r)))))) 3754 (t 3755 (setq result nil))))) 3756 (t 3757 (setq result nil))) 3758 ;; Simplify result and set $gamma_expand to global value 3759 (let (($gamma_expand $gamma_expand)) (sratsimp result)))) 3760 3761;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3762