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 definied 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 (declare-top (special $factlim $gamma_expand
))
78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80 (defmvar $factorial_expand nil
)
81 (defmvar $beta_expand nil
)
83 (defmvar $erf_representation nil
84 "When T erfc, erfi and erf_generalized are transformed to erf.")
86 (defmvar $erf_%iargs nil
87 "When T erf and erfi simplifies for an imaginary argument.")
89 (defmvar $hypergeometric_representation nil
90 "When T a transformation to a hypergeometric representation is done.")
92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
93 ;;; The following functions test if numerical evaluation has to be done.
94 ;;; The functions should help to test for numerical evaluation more consitent
95 ;;; and without complicated conditional tests including more than one or two
98 ;;; The functions take a list of arguments. All arguments have to be a CL or
99 ;;; Maxima number. If all arguments are numbers we have two cases:
100 ;;; 1. $numer is T we return T. The function has to be evaluated numerically.
101 ;;; 2. One of the args is a float or a bigfloat. Evaluate numerically.
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104 ;;; Test for numerically evaluation in float precision
106 (defun float-numerical-eval-p (&rest args
)
109 (when (not (float-or-rational-p ll
))
110 (return-from float-numerical-eval-p nil
))
111 (when (floatp ll
) (setq flag t
)))
112 (if (or $numer flag
) t nil
)))
114 ;;; Test for numerically evaluation in complex float precision
116 (defun complex-float-numerical-eval-p (&rest args
)
117 "Determine if ARGS consists of numerical values by determining if
118 the real and imaginary parts of each arg are nuemrical (but not
119 bigfloats). A non-NIL result is returned if at least one of args is
120 a floating-point value or if numer is true. If the result is
121 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P"
124 (multiple-value-bind (bool rll ill
)
125 (complex-number-p ll
'float-or-rational-p
)
127 (return-from complex-float-numerical-eval-p nil
))
128 ;; Always save the result from complex-number-p. But for backward
129 ;; compatibility, only set the flag if any item is a float.
130 (push (add rll
(mul ill
'$%i
)) values
)
131 (setf flag
(or flag
(or (floatp rll
) (floatp ill
))))))
132 (when (or $numer flag
)
133 ;; Return the values in the same order as the args!
136 ;;; Test for numerically evaluation in bigfloat precision
138 (defun bigfloat-numerical-eval-p (&rest args
)
141 (when (not (bigfloat-or-number-p ll
))
142 (return-from bigfloat-numerical-eval-p nil
))
145 (if (or $numer flag
) t nil
)))
147 ;;; Test for numerically evaluation in complex bigfloat precision
149 (defun complex-bigfloat-numerical-eval-p (&rest args
)
150 "Determine if ARGS consists of numerical values by determining if
151 the real and imaginary parts of each arg are nuemrical (including
152 bigfloats). A non-NIL result is returned if at least one of args is
153 a floating-point value or if numer is true. If the result is
154 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P."
158 (multiple-value-bind (bool rll ill
)
159 (complex-number-p ll
'bigfloat-or-number-p
)
161 (return-from complex-bigfloat-numerical-eval-p nil
))
162 ;; Always save the result from complex-number-p. But for backward
163 ;; compatibility, only set the flag if any item is a bfloat.
164 (push (add rll
(mul ill
'$%i
)) values
)
165 (when (or ($bfloatp rll
) ($bfloatp ill
))
167 (when (or $numer flag
)
168 ;; Return the values in the same order as the args!
171 ;;; Test for numerical evaluation in any precision, real or complex.
172 (defun numerical-eval-p (&rest args
)
173 (or (apply 'float-numerical-eval-p args
)
174 (apply 'complex-float-numerical-eval-p args
)
175 (apply 'bigfloat-numerical-eval-p args
)
176 (apply 'complex-bigfloat-numerical-eval-p args
)))
178 ;;; Check for an integer or a float or bigfloat representation. When we
179 ;;; have a float or bigfloat representation return the integer value.
181 (defun integer-representation-p (x)
183 (cond ((integerp x
) x
)
184 ((and (floatp x
) (= 0 (nth-value 1 (truncate x
))))
185 (nth-value 0 (truncate x
)))
187 (eq ($sign
(sub (setq val
($truncate x
)) x
)) '$zero
))
191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
193 ;;; The changes to the parser to connect the operator !! to double_factorial(z)
195 ;(def-mheader |$!!| (%double_factorial))
197 ;(def-led (|$!!| 160.) (op left)
200 ; (convert left '$expr)))
202 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
204 ;;; The implementation of the function Double factorial
206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
208 ;;; Double factorial distributes over bags
210 (defprop %double_factorial
(mlist $matrix mequal
) distribute_over
)
212 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
214 ;;; Double factorial has mirror symmetry
216 (defprop %double_factorial t commutes-with-conjugate
)
218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
220 ;;; Differentiation of Double factorial
222 (defprop %double_factorial
226 ((%double_factorial
) z
)
231 ((mplus) 1 ((mtimes) ((rat) 1 2) z
)))
234 ((%log
) ((mtimes) 2 ((mexpt) $%pi -
1)))
235 ((%sin
) ((mtimes) $%pi z
))))))
238 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
240 ;;; Double factorial is a simplifying function
242 (def-simplifier double_factorial
(z)
244 ((and (fixnump z
) (> z -
1) (or (minusp $factlim
) (< z $factlim
)))
245 ;; Positive Integer less then $factlim or $factlim is -1. Call gfact.
246 (gfact z
(floor (/ z
2)) 2))
250 (zerop1 (sub (simplify (list '(%truncate
) (div z
2))) (div z
2))))
251 ;; Even negative integer or real representation. Not defined.
254 "double_factorial: double_factorial(~:M) is undefined.") z
))
256 ((or (integerp z
) ; at this point odd negative integer. Evaluate.
257 (complex-float-numerical-eval-p z
))
259 ((and (integerp z
) (= z -
1)) 1) ; Special cases -1 and -3
260 ((and (integerp z
) (= z -
3)) -
1)
262 ;; Odd negative integer, float or complex float.
265 (complex ($float
($realpart z
)) ($float
($imagpart z
))))))))
267 ((and (not (ratnump z
))
268 (complex-bigfloat-numerical-eval-p z
))
269 ;; bigfloat or complex bigfloat.
270 (bfloat-double-factorial
271 (add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))
273 ;; double_factorial(inf) -> inf
276 ((and $factorial_expand
280 (n (simplify (cons '(mplus) (cddr z
)))))
283 ;; Special case double_factorial(n-1)
284 ;; Not sure if this simplification is useful.
285 (div (simplify (list '(mfactorial) n
))
286 (simplify (list '(%double_factorial
) n
))))
287 ((= k
(* 2 (truncate (/ k
2))))
288 ;; Special case double_factorial(2*k+n), k integer
290 ($factor
; we get more simple expression when factoring
293 (simplify (list '($pochhammer
) (add (div n
2) 1) k
))
294 (simplify (list '(%double_factorial
) n
)))))
301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
302 ;;; Double factorial for a complex float argument. The result is a CL complex.
303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
305 (defun double-factorial (z)
306 (let ((pival (float pi
)))
310 (/ (- 1 (cos (* pival z
))) 4))
312 (gamma-lanczos (+ 1 (/ z
2))))))
314 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
315 ;;; Double factorial for a bigfloat or complex bigfloat argument
316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
318 (defun bfloat-double-factorial (z)
319 (let* ((pival ($bfloat
'$%pi
))
320 (bigfloat1 ($bfloat bigfloatone
))
321 (bigfloat2 (add bigfloat1 bigfloat1
))
322 (bigfloat4 (add bigfloat2 bigfloat2
))
326 (cdiv bigfloat2 pival
)
328 (simplify (list '(%cos
) (cmul pival z
)))) bigfloat4
))
330 (cpower bigfloat2
(cdiv z bigfloat2
))
331 (simplify (list '(%gamma
) (add bigfloat1
(cdiv z bigfloat2
))))))))
333 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
335 ;;; The implementation of the Incomplete Gamma function
342 ;;; gamma_incomplete(a, z) = I t %e dt
347 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
349 (defvar *debug-gamma
* nil
)
351 ;; TODO: This is currently called by integrate-exp-special in sin.lisp.
352 ;; Need to fix that before this can be removed.
353 (defmfun $gamma_incomplete
(a z
)
354 (simplify (list '(%gamma_incomplete
) a z
)))
356 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
359 ;;; Incomplete Gamma distributes over bags
361 (defprop %gamma_incomplete
(mlist $matrix mequal
) distribute_over
)
363 ;;; Incomplete Gamma function has not mirror symmetry for z on the negative
364 ;;; real axis. We support a conjugate-function which test this case.
366 (defprop %gamma_incomplete conjugate-gamma-incomplete conjugate-function
)
368 (defun conjugate-gamma-incomplete (args)
369 (let ((a (first args
)) (z (second args
)))
370 (cond ((off-negative-real-axisp z
)
371 ;; Definitely not on the negative real axis for z. Mirror symmetry.
375 (simplify (list '($conjugate
) a
))
376 (simplify (list '($conjugate
) z
)))))
378 ;; On the negative real axis or no information. Unsimplified.
381 (simplify (list '(%gamma_incomplete
) a z
)))))))
383 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
385 ;;; Derivative of the Incomplete Gamma function
387 (putprop '%gamma_incomplete
390 (cond ((member ($sign a
) '($pos $pz
))
391 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2
392 ;; function and the Generalized Incomplete Gamma function
393 ;; (functions.wolfram.com), only for a>0.
396 ((mexpt) ((%gamma
) ,a
) 2)
398 (($hypergeometric_regularized
)
400 ((mlist) ((mplus) 1 ,a
) ((mplus) 1 ,a
))
403 ((%gamma_incomplete_generalized
) ,a
0 ,z
)
407 ((mqapply) (($psi array
) 0) ,a
))))
409 ;; No derivative. Maxima generates a noun form.
411 ;; The derivative wrt z
413 ((mexpt) $%e
((mtimes) -
1 z
))
414 ((mexpt) z
((mplus) -
1 a
))))
417 ;;; Integral of the Incomplete Gamma function
419 (defprop %gamma_incomplete
423 ((mtimes) -
1 ((%gamma_incomplete
) ((mplus) 1 a
) z
))
424 ((mtimes) ((%gamma_incomplete
) a z
) z
)))
427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
429 ;;; We support a simplim%function. The function is looked up in simplimit and
430 ;;; handles specific values of the function.
432 (defprop %gamma_incomplete simplim%gamma_incomplete simplim%function
)
434 (defun simplim%gamma_incomplete
(expr var val
)
435 ;; Look for the limit of the arguments.
436 (let ((a (limit (cadr expr
) var val
'think
))
437 (z (limit (caddr expr
) var val
'think
)))
440 ((eq z
'$infinity
) ;; http://dlmf.nist.gov/8.11#i
441 (cond ((and (zerop1 ($realpart
(caddr expr
)))
442 (eq ($csign
(m+ -
1 (cadr expr
))) '$neg
))
444 (t (throw 'limit t
))))
446 ;; Handle an argument 0 at this place.
450 (let ((sgn ($sign
($realpart a
))))
451 (cond ((zerop1 a
) '$inf
)
452 ((member sgn
'($neg $nz
)) '$infinity
)
453 ;; Call the simplifier of the function.
454 (t (simplify (list '(%gamma_incomplete
) a z
))))))
456 ;; All other cases are handled by the simplifier of the function.
457 (simplify (list '(%gamma_incomplete
) a z
))))))
459 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
461 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
463 ;;; Implementation of the Lower Incomplete gamma function:
470 ;;; gamma_incomplete_lower(a, z) = I t %e dt
474 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
475 ;;; distribute over bags (aggregates)
477 (defprop %gamma_incomplete_lower
(mlist $matrix mequal
) distribute_over
)
479 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
481 ;; (defprop %gamma_incomplete_lower ??? grad) WHAT TO PUT HERE ??
484 ;; Handles some special cases for the order a and simplifies it to an
485 ;; equivalent form, possibly involving erf and gamma_incomplete_lower
487 (def-simplifier gamma_incomplete_lower
(a z
)
490 (float-numerical-eval-p a z
)
491 (complex-float-numerical-eval-p a z
)
492 (bigfloat-numerical-eval-p a z
)
493 (complex-bigfloat-numerical-eval-p a z
))
494 (ftake '%gamma_incomplete_generalized a
0 z
))
495 ((gamma-incomplete-lower-expand a z
))
499 ;; Try to express gamma_incomplete_lower(a,z) in simpler terms for
500 ;; special values of the order a. If we can't, return NIL to say so.
501 (defun gamma-incomplete-lower-expand (a z
)
502 (cond ((and $gamma_expand
(integerp a
) (eql a
1))
503 ;; gamma_incomplete_lower(0, x) = 1-exp(x)
504 (sub 1 (m^t
'$%e
(neg z
))))
505 ((and $gamma_expand
(integerp a
) (plusp a
))
506 ;; gamma_incomplete_lower(a,z) can be simplified if a is a
507 ;; positive integer. Since gamma_incomplete_lower(a,z) =
508 ;; gamma(a) - gamma_incomplete(a,z), use gamma_incomplete to
510 (sub (simpgamma (list '(%gamma
) a
) 1 nil
)
511 (take '(%gamma_incomplete
) a z
)))
512 ((and $gamma_expand
(alike1 a
1//2))
515 ;; gamma_incomplete_lower(1/2,x^2) = sqrt(%pi)*erf(x)
517 ;; gamma_incomplete_lower(1/2,z) = sqrt(%pi)*erf(sqrt(x))
519 (mul (power '$%pi
'((rat simp
) 1 2))
520 (take '(%erf
) (power z
'((rat simp
) 1 2)))))
521 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
522 ;; gamma_incomplete_lower(a+n,z), where n is an integer
524 (a (simplify (cons '(mplus) (cddr a
)))))
527 ;; gamma_incomplete_lower(a+n,z). See DLMF 8.8.7:
529 ;; gamma_incomplete_lower(a+n,z)
530 ;; = pochhammer(a,n)*gamma_incomplete_lower(a,z)
531 ;; -z^a*exp(-z)*sum(gamma(a+n)gamma(a+k+1)*z^k,k,0,n-1)
534 (simplify (list '($pochhammer
) a n
))
535 (simplify (list '(%gamma_incomplete_lower
) a z
)))
538 (power '$%e
(mul -
1 z
))
539 (let ((gamma-a+n
(simpgamma (list '(%gamma
) (add a n
)) 1 nil
))
540 (index (gensumindex))
545 (simpgamma (list '(%gamma
) (add a index
1)) 1 nil
))
547 index
0 (add n -
1))))))
550 ;; See DLMF 8.8.8. For simplicity let g(a,z) = gamma_incomplete_lower(a,z).
552 ;; g(a,z) = gamma(a)/gamma(a-n)*g(a-n,z)
553 ;; - z^(a-1)*exp(z)*sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
556 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
557 ;; + gamma(a-n)/gamma(a)*z^(a-1)*exp(-z)
558 ;; * sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
560 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
562 ;; * sum(gamma(a-n)/gamma(a-k)*z^(-k),k,0,n-1)
563 (let ((gamma-a-n (simpgamma (list '(%gamma
) (sub a n
)) 1 nil
))
564 (index (gensumindex))
570 (simplify (list '(%gamma_incomplete_lower
) a z
)))
573 (power '$%e
(mul -
1 z
))
577 (simpgamma (list '(%gamma
) (sub a index
)) 1 nil
))
578 (power z
(mul -
1 index
)))
579 index
0 (add n -
1)))))))))
580 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
581 (integerp (second a
))
582 (integerp (third a
)))
583 ;; gamma_incomplete_lower of (numeric) rational order.
584 ;; Expand it out so that the resulting order is between 0 and
586 (multiple-value-bind (n order
)
587 (floor (/ (second a
) (third a
)))
588 ;; a = n + order where 0 <= order < 1.
589 (let ((rat-order (rat (numerator order
) (denominator order
))))
592 ;; Nothing to do if the order is already between 0 and 1
593 (list '(%gamma_incomplete_lower simp
) a z
))
595 ;; Use gamma_incomplete(a+n,z) above. and then substitue
596 ;; a=order. This works for n positive or negative.
597 (let* ((ord (gensym))
598 (g (simplify (list '(%gamma_incomplete_lower
) (add ord n
) z
))))
599 ($substitute rat-order ord g
)))))))
601 ;; No expansion so return nil to indicate that
604 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
606 ;;; Incomplete Gamma function is a simplifying function
608 (def-simplifier gamma_incomplete
(a z
)
613 ;; Check for specific values
616 ;; gamma_incomplete(v,0) is gamma(v) only if the realpart(v) >
617 ;; 0. If realpart(v) <= 0, gamma_incomplete is undefined. For
618 ;; all other cases, return the noun form.
619 (let ((sgn ($sign
($realpart a
))))
620 (cond ((member sgn
'($neg $zero
))
623 "gamma_incomplete: gamma_incomplete(~:M,~:M) is undefined.")
625 ((member sgn
'($pos $pz
)) ($gamma a
))
633 ;; Check for numerical evaluation in Float or Bigfloat precision
635 ((float-numerical-eval-p a z
)
637 (format t
"~&SIMP-GAMMA-INCOMPLETE in float-numerical-eval-p~%"))
638 ;; a and z are Maxima numbers, at least one has a float value
643 (and (= 0 (- a
(truncate a
)))
645 ;; a is zero or a negative float representing an integer.
646 ;; For these cases the numerical routines of gamma-incomplete
647 ;; do not work. Call the numerical routine for the Exponential
648 ;; Integral E(n,z). The routine is called with a positive integer!.
649 (setq a
(truncate a
))
650 (complexify (* (expt z a
) (expintegral-e (- 1 a
) z
))))
652 (complexify (gamma-incomplete a z
))))))
654 ((complex-float-numerical-eval-p a z
)
657 "~&SIMP-GAMMA-INCOMPLETE in complex-float-numerical-eval-p~%"))
658 ;; a and z are Maxima numbers, at least one is a complex value and
659 ;; we have at least one float part
660 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
661 (cz (complex ($float
($realpart z
)) ($float
($imagpart z
)))))
663 ((and (= (imagpart ca
) 0.0)
664 (or (= (realpart ca
) 0.0)
665 (and (= 0 (- (realpart ca
) (truncate (realpart ca
))))
666 (< (realpart ca
) 0.0))))
667 ;; Call expintegral-e. See comment above.
668 (setq ca
(truncate (realpart ca
)))
669 (complexify (* (expt cz ca
) (expintegral-e (- 1 ca
) cz
))))
671 (complexify (gamma-incomplete ca cz
))))))
673 ((bigfloat-numerical-eval-p a z
)
675 (format t
"~&SIMP-GAMMA-INCOMPLETE in bigfloat-numerical-eval-p~%"))
676 (let ((a ($bfloat a
))
679 ((or (eq ($sign a
) '$zero
)
680 (and (eq ($sign
(sub a
($truncate a
))) '$zero
)
681 (eq ($sign a
) '$neg
)))
682 ;; Call bfloat-expintegral-e. See comment above.
683 (setq a
($truncate a
))
684 ($rectform
(mul (power z a
) (bfloat-expintegral-e (- 1 a
) z
))))
686 (bfloat-gamma-incomplete a z
)))))
688 ((complex-bigfloat-numerical-eval-p a z
)
691 "~&SIMP-GAMMA-INCOMPLETE in complex-bigfloat-numerical-eval-p~%"))
692 (let ((ca (add ($bfloat
($realpart a
))
693 (mul '$%i
($bfloat
($imagpart a
)))))
694 (cz (add ($bfloat
($realpart z
))
695 (mul '$%i
($bfloat
($imagpart z
))))))
697 ((and (eq ($sign
($imagpart ca
)) '$zero
)
698 (or (eq ($sign
($realpart ca
)) '$zero
)
699 (and (eq ($sign
(sub ($realpart ca
)
700 ($truncate
($realpart ca
))))
702 (eq ($sign
($realpart ca
)) '$neg
))))
703 ;; Call bfloat-expintegral-e. See comment above.
706 "~& bigfloat-numerical-eval-p calls bfloat-expintegral-e~%"))
707 (setq a
($truncate
($realpart a
)))
708 ($rectform
(mul (power cz a
)
709 (bfloat-expintegral-e (- 1 a
) cz
))))
711 (complex-bfloat-gamma-incomplete ca cz
)))))
713 ;; Check for transformations and argument simplification
715 ((and $gamma_expand
(integerp a
))
716 ;; Integer or a symbol declared to be an integer. Expand in a series.
717 (let ((sgn ($sign a
)))
722 (simplify (list '(%expintegral_ei
) (mul -
1 z
))))
726 (simplify (list '(%log
) (mul -
1 z
)))
727 (simplify (list '(%log
) (div -
1 z
)))))
728 (mul -
1 (simplify (list '(%log
) z
)))))
729 ((member sgn
'($pos $pz
))
731 (simplify (list '(%gamma
) a
))
732 (power '$%e
(mul -
1 z
))
733 (let ((index (gensumindex)))
737 (let (($gamma_expand nil
))
738 ;; Simplify gamma, but do not expand to avoid division
740 (simplify (list '(%gamma
) (add index
1)))))
741 index
0 (sub a
1)))))
742 ((member sgn
'($neg $nz
))
746 (power -
1 (add (mul -
1 a
) -
1))
747 (simplify (list '(%gamma
) (add (mul -
1 a
) 1))))
749 (simplify (list '(%expintegral_ei
) (mul -
1 z
)))
753 (simplify (list '(%log
) (mul -
1 z
)))
754 (simplify (list '(%log
) (div -
1 z
)))))
755 (simplify (list '(%log
) z
))))
757 (power '$%e
(mul -
1 z
))
758 (let ((index (gensumindex)))
761 (power z
(add index a -
1))
762 (simplify (list '($pochhammer
) a index
)))
763 index
1 (mul -
1 a
))))))
766 ((and $gamma_expand
(setq ratorder
(max-numeric-ratio-p a
2)))
767 ;; We have a half integral order and $gamma_expand is not NIL.
768 ;; We expand in a series with the Erfc function
769 (setq ratorder
(- ratorder
(/ 1 2)))
773 (power '$%pi
'((rat simp
) 1 2))
774 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))))
778 (simplify (list '(%gamma
) a
))
779 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
781 (power -
1 (sub ratorder
1))
782 (power '$%e
(mul -
1 z
))
783 (power z
'((rat simp
) 1 2))
784 (let ((index (gensumindex)))
786 (mul -
1 ; we get more simple results
787 (simplify ; when multiplying with -1
790 (sub '((rat simp
) 1 2) ratorder
)
791 (sub ratorder
(add index
1))))
792 (power (mul -
1 z
) index
))
793 index
0 (sub ratorder
1))))))
795 (setq ratorder
(- ratorder
))
800 (power '$%pi
'((rat simp
) 1 2))
801 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
802 (simplify (list '($pochhammer
) '((rat simp
) 1 2) ratorder
)))
804 (power z
(sub '((rat simp
) 1 2) ratorder
))
805 (power '$%e
(mul -
1 z
))
806 (let ((index (gensumindex)))
813 (sub '((rat simp
) 1 2) ratorder
)
815 index
0 (sub ratorder
1))))))))
817 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
818 ;; Handle gamma_incomplete(a+n, z), where n is a numerical integer
820 (a (simplify (cons '(mplus) (cddr a
)))))
823 ;; See DLMF 8.8.9: https://dlmf.nist.gov/8.8.E9
825 ;; gamma_incomplete(a+n,z) = pochhammer(a,n)*gamma_incomplete(a,z)
826 ;; + z^a*exp(-z)*sum(gamma(a+n)/gamma(a+k+1)*z^k,k,0,n-1)
829 (simplify (list '($pochhammer
) a n
))
830 (simplify (list '(%gamma_incomplete
) a z
)))
832 (power '$%e
(mul -
1 z
))
834 (let ((gamma-a+n
(simpgamma (list '(%gamma
) (add a n
)) 1 nil
))
835 (index (gensumindex)))
839 (simpgamma (list '(%gamma
) (add a index
1)) 1 nil
))
841 index
0 (add n -
1))))))
844 ;; See http://functions.wolfram.com/06.06.17.0004.01
846 ;; gamma_incomplate(a,z) =
847 ;; (-1)^n*pochhammer(1-a,n)
848 ;; *[gamma_incomplete(a-n,z)
849 ;; + z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)]
851 ;; Rerarrange this in terms of gamma_incomplete(a-n,z):
853 ;; gamma_incomplete(a-n,z) =
854 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
855 ;; -z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)
857 ;; Change the summation index to go from k = 0 to n-1:
859 ;; z^(a-n-1)*sum(z^k/pochhammer(a-n,k),k,1,n)
860 ;; = z^(a-n-1)*sum(z^(k+1)/pochhammer(a-n,k+1),k,0,n-1)
861 ;; = z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
864 ;; gamma_incomplete(a-n,z) =
865 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
866 ;; -z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
868 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
872 (simplify (list '(%gamma_incomplete
) a z
)))
873 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
875 (power '$%e
(mul -
1 z
))
877 ;; sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
878 (let ((index (gensumindex)))
882 (simplify (list '($pochhammer
) (sub a n
) (add index
1))))
883 index
0 (sub n
1)))))))))
884 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
885 (integerp (second a
))
886 (integerp (third a
)))
887 ;; gamma_incomplete of (numeric) rational order. Expand it out
888 ;; so that the resulting order is between 0 and 1.
889 (multiple-value-bind (n order
)
890 (floor (/ (second a
) (third a
)))
891 ;; a = n + order where 0 <= order < 1.
892 (let ((rat-order (rat (numerator order
) (denominator order
))))
895 ;; Nothing to do if the order is already between 0 and 1
898 ;; Use gamma_incomplete(a+n,z) above. and then substitue
899 ;; a=order. This works for n positive or negative.
900 (let* ((ord (gensym))
901 (g (simplify (list '(%gamma_incomplete
) (add ord n
) z
))))
902 ($substitute rat-order ord g
)))))))
906 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
907 ;;; Numerical evaluation of the Incomplete Gamma function
909 ;;; gamma-incomplete (a,z) - real and complex double float
910 ;;; bfloat-gamma-incomplete (a z) - bigfloat
911 ;;; complex-bfloat-gamma-incomplete (a z) - complex bigfloat
913 ;;; Expansion in a power series for abs(x) < R, where R is
914 ;;; *gamma-radius* + real(a) if real(a) > 0 or *gamma-radius*
922 ;;; gamma(a,z) = exp(-x)*z^a * > ------------ * z^n
927 ;;; This expansion does not work for an integer a<=0, because the Gamma function
928 ;;; in the denominator is not defined for a=0 and negative integers. For this
929 ;;; case we use the Exponential Integral E for numerically evaluation. The
930 ;;; Incomplete Gamma function and the Exponential integral are connected by
932 ;;; gamma(a,z) = z^a * expintegral_e(1-a,z)
934 ;;; When the series is not used, two forms of the continued fraction
935 ;;; are used. When z is not near the negative real axis use the
936 ;;; continued fractions (A&S 6.5.31):
939 ;;; gamma(a,z) = exp(-z) z^a *( -- --- --- --- --- ... )
942 ;;; The accuracy is controlled by *gamma-incomplete-eps* for double float
943 ;;; precision. For bigfloat precision epsilon is 10^(-$fpprec). The expansions
944 ;;; in a power series or continued fractions stops if *gamma-incomplete-maxit*
945 ;;; is exceeded and an Maxima error is thrown.
947 ;;; The above fraction does not converge on the negative real axis and
948 ;;; converges very slowly near the axis. In this case, use the
951 ;;; gamma(a,z) = gamma(a) - gamma_lower(a,z)
953 ;;; The continued fraction for gamma_incomplete_lower(a,z) is
954 ;;; (http://functions.wolfram.com/06.06.10.0009.01):
956 ;;; gamma_lower(a,z) = exp(-z) * z^a / cf(a,z)
960 ;;; -a*z z (a+1)*z 2*z (a+2)*z
961 ;;; cf(a,z) = a + ---- ---- ------- ---- -------
962 ;;; a+1+ a+2- a+3+ a+4- a+5+
964 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
966 (defvar *gamma-incomplete-maxit
* 10000)
967 (defvar *gamma-incomplete-eps
* (* 2 flonum-epsilon
))
968 (defvar *gamma-incomplete-min
* 1.0e-32)
970 (defvar *gamma-radius
* 1.0
971 "Controls the radius within a series expansion is done.")
972 (defvar *gamma-imag
* 1.0)
974 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
976 ;;; The numerical evaluation for CL float or complex values a and x
977 ;;; When the flag regularized is T, the result is divided by gamma(a) and
978 ;;; Maxima returns the numercial result for gamma_incomplete_regularized
980 (defun gamma-incomplete (a x
&optional
(regularized nil
))
981 (setq x
(+ x
(cond ((complexp x
) #C
(0.0
0.0)) ((realp x
) 0.0))))
984 ;; Compute the factor needed to scale the series or continued
985 ;; fraction. This is x^a*exp(-x) or x^a*exp(-x)/gamma(a)
986 ;; depending on whether we want a non-regularized or
987 ;; regularized form. We want to compute the factor carefully
988 ;; to avoid unnecessary overflow if possible.
990 (or (try-float-computation
992 ;; gammafloat is more accurate for real
995 (/ (* (expt x a
) (exp (- x
)))
998 (/ (* (expt x a
) (exp (- x
)))
1000 ;; Easy way failed. Use logs to compute the
1001 ;; result. This loses some precision, especially
1002 ;; for large values of a and/or x because we use
1003 ;; many bits to hold the exponent part.
1004 (exp (- (* a
(log x
))
1006 (log-gamma-lanczos (if (complexp a
)
1010 (or (try-float-computation
1012 (* (expt x a
) (exp (- x
)))))
1013 ;; Easy way failed, so use the log form.
1014 (exp (- (* a
(log x
))
1016 (multiple-value-bind (result lower-incomplete-tail-p
)
1017 (%gamma-incomplete a x
)
1018 (cond (lower-incomplete-tail-p
1019 ;; %gamma-incomplete compute the lower incomplete gamma
1020 ;; function, so we need to subtract that from gamma(a),
1023 (- 1 (* result factor
)))
1025 (- (gamma-lanczos a
) (* result factor
)))
1027 (- (gammafloat a
) (* result factor
)))))
1029 ;; Continued fraction used. Just multiply by the factor
1030 ;; to get the final result.
1031 (* factor result
))))))
1033 ;; Compute the key part of the gamma incomplete function using either
1034 ;; a series expression or a continued fraction expression. Two values
1035 ;; are returned: the value itself and a boolean, indicating what the
1036 ;; computed value is. If the boolean non-NIL, then the computed value
1037 ;; is the lower incomplete gamma function.
1038 (defun %gamma-incomplete
(a x
)
1039 (let ((gm-maxit *gamma-incomplete-maxit
*)
1040 (gm-eps *gamma-incomplete-eps
*)
1041 (gm-min *gamma-incomplete-min
*))
1043 (format t
"~&GAMMA-INCOMPLETE with ~A and ~A~%" a x
))
1045 ;; The series expansion is done for x within a circle of radius
1046 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1047 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1048 ;; continued fraction is used.
1049 ((and (> (abs x
) (+ *gamma-radius
*
1050 (if (> (realpart a
) 0.0) (realpart a
) 0.0))))
1051 (cond ((and (< (realpart x
) 0)
1052 (< (abs (imagpart x
))
1053 (* *gamma-imag
* (abs (realpart x
)))))
1054 ;; For x near the negative real axis, use the
1055 ;; relationship gamma_incomplete(a,z) = gamma(a) -
1056 ;; gamma_incomplete_lower(a,z), where
1057 ;; gamma_incomplete_lower(a,z) is the lower poart of the
1058 ;; incomplete gamma function. We can evaluate that
1059 ;; using a continued fraction from
1060 ;; http://functions.wolfram.com/06.06.10.0009.01. (Note
1061 ;; that the alternative fraction,
1062 ;; http://functions.wolfram.com/06.06.10.0007.01,
1063 ;; appears to be less accurate.)
1065 ;; Also note that this appears to be valid for all
1066 ;; values of x (real or complex), but we don't want to
1067 ;; use this everywhere for gamma_incomplete. Consider
1068 ;; what happens for large real x. gamma_incomplete(a,x)
1069 ;; is small, but gamma_incomplete(a,x) = gamma(x) - cf
1070 ;; will have large roundoff errors.
1072 (format t
"~&GAMMA-INCOMPLETE in continued fractions for lower integral~%"))
1073 (let ((a (bigfloat:to a
))
1075 (bigfloat::*debug-cf-eval
* *debug-gamma
*)
1076 (bigfloat::*max-cf-iterations
* *gamma-incomplete-maxit
*))
1077 (values (/ (bigfloat::lentz
#'(lambda (n)
1082 (- (* (+ a
(ash n -
1)) x
))))))
1085 ;; Expansion in continued fractions for gamma_incomplete.
1087 (format t
"~&GAMMA-INCOMPLETE in continued fractions~%"))
1089 (an (- a
1.0) (* i
(- a i
)))
1090 (b (+ 3.0 x
(- a
)) (+ b
2.0))
1092 (d (/ 1.0 (- b
2.0)))
1096 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1097 (setq d
(+ (* an d
) b
))
1098 (when (< (abs d
) gm-min
) (setq d gm-min
))
1099 (setq c
(+ b
(/ an c
)))
1100 (when (< (abs c
) gm-min
) (setq c gm-min
))
1104 (when (< (abs (- del
1.0)) gm-eps
)
1105 ;; Return nil to indicate we used the continued fraction.
1106 (return (values h nil
)))))))
1108 ;; Expansion in a series
1110 (format t
"~&GAMMA-INCOMPLETE in series~%"))
1113 (del (/ 1.0 a
) (* del
(/ x ap
)))
1114 (sum del
(+ sum del
)))
1116 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1117 (when (< (abs del
) (* (abs sum
) gm-eps
))
1118 (when *debug-gamma
* (format t
"~&Series converged.~%"))
1119 ;; Return T to indicate we used the series and the series
1120 ;; is for the integral from 0 to x, not x to inf.
1121 (return (values sum t
))))))))
1123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1125 ;;; This function is called for a and x real
1127 (defun bfloat-gamma-incomplete (a x
)
1128 (let* ((gm-maxit *gamma-incomplete-maxit
*)
1129 (gm-eps (power ($bfloat
10.0) (- $fpprec
)))
1130 (gm-min (mul gm-eps gm-eps
))
1133 ;; The series expansion is done for x within a circle of radius
1134 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1135 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1136 ;; continued fraction is used.
1137 ((eq ($sign
(sub (simplify (list '(mabs) x
))
1139 (if (eq ($sign a
) '$pos
) a
0.0))))
1142 ((and (eq ($sign x
) '$pos
))
1143 ;; Expansion in continued fractions of the Incomplete Gamma function
1145 (an (sub a
1.0) (mul i
(sub a i
)))
1146 (b (add 3.0 x
(mul -
1 a
)) (add b
2.0))
1147 (c (div 1.0 gm-min
))
1148 (d (div 1.0 (sub b
2.0)))
1152 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1154 (format t
"~&in continued fractions:~%")
1155 (mformat t
"~& : i = ~M~%" i
)
1156 (mformat t
"~& : h = ~M~%" h
))
1157 (setq d
(add (mul an d
) b
))
1158 (when (eq ($sign
(sub (simplify (list '(mabs) d
)) gm-min
)) '$neg
)
1160 (setq c
(add b
(div an c
)))
1161 (when (eq ($sign
(sub (simplify (list '(mabs) c
)) gm-min
)) '$neg
)
1163 (setq d
(div 1.0 d
))
1164 (setq del
(mul d c
))
1165 (setq h
(mul h del
))
1166 (when (eq ($sign
(sub (simplify (list '(mabs) (sub del
1.0))) gm-eps
))
1171 (power ($bfloat
'$%e
) (mul -
1 x
)))))))
1173 ;; Expand to multiply everything out.
1175 ;; Expansion in continued fraction for the lower incomplete gamma.
1176 (sub (simplify (list '(%gamma
) a
))
1177 ;; NOTE: We want (power x a) instead of bigfloat:expt
1178 ;; because this preserves how maxima computes x^a when
1179 ;; x is negative and a is rational. For, example
1180 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1183 (power ($bfloat
'$%e
) (mul -
1 x
))
1184 (let ((a (bigfloat:to a
))
1185 (x (bigfloat:to x
)))
1192 (bigfloat:* (ash n -
1) x
)
1193 (bigfloat:-
(bigfloat:* (bigfloat:+ a
(ash n -
1))
1197 ;; Series expansion of the Incomplete Gamma function
1200 (del (div 1.0 a
) (mul del
(div x ap
)))
1201 (sum del
(add sum del
)))
1203 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1205 (format t
"~&GAMMA-INCOMPLETE in series:~%")
1206 (mformat t
"~& : i = ~M~%" i
)
1207 (mformat t
"~& : ap = ~M~%" ap
)
1208 (mformat t
"~& : x/ap = ~M~%" (div x ap
))
1209 (mformat t
"~& : del = ~M~%" del
)
1210 (mformat t
"~& : sum = ~M~%" sum
))
1211 (when (eq ($sign
(sub (simplify (list '(mabs) del
))
1212 (mul (simplify (list '(mabs) sum
)) gm-eps
)))
1214 (when *debug-gamma
* (mformat t
"~&Series converged to ~M.~%" sum
))
1216 (sub (simplify (list '(%gamma
) a
))
1220 (power ($bfloat
'$%e
) (mul -
1 x
))))))))))))
1222 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1224 (defun complex-bfloat-gamma-incomplete (a x
)
1225 (let* ((gm-maxit *gamma-incomplete-maxit
*)
1226 (gm-eps (power ($bfloat
10.0) (- $fpprec
)))
1227 (gm-min (mul gm-eps gm-eps
))
1230 (format t
"~&COMPLEX-BFLOAT-GAMMA-INCOMPLETE~%")
1231 (format t
" : a = ~A~%" a
)
1232 (format t
" : x = ~A~%" x
))
1234 ;; The series expansion is done for x within a circle of radius
1235 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1236 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1237 ;; continued fraction is used.
1238 ((and (eq ($sign
(sub (simplify (list '(mabs) x
))
1240 (if (eq ($sign
($realpart a
)) '$pos
)
1245 ((not (and (eq ($sign
($realpart x
)) '$neg
)
1246 (eq ($sign
(sub (simplify (list '(mabs) ($imagpart x
)))
1247 (simplify (list '(mabs) ($realpart x
)))))
1249 ;; Expansion in continued fractions of the Incomplete Gamma function
1251 (format t
"~&in continued fractions:~%"))
1253 (an (sub a
1.0) (mul i
(sub a i
)))
1254 (b (add 3.0 x
(mul -
1 a
)) (add b
2.0))
1255 (c (cdiv 1.0 gm-min
))
1256 (d (cdiv 1.0 (sub b
2.0)))
1260 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1261 (setq d
(add (cmul an d
) b
))
1262 (when (eq ($sign
(sub (simplify (list '(mabs) d
)) gm-min
)) '$neg
)
1264 (setq c
(add b
(cdiv an c
)))
1265 (when (eq ($sign
(sub (simplify (list '(mabs) c
)) gm-min
)) '$neg
)
1267 (setq d
(cdiv 1.0 d
))
1268 (setq del
(cmul d c
))
1269 (setq h
(cmul h del
))
1270 (when (eq ($sign
(sub (simplify (list '(mabs) (sub del
1.0)))
1274 ($bfloat
; force evaluation of expressions with sin or cos
1278 (cpower ($bfloat
'$%e
) ($bfloat
(mul -
1 x
))))))))))
1280 ;; Expand to multiply everything out.
1282 ;; Expansion in continued fraction for the lower incomplete gamma.
1283 (sub ($rectform
(simplify (list '(%gamma
) a
)))
1284 ;; NOTE: We want (power x a) instead of bigfloat:expt
1285 ;; because this preserves how maxima computes x^a when
1286 ;; x is negative and a is rational. For, example
1287 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1289 (mul ($rectform
(power x a
))
1290 ($rectform
(power ($bfloat
'$%e
) (mul -
1 x
)))
1291 (let ((a (bigfloat:to a
))
1292 (x (bigfloat:to x
)))
1299 (bigfloat:* (ash n -
1) x
)
1300 (bigfloat:-
(bigfloat:* (bigfloat:+ a
(ash n -
1))
1303 ;; Series expansion of the Incomplete Gamma function
1305 (format t
"~&GAMMA-INCOMPLETE in series:~%"))
1308 (del (cdiv 1.0 a
) (cmul del
(cdiv x ap
)))
1309 (sum del
(add sum del
)))
1311 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1312 (when (eq ($sign
(sub (simplify (list '(mabs) del
))
1313 (mul (simplify (list '(mabs) sum
)) gm-eps
)))
1315 (when *debug-gamma
* (format t
"~&Series converged.~%"))
1317 ($bfloat
; force evaluation of expressions with sin or cos
1318 (sub (simplify (list '(%gamma
) a
))
1322 (cpower ($bfloat
'$%e
) (mul -
1 x
)))))))))))))
1324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1326 ;;; Implementation of the Generalized Incomplete Gamma function
1331 ;;; gamma_incomplete_generalized(a, z1, z2) = I t %e dt
1336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1338 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1339 ;;; on the negative real axis.
1340 ;;; We support a conjugate-function which test this case.
1342 (defprop %gamma_incomplete_generalized
1343 conjugate-gamma-incomplete-generalized conjugate-function
)
1345 (defun conjugate-gamma-incomplete-generalized (args)
1346 (let ((a (first args
)) (z1 (second args
)) (z2 (third args
)))
1347 (cond ((and (off-negative-real-axisp z1
) (off-negative-real-axisp z2
))
1348 ;; z1 and z2 definitely not on the negative real axis.
1352 '(%gamma_incomplete_generalized
)
1353 (simplify (list '($conjugate
) a
))
1354 (simplify (list '($conjugate
) z1
))
1355 (simplify (list '($conjugate
) z2
)))))
1357 ;; On the negative real axis or no information. Unsimplified.
1360 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
)))))))
1362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1364 ;;; Generalized Incomplete Gamma distributes over bags
1366 (defprop %gamma_incomplete_generalized
(mlist $matrix mequal
) distribute_over
)
1368 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1370 ;;; Differentiation of Generalized Incomplete Gamma function
1372 (defprop %gamma_incomplete_generalized
1374 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1375 ;; and the Generalized Incomplete Gamma function (functions.wolfram.com)
1378 ((mexpt) ((%gamma
) a
) 2)
1380 (($hypergeometric_regularized
)
1382 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1385 ((mexpt) ((%gamma
) a
) 2)
1387 (($hypergeometric_regularized
)
1389 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1392 ((%gamma_incomplete_generalized
) a
0 z1
)
1395 ((%gamma_incomplete_generalized
) a
0 z2
)
1397 ;; The derivative wrt z1
1399 ((mexpt) $%e
((mtimes) -
1 z1
))
1400 ((mexpt) z1
((mplus) -
1 a
)))
1401 ;; The derivative wrt z2
1403 ((mexpt) $%e
((mtimes) -
1 z2
))
1404 ((mexpt) z2
((mplus) -
1 a
))))
1407 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1409 ;;; Generalized Incomplete Gamma function is a simplifying function
1411 (def-simplifier gamma_incomplete_generalized
(a z1 z2
)
1415 ;; Check for specific values
1418 (let ((sgn ($sign
($realpart a
))))
1420 ((member sgn
'($pos $pz
))
1422 (simplify (list '(%gamma_incomplete
) a z1
))
1423 (simplify (list '(%gamma
) a
))))
1428 (let ((sgn ($sign
($realpart a
))))
1430 ((member sgn
'($pos $pz
))
1432 (simplify (list '(%gamma
) a
))
1433 (simplify (list '(%gamma_incomplete
) a z2
))))
1437 ((zerop1 (sub z1 z2
)) 0)
1439 ((eq z2
'$inf
) (simplify (list '(%gamma_incomplete
) a z1
)))
1440 ((eq z1
'$inf
) (mul -
1 (simplify (list '(%gamma_incomplete
) a z2
))))
1442 ;; Check for numerical evaluation in Float or Bigfloat precision
1443 ;; Use the numerical routines of the Incomplete Gamma function
1445 ((float-numerical-eval-p a z1 z2
)
1447 (- (gamma-incomplete ($float a
) ($float z1
))
1448 (gamma-incomplete ($float a
) ($float z2
)))))
1450 ((complex-float-numerical-eval-p a z1 z2
)
1451 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
1452 (cz1 (complex ($float
($realpart z1
)) ($float
($imagpart z1
))))
1453 (cz2 (complex ($float
($realpart z2
)) ($float
($imagpart z2
)))))
1454 (complexify (- (gamma-incomplete ca cz1
) (gamma-incomplete ca cz2
)))))
1456 ((bigfloat-numerical-eval-p a z1 z2
)
1457 (sub (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z1
))
1458 (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z2
))))
1460 ((complex-bigfloat-numerical-eval-p a z1 z2
)
1461 (let ((ca (add ($bfloat
($realpart a
))
1462 (mul '$%i
($bfloat
($imagpart a
)))))
1463 (cz1 (add ($bfloat
($realpart z1
))
1464 (mul '$%i
($bfloat
($imagpart z1
)))))
1465 (cz2 (add ($bfloat
($realpart z2
))
1466 (mul '$%i
($bfloat
($imagpart z2
))))))
1467 (sub (complex-bfloat-gamma-incomplete ca cz1
)
1468 (complex-bfloat-gamma-incomplete ca cz2
))))
1470 ;; Check for transformations and argument simplification
1472 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
1473 ;; Expand gamma_incomplete_generalized(a+n,z1,z2) with n an integer
1475 (a (simplify (cons '(mplus) (cddr a
)))))
1479 (simplify (list '($pochhammer
) a n
))
1481 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
))
1483 (power '$%e
(mul -
1 z1
))
1484 (let ((index (gensumindex)))
1487 (power z1
(add a index -
1))
1488 (simplify (list '($pochhammer
) a index
)))
1491 (power '$%e
(mul -
1 z2
))
1492 (let ((index (gensumindex)))
1495 (power z2
(add a index -
1))
1496 (simplify (list '($pochhammer
) a index
)))
1505 ($factor
(simplify (list '($pochhammer
) (sub 1 a
) n
))))
1506 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
)))
1508 (power '$%e
(mul -
1 z2
))
1509 (let ((index (gensumindex)))
1512 (power z1
(add a index
(- n
) -
1))
1513 (simplify (list '($pochhammer
) (sub a n
) index
)))
1516 (power '$%e
(mul -
1 z2
))
1517 (let ((index (gensumindex)))
1520 (power z2
(add a index
(- n
) -
1))
1521 (simplify (list '($pochhammer
) (sub a n
) index
)))
1526 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1528 ;;; Implementation of the Regularized Incomplete Gamma function
1532 ;;; gamma_incomplete(a, z)
1533 ;;; gamma_incomplete_regularized(a, z) = ----------------------
1536 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1538 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1540 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1541 ;;; on the negative real axis.
1542 ;;; We support a conjugate-function which test this case.
1544 (defprop %gamma_incomplete_regularized
1545 conjugate-gamma-incomplete-regularized conjugate-function
)
1547 (defun conjugate-gamma-incomplete-regularized (args)
1548 (let ((a (first args
)) (z (second args
)))
1549 (cond ((off-negative-real-axisp z
)
1550 ;; z definitely not on the negative real axis. Mirror symmetry.
1553 '(%gamma_incomplete_regularized
)
1554 (simplify (list '($conjugate
) a
))
1555 (simplify (list '($conjugate
) z
)))))
1557 ;; On the negative real axis or no information. Unsimplified.
1560 (simplify (list '(%gamma_incomplete_regularized
) a z
)))))))
1562 ;;; Regularized Incomplete Gamma distributes over bags
1564 (defprop %gamma_incomplete_regularized
(mlist $matrix mequal
) distribute_over
)
1566 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1568 ;;; Differentiation of Regularized Incomplete Gamma function
1570 (defprop %gamma_incomplete_regularized
1572 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1573 ;; and the Regularized Generalized Incomplete Gamma function
1574 ;; (functions.wolfram.com)
1579 (($hypergeometric_regularized
)
1581 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1584 ((%gamma_incomplete_generalized_regularized
) a z
0)
1587 ((mtimes) -
1 ((mqapply) (($psi array
) 0) a
)))))
1588 ;; The derivative wrt z
1591 ((mexpt) $%e
((mtimes) -
1 z
))
1592 ((mexpt) z
((mplus) -
1 a
))
1593 ((mexpt) ((%gamma
) a
) -
1)))
1596 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1598 ;;; Regularized Incomplete Gamma function is a simplifying function
1600 (def-simplifier gamma_incomplete_regularized
(a z
)
1606 ;; Check for specific values
1609 (let ((sgn ($sign
($realpart a
))))
1610 (cond ((member sgn
'($neg $zero
))
1613 "gamma_incomplete_regularized: gamma_incomplete_regularized(~:M,~:M) is undefined.")
1615 ((member sgn
'($pos $pz
)) 1)
1621 ;; Check for numerical evaluation in Float or Bigfloat precision
1623 ((float-numerical-eval-p a z
)
1625 ;; gamma_incomplete returns a regularized result
1626 (gamma-incomplete ($float a
) ($float z
) t
)))
1628 ((complex-float-numerical-eval-p a z
)
1629 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
1630 (cz (complex ($float
($realpart z
)) ($float
($imagpart z
)))))
1631 ;; gamma_incomplete returns a regularized result
1632 (complexify (gamma-incomplete ca cz t
))))
1634 ((bigfloat-numerical-eval-p a z
)
1635 (div (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z
))
1636 (simplify (list '(%gamma
) ($bfloat a
)))))
1638 ((complex-bigfloat-numerical-eval-p a z
)
1639 (let ((ca (add ($bfloat
($realpart a
))
1640 (mul '$%i
($bfloat
($imagpart a
)))))
1641 (cz (add ($bfloat
($realpart z
))
1642 (mul '$%i
($bfloat
($imagpart z
))))))
1645 (complex-bfloat-gamma-incomplete ca cz
)
1646 (simplify (list '(%gamma
) ca
))))))
1648 ;; Check for transformations and argument simplification
1650 ((and $gamma_expand
(integerp a
))
1651 ;; An integer. Expand the expression.
1652 (let ((sgn ($sign a
)))
1654 ((member sgn
'($pos $pz
))
1656 (power '$%e
(mul -
1 z
))
1657 (let ((index (gensumindex)))
1661 (let (($gamma_expand nil
))
1662 (simplify (list '(%gamma
) (add index
1)))))
1663 index
0 (sub a
1)))))
1664 ((member sgn
'($neg $nz
)) 0)
1667 ((and $gamma_expand
(setq ratorder
(max-numeric-ratio-p a
2)))
1668 ;; We have a half integral order and $gamma_expand is not NIL.
1669 ;; We expand in a series with the Erfc function
1670 (setq ratorder
(- ratorder
(/ 1 2)))
1672 (format t
"~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in RATORDER~%")
1673 (format t
"~& : a = ~A~%" a
)
1674 (format t
"~& : ratorder = ~A~%" ratorder
))
1677 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
1681 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))
1683 (power -
1 (sub ratorder
1))
1684 (power '$%e
(mul -
1 z
))
1685 (power z
'((rat simp
) 1 2))
1686 (div 1 (simplify (list '(%gamma
) a
)))
1687 (let ((index (gensumindex)))
1690 (power (mul -
1 z
) index
)
1691 (simplify (list '($pochhammer
)
1692 (sub '((rat simp
) 1 2) ratorder
)
1693 (sub ratorder
(add index
1)))))
1694 index
0 (sub ratorder
1))))))
1697 (setq ratorder
(- ratorder
))
1699 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))
1701 (power '$%e
(mul -
1 z
))
1702 (power z
(sub '((rat simp
) 1 2) ratorder
))
1703 (inv (simplify (list '(%gamma
) (sub '((rat simp
) 1 2) ratorder
))))
1704 (let ((index (gensumindex)))
1708 (simplify (list '($pochhammer
)
1709 (sub '((rat simp
) 1 2) ratorder
)
1711 index
0 (sub ratorder
1))))))))
1713 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
1715 (format t
"~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in COND (mplusp)~%"))
1717 (a (simplify (cons '(mplus) (cddr a
)))))
1721 (simplify (list '(%gamma_incomplete_regularized
) a z
))
1722 ;; We factor the second summand.
1723 ;; Some factors vanish and the result is more readable.
1726 (power '$%e
(mul -
1 z
))
1727 (power z
(add a -
1))
1728 (div 1 (simplify (list '(%gamma
) a
)))
1729 (let ((index (gensumindex)))
1733 (simplify (list '($pochhammer
) a index
)))
1738 (simplify (list '(%gamma_incomplete_regularized
) a z
))
1739 ;; We factor the second summand.
1742 (power '$%e
(mul -
1 z
))
1743 (power z
(sub a
(add n
1)))
1744 (div 1 (simplify (list '(%gamma
) (add a
(- n
)))))
1745 (let ((index (gensumindex)))
1749 (simplify (list '($pochhammer
) (add a
(- n
)) index
)))
1751 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
1752 (integerp (second a
))
1753 (integerp (third a
)))
1754 ;; gamma_incomplete_regularized of numeric rational order.
1755 ;; Expand it out so that the resulting order is between 0 and
1756 ;; 1. Use gamma_incomplete_regularized(a+n,z) to do the dirty
1758 (multiple-value-bind (n order
)
1759 (floor (/ (second a
) (third a
)))
1760 ;; a = n + order where 0 <= order < 1.
1761 (let ((rat-order (rat (numerator order
) (denominator order
))))
1764 ;; Nothing to do if the order is already between 0 and 1
1767 ;; Use gamma_incomplete_regularized(a+n,z) above. and
1768 ;; then substitue a=order. This works for n positive or
1770 (let* ((ord (gensym))
1771 (g (simplify (list '(%gamma_incomplete_regularized
) (add ord n
) z
))))
1772 ($substitute rat-order ord g
)))))))
1776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1778 ;;; Implementation of the Logarithm of the Gamma function
1780 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1782 (defmfun $log_gamma
(z)
1783 (simplify (list '(%log_gamma
) z
)))
1785 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1787 (defprop $log_gamma %log_gamma alias
)
1788 (defprop $log_gamma %log_gamma verb
)
1790 (defprop %log_gamma $log_gamma reversealias
)
1791 (defprop %log_gamma $log_gamma noun
)
1793 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1795 (defprop %log_gamma simp-log-gamma operators
)
1797 ;;; Logarithm of the Gamma function distributes over bags
1799 (defprop %log_gamma
(mlist $matrix mequal
) distribute_over
)
1801 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1805 ((mqapply) (($psi array
) 0) z
))
1808 ;; integrate(log_gamma(x),x) = psi[-2](x)
1809 (defun log-gamma-integral (x)
1810 (take '(mqapply) (take '($psi
) -
2) x
))
1812 (putprop '%log_gamma
(list (list 'x
) #'log-gamma-integral
) 'integral
)
1814 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1816 (defun simp-log-gamma (expr z simpflag
)
1818 (setq z
(simpcheck (cadr expr
) simpflag
))
1821 ;; Check for specific values
1825 (and (eq ($sign z
) '$neg
)
1826 (zerop1 (sub z
($truncate z
))))))
1827 ;; We have zero, a negative integer or a float or bigfloat representation.
1829 (intl:gettext
"log_gamma: log_gamma(~:M) is undefined.") z
))
1831 ((eq z
'$inf
) '$inf
)
1833 ;; Check for numerical evaluation
1835 ((float-numerical-eval-p z
)
1836 (complexify (log-gamma-lanczos (complex ($float z
) 0))))
1838 ((complex-float-numerical-eval-p z
)
1841 (complex ($float
($realpart z
)) ($float
($imagpart z
))))))
1843 ((bigfloat-numerical-eval-p z
)
1844 (bfloat-log-gamma ($bfloat z
)))
1846 ((complex-bigfloat-numerical-eval-p z
)
1847 (complex-bfloat-log-gamma
1848 (add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))
1850 ;; Transform to Logarithm of Factorial for integer values
1851 ;; At this point the integer value is positive and not zero.
1854 (simplify (list '(%log
) (simplify (list '(mfactorial) (- z
1))))))
1856 (t (eqtest (list '(%log_gamma
) z
) expr
))))
1858 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1859 ;;; The functions log-gamma-lanczos, bfloat-log-gamma and
1860 ;;; complex-bfloat-log-gamma are modified versions of the related functions
1861 ;;; gamma-lanczos, bffac and cbffac. The functions return the Logarithm of
1862 ;;; the Gamma function. If we have to calculate the quotient of Gamma functions,
1863 ;;; e. g. for the Beta function, it is much more appropriate to use the
1864 ;;; logarithmic versions to avoid overflow.
1866 ;;; Be careful log(gamma(z)) is only for realpart(z) positive equal to
1867 ;;; log_gamma(z). For a negative realpart(z) log_gamma differ by multiple of
1868 ;;; %pi from log(gamma(z)). But we always have exp(log_gamma(z))= gamma(z).
1869 ;;; The terms to get the transformation for log_gamma(-z) are taken from
1870 ;;; functions.wolfram.com.
1871 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1873 (defun log-gamma-lanczos (z)
1874 (declare (type (complex flonum
) z
)
1875 (optimize (safety 3)))
1876 (let ((c (make-array 15 :element-type
'flonum
1878 '(0.99999999999999709182
1879 57.156235665862923517
1880 -
59.597960355475491248
1881 14.136097974741747174
1882 -
0.49191381609762019978
1883 .33994649984811888699e-4
1884 .46523628927048575665e-4
1885 -
.98374475304879564677e-4
1886 .15808870322491248884e-3
1887 -
.21026444172410488319e-3
1888 .21743961811521264320e-3
1889 -
.16431810653676389022e-3
1890 .84418223983852743293e-4
1891 -
.26190838401581408670e-4
1892 .36899182659531622704e-5))))
1893 (declare (type (simple-array flonum
(15)) c
))
1894 (if (minusp (realpart z
))
1901 (abs (floor (realpart z
)))
1902 (- 1 (abs (signum (imagpart z
)))))
1905 (- (log (sin (* (float pi
) (- z
(floor (realpart z
)))))))
1909 (floor (realpart z
))
1910 (signum (imagpart z
))))
1911 (log-gamma-lanczos z
)))
1914 (zgh (+ zh
607/128))
1915 (lnzp (* (/ zh
2) (log zgh
)))
1918 (pp (1- (length c
)) (1- pp
)))
1921 (incf sum
(/ (aref c pp
) (+ z pp
))))))
1922 (+ (log (sqrt (float (* 2 pi
))))
1923 (log (+ ss
(aref c
0)))
1924 (+ (- zgh
) (* 2 lnzp
)))))))
1926 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1928 (defun bfloat-log-gamma (z)
1929 (let (($ratprint nil
)
1930 (bigfloat%pi
($bfloat
'$%pi
)))
1932 ((eq ($sign z
) '$neg
)
1933 (let ((z (mul -
1 z
)))
1936 (mul -
1 bigfloat%pi
'$%i
1937 (simplify (list '(mabs) (simplify (list '($floor
) ($realpart z
)))))
1940 (list '(mabs) (simplify (list '(%signum
) ($imagpart z
)))))))
1941 (simplify (list '(%log
) bigfloat%pi
))
1942 (mul -
1 (simplify (list '(%log
) (mul -
1 z
))))
1944 (simplify (list '(%log
)
1945 (simplify (list '(%sin
)
1948 (sub z
(simplify (list '($floor
) ($realpart z
))))))))))
1951 (simplify (list '($floor
) ($realpart z
)))
1952 (simplify (list '(%signum
) ($imagpart z
)))))
1953 (bfloat-log-gamma z
))))
1955 (let* ((k (* 2 (+ 1 ($entier
(* 0.41 $fpprec
)))))
1956 (m ($bfloat bigfloatone
))
1959 (x ($bfloat bigfloatzero
))
1961 (dotimes (i (/ k
2))
1962 (setq ii
(* 2 (+ i
1)))
1963 (setq m
(mul m
(add z ii -
2) (add z ii -
1)))
1966 (div ($bern
(+ k
(- ii
) 2))
1967 (* (+ k
(- ii
) 1) (+ k
(- ii
) 2))))
1970 (div (simplify (list '(%log
) (mul 2 bigfloat%pi z
+k
))) 2)
1971 (mul z
+k
(add (simplify (list '(%log
) z
+k
)) x -
1))
1972 (mul -
1 (simplify (list '(%log
) m
)))))))))
1974 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1976 (defun complex-bfloat-log-gamma (z)
1977 (let (($ratprint nil
)
1978 (bigfloat%pi
($bfloat
'$%pi
)))
1980 ((eq ($sign
($realpart z
)) '$neg
)
1981 (let ((z (mul -
1 z
)))
1984 (mul -
1 bigfloat%pi
'$%i
1985 (simplify (list '(mabs) (simplify (list '($floor
) ($realpart z
)))))
1988 (list '(mabs) (simplify (list '(%signum
) ($imagpart z
)))))))
1989 (simplify (list '(%log
) bigfloat%pi
))
1990 (mul -
1 (simplify (list '(%log
) (mul -
1 z
))))
1992 (simplify (list '(%log
)
1993 (simplify (list '(%sin
)
1996 (sub z
(simplify (list '($floor
) ($realpart z
))))))))))
1999 (simplify (list '($floor
) ($realpart z
)))
2000 (simplify (list '(%signum
) ($imagpart z
)))))
2001 (complex-bfloat-log-gamma z
))))
2003 (let* ((k (* 2 (+ 1 ($entier
(* 0.41 $fpprec
)))))
2004 (m ($bfloat bigfloatone
))
2006 (y ($rectform
(power z
+k
2)))
2007 (x ($bfloat bigfloatzero
))
2009 (dotimes (i (/ k
2))
2010 (setq ii
(* 2 (+ i
1)))
2011 (setq m
($rectform
(mul m
(add z ii -
2) (add z ii -
1))))
2015 (div ($bern
(+ k
(- ii
) 2))
2016 (* (+ k
(- ii
) 1) (+ k
(- ii
) 2))))
2020 (div (simplify (list '(%log
) (mul 2 bigfloat%pi z
+k
))) 2)
2021 (mul z
+k
(add (simplify (list '(%log
) z
+k
)) x -
1))
2022 (mul -
1 (simplify (list '(%log
) m
))))))))))
2024 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2026 ;;; Implementation of the Error function Erf(z)
2028 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2030 ;; TODO: This is called by simp-expintegral-e in expintegral.lisp.
2031 ;; Can't remove this until that is fixed.
2033 (simplify (list '(%erf
) z
)))
2035 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2037 ;;; erf has mirror symmetry
2039 (defprop %erf t commutes-with-conjugate
)
2041 ;;; erf is an odd function
2043 (defprop %erf odd-function-reflect reflection-rule
)
2045 ;;; erf distributes over bags
2047 (defprop %erf
(mlist $matrix mequal
) distribute_over
)
2049 ;;; Derivative of the Error function erf
2054 ((mexpt) $%pi
((rat) -
1 2))
2055 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2)))))
2058 ;;; Integral of the Error function erf
2064 ((mexpt) $%pi
((rat) -
1 2))
2065 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2))))
2066 ((mtimes) z
((%erf
) z
))))
2069 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2071 (defun erf-hypergeometric (z)
2072 ; See A&S 7.1.21 or http://functions.wolfram.com/06.25.26.0001.01
2075 (power '$%pi
'((rat simp
) -
1 2))
2076 (list '(%hypergeometric simp
)
2077 (list '(mlist simp
) '((rat simp
) 1 2))
2078 (list '(mlist simp
) '((rat simp
) 3 2))
2079 (mul -
1 (power z
2)))))
2081 ;;; erf is a simplifying function
2083 (def-simplifier erf
(z)
2086 ;; Check for specific values
2092 ;; Check for numerical evaluation
2094 ((float-numerical-eval-p z
)
2095 (bigfloat::bf-erf
($float z
)))
2096 ((complex-float-numerical-eval-p z
)
2098 (bigfloat::bf-erf
(complex ($float
($realpart z
)) ($float
($imagpart z
))))))
2099 ((bigfloat-numerical-eval-p z
)
2100 (to (bigfloat::bf-erf
(bigfloat:to
($bfloat z
)))))
2101 ((complex-bigfloat-numerical-eval-p z
)
2102 (to (bigfloat::bf-erf
2103 (bigfloat:to
(add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))))
2105 ;; Argument simplification
2107 ((taylorize (mop form
) (second form
)))
2109 (not $erf_representation
)
2111 (mul '$%i
(simplify (list '(%erfi
) (coeff z
'$%i
1)))))
2112 ((apply-reflection-simp (mop form
) z $trigsign
))
2114 ;; Representation through more general functions
2116 ($hypergeometric_representation
2117 (erf-hypergeometric z
))
2119 ;; Transformation to Erfc or Erfi
2121 ((and $erf_representation
2122 (not (eq $erf_representation
'$erf
)))
2123 (case $erf_representation
2125 (sub 1 (take '(%erfc
) z
)))
2127 (mul -
1 '$%i
(take '(%erfi
) (mul '$%i z
))))
2134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2137 ;; We use the slatec routine for float values.
2138 (slatec:derf
(float z
)))
2140 ;; Compute erf(z) using the relationship
2142 ;; erf(z) = sqrt(z^2)/z*(1 - gamma_incomplete(1/2,z^2)/sqrt(%pi))
2144 ;; When z is real sqrt(z^2)/z is signum(z). For complex z,
2145 ;; sqrt(z^2)/z = 1 if -%pi/2 < arg(z) <= %pi/2 and -1 otherwise.
2147 ;; This relationship has serious round-off issues when z is small
2148 ;; because gamma_incomplete(1/2,z^2)/sqrt(%pi) is near 1.
2150 ;; complex-erf is for (lisp) complex numbers; bfloat-erf is for real
2151 ;; bfloats, and complex-bfloat-erf is for complex bfloats. Care is
2152 ;; taken to return real results for real arguments and imaginary
2153 ;; results for imaginary arguments
2154 (defun complex-erf (z)
2157 (if (or (< (realpart z
) 0.0) (and (= (realpart z
) 0.0) (< (imagpart z
) 0.0)))
2161 (* (/ (sqrt (float pi
))) (gamma-incomplete 0.5 (* z z
)))))))
2163 ((= (imagpart z
) 0.0)
2164 ;; Pure real argument, the result is real
2165 (complex (realpart result
) 0.0))
2166 ((= (realpart z
) 0.0)
2167 ;; Pure imaginary argument, the result is pure imaginary
2168 (complex 0.0 (imagpart result
)))
2172 (defun bfloat-erf (z)
2173 ;; Warning! This has round-off problems when abs(z) is very small.
2174 (let ((1//2 ($bfloat
'((rat simp
) 1 2))))
2175 ;; The argument is real, the result is real too
2178 (simplify (list '(%signum
) z
))
2181 (div 1 (power ($bfloat
'$%pi
) 1//2))
2182 (bfloat-gamma-incomplete 1//2 ($bfloat
(power z
2)))))))))
2184 (defun complex-bfloat-erf (z)
2185 ;; Warning! This has round-off problems when abs(z) is very small.
2186 (let* (($ratprint nil
)
2187 (1//2 ($bfloat
'((rat simp
) 1 2)))
2190 (cdiv (cpower (cpower z
2) 1//2) z
)
2193 (div 1 (power ($bfloat
'$%pi
) 1//2))
2194 (complex-bfloat-gamma-incomplete
2196 ($bfloat
(cpower z
2))))))))
2198 ((zerop1 ($imagpart z
))
2199 ;; Pure real argument, the result is real
2201 ((zerop1 ($realpart z
))
2202 ;; Pure imaginary argument, the result is pure imaginary
2203 (mul '$%i
($imagpart result
)))
2205 ;; A general complex result
2208 (in-package :bigfloat
)
2210 ;; Erf(z) for all z. Z must be a CL real or complex number or a
2211 ;; BIGFLOAT or COMPLEX-BIGFLOAT object. The result will be of the
2214 (cond ((typep z
'cl
:real
)
2215 ;; Use Slatec derf, which should be faster than the series.
2217 ((<= (abs z
) 0.476936)
2218 ;; Use the series A&S 7.1.5 for small x:
2220 ;; erf(z) = 2*z/sqrt(%pi) * sum((-1)^n*z^(2*n)/n!/(2*n+1), n, 0, inf)
2222 ;; The threshold is approximately erf(x) = 0.5. (Doesn't
2223 ;; have to be super accurate.) This gives max accuracy when
2224 ;; using the identity erf(x) = 1 - erfc(x).
2225 (let ((z^
2 (* z z
)))
2226 (/ (* 2 z
(sum-power-series z^
2
2234 ;; The general case.
2236 (cl:real
(maxima::erf z
))
2237 (cl:complex
(maxima::complex-erf z
))
2239 (bigfloat (maxima::$bfloat
(maxima::$expand
(maxima::bfloat-erf
(maxima::to z
))))))
2241 (bigfloat (maxima::$bfloat
(maxima::$expand
(maxima::complex-bfloat-erf
(maxima::to z
))))))))))
2244 ;; Compute erfc(z) via 1 - erf(z) is not very accurate if erf(z) is
2245 ;; near 1. Wolfram says
2247 ;; erfc(z) = 1 - sqrt(z^2)/z * (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2, z^2))
2249 ;; For real(z) > 0, sqrt(z^2)/z is 1 so
2251 ;; erfc(z) = 1 - (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2252 ;; = 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2)
2254 ;; For real(z) < 0, sqrt(z^2)/z is -1 so
2256 ;; erfc(z) = 1 + (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2257 ;; = 2 - 1/sqrt(pi)*gamma_incomplete(1/2,z^2)
2258 (flet ((gamma-inc (z)
2261 (maxima::gamma-incomplete
0.5 z
))
2263 (bigfloat:to
(maxima::$bfloat
2264 (maxima::bfloat-gamma-incomplete
(maxima::$bfloat maxima
::1//2)
2267 (bigfloat:to
(maxima::$bfloat
2268 (maxima::complex-bfloat-gamma-incomplete
(maxima::$bfloat maxima
::1//2)
2269 (maxima::to z
))))))))
2270 (if (>= (realpart z
) 0)
2271 (/ (gamma-inc (* z z
))
2274 (/ (gamma-inc (* z z
))
2277 (in-package :maxima
)
2279 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2281 ;;; Implementation of the Generalized Error function Erf(z1,z2)
2283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2285 ;;; Generalized Erf has mirror symmetry
2287 (defprop %erf_generalized t commutes-with-conjugate
)
2289 ;;; Generalized Erf distributes over bags
2291 (defprop %erf_generalized
(mlist $matrix mequal
) distribute_over
)
2293 ;;; Generalized Erf is antisymmetric Erf(z1,z2) = - Erf(z2,z1)
2297 #-gcl
(:load-toplevel
:execute
)
2298 (let (($context
'$global
) (context '$global
))
2299 (meval '(($declare
) %erf_generalized $antisymmetric
))
2300 ;; Let's remove built-in symbols from list for user-defined properties.
2301 (setq $props
(remove '%erf_generalized $props
))))
2303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2305 (defprop %erf_generalized
2307 ;; derivative wrt z1
2309 ((mexpt) $%pi
((rat) -
1 2))
2310 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z1
2))))
2311 ;; derviative wrt z2
2313 ((mexpt) $%pi
((rat) -
1 2))
2314 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z2
2)))))
2317 ;;; ----------------------------------------------------------------------------
2319 (defprop %erf_generalized simplim%erf_generalized simplim%function
)
2321 (defun simplim%erf_generalized
(expr var val
)
2322 ;; Look for the limit of the arguments.
2323 (let ((z1 (limit (cadr expr
) var val
'think
))
2324 (z2 (limit (caddr expr
) var val
'think
)))
2326 ;; Handle infinities at this place.
2328 (alike1 z2
'((mtimes) -
1 $minf
)))
2329 (sub 1 (take '(%erf
) z1
)))
2331 (alike1 z2
'((mtimes) -
1 $inf
)))
2332 (sub (mul -
1 (take '(%erf
) z1
)) 1))
2334 (alike1 z1
'((mtimes) -
1 $minf
)))
2335 (sub (take '(%erf
) z2
) 1))
2337 (alike1 z1
'((mtimes) -
1 $inf
)))
2338 (add (take '(%erf
) z2
) 1))
2340 ;; All other cases are handled by the simplifier of the function.
2341 (simplify (list '(%erf_generalized
) z1 z2
))))))
2343 ;;; ----------------------------------------------------------------------------
2345 (def-simplifier erf_generalized
(z1 z2
)
2348 ;; Check for specific values
2350 ((and (zerop1 z1
) (zerop1 z2
)) 0)
2351 ((zerop1 z1
) (take '(%erf
) z2
))
2352 ((zerop1 z2
) (mul -
1 (take '(%erf
) z1
)))
2354 (alike1 z2
'((mtimes) -
1 $minf
)))
2355 (sub 1 (take '(%erf
) z1
)))
2357 (alike1 z2
'((mtimes) -
1 $inf
)))
2358 (sub (mul -
1 (take '(%erf
) z1
)) 1))
2360 (alike1 z1
'((mtimes) -
1 $minf
)))
2361 (sub (take '(%erf
) z2
) 1))
2363 (alike1 z1
'((mtimes) -
1 $inf
)))
2364 (add (take '(%erf
) z2
) 1))
2366 ;; Check for numerical evaluation. Use erf(z1,z2) = erf(z2)-erf(z1)
2368 ((float-numerical-eval-p z1 z2
)
2369 (- (bigfloat::bf-erf
($float z2
))
2370 (bigfloat::bf-erf
($float z1
))))
2371 ((complex-float-numerical-eval-p z1 z2
)
2375 (complex ($float
($realpart z2
)) ($float
($imagpart z2
))))
2377 (complex ($float
($realpart z1
)) ($float
($imagpart z1
)))))))
2378 ((bigfloat-numerical-eval-p z1 z2
)
2380 (bigfloat::bf-erf
(bigfloat:to
($bfloat z2
)))
2381 (bigfloat::bf-erf
(bigfloat:to
($bfloat z1
))))))
2382 ((complex-bigfloat-numerical-eval-p z1 z2
)
2385 (bigfloat:to
(add ($bfloat
($realpart z2
)) (mul '$%i
($bfloat
($imagpart z2
))))))
2387 (bigfloat:to
(add ($bfloat
($realpart z1
)) (mul '$%i
($bfloat
($imagpart z1
)))))))))
2389 ;; Argument simplification
2391 ((and $trigsign
(great (mul -
1 z1
) z1
) (great (mul -
1 z2
) z2
))
2392 (mul -
1 (simplify (list '(%erf_generalized
) (mul -
1 z1
) (mul -
1 z2
)))))
2394 ;; Representation through more general functions
2396 ($hypergeometric_representation
2397 (sub (erf-hypergeometric z2
) (erf-hypergeometric z1
)))
2399 ;; Transformation to Erf
2401 ($erf_representation
2402 (sub (simplify (list '(%erf
) z2
)) (simplify (list '(%erf
) z1
))))
2407 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2409 ;;; Implementation of the Complementary Error function Erfc(z)
2411 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2413 ;; TODO: called by simp-expintegral-e in expintegral.lisp. Need to
2414 ;; keep this around until that is fixed.
2416 (simplify (list '(%erfc
) z
)))
2418 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2420 (defprop %erfc t commutes-with-conjugate
)
2422 ;;; Complementary Error function distributes over bags
2424 (defprop %erfc
(mlist $matrix mequal
) distribute_over
)
2426 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2431 ((mexpt) $%pi
((rat) -
1 2))
2432 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2)))))
2435 ;;; Integral of the Error function erfc
2441 ((mexpt) $%pi
((rat) -
1 2))
2442 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2))))
2443 ((mtimes) z
((%erfc
) z
))))
2446 ;;; ----------------------------------------------------------------------------
2448 (defprop %erfc simplim%erfc simplim%function
)
2450 (defun simplim%erfc
(expr var val
)
2451 ;; Look for the limit of the arguments.
2452 (let ((z (limit (cadr expr
) var val
'think
)))
2454 ;; Handle infinities at this place.
2457 ((eq z
'$infinity
) ;; parallel to code in simplim%erf-%tanh
2458 (destructuring-let (((rpart . ipart
) (trisplit (cadr expr
)))
2460 (setq rlim
(limit rpart var val
'think
))
2462 (limit (m* rpart
(m^t ipart -
1)) var val
'think
))
2463 (setq ans
($asksign
(m+ `((mabs) ,ans
) -
1)))
2464 (cond ((or (eq ans
'$pos
) (eq ans
'$zero
))
2465 (cond ((eq rlim
'$inf
) 0)
2466 ((eq rlim
'$minf
) 2)
2469 ((eq z
'$ind
) '$ind
)
2471 ;; All other cases are handled by the simplifier of the function.
2472 (simplify (list '(%erfc
) z
))))))
2474 ;;; ----------------------------------------------------------------------------
2476 (def-simplifier erfc
(z)
2479 ;; Check for specific values
2485 ;; Check for numerical evaluation.
2487 ((numerical-eval-p z
)
2488 (to (bigfloat::bf-erfc
(bigfloat:to z
))))
2490 ;; Argument simplification
2492 ((taylorize (mop form
) (second form
)))
2493 ((and $trigsign
(great (mul -
1 z
) z
))
2494 (sub 2 (simplify (list '(%erfc
) (mul -
1 z
)))))
2496 ;; Representation through more general functions
2498 ($hypergeometric_representation
2499 (sub 1 (erf-hypergeometric z
)))
2501 ;; Transformation to Erf or Erfi
2503 ((and $erf_representation
2504 (not (eq $erf_representation
'$erfc
)))
2505 (case $erf_representation
2507 (sub 1 (take '(%erf
) z
)))
2509 (add 1 (mul '$%i
(take '(%erfi
) (mul '$%i z
)))))
2516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2518 ;;; Implementation of the Imaginary Error function Erfi(z)
2520 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2522 ;; TODO: Called by integrate-exp-special in sin.lisp. That needs to
2523 ;; be fixed before this can be removed.
2525 (simplify (list '(%erfi
) z
)))
2527 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2529 ;;; erfi has mirror symmetry
2531 (defprop %erfi t commutes-with-conjugate
)
2533 ;;; erfi is an odd function
2535 (defprop %erfi odd-function-reflect reflection-rule
)
2537 ;;; erfi distributes over bags
2539 (defprop %erfi
(mlist $matrix mequal
) distribute_over
)
2541 ;;; Derivative of the Error function erfi
2546 ((mexpt) $%pi
((rat) -
1 2))
2547 ((mexpt) $%e
((mexpt) z
2))))
2550 ;;; Integral of the Error function erfi
2556 ((mexpt) $%pi
((rat) -
1 2))
2557 ((mexpt) $%e
((mexpt) z
2)))
2558 ((mtimes) z
((%erfi
) z
))))
2561 ;;; ----------------------------------------------------------------------------
2563 (defprop %erfi simplim%erfi simplim%function
)
2565 (defun simplim%erfi
(expr var val
)
2566 ;; Look for the limit of the arguments.
2567 (let ((z (limit (cadr expr
) var val
'think
)))
2569 ;; Handle infinities at this place.
2570 ((eq z
'$inf
) '$inf
)
2571 ((eq z
'$minf
) '$minf
)
2573 ;; All other cases are handled by the simplifier of the function.
2574 (simplify (list '(%erfi
) z
))))))
2576 ;;; ----------------------------------------------------------------------------
2578 (in-package :bigfloat
)
2581 ;; Use the relationship erfi(z) = -%i*erf(%i*z)
2582 (let* ((iz (complex (- (imagpart z
)) (realpart z
))) ; %i*z
2583 (result (bf-erf iz
)))
2584 (complex (imagpart result
) (- (realpart result
))))))
2585 ;; Take care to return real results when the argument is real.
2589 (realpart (erfi z
)))
2592 (in-package :maxima
)
2594 ;;; erfi is an simplifying function
2596 (def-simplifier erfi
(z)
2599 ;; Check for specific values
2602 ((eq z
'$inf
) '$inf
)
2603 ((eq z
'$minf
) '$minf
)
2605 ;; Check for numerical evaluation. Use erfi(z) = -%i*erf(%i*z).
2607 ((numerical-eval-p z
)
2608 (to (bigfloat::bf-erfi
(bigfloat:to z
))))
2610 ;; Argument simplification
2612 ((taylorize (mop form
) (second form
)))
2615 (mul '$%i
(simplify (list '(%erf
) (coeff z
'$%i
1)))))
2616 ((apply-reflection-simp (mop form
) z $trigsign
))
2618 ;; Representation through more general functions
2620 ($hypergeometric_representation
2621 (mul -
1 '$%i
(erf-hypergeometric (mul '$%i z
))))
2623 ;; Transformation to Erf or Erfc
2625 ((and $erf_representation
2626 (not (eq $erf_representation
'$erfi
)))
2627 (case $erf_representation
2629 (mul -
1 '$%i
(take '(%erf
) (mul '$%i z
))))
2631 (sub (mul '$%i
(take '(%erfc
) (mul '$%i z
))) '$%i
))
2638 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2640 ;;; The implementation of the Inverse Error function
2642 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2644 ;;; The Inverse Error function distributes over bags
2646 (defprop %inverse_erf
(mlist $matrix mequal
) distribute_over
)
2648 ;;; inverse_erf is the inverse of the erf function
2650 (defprop %inverse_erf %erf $inverse
)
2651 (defprop %erf %inverse_erf $inverse
)
2653 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2655 ;;; Differentiation of the Inverse Error function
2657 (defprop %inverse_erf
2661 ((mexpt) $%pi
((rat) 1 2))
2662 ((mexpt) $%e
((mexpt) ((%inverse_erf
) z
) 2))))
2665 ;;; Integral of the Inverse Error function
2667 (defprop %inverse_erf
2670 ((mexpt) $%pi
((rat) -
1 2))
2671 ((mexpt) $%e
((mtimes) -
1 ((mexpt) ((%inverse_erf
) z
) 2)))))
2674 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2676 ;;; We support a simplim%function. The function is looked up in simplimit and
2677 ;;; handles specific values of the function.
2679 (defprop %inverse_erf simplim%inverse_erf simplim%function
)
2681 (defun simplim%inverse_erf
(expr var val
)
2682 ;; Look for the limit of the argument.
2683 (let ((z (limit (cadr expr
) var val
'think
)))
2685 ;; Handle an argument 1 at this place
2687 ((onep1 (mul -
1 z
)) '$minf
)
2689 ;; All other cases are handled by the simplifier of the function.
2690 (simplify (list '(%inverse_erf
) z
))))))
2692 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2694 ;;; The Inverse Error function is a simplifying function
2696 (def-simplifier inverse_erf
(z)
2701 (intl:gettext
"inverse_erf: inverse_erf(~:M) is undefined.") z
))
2703 ((numerical-eval-p z
)
2704 (to (bigfloat::bf-inverse-erf
(bigfloat:to z
))))
2705 ((taylorize (mop form
) (cadr form
)))
2709 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2711 ;;; The implementation of the Inverse Complementary Error function
2713 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2715 ;;; Inverse Complementary Error function distributes over bags
2717 (defprop %inverse_erfc
(mlist $matrix mequal
) distribute_over
)
2719 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2721 ;;; inverse_erfc is the inverse of the erfc function
2723 (defprop %inverse_erfc %erfc $inverse
)
2724 (defprop %erfc %inverse_erfc $inverse
)
2727 ;;; Differentiation of the Inverse Complementary Error function
2729 (defprop %inverse_erfc
2733 ((mexpt) $%pi
((rat) 1 2))
2734 ((mexpt) $%e
((mexpt) ((%inverse_erfc
) z
) 2))))
2737 ;;; Integral of the Inverse Complementary Error function
2739 (defprop %inverse_erfc
2742 ((mexpt) $%pi
((rat) -
1 2))
2744 ((mtimes) -
1 ((mexpt) ((%inverse_erfc
) z
) 2)))))
2747 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2749 ;;; We support a simplim%function. The function is looked up in simplimit and
2750 ;;; handles specific values of the function.
2752 (defprop %inverse_erfc simplim%inverse_erfc simplim%function
)
2754 (defun simplim%inverse_erfc
(expr var val
)
2755 ;; Look for the limit of the argument.
2756 (let ((z (limit (cadr expr
) var val
'think
)))
2758 ;; Handle an argument 0 at this place
2763 ((zerop1 (add z -
2)) '$minf
)
2765 ;; All other cases are handled by the simplifier of the function.
2766 (simplify (list '(%inverse_erfc
) z
))))))
2768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2770 ;;; Inverse Complementary Error function is a simplifying function
2771 (def-simplifier inverse_erfc
(z)
2774 (zerop1 (add z -
2)))
2776 (intl:gettext
"inverse_erfc: inverse_erfc(~:M) is undefined.") z
))
2778 ((numerical-eval-p z
)
2779 (to (bigfloat::bf-inverse-erfc
(bigfloat:to z
))))
2780 ((taylorize (mop form
) (cadr form
)))
2784 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2786 ;;; Implementation of the Newton algorithm to calculate numerical values
2787 ;;; of the Inverse Error functions in float or bigfloat precision.
2788 ;;; The algorithm is a modified version of the routine in newton1.mac.
2790 (defvar *debug-newton
* nil
)
2791 (defvar *newton-maxcount
* 1000)
2792 (defvar *newton-epsilon-factor
* 50)
2793 (defvar *newton-epsilon-factor-float
* 10)
2795 (defun float-newton (expr var x0 eps
)
2796 (do ((s (sdiff expr var
))
2799 (count 0 (+ count
1)))
2800 ((> count
*newton-maxcount
*)
2802 (intl:gettext
"float-newton: Newton does not converge for ~:M") expr
))
2803 (setq sn
($float
(maxima-substitute xn var expr
)))
2804 (when (< (abs sn
) eps
) (return xn
))
2805 (when *debug-newton
* (format t
"~&xn = ~A~%" xn
))
2806 (setq xn
($float
(sub xn
(div sn
(maxima-substitute xn var s
)))))))
2808 (defun bfloat-newton (expr var x0 eps
)
2809 (do ((s (sdiff expr var
))
2812 (count 0 (+ count
1)))
2813 ((> count
*newton-maxcount
*)
2815 (intl:gettext
"bfloat-newton: Newton does not converge for ~:M") expr
))
2816 (setq sn
($bfloat
(maxima-substitute xn var expr
)))
2817 (when (eq ($sign
(sub (simplify (list '(mabs) sn
)) eps
)) '$neg
)
2819 (when *debug-newton
* (format t
"~&xn = ~A~%" xn
))
2820 (setq xn
($bfloat
(sub xn
(div sn
(maxima-substitute xn var s
)))))))
2823 (in-package :bigfloat
)
2825 ;; Compute inverse_erf(z) for z a real or complex number, including
2826 ;; bigfloat objects. The value is computing using a Newton iteration
2827 ;; to solve erf(x) = z.
2828 (defun bf-inverse-erf (z)
2833 (intl:gettext
"bf-inverse-erf: inverse_erf(~M) is undefined")
2835 ((minusp (realpart z
))
2836 ;; inverse_erf is odd because erf is.
2837 (- (bf-inverse-erf (- z
))))
2841 ;; Find an approximate solution for x = inverse_erf(z).
2843 (cond ((<= (abs z
) 1)
2844 ;; For small z, inverse_erf(z) = z*sqrt(%pi)/2
2845 ;; + O(z^3). Thus, x = z*sqrt(%pi)/2 is our
2846 ;; initial starting point.
2847 (* z
(sqrt (%pi z
)) 1/2))
2849 ;; For |z| > 1 and realpart(z) >= 0, we have
2850 ;; the asymptotic series z = erf(x) = 1 -
2851 ;; exp(-x^2)/x/sqrt(%pi).
2854 ;; x = sqrt(-log(x*sqrt(%pi)*(1-z))
2856 ;; We can use this as a fixed-point iteration
2857 ;; to find x, and we can start the iteration at
2858 ;; x = 1. Just do one more iteration. I (RLT)
2859 ;; think that's close enough to get the Newton
2860 ;; algorithm to converge.
2861 (let* ((sp (sqrt (%pi z
)))
2862 (a (sqrt (- (log (* sp
(- 1 z
)))))))
2863 (setf a
(sqrt (- (log (* a sp
(- 1 z
))))))
2864 (setf a
(sqrt (- (log (* a sp
(- 1 z
)))))))))))
2865 (when maxima
::*debug-newton
*
2866 (format t
"approx = ~S~%" result
))
2868 (let ((two/sqrt-pi
(/ 2 (sqrt (%pi z
))))
2870 ;; Try to pick a reasonable epsilon value for the
2871 ;; Newton iteration.
2872 (cond ((<= (abs z
) 1)
2874 (cl:real
(* maxima
::*newton-epsilon-factor-float
*
2875 maxima
::flonum-epsilon
))
2876 (t (* maxima
::*newton-epsilon-factor
* (epsilon z
)))))
2878 (* maxima
::*newton-epsilon-factor
* (epsilon z
))))))
2879 (when maxima
::*debug-newton
*
2880 (format t
"eps = ~S~%" eps
))
2882 ;; Derivative of erf(x)
2883 (* two
/sqrt-pi
(exp (- (* x x
))))))
2890 (defun bf-inverse-erfc (z)
2893 (intl:gettext
"bf-inverse-erfc: inverse_erfc(~M) is undefined")
2900 ;; Find an approximate solution for x =
2901 ;; inverse_erfc(z). We have inverse_erfc(z) =
2902 ;; inverse_erf(1-z), so that's a good starting point.
2903 ;; We don't need full precision, so a float value is
2904 ;; good enough. But if 1-z is 1, inverse_erf is
2905 ;; undefined, so we need to do something else.
2907 (let ((1-z (float (- 1 z
) 0.0)))
2909 (if (minusp (realpart z
))
2910 (bf-inverse-erf (+ 1 (* 5 maxima
::flonum-epsilon
)))
2911 (bf-inverse-erf (- 1 (* 5 maxima
::flonum-epsilon
)))))
2913 (bf-inverse-erf 1-z
))))))
2914 (when maxima
::*debug-newton
*
2915 (format t
"approx = ~S~%" result
))
2917 (let ((-two/sqrt-pi
(/ -
2 (sqrt (%pi z
))))
2918 (eps (* maxima
::*newton-epsilon-factor
* (epsilon z
))))
2919 (when maxima
::*debug-newton
*
2920 (format t
"eps = ~S~%" eps
))
2922 ;; Derivative of erfc(x)
2923 (* -two
/sqrt-pi
(exp (- (* x x
))))))
2924 (bf-newton #'bf-erfc
2930 ;; Newton iteration for solving f(x) = z, given f and the derivative
2932 (defun bf-newton (f df z start eps
)
2934 (delta (/ (- (funcall f start
) z
)
2936 (/ (- (funcall f x
) z
)
2938 (count 0 (1+ count
)))
2939 ((or (< (abs delta
) (* (abs x
) eps
))
2940 (> count maxima
::*newton-maxcount
*))
2941 (if (> count maxima
::*newton-maxcount
*)
2943 (intl:gettext
"bf-newton: failed to converge after ~M iterations: delta = ~S, x = ~S eps = ~S")
2946 (when maxima
::*debug-newton
*
2947 (format t
"x = ~S, abs(delta) = ~S relerr = ~S~%"
2948 x
(abs delta
) (/ (abs delta
) (abs x
))))
2949 (setf x
(- x delta
))))
2951 (in-package :maxima
)
2953 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2955 ;;; Implementation of the Fresnel Integral S(z)
2957 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2959 ;;; fresnel_s distributes over bags
2961 (defprop %fresnel_s
(mlist $matrix mequal
) distribute_over
)
2963 ;;; fresnel_s has mirror symmetry
2965 (defprop %fresnel_s t commutes-with-conjugate
)
2967 ;;; fresnel_s is an odd function
2969 ;;; Maxima has two mechanism to define a reflection property
2970 ;;; 1. Declare the feature oddfun or evenfun
2971 ;;; 2. Put a reflection rule on the property list
2973 ;;; The second way is used for the trig functions. We use it here too.
2975 ;;; This would be the first way to give the property of an odd function.
2978 ; #-gcl (:load-toplevel :execute)
2979 ; (let (($context '$global) (context '$global))
2980 ; (meval '(($declare) %fresnel_s $oddfun))
2981 ; ;; Let's remove built-in symbols from list for user-defined properties.
2982 ; (setq $props (remove '%fresnel_s $props))))
2984 (defprop %fresnel_s odd-function-reflect reflection-rule
)
2986 ;;; Differentiation of the Fresnel Integral S
2990 ((%sin
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))
2993 ;;; Integration of the Fresnel Integral S
2998 ((mtimes) z
((%fresnel_s
) z
))
3001 ((%cos
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))))
3004 ;;; Limits of the Fresnel Integral S
3006 (defprop %fresnel_s simplim%fresnel_s simplim%function
)
3007 (defun simplim%fresnel_s
(exp var val
)
3008 (let ((arg (limit (cadr exp
) var val
'think
)))
3009 (cond ((eq arg
'$inf
)
3014 `((%fresnel_s
) ,arg
)))))
3016 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3018 (defvar *fresnel-maxit
* 1000)
3019 (defvar *fresnel-eps
* (* 2 flonum-epsilon
))
3020 (defvar *fresnel-min
* 1e-32)
3022 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3023 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3025 (in-package :bigfloat
)
3027 (defun bf-fresnel (z)
3028 (let* ((eps (epsilon z
))
3029 (maxit maxima
::*fresnel-maxit
*)
3032 ;; For very small x, we have
3033 ;; fresnel_s(x) = %pi/6*z^3
3035 (s (* (/ bf-pi
6) z z z
))
3037 (when (> (abs z
) eps
)
3040 (when maxima
::*debug-gamma
*
3041 (format t
"~& in FRESNEL series expansion.~%"))
3042 (let ((sums 0) (sumc z
))
3045 (fact (* (/ bf-pi
2) (* z z
)))
3052 (maxima::merror
(intl:gettext
"fresnel: series expansion failed for (COMPLEX-BFLOAT-FRESNEL ~:M).") z
))
3053 (setq term
(* term
(/ fact k
)))
3054 (setq sum
(+ sum
(/ (* sign term
) n
)))
3055 (setq test
(* (abs sum
) eps
))
3058 (setq sign
(- sign
))
3064 (if (< (abs term
) test
)
3069 (let* ((sqrt-pi (sqrt bf-pi
))
3070 (z+ (* (complex 1/2 1/2)
3073 (z- (* (complex 1/2 -
1/2)
3078 (setq s
(* (complex 1/4 1/4)
3079 (+ erf
+ (* (complex 0 -
1) erf-
))))
3080 (setq c
(* (complex 1/4 -
1/4)
3081 (+ erf
+ (* (complex 0 1) erf-
))))))))
3084 (defun bf-fresnel-s (z)
3085 (if (and (complexp z
) (zerop (realpart z
)))
3086 ;; A pure imaginary argument. Use fresnel_s(%i*x)=-%i*fresnel_s(x).
3088 (- (bf-fresnel-s (imagpart z
))))
3089 (let ((fs (bf-fresnel z
)))
3094 (defun bf-fresnel-c (z)
3095 (if (and (complexp z
) (zerop (realpart z
)))
3096 ;; A pure imaginary argument. Use fresnel_c(%i*x)=%i*fresnel_c(x).
3098 (bf-fresnel-c (imagpart z
)))
3099 (let ((fc (nth-value 1 (bf-fresnel z
))))
3104 (in-package :maxima
)
3106 ;;; fresnel_s is a simplifying function
3107 (def-simplifier fresnel_s
(z)
3110 ;; Check for specific values
3113 ((eq z
'$inf
) '((rat simp
) 1 2))
3114 ((eq z
'$minf
) '((rat simp
) -
1 2))
3116 ;; Check for numerical evaluation
3117 ((numerical-eval-p z
)
3118 (to (bigfloat::bf-fresnel-s
(bigfloat::to z
))))
3120 ;; Check for argument simplification
3122 ((taylorize (mop form
) (second form
)))
3123 ((and $%iargs
(multiplep z
'$%i
))
3124 (mul -
1 '$%i
(simplify (list '(%fresnel_s
) (coeff z
'$%i
1)))))
3125 ((apply-reflection-simp (mop form
) z $trigsign
))
3127 ;; Representation through equivalent functions
3129 ($erf_representation
3131 (div (add 1 '$%i
) 4)
3136 (mul (div (add 1 '$%i
) 2) (power '$%pi
'((rat simp
) 1 2)) z
)))
3141 (mul (div (sub 1 '$%i
) 2)
3142 (power '$%pi
'((rat simp
) 1 2)) z
)))))))
3144 ($hypergeometric_representation
3145 (mul (div (mul '$%pi
(power z
3)) 6)
3146 (take '($hypergeometric
)
3147 (list '(mlist) (div 3 4))
3148 (list '(mlist) (div 3 2) (div 7 4))
3149 (mul -
1 (div (mul (power '$%pi
2) (power z
4)) 16)))))
3153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3155 ;;; Implementation of the Fresnel Integral C(z)
3157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3159 ;;; fresnel_c distributes over bags
3161 (defprop %fresnel_c
(mlist $matrix mequal
) distribute_over
)
3163 ;;; fresnel_c has mirror symmetry
3165 (defprop %fresnel_c t commutes-with-conjugate
)
3167 ;;; fresnel_c is an odd function
3168 ;;; Maxima has two mechanism to define a reflection property
3169 ;;; 1. Declare the feature oddfun or evenfun
3170 ;;; 2. Put a reflection rule on the property list
3172 ;;; The second way is used for the trig functions. We use it here too.
3174 (defprop %fresnel_c odd-function-reflect reflection-rule
)
3176 ;;; Differentiation of the Fresnel Integral C
3180 ((%cos
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))
3183 ;;; Integration of the Fresnel Integral C
3188 ((mtimes) z
((%fresnel_c
) z
))
3191 ((%sin
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))))
3194 ;;; Limits of the Fresnel Integral C
3196 (defprop %fresnel_c simplim%fresnel_c simplim%function
)
3197 (defun simplim%fresnel_c
(exp var val
)
3198 (let ((arg (limit (cadr exp
) var val
'think
)))
3199 (cond ((eq arg
'$inf
)
3204 `((%fresnel_c
) ,arg
)))))
3206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3208 ;;; fresnel_c is a simplifying function
3209 (def-simplifier fresnel_c
(z)
3212 ;; Check for specific values
3215 ((eq z
'$inf
) '((rat simp
) 1 2))
3216 ((eq z
'$minf
) '((rat simp
) -
1 2))
3218 ;; Check for numerical evaluation
3219 ((numerical-eval-p z
)
3220 (to (bigfloat::bf-fresnel-c
(bigfloat::to z
))))
3223 ;; Check for argument simplification
3225 ((taylorize (mop form
) (second form
)))
3226 ((and $%iargs
(multiplep z
'$%i
))
3227 (mul '$%i
(simplify (list '(%fresnel_c
) (coeff z
'$%i
1)))))
3228 ((apply-reflection-simp (mop form
) z $trigsign
))
3230 ;; Representation through equivalent functions
3232 ($erf_representation
3234 (div (sub 1 '$%i
) 4)
3239 (mul (div (add 1 '$%i
) 2) (power '$%pi
'((rat simp
) 1 2)) z
)))
3244 (mul (div (sub 1 '$%i
) 2)
3245 (power '$%pi
'((rat simp
) 1 2)) z
)))))))
3247 ($hypergeometric_representation
3249 (take '($hypergeometric
)
3250 (list '(mlist) (div 1 4))
3251 (list '(mlist) (div 1 2) (div 5 4))
3252 (mul -
1 (div (mul (power '$%pi
2) (power z
4)) 16)))))
3256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3258 ;;; Implementation of the Beta function
3260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3262 ;;; The code for the implementation of the beta function is in the files
3263 ;;; csimp2.lisp, simp.lisp and mactex.lisp.
3264 ;;; At this place we only implement the operator property SYMMETRIC.
3266 ;;; Beta is symmetric beta(a,b) = beta(b,a)
3270 #-gcl
(:load-toplevel
:execute
)
3271 (let (($context
'$global
) (context '$global
))
3272 (meval '(($declare
) $beta $symmetric
))
3273 ;; Let's remove built-in symbols from list for user-defined properties.
3274 (setq $props
(remove '$beta $props
))))
3276 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3278 ;;; Implementation of the Incomplete Beta function
3280 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3282 (defvar *beta-incomplete-maxit
* 10000)
3283 (defvar *beta-incomplete-eps
* 1.0e-15)
3285 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3287 ;;; beta_incomplete distributes over bags
3289 (defprop %beta_incomplete
(mlist $matrix mequal
) distribute_over
)
3291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3293 (defprop %beta_incomplete
3297 ((mtimes) ((%beta_incomplete
) a b z
) ((%log
) z
))
3299 ((mexpt) ((%gamma
) a
) 2)
3300 (($hypergeometric_regularized
)
3301 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3302 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3310 ((mqapply) (($psi array
) 0) b
)
3311 ((mtimes) -
1 ((mqapply) (($psi array
) 0) ((mplus) a b
)))))
3313 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z
)))
3314 ((%log
) ((mplus) 1 ((mtimes) -
1 z
))))
3316 ((mexpt) ((%gamma
) b
) 2)
3317 (($hypergeometric_regularized
)
3318 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3319 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3320 ((mplus) 1 ((mtimes) -
1 z
)))
3321 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) b
)))
3322 ;; The derivative wrt z
3324 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) ((mplus) -
1 b
))
3325 ((mexpt) z
((mplus) -
1 a
))))
3328 ;;; Integral of the Incomplete Beta function
3330 (defprop %beta_incomplete
3335 ((mtimes) -
1 ((%beta_incomplete
) ((mplus) 1 a
) b z
))
3336 ((mtimes) ((%beta_incomplete
) a b z
) z
)))
3339 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3341 (def-simplifier beta_incomplete
(a b z
)
3344 (format t
"~&SIMP-BETA-INCOMPLETE:~%")
3345 (format t
"~& : a = ~A~%" a
)
3346 (format t
"~& : b = ~A~%" b
)
3347 (format t
"~& : z = ~A~%" z
))
3350 ;; Check for specific values
3353 (let ((sgn ($sign
($realpart a
))))
3354 (cond ((member sgn
'($neg $zero
))
3357 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.")
3359 ((member sgn
'($pos $pz
))
3364 ((and (onep1 z
) (eq ($sign
($realpart b
)) '$pos
))
3365 ;; z=1 and realpart(b)>0. Simplify to a Beta function.
3366 ;; If we have to evaluate numerically preserve the type.
3368 ((complex-float-numerical-eval-p a b z
)
3369 (simplify (list '($beta
) ($float a
) ($float b
))))
3370 ((complex-bigfloat-numerical-eval-p a b z
)
3371 (simplify (list '($beta
) ($bfloat a
) ($bfloat b
))))
3373 (simplify (list '($beta
) a b
)))))
3376 (and (integer-representation-p a
)
3377 (eq ($sign a
) '$neg
)
3379 (not (integer-representation-p b
)))
3380 (eq ($sign
(add a b
)) '$pos
))))
3381 ;; The argument a is zero or a is negative and the argument b is
3382 ;; not in a valid range. Beta incomplete is undefined.
3383 ;; It would be more correct to return Complex infinity.
3386 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.") a b z
))
3388 ;; Check for numerical evaluation in Float or Bigfloat precision
3390 ((complex-float-numerical-eval-p a b z
)
3392 ((not (and (integer-representation-p a
) (< a
0.0)))
3393 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0))))
3394 (beta-incomplete ($float a
) ($float b
) ($float z
))))
3396 ;; Negative integer a and b is in a valid range. Expand.
3398 (beta-incomplete-expand-negative-integer
3399 (truncate a
) ($float b
) ($float z
))))))
3401 ((complex-bigfloat-numerical-eval-p a b z
)
3403 ((not (and (integer-representation-p a
) (eq ($sign a
) '$neg
)))
3404 (let ((*beta-incomplete-eps
*
3405 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
3406 (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z
))))
3408 ;; Negative integer a and b is in a valid range. Expand.
3410 (beta-incomplete-expand-negative-integer
3411 ($truncate a
) ($bfloat b
) ($bfloat z
))))))
3413 ;; Argument simplifications and transformations
3417 (or (not (integerp a
))
3419 ;; Expand for b a positive integer and a not a negative integer.
3421 (simplify (list '($beta
) a b
))
3423 (let ((index (gensumindex)))
3427 (simplify (list '($pochhammer
) a index
))
3428 (power (sub 1 z
) index
))
3429 (simplify (list '(mfactorial) index
)))
3430 index
0 (sub b
1)))))
3432 ((and (integerp a
) (plusp a
))
3433 ;; Expand for a a positive integer.
3435 (simplify (list '($beta
) a b
))
3439 (let ((index (gensumindex)))
3443 (simplify (list '($pochhammer
) b index
))
3445 (simplify (list '(mfactorial) index
)))
3446 index
0 (sub a
1)))))))
3448 ((and (integerp a
) (minusp a
) (integerp b
) (plusp b
) (<= b
(- a
)))
3449 ;; Expand for a a negative integer and b an integer with b <= -a.
3452 (let ((index (gensumindex)))
3455 (mul (simplify (list '($pochhammer
) (sub 1 b
) index
))
3458 (simplify (list '(mfactorial) index
))))
3459 index
0 (sub b
1)))))
3461 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
3463 (a (simplify (cons '(mplus) (cddr a
)))))
3467 (simplify (list '($pochhammer
) a n
))
3468 (simplify (list '($pochhammer
) (add a b
) n
)))
3469 (ftake '%beta_incomplete a b z
))
3471 (power (add a b n -
1) -
1)
3472 (let ((index (gensumindex)))
3476 (simplify (list '($pochhammer
)
3477 (add 1 (mul -
1 a
) (mul -
1 n
))
3479 (simplify (list '($pochhammer
)
3480 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
3482 (mul (power (sub 1 z
) b
)
3483 (power z
(add a n
(mul -
1 index
) -
1))))
3484 index
0 (sub n
1)))))))
3486 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
3487 (let ((n (- (cadr a
)))
3488 (a (simplify (cons '(mplus) (cddr a
)))))
3492 (simplify (list '($pochhammer
) (add 1 (mul -
1 a
) (mul -
1 b
)) n
))
3493 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3494 (ftake '%beta_incomplete a b z
))
3498 (list '($pochhammer
) (add 2 (mul -
1 a
) (mul -
1 b
)) (sub n
1)))
3499 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3500 (let ((index (gensumindex)))
3504 (simplify (list '($pochhammer
) (sub 1 a
) index
))
3505 (simplify (list '($pochhammer
)
3506 (add 2 (mul -
1 a
) (mul -
1 b
))
3508 (mul (power (sub 1 z
) b
)
3509 (power z
(add a
(mul -
1 index
) -
1))))
3510 index
0 (sub n
1)))))))
3515 (defun beta-incomplete-expand-negative-integer (a b z
)
3518 (let ((index (gensumindex)) ($simpsum t
))
3521 (mul (simplify (list '($pochhammer
) (sub 1 b
) index
))
3523 (mul (add index a
) (simplify (list '(mfactorial) index
))))
3524 index
0 (sub b
1)))))
3526 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3528 (defun beta-incomplete (a b z
)
3530 ((eq ($sign
(sub (mul ($realpart z
) ($realpart
(add a b
2)))
3531 ($realpart
(add a
1))))
3535 (simplify (list '($beta
) a b
))
3536 (to (numeric-beta-incomplete b a
(sub 1.0 z
))))))
3538 (to (numeric-beta-incomplete a b z
)))))
3540 (defun numeric-beta-incomplete (a b z
)
3542 (format t
"~&NUMERIC-BETA-INCOMPLETE enters continued fractions~%"))
3543 (let ((a (bigfloat:to a
))
3545 (z (bigfloat:to z
)))
3546 (do* ((beta-maxit *beta-incomplete-maxit
*)
3547 (beta-eps *beta-incomplete-eps
*)
3548 (beta-min (bigfloat:* beta-eps beta-eps
))
3549 (ab (bigfloat:+ a b
))
3550 (ap (bigfloat:+ a
1.0))
3551 (am (bigfloat:- a
1.0))
3553 (d (bigfloat:-
1.0 (bigfloat:/ (bigfloat:* z ab
) ap
)))
3554 (d (if (bigfloat:< (bigfloat:abs d
) beta-min
) beta-min d
))
3555 (d (bigfloat:/ 1.0 d
))
3562 (merror (intl:gettext
"beta_incomplete: continued fractions failed for beta_incomplete(~:M, ~:M, ~:M).") a b z
))
3564 (setq aa
(bigfloat:/ (bigfloat:* m z
(bigfloat:- b m
))
3565 (bigfloat:* (bigfloat:+ am m2
)
3566 (bigfloat:+ a m2
))))
3567 (setq d
(bigfloat:+ 1.0 (bigfloat:* aa d
)))
3568 (when (bigfloat:< (bigfloat:abs d
) beta-min
) (setq d beta-min
))
3569 (setq c
(bigfloat:+ 1.0 (bigfloat:/ aa c
)))
3570 (when (bigfloat:< (bigfloat:abs c
) beta-min
) (setq c beta-min
))
3571 (setq d
(bigfloat:/ 1.0 d
))
3572 (setq h
(bigfloat:* h d c
))
3573 (setq aa
(bigfloat:/ (bigfloat:* -
1
3575 (bigfloat:+ ab m
) z
)
3576 (bigfloat:* (bigfloat:+ a m2
)
3577 (bigfloat:+ ap m2
))))
3578 (setq d
(bigfloat:+ 1.0 (bigfloat:* aa d
)))
3579 (when (bigfloat:< (bigfloat:abs d
) beta-min
) (setq d beta-min
))
3580 (setq c
(bigfloat:+ 1.0 (bigfloat:/ aa c
)))
3581 (when (bigfloat:< (bigfloat:abs c
) beta-min
) (setq c beta-min
))
3582 (setq d
(bigfloat:/ 1.0 d
))
3583 (setq de
(bigfloat:* d c
))
3584 (setq h
(bigfloat:* h de
))
3585 (when (bigfloat:< (bigfloat:abs
(bigfloat:- de
1.0)) beta-eps
)
3587 (format t
"~&Continued fractions finished.~%")
3588 (format t
"~& z = ~A~%" z
)
3589 (format t
"~& a = ~A~%" a
)
3590 (format t
"~& b = ~A~%" b
)
3591 (format t
"~& h = ~A~%" h
))
3597 (bigfloat:expt
(bigfloat:-
1.0 z
) b
)) a
)))
3599 (format t
"~& result = ~A~%" result
))
3602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3604 ;;; Implementation of the Generalized Incomplete Beta function
3606 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3608 ;;; beta_incomplete_generalized distributes over bags
3610 (defprop %beta_incomplete_generalized
(mlist $matrix mequal
) distribute_over
)
3612 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3614 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
3615 ;;; but not on the negative real axis and for z1 or z2 real and > 1.
3616 ;;; We support a conjugate-function which test these cases.
3618 (defprop %beta_incomplete_generalized
3619 conjugate-beta-incomplete-generalized conjugate-function
)
3621 (defun conjugate-beta-incomplete-generalized (args)
3622 (let ((a (first args
))
3626 (cond ((and (off-negative-real-axisp z1
)
3627 (not (and (zerop1 ($imagpart z1
))
3628 (eq ($sign
(sub ($realpart z1
) 1)) '$pos
)))
3629 (off-negative-real-axisp z2
)
3630 (not (and (zerop1 ($imagpart z2
))
3631 (eq ($sign
(sub ($realpart z2
) 1)) '$pos
))))
3634 '(%beta_incomplete_generalized
)
3635 (simplify (list '($conjugate
) a
))
3636 (simplify (list '($conjugate
) b
))
3637 (simplify (list '($conjugate
) z1
))
3638 (simplify (list '($conjugate
) z2
)))))
3642 (simplify (list '(%beta_incomplete_generalized
)
3645 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3647 (defprop %beta_incomplete_generalized
3652 ((%beta_incomplete
) a b z1
)
3655 ((mexpt) ((%gamma
) a
) 2)
3658 (($hypergeometric_regularized
)
3659 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3660 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3664 (($hypergeometric_regularized
)
3665 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3666 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3669 ((mtimes) ((%beta_incomplete
) a b z2
) ((%log
) z2
)))
3673 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z1
)))
3674 ((%log
) ((mplus) 1 ((mtimes) -
1 z1
))))
3676 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z2
)))
3677 ((%log
) ((mplus) 1 ((mtimes) -
1 z2
))))
3679 ((mexpt) ((%gamma
) b
) 2)
3682 (($hypergeometric_regularized
)
3683 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3684 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3685 ((mplus) 1 ((mtimes) -
1 z1
)))
3686 ((mexpt) ((mplus) 1 ((mtimes) -
1 z1
)) b
))
3688 (($hypergeometric_regularized
)
3689 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3690 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3691 ((mplus) 1 ((mtimes) -
1 z2
)))
3692 ((mexpt) ((mplus) 1 ((mtimes) -
1 z2
)) b
)))))
3693 ;; The derivative wrt z1
3696 ((mplus) 1 ((mtimes) -
1 z1
))
3698 ((mexpt) z1
((mplus) -
1 a
)))
3699 ;; The derivative wrt z2
3702 ((mplus) 1 ((mtimes) -
1 z2
))
3704 ((mexpt) z2
((mplus) -
1 a
))))
3707 ;;; Integral of the Incomplete Beta function
3709 (defprop %beta_incomplete_generalized
3715 ((%beta_incomplete
) ((mplus) 1 a
) b z1
)
3716 ((mtimes) ((%beta_incomplete_generalized
) a b z1 z2
) z1
))
3720 ((%beta_incomplete
) ((mplus) 1 a
) b z2
))
3721 ((mtimes) ((%beta_incomplete_generalized
) a b z1 z2
) z2
)))
3724 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3726 (def-simplifier beta_incomplete_generalized
(a b z1 z2
)
3730 ;; Check for specific values
3733 (let ((sgn ($sign
($realpart a
))))
3734 (cond ((eq sgn
'$neg
)
3737 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3739 ((member sgn
'($pos $pz
))
3740 (mul -
1 (ftake '%beta_incomplete a b z1
)))
3745 (let ((sgn ($sign
($realpart a
))))
3746 (cond ((eq sgn
'$neg
)
3749 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3751 ((member sgn
'($pos $pz
))
3752 (mul -
1 (ftake '%beta_incomplete a b z2
)))
3756 ((and (onep1 z2
) (or (not (mnump a
)) (not (mnump b
)) (not (mnump z1
))))
3757 (let ((sgn ($sign
($realpart b
))))
3758 (cond ((member sgn
'($pos $pz
))
3759 (sub (simplify (list '($beta
) a b
))
3760 (ftake '%beta_incomplete a b z1
)))
3764 ((and (onep1 z1
) (or (not (mnump a
)) (not (mnump b
)) (not (mnump z2
))))
3765 (let ((sgn ($sign
($realpart b
))))
3766 (cond ((member sgn
'($pos $pz
))
3767 (sub (ftake '%beta_incomplete a b z2
)
3768 (simplify (list '($beta
) a b
))))
3772 ;; Check for numerical evaluation in Float or Bigfloat precision
3774 ((complex-float-numerical-eval-p a b z1 z2
)
3775 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0))))
3776 (sub (beta-incomplete ($float a
) ($float b
) ($float z2
))
3777 (beta-incomplete ($float a
) ($float b
) ($float z1
)))))
3779 ((complex-bigfloat-numerical-eval-p a b z1 z2
)
3780 (let ((*beta-incomplete-eps
*
3781 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
3782 (sub (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z2
))
3783 (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z1
)))))
3785 ;; Check for argument simplifications and transformations
3787 ((and (integerp a
) (plusp a
))
3789 (simplify (list '($beta
) a b
))
3792 (power (sub 1 z1
) b
)
3793 (let ((index (gensumindex)))
3797 (simplify (list '($pochhammer
) b index
))
3799 (simplify (list '(mfactorial) index
)))
3800 index
0 (sub a
1))))
3802 (power (sub 1 z2
) b
)
3803 (let ((index (gensumindex)))
3807 (simplify (list '($pochhammer
) b index
))
3809 (simplify (list '(mfactorial) index
)))
3810 index
0 (sub a
1)))))))
3812 ((and (integerp b
) (plusp b
))
3814 (simplify (list '($beta
) a b
))
3818 (let ((index (gensumindex)))
3822 (simplify (list '($pochhammer
) a index
))
3823 (power (sub 1 z2
) index
))
3824 (simplify (list '(mfactorial) index
)))
3825 index
0 (sub b
1))))
3828 (let ((index (gensumindex)))
3832 (simplify (list '($pochhammer
) a index
))
3833 (power (sub 1 z1
) index
))
3834 (simplify (list '(mfactorial) index
)))
3835 index
0 (sub b
1)))))))
3837 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
3839 (a (simplify (cons '(mplus) (cddr a
)))))
3843 (simplify (list '($pochhammer
) a n
))
3844 (simplify (list '($pochhammer
) (add a b
) n
)))
3845 (take '(%beta_incomplete_generalized
) a b z1 z2
))
3847 (power (add a b n -
1) -
1)
3848 (let ((index (gensumindex)))
3852 (simplify (list '($pochhammer
)
3853 (add 1 (mul -
1 a
) (mul -
1 n
))
3855 (simplify (list '($pochhammer
)
3856 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
3859 (mul (power (sub 1 z1
) b
)
3860 (power z1
(add a n
(mul -
1 index
) -
1)))
3861 (mul (power (sub 1 z2
) b
)
3862 (power z2
(add a n
(mul -
1 index
) -
1)))))
3863 index
0 (sub n
1)))))))
3865 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
3866 (let ((n (- (cadr a
)))
3867 (a (simplify (cons '(mplus) (cddr a
)))))
3871 (simplify (list '($pochhammer
) (add 1 (mul -
1 a
) (mul -
1 b
)) n
))
3872 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3873 (take '(%beta_incomplete_generalized
) a b z1 z2
))
3877 (list '($pochhammer
) (add 2 (mul -
1 a
) (mul -
1 b
)) (sub n
1)))
3878 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3879 (let ((index (gensumindex)))
3883 (simplify (list '($pochhammer
) (sub 1 a
) index
))
3884 (simplify (list '($pochhammer
)
3885 (add 2 (mul -
1 a
) (mul -
1 b
))
3888 (mul (power (sub 1 z2
) b
)
3889 (power z2
(add a
(mul -
1 index
) -
1)))
3890 (mul (power (sub 1 z1
) b
)
3891 (power z1
(add a
(mul -
1 index
) -
1)))))
3892 index
0 (sub n
1)))))))
3897 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3899 ;;; Implementation of the Regularized Incomplete Beta function
3901 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3903 ;;; beta_incomplete_regularized distributes over bags
3905 (defprop %beta_incomplete_regularized
(mlist $matrix mequal
) distribute_over
)
3907 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3909 (defprop %beta_incomplete_regularized
3915 (($hypergeometric_regularized
)
3916 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3917 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
)) z
)
3918 ((mexpt) ((%gamma
) b
) -
1)
3919 ((%gamma
) ((mplus) a b
))
3922 ((%beta_incomplete_regularized
) a b z
)
3924 ((mtimes) -
1 ((mqapply) (($psi array
) 0) a
))
3925 ((mqapply) (($psi array
) 0) ((mplus) a b
))
3930 ((%beta_incomplete_regularized
) b a
((mplus) 1 ((mtimes) -
1 z
)))
3932 ((mqapply) (($psi array
) 0) b
)
3933 ((mtimes) -
1 ((mqapply) (($psi array
) 0) ((mplus) a b
)))
3934 ((mtimes) -
1 ((%log
) ((mplus) 1 ((mtimes) -
1 z
))))))
3936 ((mexpt) ((%gamma
) a
) -
1)
3938 ((%gamma
) ((mplus) a b
))
3939 (($hypergeometric_regularized
)
3940 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3941 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3942 ((mplus) 1 ((mtimes) -
1 z
)))
3943 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) b
)))
3944 ;; The derivative wrt z
3946 ((mexpt) (($beta
) a b
) -
1)
3947 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) ((mplus) -
1 b
))
3948 ((mexpt) z
((mplus) -
1 a
))))
3951 ;;; Integral of the Generalized Incomplete Beta function
3953 (defprop %beta_incomplete_regularized
3960 ((%beta_incomplete_regularized
) ((mplus) 1 a
) b z
)
3961 ((mexpt) ((mplus) a b
) -
1))
3962 ((mtimes) ((%beta_incomplete_regularized
) a b z
) z
)))
3965 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3967 (def-simplifier beta_incomplete_regularized
(a b z
)
3971 ;; Check for specific values
3974 (let ((sgn ($sign
($realpart a
))))
3975 (cond ((eq sgn
'$neg
)
3978 "beta_incomplete_regularized: beta_incomplete_regularized(~:M,~:M,~:M) is undefined.")
3980 ((member sgn
'($pos $pz
))
3989 (let ((sgn ($sign
($realpart b
))))
3990 (cond ((member sgn
'($pos $pz
))
3995 ((and (integer-representation-p b
)
3996 (if ($bfloatp b
) (minusp (cadr b
)) (minusp b
)) )
3997 ;; Problem: for b a negative integer the Regularized Incomplete
3998 ;; Beta function is defined to be zero. BUT: When we calculate
3999 ;; e.g. beta_incomplete(1.0,-2.0,1/2)/beta(1.0,-2.0) we get the
4000 ;; result -3.0, because beta_incomplete and beta are defined for
4001 ;; for this case. How do we get a consistent behaviour?
4004 ((and (integer-representation-p a
)
4005 (if ($bfloatp a
) (minusp (cadr a
)) (minusp a
)) )
4007 ;; TODO: The following line does not work for bigfloats.
4008 ((and (integer-representation-p b
) (<= b
(- a
)))
4009 ;; Does $beta_incomplete or simpbeta underflow in this case?
4010 (div (ftake '%beta_incomplete a b z
)
4011 (simplify (list '($beta
) a b
))))
4015 ;; Check for numerical evaluation in Float or Bigfloat precision
4017 ((complex-float-numerical-eval-p a b z
)
4018 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0)))
4020 (setq a
($float a
) b
($float b
))
4021 (if (or (< ($abs
(setq beta
(simplify (list '($beta
) a b
)))) 1e-307)
4022 (< ($abs
(setq ibeta
(beta-incomplete a b
($float z
)))) 1e-307) )
4023 ;; In case of underflow (see bug #2999) or precision loss use bigfloats
4024 ;; and emporarily give some extra precision but avoid fpprec dependency.
4025 ;; Is this workaround correct for complex values?
4027 ($float
(take '(%beta_incomplete_regularized
) ($bfloat a
) ($bfloat b
) z
)) )
4028 ($rectform
(div ibeta beta
)) )))
4030 ((complex-bigfloat-numerical-eval-p a b z
)
4031 (let ((*beta-incomplete-eps
*
4032 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
4033 (setq a
($bfloat a
) b
($bfloat b
))
4035 (div (beta-incomplete a b
($bfloat z
))
4036 (simplify (list '($beta
) a b
))))))
4038 ;; Check for argument simplifications and transformations
4040 ((and (integerp b
) (plusp b
))
4041 (div (ftake '%beta_incomplete a b z
)
4042 (simplify (list '($beta
) a b
))))
4044 ((and (integerp a
) (plusp a
))
4045 (div (ftake '%beta_incomplete a b z
)
4046 (simplify (list '($beta
) a b
))))
4048 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
4050 (a (simplify (cons '(mplus) (cddr a
)))))
4052 (take '(%beta_incomplete_regularized
) a b z
)
4054 (power (add a b n -
1) -
1)
4055 (power (simplify (list '($beta
) (add a n
) b
)) -
1)
4056 (let ((index (gensumindex)))
4060 (simplify (list '($pochhammer
)
4061 (add 1 (mul -
1 a
) (mul -
1 n
))
4063 (simplify (list '($pochhammer
)
4064 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
4067 (power z
(add a n
(mul -
1 index
) -
1)))
4068 index
0 (sub n
1)))))))
4070 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
4071 (let ((n (- (cadr a
)))
4072 (a (simplify (cons '(mplus) (cddr a
)))))
4074 (take '(%beta_incomplete_regularized
) a b z
)
4076 (power (add a b -
1) -
1)
4077 (power (simplify (list '($beta
) a b
)) -
1)
4078 (let ((index (gensumindex)))
4082 (simplify (list '($pochhammer
) (sub 1 a
) index
))
4083 (simplify (list '($pochhammer
)
4084 (add 2 (mul -
1 a
) (mul -
1 b
))
4087 (power z
(add a
(mul -
1 index
) -
1)))
4088 index
0 (sub n
1)))))))
4093 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;