1 | ;;;; -*- Mode: lisp -*- |
---|
2 | ;;;; |
---|
3 | ;;;; Copyright (c) 2011 Raymond Toy |
---|
4 | ;;;; Permission is hereby granted, free of charge, to any person |
---|
5 | ;;;; obtaining a copy of this software and associated documentation |
---|
6 | ;;;; files (the "Software"), to deal in the Software without |
---|
7 | ;;;; restriction, including without limitation the rights to use, |
---|
8 | ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell |
---|
9 | ;;;; copies of the Software, and to permit persons to whom the |
---|
10 | ;;;; Software is furnished to do so, subject to the following |
---|
11 | ;;;; conditions: |
---|
12 | ;;;; |
---|
13 | ;;;; The above copyright notice and this permission notice shall be |
---|
14 | ;;;; included in all copies or substantial portions of the Software. |
---|
15 | ;;;; |
---|
16 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
---|
17 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES |
---|
18 | ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND |
---|
19 | ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT |
---|
20 | ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, |
---|
21 | ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING |
---|
22 | ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR |
---|
23 | ;;;; OTHER DEALINGS IN THE SOFTWARE. |
---|
24 | |
---|
25 | (in-package #:oct) |
---|
26 | |
---|
27 | ;;; References: |
---|
28 | ;;; |
---|
29 | ;;; [1] Borwein, Borwein, Crandall, "Effective Laguerre Asymptotics", |
---|
30 | ;;; http://people.reed.edu/~crandall/papers/Laguerre-f.pdf |
---|
31 | ;;; |
---|
32 | ;;; [2] Borwein, Borwein, Chan, "The Evaluation of Bessel Functions |
---|
33 | ;;; via Exp-Arc Integrals", http://web.cs.dal.ca/~jborwein/bessel.pdf |
---|
34 | ;;; |
---|
35 | |
---|
36 | (defvar *debug-exparc* nil) |
---|
37 | |
---|
38 | ;; B[k](p) = 1/2^(k+3/2)*integrate(exp(-p*u)*u^(k-1/2),u,0,1) |
---|
39 | ;; = 1/2^(k+3/2)/p^(k+1/2)*integrate(t^(k-1/2)*exp(-t),t,0,p) |
---|
40 | ;; = 1/2^(k+3/2)/p^(k+1/2) * g(k+1/2, p) |
---|
41 | ;; |
---|
42 | ;; where G(a,z) is the lower incomplete gamma function. |
---|
43 | ;; |
---|
44 | ;; There is the continued fraction expansion for G(a,z) (see |
---|
45 | ;; cf-incomplete-gamma in qd-gamma.lisp): |
---|
46 | ;; |
---|
47 | ;; G(a,z) = z^a*exp(-z)/ CF |
---|
48 | ;; |
---|
49 | ;; So |
---|
50 | ;; |
---|
51 | ;; B[k](p) = 1/2^(k+3/2)/p^(k+1/2)*p^(k+1/2)*exp(-p)/CF |
---|
52 | ;; = exp(-p)/2^(k+3/2)/CF |
---|
53 | ;; |
---|
54 | ;; |
---|
55 | ;; Note also that [2] gives a recurrence relationship for B[k](p) in |
---|
56 | ;; eq (2.6), but there is an error there. The correct relationship is |
---|
57 | ;; |
---|
58 | ;; B[k](p) = -exp(-p)/(p*sqrt(2)*2^(k+1)) + (k-1/2)*B[k-1](p)/(2*p) |
---|
59 | ;; |
---|
60 | ;; The paper is missing the division by p in the term containing |
---|
61 | ;; B[k-1](p). This is easily derived from the recurrence relationship |
---|
62 | ;; for the (lower) incomplete gamma function. |
---|
63 | ;; |
---|
64 | ;; Note too that as k increases, the recurrence appears to be unstable |
---|
65 | ;; and B[k](p) begins to increase even though it is strictly bounded. |
---|
66 | ;; (This is also easy to see from the integral.) Hence, we do not use |
---|
67 | ;; the recursion. However, it might be stable for use with |
---|
68 | ;; double-float precision; this has not been tested. |
---|
69 | ;; |
---|
70 | (defun bk (k p) |
---|
71 | (/ (exp (- p)) |
---|
72 | (* (sqrt (float 2 (realpart p))) (ash 1 (+ k 1))) |
---|
73 | (let ((a (float (+ k 1/2) (realpart p)))) |
---|
74 | (lentz #'(lambda (n) |
---|
75 | (+ n a)) |
---|
76 | #'(lambda (n) |
---|
77 | (if (evenp n) |
---|
78 | (* (ash n -1) p) |
---|
79 | (- (* (+ a (ash n -1)) p)))))))) |
---|
80 | |
---|
81 | ;; exp-arc I function, as given in the Laguerre paper |
---|
82 | ;; |
---|
83 | ;; I(p, q) = 4*exp(p) * sum(g[k](-2*%i*q)/(2*k)!*B[k](p), k, 0, inf) |
---|
84 | ;; |
---|
85 | ;; where g[k](p) = product(p^2+(2*j-1)^2, j, 1, k) and B[k](p) as above. |
---|
86 | ;; |
---|
87 | ;; For computation, note that g[k](p) = g[k-1](p) * (p^2 + (2*k-1)^2) |
---|
88 | ;; and (2*k)! = (2*k-2)! * (2*k-1) * (2*k). Then, let |
---|
89 | ;; |
---|
90 | ;; R[k](p) = g[k](p)/(2*k)! |
---|
91 | ;; |
---|
92 | ;; Then |
---|
93 | ;; |
---|
94 | ;; R[k](p) = g[k](p)/(2*k)! |
---|
95 | ;; = g[k-1](p)/(2*k-2)! * (p^2 + (2*k-1)^2)/((2*k-1)*(2*k) |
---|
96 | ;; = R[k-1](p) * (p^2 + (2*k-1)^2)/((2*k-1)*(2*k) |
---|
97 | ;; |
---|
98 | ;; In the exp-arc paper, the function is defined (equivalently) as |
---|
99 | ;; |
---|
100 | ;; I(p, q) = 2*%i*exp(p)/q * sum(r[2*k+1](-2*%i*q)/(2*k)!*B[k](p), k, 0, inf) |
---|
101 | ;; |
---|
102 | ;; where r[2*k+1](p) = p*product(p^2 + (2*j-1)^2, j, 1, k) |
---|
103 | ;; |
---|
104 | ;; Let's note some properties of I(p, q). |
---|
105 | ;; |
---|
106 | ;; I(-%i*z, v) = 2*%i*exp(-%i*z)/q * sum(r[2*k+1](-2*%i*v)/(2*k)!*B[k](-%i*z)) |
---|
107 | ;; |
---|
108 | ;; Note thate B[k](-%i*z) = 1/2^(k+3/2)*integrate(exp(%i*z*u)*u^(k-1/2),u,0,1) |
---|
109 | ;; = conj(B[k](%i*z). |
---|
110 | ;; |
---|
111 | ;; Hence I(-%i*z, v) = conj(I(%i*z, v)) when both z and v are real. |
---|
112 | (defun exp-arc-i (p q) |
---|
113 | (let* ((sqrt2 (sqrt (float 2 (realpart p)))) |
---|
114 | (exp/p/sqrt2 (/ (exp (- p)) p sqrt2)) |
---|
115 | (v (* #c(0 -2) q)) |
---|
116 | (v2 (expt v 2)) |
---|
117 | (eps (epsilon (realpart p)))) |
---|
118 | (when *debug-exparc* |
---|
119 | (format t "sqrt2 = ~S~%" sqrt2) |
---|
120 | (format t "exp/p/sqrt2 = ~S~%" exp/p/sqrt2)) |
---|
121 | (do* ((k 0 (1+ k)) |
---|
122 | (bk (/ (incomplete-gamma 1/2 p) |
---|
123 | 2 sqrt2 (sqrt p)) |
---|
124 | (- (/ (* bk (- k 1/2)) 2 p) |
---|
125 | (/ exp/p/sqrt2 (ash 1 (+ k 1))))) |
---|
126 | ;; ratio[k] = r[2*k+1](v)/(2*k)!. |
---|
127 | ;; r[1] = v and r[2*k+1](v) = r[2*k-1](v)*(v^2 + (2*k-1)^2) |
---|
128 | ;; ratio[0] = v |
---|
129 | ;; and ratio[k] = r[2*k-1](v)*(v^2+(2*k-1)^2) / ((2*k-2)! * (2*k-1) * 2*k) |
---|
130 | ;; = ratio[k]*(v^2+(2*k-1)^2)/((2*k-1) * 2 * k) |
---|
131 | (ratio v |
---|
132 | (* ratio (/ (+ v2 (expt (1- (* 2 k)) 2)) |
---|
133 | (* 2 k (1- (* 2 k)))))) |
---|
134 | (term (* ratio bk) |
---|
135 | (* ratio bk)) |
---|
136 | (sum term (+ sum term))) |
---|
137 | ((< (abs term) (* (abs sum) eps)) |
---|
138 | (* sum #c(0 2) (/ (exp p) q))) |
---|
139 | (when *debug-exparc* |
---|
140 | (format t "k = ~D~%" k) |
---|
141 | (format t " bk = ~S~%" bk) |
---|
142 | (format t " ratio = ~S~%" ratio) |
---|
143 | (format t " term = ~S~%" term) |
---|
144 | (format t " sum - ~S~%" sum))))) |
---|
145 | |
---|
146 | (defun exp-arc-i-2 (p q) |
---|
147 | (let* ((sqrt2 (sqrt (float 2 (realpart p)))) |
---|
148 | (exp/p/sqrt2 (/ (exp (- p)) p sqrt2)) |
---|
149 | (v (* #c(0 -2) q)) |
---|
150 | (v2 (expt v 2)) |
---|
151 | (eps (epsilon (realpart p)))) |
---|
152 | (when *debug-exparc* |
---|
153 | (format t "sqrt2 = ~S~%" sqrt2) |
---|
154 | (format t "exp/p/sqrt2 = ~S~%" exp/p/sqrt2)) |
---|
155 | (do* ((k 0 (1+ k)) |
---|
156 | (bk (bk 0 p) |
---|
157 | (bk k p)) |
---|
158 | (ratio v |
---|
159 | (* ratio (/ (+ v2 (expt (1- (* 2 k)) 2)) |
---|
160 | (* 2 k (1- (* 2 k)))))) |
---|
161 | (term (* ratio bk) |
---|
162 | (* ratio bk)) |
---|
163 | (sum term (+ sum term))) |
---|
164 | ((< (abs term) (* (abs sum) eps)) |
---|
165 | (* sum #c(0 2) (/ (exp p) q))) |
---|
166 | (when *debug-exparc* |
---|
167 | (format t "k = ~D~%" k) |
---|
168 | (format t " bk = ~S~%" bk) |
---|
169 | (format t " ratio = ~S~%" ratio) |
---|
170 | (format t " term = ~S~%" term) |
---|
171 | (format t " sum - ~S~%" sum))))) |
---|
172 | |
---|
173 | |
---|
174 | ;; |
---|
175 | (defun integer-bessel-j-exp-arc (v z) |
---|
176 | (let* ((iz (* #c(0 1) z)) |
---|
177 | (i+ (exp-arc-i-2 iz v))) |
---|
178 | (cond ((= v (ftruncate v)) |
---|
179 | ;; We can simplify the result |
---|
180 | (let ((c (cis (* v (float-pi i+) -1/2)))) |
---|
181 | (/ (+ (* c i+) |
---|
182 | (* (conjugate c) (conjugate i+))) |
---|
183 | (float-pi i+) |
---|
184 | 2))) |
---|
185 | (t |
---|
186 | (let ((i- (exp-arc-i-2 (- iz ) v))) |
---|
187 | (/ (+ (* (cis (* v (float-pi i+) -1/2)) |
---|
188 | i+) |
---|
189 | (* (cis (* v (float-pi i+) 1/2)) |
---|
190 | i-)) |
---|
191 | (float-pi i+) |
---|
192 | 2)))))) |
---|
193 | |
---|
194 | ;; alpha[n](z) = integrate(exp(-z*s)*s^n, s, 0, 1/2) |
---|
195 | ;; beta[n](z) = integrate(exp(-z*s)*s^n, s, -1/2, 1/2) |
---|
196 | ;; |
---|
197 | ;; The recurrence in [2] is |
---|
198 | ;; |
---|
199 | ;; alpha[n](z) = - exp(-z/2)/2^n/z + n/z*alpha[n-1](z) |
---|
200 | ;; beta[n]z) = ((-1)^n*exp(z/2)-exp(-z/2))/2^n/z + n/z*beta[n-1](z) |
---|
201 | ;; |
---|
202 | ;; We also note that |
---|
203 | ;; |
---|
204 | ;; alpha[n](z) = G(n+1,z/2)/z^(n+1) |
---|
205 | ;; beta[n](z) = G(n+1,z/2)/z^(n+1) - G(n+1,-z/2)/z^(n+1) |
---|
206 | |
---|
207 | (defun alpha (n z) |
---|
208 | (let ((n (float n (realpart z)))) |
---|
209 | (/ (cf-incomplete-gamma (1+ n) (/ z 2)) |
---|
210 | (expt z (1+ n))))) |
---|
211 | |
---|
212 | (defun beta (n z) |
---|
213 | (let ((n (float n (realpart z)))) |
---|
214 | (/ (- (cf-incomplete-gamma (1+ n) (/ z 2)) |
---|
215 | (cf-incomplete-gamma (1+ n) (/ z -2))) |
---|
216 | (expt z (1+ n))))) |
---|
217 | |
---|
218 | ;; a[0](k,v) := (k+sqrt(k^2+1))^(-v); |
---|
219 | ;; a[1](k,v) := -v*a[0](k,v)/sqrt(k^2+1); |
---|
220 | ;; a[n](k,v) := 1/(k^2+1)/(n-1)/n*((v^2-(n-2)^2)*a[n-2](k,v)-k*(n-1)*(2*n-3)*a[n-1](k,v)); |
---|
221 | |
---|
222 | ;; Convert this to iteration instead of using this quick-and-dirty |
---|
223 | ;; memoization? |
---|
224 | (let ((hash (make-hash-table :test 'equal))) |
---|
225 | (defun an-clrhash () |
---|
226 | (clrhash hash)) |
---|
227 | (defun an-dump-hash () |
---|
228 | (maphash #'(lambda (k v) |
---|
229 | (format t "~S -> ~S~%" k v)) |
---|
230 | hash)) |
---|
231 | (defun an (n k v) |
---|
232 | (or (gethash (list n k v) hash) |
---|
233 | (let ((result |
---|
234 | (cond ((= n 0) |
---|
235 | (expt (+ k (sqrt (float (1+ (* k k)) (realpart v)))) (- v))) |
---|
236 | ((= n 1) |
---|
237 | (- (/ (* v (an 0 k v)) |
---|
238 | (sqrt (float (1+ (* k k)) (realpart v)))))) |
---|
239 | (t |
---|
240 | (/ (- (* (- (* v v) (expt (- n 2) 2)) (an (- n 2) k v)) |
---|
241 | (* k (- n 1) (+ n n -3) (an (- n 1) k v))) |
---|
242 | (+ 1 (* k k)) |
---|
243 | (- n 1) |
---|
244 | n))))) |
---|
245 | (setf (gethash (list n k v) hash) result) |
---|
246 | result)))) |
---|
247 | |
---|
248 | ;; SUM-AN computes the series |
---|
249 | ;; |
---|
250 | ;; sum(exp(-k*z)*a[n](k,v), k, 1, N) |
---|
251 | ;; |
---|
252 | (defun sum-an (big-n n v z) |
---|
253 | (let ((sum 0)) |
---|
254 | (loop for k from 1 upto big-n |
---|
255 | do |
---|
256 | (incf sum (* (exp (- (* k z))) |
---|
257 | (an n k v)))) |
---|
258 | sum)) |
---|
259 | |
---|
260 | ;; SUM-AB computes the series |
---|
261 | ;; |
---|
262 | ;; sum(alpha[n](z)*a[n](0,v) + beta[n](z)*sum_an(N, n, v, z), n, 0, inf) |
---|
263 | (defun sum-ab (big-n v z) |
---|
264 | (let ((eps (epsilon (realpart z)))) |
---|
265 | (an-clrhash) |
---|
266 | (do* ((n 0 (+ 1 n)) |
---|
267 | (term (+ (* (alpha n z) (an n 0 v)) |
---|
268 | (* (beta n z) (sum-an big-n n v z))) |
---|
269 | (+ (* (alpha n z) (an n 0 v)) |
---|
270 | (* (beta n z) (sum-an big-n n v z)))) |
---|
271 | (sum term (+ sum term))) |
---|
272 | ((<= (abs term) (* eps (abs sum))) |
---|
273 | sum) |
---|
274 | (when nil |
---|
275 | (format t "n = ~D~%" n) |
---|
276 | (format t " term = ~S~%" term) |
---|
277 | (format t " sum = ~S~%" sum))))) |
---|
278 | |
---|
279 | ;; Convert to iteration instead of this quick-and-dirty memoization? |
---|
280 | (let ((hash (make-hash-table :test 'equal))) |
---|
281 | (defun %big-a-clrhash () |
---|
282 | (clrhash hash)) |
---|
283 | (defun %big-a-dump-hash () |
---|
284 | (maphash #'(lambda (k v) |
---|
285 | (format t "~S -> ~S~%" k v)) |
---|
286 | hash)) |
---|
287 | (defun %big-a (n v) |
---|
288 | (or (gethash (list n v) hash) |
---|
289 | (let ((result |
---|
290 | (cond ((zerop n) |
---|
291 | (expt 2 (- v))) |
---|
292 | (t |
---|
293 | (* (%big-a (- n 1) v) |
---|
294 | (/ (* (+ v n n -2) (+ v n n -1)) |
---|
295 | (* 4 n (+ n v)))))))) |
---|
296 | (setf (gethash (list n v) hash) result) |
---|
297 | result)))) |
---|
298 | |
---|
299 | ;; Computes A[n](v) = |
---|
300 | ;; (-1)^n*v*2^(-v)*pochhammer(v+n+1,n-1)/(2^(2*n)*n!) If v is a |
---|
301 | ;; negative integer -m, use A[n](-m) = (-1)^(m+1)*A[n-m](m) for n >= |
---|
302 | ;; m. |
---|
303 | (defun big-a (n v) |
---|
304 | (let ((m (ftruncate v))) |
---|
305 | (cond ((and (= m v) (minusp m)) |
---|
306 | (if (< n m) |
---|
307 | (%big-a n v) |
---|
308 | (let ((result (%big-a (+ n m) (- v)))) |
---|
309 | (if (oddp (truncate m)) |
---|
310 | result |
---|
311 | (- result))))) |
---|
312 | (t |
---|
313 | (%big-a n v))))) |
---|
314 | |
---|
315 | ;; I[n](t, z, v) = exp(-t*z)/t^(2*n+v-1) * |
---|
316 | ;; integrate(exp(-t*z*s)*(1+s)^(-2*n-v), s, 0, inf) |
---|
317 | ;; |
---|
318 | ;; Use the substitution u=1+s to get a new integral |
---|
319 | ;; |
---|
320 | ;; integrate(exp(-t*z*s)*(1+s)^(-2*n-v), s, 0, inf) |
---|
321 | ;; = exp(t*z) * integrate(u^(-v-2*n)*exp(-t*u*z), u, 1, inf) |
---|
322 | ;; = exp(t*z)*t^(v+2*n-1)*z^(v+2*n-1)*incomplete_gamma_tail(1-v-2*n,t*z) |
---|
323 | ;; |
---|
324 | ;; Thus, |
---|
325 | ;; |
---|
326 | ;; I[n](t, z, v) = z^(v+2*n-1)*incomplete_gamma_tail(1-v-2*n,t*z) |
---|
327 | ;; |
---|
328 | (defun big-i (n theta z v) |
---|
329 | (let* ((a (- 1 v n n))) |
---|
330 | (* (expt z (- a)) |
---|
331 | (incomplete-gamma-tail a (* theta z))))) |
---|
332 | |
---|
333 | (defun sum-big-ia (big-n v z) |
---|
334 | (let ((big-n-1/2 (+ big-n 1/2)) |
---|
335 | (eps (epsilon z))) |
---|
336 | (do* ((n 0 (1+ n)) |
---|
337 | (term (* (big-a 0 v) |
---|
338 | (big-i 0 big-n-1/2 z v)) |
---|
339 | (* (big-a n v) |
---|
340 | (big-i n big-n-1/2 z v))) |
---|
341 | (sum term (+ sum term))) |
---|
342 | ((<= (abs term) (* eps (abs sum))) |
---|
343 | sum) |
---|
344 | #+nil |
---|
345 | (progn |
---|
346 | (format t "n = ~D~%" n) |
---|
347 | (format t " term = ~S~%" term) |
---|
348 | (format t " sum = ~S~%" sum))))) |
---|
349 | |
---|
350 | ;; Series for bessel J: |
---|
351 | ;; |
---|
352 | ;; (z/2)^v*sum((-1)^k/Gamma(k+v+1)/k!*(z^2//4)^k, k, 0, inf) |
---|
353 | (defun s-bessel-j (v z) |
---|
354 | (with-floating-point-contagion (v z) |
---|
355 | (let ((z2/4 (* z z 1/4)) |
---|
356 | (eps (epsilon z))) |
---|
357 | (do* ((k 0 (+ 1 k)) |
---|
358 | (f (gamma (+ v 1)) |
---|
359 | (* k (+ v k))) |
---|
360 | (term (/ f) |
---|
361 | (/ (* (- term) z2/4) f)) |
---|
362 | (sum term (+ sum term))) |
---|
363 | ((<= (abs term) (* eps (abs sum))) |
---|
364 | (* sum (expt (* z 1/2) v))) |
---|
365 | #+nil |
---|
366 | (progn |
---|
367 | (format t "k = ~D~%" k) |
---|
368 | (format t " f = ~S~%" f) |
---|
369 | (format t " term = ~S~%" term) |
---|
370 | (format t " sum = ~S~%" sum)))))) |
---|
371 | |
---|
372 | (defun bessel-j (v z) |
---|
373 | (let ((vv (ftruncate v))) |
---|
374 | (cond ((= vv v) |
---|
375 | ;; v is an integer |
---|
376 | (integer-bessel-j-exp-arc v z)) |
---|
377 | (t |
---|
378 | (let ((big-n 100) |
---|
379 | (vpi (* v (float-pi (realpart z))))) |
---|
380 | (+ (integer-bessel-j-exp-arc v z) |
---|
381 | (* z |
---|
382 | (/ (sin vpi) vpi) |
---|
383 | (+ (/ -1 z) |
---|
384 | (sum-ab big-n v z) |
---|
385 | (sum-big-ia big-n v z))))))))) |
---|
386 | |
---|
387 | (defun paris-series (v z n) |
---|
388 | (labels ((pochhammer (a k) |
---|
389 | (/ (gamma (+ a k)) |
---|
390 | (gamma a))) |
---|
391 | (a (v k) |
---|
392 | (* (/ (pochhammer (+ 1/2 v) k) |
---|
393 | (gamma (float (1+ k) z))) |
---|
394 | (pochhammer (- 1/2 v) k)))) |
---|
395 | (* (loop for k from 0 below n |
---|
396 | sum (* (/ (a v k) |
---|
397 | (expt (* 2 z) k)) |
---|
398 | (/ (cf-incomplete-gamma (+ k v 1/2) (* 2 z)) |
---|
399 | (gamma (+ k v 1/2))))) |
---|
400 | (/ (exp z) |
---|
401 | (sqrt (* 2 (float-pi z) z)))))) |
---|
402 | |
---|