1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Double Factorial, Incomplete Gamma function, ...
5 ;;; This file will be extended with further functions related to the
6 ;;; Factorial and Gamma functions.
8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10 ;;; This file contains the following Maxima User functions:
12 ;;; double_factorial(z)
14 ;;; gamma_incomplete(a,z)
15 ;;; gamma_incomplete_generalized(a,z1,z2)
16 ;;; gamma_incomplete_regularized(a,z)
23 ;;; erf_generalized(z1,z2)
31 ;;; beta_incomplete(a,b,z)
32 ;;; beta_incomplete_generalized(a,b,z1,z2)
33 ;;; beta_incomplete_regularized(a,b,z)
35 ;;; Maxima User variable:
37 ;;; $factorial_expand - Allows argument simplificaton for expressions like
38 ;;; double_factorial(n-1) and double_factorial(2*k+n)
39 ;;; $beta_expand - Switch on further expansions for the Beta functions
41 ;;; $erf_representation - When T erfc, erfi, erf_generalized, fresnel_s
42 ;;; and fresnel_c are transformed to erf.
43 ;;; $erf_%iargs - Enable simplification of Erf and Erfi for
44 ;;; imaginary arguments
45 ;;; $hypergeometric_representation
46 ;;; - Enables transformation to a Hypergeometric
47 ;;; representation for fresnel_s and fresnel_c
49 ;;; Maxima User variable (not defined in this file):
51 ;;; $factlim - biggest integer for numerically evaluation
52 ;;; of the Double factorial
53 ;;; $gamma_expand - Expansion of the Gamma und Incomplete Gamma
54 ;;; function for some special cases
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57 ;;; This library is free software; you can redistribute it and/or modify it
58 ;;; under the terms of the GNU General Public License as published by the
59 ;;; Free Software Foundation; either version 2 of the License, or (at
60 ;;; your option) any later version.
62 ;;; This library is distributed in the hope that it will be useful, but
63 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
64 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
65 ;;; Library General Public License for more details.
67 ;;; You should have received a copy of the GNU General Public License along
68 ;;; with this library; if not, write to the Free Software
69 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
71 ;;; Copyright (C) 2008 Dieter Kaiser
72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
76 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
78 (defmvar $erf_representation nil
79 "When not false, error functions are transformed to erf, erfc, or erfi
80 depending on the value of $erf_representation."
81 ;; Need to use the noun form of these.
82 :setting-list
(nil t %erf %erfc %erfi
))
84 (defmvar $erf_%iargs nil
85 "When T erf and erfi simplifies for an imaginary argument.")
87 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
88 ;;; The following functions test if numerical evaluation has to be done.
89 ;;; The functions should help to test for numerical evaluation more consistent
90 ;;; and without complicated conditional tests including more than one or two
93 ;;; The functions take a list of arguments. All arguments have to be a CL or
94 ;;; Maxima number. If all arguments are numbers we have two cases:
95 ;;; 1. $numer is T we return T. The function has to be evaluated numerically.
96 ;;; 2. One of the args is a float or a bigfloat. Evaluate numerically.
97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99 ;;; Test for numerically evaluation in float precision
101 (defun float-numerical-eval-p (&rest args
)
104 (when (not (float-or-rational-p ll
))
105 (return-from float-numerical-eval-p nil
))
106 (when (floatp ll
) (setq flag t
)))
107 (if (or $numer flag
) t nil
)))
109 ;;; Test for numerically evaluation in complex float precision
111 (defun complex-float-numerical-eval-p (&rest args
)
112 "Determine if ARGS consists of numerical values by determining if
113 the real and imaginary parts of each arg are nuemrical (but not
114 bigfloats). A non-NIL result is returned if at least one of args is
115 a floating-point value or if numer is true. If the result is
116 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P"
119 (multiple-value-bind (bool rll ill
)
120 (complex-number-p ll
'float-or-rational-p
)
122 (return-from complex-float-numerical-eval-p nil
))
123 ;; Always save the result from complex-number-p. But for backward
124 ;; compatibility, only set the flag if any item is a float.
125 (push (add rll
(mul ill
'$%i
)) values
)
126 (setf flag
(or flag
(or (floatp rll
) (floatp ill
))))))
127 (when (or $numer flag
)
128 ;; Return the values in the same order as the args!
131 ;;; Test for numerically evaluation in bigfloat precision
133 (defun bigfloat-numerical-eval-p (&rest args
)
136 (when (not (bigfloat-or-number-p ll
))
137 (return-from bigfloat-numerical-eval-p nil
))
140 (if (or $numer flag
) t nil
)))
142 ;;; Test for numerically evaluation in complex bigfloat precision
144 (defun complex-bigfloat-numerical-eval-p (&rest args
)
145 "Determine if ARGS consists of numerical values by determining if
146 the real and imaginary parts of each arg are nuemrical (including
147 bigfloats). A non-NIL result is returned if at least one of args is
148 a floating-point value or if numer is true. If the result is
149 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P."
153 (multiple-value-bind (bool rll ill
)
154 (complex-number-p ll
'bigfloat-or-number-p
)
156 (return-from complex-bigfloat-numerical-eval-p nil
))
157 ;; Always save the result from complex-number-p. But for backward
158 ;; compatibility, only set the flag if any item is a bfloat.
159 (push (add rll
(mul ill
'$%i
)) values
)
160 (when (or ($bfloatp rll
) ($bfloatp ill
))
162 (when (or $numer flag
)
163 ;; Return the values in the same order as the args!
166 ;;; Test for numerical evaluation in any precision, real or complex.
167 (defun numerical-eval-p (&rest args
)
168 (or (apply 'float-numerical-eval-p args
)
169 (apply 'complex-float-numerical-eval-p args
)
170 (apply 'bigfloat-numerical-eval-p args
)
171 (apply 'complex-bigfloat-numerical-eval-p args
)))
173 ;;; Check for an integer or a float or bigfloat representation. When we
174 ;;; have a float or bigfloat representation return the integer value.
176 (defun integer-representation-p (x)
178 (cond ((integerp x
) x
)
179 ((and (floatp x
) (= 0 (nth-value 1 (truncate x
))))
180 (nth-value 0 (truncate x
)))
182 (eq ($sign
(sub (setq val
($truncate x
)) x
)) '$zero
))
186 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
188 ;;; The changes to the parser to connect the operator !! to double_factorial(z)
190 ;(def-mheader |$!!| (%double_factorial))
192 ;(def-led (|$!!| 160.) (op left)
195 ; (convert left '$expr)))
197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
199 ;;; The implementation of the function Double factorial
201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
203 ;;; Double factorial distributes over bags
205 (defprop %double_factorial
(mlist $matrix mequal
) distribute_over
)
207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209 ;;; Double factorial has mirror symmetry
211 (defprop %double_factorial t commutes-with-conjugate
)
213 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
215 ;;; Differentiation of Double factorial
217 (defprop %double_factorial
221 ((%double_factorial
) z
)
226 ((mplus) 1 ((mtimes) ((rat) 1 2) z
)))
229 ((%log
) ((mtimes) 2 ((mexpt) $%pi -
1)))
230 ((%sin
) ((mtimes) $%pi z
))))))
233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
235 ;;; Double factorial is a simplifying function
237 (def-simplifier double_factorial
(z)
239 ((and (fixnump z
) (> z -
1) (or (minusp $factlim
) (< z $factlim
)))
240 ;; Positive Integer less then $factlim or $factlim is -1. Call gfact.
241 (gfact z
(floor (/ z
2)) 2))
245 (zerop1 (sub (simplify (list '(%truncate
) (div z
2))) (div z
2))))
246 ;; Even negative integer or real representation. Not defined.
249 "double_factorial: double_factorial(~:M) is undefined.") z
))
251 ((or (integerp z
) ; at this point odd negative integer. Evaluate.
252 (complex-float-numerical-eval-p z
))
254 ((and (integerp z
) (= z -
1)) 1) ; Special cases -1 and -3
255 ((and (integerp z
) (= z -
3)) -
1)
257 ;; Odd negative integer, float or complex float.
260 (complex ($float
($realpart z
)) ($float
($imagpart z
))))))))
262 ((and (not (ratnump z
))
263 (complex-bigfloat-numerical-eval-p z
))
264 ;; bigfloat or complex bigfloat.
265 (bfloat-double-factorial
266 (add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))
268 ;; double_factorial(inf) -> inf
271 ((and $factorial_expand
275 (n (simplify (cons '(mplus) (cddr z
)))))
278 ;; Special case double_factorial(n-1)
279 ;; Not sure if this simplification is useful.
280 (div (simplify (list '(mfactorial) n
))
281 (simplify (list '(%double_factorial
) n
))))
282 ((= k
(* 2 (truncate (/ k
2))))
283 ;; Special case double_factorial(2*k+n), k integer
285 ($factor
; we get more simple expression when factoring
288 (simplify (list '($pochhammer
) (add (div n
2) 1) k
))
289 (simplify (list '(%double_factorial
) n
)))))
296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
297 ;;; Double factorial for a complex float argument. The result is a CL complex.
298 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
300 (defun double-factorial (z)
301 (let ((pival (float pi
)))
305 (/ (- 1 (cos (* pival z
))) 4))
307 (gamma-lanczos (+ 1 (/ z
2))))))
309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
310 ;;; Double factorial for a bigfloat or complex bigfloat argument
311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
313 (defun bfloat-double-factorial (z)
314 (let* ((pival ($bfloat
'$%pi
))
315 (bigfloat1 ($bfloat bigfloatone
))
316 (bigfloat2 (add bigfloat1 bigfloat1
))
317 (bigfloat4 (add bigfloat2 bigfloat2
))
321 (cdiv bigfloat2 pival
)
323 (simplify (list '(%cos
) (cmul pival z
)))) bigfloat4
))
325 (cpower bigfloat2
(cdiv z bigfloat2
))
326 (simplify (list '(%gamma
) (add bigfloat1
(cdiv z bigfloat2
))))))))
328 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
330 ;;; The implementation of the Incomplete Gamma function
337 ;;; gamma_incomplete(a, z) = I t %e dt
342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
344 (defvar *debug-gamma
* nil
)
346 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
349 ;;; Incomplete Gamma distributes over bags
351 (defprop %gamma_incomplete
(mlist $matrix mequal
) distribute_over
)
353 ;;; Incomplete Gamma function has not mirror symmetry for z on the negative
354 ;;; real axis. We support a conjugate-function which test this case.
356 (defprop %gamma_incomplete conjugate-gamma-incomplete conjugate-function
)
358 (defun conjugate-gamma-incomplete (args)
359 (let ((a (first args
)) (z (second args
)))
360 (cond ((off-negative-real-axisp z
)
361 ;; Definitely not on the negative real axis for z. Mirror symmetry.
365 (simplify (list '($conjugate
) a
))
366 (simplify (list '($conjugate
) z
)))))
368 ;; On the negative real axis or no information. Unsimplified.
371 (simplify (list '(%gamma_incomplete
) a z
)))))))
373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
375 ;;; Derivative of the Incomplete Gamma function
377 (putprop '%gamma_incomplete
380 (cond ((member ($sign a
) '($pos $pz
))
381 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2
382 ;; function and the Generalized Incomplete Gamma function
383 ;; (functions.wolfram.com), only for a>0.
386 ((mexpt) ((%gamma
) ,a
) 2)
388 (($hypergeometric_regularized
)
390 ((mlist) ((mplus) 1 ,a
) ((mplus) 1 ,a
))
393 ((%gamma_incomplete_generalized
) ,a
0 ,z
)
397 ((mqapply) (($psi array
) 0) ,a
))))
399 ;; No derivative. Maxima generates a noun form.
401 ;; The derivative wrt z
403 ((mexpt) $%e
((mtimes) -
1 z
))
404 ((mexpt) z
((mplus) -
1 a
))))
407 ;;; Integral of the Incomplete Gamma function
409 (defprop %gamma_incomplete
413 ((mtimes) -
1 ((%gamma_incomplete
) ((mplus) 1 a
) z
))
414 ((mtimes) ((%gamma_incomplete
) a z
) z
)))
417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
419 ;;; We support a simplim%function. The function is looked up in simplimit and
420 ;;; handles specific values of the function.
422 (defprop %gamma_incomplete simplim%gamma_incomplete simplim%function
)
424 (defun simplim%gamma_incomplete
(expr var val
)
425 ;; Set preserve-direction to true and find the limit of each argument.
426 (let* ((preserve-direction t
)
427 (a (limit (cadr expr
) var val
'think
))
428 (z (limit (caddr expr
) var val
'think
)))
430 ;; when either a or z is und, return und
431 ((or (eql a
'$und
) (eql z
'$und
)) '$und
)
432 ;; z in {minf, inf, infinity}, use http://dlmf.nist.gov/8.11#i
433 ((or (eq z
'$infinity
)
436 ;; Revert a & z to the arguments of gamma_incomplete.
438 (setq z
(caddr expr
))
439 ;; Use gamma_incomplete(a,z) = z^(a-1)/exp(z) + ... for
440 ;; fixed a and |z| --> inf. Unfortunately, limit(x*exp(%i*x),x,inf) = und.
441 ;; And that makes limit(gamma_incomplete(2, -%i*x), x, inf) = und, not
442 ;; infinity (this is a test in rtest_limit) But this bug needs to be fixed
443 ;; elsewhere. When a isn't fixed, give up.
445 (limit (div (ftake 'mexpt z
(sub a
1)) (ftake 'mexpt
'$%e z
)) var val
'think
)
448 ((and (eql a
0) (eq t
(mgrp 0 z
)))
449 (let ((im (behavior (cdr (risplit (caddr expr
))) var val
)))
451 (sub (mul '$%i
'$%pi
) (ftake '%expintegral_ei
(mul -
1 z
))))
453 (sub (mul -
1 '$%i
'$%pi
) (ftake '%expintegral_ei
(mul -
1 z
))))
454 (t (throw 'limit nil
)))))
456 ;; z in {zerob, 0, zeroa}.
457 ((and (freeof var a
) (or (eql z
0) (eq z
'$zeroa
) (eq z
'$zerob
)))
458 ;; Two cases: (i) a <= 0 & integer (ii) a not a negative integer.
459 ;; Revert a & z to the arguments of gamma_incomplete.
461 (setq z
(caddr expr
))
462 (cond ((and ($featurep a
'$integer
) (eq t
(mgqp 0 a
)))
463 ;; gamma_incomplete(a,n) = - (-1)^(-a) log(z)/(-a)! + ...
465 (limit (div (mul -
1 (ftake 'mexpt -
1 a
) (ftake '%log z
))
466 (ftake 'mfactorial a
)) var val
'think
))
468 (limit (sub (ftake '%gamma a
) (div (ftake 'mexpt z a
) a
)) var val
'think
))))
469 ;; z is on the branch cut. We need to know if the imaginary part of
470 ;; (caddr exp) approaches zero from above or below. The incomplete
471 ;; gamma function is continuous from above its branch cut. The check for
472 ;; $ind is needed to avoid calling sign on $ind.
473 ((and (not (eq z
'$ind
)) (eq t
(mgrp 0 z
)))
474 (let ((im (behavior (cdr (risplit (caddr expr
))) var val
)))
475 (cond ((eql im
1) ; use direct substitution
476 (ftake '%gamma_incomplete a z
))
480 (mul (ftake 'mexpt
'$%e
(mul -
2 '$%i
'$%pi a
))
481 (sub (ftake '%gamma a
) (ftake '%gamma_incomplete a z
)))))
483 (throw 'limit nil
)))))
485 ((or (eq a
'$ind
) (eq z
'$ind
))
486 ;; Revert a & z to the arguments of gamma_incomplete. When z is
487 ;; off the negative real axis or a is not a negative integer,
490 (setq z
(caddr expr
))
491 (if (or (off-negative-real-axisp z
)
492 (not (and ($featurep a
'$integer
) (eq t
(mgqp 0 a
))))) '$ind
494 ((or (eq a
'$und
) (eq z
'$und
)) '$und
)
501 ;; All other cases are handled by the simplifier of the function.
502 (ftake '%gamma_incomplete a z
)))))
504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
506 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
508 ;;; Implementation of the Lower Incomplete gamma function:
515 ;;; gamma_incomplete_lower(a, z) = I t %e dt
519 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
520 ;;; distribute over bags (aggregates)
522 (defprop %gamma_incomplete_lower
(mlist $matrix mequal
) distribute_over
)
524 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
526 ;; (defprop %gamma_incomplete_lower ??? grad) WHAT TO PUT HERE ??
529 ;; Handles some special cases for the order a and simplifies it to an
530 ;; equivalent form, possibly involving erf and gamma_incomplete_lower
532 (def-simplifier gamma_incomplete_lower
(a z
)
535 (float-numerical-eval-p a z
)
536 (complex-float-numerical-eval-p a z
)
537 (bigfloat-numerical-eval-p a z
)
538 (complex-bigfloat-numerical-eval-p a z
))
539 (ftake '%gamma_incomplete_generalized a
0 z
))
540 ((gamma-incomplete-lower-expand a z
))
541 ($hypergeometric_representation
542 ;; We make use of the fact that gamma_incomplete_lower(a,z) +
543 ;; gamma_incomplete(a,z) = gamma(a). Thus,
544 ;; gamma_incomplete_lower(a,z) = gamma(a)-gamma_incomplete(a,z).
545 ;; And we know the hypergeometric form for gamma_incomplete.
546 (sub (ftake '%gamma a
)
547 (ftake '%gamma_incomplete a z
)))
551 ;; Try to express gamma_incomplete_lower(a,z) in simpler terms for
552 ;; special values of the order a. If we can't, return NIL to say so.
553 (defun gamma-incomplete-lower-expand (a z
)
554 (cond ((and $gamma_expand
(integerp a
) (eql a
1))
555 ;; gamma_incomplete_lower(0, x) = 1-exp(x)
556 (sub 1 (m^t
'$%e
(neg z
))))
557 ((and $gamma_expand
(integerp a
) (plusp a
))
558 ;; gamma_incomplete_lower(a,z) can be simplified if a is a
559 ;; positive integer. Since gamma_incomplete_lower(a,z) =
560 ;; gamma(a) - gamma_incomplete(a,z), use gamma_incomplete to
562 (sub (ftake* '%gamma a
)
563 (take '(%gamma_incomplete
) a z
)))
564 ((and $gamma_expand
(alike1 a
1//2))
567 ;; gamma_incomplete_lower(1/2,x^2) = sqrt(%pi)*erf(x)
569 ;; gamma_incomplete_lower(1/2,z) = sqrt(%pi)*erf(sqrt(x))
571 (mul (power '$%pi
'((rat simp
) 1 2))
572 (take '(%erf
) (power z
'((rat simp
) 1 2)))))
573 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
574 ;; gamma_incomplete_lower(a+n,z), where n is an integer
576 (a (simplify (cons '(mplus) (cddr a
)))))
579 ;; gamma_incomplete_lower(a+n,z). See DLMF 8.8.7:
581 ;; gamma_incomplete_lower(a+n,z)
582 ;; = pochhammer(a,n)*gamma_incomplete_lower(a,z)
583 ;; -z^a*exp(-z)*sum(gamma(a+n)gamma(a+k+1)*z^k,k,0,n-1)
586 (simplify (list '($pochhammer
) a n
))
587 (simplify (list '(%gamma_incomplete_lower
) a z
)))
590 (power '$%e
(mul -
1 z
))
591 (let ((gamma-a+n
(ftake* '%gamma
(add a n
)))
592 (index (gensumindex))
597 (ftake* '%gamma
(add a index
1)))
599 index
0 (add n -
1))))))
602 ;; See DLMF 8.8.8. For simplicity let g(a,z) = gamma_incomplete_lower(a,z).
604 ;; g(a,z) = gamma(a)/gamma(a-n)*g(a-n,z)
605 ;; - z^(a-1)*exp(z)*sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
608 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
609 ;; + gamma(a-n)/gamma(a)*z^(a-1)*exp(-z)
610 ;; * sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
612 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
614 ;; * sum(gamma(a-n)/gamma(a-k)*z^(-k),k,0,n-1)
615 (let ((gamma-a-n (ftake* '%gamma
(sub a n
)))
616 (index (gensumindex))
622 (simplify (list '(%gamma_incomplete_lower
) a z
)))
625 (power '$%e
(mul -
1 z
))
629 (ftake* '%gamma
(sub a index
)))
630 (power z
(mul -
1 index
)))
631 index
0 (add n -
1)))))))))
632 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
633 (integerp (second a
))
634 (integerp (third a
)))
635 ;; gamma_incomplete_lower of (numeric) rational order.
636 ;; Expand it out so that the resulting order is between 0 and
638 (multiple-value-bind (n order
)
639 (floor (/ (second a
) (third a
)))
640 ;; a = n + order where 0 <= order < 1.
641 (let ((rat-order (rat (numerator order
) (denominator order
))))
644 ;; Nothing to do if the order is already between 0 and 1
645 (list '(%gamma_incomplete_lower simp
) a z
))
647 ;; Use gamma_incomplete(a+n,z) above. and then substitute
648 ;; a=order. This works for n positive or negative.
649 (let* ((ord (gensym))
650 (g (simplify (list '(%gamma_incomplete_lower
) (add ord n
) z
))))
651 ($substitute rat-order ord g
)))))))
653 ;; No expansion so return nil to indicate that
656 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
658 ;;; Incomplete Gamma function is a simplifying function
660 (def-simplifier gamma_incomplete
(a z
)
665 ;; Check for specific values
668 ;; gamma_incomplete(v,0) is gamma(v) only if the realpart(v) >
669 ;; 0. If realpart(v) <= 0, gamma_incomplete is undefined. For
670 ;; all other cases, return the noun form.
671 (let ((sgn ($sign
($realpart a
))))
672 (cond ((member sgn
'($neg $zero
))
675 "gamma_incomplete: gamma_incomplete(~:M,~:M) is undefined.")
677 ((member sgn
'($pos $pz
)) ($gamma a
))
685 ;; Check for numerical evaluation in Float or Bigfloat precision
687 ((float-numerical-eval-p a z
)
689 (format t
"~&SIMP-GAMMA-INCOMPLETE in float-numerical-eval-p~%"))
690 ;; a and z are Maxima numbers, at least one has a float value
695 (and (= 0 (- a
(truncate a
)))
697 ;; a is zero or a negative float representing an integer.
698 ;; For these cases the numerical routines of gamma-incomplete
699 ;; do not work. Call the numerical routine for the Exponential
700 ;; Integral E(n,z). The routine is called with a positive integer!.
701 (setq a
(truncate a
))
702 (complexify (* (expt z a
) (expintegral-e (- 1 a
) z
))))
704 (complexify (gamma-incomplete a z
))))))
706 ((complex-float-numerical-eval-p a z
)
709 "~&SIMP-GAMMA-INCOMPLETE in complex-float-numerical-eval-p~%"))
710 ;; a and z are Maxima numbers, at least one is a complex value and
711 ;; we have at least one float part
712 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
713 (cz (complex ($float
($realpart z
)) ($float
($imagpart z
)))))
715 ((and (= (imagpart ca
) 0.0)
716 (or (= (realpart ca
) 0.0)
717 (and (= 0 (- (realpart ca
) (truncate (realpart ca
))))
718 (< (realpart ca
) 0.0))))
719 ;; Call expintegral-e. See comment above.
720 (setq ca
(truncate (realpart ca
)))
721 (complexify (* (expt cz ca
) (expintegral-e (- 1 ca
) cz
))))
723 (complexify (gamma-incomplete ca cz
))))))
725 ((bigfloat-numerical-eval-p a z
)
727 (format t
"~&SIMP-GAMMA-INCOMPLETE in bigfloat-numerical-eval-p~%"))
728 (let ((a ($bfloat a
))
731 ((or (eq ($sign a
) '$zero
)
732 (and (eq ($sign
(sub a
($truncate a
))) '$zero
)
733 (eq ($sign a
) '$neg
)))
734 ;; Call bfloat-expintegral-e. See comment above.
735 (setq a
($truncate a
))
736 ($rectform
(mul (power z a
) (bfloat-expintegral-e (- 1 a
) z
))))
738 (bfloat-gamma-incomplete a z
)))))
740 ((complex-bigfloat-numerical-eval-p a z
)
743 "~&SIMP-GAMMA-INCOMPLETE in complex-bigfloat-numerical-eval-p~%"))
744 (let ((ca (add ($bfloat
($realpart a
))
745 (mul '$%i
($bfloat
($imagpart a
)))))
746 (cz (add ($bfloat
($realpart z
))
747 (mul '$%i
($bfloat
($imagpart z
))))))
749 ((and (eq ($sign
($imagpart ca
)) '$zero
)
750 (or (eq ($sign
($realpart ca
)) '$zero
)
751 (and (eq ($sign
(sub ($realpart ca
)
752 ($truncate
($realpart ca
))))
754 (eq ($sign
($realpart ca
)) '$neg
))))
755 ;; Call bfloat-expintegral-e. See comment above.
758 "~& bigfloat-numerical-eval-p calls bfloat-expintegral-e~%"))
759 (setq a
($truncate
($realpart a
)))
760 ($rectform
(mul (power cz a
)
761 (bfloat-expintegral-e (- 1 a
) cz
))))
763 (complex-bfloat-gamma-incomplete ca cz
)))))
765 ;; Check for transformations and argument simplification
767 ((and $gamma_expand
(integerp a
))
768 ;; Integer or a symbol declared to be an integer. Expand in a series.
769 (let ((sgn ($sign a
)))
774 (simplify (list '(%expintegral_ei
) (mul -
1 z
))))
778 (simplify (list '(%log
) (mul -
1 z
)))
779 (simplify (list '(%log
) (div -
1 z
)))))
780 (mul -
1 (simplify (list '(%log
) z
)))))
781 ((member sgn
'($pos $pz
))
783 (simplify (list '(%gamma
) a
))
784 (power '$%e
(mul -
1 z
))
785 (let ((index (gensumindex)))
789 (let (($gamma_expand nil
))
790 ;; Simplify gamma, but do not expand to avoid division
792 (simplify (list '(%gamma
) (add index
1)))))
793 index
0 (sub a
1)))))
794 ((member sgn
'($neg $nz
))
798 (power -
1 (add (mul -
1 a
) -
1))
799 (simplify (list '(%gamma
) (add (mul -
1 a
) 1))))
801 (simplify (list '(%expintegral_ei
) (mul -
1 z
)))
805 (simplify (list '(%log
) (mul -
1 z
)))
806 (simplify (list '(%log
) (div -
1 z
)))))
807 (simplify (list '(%log
) z
))))
809 (power '$%e
(mul -
1 z
))
810 (let ((index (gensumindex)))
813 (power z
(add index a -
1))
814 (simplify (list '($pochhammer
) a index
)))
815 index
1 (mul -
1 a
))))))
818 ((and $gamma_expand
(setq ratorder
(max-numeric-ratio-p a
2)))
819 ;; We have a half integral order and $gamma_expand is not NIL.
820 ;; We expand in a series with the Erfc function
821 (setq ratorder
(- ratorder
(/ 1 2)))
825 (power '$%pi
'((rat simp
) 1 2))
826 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))))
830 (simplify (list '(%gamma
) a
))
831 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
833 (power -
1 (sub ratorder
1))
834 (power '$%e
(mul -
1 z
))
835 (power z
'((rat simp
) 1 2))
836 (let ((index (gensumindex)))
838 (mul -
1 ; we get more simple results
839 (simplify ; when multiplying with -1
842 (sub '((rat simp
) 1 2) ratorder
)
843 (sub ratorder
(add index
1))))
844 (power (mul -
1 z
) index
))
845 index
0 (sub ratorder
1))))))
847 (setq ratorder
(- ratorder
))
852 (power '$%pi
'((rat simp
) 1 2))
853 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
854 (simplify (list '($pochhammer
) '((rat simp
) 1 2) ratorder
)))
856 (power z
(sub '((rat simp
) 1 2) ratorder
))
857 (power '$%e
(mul -
1 z
))
858 (let ((index (gensumindex)))
865 (sub '((rat simp
) 1 2) ratorder
)
867 index
0 (sub ratorder
1))))))))
869 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
870 ;; Handle gamma_incomplete(a+n, z), where n is a numerical integer
872 (a (simplify (cons '(mplus) (cddr a
)))))
875 ;; See DLMF 8.8.9: https://dlmf.nist.gov/8.8.E9
877 ;; gamma_incomplete(a+n,z) = pochhammer(a,n)*gamma_incomplete(a,z)
878 ;; + z^a*exp(-z)*sum(gamma(a+n)/gamma(a+k+1)*z^k,k,0,n-1)
881 (simplify (list '($pochhammer
) a n
))
882 (simplify (list '(%gamma_incomplete
) a z
)))
884 (power '$%e
(mul -
1 z
))
886 (let ((gamma-a+n
(ftake* '%gamma
(add a n
)))
887 (index (gensumindex)))
891 (ftake* '%gamma
(add a index
1)))
893 index
0 (add n -
1))))))
896 ;; See http://functions.wolfram.com/06.06.17.0004.01
898 ;; gamma_incomplate(a,z) =
899 ;; (-1)^n*pochhammer(1-a,n)
900 ;; *[gamma_incomplete(a-n,z)
901 ;; + z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)]
903 ;; Rerarrange this in terms of gamma_incomplete(a-n,z):
905 ;; gamma_incomplete(a-n,z) =
906 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
907 ;; -z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)
909 ;; Change the summation index to go from k = 0 to n-1:
911 ;; z^(a-n-1)*sum(z^k/pochhammer(a-n,k),k,1,n)
912 ;; = z^(a-n-1)*sum(z^(k+1)/pochhammer(a-n,k+1),k,0,n-1)
913 ;; = z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
916 ;; gamma_incomplete(a-n,z) =
917 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
918 ;; -z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
920 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
924 (simplify (list '(%gamma_incomplete
) a z
)))
925 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
927 (power '$%e
(mul -
1 z
))
929 ;; sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
930 (let ((index (gensumindex)))
934 (simplify (list '($pochhammer
) (sub a n
) (add index
1))))
935 index
0 (sub n
1)))))))))
936 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
937 (integerp (second a
))
938 (integerp (third a
)))
939 ;; gamma_incomplete of (numeric) rational order. Expand it out
940 ;; so that the resulting order is between 0 and 1.
941 (multiple-value-bind (n order
)
942 (floor (/ (second a
) (third a
)))
943 ;; a = n + order where 0 <= order < 1.
944 (let ((rat-order (rat (numerator order
) (denominator order
))))
947 ;; Nothing to do if the order is already between 0 and 1
950 ;; Use gamma_incomplete(a+n,z) above. and then substitute
951 ;; a=order. This works for n positive or negative.
952 (let* ((ord (gensym))
953 (g (simplify (list '(%gamma_incomplete
) (add ord n
) z
))))
954 ($substitute rat-order ord g
)))))))
956 ($hypergeometric_representation
957 ;; See http://functions.wolfram.com/06.06.26.0002.01
959 ;; gamma_incomplete(a,z) = gamma(z) - z^a/a*%f[1,1]([a],[a+1},-z)
961 ;; However, hypergeomtric simplifies
962 ;; hypergeometric([a],[a+1],-z) to
963 ;; hypergeometric([1],[a+1],z)*exp(-z).
964 (sub (ftake '%gamma a
)
967 (ftake '%hypergeometric
969 (make-mlist (add 1 a
))
973 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
974 ;;; Numerical evaluation of the Incomplete Gamma function
976 ;;; gamma-incomplete (a,z) - real and complex double float
977 ;;; bfloat-gamma-incomplete (a z) - bigfloat
978 ;;; complex-bfloat-gamma-incomplete (a z) - complex bigfloat
980 ;;; Expansion in a power series for abs(x) < R, where R is
981 ;;; *gamma-radius* + real(a) if real(a) > 0 or *gamma-radius*
989 ;;; gamma(a,z) = exp(-x)*z^a * > ------------ * z^n
994 ;;; This expansion does not work for an integer a<=0, because the Gamma function
995 ;;; in the denominator is not defined for a=0 and negative integers. For this
996 ;;; case we use the Exponential Integral E for numerically evaluation. The
997 ;;; Incomplete Gamma function and the Exponential integral are connected by
999 ;;; gamma(a,z) = z^a * expintegral_e(1-a,z)
1001 ;;; When the series is not used, two forms of the continued fraction
1002 ;;; are used. When z is not near the negative real axis use the
1003 ;;; continued fractions (A&S 6.5.31):
1006 ;;; gamma(a,z) = exp(-z) z^a *( -- --- --- --- --- ... )
1009 ;;; The accuracy is controlled by *gamma-incomplete-eps* for double float
1010 ;;; precision. For bigfloat precision epsilon is 10^(-$fpprec). The expansions
1011 ;;; in a power series or continued fractions stops if *gamma-incomplete-maxit*
1012 ;;; is exceeded and an Maxima error is thrown.
1014 ;;; The above fraction does not converge on the negative real axis and
1015 ;;; converges very slowly near the axis. In this case, use the
1018 ;;; gamma(a,z) = gamma(a) - gamma_lower(a,z)
1020 ;;; The continued fraction for gamma_incomplete_lower(a,z) is
1021 ;;; (http://functions.wolfram.com/06.06.10.0009.01):
1023 ;;; gamma_lower(a,z) = exp(-z) * z^a / cf(a,z)
1027 ;;; -a*z z (a+1)*z 2*z (a+2)*z
1028 ;;; cf(a,z) = a + ---- ---- ------- ---- -------
1029 ;;; a+1+ a+2- a+3+ a+4- a+5+
1031 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1033 (defvar *gamma-incomplete-maxit
* 10000)
1034 (defvar *gamma-incomplete-eps
* (* 2 +flonum-epsilon
+))
1035 (defvar *gamma-incomplete-min
* 1.0e-32)
1037 (defvar *gamma-radius
* 1.0
1038 "Controls the radius within a series expansion is done.")
1039 (defvar *gamma-imag
* 1.0)
1041 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1043 ;;; The numerical evaluation for CL float or complex values a and x
1044 ;;; When the flag regularized is T, the result is divided by gamma(a) and
1045 ;;; Maxima returns the numerical result for gamma_incomplete_regularized
1047 (defun gamma-incomplete (a x
&optional
(regularized nil
))
1048 (setq x
(+ x
(cond ((complexp x
) #C
(0.0
0.0)) ((realp x
) 0.0))))
1051 ;; Compute the factor needed to scale the series or continued
1052 ;; fraction. This is x^a*exp(-x) or x^a*exp(-x)/gamma(a)
1053 ;; depending on whether we want a non-regularized or
1054 ;; regularized form. We want to compute the factor carefully
1055 ;; to avoid unnecessary overflow if possible.
1057 (or (try-float-computation
1059 ;; gammafloat is more accurate for real
1062 (/ (* (expt x a
) (exp (- x
)))
1065 (/ (* (expt x a
) (exp (- x
)))
1067 ;; Easy way failed. Use logs to compute the
1068 ;; result. This loses some precision, especially
1069 ;; for large values of a and/or x because we use
1070 ;; many bits to hold the exponent part.
1071 (exp (- (* a
(log x
))
1073 (log-gamma-lanczos (if (complexp a
)
1077 (or (try-float-computation
1079 (* (expt x a
) (exp (- x
)))))
1080 ;; Easy way failed, so use the log form.
1081 (exp (- (* a
(log x
))
1083 (multiple-value-bind (result lower-incomplete-tail-p
)
1084 (%gamma-incomplete a x
)
1085 (cond (lower-incomplete-tail-p
1086 ;; %gamma-incomplete compute the lower incomplete gamma
1087 ;; function, so we need to subtract that from gamma(a),
1090 (- 1 (* result factor
)))
1092 (- (gamma-lanczos a
) (* result factor
)))
1094 (- (gammafloat a
) (* result factor
)))))
1096 ;; Continued fraction used. Just multiply by the factor
1097 ;; to get the final result.
1098 (* factor result
))))))
1100 ;; Compute the key part of the gamma incomplete function using either
1101 ;; a series expression or a continued fraction expression. Two values
1102 ;; are returned: the value itself and a boolean, indicating what the
1103 ;; computed value is. If the boolean non-NIL, then the computed value
1104 ;; is the lower incomplete gamma function.
1105 (defun %gamma-incomplete
(a x
)
1106 (let ((gm-maxit *gamma-incomplete-maxit
*)
1107 (gm-eps *gamma-incomplete-eps
*)
1108 (gm-min *gamma-incomplete-min
*))
1110 (format t
"~&GAMMA-INCOMPLETE with ~A and ~A~%" a x
))
1112 ;; The series expansion is done for x within a circle of radius
1113 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1114 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1115 ;; continued fraction is used.
1116 ((and (> (abs x
) (+ *gamma-radius
*
1117 (if (> (realpart a
) 0.0) (realpart a
) 0.0))))
1118 (cond ((and (< (realpart x
) 0)
1119 (< (abs (imagpart x
))
1120 (* *gamma-imag
* (abs (realpart x
)))))
1121 ;; For x near the negative real axis, use the
1122 ;; relationship gamma_incomplete(a,z) = gamma(a) -
1123 ;; gamma_incomplete_lower(a,z), where
1124 ;; gamma_incomplete_lower(a,z) is the lower poart of the
1125 ;; incomplete gamma function. We can evaluate that
1126 ;; using a continued fraction from
1127 ;; http://functions.wolfram.com/06.06.10.0009.01. (Note
1128 ;; that the alternative fraction,
1129 ;; http://functions.wolfram.com/06.06.10.0007.01,
1130 ;; appears to be less accurate.)
1132 ;; Also note that this appears to be valid for all
1133 ;; values of x (real or complex), but we don't want to
1134 ;; use this everywhere for gamma_incomplete. Consider
1135 ;; what happens for large real x. gamma_incomplete(a,x)
1136 ;; is small, but gamma_incomplete(a,x) = gamma(x) - cf
1137 ;; will have large roundoff errors.
1139 (format t
"~&GAMMA-INCOMPLETE in continued fractions for lower integral~%"))
1140 (let ((a (bigfloat:to a
))
1142 (bigfloat::*debug-cf-eval
* *debug-gamma
*)
1143 (bigfloat::*max-cf-iterations
* *gamma-incomplete-maxit
*))
1144 (values (/ (bigfloat::lentz
#'(lambda (n)
1149 (- (* (+ a
(ash n -
1)) x
))))))
1152 ;; Expansion in continued fractions for gamma_incomplete.
1154 (format t
"~&GAMMA-INCOMPLETE in continued fractions~%"))
1156 (an (- a
1.0) (* i
(- a i
)))
1157 (b (+ 3.0 x
(- a
)) (+ b
2.0))
1159 (d (/ 1.0 (- b
2.0)))
1163 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1164 (setq d
(+ (* an d
) b
))
1165 (when (< (abs d
) gm-min
) (setq d gm-min
))
1166 (setq c
(+ b
(/ an c
)))
1167 (when (< (abs c
) gm-min
) (setq c gm-min
))
1171 (when (< (abs (- del
1.0)) gm-eps
)
1172 ;; Return nil to indicate we used the continued fraction.
1173 (return (values h nil
)))))))
1175 ;; Expansion in a series
1177 (format t
"~&GAMMA-INCOMPLETE in series~%"))
1180 (del (/ 1.0 a
) (* del
(/ x ap
)))
1181 (sum del
(+ sum del
)))
1183 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1184 (when (< (abs del
) (* (abs sum
) gm-eps
))
1185 (when *debug-gamma
* (format t
"~&Series converged.~%"))
1186 ;; Return T to indicate we used the series and the series
1187 ;; is for the integral from 0 to x, not x to inf.
1188 (return (values sum t
))))))))
1190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1192 ;;; This function is called for a and x real
1194 (defun bfloat-gamma-incomplete (a x
)
1195 (let* ((gm-maxit *gamma-incomplete-maxit
*)
1196 (gm-eps (power ($bfloat
10.0) (- $fpprec
)))
1197 (gm-min (mul gm-eps gm-eps
))
1200 ;; The series expansion is done for x within a circle of radius
1201 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1202 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1203 ;; continued fraction is used.
1204 ((eq ($sign
(sub (simplify (list '(mabs) x
))
1206 (if (eq ($sign a
) '$pos
) a
0.0))))
1209 ((and (eq ($sign x
) '$pos
))
1210 ;; Expansion in continued fractions of the Incomplete Gamma function
1212 (an (sub a
1.0) (mul i
(sub a i
)))
1213 (b (add 3.0 x
(mul -
1 a
)) (add b
2.0))
1214 (c (div 1.0 gm-min
))
1215 (d (div 1.0 (sub b
2.0)))
1219 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1221 (format t
"~&in continued fractions:~%")
1222 (mformat t
"~& : i = ~M~%" i
)
1223 (mformat t
"~& : h = ~M~%" h
))
1224 (setq d
(add (mul an d
) b
))
1225 (when (eq ($sign
(sub (simplify (list '(mabs) d
)) gm-min
)) '$neg
)
1227 (setq c
(add b
(div an c
)))
1228 (when (eq ($sign
(sub (simplify (list '(mabs) c
)) gm-min
)) '$neg
)
1230 (setq d
(div 1.0 d
))
1231 (setq del
(mul d c
))
1232 (setq h
(mul h del
))
1233 (when (eq ($sign
(sub (simplify (list '(mabs) (sub del
1.0))) gm-eps
))
1238 (power ($bfloat
'$%e
) (mul -
1 x
)))))))
1240 ;; Expand to multiply everything out.
1242 ;; Expansion in continued fraction for the lower incomplete gamma.
1243 (sub (simplify (list '(%gamma
) a
))
1244 ;; NOTE: We want (power x a) instead of bigfloat:expt
1245 ;; because this preserves how maxima computes x^a when
1246 ;; x is negative and a is rational. For, example
1247 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1250 (power ($bfloat
'$%e
) (mul -
1 x
))
1251 (let ((a (bigfloat:to a
))
1252 (x (bigfloat:to x
)))
1259 (bigfloat:* (ash n -
1) x
)
1260 (bigfloat:-
(bigfloat:* (bigfloat:+ a
(ash n -
1))
1264 ;; Series expansion of the Incomplete Gamma function
1267 (del (div 1.0 a
) (mul del
(div x ap
)))
1268 (sum del
(add sum del
)))
1270 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1272 (format t
"~&GAMMA-INCOMPLETE in series:~%")
1273 (mformat t
"~& : i = ~M~%" i
)
1274 (mformat t
"~& : ap = ~M~%" ap
)
1275 (mformat t
"~& : x/ap = ~M~%" (div x ap
))
1276 (mformat t
"~& : del = ~M~%" del
)
1277 (mformat t
"~& : sum = ~M~%" sum
))
1278 (when (eq ($sign
(sub (simplify (list '(mabs) del
))
1279 (mul (simplify (list '(mabs) sum
)) gm-eps
)))
1281 (when *debug-gamma
* (mformat t
"~&Series converged to ~M.~%" sum
))
1283 (sub (simplify (list '(%gamma
) a
))
1287 (power ($bfloat
'$%e
) (mul -
1 x
))))))))))))
1289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1291 (defun complex-bfloat-gamma-incomplete (a x
)
1292 (let* ((gm-maxit *gamma-incomplete-maxit
*)
1293 (gm-eps (power ($bfloat
10.0) (- $fpprec
)))
1294 (gm-min (mul gm-eps gm-eps
))
1297 (format t
"~&COMPLEX-BFLOAT-GAMMA-INCOMPLETE~%")
1298 (format t
" : a = ~A~%" a
)
1299 (format t
" : x = ~A~%" x
))
1301 ;; The series expansion is done for x within a circle of radius
1302 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1303 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1304 ;; continued fraction is used.
1305 ((and (eq ($sign
(sub (simplify (list '(mabs) x
))
1307 (if (eq ($sign
($realpart a
)) '$pos
)
1312 ((not (and (eq ($sign
($realpart x
)) '$neg
)
1313 (eq ($sign
(sub (simplify (list '(mabs) ($imagpart x
)))
1314 (simplify (list '(mabs) ($realpart x
)))))
1316 ;; Expansion in continued fractions of the Incomplete Gamma function
1318 (format t
"~&in continued fractions:~%"))
1320 (an (sub a
1.0) (mul i
(sub a i
)))
1321 (b (add 3.0 x
(mul -
1 a
)) (add b
2.0))
1322 (c (cdiv 1.0 gm-min
))
1323 (d (cdiv 1.0 (sub b
2.0)))
1327 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1328 (setq d
(add (cmul an d
) b
))
1329 (when (eq ($sign
(sub (simplify (list '(mabs) d
)) gm-min
)) '$neg
)
1331 (setq c
(add b
(cdiv an c
)))
1332 (when (eq ($sign
(sub (simplify (list '(mabs) c
)) gm-min
)) '$neg
)
1334 (setq d
(cdiv 1.0 d
))
1335 (setq del
(cmul d c
))
1336 (setq h
(cmul h del
))
1337 (when (eq ($sign
(sub (simplify (list '(mabs) (sub del
1.0)))
1341 ($bfloat
; force evaluation of expressions with sin or cos
1345 (cpower ($bfloat
'$%e
) ($bfloat
(mul -
1 x
))))))))))
1347 ;; Expand to multiply everything out.
1349 ;; Expansion in continued fraction for the lower incomplete gamma.
1350 (sub ($rectform
(simplify (list '(%gamma
) a
)))
1351 ;; NOTE: We want (power x a) instead of bigfloat:expt
1352 ;; because this preserves how maxima computes x^a when
1353 ;; x is negative and a is rational. For, example
1354 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1356 (mul ($rectform
(power x a
))
1357 ($rectform
(power ($bfloat
'$%e
) (mul -
1 x
)))
1358 (let ((a (bigfloat:to a
))
1359 (x (bigfloat:to x
)))
1366 (bigfloat:* (ash n -
1) x
)
1367 (bigfloat:-
(bigfloat:* (bigfloat:+ a
(ash n -
1))
1370 ;; Series expansion of the Incomplete Gamma function
1372 (format t
"~&GAMMA-INCOMPLETE in series:~%"))
1375 (del (cdiv 1.0 a
) (cmul del
(cdiv x ap
)))
1376 (sum del
(add sum del
)))
1378 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1379 (when (eq ($sign
(sub (simplify (list '(mabs) del
))
1380 (mul (simplify (list '(mabs) sum
)) gm-eps
)))
1382 (when *debug-gamma
* (format t
"~&Series converged.~%"))
1384 ($bfloat
; force evaluation of expressions with sin or cos
1385 (sub (simplify (list '(%gamma
) a
))
1389 (cpower ($bfloat
'$%e
) (mul -
1 x
)))))))))))))
1391 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1393 ;;; Implementation of the Generalized Incomplete Gamma function
1398 ;;; gamma_incomplete_generalized(a, z1, z2) = I t %e dt
1403 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1405 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1406 ;;; on the negative real axis.
1407 ;;; We support a conjugate-function which test this case.
1409 (defprop %gamma_incomplete_generalized
1410 conjugate-gamma-incomplete-generalized conjugate-function
)
1412 (defun conjugate-gamma-incomplete-generalized (args)
1413 (let ((a (first args
)) (z1 (second args
)) (z2 (third args
)))
1414 (cond ((and (off-negative-real-axisp z1
) (off-negative-real-axisp z2
))
1415 ;; z1 and z2 definitely not on the negative real axis.
1419 '(%gamma_incomplete_generalized
)
1420 (simplify (list '($conjugate
) a
))
1421 (simplify (list '($conjugate
) z1
))
1422 (simplify (list '($conjugate
) z2
)))))
1424 ;; On the negative real axis or no information. Unsimplified.
1427 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
)))))))
1429 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1431 ;;; Generalized Incomplete Gamma distributes over bags
1433 (defprop %gamma_incomplete_generalized
(mlist $matrix mequal
) distribute_over
)
1435 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1437 ;;; Differentiation of Generalized Incomplete Gamma function
1439 (defprop %gamma_incomplete_generalized
1441 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1442 ;; and the Generalized Incomplete Gamma function (functions.wolfram.com)
1445 ((mexpt) ((%gamma
) a
) 2)
1447 (($hypergeometric_regularized
)
1449 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1452 ((mexpt) ((%gamma
) a
) 2)
1454 (($hypergeometric_regularized
)
1456 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1459 ((%gamma_incomplete_generalized
) a
0 z1
)
1462 ((%gamma_incomplete_generalized
) a
0 z2
)
1464 ;; The derivative wrt z1
1466 ((mexpt) $%e
((mtimes) -
1 z1
))
1467 ((mexpt) z1
((mplus) -
1 a
)))
1468 ;; The derivative wrt z2
1470 ((mexpt) $%e
((mtimes) -
1 z2
))
1471 ((mexpt) z2
((mplus) -
1 a
))))
1474 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1476 ;;; Generalized Incomplete Gamma function is a simplifying function
1478 (def-simplifier gamma_incomplete_generalized
(a z1 z2
)
1482 ;; Check for specific values
1485 (let ((sgn ($sign
($realpart a
))))
1487 ((member sgn
'($pos $pz
))
1489 (simplify (list '(%gamma_incomplete
) a z1
))
1490 (simplify (list '(%gamma
) a
))))
1495 (let ((sgn ($sign
($realpart a
))))
1497 ((member sgn
'($pos $pz
))
1499 (simplify (list '(%gamma
) a
))
1500 (simplify (list '(%gamma_incomplete
) a z2
))))
1504 ((zerop1 (sub z1 z2
)) 0)
1506 ((eq z2
'$inf
) (simplify (list '(%gamma_incomplete
) a z1
)))
1507 ((eq z1
'$inf
) (mul -
1 (simplify (list '(%gamma_incomplete
) a z2
))))
1509 ;; Check for numerical evaluation in Float or Bigfloat precision
1510 ;; Use the numerical routines of the Incomplete Gamma function
1512 ((float-numerical-eval-p a z1 z2
)
1514 (- (gamma-incomplete ($float a
) ($float z1
))
1515 (gamma-incomplete ($float a
) ($float z2
)))))
1517 ((complex-float-numerical-eval-p a z1 z2
)
1518 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
1519 (cz1 (complex ($float
($realpart z1
)) ($float
($imagpart z1
))))
1520 (cz2 (complex ($float
($realpart z2
)) ($float
($imagpart z2
)))))
1521 (complexify (- (gamma-incomplete ca cz1
) (gamma-incomplete ca cz2
)))))
1523 ((bigfloat-numerical-eval-p a z1 z2
)
1524 (sub (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z1
))
1525 (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z2
))))
1527 ((complex-bigfloat-numerical-eval-p a z1 z2
)
1528 (let ((ca (add ($bfloat
($realpart a
))
1529 (mul '$%i
($bfloat
($imagpart a
)))))
1530 (cz1 (add ($bfloat
($realpart z1
))
1531 (mul '$%i
($bfloat
($imagpart z1
)))))
1532 (cz2 (add ($bfloat
($realpart z2
))
1533 (mul '$%i
($bfloat
($imagpart z2
))))))
1534 (sub (complex-bfloat-gamma-incomplete ca cz1
)
1535 (complex-bfloat-gamma-incomplete ca cz2
))))
1537 ;; Check for transformations and argument simplification
1539 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
1540 ;; Expand gamma_incomplete_generalized(a+n,z1,z2) with n an integer
1542 (a (simplify (cons '(mplus) (cddr a
)))))
1546 (simplify (list '($pochhammer
) a n
))
1548 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
))
1550 (power '$%e
(mul -
1 z1
))
1551 (let ((index (gensumindex)))
1554 (power z1
(add a index -
1))
1555 (simplify (list '($pochhammer
) a index
)))
1558 (power '$%e
(mul -
1 z2
))
1559 (let ((index (gensumindex)))
1562 (power z2
(add a index -
1))
1563 (simplify (list '($pochhammer
) a index
)))
1572 ($factor
(simplify (list '($pochhammer
) (sub 1 a
) n
))))
1573 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
)))
1575 (power '$%e
(mul -
1 z2
))
1576 (let ((index (gensumindex)))
1579 (power z1
(add a index
(- n
) -
1))
1580 (simplify (list '($pochhammer
) (sub a n
) index
)))
1583 (power '$%e
(mul -
1 z2
))
1584 (let ((index (gensumindex)))
1587 (power z2
(add a index
(- n
) -
1))
1588 (simplify (list '($pochhammer
) (sub a n
) index
)))
1590 ($hypergeometric_representation
1591 ;; Use the fact that gamma_incomplete_generalized(a,z1,z2) =
1592 ;; gamma_incomplete(a,z1) - gamma_incomplete(a,z2).
1593 (sub (ftake '%gamma_incomplete a z1
)
1594 (ftake '%gamma_incomplete a z2
)))
1597 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1599 ;;; Implementation of the Regularized Incomplete Gamma function
1603 ;;; gamma_incomplete(a, z)
1604 ;;; gamma_incomplete_regularized(a, z) = ----------------------
1607 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1609 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1611 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1612 ;;; on the negative real axis.
1613 ;;; We support a conjugate-function which test this case.
1615 (defprop %gamma_incomplete_regularized
1616 conjugate-gamma-incomplete-regularized conjugate-function
)
1618 (defun conjugate-gamma-incomplete-regularized (args)
1619 (let ((a (first args
)) (z (second args
)))
1620 (cond ((off-negative-real-axisp z
)
1621 ;; z definitely not on the negative real axis. Mirror symmetry.
1624 '(%gamma_incomplete_regularized
)
1625 (simplify (list '($conjugate
) a
))
1626 (simplify (list '($conjugate
) z
)))))
1628 ;; On the negative real axis or no information. Unsimplified.
1631 (simplify (list '(%gamma_incomplete_regularized
) a z
)))))))
1633 ;;; Regularized Incomplete Gamma distributes over bags
1635 (defprop %gamma_incomplete_regularized
(mlist $matrix mequal
) distribute_over
)
1637 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1639 ;;; Differentiation of Regularized Incomplete Gamma function
1641 (defprop %gamma_incomplete_regularized
1643 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1644 ;; and the Regularized Generalized Incomplete Gamma function
1645 ;; (functions.wolfram.com)
1650 (($hypergeometric_regularized
)
1652 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1655 ((%gamma_incomplete_generalized_regularized
) a z
0)
1658 ((mtimes) -
1 ((mqapply) (($psi array
) 0) a
)))))
1659 ;; The derivative wrt z
1662 ((mexpt) $%e
((mtimes) -
1 z
))
1663 ((mexpt) z
((mplus) -
1 a
))
1664 ((mexpt) ((%gamma
) a
) -
1)))
1667 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1669 ;;; Regularized Incomplete Gamma function is a simplifying function
1671 (def-simplifier gamma_incomplete_regularized
(a z
)
1677 ;; Check for specific values
1680 (let ((sgn ($sign
($realpart a
))))
1681 (cond ((member sgn
'($neg $zero
))
1684 "gamma_incomplete_regularized: gamma_incomplete_regularized(~:M,~:M) is undefined.")
1686 ((member sgn
'($pos $pz
)) 1)
1692 ;; Check for numerical evaluation in Float or Bigfloat precision
1694 ((float-numerical-eval-p a z
)
1696 ;; gamma_incomplete returns a regularized result
1697 (gamma-incomplete ($float a
) ($float z
) t
)))
1699 ((complex-float-numerical-eval-p a z
)
1700 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
1701 (cz (complex ($float
($realpart z
)) ($float
($imagpart z
)))))
1702 ;; gamma_incomplete returns a regularized result
1703 (complexify (gamma-incomplete ca cz t
))))
1705 ((bigfloat-numerical-eval-p a z
)
1706 (div (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z
))
1707 (simplify (list '(%gamma
) ($bfloat a
)))))
1709 ((complex-bigfloat-numerical-eval-p a z
)
1710 (let ((ca (add ($bfloat
($realpart a
))
1711 (mul '$%i
($bfloat
($imagpart a
)))))
1712 (cz (add ($bfloat
($realpart z
))
1713 (mul '$%i
($bfloat
($imagpart z
))))))
1716 (complex-bfloat-gamma-incomplete ca cz
)
1717 (simplify (list '(%gamma
) ca
))))))
1719 ;; Check for transformations and argument simplification
1721 ((and $gamma_expand
(integerp a
))
1722 ;; An integer. Expand the expression.
1723 (let ((sgn ($sign a
)))
1725 ((member sgn
'($pos $pz
))
1727 (power '$%e
(mul -
1 z
))
1728 (let ((index (gensumindex)))
1732 (let (($gamma_expand nil
))
1733 (simplify (list '(%gamma
) (add index
1)))))
1734 index
0 (sub a
1)))))
1735 ((member sgn
'($neg $nz
)) 0)
1738 ((and $gamma_expand
(setq ratorder
(max-numeric-ratio-p a
2)))
1739 ;; We have a half integral order and $gamma_expand is not NIL.
1740 ;; We expand in a series with the Erfc function
1741 (setq ratorder
(- ratorder
(/ 1 2)))
1743 (format t
"~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in RATORDER~%")
1744 (format t
"~& : a = ~A~%" a
)
1745 (format t
"~& : ratorder = ~A~%" ratorder
))
1748 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
1752 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))
1754 (power -
1 (sub ratorder
1))
1755 (power '$%e
(mul -
1 z
))
1756 (power z
'((rat simp
) 1 2))
1757 (div 1 (simplify (list '(%gamma
) a
)))
1758 (let ((index (gensumindex)))
1761 (power (mul -
1 z
) index
)
1762 (simplify (list '($pochhammer
)
1763 (sub '((rat simp
) 1 2) ratorder
)
1764 (sub ratorder
(add index
1)))))
1765 index
0 (sub ratorder
1))))))
1768 (setq ratorder
(- ratorder
))
1770 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))
1772 (power '$%e
(mul -
1 z
))
1773 (power z
(sub '((rat simp
) 1 2) ratorder
))
1774 (inv (simplify (list '(%gamma
) (sub '((rat simp
) 1 2) ratorder
))))
1775 (let ((index (gensumindex)))
1779 (simplify (list '($pochhammer
)
1780 (sub '((rat simp
) 1 2) ratorder
)
1782 index
0 (sub ratorder
1))))))))
1784 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
1786 (format t
"~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in COND (mplusp)~%"))
1788 (a (simplify (cons '(mplus) (cddr a
)))))
1792 (simplify (list '(%gamma_incomplete_regularized
) a z
))
1793 ;; We factor the second summand.
1794 ;; Some factors vanish and the result is more readable.
1797 (power '$%e
(mul -
1 z
))
1798 (power z
(add a -
1))
1799 (div 1 (simplify (list '(%gamma
) a
)))
1800 (let ((index (gensumindex)))
1804 (simplify (list '($pochhammer
) a index
)))
1809 (simplify (list '(%gamma_incomplete_regularized
) a z
))
1810 ;; We factor the second summand.
1813 (power '$%e
(mul -
1 z
))
1814 (power z
(sub a
(add n
1)))
1815 (div 1 (simplify (list '(%gamma
) (add a
(- n
)))))
1816 (let ((index (gensumindex)))
1820 (simplify (list '($pochhammer
) (add a
(- n
)) index
)))
1822 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
1823 (integerp (second a
))
1824 (integerp (third a
)))
1825 ;; gamma_incomplete_regularized of numeric rational order.
1826 ;; Expand it out so that the resulting order is between 0 and
1827 ;; 1. Use gamma_incomplete_regularized(a+n,z) to do the dirty
1829 (multiple-value-bind (n order
)
1830 (floor (/ (second a
) (third a
)))
1831 ;; a = n + order where 0 <= order < 1.
1832 (let ((rat-order (rat (numerator order
) (denominator order
))))
1835 ;; Nothing to do if the order is already between 0 and 1
1838 ;; Use gamma_incomplete_regularized(a+n,z) above. and
1839 ;; then substitute a=order. This works for n positive or
1841 (let* ((ord (gensym))
1842 (g (simplify (list '(%gamma_incomplete_regularized
) (add ord n
) z
))))
1843 ($substitute rat-order ord g
)))))))
1845 ($hypergeometric_representation
1846 ;; gamma_incomplete_regularized(a,z)
1847 ;; = gamma_incomplete(a,z)/gamma(a)
1848 ;; = (gamma(a) - gamma_incomplete_lower(a,z))/gamma(a)
1849 ;; = 1 - gamma_incomplete_lower(a,z)/gamma(a)
1851 (div (ftake '%gamma_incomplete_lower a z
)
1852 (ftake '%gamma a
))))
1855 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1857 ;;; Implementation of the Logarithm of the Gamma function
1859 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1861 (defmfun $log_gamma
(z)
1862 (simplify (list '(%log_gamma
) z
)))
1864 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1866 (defprop $log_gamma %log_gamma alias
)
1867 (defprop $log_gamma %log_gamma verb
)
1869 (defprop %log_gamma $log_gamma reversealias
)
1870 (defprop %log_gamma $log_gamma noun
)
1872 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1874 (defprop %log_gamma simp-log-gamma operators
)
1876 ;;; Logarithm of the Gamma function distributes over bags
1878 (defprop %log_gamma
(mlist $matrix mequal
) distribute_over
)
1880 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1884 ((mqapply) (($psi array
) 0) z
))
1887 ;; integrate(log_gamma(x),x) = psi[-2](x)
1888 (defun log-gamma-integral (x)
1889 (take '(mqapply) (take '($psi
) -
2) x
))
1891 (putprop '%log_gamma
(list (list 'x
) 'log-gamma-integral
) 'integral
)
1893 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1895 (defun simp-log-gamma (expr z simpflag
)
1897 (setq z
(simpcheck (cadr expr
) simpflag
))
1900 ;; Check for specific values
1904 (and (eq ($sign z
) '$neg
)
1905 (zerop1 (sub z
($truncate z
))))))
1906 ;; We have zero, a negative integer or a float or bigfloat representation.
1908 (intl:gettext
"log_gamma: log_gamma(~:M) is undefined.") z
))
1910 ((eq z
'$inf
) '$inf
)
1912 ;; Check for numerical evaluation
1914 ((float-numerical-eval-p z
)
1915 (complexify (log-gamma-lanczos (complex ($float z
) 0))))
1917 ((complex-float-numerical-eval-p z
)
1920 (complex ($float
($realpart z
)) ($float
($imagpart z
))))))
1922 ((bigfloat-numerical-eval-p z
)
1923 (bfloat-log-gamma ($bfloat z
)))
1925 ((complex-bigfloat-numerical-eval-p z
)
1926 (complex-bfloat-log-gamma
1927 (add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))
1929 ;; Transform to Logarithm of Factorial for integer values
1930 ;; At this point the integer value is positive and not zero.
1933 (simplify (list '(%log
) (simplify (list '(mfactorial) (- z
1))))))
1935 (t (eqtest (list '(%log_gamma
) z
) expr
))))
1937 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1938 ;;; The functions log-gamma-lanczos, bfloat-log-gamma and
1939 ;;; complex-bfloat-log-gamma are modified versions of the related functions
1940 ;;; gamma-lanczos, bffac and cbffac. The functions return the Logarithm of
1941 ;;; the Gamma function. If we have to calculate the quotient of Gamma functions,
1942 ;;; e. g. for the Beta function, it is much more appropriate to use the
1943 ;;; logarithmic versions to avoid overflow.
1945 ;;; Be careful log(gamma(z)) is only for realpart(z) positive equal to
1946 ;;; log_gamma(z). For a negative realpart(z) log_gamma differ by multiple of
1947 ;;; %pi from log(gamma(z)). But we always have exp(log_gamma(z))= gamma(z).
1948 ;;; The terms to get the transformation for log_gamma(-z) are taken from
1949 ;;; functions.wolfram.com.
1950 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1952 (defun log-gamma-lanczos (z)
1953 (declare (type (complex flonum
) z
)
1954 (optimize (safety 3)))
1955 (let ((c (make-array 15 :element-type
'flonum
1957 '(0.99999999999999709182
1958 57.156235665862923517
1959 -
59.597960355475491248
1960 14.136097974741747174
1961 -
0.49191381609762019978
1962 .33994649984811888699e-4
1963 .46523628927048575665e-4
1964 -
.98374475304879564677e-4
1965 .15808870322491248884e-3
1966 -
.21026444172410488319e-3
1967 .21743961811521264320e-3
1968 -
.16431810653676389022e-3
1969 .84418223983852743293e-4
1970 -
.26190838401581408670e-4
1971 .36899182659531622704e-5))))
1972 (declare (type (simple-array flonum
(15)) c
))
1973 (if (minusp (realpart z
))
1980 (abs (floor (realpart z
)))
1981 (- 1 (abs (signum (imagpart z
)))))
1984 (- (log (sin (* (float pi
) (- z
(floor (realpart z
)))))))
1988 (floor (realpart z
))
1989 (signum (imagpart z
))))
1990 (log-gamma-lanczos z
)))
1993 (zgh (+ zh
607/128))
1994 (lnzp (* (/ zh
2) (log zgh
)))
1997 (pp (1- (length c
)) (1- pp
)))
2000 (incf sum
(/ (aref c pp
) (+ z pp
))))))
2001 (+ (log (sqrt (float (* 2 pi
))))
2002 (log (+ ss
(aref c
0)))
2003 (+ (- zgh
) (* 2 lnzp
)))))))
2005 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2007 (defun bfloat-log-gamma (z)
2008 (let (($ratprint nil
)
2009 (bigfloat%pi
($bfloat
'$%pi
)))
2011 ((eq ($sign z
) '$neg
)
2012 (let ((z (mul -
1 z
)))
2015 (mul -
1 bigfloat%pi
'$%i
2016 (simplify (list '(mabs) (simplify (list '($floor
) ($realpart z
)))))
2019 (list '(mabs) (simplify (list '(%signum
) ($imagpart z
)))))))
2020 (simplify (list '(%log
) bigfloat%pi
))
2021 (mul -
1 (simplify (list '(%log
) (mul -
1 z
))))
2023 (simplify (list '(%log
)
2024 (simplify (list '(%sin
)
2027 (sub z
(simplify (list '($floor
) ($realpart z
))))))))))
2030 (simplify (list '($floor
) ($realpart z
)))
2031 (simplify (list '(%signum
) ($imagpart z
)))))
2032 (bfloat-log-gamma z
))))
2034 (let* ((k (* 2 (+ 1 ($entier
(* 0.41 $fpprec
)))))
2035 (m ($bfloat bigfloatone
))
2038 (x ($bfloat bigfloatzero
))
2040 (dotimes (i (/ k
2))
2041 (setq ii
(* 2 (+ i
1)))
2042 (setq m
(mul m
(add z ii -
2) (add z ii -
1)))
2045 (div (ftake '%bern
(+ k
(- ii
) 2))
2046 (* (+ k
(- ii
) 1) (+ k
(- ii
) 2))))
2049 (div (simplify (list '(%log
) (mul 2 bigfloat%pi z
+k
))) 2)
2050 (mul z
+k
(add (simplify (list '(%log
) z
+k
)) x -
1))
2051 (mul -
1 (simplify (list '(%log
) m
)))))))))
2053 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2055 (defun complex-bfloat-log-gamma (z)
2056 (let (($ratprint nil
)
2057 (bigfloat%pi
($bfloat
'$%pi
)))
2059 ((eq ($sign
($realpart z
)) '$neg
)
2060 (let ((z (mul -
1 z
)))
2063 (mul -
1 bigfloat%pi
'$%i
2064 (simplify (list '(mabs) (simplify (list '($floor
) ($realpart z
)))))
2067 (list '(mabs) (simplify (list '(%signum
) ($imagpart z
)))))))
2068 (simplify (list '(%log
) bigfloat%pi
))
2069 (mul -
1 (simplify (list '(%log
) (mul -
1 z
))))
2071 (simplify (list '(%log
)
2072 (simplify (list '(%sin
)
2075 (sub z
(simplify (list '($floor
) ($realpart z
))))))))))
2078 (simplify (list '($floor
) ($realpart z
)))
2079 (simplify (list '(%signum
) ($imagpart z
)))))
2080 (complex-bfloat-log-gamma z
))))
2082 (let* ((k (* 2 (+ 1 ($entier
(* 0.41 $fpprec
)))))
2083 (m ($bfloat bigfloatone
))
2085 (y ($rectform
(power z
+k
2)))
2086 (x ($bfloat bigfloatzero
))
2088 (dotimes (i (/ k
2))
2089 (setq ii
(* 2 (+ i
1)))
2090 (setq m
($rectform
(mul m
(add z ii -
2) (add z ii -
1))))
2094 (div (ftake '%bern
(+ k
(- ii
) 2))
2095 (* (+ k
(- ii
) 1) (+ k
(- ii
) 2))))
2099 (div (simplify (list '(%log
) (mul 2 bigfloat%pi z
+k
))) 2)
2100 (mul z
+k
(add (simplify (list '(%log
) z
+k
)) x -
1))
2101 (mul -
1 (simplify (list '(%log
) m
))))))))))
2103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2105 ;;; Implementation of the Error function Erf(z)
2107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2109 ;;; erf has mirror symmetry
2111 (defprop %erf t commutes-with-conjugate
)
2113 ;;; erf is an odd function
2115 (defprop %erf odd-function-reflect reflection-rule
)
2117 ;;; erf distributes over bags
2119 (defprop %erf
(mlist $matrix mequal
) distribute_over
)
2121 ;;; Derivative of the Error function erf
2126 ((mexpt) $%pi
((rat) -
1 2))
2127 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2)))))
2130 ;;; Integral of the Error function erf
2136 ((mexpt) $%pi
((rat) -
1 2))
2137 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2))))
2138 ((mtimes) z
((%erf
) z
))))
2141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2143 (defun erf-hypergeometric (z)
2144 ; See A&S 7.1.21 or http://functions.wolfram.com/06.25.26.0001.01
2147 (power '$%pi
'((rat simp
) -
1 2))
2148 (ftake '%hypergeometric
2151 (mul -
1 (power z
2)))))
2153 ;;; erf is a simplifying function
2155 (def-simplifier erf
(z)
2158 ;; Check for specific values
2164 ;; Check for numerical evaluation
2166 ((float-numerical-eval-p z
)
2167 (bigfloat::bf-erf
($float z
)))
2168 ((complex-float-numerical-eval-p z
)
2170 (bigfloat::bf-erf
(complex ($float
($realpart z
)) ($float
($imagpart z
))))))
2171 ((bigfloat-numerical-eval-p z
)
2172 (to (bigfloat::bf-erf
(bigfloat:to
($bfloat z
)))))
2173 ((complex-bigfloat-numerical-eval-p z
)
2174 (to (bigfloat::bf-erf
2175 (bigfloat:to
(add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))))
2177 ;; Argument simplification
2179 ((taylorize (mop form
) (second form
)))
2181 (not $erf_representation
)
2183 (mul '$%i
(simplify (list '(%erfi
) (coeff z
'$%i
1)))))
2184 ((apply-reflection-simp (mop form
) z $trigsign
))
2186 ;; Representation through more general functions
2188 ($hypergeometric_representation
2189 (erf-hypergeometric z
))
2191 ;; Transformation to Erfc or Erfi
2193 ((and $erf_representation
2194 (not (eq $erf_representation
'$erf
)))
2195 (case $erf_representation
2197 (sub 1 (take '(%erfc
) z
)))
2199 (mul -
1 '$%i
(take '(%erfi
) (mul '$%i z
))))
2206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2209 ;; We use the slatec routine for float values.
2210 (slatec:derf
(float z
)))
2212 ;; Compute erf(z) using the relationship
2214 ;; erf(z) = sqrt(z^2)/z*(1 - gamma_incomplete(1/2,z^2)/sqrt(%pi))
2216 ;; When z is real sqrt(z^2)/z is signum(z). For complex z,
2217 ;; sqrt(z^2)/z = 1 if -%pi/2 < arg(z) <= %pi/2 and -1 otherwise.
2219 ;; This relationship has serious round-off issues when z is small
2220 ;; because gamma_incomplete(1/2,z^2)/sqrt(%pi) is near 1.
2222 ;; complex-erf is for (lisp) complex numbers; bfloat-erf is for real
2223 ;; bfloats, and complex-bfloat-erf is for complex bfloats. Care is
2224 ;; taken to return real results for real arguments and imaginary
2225 ;; results for imaginary arguments
2226 (defun complex-erf (z)
2229 (if (or (< (realpart z
) 0.0) (and (= (realpart z
) 0.0) (< (imagpart z
) 0.0)))
2233 (* (/ (sqrt (float pi
))) (gamma-incomplete 0.5 (* z z
)))))))
2235 ((= (imagpart z
) 0.0)
2236 ;; Pure real argument, the result is real
2237 (complex (realpart result
) 0.0))
2238 ((= (realpart z
) 0.0)
2239 ;; Pure imaginary argument, the result is pure imaginary
2240 (complex 0.0 (imagpart result
)))
2244 (defun bfloat-erf (z)
2245 ;; Warning! This has round-off problems when abs(z) is very small.
2246 (let ((1//2 ($bfloat
'((rat simp
) 1 2))))
2247 ;; The argument is real, the result is real too
2250 (simplify (list '(%signum
) z
))
2253 (div 1 (power ($bfloat
'$%pi
) 1//2))
2254 (bfloat-gamma-incomplete 1//2 ($bfloat
(power z
2)))))))))
2256 (defun complex-bfloat-erf (z)
2257 ;; Warning! This has round-off problems when abs(z) is very small.
2258 (let* (($ratprint nil
)
2259 (1//2 ($bfloat
'((rat simp
) 1 2)))
2262 (cdiv (cpower (cpower z
2) 1//2) z
)
2265 (div 1 (power ($bfloat
'$%pi
) 1//2))
2266 (complex-bfloat-gamma-incomplete
2268 ($bfloat
(cpower z
2))))))))
2270 ((zerop1 ($imagpart z
))
2271 ;; Pure real argument, the result is real
2273 ((zerop1 ($realpart z
))
2274 ;; Pure imaginary argument, the result is pure imaginary
2275 (mul '$%i
($imagpart result
)))
2277 ;; A general complex result
2280 (in-package :bigfloat
)
2282 ;; Erf(z) for all z. Z must be a CL real or complex number or a
2283 ;; BIGFLOAT or COMPLEX-BIGFLOAT object. The result will be of the
2286 (cond ((typep z
'cl
:real
)
2287 ;; Use Slatec derf, which should be faster than the series.
2289 ((<= (abs z
) 0.476936)
2290 ;; Use the series A&S 7.1.5 for small x:
2292 ;; erf(z) = 2*z/sqrt(%pi) * sum((-1)^n*z^(2*n)/n!/(2*n+1), n, 0, inf)
2294 ;; The threshold is approximately erf(x) = 0.5. (Doesn't
2295 ;; have to be super accurate.) This gives max accuracy when
2296 ;; using the identity erf(x) = 1 - erfc(x).
2297 (let ((z^
2 (* z z
)))
2298 (/ (* 2 z
(sum-power-series z^
2
2306 ;; The general case.
2308 (cl:real
(maxima::erf z
))
2309 (cl:complex
(maxima::complex-erf z
))
2311 (bigfloat (maxima::$bfloat
(maxima::$expand
(maxima::bfloat-erf
(maxima::to z
))))))
2313 (bigfloat (maxima::$bfloat
(maxima::$expand
(maxima::complex-bfloat-erf
(maxima::to z
))))))))))
2316 ;; Compute erfc(z) via 1 - erf(z) is not very accurate if erf(z) is
2317 ;; near 1. Wolfram says
2319 ;; erfc(z) = 1 - sqrt(z^2)/z * (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2, z^2))
2321 ;; For real(z) > 0, sqrt(z^2)/z is 1 so
2323 ;; erfc(z) = 1 - (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2324 ;; = 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2)
2326 ;; For real(z) < 0, sqrt(z^2)/z is -1 so
2328 ;; erfc(z) = 1 + (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2329 ;; = 2 - 1/sqrt(pi)*gamma_incomplete(1/2,z^2)
2330 (flet ((gamma-inc (z)
2333 (maxima::gamma-incomplete
0.5 z
))
2335 (bigfloat:to
(maxima::$bfloat
2336 (maxima::bfloat-gamma-incomplete
(maxima::$bfloat maxima
::1//2)
2339 (bigfloat:to
(maxima::$bfloat
2340 (maxima::complex-bfloat-gamma-incomplete
(maxima::$bfloat maxima
::1//2)
2341 (maxima::to z
))))))))
2342 (if (>= (realpart z
) 0)
2343 (/ (gamma-inc (* z z
))
2346 (/ (gamma-inc (* z z
))
2349 (in-package :maxima
)
2351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2353 ;;; Implementation of the Generalized Error function Erf(z1,z2)
2355 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2357 ;;; Generalized Erf has mirror symmetry
2359 (defprop %erf_generalized t commutes-with-conjugate
)
2361 ;;; Generalized Erf distributes over bags
2363 (defprop %erf_generalized
(mlist $matrix mequal
) distribute_over
)
2365 ;;; Generalized Erf is antisymmetric Erf(z1,z2) = - Erf(z2,z1)
2368 (:load-toplevel
:execute
)
2369 (let (($context
'$global
) (context '$global
))
2370 (meval '(($declare
) %erf_generalized $antisymmetric
))
2371 ;; Let's remove built-in symbols from list for user-defined properties.
2372 (setq $props
(remove '%erf_generalized $props
))))
2374 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2376 (defprop %erf_generalized
2378 ;; derivative wrt z1
2380 ((mexpt) $%pi
((rat) -
1 2))
2381 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z1
2))))
2382 ;; derivative wrt z2
2384 ((mexpt) $%pi
((rat) -
1 2))
2385 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z2
2)))))
2388 ;;; ----------------------------------------------------------------------------
2390 (defprop %erf_generalized simplim%erf_generalized simplim%function
)
2392 (defun simplim%erf_generalized
(expr var val
)
2393 ;; Look for the limit of the arguments.
2394 (let ((z1 (limit (cadr expr
) var val
'think
))
2395 (z2 (limit (caddr expr
) var val
'think
)))
2397 ;; Handle infinities at this place.
2399 (alike1 z2
'((mtimes) -
1 $minf
)))
2400 (sub 1 (take '(%erf
) z1
)))
2402 (alike1 z2
'((mtimes) -
1 $inf
)))
2403 (sub (mul -
1 (take '(%erf
) z1
)) 1))
2405 (alike1 z1
'((mtimes) -
1 $minf
)))
2406 (sub (take '(%erf
) z2
) 1))
2408 (alike1 z1
'((mtimes) -
1 $inf
)))
2409 (add (take '(%erf
) z2
) 1))
2411 ;; All other cases are handled by the simplifier of the function.
2412 (simplify (list '(%erf_generalized
) z1 z2
))))))
2414 ;;; ----------------------------------------------------------------------------
2416 (def-simplifier erf_generalized
(z1 z2
)
2419 ;; Check for specific values
2421 ((and (zerop1 z1
) (zerop1 z2
)) 0)
2422 ((zerop1 z1
) (take '(%erf
) z2
))
2423 ((zerop1 z2
) (mul -
1 (take '(%erf
) z1
)))
2425 (alike1 z2
'((mtimes) -
1 $minf
)))
2426 (sub 1 (take '(%erf
) z1
)))
2428 (alike1 z2
'((mtimes) -
1 $inf
)))
2429 (sub (mul -
1 (take '(%erf
) z1
)) 1))
2431 (alike1 z1
'((mtimes) -
1 $minf
)))
2432 (sub (take '(%erf
) z2
) 1))
2434 (alike1 z1
'((mtimes) -
1 $inf
)))
2435 (add (take '(%erf
) z2
) 1))
2437 ;; Check for numerical evaluation. Use erf(z1,z2) = erf(z2)-erf(z1)
2439 ((float-numerical-eval-p z1 z2
)
2440 (- (bigfloat::bf-erf
($float z2
))
2441 (bigfloat::bf-erf
($float z1
))))
2442 ((complex-float-numerical-eval-p z1 z2
)
2446 (complex ($float
($realpart z2
)) ($float
($imagpart z2
))))
2448 (complex ($float
($realpart z1
)) ($float
($imagpart z1
)))))))
2449 ((bigfloat-numerical-eval-p z1 z2
)
2451 (bigfloat::bf-erf
(bigfloat:to
($bfloat z2
)))
2452 (bigfloat::bf-erf
(bigfloat:to
($bfloat z1
))))))
2453 ((complex-bigfloat-numerical-eval-p z1 z2
)
2456 (bigfloat:to
(add ($bfloat
($realpart z2
)) (mul '$%i
($bfloat
($imagpart z2
))))))
2458 (bigfloat:to
(add ($bfloat
($realpart z1
)) (mul '$%i
($bfloat
($imagpart z1
)))))))))
2460 ;; Argument simplification
2462 ((and $trigsign
(great (mul -
1 z1
) z1
) (great (mul -
1 z2
) z2
))
2463 (mul -
1 (simplify (list '(%erf_generalized
) (mul -
1 z1
) (mul -
1 z2
)))))
2465 ;; Representation through more general functions
2467 ($hypergeometric_representation
2468 (sub (erf-hypergeometric z2
) (erf-hypergeometric z1
)))
2470 ;; Transformation to Erf
2472 ($erf_representation
2473 (sub (simplify (list '(%erf
) z2
)) (simplify (list '(%erf
) z1
))))
2478 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2480 ;;; Implementation of the Complementary Error function Erfc(z)
2482 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2484 (defprop %erfc t commutes-with-conjugate
)
2486 ;;; Complementary Error function distributes over bags
2488 (defprop %erfc
(mlist $matrix mequal
) distribute_over
)
2490 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2495 ((mexpt) $%pi
((rat) -
1 2))
2496 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2)))))
2499 ;;; Integral of the Error function erfc
2505 ((mexpt) $%pi
((rat) -
1 2))
2506 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2))))
2507 ((mtimes) z
((%erfc
) z
))))
2510 ;;; ----------------------------------------------------------------------------
2512 (defprop %erfc simplim%erfc simplim%function
)
2514 (defun simplim%erfc
(expr var val
)
2515 ;; Look for the limit of the arguments.
2516 (let ((z (limit (cadr expr
) var val
'think
)))
2518 ;; Handle infinities at this place.
2521 ((eq z
'$infinity
) ;; parallel to code in simplim%erf-%tanh
2522 (destructuring-let (((rpart . ipart
) (trisplit (cadr expr
)))
2524 (setq rlim
(limit rpart var val
'think
))
2526 (limit (m* rpart
(m^t ipart -
1)) var val
'think
))
2527 (setq ans
($asksign
(m+ `((mabs) ,ans
) -
1)))
2528 (cond ((or (eq ans
'$pos
) (eq ans
'$zero
))
2529 (cond ((eq rlim
'$inf
) 0)
2530 ((eq rlim
'$minf
) 2)
2533 ((eq z
'$ind
) '$ind
)
2535 ;; All other cases are handled by the simplifier of the function.
2536 (simplify (list '(%erfc
) z
))))))
2538 ;;; ----------------------------------------------------------------------------
2540 (def-simplifier erfc
(z)
2543 ;; Check for specific values
2549 ;; Check for numerical evaluation.
2551 ((numerical-eval-p z
)
2552 (to (bigfloat::bf-erfc
(bigfloat:to z
))))
2554 ;; Argument simplification
2556 ((taylorize (mop form
) (second form
)))
2557 ((and $trigsign
(great (mul -
1 z
) z
))
2558 (sub 2 (simplify (list '(%erfc
) (mul -
1 z
)))))
2560 ;; Representation through more general functions
2562 ($hypergeometric_representation
2563 (sub 1 (erf-hypergeometric z
)))
2565 ;; Transformation to Erf or Erfi
2567 ((and $erf_representation
2568 (not (eq $erf_representation
'$erfc
)))
2569 (case $erf_representation
2571 (sub 1 (take '(%erf
) z
)))
2573 (add 1 (mul '$%i
(take '(%erfi
) (mul '$%i z
)))))
2580 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2582 ;;; Implementation of the Imaginary Error function Erfi(z)
2584 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2586 ;;; erfi has mirror symmetry
2588 (defprop %erfi t commutes-with-conjugate
)
2590 ;;; erfi is an odd function
2592 (defprop %erfi odd-function-reflect reflection-rule
)
2594 ;;; erfi distributes over bags
2596 (defprop %erfi
(mlist $matrix mequal
) distribute_over
)
2598 ;;; Derivative of the Error function erfi
2603 ((mexpt) $%pi
((rat) -
1 2))
2604 ((mexpt) $%e
((mexpt) z
2))))
2607 ;;; Integral of the Error function erfi
2613 ((mexpt) $%pi
((rat) -
1 2))
2614 ((mexpt) $%e
((mexpt) z
2)))
2615 ((mtimes) z
((%erfi
) z
))))
2618 ;;; ----------------------------------------------------------------------------
2620 (defprop %erfi simplim%erfi simplim%function
)
2622 (defun simplim%erfi
(expr var val
)
2623 ;; Look for the limit of the arguments.
2624 (let ((z (limit (cadr expr
) var val
'think
)))
2626 ;; Handle extended reals
2627 ((eq z
'$inf
) '$inf
)
2628 ((eq z
'$minf
) '$minf
)
2629 ((eq z
'$und
) '$und
)
2630 ((eq z
'$ind
) '$ind
)
2631 ((or (eq z
'$zerob
) (eq z
'$zeroa
)) z
)
2632 ((eq z
'$infinity
) '$und
)
2634 ;; All other cases are handled by the simplifier of the function.
2635 (ftake '%erfi z
)))))
2637 ;;; ----------------------------------------------------------------------------
2639 (in-package :bigfloat
)
2642 ;; Use the relationship erfi(z) = -%i*erf(%i*z)
2643 (let* ((iz (complex (- (imagpart z
)) (realpart z
))) ; %i*z
2644 (result (bf-erf iz
)))
2645 (complex (imagpart result
) (- (realpart result
))))))
2646 ;; Take care to return real results when the argument is real.
2650 (realpart (erfi z
)))
2653 (in-package :maxima
)
2655 ;;; erfi is an simplifying function
2657 (def-simplifier erfi
(z)
2660 ;; Check for specific values
2663 ((eq z
'$inf
) '$inf
)
2664 ((eq z
'$minf
) '$minf
)
2666 ;; Check for numerical evaluation. Use erfi(z) = -%i*erf(%i*z).
2668 ((numerical-eval-p z
)
2669 (to (bigfloat::bf-erfi
(bigfloat:to z
))))
2671 ;; Argument simplification
2673 ((taylorize (mop form
) (second form
)))
2676 (mul '$%i
(simplify (list '(%erf
) (coeff z
'$%i
1)))))
2677 ((apply-reflection-simp (mop form
) z $trigsign
))
2679 ;; Representation through more general functions
2681 ($hypergeometric_representation
2682 (mul -
1 '$%i
(erf-hypergeometric (mul '$%i z
))))
2684 ;; Transformation to Erf or Erfc
2686 ((and $erf_representation
2687 (not (eq $erf_representation
'$erfi
)))
2688 (case $erf_representation
2690 (mul -
1 '$%i
(take '(%erf
) (mul '$%i z
))))
2692 (sub (mul '$%i
(take '(%erfc
) (mul '$%i z
))) '$%i
))
2699 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2701 ;;; The implementation of the Inverse Error function
2703 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2705 ;;; The Inverse Error function distributes over bags
2707 (defprop %inverse_erf
(mlist $matrix mequal
) distribute_over
)
2709 ;;; inverse_erf is the inverse of the erf function
2711 (defprop %inverse_erf %erf $inverse
)
2712 (defprop %erf %inverse_erf $inverse
)
2714 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2716 ;;; Differentiation of the Inverse Error function
2718 (defprop %inverse_erf
2722 ((mexpt) $%pi
((rat) 1 2))
2723 ((mexpt) $%e
((mexpt) ((%inverse_erf
) z
) 2))))
2726 ;;; Integral of the Inverse Error function
2728 (defprop %inverse_erf
2731 ((mexpt) $%pi
((rat) -
1 2))
2732 ((mexpt) $%e
((mtimes) -
1 ((mexpt) ((%inverse_erf
) z
) 2)))))
2735 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2737 ;;; We support a simplim%function. The function is looked up in simplimit and
2738 ;;; handles specific values of the function.
2740 (defprop %inverse_erf simplim%inverse_erf simplim%function
)
2742 (defun simplim%inverse_erf
(expr var val
)
2743 ;; Look for the limit of the argument.
2744 (let ((z (limit (cadr expr
) var val
'think
)))
2746 ;; Handle an argument 1 at this place
2748 ((onep1 (mul -
1 z
)) '$minf
)
2750 ;; All other cases are handled by the simplifier of the function.
2751 (simplify (list '(%inverse_erf
) z
))))))
2753 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2755 ;;; The Inverse Error function is a simplifying function
2757 (def-simplifier inverse_erf
(z)
2762 (intl:gettext
"inverse_erf: inverse_erf(~:M) is undefined.") z
))
2764 ((numerical-eval-p z
)
2765 (to (bigfloat::bf-inverse-erf
(bigfloat:to z
))))
2766 ((taylorize (mop form
) (cadr form
)))
2770 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2772 ;;; The implementation of the Inverse Complementary Error function
2774 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2776 ;;; Inverse Complementary Error function distributes over bags
2778 (defprop %inverse_erfc
(mlist $matrix mequal
) distribute_over
)
2780 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2782 ;;; inverse_erfc is the inverse of the erfc function
2784 (defprop %inverse_erfc %erfc $inverse
)
2785 (defprop %erfc %inverse_erfc $inverse
)
2788 ;;; Differentiation of the Inverse Complementary Error function
2790 (defprop %inverse_erfc
2794 ((mexpt) $%pi
((rat) 1 2))
2795 ((mexpt) $%e
((mexpt) ((%inverse_erfc
) z
) 2))))
2798 ;;; Integral of the Inverse Complementary Error function
2800 (defprop %inverse_erfc
2803 ((mexpt) $%pi
((rat) -
1 2))
2805 ((mtimes) -
1 ((mexpt) ((%inverse_erfc
) z
) 2)))))
2808 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2810 ;;; We support a simplim%function. The function is looked up in simplimit and
2811 ;;; handles specific values of the function.
2813 (defprop %inverse_erfc simplim%inverse_erfc simplim%function
)
2815 (defun simplim%inverse_erfc
(expr var val
)
2816 ;; Look for the limit of the argument.
2817 (let ((z (limit (cadr expr
) var val
'think
)))
2819 ;; Handle an argument 0 at this place
2824 ((zerop1 (add z -
2)) '$minf
)
2826 ;; All other cases are handled by the simplifier of the function.
2827 (simplify (list '(%inverse_erfc
) z
))))))
2829 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2831 ;;; Inverse Complementary Error function is a simplifying function
2832 (def-simplifier inverse_erfc
(z)
2835 (zerop1 (add z -
2)))
2837 (intl:gettext
"inverse_erfc: inverse_erfc(~:M) is undefined.") z
))
2839 ((numerical-eval-p z
)
2840 (to (bigfloat::bf-inverse-erfc
(bigfloat:to z
))))
2841 ((taylorize (mop form
) (cadr form
)))
2845 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2847 ;;; Implementation of the Newton algorithm to calculate numerical values
2848 ;;; of the Inverse Error functions in float or bigfloat precision.
2849 ;;; The algorithm is a modified version of the routine in newton1.mac.
2851 (defvar *debug-newton
* nil
)
2852 (defvar *newton-maxcount
* 1000)
2853 (defvar *newton-epsilon-factor
* 50)
2854 (defvar *newton-epsilon-factor-float
* 10)
2856 (defun float-newton (expr var x0 eps
)
2857 (do ((s (sdiff expr var
))
2860 (count 0 (+ count
1)))
2861 ((> count
*newton-maxcount
*)
2863 (intl:gettext
"float-newton: Newton does not converge for ~:M") expr
))
2864 (setq sn
($float
(maxima-substitute xn var expr
)))
2865 (when (< (abs sn
) eps
) (return xn
))
2866 (when *debug-newton
* (format t
"~&xn = ~A~%" xn
))
2867 (setq xn
($float
(sub xn
(div sn
(maxima-substitute xn var s
)))))))
2869 (defun bfloat-newton (expr var x0 eps
)
2870 (do ((s (sdiff expr var
))
2873 (count 0 (+ count
1)))
2874 ((> count
*newton-maxcount
*)
2876 (intl:gettext
"bfloat-newton: Newton does not converge for ~:M") expr
))
2877 (setq sn
($bfloat
(maxima-substitute xn var expr
)))
2878 (when (eq ($sign
(sub (simplify (list '(mabs) sn
)) eps
)) '$neg
)
2880 (when *debug-newton
* (format t
"~&xn = ~A~%" xn
))
2881 (setq xn
($bfloat
(sub xn
(div sn
(maxima-substitute xn var s
)))))))
2884 (in-package :bigfloat
)
2886 ;; Compute inverse_erf(z) for z a real or complex number, including
2887 ;; bigfloat objects. The value is computing using a Newton iteration
2888 ;; to solve erf(x) = z.
2889 (defun bf-inverse-erf (z)
2894 (intl:gettext
"bf-inverse-erf: inverse_erf(~M) is undefined")
2896 ((minusp (realpart z
))
2897 ;; inverse_erf is odd because erf is.
2898 (- (bf-inverse-erf (- z
))))
2902 ;; Find an approximate solution for x = inverse_erf(z).
2904 (cond ((<= (abs z
) 1)
2905 ;; For small z, inverse_erf(z) = z*sqrt(%pi)/2
2906 ;; + O(z^3). Thus, x = z*sqrt(%pi)/2 is our
2907 ;; initial starting point.
2908 (* z
(sqrt (%pi z
)) 1/2))
2910 ;; For |z| > 1 and realpart(z) >= 0, we have
2911 ;; the asymptotic series z = erf(x) = 1 -
2912 ;; exp(-x^2)/x/sqrt(%pi).
2915 ;; x = sqrt(-log(x*sqrt(%pi)*(1-z))
2917 ;; We can use this as a fixed-point iteration
2918 ;; to find x, and we can start the iteration at
2919 ;; x = 1. Just do one more iteration. I (RLT)
2920 ;; think that's close enough to get the Newton
2921 ;; algorithm to converge.
2922 (let* ((sp (sqrt (%pi z
)))
2923 (a (sqrt (- (log (* sp
(- 1 z
)))))))
2924 (setf a
(sqrt (- (log (* a sp
(- 1 z
))))))
2925 (setf a
(sqrt (- (log (* a sp
(- 1 z
)))))))))))
2926 (when maxima
::*debug-newton
*
2927 (format t
"approx = ~S~%" result
))
2929 (let ((two/sqrt-pi
(/ 2 (sqrt (%pi z
))))
2931 ;; Try to pick a reasonable epsilon value for the
2932 ;; Newton iteration.
2933 (cond ((<= (abs z
) 1)
2935 (cl:real
(* maxima
::*newton-epsilon-factor-float
*
2936 maxima
::+flonum-epsilon
+))
2937 (t (* maxima
::*newton-epsilon-factor
* (epsilon z
)))))
2939 (* maxima
::*newton-epsilon-factor
* (epsilon z
))))))
2940 (when maxima
::*debug-newton
*
2941 (format t
"eps = ~S~%" eps
))
2943 ;; Derivative of erf(x)
2944 (* two
/sqrt-pi
(exp (- (* x x
))))))
2951 (defun bf-inverse-erfc (z)
2954 (intl:gettext
"bf-inverse-erfc: inverse_erfc(~M) is undefined")
2961 ;; Find an approximate solution for x =
2962 ;; inverse_erfc(z). We have inverse_erfc(z) =
2963 ;; inverse_erf(1-z), so that's a good starting point.
2964 ;; We don't need full precision, so a float value is
2965 ;; good enough. But if 1-z is 1, inverse_erf is
2966 ;; undefined, so we need to do something else.
2968 (let ((1-z (float (- 1 z
) 0.0)))
2970 (if (minusp (realpart z
))
2971 (bf-inverse-erf (+ 1 (* 5 maxima
::+flonum-epsilon
+)))
2972 (bf-inverse-erf (- 1 (* 5 maxima
::+flonum-epsilon
+)))))
2974 (bf-inverse-erf 1-z
))))))
2975 (when maxima
::*debug-newton
*
2976 (format t
"approx = ~S~%" result
))
2978 (let ((-two/sqrt-pi
(/ -
2 (sqrt (%pi z
))))
2979 (eps (* maxima
::*newton-epsilon-factor
* (epsilon z
))))
2980 (when maxima
::*debug-newton
*
2981 (format t
"eps = ~S~%" eps
))
2983 ;; Derivative of erfc(x)
2984 (* -two
/sqrt-pi
(exp (- (* x x
))))))
2985 (bf-newton #'bf-erfc
2991 ;; Newton iteration for solving f(x) = z, given f and the derivative
2993 (defun bf-newton (f df z start eps
)
2995 (delta (/ (- (funcall f start
) z
)
2997 (/ (- (funcall f x
) z
)
2999 (count 0 (1+ count
)))
3000 ((or (< (abs delta
) (* (abs x
) eps
))
3001 (> count maxima
::*newton-maxcount
*))
3002 (if (> count maxima
::*newton-maxcount
*)
3004 (intl:gettext
"bf-newton: failed to converge after ~M iterations: delta = ~S, x = ~S eps = ~S")
3007 (when maxima
::*debug-newton
*
3008 (format t
"x = ~S, abs(delta) = ~S relerr = ~S~%"
3009 x
(abs delta
) (/ (abs delta
) (abs x
))))
3010 (setf x
(- x delta
))))
3012 (in-package :maxima
)
3014 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3016 ;;; Implementation of the Fresnel Integral S(z)
3018 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3020 ;;; fresnel_s distributes over bags
3022 (defprop %fresnel_s
(mlist $matrix mequal
) distribute_over
)
3024 ;;; fresnel_s has mirror symmetry
3026 (defprop %fresnel_s t commutes-with-conjugate
)
3028 ;;; fresnel_s is an odd function
3030 ;;; Maxima has two mechanism to define a reflection property
3031 ;;; 1. Declare the feature oddfun or evenfun
3032 ;;; 2. Put a reflection rule on the property list
3034 ;;; The second way is used for the trig functions. We use it here too.
3036 ;;; This would be the first way to give the property of an odd function.
3038 ; (:load-toplevel :execute)
3039 ; (let (($context '$global) (context '$global))
3040 ; (meval '(($declare) %fresnel_s $oddfun))
3041 ; ;; Let's remove built-in symbols from list for user-defined properties.
3042 ; (setq $props (remove '%fresnel_s $props))))
3044 (defprop %fresnel_s odd-function-reflect reflection-rule
)
3046 ;;; Differentiation of the Fresnel Integral S
3050 ((%sin
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))
3053 ;;; Integration of the Fresnel Integral S
3058 ((mtimes) z
((%fresnel_s
) z
))
3061 ((%cos
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))))
3064 ;;; Limits of the Fresnel Integral S
3066 (defprop %fresnel_s simplim%fresnel_s simplim%function
)
3067 (defun simplim%fresnel_s
(exp var val
)
3068 (let ((arg (limit (cadr exp
) var val
'think
)))
3069 (cond ((eq arg
'$inf
)
3074 `((%fresnel_s
) ,arg
)))))
3076 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3078 (defvar *fresnel-maxit
* 1000)
3079 (defvar *fresnel-eps
* (* 2 +flonum-epsilon
+))
3080 (defvar *fresnel-min
* 1e-32)
3082 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3083 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3085 (in-package :bigfloat
)
3087 (defun bf-fresnel (z)
3088 (let* ((eps (epsilon z
))
3089 (maxit maxima
::*fresnel-maxit
*)
3092 ;; For very small x, we have
3093 ;; fresnel_s(x) = %pi/6*z^3
3095 (s (* (/ bf-pi
6) z z z
))
3097 (when (> (abs z
) eps
)
3100 (when maxima
::*debug-gamma
*
3101 (format t
"~& in FRESNEL series expansion.~%"))
3102 (let ((sums 0) (sumc z
))
3105 (fact (* (/ bf-pi
2) (* z z
)))
3112 (maxima::merror
(intl:gettext
"fresnel: series expansion failed for (COMPLEX-BFLOAT-FRESNEL ~:M).") z
))
3113 (setq term
(* term
(/ fact k
)))
3114 (setq sum
(+ sum
(/ (* sign term
) n
)))
3115 (setq test
(* (abs sum
) eps
))
3118 (setq sign
(- sign
))
3124 (if (< (abs term
) test
)
3129 (let* ((sqrt-pi (sqrt bf-pi
))
3130 (z+ (* (complex 1/2 1/2)
3133 (z- (* (complex 1/2 -
1/2)
3138 (setq s
(* (complex 1/4 1/4)
3139 (+ erf
+ (* (complex 0 -
1) erf-
))))
3140 (setq c
(* (complex 1/4 -
1/4)
3141 (+ erf
+ (* (complex 0 1) erf-
))))))))
3144 (defun bf-fresnel-s (z)
3145 (if (and (complexp z
) (zerop (realpart z
)))
3146 ;; A pure imaginary argument. Use fresnel_s(%i*x)=-%i*fresnel_s(x).
3148 (- (bf-fresnel-s (imagpart z
))))
3149 (let ((fs (bf-fresnel z
)))
3154 (defun bf-fresnel-c (z)
3155 (if (and (complexp z
) (zerop (realpart z
)))
3156 ;; A pure imaginary argument. Use fresnel_c(%i*x)=%i*fresnel_c(x).
3158 (bf-fresnel-c (imagpart z
)))
3159 (let ((fc (nth-value 1 (bf-fresnel z
))))
3164 (in-package :maxima
)
3166 ;;; fresnel_s is a simplifying function
3167 (def-simplifier fresnel_s
(z)
3170 ;; Check for specific values
3173 ((eq z
'$inf
) '((rat simp
) 1 2))
3174 ((eq z
'$minf
) '((rat simp
) -
1 2))
3176 ;; Check for numerical evaluation
3177 ((numerical-eval-p z
)
3178 (to (bigfloat::bf-fresnel-s
(bigfloat::to z
))))
3180 ;; Check for argument simplification
3182 ((taylorize (mop form
) (second form
)))
3183 ((and $%iargs
(multiplep z
'$%i
))
3184 (mul -
1 '$%i
(simplify (list '(%fresnel_s
) (coeff z
'$%i
1)))))
3185 ((apply-reflection-simp (mop form
) z $trigsign
))
3187 ;; Representation through equivalent functions
3189 ($erf_representation
3191 (div (add 1 '$%i
) 4)
3196 (mul (div (add 1 '$%i
) 2) (power '$%pi
'((rat simp
) 1 2)) z
)))
3201 (mul (div (sub 1 '$%i
) 2)
3202 (power '$%pi
'((rat simp
) 1 2)) z
)))))))
3204 ($hypergeometric_representation
3205 (mul (div (mul '$%pi
(power z
3)) 6)
3206 (ftake '%hypergeometric
3207 (list '(mlist) (div 3 4))
3208 (list '(mlist) (div 3 2) (div 7 4))
3209 (mul -
1 (div (mul (power '$%pi
2) (power z
4)) 16)))))
3213 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3215 ;;; Implementation of the Fresnel Integral C(z)
3217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3219 ;;; fresnel_c distributes over bags
3221 (defprop %fresnel_c
(mlist $matrix mequal
) distribute_over
)
3223 ;;; fresnel_c has mirror symmetry
3225 (defprop %fresnel_c t commutes-with-conjugate
)
3227 ;;; fresnel_c is an odd function
3228 ;;; Maxima has two mechanism to define a reflection property
3229 ;;; 1. Declare the feature oddfun or evenfun
3230 ;;; 2. Put a reflection rule on the property list
3232 ;;; The second way is used for the trig functions. We use it here too.
3234 (defprop %fresnel_c odd-function-reflect reflection-rule
)
3236 ;;; Differentiation of the Fresnel Integral C
3240 ((%cos
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))
3243 ;;; Integration of the Fresnel Integral C
3248 ((mtimes) z
((%fresnel_c
) z
))
3251 ((%sin
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))))
3254 ;;; Limits of the Fresnel Integral C
3256 (defprop %fresnel_c simplim%fresnel_c simplim%function
)
3257 (defun simplim%fresnel_c
(exp var val
)
3258 (let ((arg (limit (cadr exp
) var val
'think
)))
3259 (cond ((eq arg
'$inf
)
3264 `((%fresnel_c
) ,arg
)))))
3266 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3268 ;;; fresnel_c is a simplifying function
3269 (def-simplifier fresnel_c
(z)
3272 ;; Check for specific values
3275 ((eq z
'$inf
) '((rat simp
) 1 2))
3276 ((eq z
'$minf
) '((rat simp
) -
1 2))
3278 ;; Check for numerical evaluation
3279 ((numerical-eval-p z
)
3280 (to (bigfloat::bf-fresnel-c
(bigfloat::to z
))))
3283 ;; Check for argument simplification
3285 ((taylorize (mop form
) (second form
)))
3286 ((and $%iargs
(multiplep z
'$%i
))
3287 (mul '$%i
(simplify (list '(%fresnel_c
) (coeff z
'$%i
1)))))
3288 ((apply-reflection-simp (mop form
) z $trigsign
))
3290 ;; Representation through equivalent functions
3292 ($erf_representation
3294 (div (sub 1 '$%i
) 4)
3299 (mul (div (add 1 '$%i
) 2) (power '$%pi
'((rat simp
) 1 2)) z
)))
3304 (mul (div (sub 1 '$%i
) 2)
3305 (power '$%pi
'((rat simp
) 1 2)) z
)))))))
3307 ($hypergeometric_representation
3309 (ftake '%hypergeometric
3310 (list '(mlist) (div 1 4))
3311 (list '(mlist) (div 1 2) (div 5 4))
3312 (mul -
1 (div (mul (power '$%pi
2) (power z
4)) 16)))))
3316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3318 ;;; Implementation of the Beta function
3320 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3322 ;;; The code for the implementation of the beta function is in the files
3323 ;;; csimp2.lisp, simp.lisp and mactex.lisp.
3324 ;;; At this place we only implement the operator property SYMMETRIC.
3326 ;;; Beta is symmetric beta(a,b) = beta(b,a)
3329 (:load-toplevel
:execute
)
3330 (let (($context
'$global
) (context '$global
))
3331 (meval '(($declare
) %beta $symmetric
))
3332 ;; Let's remove built-in symbols from list for user-defined properties.
3333 (setq $props
(remove '%beta $props
))))
3335 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3337 ;;; Implementation of the Incomplete Beta function
3339 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3341 (defvar *beta-incomplete-maxit
* 10000)
3342 (defvar *beta-incomplete-eps
* 1.0e-15)
3344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3346 ;;; beta_incomplete distributes over bags
3348 (defprop %beta_incomplete
(mlist $matrix mequal
) distribute_over
)
3350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3352 (defprop %beta_incomplete
3356 ((mtimes) ((%beta_incomplete
) a b z
) ((%log
) z
))
3358 ((mexpt) ((%gamma
) a
) 2)
3359 (($hypergeometric_regularized
)
3360 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3361 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3369 ((mqapply) (($psi array
) 0) b
)
3370 ((mtimes) -
1 ((mqapply) (($psi array
) 0) ((mplus) a b
)))))
3372 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z
)))
3373 ((%log
) ((mplus) 1 ((mtimes) -
1 z
))))
3375 ((mexpt) ((%gamma
) b
) 2)
3376 (($hypergeometric_regularized
)
3377 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3378 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3379 ((mplus) 1 ((mtimes) -
1 z
)))
3380 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) b
)))
3381 ;; The derivative wrt z
3383 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) ((mplus) -
1 b
))
3384 ((mexpt) z
((mplus) -
1 a
))))
3387 ;;; Integral of the Incomplete Beta function
3389 (defprop %beta_incomplete
3394 ((mtimes) -
1 ((%beta_incomplete
) ((mplus) 1 a
) b z
))
3395 ((mtimes) ((%beta_incomplete
) a b z
) z
)))
3398 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3400 (def-simplifier beta_incomplete
(a b z
)
3403 (format t
"~&SIMP-BETA-INCOMPLETE:~%")
3404 (format t
"~& : a = ~A~%" a
)
3405 (format t
"~& : b = ~A~%" b
)
3406 (format t
"~& : z = ~A~%" z
))
3409 ;; Check for specific values
3412 (let ((sgn ($sign
($realpart a
))))
3413 (cond ((member sgn
'($neg $zero
))
3416 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.")
3418 ((member sgn
'($pos $pz
))
3423 ((and (onep1 z
) (eq ($sign
($realpart b
)) '$pos
))
3424 ;; z=1 and realpart(b)>0. Simplify to a Beta function.
3425 ;; If we have to evaluate numerically preserve the type.
3427 ((complex-float-numerical-eval-p a b z
)
3428 (ftake* '%beta
($float a
) ($float b
)))
3429 ((complex-bigfloat-numerical-eval-p a b z
)
3430 (ftake* '%beta
($bfloat a
) ($bfloat b
)))
3432 (ftake* '%beta a b
))))
3435 (and (integer-representation-p a
)
3436 (eq ($sign a
) '$neg
)
3438 (not (integer-representation-p b
)))
3439 (eq ($sign
(add a b
)) '$pos
))))
3440 ;; The argument a is zero or a is negative and the argument b is
3441 ;; not in a valid range. Beta incomplete is undefined.
3442 ;; It would be more correct to return Complex infinity.
3445 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.") a b z
))
3447 ;; Check for numerical evaluation in Float or Bigfloat precision
3449 ((complex-float-numerical-eval-p a b z
)
3451 ((not (and (integer-representation-p a
) (< a
0.0)))
3452 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0))))
3453 (beta-incomplete ($float a
) ($float b
) ($float z
))))
3455 ;; Negative integer a and b is in a valid range. Expand.
3457 (beta-incomplete-expand-negative-integer
3458 (truncate a
) ($float b
) ($float z
))))))
3460 ((complex-bigfloat-numerical-eval-p a b z
)
3462 ((not (and (integer-representation-p a
) (eq ($sign a
) '$neg
)))
3463 (let ((*beta-incomplete-eps
*
3464 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
3465 (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z
))))
3467 ;; Negative integer a and b is in a valid range. Expand.
3469 (beta-incomplete-expand-negative-integer
3470 ($truncate a
) ($bfloat b
) ($bfloat z
))))))
3472 ;; Argument simplifications and transformations
3476 (or (not (integerp a
))
3478 ;; Expand for b a positive integer and a not a negative integer.
3482 (let ((index (gensumindex)))
3486 (simplify (list '($pochhammer
) a index
))
3487 (power (sub 1 z
) index
))
3488 (simplify (list '(mfactorial) index
)))
3489 index
0 (sub b
1)))))
3491 ((and (integerp a
) (plusp a
))
3492 ;; Expand for a a positive integer.
3498 (let ((index (gensumindex)))
3502 (simplify (list '($pochhammer
) b index
))
3504 (simplify (list '(mfactorial) index
)))
3505 index
0 (sub a
1)))))))
3507 ((and (integerp a
) (minusp a
) (integerp b
) (plusp b
) (<= b
(- a
)))
3508 ;; Expand for a a negative integer and b an integer with b <= -a.
3511 (let ((index (gensumindex)))
3514 (mul (simplify (list '($pochhammer
) (sub 1 b
) index
))
3517 (simplify (list '(mfactorial) index
))))
3518 index
0 (sub b
1)))))
3520 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
3522 (a (simplify (cons '(mplus) (cddr a
)))))
3526 (simplify (list '($pochhammer
) a n
))
3527 (simplify (list '($pochhammer
) (add a b
) n
)))
3528 (ftake '%beta_incomplete a b z
))
3530 (power (add a b n -
1) -
1)
3531 (let ((index (gensumindex)))
3535 (simplify (list '($pochhammer
)
3536 (add 1 (mul -
1 a
) (mul -
1 n
))
3538 (simplify (list '($pochhammer
)
3539 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
3541 (mul (power (sub 1 z
) b
)
3542 (power z
(add a n
(mul -
1 index
) -
1))))
3543 index
0 (sub n
1)))))))
3545 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
3546 (let ((n (- (cadr a
)))
3547 (a (simplify (cons '(mplus) (cddr a
)))))
3551 (simplify (list '($pochhammer
) (add 1 (mul -
1 a
) (mul -
1 b
)) n
))
3552 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3553 (ftake '%beta_incomplete a b z
))
3557 (list '($pochhammer
) (add 2 (mul -
1 a
) (mul -
1 b
)) (sub n
1)))
3558 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3559 (let ((index (gensumindex)))
3563 (simplify (list '($pochhammer
) (sub 1 a
) index
))
3564 (simplify (list '($pochhammer
)
3565 (add 2 (mul -
1 a
) (mul -
1 b
))
3567 (mul (power (sub 1 z
) b
)
3568 (power z
(add a
(mul -
1 index
) -
1))))
3569 index
0 (sub n
1)))))))
3571 ($hypergeometric_representation
3572 ;; There are several cases to consider.
3574 ;; For -a not an integer see
3575 ;; http://functions.wolfram.com/06.19.26.0005.01
3577 ;; beta_incomplete(a,b,z) = z^a/a*%f[2,1]([a,1-b],[a+1],z)
3579 ;; For -b not an integer see
3580 ;; http://functions.wolfram.com/06.19.26.0007.01
3582 ;; beta_incomplete(a,b,z) = beta(a,b) -
3583 ;; (1-z)^b*z^a/b*%f[2,1]([1,a+b],[b+1],1-z)
3585 ;; For a+b not a positive integer see
3586 ;; http://functions.wolfram.com/06.19.26.0008.01
3588 ;; beta_incomplete(a,b,z) =
3589 ;; z^a*(-z)^(b-1)/(a+b-1)*%f[2,1]([1-b,-a-b+1],[-a-b+2],1/z)
3590 ;; + z^a*beta(1-a-b,a)*(-z)^(-a)
3592 ;; We need to handle more cases here
3593 (mul (div (power z a
)
3595 (ftake '%hypergeometric
3596 (make-mlist a
(sub 1 b
))
3597 (make-mlist (add 1 a
))
3603 (defun beta-incomplete-expand-negative-integer (a b z
)
3606 (let ((index (gensumindex)) ($simpsum t
))
3609 (mul (simplify (list '($pochhammer
) (sub 1 b
) index
))
3611 (mul (add index a
) (simplify (list '(mfactorial) index
))))
3612 index
0 (sub b
1)))))
3614 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3616 (defun beta-incomplete (a b z
)
3618 ((eq ($sign
(sub (mul ($realpart z
) ($realpart
(add a b
2)))
3619 ($realpart
(add a
1))))
3624 (to (numeric-beta-incomplete b a
(sub 1.0 z
))))))
3626 (to (numeric-beta-incomplete a b z
)))))
3628 (defun numeric-beta-incomplete (a b z
)
3630 (format t
"~&NUMERIC-BETA-INCOMPLETE enters continued fractions~%"))
3631 (let ((a (bigfloat:to a
))
3633 (z (bigfloat:to z
)))
3634 (do* ((beta-maxit *beta-incomplete-maxit
*)
3635 (beta-eps *beta-incomplete-eps
*)
3636 (beta-min (bigfloat:* beta-eps beta-eps
))
3637 (ab (bigfloat:+ a b
))
3638 (ap (bigfloat:+ a
1.0))
3639 (am (bigfloat:- a
1.0))
3641 (d (bigfloat:-
1.0 (bigfloat:/ (bigfloat:* z ab
) ap
)))
3642 (d (if (bigfloat:< (bigfloat:abs d
) beta-min
) beta-min d
))
3643 (d (bigfloat:/ 1.0 d
))
3650 (merror (intl:gettext
"beta_incomplete: continued fractions failed for beta_incomplete(~:M, ~:M, ~:M).") a b z
))
3652 (setq aa
(bigfloat:/ (bigfloat:* m z
(bigfloat:- b m
))
3653 (bigfloat:* (bigfloat:+ am m2
)
3654 (bigfloat:+ a m2
))))
3655 (setq d
(bigfloat:+ 1.0 (bigfloat:* aa d
)))
3656 (when (bigfloat:< (bigfloat:abs d
) beta-min
) (setq d beta-min
))
3657 (setq c
(bigfloat:+ 1.0 (bigfloat:/ aa c
)))
3658 (when (bigfloat:< (bigfloat:abs c
) beta-min
) (setq c beta-min
))
3659 (setq d
(bigfloat:/ 1.0 d
))
3660 (setq h
(bigfloat:* h d c
))
3661 (setq aa
(bigfloat:/ (bigfloat:* -
1
3663 (bigfloat:+ ab m
) z
)
3664 (bigfloat:* (bigfloat:+ a m2
)
3665 (bigfloat:+ ap m2
))))
3666 (setq d
(bigfloat:+ 1.0 (bigfloat:* aa d
)))
3667 (when (bigfloat:< (bigfloat:abs d
) beta-min
) (setq d beta-min
))
3668 (setq c
(bigfloat:+ 1.0 (bigfloat:/ aa c
)))
3669 (when (bigfloat:< (bigfloat:abs c
) beta-min
) (setq c beta-min
))
3670 (setq d
(bigfloat:/ 1.0 d
))
3671 (setq de
(bigfloat:* d c
))
3672 (setq h
(bigfloat:* h de
))
3673 (when (bigfloat:< (bigfloat:abs
(bigfloat:- de
1.0)) beta-eps
)
3675 (format t
"~&Continued fractions finished.~%")
3676 (format t
"~& z = ~A~%" z
)
3677 (format t
"~& a = ~A~%" a
)
3678 (format t
"~& b = ~A~%" b
)
3679 (format t
"~& h = ~A~%" h
))
3685 (bigfloat:expt
(bigfloat:-
1.0 z
) b
)) a
)))
3687 (format t
"~& result = ~A~%" result
))
3690 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3692 ;;; Implementation of the Generalized Incomplete Beta function
3694 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3696 ;;; beta_incomplete_generalized distributes over bags
3698 (defprop %beta_incomplete_generalized
(mlist $matrix mequal
) distribute_over
)
3700 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3702 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
3703 ;;; but not on the negative real axis and for z1 or z2 real and > 1.
3704 ;;; We support a conjugate-function which test these cases.
3706 (defprop %beta_incomplete_generalized
3707 conjugate-beta-incomplete-generalized conjugate-function
)
3709 (defun conjugate-beta-incomplete-generalized (args)
3710 (let ((a (first args
))
3714 (cond ((and (off-negative-real-axisp z1
)
3715 (not (and (zerop1 ($imagpart z1
))
3716 (eq ($sign
(sub ($realpart z1
) 1)) '$pos
)))
3717 (off-negative-real-axisp z2
)
3718 (not (and (zerop1 ($imagpart z2
))
3719 (eq ($sign
(sub ($realpart z2
) 1)) '$pos
))))
3722 '(%beta_incomplete_generalized
)
3723 (simplify (list '($conjugate
) a
))
3724 (simplify (list '($conjugate
) b
))
3725 (simplify (list '($conjugate
) z1
))
3726 (simplify (list '($conjugate
) z2
)))))
3730 (simplify (list '(%beta_incomplete_generalized
)
3733 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3735 (defprop %beta_incomplete_generalized
3740 ((%beta_incomplete
) a b z1
)
3743 ((mexpt) ((%gamma
) a
) 2)
3746 (($hypergeometric_regularized
)
3747 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3748 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3752 (($hypergeometric_regularized
)
3753 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3754 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3757 ((mtimes) ((%beta_incomplete
) a b z2
) ((%log
) z2
)))
3761 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z1
)))
3762 ((%log
) ((mplus) 1 ((mtimes) -
1 z1
))))
3764 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z2
)))
3765 ((%log
) ((mplus) 1 ((mtimes) -
1 z2
))))
3767 ((mexpt) ((%gamma
) b
) 2)
3770 (($hypergeometric_regularized
)
3771 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3772 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3773 ((mplus) 1 ((mtimes) -
1 z1
)))
3774 ((mexpt) ((mplus) 1 ((mtimes) -
1 z1
)) b
))
3776 (($hypergeometric_regularized
)
3777 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3778 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3779 ((mplus) 1 ((mtimes) -
1 z2
)))
3780 ((mexpt) ((mplus) 1 ((mtimes) -
1 z2
)) b
)))))
3781 ;; The derivative wrt z1
3784 ((mplus) 1 ((mtimes) -
1 z1
))
3786 ((mexpt) z1
((mplus) -
1 a
)))
3787 ;; The derivative wrt z2
3790 ((mplus) 1 ((mtimes) -
1 z2
))
3792 ((mexpt) z2
((mplus) -
1 a
))))
3795 ;;; Integral of the Incomplete Beta function
3797 (defprop %beta_incomplete_generalized
3803 ((%beta_incomplete
) ((mplus) 1 a
) b z1
)
3804 ((mtimes) ((%beta_incomplete_generalized
) a b z1 z2
) z1
))
3808 ((%beta_incomplete
) ((mplus) 1 a
) b z2
))
3809 ((mtimes) ((%beta_incomplete_generalized
) a b z1 z2
) z2
)))
3812 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3814 (def-simplifier beta_incomplete_generalized
(a b z1 z2
)
3818 ;; Check for specific values
3821 (let ((sgn ($sign
($realpart a
))))
3822 (cond ((eq sgn
'$neg
)
3825 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3827 ((member sgn
'($pos $pz
))
3828 (mul -
1 (ftake '%beta_incomplete a b z1
)))
3833 (let ((sgn ($sign
($realpart a
))))
3834 (cond ((eq sgn
'$neg
)
3837 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3839 ((member sgn
'($pos $pz
))
3840 (mul -
1 (ftake '%beta_incomplete a b z2
)))
3844 ((and (onep1 z2
) (or (not (mnump a
)) (not (mnump b
)) (not (mnump z1
))))
3845 (let ((sgn ($sign
($realpart b
))))
3846 (cond ((member sgn
'($pos $pz
))
3847 (sub (ftake* '%beta a b
)
3848 (ftake '%beta_incomplete a b z1
)))
3852 ((and (onep1 z1
) (or (not (mnump a
)) (not (mnump b
)) (not (mnump z2
))))
3853 (let ((sgn ($sign
($realpart b
))))
3854 (cond ((member sgn
'($pos $pz
))
3855 (sub (ftake '%beta_incomplete a b z2
)
3856 (ftake* '%beta a b
)))
3860 ;; Check for numerical evaluation in Float or Bigfloat precision
3862 ((complex-float-numerical-eval-p a b z1 z2
)
3863 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0))))
3864 (sub (beta-incomplete ($float a
) ($float b
) ($float z2
))
3865 (beta-incomplete ($float a
) ($float b
) ($float z1
)))))
3867 ((complex-bigfloat-numerical-eval-p a b z1 z2
)
3868 (let ((*beta-incomplete-eps
*
3869 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
3870 (sub (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z2
))
3871 (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z1
)))))
3873 ;; Check for argument simplifications and transformations
3875 ((and (integerp a
) (plusp a
))
3880 (power (sub 1 z1
) b
)
3881 (let ((index (gensumindex)))
3885 (simplify (list '($pochhammer
) b index
))
3887 (simplify (list '(mfactorial) index
)))
3888 index
0 (sub a
1))))
3890 (power (sub 1 z2
) b
)
3891 (let ((index (gensumindex)))
3895 (simplify (list '($pochhammer
) b index
))
3897 (simplify (list '(mfactorial) index
)))
3898 index
0 (sub a
1)))))))
3900 ((and (integerp b
) (plusp b
))
3906 (let ((index (gensumindex)))
3910 (simplify (list '($pochhammer
) a index
))
3911 (power (sub 1 z2
) index
))
3912 (simplify (list '(mfactorial) index
)))
3913 index
0 (sub b
1))))
3916 (let ((index (gensumindex)))
3920 (simplify (list '($pochhammer
) a index
))
3921 (power (sub 1 z1
) index
))
3922 (simplify (list '(mfactorial) index
)))
3923 index
0 (sub b
1)))))))
3925 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
3927 (a (simplify (cons '(mplus) (cddr a
)))))
3931 (simplify (list '($pochhammer
) a n
))
3932 (simplify (list '($pochhammer
) (add a b
) n
)))
3933 (take '(%beta_incomplete_generalized
) a b z1 z2
))
3935 (power (add a b n -
1) -
1)
3936 (let ((index (gensumindex)))
3940 (simplify (list '($pochhammer
)
3941 (add 1 (mul -
1 a
) (mul -
1 n
))
3943 (simplify (list '($pochhammer
)
3944 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
3947 (mul (power (sub 1 z1
) b
)
3948 (power z1
(add a n
(mul -
1 index
) -
1)))
3949 (mul (power (sub 1 z2
) b
)
3950 (power z2
(add a n
(mul -
1 index
) -
1)))))
3951 index
0 (sub n
1)))))))
3953 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
3954 (let ((n (- (cadr a
)))
3955 (a (simplify (cons '(mplus) (cddr a
)))))
3959 (simplify (list '($pochhammer
) (add 1 (mul -
1 a
) (mul -
1 b
)) n
))
3960 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3961 (take '(%beta_incomplete_generalized
) a b z1 z2
))
3965 (list '($pochhammer
) (add 2 (mul -
1 a
) (mul -
1 b
)) (sub n
1)))
3966 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3967 (let ((index (gensumindex)))
3971 (simplify (list '($pochhammer
) (sub 1 a
) index
))
3972 (simplify (list '($pochhammer
)
3973 (add 2 (mul -
1 a
) (mul -
1 b
))
3976 (mul (power (sub 1 z2
) b
)
3977 (power z2
(add a
(mul -
1 index
) -
1)))
3978 (mul (power (sub 1 z1
) b
)
3979 (power z1
(add a
(mul -
1 index
) -
1)))))
3980 index
0 (sub n
1)))))))
3985 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3987 ;;; Implementation of the Regularized Incomplete Beta function
3989 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3991 ;;; beta_incomplete_regularized distributes over bags
3993 (defprop %beta_incomplete_regularized
(mlist $matrix mequal
) distribute_over
)
3995 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3997 (defprop %beta_incomplete_regularized
4003 (($hypergeometric_regularized
)
4004 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
4005 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
)) z
)
4006 ((mexpt) ((%gamma
) b
) -
1)
4007 ((%gamma
) ((mplus) a b
))
4010 ((%beta_incomplete_regularized
) a b z
)
4012 ((mtimes) -
1 ((mqapply) (($psi array
) 0) a
))
4013 ((mqapply) (($psi array
) 0) ((mplus) a b
))
4018 ((%beta_incomplete_regularized
) b a
((mplus) 1 ((mtimes) -
1 z
)))
4020 ((mqapply) (($psi array
) 0) b
)
4021 ((mtimes) -
1 ((mqapply) (($psi array
) 0) ((mplus) a b
)))
4022 ((mtimes) -
1 ((%log
) ((mplus) 1 ((mtimes) -
1 z
))))))
4024 ((mexpt) ((%gamma
) a
) -
1)
4026 ((%gamma
) ((mplus) a b
))
4027 (($hypergeometric_regularized
)
4028 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
4029 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
4030 ((mplus) 1 ((mtimes) -
1 z
)))
4031 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) b
)))
4032 ;; The derivative wrt z
4034 ((mexpt) ((%beta
) a b
) -
1)
4035 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) ((mplus) -
1 b
))
4036 ((mexpt) z
((mplus) -
1 a
))))
4039 ;;; Integral of the Generalized Incomplete Beta function
4041 (defprop %beta_incomplete_regularized
4048 ((%beta_incomplete_regularized
) ((mplus) 1 a
) b z
)
4049 ((mexpt) ((mplus) a b
) -
1))
4050 ((mtimes) ((%beta_incomplete_regularized
) a b z
) z
)))
4053 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4055 (def-simplifier beta_incomplete_regularized
(a b z
)
4059 ;; Check for specific values
4062 (let ((sgn ($sign
($realpart a
))))
4063 (cond ((eq sgn
'$neg
)
4066 "beta_incomplete_regularized: beta_incomplete_regularized(~:M,~:M,~:M) is undefined.")
4068 ((member sgn
'($pos $pz
))
4077 (let ((sgn ($sign
($realpart b
))))
4078 (cond ((member sgn
'($pos $pz
))
4083 ((and (integer-representation-p b
)
4084 (if ($bfloatp b
) (minusp (cadr b
)) (minusp b
)) )
4085 ;; Problem: for b a negative integer the Regularized Incomplete
4086 ;; Beta function is defined to be zero. BUT: When we calculate
4087 ;; e.g. beta_incomplete(1.0,-2.0,1/2)/beta(1.0,-2.0) we get the
4088 ;; result -3.0, because beta_incomplete and beta are defined for
4089 ;; for this case. How do we get a consistent behaviour?
4092 ((and (integer-representation-p a
)
4093 (if ($bfloatp a
) (minusp (cadr a
)) (minusp a
)) )
4095 ;; TODO: The following line does not work for bigfloats.
4096 ((and (integer-representation-p b
) (<= b
(- a
)))
4097 ;; Does $beta_incomplete or simpbeta underflow in this case?
4098 (div (ftake '%beta_incomplete a b z
)
4099 (ftake* '%beta a b
)))
4103 ;; Check for numerical evaluation in Float or Bigfloat precision
4105 ((complex-float-numerical-eval-p a b z
)
4106 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0)))
4108 (setq a
($float a
) b
($float b
))
4109 (if (or (< ($abs
(setq beta
(ftake* '%beta a b
))) 1e-307)
4110 (< ($abs
(setq ibeta
(beta-incomplete a b
($float z
)))) 1e-307) )
4111 ;; In case of underflow (see bug #2999) or precision loss use bigfloats
4112 ;; and emporarily give some extra precision but avoid fpprec dependency.
4113 ;; Is this workaround correct for complex values?
4115 ($float
(take '(%beta_incomplete_regularized
) ($bfloat a
) ($bfloat b
) z
)) )
4116 ($rectform
(div ibeta beta
)) )))
4118 ((complex-bigfloat-numerical-eval-p a b z
)
4119 (let ((*beta-incomplete-eps
*
4120 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
4121 (setq a
($bfloat a
) b
($bfloat b
))
4123 (div (beta-incomplete a b
($bfloat z
))
4124 (ftake* '%beta a b
)))))
4126 ;; Check for argument simplifications and transformations
4128 ((and (integerp b
) (plusp b
))
4129 (div (ftake '%beta_incomplete a b z
)
4130 (ftake* '%beta a b
)))
4132 ((and (integerp a
) (plusp a
))
4133 (div (ftake '%beta_incomplete a b z
)
4134 (ftake* '%beta a b
)))
4136 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
4138 (a (simplify (cons '(mplus) (cddr a
)))))
4140 (take '(%beta_incomplete_regularized
) a b z
)
4142 (power (add a b n -
1) -
1)
4143 (power (ftake* '%beta
(add a n
) b
) -
1)
4144 (let ((index (gensumindex)))
4148 (simplify (list '($pochhammer
)
4149 (add 1 (mul -
1 a
) (mul -
1 n
))
4151 (simplify (list '($pochhammer
)
4152 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
4155 (power z
(add a n
(mul -
1 index
) -
1)))
4156 index
0 (sub n
1)))))))
4158 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
4159 (let ((n (- (cadr a
)))
4160 (a (simplify (cons '(mplus) (cddr a
)))))
4162 (take '(%beta_incomplete_regularized
) a b z
)
4164 (power (add a b -
1) -
1)
4165 (power (ftake* '%beta a b
) -
1)
4166 (let ((index (gensumindex)))
4170 (simplify (list '($pochhammer
) (sub 1 a
) index
))
4171 (simplify (list '($pochhammer
)
4172 (add 2 (mul -
1 a
) (mul -
1 b
))
4175 (power z
(add a
(mul -
1 index
) -
1)))
4176 index
0 (sub n
1)))))))
4181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;