From rtoy at common-lisp.net Fri Mar 4 21:23:09 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Fri, 04 Mar 2011 16:23:09 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 7310f8e9c4f8d905d60121a1bc89665b9f620689 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 7310f8e9c4f8d905d60121a1bc89665b9f620689 (commit) via cc9eb34a6fa1e8971a09dddc91e93848ba360dbf (commit) from 6ab0812b935e4fa1c63ba9f5d58f7e66eb6f375b (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 7310f8e9c4f8d905d60121a1bc89665b9f620689 Author: Raymond Toy Date: Fri Mar 4 16:03:17 2011 -0500 Add newline to end of file. Fix #1. diff --git a/oct.asd b/oct.asd index 3cef6d7..947b047 100644 --- a/oct.asd +++ b/oct.asd @@ -75,4 +75,4 @@ (defmethod perform ((op test-op) (c (eql (find-system :oct-tests)))) (or (funcall (intern "DO-TESTS" (find-package "RT"))) - (error "TEST-OP failed for OCT-TESTS"))) \ No newline at end of file + (error "TEST-OP failed for OCT-TESTS"))) commit cc9eb34a6fa1e8971a09dddc91e93848ba360dbf Author: Raymond Toy Date: Sun Feb 13 18:41:29 2011 -0500 Add test-op for oct to run the tests. diff --git a/oct.asd b/oct.asd index ba4d6b6..3cef6d7 100644 --- a/oct.asd +++ b/oct.asd @@ -27,7 +27,7 @@ ;;; so it might be out of date. Use at your own risk. (defpackage #:oct-system - (:use #:cl)) + (:use #:cl #:asdf)) (in-package #:oct-system) @@ -59,3 +59,20 @@ (:file "qd-complex" :depends-on ("qd-methods")) )) + +(defmethod perform ((op test-op) (c (eql (find-system :oct)))) + (oos 'test-op 'oct-tests)) + +(asdf:defsystem oct-tests + :depends-on (oct) + :version "2011-02-09" ; Just use the date + :in-order-to ((compile-op (load-op :rt)) + (test-op (load-op :rt :oct))) + :components + ((:file "qd-extra") + (:file "qd-test") + (:file "rt-tests"))) + +(defmethod perform ((op test-op) (c (eql (find-system :oct-tests)))) + (or (funcall (intern "DO-TESTS" (find-package "RT"))) + (error "TEST-OP failed for OCT-TESTS"))) \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: oct.asd | 19 ++++++++++++++++++- 1 files changed, 18 insertions(+), 1 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 4 21:25:12 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Fri, 04 Mar 2011 16:25:12 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. d28bce81063ce796763a7b7de995ee0157603ed9 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via d28bce81063ce796763a7b7de995ee0157603ed9 (commit) from 7310f8e9c4f8d905d60121a1bc89665b9f620689 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit d28bce81063ce796763a7b7de995ee0157603ed9 Author: Raymond Toy Date: Fri Mar 4 16:08:27 2011 -0500 Add newline to end of file. Fix #1. diff --git a/LICENSE b/LICENSE index d4bf97c..90cf16a 100644 --- a/LICENSE +++ b/LICENSE @@ -16,4 +16,4 @@ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. \ No newline at end of file +THE SOFTWARE. ----------------------------------------------------------------------- Summary of changes: LICENSE | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 4 21:40:56 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Fri, 04 Mar 2011 16:40:56 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 0597a1124076fd119c55c7ecb57b765e1fb6e2ad Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 0597a1124076fd119c55c7ecb57b765e1fb6e2ad (commit) from d28bce81063ce796763a7b7de995ee0157603ed9 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 0597a1124076fd119c55c7ecb57b765e1fb6e2ad Author: Raymond Toy Date: Fri Mar 4 16:24:11 2011 -0500 Remove trailing empty lines. Fix #1. diff --git a/branch-test.lisp b/branch-test.lisp index ee40765..1ae66fb 100644 --- a/branch-test.lisp +++ b/branch-test.lisp @@ -138,6 +138,3 @@ #+cmu (check-signs #'atanh 2w0 tr ti) (check-signs #'atanh #q2 tr ti))) - - - ----------------------------------------------------------------------- Summary of changes: branch-test.lisp | 3 --- 1 files changed, 0 insertions(+), 3 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 4 21:48:08 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Fri, 04 Mar 2011 16:48:08 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 20558955b7953055a77ef1cbe690dcb1b1f54291 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 20558955b7953055a77ef1cbe690dcb1b1f54291 (commit) from 0597a1124076fd119c55c7ecb57b765e1fb6e2ad (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 20558955b7953055a77ef1cbe690dcb1b1f54291 Author: Raymond Toy Date: Fri Mar 4 16:30:41 2011 -0500 Note this defsystem is deprecated. Fix #1. diff --git a/oct.system b/oct.system index 91d5e58..d815a15 100644 --- a/oct.system +++ b/oct.system @@ -23,6 +23,10 @@ ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;;; OTHER DEALINGS IN THE SOFTWARE. +;; This is no longer used, but we leave it here for reference and in +;; case someone wants to build oct with mk:defsys. Oct now uses asdf +;; to build. + (in-package #:cl-user) (mk:defsystem oct :source-pathname (make-pathname :directory (pathname-directory *load-pathname*)) ----------------------------------------------------------------------- Summary of changes: oct.system | 4 ++++ 1 files changed, 4 insertions(+), 0 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Mon Mar 7 02:44:48 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Sun, 06 Mar 2011 21:44:48 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 258cd829289826458d6075caa279b253b8848749 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 258cd829289826458d6075caa279b253b8848749 (commit) from 20558955b7953055a77ef1cbe690dcb1b1f54291 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 258cd829289826458d6075caa279b253b8848749 Author: Raymond Toy Date: Sun Mar 6 21:27:16 2011 -0500 Remove extra blank lines. Fix #1. diff --git a/qd.lisp b/qd.lisp index 2b72769..af5a779 100644 --- a/qd.lisp +++ b/qd.lisp @@ -1346,11 +1346,6 @@ is a fixnum." (cl:* (cl:* q2 s1) s2) (cl:* (cl:* q3 s1) s2))))) - - - - - (defun decode-float-qd (q) "Like DECODE-FLOAT, but for %QUAD-DOUBLE numbers. Returns three values: 1) a %QUAD-DOUBLE number representing the significand. This is always ----------------------------------------------------------------------- Summary of changes: qd.lisp | 5 ----- 1 files changed, 0 insertions(+), 5 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Mon Mar 7 02:47:25 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Sun, 06 Mar 2011 21:47:25 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 535d2509c2974c113e6c1bfa27ece5d5b8f99bd1 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 535d2509c2974c113e6c1bfa27ece5d5b8f99bd1 (commit) from 258cd829289826458d6075caa279b253b8848749 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 535d2509c2974c113e6c1bfa27ece5d5b8f99bd1 Author: Raymond Toy Date: Sun Mar 6 21:30:15 2011 -0500 Add support for Jacobi elliptic functions qd-elliptic.lisp: o Implementation for Jacobi sn, cn, and dn functions. qd-methods.lisp: o Add EPSILON method to return the floating-point epsilon value for the given float. oct.asd: o Build qd-elliptic.lisp. diff --git a/oct.asd b/oct.asd index 947b047..153706c 100644 --- a/oct.asd +++ b/oct.asd @@ -58,6 +58,8 @@ :depends-on ("qd-methods")) (:file "qd-complex" :depends-on ("qd-methods")) + (:file "qd-elliptic" + :depends-on ("qd-methods")) )) (defmethod perform ((op test-op) (c (eql (find-system :oct)))) diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp new file mode 100644 index 0000000..9c56fcd --- /dev/null +++ b/qd-elliptic.lisp @@ -0,0 +1,180 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2011 Raymond Toy +;;;; Permission is hereby granted, free of charge, to any person +;;;; obtaining a copy of this software and associated documentation +;;;; files (the "Software"), to deal in the Software without +;;;; restriction, including without limitation the rights to use, +;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell +;;;; copies of the Software, and to permit persons to whom the +;;;; Software is furnished to do so, subject to the following +;;;; conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. + +(in-package #:oct) + +(declaim (inline descending-transform ascending-transform)) + +(defun ascending-transform (u m) + ;; A&S 16.14.1 + ;; + ;; Take care in computing this transform. For the case where + ;; m is complex, we should compute sqrt(mu1) first as + ;; (1-sqrt(m))/(1+sqrt(m)), and then square this to get mu1. + ;; If not, we may choose the wrong branch when computing + ;; sqrt(mu1). + (let* ((root-m (sqrt m)) + (mu (/ (* 4 root-m) + (expt (1+ root-m) 2))) + (root-mu1 (/ (- 1 root-m) (+ 1 root-m))) + (v (/ u (1+ root-mu1)))) + (values v mu root-mu1))) + +(defun descending-transform (u m) + ;; Note: Don't calculate mu first, as given in 16.12.1. We + ;; should calculate sqrt(mu) = (1-sqrt(m1)/(1+sqrt(m1)), and + ;; then compute mu = sqrt(mu)^2. If we calculate mu first, + ;; sqrt(mu) loses information when m or m1 is complex. + (let* ((root-m1 (sqrt (- 1 m))) + (root-mu (/ (- 1 root-m1) (+ 1 root-m1))) + (mu (* root-mu root-mu)) + (v (/ u (1+ root-mu)))) + (values v mu root-mu))) + + +;; Could use the descending transform, but some of my tests show +;; that it has problems with roundoff errors. + +;; WARNING: This doesn't work very well for u > 1000 or so. For +;; example (elliptic-dn-ascending 1000b0 .5b0) -> 3.228b324, but dn <= 1. +#+nil +(defun elliptic-dn-ascending (u m) + (cond ((zerop m) + ;; A&S 16.6.3 + 1.0) + ((< (abs (- 1 m)) (* 4 (epsilon u))) + ;; A&S 16.6.3 + (/ (cosh u))) + (t + (multiple-value-bind (v mu root-mu1) + (ascending-transform u m) + ;; A&S 16.14.4 + (let* ((new-dn (elliptic-dn-ascending v mu))) + (* (/ (- 1 root-mu1) mu) + (/ (+ root-mu1 (* new-dn new-dn)) + new-dn))))))) + +;; Don't use the descending version because it requires cn, dn, and +;; sn. +;; +;; WARNING: This doesn't work very well for large u. +;; (elliptic-cn-ascending 1000b0 .5b0) -> 4.565b324. But |cn| <= 1. +#+nil +(defun elliptic-cn-ascending (u m) + (cond ((zerop m) + ;; A&S 16.6.2 + (cos u)) + ((< (abs (- 1 m)) (* 4 (epsilon u))) + ;; A&S 16.6.2 + (/ (cl:cosh u))) + (t + (multiple-value-bind (v mu root-mu1) + (ascending-transform u m) + ;; A&S 16.14.3 + (let* ((new-dn (elliptic-dn-ascending v mu))) + (* (/ (+ 1 root-mu1) mu) + (/ (- (* new-dn new-dn) root-mu1) + new-dn))))))) + +;; +;; This appears to work quite well for both real and complex values +;; of u. +(defun elliptic-sn-descending (u m) + (cond ((= m 1) + ;; A&S 16.6.1 + (tanh u)) + ((< (abs m) (epsilon u)) + ;; A&S 16.6.1 + (sin u)) + (t + (multiple-value-bind (v mu root-mu) + (descending-transform u m) + (let* ((new-sn (elliptic-sn-descending v mu))) + (/ (* (1+ root-mu) new-sn) + (1+ (* root-mu new-sn new-sn)))))))) + +;; We don't use the ascending transform here because it requires +;; evaluating sn, cn, and dn. The ascending transform only needs +;; sn. +#+nil +(defun elliptic-sn-ascending (u m) + (if (< (abs (- 1 m)) (* 4 flonum-epsilon)) + ;; A&S 16.6.1 + (tanh u) + (multiple-value-bind (v mu root-mu1) + (ascending-transform u m) + ;; A&S 16.14.2 + (let* ((new-cn (elliptic-cn-ascending v mu)) + (new-dn (elliptic-dn-ascending v mu)) + (new-sn (elliptic-sn-ascending v mu))) + (/ (* (+ 1 root-mu1) new-sn new-cn) + new-dn))))) + +(defun jacobi-sn (u m) + (let ((s (elliptic-sn-descending u m))) + (if (and (realp u) (realp m)) + (realpart s) + s))) + +(defun jacobi-dn (u m) + ;; Use the Gauss transformation from + ;; http://functions.wolfram.com/09.29.16.0013.01: + ;; + ;; + ;; dn((1+sqrt(m))*z, 4*sqrt(m)/(1+sqrt(m))^2) + ;; = (1-sqrt(m)*sn(z, m)^2)/(1+sqrt(m)*sn(z,m)^2) + ;; + ;; So + ;; + ;; dn(y, mu) = (1-sqrt(m)*sn(z, m)^2)/(1+sqrt(m)*sn(z,m)^2) + ;; + ;; where z = y/(1+sqrt(m)) and mu=4*sqrt(m)/(1+sqrt(m))^2. + ;; + ;; Solve for m, and we get + ;; + ;; sqrt(m) = -(mu+2*sqrt(1-mu)-2)/mu or (-mu+2*sqrt(1-mu)+2)/mu. + ;; + ;; I don't think it matters which sqrt we use, so I (rtoy) + ;; arbitrarily choose the first one above. + ;; + ;; Note that (1-sqrt(1-mu))/(1+sqrt(1-mu)) is the same as + ;; -(mu+2*sqrt(1-mu)-2)/mu. Also, the former is more + ;; accurate for small mu. + (let* ((root (let ((root-1-m (sqrt (- 1 m)))) + (/ (- 1 root-1-m) + (+ 1 root-1-m)))) + (z (/ u (+ 1 root))) + (s (elliptic-sn-descending z (* root root))) + (p (* root s s ))) + (/ (- 1 p) + (+ 1 p)))) + +(defun jacobi-cn (u m) + ;; Use the ascending Landen transformation, A&S 16.14.3. + (multiple-value-bind (v mu root-mu1) + (ascending-transform u m) + (let ((d (dn v mu))) + (* (/ (+ 1 root-mu1) mu) + (/ (- (* d d) root-mu1) + d))))) \ No newline at end of file diff --git a/qd-methods.lisp b/qd-methods.lisp index b6a83cf..3af7bd0 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -1089,3 +1089,23 @@ underlying floating-point format" ;; and make a real qd-real float, instead of the hackish ;; %qd-real. (set-dispatch-macro-character #\# #\Q #'qd-class-reader) + + +(defmethod epsilon ((m cl:float)) + (etypecase m + (single-float single-float-epsilon) + (double-float double-float-epsilon))) + +(defmethod epsilon ((m cl:complex)) + (epsilon (realpart m))) + +(defmethod epsilon ((m qd-real)) + ;; What is the epsilon value for a quad-double? This is complicated + ;; by the fact that things like (+ #q1 #q1q-100) is representable as + ;; a quad-double. For most purposes we want epsilon to be close to + ;; the 212 bits of precision (4*53 bits) that we normally have with + ;; a quad-double. + (scale-float #q1 -212)) + +(defmethod epsilon ((m qd-complex)) + (epsilon (realpart m))) ----------------------------------------------------------------------- Summary of changes: oct.asd | 2 + qd-elliptic.lisp | 180 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ qd-methods.lisp | 20 ++++++ 3 files changed, 202 insertions(+), 0 deletions(-) create mode 100644 qd-elliptic.lisp hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Mon Mar 7 03:33:07 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Sun, 06 Mar 2011 22:33:07 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. c014c5f4e4b941aacf16a897a2cf689ed49b37ef Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via c014c5f4e4b941aacf16a897a2cf689ed49b37ef (commit) from 535d2509c2974c113e6c1bfa27ece5d5b8f99bd1 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c014c5f4e4b941aacf16a897a2cf689ed49b37ef Author: Raymond Toy Date: Sun Mar 6 21:47:26 2011 -0500 Oops. Can't use #q yet,so change #q1 to (make-qd-d 1d0). diff --git a/qd-methods.lisp b/qd-methods.lisp index 3af7bd0..205c9fe 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -1105,7 +1105,7 @@ underlying floating-point format" ;; a quad-double. For most purposes we want epsilon to be close to ;; the 212 bits of precision (4*53 bits) that we normally have with ;; a quad-double. - (scale-float #q1 -212)) + (scale-float (make-qd-d 1d0) -212)) (defmethod epsilon ((m qd-complex)) (epsilon (realpart m))) ----------------------------------------------------------------------- Summary of changes: qd-methods.lisp | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Mon Mar 7 03:55:16 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Sun, 06 Mar 2011 22:55:16 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 1421224af506145ab18f9f4b412f300c97c11751 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 1421224af506145ab18f9f4b412f300c97c11751 (commit) from c014c5f4e4b941aacf16a897a2cf689ed49b37ef (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 1421224af506145ab18f9f4b412f300c97c11751 Author: Raymond Toy Date: Sun Mar 6 22:38:09 2011 -0500 Document algorithms better. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 9c56fcd..c29d9ce 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -34,6 +34,12 @@ ;; (1-sqrt(m))/(1+sqrt(m)), and then square this to get mu1. ;; If not, we may choose the wrong branch when computing ;; sqrt(mu1). + ;; + ;; mu = 4*sqrt(m)/(1+sqrt(m))^2 + ;; sqrt(mu1) = (1-sqrt(m))/(1+sqrt(m)) + ;; v = u/(1+sqrt(mu1)) + ;; + ;; Return v, mu, sqrt(mu1) (let* ((root-m (sqrt m)) (mu (/ (* 4 root-m) (expt (1+ root-m) 2))) @@ -42,10 +48,19 @@ (values v mu root-mu1))) (defun descending-transform (u m) + ;; A&S 16.12.1 + ;; ;; Note: Don't calculate mu first, as given in 16.12.1. We ;; should calculate sqrt(mu) = (1-sqrt(m1)/(1+sqrt(m1)), and ;; then compute mu = sqrt(mu)^2. If we calculate mu first, ;; sqrt(mu) loses information when m or m1 is complex. + ;; + ;; sqrt(mu) = (1-sqrt(m1))/(1+sqrt(m1)) + ;; v = u/(1+sqrt(mu)) + ;; + ;; where m1 = 1-m + ;; + ;; Return v, mu, sqrt(mu) (let* ((root-m1 (sqrt (- 1 m))) (root-mu (/ (- 1 root-m1) (+ 1 root-m1))) (mu (* root-mu root-mu)) @@ -108,6 +123,9 @@ ;; A&S 16.6.1 (sin u)) (t + ;; A&S 16.12.2 + ;; + ;; sn(u|m) = (1 + sqrt(mu))*sn(v|u)/(1 + sqrt(mu)*sn(v|mu)^2) (multiple-value-bind (v mu root-mu) (descending-transform u m) (let* ((new-sn (elliptic-sn-descending v mu))) @@ -172,6 +190,8 @@ (defun jacobi-cn (u m) ;; Use the ascending Landen transformation, A&S 16.14.3. + ;; + ;; cn(u,m) = (1+sqrt(mu1))/mu * (dn(v,mu)^2-sqrt(mu1))/dn(v,mu) (multiple-value-bind (v mu root-mu1) (ascending-transform u m) (let ((d (dn v mu))) ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 20 ++++++++++++++++++++ 1 files changed, 20 insertions(+), 0 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Mon Mar 7 20:46:15 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Mon, 07 Mar 2011 15:46:15 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 3d2184f115538262f60b359249d76fb1c4c7048d Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 3d2184f115538262f60b359249d76fb1c4c7048d (commit) via 1e343ca0be49b9e56938a8063b4d2e679e338965 (commit) via 935f7e0f335c1ba01a17c6c6c39e0421f5f62b50 (commit) from 1421224af506145ab18f9f4b412f300c97c11751 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 3d2184f115538262f60b359249d76fb1c4c7048d Author: Raymond Toy Date: Mon Mar 7 14:59:00 2011 -0500 Support testing with Lisps without signed floating-point zeros. CHECK-SIGN just returns T if Lisp thinks -0d0 and 0d0 are the same number. This is only true if Lisp doesn't support signed zeroes. diff --git a/rt-tests.lisp b/rt-tests.lisp index b87100e..b9e5867 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -583,8 +583,11 @@ (let* ((z (funcall fun arg)) (x (realpart z)) (y (imagpart z))) - (if (and (= (float-sign x) (float-sign (realpart expected))) - (= (float-sign y) (float-sign (imagpart expected)))) + ;; If the Lisp doesn't support signed zeroes, then this test + ;; should always pass. + (if (or (eql -0d0 0d0) + (and (= (float-sign x) (float-sign (realpart expected))) + (= (float-sign y) (float-sign (imagpart expected))))) t (list z expected fun arg)))) commit 1e343ca0be49b9e56938a8063b4d2e679e338965 Author: Raymond Toy Date: Mon Mar 7 14:50:44 2011 -0500 Fix issue with float-sign calling qfloat-sign. If the optional arg to FLOAT-SIGN is not given, don't call qfloat-sign with a second arg of NIL. This breaks things. Call qfloat-sign with the same number of arguments as float-sign. diff --git a/qd-methods.lisp b/qd-methods.lisp index 205c9fe..037bcc3 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -717,6 +717,7 @@ underlying floating-point format" (defmethod qfloat-sign ((a real) &optional (f (float 1 a))) (cl:float-sign a f)) + (defmethod qfloat-sign ((a qd-real) &optional f) (if f (make-instance 'qd-real @@ -725,8 +726,10 @@ underlying floating-point format" (make-instance 'qd-real :value (make-qd-d (cl:float-sign (qd-0 (qd-value a))))))) (declaim (inline float-sign)) -(defun float-sign (n &optional float2) - (qfloat-sign n float2)) +(defun float-sign (n &optional (float2 nil float2p)) + (if float2p + (qfloat-sign n float2) + (qfloat-sign n))) (defun max (number &rest more-numbers) "Returns the greatest of its arguments." commit 935f7e0f335c1ba01a17c6c6c39e0421f5f62b50 Author: Raymond Toy Date: Mon Mar 7 14:47:00 2011 -0500 Ignore *.fas files. diff --git a/.gitignore b/.gitignore index 39ef52b..62c3cc0 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ *.sse2f *.x86f *.sparcf +*.fas *.fasl *.err *~ ----------------------------------------------------------------------- Summary of changes: .gitignore | 1 + qd-methods.lisp | 7 +++++-- rt-tests.lisp | 7 +++++-- 3 files changed, 11 insertions(+), 4 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Mon Mar 7 21:05:21 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Mon, 07 Mar 2011 16:05:21 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 25a15317f76cba7a1c38341edf5a418020e9b477 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 25a15317f76cba7a1c38341edf5a418020e9b477 (commit) from 3d2184f115538262f60b359249d76fb1c4c7048d (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 25a15317f76cba7a1c38341edf5a418020e9b477 Author: Raymond Toy Date: Mon Mar 7 15:48:05 2011 -0500 Clean up printing and fix printing bug in non-cmucl. Clisp was printing #q(1 2) as #q(#q#q1 #q#q2). This is caused by PRINT-OBJECT for QD-COMPLEX printing a #q in addition to a #q printed by QD-FORMAT. qd-class.lisp: o Use the same PRINT-OBJECT method for qd-real for all Lisps. o Remove extraneous #q from PRINT-OBJECT method for qd-complex. qd-io.lisp: o QD-FORMAT for cmucl needs to output #q. diff --git a/qd-class.lisp b/qd-class.lisp index 5cc3cb4..2134ef7 100644 --- a/qd-class.lisp +++ b/qd-class.lisp @@ -47,21 +47,9 @@ :type %quad-double)) (:documentation "Complex number consisting of QUAD-DOUBLE components")) -#-cmu (defmethod print-object ((qd qd-real) stream) (format stream "~/octi::qd-format/" (qd-value qd))) -#+cmu -(defun print-qd (q stream) - (declare (type %quad-double q)) - (if (or (float-infinity-p (qd-0 q)) - (float-nan-p (qd-0 q))) - (format stream "~/octi::qd-format/" q) - (format stream "#q~/octi::qd-format/" q))) -#+cmu -(defmethod print-object ((qd qd-real) stream) - (print-qd (qd-value qd) stream)) - (defmethod make-qd ((x cl:float)) (make-instance 'qd-real :value (make-qd-d (float x 1d0)))) @@ -69,7 +57,7 @@ (make-instance 'qd-real :value (qd-value x))) (defmethod print-object ((qd qd-complex) stream) - (format stream "#q(~<#q~/octi::qd-format/ #q~/octi::qd-format/~:@>)" + (format stream "#q(~<~/octi::qd-format/ ~/octi::qd-format/~:@>)" (list (qd-real qd) (qd-imag qd)))) diff --git a/qd-io.lisp b/qd-io.lisp index 1df662e..40d7c90 100644 --- a/qd-io.lisp +++ b/qd-io.lisp @@ -303,6 +303,7 @@ ((ext:float-nan-p (qd-0 arg)) (qd-output-nan arg stream)) (t + (write-string "#q" stream) (qd-output-aux arg stream)))) ;; This version has problems with roundoff. ----------------------------------------------------------------------- Summary of changes: qd-class.lisp | 14 +------------- qd-io.lisp | 1 + 2 files changed, 2 insertions(+), 13 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Mon Mar 7 23:13:45 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Mon, 07 Mar 2011 18:13:45 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 8481ee30bafaec66ccb99a330e1aee392c4d894b Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 8481ee30bafaec66ccb99a330e1aee392c4d894b (commit) from 25a15317f76cba7a1c38341edf5a418020e9b477 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 8481ee30bafaec66ccb99a330e1aee392c4d894b Author: Raymond Toy Date: Mon Mar 7 17:55:50 2011 -0500 Oops. Use jacobi-dn, not dn. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index c29d9ce..9240eb0 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -194,7 +194,7 @@ ;; cn(u,m) = (1+sqrt(mu1))/mu * (dn(v,mu)^2-sqrt(mu1))/dn(v,mu) (multiple-value-bind (v mu root-mu1) (ascending-transform u m) - (let ((d (dn v mu))) + (let ((d (jacobi-dn v mu))) (* (/ (+ 1 root-mu1) mu) (/ (- (* d d) root-mu1) - d))))) \ No newline at end of file + d))))) ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 4 ++-- 1 files changed, 2 insertions(+), 2 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Tue Mar 8 00:54:09 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Mon, 07 Mar 2011 19:54:09 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. f86bc7e7f3c5b617a141ac5d0f32b5fc6b5e77d5 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via f86bc7e7f3c5b617a141ac5d0f32b5fc6b5e77d5 (commit) via 1a38c9e3dd557620c053919bbccde06741118a36 (commit) from 8481ee30bafaec66ccb99a330e1aee392c4d894b (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f86bc7e7f3c5b617a141ac5d0f32b5fc6b5e77d5 Author: Raymond Toy Date: Mon Mar 7 19:36:35 2011 -0500 Add elliptic K function and tests for it and Jacobi functions. qd-elliptic.lisp: o Add support for the complete elliptic integral K using Carlson's Rf function. rt-tests.lisp: o Fix indentation for oct.atan.5 o Add tests for elliptic K o Add tests for Jacobi sn, cn, and dn functions. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 9240eb0..3336444 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -198,3 +198,59 @@ (* (/ (+ 1 root-mu1) mu) (/ (- (* d d) root-mu1) d))))) + +(defun errtol (&rest args) + ;; Compute error tolerance as sqrt(2^(-fpprec)). Not sure this is + ;; quite right, but it makes the routines more accurate as fpprec + ;; increases. + (sqrt (reduce #'min (mapcar #'(lambda (x) + (if (rationalp x) + double-float-epsilon + (epsilon x))) + args)))) + +(defun carlson-rf (x y z) + (let* ((xn x) + (yn y) + (zn z) + (a (/ (+ xn yn zn) 3)) + (epslon (/ (max (abs (- a xn)) + (abs (- a yn)) + (abs (- a zn))) + (errtol x y z))) + (an a) + (power4 1) + (n 0) + xnroot ynroot znroot lam) + (loop while (> (* power4 epslon) (abs an)) + do + (setf xnroot (sqrt xn)) + (setf ynroot (sqrt yn)) + (setf znroot (sqrt zn)) + (setf lam (+ (* xnroot ynroot) + (* xnroot znroot) + (* ynroot znroot))) + (setf power4 (* power4 1/4)) + (setf xn (* (+ xn lam) 1/4)) + (setf yn (* (+ yn lam) 1/4)) + (setf zn (* (+ zn lam) 1/4)) + (setf an (* (+ an lam) 1/4)) + (incf n)) + ;; c1=-3/14,c2=1/6,c3=9/88,c4=9/22,c5=-3/22,c6=-9/52,c7=3/26 + (let* ((xndev (/ (* (- a x) power4) an)) + (yndev (/ (* (- a y) power4) an)) + (zndev (- (+ xndev yndev))) + (ee2 (- (* xndev yndev) (* 6 zndev zndev))) + (ee3 (* xndev yndev zndev)) + (s (+ 1 + (* -1/10 ee2) + (* 1/14 ee3) + (* 1/24 ee2 ee2) + (* -3/44 ee2 ee3)))) + (/ s (sqrt an))))) + +(defun elliptic-k (m) + (cond ((= m 0) + (/ (float +pi+ m) 2)) + (t + (carlson-rf 0 (- 1 m) 1)))) diff --git a/rt-tests.lisp b/rt-tests.lisp index b9e5867..f4e06c1 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -118,8 +118,8 @@ (rt:deftest oct.atan.5 (let* ((arg #q-1q100) - (y (/ (atan arg) +pi+)) - (true #q-.5)) + (y (/ (atan arg) +pi+)) + (true #q-.5)) (check-accuracy 212 y true)) nil) @@ -761,3 +761,70 @@ (let ((true (cl:atanh #c(2d0 1d-20)))) (check-signs #'atanh #q2 true)) t) + +;; elliptic_k(-1) = gamma(1/4)^2/2^(5/2)/sqrt(%pi) +(rt:deftest oct.elliptic-k.1d + (let* ((val (elliptic-k -1d0)) + (true #q1.311028777146059905232419794945559706841377475715811581408410851900395293535207125115147766480714547q0)) + (check-accuracy 53 val true)) + nil) + +(rt:deftest oct.elliptic-k.1q + (let* ((val (elliptic-k #q-1q0)) + (true #q1.311028777146059905232419794945559706841377475715811581408410851900395293535207125115147766480714547q0)) + (check-accuracy 210 val true)) + nil) + +;; elliptic_k(1/2) = %pi^(3/2)/2/gamma(3/4)^2 +(rt:deftest oct.elliptic-k.2d + (let* ((val (elliptic-k 0.5d0)) + (true #q1.854074677301371918433850347195260046217598823521766905585928045056021776838119978357271861650371897q0)) + (check-accuracy 53 val true)) + nil) + +(rt:deftest oct.elliptic-k.2q + (let* ((val (elliptic-k #q.5)) + (true #q1.854074677301371918433850347195260046217598823521766905585928045056021776838119978357271861650371897q0)) + (check-accuracy 210 val true)) + nil) + +;; jacobi_sn(K,1/2) = 1, where K = elliptic_k(1/2) +(rt:deftest oct.jacobi-sn.1d + (let* ((ek (elliptic-k .5d0)) + (val (jacobi-sn ek .5d0))) + (check-accuracy 54 val 1d0)) + nil) + +(rt:deftest oct.jacobi-sn.1q + (let* ((ek (elliptic-k #q.5)) + (val (jacobi-sn ek #q.5))) + (check-accuracy 212 val #q1)) + nil) + +;; jacobi_cn(K,1/2) = 0 +(rt:deftest oct.jacobi-cn.1d + (let* ((ek (elliptic-k .5d0)) + (val (jacobi-cn ek .5d0))) + (check-accuracy 50 val 0d0)) + nil) + +(rt:deftest oct.jacobi-sn.1q + (let* ((ek (elliptic-k #q.5)) + (val (jacobi-cn ek #q.5))) + (check-accuracy 210 val #q0)) + nil) + +;; jacobi-dn(K, 1/2) = sqrt(1/2) +(rt:deftest oct.jacobi-dn.1d + (let* ((ek (elliptic-k .5d0)) + (true (sqrt .5d0)) + (val (jacobi-dn ek .5d0))) + (check-accuracy 52 val true)) + nil) + +(rt:deftest oct.jacobi-dn.1q + (let* ((ek (elliptic-k #q.5)) + (true (sqrt #q.5)) + (val (jacobi-dn ek #q.5))) + (check-accuracy 212 val true)) + nil) commit 1a38c9e3dd557620c053919bbccde06741118a36 Author: Raymond Toy Date: Mon Mar 7 19:33:34 2011 -0500 Fix bug in qd-scale-float. MAKE-QD-D returns a %quad-double, not qd-real. Use +QD-REAL-ONE+ instead. diff --git a/qd-methods.lisp b/qd-methods.lisp index 037bcc3..4f8065f 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -1108,7 +1108,7 @@ underlying floating-point format" ;; a quad-double. For most purposes we want epsilon to be close to ;; the 212 bits of precision (4*53 bits) that we normally have with ;; a quad-double. - (scale-float (make-qd-d 1d0) -212)) + (scale-float +qd-real-one+ -212)) (defmethod epsilon ((m qd-complex)) (epsilon (realpart m))) ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 56 ++++++++++++++++++++++++++++++++++++++++++ qd-methods.lisp | 2 +- rt-tests.lisp | 71 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 126 insertions(+), 3 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Tue Mar 8 14:13:35 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Tue, 08 Mar 2011 09:13:35 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 6c91244701c5867328a58c94d2118db6e09310d1 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 6c91244701c5867328a58c94d2118db6e09310d1 (commit) from f86bc7e7f3c5b617a141ac5d0f32b5fc6b5e77d5 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 6c91244701c5867328a58c94d2118db6e09310d1 Author: Raymond Toy Date: Tue Mar 8 08:56:13 2011 -0500 For clisp, disable floating-point underflow when running tests. diff --git a/rt-tests.lisp b/rt-tests.lisp index f4e06c1..82ca0b7 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -25,6 +25,11 @@ (in-package #:oct) +;; For the tests, we need to turn off underflow for clisp. +#+clisp +(ext:without-package-lock () + (setq sys::*inhibit-floating-point-underflow* t)) + ;; Compute how many bits are the same for two numbers EST and TRUE. ;; Return T if they are identical. (defun bit-accuracy (est true) ----------------------------------------------------------------------- Summary of changes: rt-tests.lisp | 5 +++++ 1 files changed, 5 insertions(+), 0 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Tue Mar 8 14:20:28 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Tue, 08 Mar 2011 09:20:28 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 68432cb1855605c346216788f1aa64517a96a808 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 68432cb1855605c346216788f1aa64517a96a808 (commit) via 3d37e3b9346092b58e820723ae20f114dc912d44 (commit) from 6c91244701c5867328a58c94d2118db6e09310d1 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 68432cb1855605c346216788f1aa64517a96a808 Author: Raymond Toy Date: Tue Mar 8 09:02:42 2011 -0500 Oops. Remove the #q reader functions from here. They've been moved to qd-reader.lisp. diff --git a/qd-methods.lisp b/qd-methods.lisp index 4f8065f..6f41857 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -1064,36 +1064,6 @@ underlying floating-point format" (frob two-arg-* cl:* mul-qd mul-d-qd mul-qd-d) (frob two-arg-/ cl:/ div-qd nil nil)) - -(defun read-qd-real-or-complex (stream) - (let ((c (peek-char t stream))) - (cond ((char= c #\() - ;; Read a QD complex - (read-char stream) ; Skip the paren - (let ((real (read stream t nil t)) - (imag (read stream t nil t))) - (unless (char= (peek-char t stream) #\)) - (error "Illegal QD-COMPLEX number format")) - ;; Read closing paren - (read-char stream) - (make-instance 'qd-complex - :real (qd-value (float real +qd-real-one+)) - :imag (qd-value (float imag +qd-real-one+))))) - (t - (make-instance 'qd-real :value (read-qd stream)))))) - -(defun qd-class-reader (stream subchar arg) - (declare (ignore subchar)) - (when arg - (warn "Numeric argument ignored in #~DQ" arg)) - (read-qd-real-or-complex stream)) - -;; Yow! We redefine the #q reader that is in qd-io.lisp to read in -;; and make a real qd-real float, instead of the hackish -;; %qd-real. -(set-dispatch-macro-character #\# #\Q #'qd-class-reader) - - (defmethod epsilon ((m cl:float)) (etypecase m (single-float single-float-epsilon) commit 3d37e3b9346092b58e820723ae20f114dc912d44 Author: Raymond Toy Date: Tue Mar 8 09:01:06 2011 -0500 Move #Q reader functions to new file qd-reader.lisp. qd-reader.lisp: o New file containing #Q reader functions. o Create a new readtable containing our reader functions so we don't destructively modify the default *readtable*. oct.asd: o Add qd-reader.lisp. qd-complex.lisp: qd-elliptic.lisp: qd-format.lisp: o Set the *readtable* to *oct-readtable* before compiling these files. diff --git a/oct.asd b/oct.asd index 153706c..77828aa 100644 --- a/oct.asd +++ b/oct.asd @@ -54,12 +54,14 @@ :depends-on ("qd-fun")) (:file "qd-methods" :depends-on ("qd-class")) - (:file "qd-format" + (:file "qd-reader" :depends-on ("qd-methods")) + (:file "qd-format" + :depends-on ("qd-methods" "qd-reader")) (:file "qd-complex" - :depends-on ("qd-methods")) + :depends-on ("qd-methods" "qd-reader")) (:file "qd-elliptic" - :depends-on ("qd-methods")) + :depends-on ("qd-methods" "qd-reader")) )) (defmethod perform ((op test-op) (c (eql (find-system :oct)))) diff --git a/qd-complex.lisp b/qd-complex.lisp index 2a2aaf7..409e94f 100644 --- a/qd-complex.lisp +++ b/qd-complex.lisp @@ -25,6 +25,9 @@ (in-package #:oct) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* *oct-readtable*)) + (defmethod add1 ((a qd-complex)) (make-instance 'qd-complex :real (add-qd-d (qd-value (realpart a)) 1d0) diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 3336444..2fadecd 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -24,6 +24,9 @@ (in-package #:oct) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* *oct-readtable*)) + (declaim (inline descending-transform ascending-transform)) (defun ascending-transform (u m) diff --git a/qd-format.lisp b/qd-format.lisp index a63d814..5ae5289 100644 --- a/qd-format.lisp +++ b/qd-format.lisp @@ -25,6 +25,9 @@ (in-package #:oct) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* *oct-readtable*)) + (defun qd-scale-exponent (original-x) (let* ((x original-x)) (multiple-value-bind (sig exponent) diff --git a/qd-reader.lisp b/qd-reader.lisp new file mode 100644 index 0000000..d2159ea --- /dev/null +++ b/qd-reader.lisp @@ -0,0 +1,58 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007, 2008, 2011 Raymond Toy +;;;; +;;;; Permission is hereby granted, free of charge, to any person +;;;; obtaining a copy of this software and associated documentation +;;;; files (the "Software"), to deal in the Software without +;;;; restriction, including without limitation the rights to use, +;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell +;;;; copies of the Software, and to permit persons to whom the +;;;; Software is furnished to do so, subject to the following +;;;; conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. + +(in-package #:oct) + + + +(defun read-qd-real-or-complex (stream) + (let ((c (peek-char t stream))) + (cond ((char= c #\() + ;; Read a QD complex + (read-char stream) ; Skip the paren + (let ((real (read stream t nil t)) + (imag (read stream t nil t))) + (unless (char= (peek-char t stream) #\)) + (error "Illegal QD-COMPLEX number format")) + ;; Read closing paren + (read-char stream) + (make-instance 'qd-complex + :real (qd-value (float real +qd-real-one+)) + :imag (qd-value (float imag +qd-real-one+))))) + (t + (make-instance 'qd-real :value (read-qd stream)))))) + +(defun qd-class-reader (stream subchar arg) + (declare (ignore subchar)) + (when arg + (warn "Numeric argument ignored in #~DQ" arg)) + (read-qd-real-or-complex stream)) + +(defvar *oct-readtable* + (let ((rt (copy-readtable nil))) + (set-dispatch-macro-character #\# #\Q #'qd-class-reader rt) + rt) + "Readtable that extends the standard readtable to include #q for + reading QD-REAL and QD-COMPLEX numbers") ----------------------------------------------------------------------- Summary of changes: oct.asd | 8 +++-- qd-complex.lisp | 3 ++ qd-elliptic.lisp | 3 ++ qd-format.lisp | 3 ++ qd-methods.lisp | 30 ---------------------- oct-test.system => qd-reader.lisp | 50 +++++++++++++++++++++++------------- 6 files changed, 46 insertions(+), 51 deletions(-) copy oct-test.system => qd-reader.lisp (51%) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 11 03:42:27 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Thu, 10 Mar 2011 22:42:27 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. c239a8514ff5f1fc96d33a4c581cbaec834f6641 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via c239a8514ff5f1fc96d33a4c581cbaec834f6641 (commit) via 46359140b7aa3c0c4af6b3aabc7bcbb4cf248301 (commit) via 85f3e2b22f917ff35d080180ab1e2dda4476e881 (commit) from 68432cb1855605c346216788f1aa64517a96a808 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c239a8514ff5f1fc96d33a4c581cbaec834f6641 Author: Raymond Toy Date: Thu Mar 10 22:23:50 2011 -0500 Implement elliptic integrals of the first kind. o Add FLOAT-CONTAGION to determine the max precision of the given arguments so we can do appopriate contagion in the routines. o Add some docstrings and other documentation of the algorithms. o Add implmentation of ELLIPTIC-K and ELLIPTIC-F for the complete and incomplete elliptic integrals of the first kind, respectively. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 2fadecd..63c3687 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -29,6 +29,57 @@ (declaim (inline descending-transform ascending-transform)) +;; Determine which of x and y has the higher precision and return the +;; value of the higher precision number. If both x and y are +;; rationals, just return 1f0, for a single-float value. +(defun float-contagion-2 (x y) + (etypecase x + (cl:rational + (etypecase y + (cl:rational + 1f0) + (cl:float + y) + (qd-real + y))) + (single-float + (etypecase y + ((or cl:rational single-float) + x) + ((or double-float qd-real) + y))) + (double-float + (etypecase y + ((or cl:rational single-float double-float) + x) + (qd-real + y))) + (qd-real + x))) + +;; Return a floating point (or complex) type of the highest precision +;; among all of the given arguments. +(defun float-contagion (&rest args) + ;; It would be easy if we could just add the args together and let + ;; normal contagion do the work, but we could easily introduce + ;; overflows or other errors that way. So look at each argument and + ;; determine the precision and choose the highest precision. + (let ((complexp (some #'complexp args)) + (max-type + (etypecase (reduce #'float-contagion-2 (mapcar #'realpart (if (cdr args) + args + (list (car args) 0)))) + (single-float 'single-float) + (double-float 'double-float) + (qd-real 'qd-real)))) + (if complexp + (if (eq max-type 'qd-real) + 'qd-complex + `(cl:complex ,max-type)) + max-type))) + +;;; Jacobian elliptic functions + (defun ascending-transform (u m) ;; A&S 16.14.1 ;; @@ -153,12 +204,14 @@ new-dn))))) (defun jacobi-sn (u m) + "Compute Jacobian sn for argument u and parameter m" (let ((s (elliptic-sn-descending u m))) (if (and (realp u) (realp m)) (realpart s) s))) (defun jacobi-dn (u m) + "Compute Jacobi dn for argument u and parameter m" ;; Use the Gauss transformation from ;; http://functions.wolfram.com/09.29.16.0013.01: ;; @@ -192,6 +245,7 @@ (+ 1 p)))) (defun jacobi-cn (u m) + "Compute Jacobi cn for argument u and parameter m" ;; Use the ascending Landen transformation, A&S 16.14.3. ;; ;; cn(u,m) = (1+sqrt(mu1))/mu * (dn(v,mu)^2-sqrt(mu1))/dn(v,mu) @@ -202,17 +256,32 @@ (/ (- (* d d) root-mu1) d))))) +;;; Elliptic Integrals +;;; +;; Translation of Jim FitzSimons' bigfloat implementation of elliptic +;; integrals from http://www.getnet.com/~cherry/elliptbf3.mac. +;; +;; The algorithms are based on B.C. Carlson's "Numerical Computation +;; of Real or Complex Elliptic Integrals". These are updated to the +;; algorithms in Journal of Computational and Applied Mathematics 118 +;; (2000) 71-85 "Reduction Theorems for Elliptic Integrands with the +;; Square Root of two quadritic factors" +;; + (defun errtol (&rest args) - ;; Compute error tolerance as sqrt(2^(-fpprec)). Not sure this is - ;; quite right, but it makes the routines more accurate as fpprec - ;; increases. + ;; Compute error tolerance as sqrt(). Not sure + ;; this is quite right, but it makes the routines more accurate as + ;; precision increases increases. (sqrt (reduce #'min (mapcar #'(lambda (x) (if (rationalp x) - double-float-epsilon + single-float-epsilon (epsilon x))) args)))) (defun carlson-rf (x y z) + "Compute Carlson's Rf function: + + Rf(x, y, z) = 1/2*integrate((t+x)^(-1/2)*(t+y)^(-1/2)*(t+z)^(-1/2), t, 0, inf)" (let* ((xn x) (yn y) (zn z) @@ -252,8 +321,90 @@ (* -3/44 ee2 ee3)))) (/ s (sqrt an))))) +;; Complete elliptic integral of the first kind. This can be computed +;; from Carlson's Rf function: +;; +;; K(m) = Rf(0, 1 - m, 1) (defun elliptic-k (m) + "Complete elliptic integral of the first kind K for parameter m + + K(m) = integrate(1/sqrt(1-m*sin(x)^2), x, 0, %pi/2). + + Note: K(m) = F(%pi/2, m), where F is the (incomplete) elliptic + integral of the first kind." (cond ((= m 0) (/ (float +pi+ m) 2)) (t - (carlson-rf 0 (- 1 m) 1)))) + (let ((precision (float-contagion m))) + (carlson-rf (coerce 0 precision) (- 1 m) (coerce 1 precision)))))) + +;; Elliptic integral of the first kind. This is computed using +;; Carlson's Rf function: +;; +;; F(phi, m) = sin(phi) * Rf(cos(phi)^2, 1 - m*sin(phi)^2, 1) +(defun elliptic-f (x m) + "Incomplete Elliptic integral of the first kind: + + F(x, m) = integrate(1/sqrt(1-m*sin(phi)^2), phi, 0, x) + + Note for the complete elliptic integral, you can use elliptic-k" + (let* ((precision (float-contagion x m)) + (x (coerce x precision)) + (m (coerce m precision))) + (cond ((and (realp m) (realp x)) + (cond ((> m 1) + ;; A&S 17.4.15 + ;; + ;; F(phi|m) = 1/sqrt(m)*F(theta|1/m) + ;; + ;; with sin(theta) = sqrt(m)*sin(phi) + (/ (elliptic-f (cl:asin (* (sqrt m) (sin x))) (/ m)) + (sqrt m))) + ((< m 0) + ;; A&S 17.4.17 + (let* ((m (- m)) + (m+1 (+ 1 m)) + (root (sqrt m+1)) + (m/m+1 (/ m m+1))) + (- (/ (elliptic-f (/ (float-pi m) 2) m/m+1) + root) + (/ (elliptic-f (- (/ (float-pi x) 2) x) m/m+1) + root)))) + ((= m 0) + ;; A&S 17.4.19 + x) + ((= m 1) + ;; A&S 17.4.21 + ;; + ;; F(phi,1) = log(sec(phi)+tan(phi)) + ;; = log(tan(pi/4+pi/2)) + (log (cl:tan (+ (/ x 2) (/ (float-pi x) 4))))) + ((minusp x) + (- (elliptic-f (- x) m))) + ((> x (float-pi x)) + ;; A&S 17.4.3 + (multiple-value-bind (s x-rem) + (truncate x (float-pi x)) + (+ (* 2 s (elliptic-k m)) + (elliptic-f x-rem m)))) + ((<= x (/ (float-pi x) 2)) + (let ((sin-x (sin x)) + (cos-x (cos x)) + (k (sqrt m))) + (* sin-x + (carlson-rf (* cos-x cos-x) + (* (- 1 (* k sin-x)) + (+ 1 (* k sin-x))) + 1.0)))) + ((< x (float-pi x)) + (+ (* 2 (elliptic-k m)) + (elliptic-f (- x (float pi x)) m))))) + (t + (let ((sin-x (sin x)) + (cos-x (cos x)) + (k (sqrt m))) + (* sin-x + (carlson-rf (* cos-x cos-x) + (* (- 1 (* k sin-x)) + (+ 1 (* k sin-x))) + 1))))))) commit 46359140b7aa3c0c4af6b3aabc7bcbb4cf248301 Author: Raymond Toy Date: Thu Mar 10 22:21:26 2011 -0500 Add documentation for EPSILON and add FLOAT-PI. FLOAT-PI returns a value of pi that matches the precision of the argument. diff --git a/qd-methods.lisp b/qd-methods.lisp index 6f41857..966d85f 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -1063,7 +1063,13 @@ underlying floating-point format" (frob two-arg-- cl:- sub-qd sub-d-qd sub-qd-d) (frob two-arg-* cl:* mul-qd mul-d-qd mul-qd-d) (frob two-arg-/ cl:/ div-qd nil nil)) - + +(defgeneric epsilon (m) + (:documentation +"Return an epsilon value of the same precision as the argument. It is +the smallest number x such that 1+x /= x. The argument can be +complex")) + (defmethod epsilon ((m cl:float)) (etypecase m (single-float single-float-epsilon) @@ -1082,3 +1088,23 @@ underlying floating-point format" (defmethod epsilon ((m qd-complex)) (epsilon (realpart m))) + +(defgeneric float-pi (x) + (:documentation +"Return a floating-point value of the mathematical constant pi that is +the same precision as the argument. The argument can be complex.")) + +(defmethod float-pi ((x cl:rational)) + (float pi 1f0)) + +(defmethod float-pi ((x cl:float)) + (float pi x)) + +(defmethod float-pi ((x qd-real)) + +pi+) + +(defmethod float-pi ((z cl:complex)) + (float pi (realpart z))) + +(defmethod float-pi ((z qd-complex)) + +pi+) \ No newline at end of file commit 85f3e2b22f917ff35d080180ab1e2dda4476e881 Author: Raymond Toy Date: Thu Mar 10 22:20:27 2011 -0500 Move inline function NEG-QD-T before first use. diff --git a/qd.lisp b/qd.lisp index af5a779..fb3e4e1 100644 --- a/qd.lisp +++ b/qd.lisp @@ -476,11 +476,6 @@ If TARGET is given, TARGET is destructively modified to contain the result." (%store-qd-d target (+ a0 b0) 0d0 0d0 0d0) (%store-qd-d target s0 s1 s2 s3))))))))))) -(defun neg-qd (a &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) - "Return the negative of the %QUAD-DOUBLE number A. -If TARGET is given, TARGET is destructively modified to contain the result." - (neg-qd-t a target)) - (defun neg-qd-t (a target) (declare (type %quad-double a #+oct-array target) #+(and cmu (not oct-array)) (ignore target)) @@ -489,6 +484,13 @@ If TARGET is given, TARGET is destructively modified to contain the result." (declare (double-float a0 a1 a2 a3)) (%store-qd-d target (cl:- a0) (cl:- a1) (cl:- a2) (cl:- a3)))) +(defun neg-qd (a &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) + "Return the negative of the %QUAD-DOUBLE number A. +If TARGET is given, TARGET is destructively modified to contain the result." + (neg-qd-t a target)) + + + (defun sub-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) "Return the difference between the %QUAD-DOUBLE numbers A and B. If TARGET is given, TARGET is destructively modified to contain the result." ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 161 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- qd-methods.lisp | 28 +++++++++- qd.lisp | 12 ++-- 3 files changed, 190 insertions(+), 11 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 11 04:22:53 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Thu, 10 Mar 2011 23:22:53 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 5bebc8d76a83b85cdba6d803d026aae741b6e7c8 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 5bebc8d76a83b85cdba6d803d026aae741b6e7c8 (commit) via 5f6c628014268b683e61baae5470a56b078d1c16 (commit) from c239a8514ff5f1fc96d33a4c581cbaec834f6641 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5bebc8d76a83b85cdba6d803d026aae741b6e7c8 Author: Raymond Toy Date: Thu Mar 10 23:05:08 2011 -0500 Test carlson-rf and carlson-rd. diff --git a/rt-tests.lisp b/rt-tests.lisp index 82ca0b7..85f9b95 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -833,3 +833,34 @@ (val (jacobi-dn ek #q.5))) (check-accuracy 212 val true)) nil) + +(rt:deftest oct.carlson-rf.1d + ;; Rf(0,2,1) = integrate(1/sqrt(1-s^4), s, 0 ,1) + ;; = 1/4*beta(1/2,1/2) + ;; = sqrt(%pi)/4*gamma(1/4)/gamma(3/4) + (let ((rf (carlson-rf 0d0 2d0 1d0)) + (true 1.31102877714605990523241979494d0)) + (check-accuracy 53 rf true)) + nil) + +(rt:deftest oct.carlson-rf.1q + ;; Rf(0,2,1) = integrate(1/sqrt(1-s^4), s, 0 ,1) + (let ((rf (carlson-rf #q0 #q2 #q1)) + (true #q1.311028777146059905232419794945559706841377475715811581408410851900395q0)) + (check-accuracy 212 rf true)) + nil) + +(rt:deftest oct.carlson-rd.1d + ;; Rd(0,2,1) = 3*integrate(s^2/sqrt(1-s^4), s, 0 ,1) + ;; = 3*beta(3/4,1/2)/4 + ;; = 3*sqrt(%pi)*gamma(3/4)/gamma(1/4) + (let ((rd (carlson-rd 0d0 2d0 1d0)) + (true 1.7972103521033883d0)) + (check-accuracy 51 rd true)) + nil) + +(rt:deftest oct.carlson-rd.1q + (let ((rd (carlson-rd #q0 #q2 #q1)) + (true #q1.797210352103388311159883738420485817340818994823477337395512429419599q0)) + (check-accuracy 212 rd true)) + nil) commit 5f6c628014268b683e61baae5470a56b078d1c16 Author: Raymond Toy Date: Thu Mar 10 23:04:28 2011 -0500 Add elliptic integrals of the second kind. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 63c3687..6c8070a 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -321,6 +321,73 @@ (* -3/44 ee2 ee3)))) (/ s (sqrt an))))) +;; rd(x,y,z) = integrate(3/2*(t+x)^(-1/2)*(t+y)^(-1/2)*(t+z)^(-3/2), t, 0, inf) +;; +;; E(K) = rf(0, 1-K^2, 1) - (K^2/3)*rd(0,1-K^2,1) +;; +;; B = integrate(s^2/sqrt(1-s^4), s, 0 ,1) +;; = beta(3/4,1/2)/4 +;; = sqrt(%pi)*gamma(3/4)/gamma(1/4) +;; = 1/3*rd(0,2,1) +(defun carlson-rd (x y z) + "Compute Carlson's Rd function: + + Rd(x,y,z) = integrate(3/2*(t+x)^(-1/2)*(t+y)^(-1/2)*(t+z)^(-3/2), t, 0, inf)" + (let* ((xn x) + (yn y) + (zn z) + (a (/ (+ xn yn (* 3 zn)) 5)) + (epslon (/ (max (abs (- a xn)) + (abs (- a yn)) + (abs (- a zn))) + (errtol x y z))) + (an a) + (sigma 0) + (power4 1) + (n 0) + xnroot ynroot znroot lam) + (loop while (> (* power4 epslon) (abs an)) + do + (setf xnroot (sqrt xn)) + (setf ynroot (sqrt yn)) + (setf znroot (sqrt zn)) + (setf lam (+ (* xnroot ynroot) + (* xnroot znroot) + (* ynroot znroot))) + (setf sigma (+ sigma (/ power4 + (* znroot (+ zn lam))))) + (setf power4 (* power4 1/4)) + (setf xn (* (+ xn lam) 1/4)) + (setf yn (* (+ yn lam) 1/4)) + (setf zn (* (+ zn lam) 1/4)) + (setf an (* (+ an lam) 1/4)) + (incf n)) + ;; c1=-3/14,c2=1/6,c3=9/88,c4=9/22,c5=-3/22,c6=-9/52,c7=3/26 + (let* ((xndev (/ (* (- a x) power4) an)) + (yndev (/ (* (- a y) power4) an)) + (zndev (- (* (+ xndev yndev) 1/3))) + (ee2 (- (* xndev yndev) (* 6 zndev zndev))) + (ee3 (* (- (* 3 xndev yndev) + (* 8 zndev zndev)) + zndev)) + (ee4 (* 3 (- (* xndev yndev) (* zndev zndev)) zndev zndev)) + (ee5 (* xndev yndev zndev zndev zndev)) + (s (+ 1 + (* -3/14 ee2) + (* 1/6 ee3) + (* 9/88 ee2 ee2) + (* -3/22 ee4) + (* -9/52 ee2 ee3) + (* 3/26 ee5) + (* -1/16 ee2 ee2 ee2) + (* 3/10 ee3 ee3) + (* 3/20 ee2 ee4) + (* 45/272 ee2 ee2 ee3) + (* -9/68 (+ (* ee2 ee5) (* ee3 ee4)))))) + (+ (* 3 sigma) + (/ (* power4 s) + (expt an 3/2)))))) + ;; Complete elliptic integral of the first kind. This can be computed ;; from Carlson's Rf function: ;; @@ -408,3 +475,55 @@ (* (- 1 (* k sin-x)) (+ 1 (* k sin-x))) 1))))))) + +;; Incomplete elliptic integral of the second kind. +;; +;; E(phi, m) = integrate(sqrt(1-m*sin(x)^2), x, 0, phi) +;; +(defun elliptic-e (phi m) + "Incomplete elliptic integral of the second kind: + +E(phi, m) = integrate(sqrt(1-m*sin(x)^2), x, 0, phi)" + (let* ((precision (float-contagion phi m)) + (phi (coerce phi precision)) + (m (coerce m precision))) + (cond ((= m 0) + ;; A&S 17.4.23 + phi) + ((= m 1) + ;; A&S 17.4.25 + (sin phi)) + (t + (let* ((sin-phi (sin phi)) + (cos-phi (cos phi)) + (k (sqrt m)) + (y (* (- 1 (* k sin-phi)) + (+ 1 (* k sin-phi))))) + (- (* sin-phi + (carlson-rf (* cos-phi cos-phi) y (coerce 1 precision))) + (* (/ m 3) + (expt sin-phi 3) + (carlson-rd (* cos-phi cos-phi) y (coerce 1 precision))))))))) + +;; Complete elliptic integral of second kind. +;; +;; E(phi) = integrate(sqrt(1-m*sin(x)^2), x, 0, %pi/2) +;; +(defun elliptic-ec (m) + "Complete elliptic integral of the second kind: + +E(m) = integrate(sqrt(1-m*sin(x)^2), x, 0, %pi/2)" + (let ((precision (float-contagion m))) + (cond ((= m 0) + ;; A&S 17.4.23 + (/ (float-pi m) 2)) + ((= m 1) + ;; A&S 17.4.25 + (coerce 1 precision)) + (t + (let* ((k (sqrt m)) + (y (* (- 1 k) + (+ 1 k)))) + (- (carlson-rf 0.0 y 1.0) + (* (/ m 3) + (carlson-rd 0.0 y 1.0)))))))) ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 119 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ rt-tests.lisp | 31 ++++++++++++++ 2 files changed, 150 insertions(+), 0 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 11 04:48:16 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Thu, 10 Mar 2011 23:48:16 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. e228d52f96d3ffc2f65514ebc9f37e35eae8d5f3 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via e228d52f96d3ffc2f65514ebc9f37e35eae8d5f3 (commit) via df6aef9bfd9b1845cc9707f8926cb834b3a791cf (commit) via 8c4f2161315be456cf82774bec04ed43f578ffd8 (commit) from 5bebc8d76a83b85cdba6d803d026aae741b6e7c8 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit e228d52f96d3ffc2f65514ebc9f37e35eae8d5f3 Author: Raymond Toy Date: Thu Mar 10 23:30:29 2011 -0500 Add ident attribute diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..70a6051 --- /dev/null +++ b/.gitattributes @@ -0,0 +1 @@ +qd-package.lisp ident commit df6aef9bfd9b1845cc9707f8926cb834b3a791cf Author: Raymond Toy Date: Thu Mar 10 23:29:22 2011 -0500 Add *oct-version*. diff --git a/qd-package.lisp b/qd-package.lisp index 9587038..16e1fa6 100644 --- a/qd-package.lisp +++ b/qd-package.lisp @@ -53,6 +53,8 @@ #-cmu (pushnew :oct-array *features*) +(defparameter *oct-version* "$Id$") + (defpackage #:oct-internal (:use #:cl) (:nicknames #:octi) commit 8c4f2161315be456cf82774bec04ed43f578ffd8 Author: Raymond Toy Date: Thu Mar 10 23:23:50 2011 -0500 Export Jacobi functions and elliptic integrals. diff --git a/qd-package.lisp b/qd-package.lisp index a083720..9587038 100644 --- a/qd-package.lisp +++ b/qd-package.lisp @@ -212,7 +212,7 @@ ;; Export types (:export #:qd-real #:qd-complex) - ;; Export functions + ;; Export functions that have CL equivalents (:export #:+ #:- #:* @@ -277,9 +277,16 @@ #:decf #:float-digits #:rational - #:rationalize - #:make-qd - ) + #:rationalize) + ;; Export Oct-specific functions + (:export #:make-qd + #:jacobi-sn + #:jacobi-cn + #:jacobi-dn + #:elliptic-k + #:elliptic-f + #:elliptic-e + #:elliptic-ec) ;; Constants (:export #:+pi+ #:+pi/2+ ----------------------------------------------------------------------- Summary of changes: .gitattributes | 1 + qd-package.lisp | 17 +++++++++++++---- 2 files changed, 14 insertions(+), 4 deletions(-) create mode 100644 .gitattributes hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 11 17:03:04 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Fri, 11 Mar 2011 12:03:04 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. b8ce6f63872d63160c4f6dac7d70c81a898818c2 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via b8ce6f63872d63160c4f6dac7d70c81a898818c2 (commit) from e228d52f96d3ffc2f65514ebc9f37e35eae8d5f3 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit b8ce6f63872d63160c4f6dac7d70c81a898818c2 Author: Raymond Toy Date: Fri Mar 11 11:42:04 2011 -0500 Add Id for testing gitattribute ident. diff --git a/qd-rep.lisp b/qd-rep.lisp index 2702907..4ee4dea 100644 --- a/qd-rep.lisp +++ b/qd-rep.lisp @@ -34,6 +34,8 @@ ;;; QD-3. A convenience function, QD-PARTS, is also provided to ;;; return all four values at once. +(defparameter *oct-rep-version* "$Id$") + ;; All of the following functions should be inline to reduce consing. #+(and cmu (not oct-array)) (declaim (inline ----------------------------------------------------------------------- Summary of changes: qd-rep.lisp | 2 ++ 1 files changed, 2 insertions(+), 0 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 11 17:05:27 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Fri, 11 Mar 2011 12:05:27 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 20c7d84de0700c4f8a43d0d9436b3ba74aa281dc Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 20c7d84de0700c4f8a43d0d9436b3ba74aa281dc (commit) from b8ce6f63872d63160c4f6dac7d70c81a898818c2 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 20c7d84de0700c4f8a43d0d9436b3ba74aa281dc Author: Raymond Toy Date: Fri Mar 11 11:47:27 2011 -0500 Add ident attribute for all Lisp files. diff --git a/.gitattributes b/.gitattributes index 70a6051..3015fc3 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1 +1 @@ -qd-package.lisp ident +*.lisp ident ----------------------------------------------------------------------- Summary of changes: .gitattributes | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 11 22:35:31 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Fri, 11 Mar 2011 17:35:31 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch cvs-ids created. 4c22d173b3945fa8817b0ecb6fcef69d162c3d8d Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, cvs-ids has been created at 4c22d173b3945fa8817b0ecb6fcef69d162c3d8d (commit) - Log ----------------------------------------------------------------- commit 4c22d173b3945fa8817b0ecb6fcef69d162c3d8d Author: Raymond Toy Date: Fri Mar 11 16:53:49 2011 -0500 Add kwexpand and kwunexpand scripts. diff --git a/kwunexpand b/kwunexpand new file mode 100755 index 0000000..4bfd86b --- /dev/null +++ b/kwunexpand @@ -0,0 +1,5 @@ +#! /bin/sh + +# Could combine this into one regex, but not all seds support () and | +# (or is that \(\) and \|)? +sed -e 's/\$Date:[^$]*\$/$Date$/' -e 's/\$Revision:[^$]*\$/$Revision$/' -e 's/\$Id:[^$]*\$/$Id$/' commit fafb5863a52f842bf40ca7b2af9a0ec68b2e6010 Author: Raymond Toy Date: Fri Mar 11 16:53:34 2011 -0500 Add kwexpand and kwunexpand scripts. diff --git a/kwexpand b/kwexpand new file mode 100755 index 0000000..2c06251 --- /dev/null +++ b/kwexpand @@ -0,0 +1,6 @@ +#! /bin/sh + +lastdate=`git log --pretty=format:"%ai" -1` +lastid=`git log --pretty=format:"%h %ai %ae" -1` +lastrev=`git log --pretty=format:"%h" -1` +sed -e "s/\\\$Date\\\$/\$Date: $lastdate \$/g" -e "s/\\\$Revision\\\$/\$Revision: $lastrev \$/g" -e "s/\\\$Id\\\$/\$Id: $lastid \$/g" commit 6195784bc3604d1f7d530d91db79bc92cd6bd7a3 Author: Raymond Toy Date: Fri Mar 11 14:58:56 2011 -0500 Add some blank lines to change file. diff --git a/qd.lisp b/qd.lisp index 83cd65c..2f3f550 100644 --- a/qd.lisp +++ b/qd.lisp @@ -1364,3 +1364,5 @@ is a fixnum." (values (scale-float-qd q (- exp)) exp (make-qd-d sign)))) + + commit 3a8139772ad7204e257e22f86e3afaa228a2d2cd Author: Raymond Toy Date: Fri Mar 11 14:56:22 2011 -0500 Test cvs keyword expansion .gitattributes: o Add filter for cvskeywords qd-rep.lisp: qd.lisp: o Add $Id$ to test expansion diff --git a/.gitattributes b/.gitattributes index 3015fc3..d9eafe8 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1 +1,3 @@ -*.lisp ident +*.lisp filter=cvskeywords + + diff --git a/qd-rep.lisp b/qd-rep.lisp index 4ee4dea..b3342ce 100644 --- a/qd-rep.lisp +++ b/qd-rep.lisp @@ -35,6 +35,7 @@ ;;; return all four values at once. (defparameter *oct-rep-version* "$Id$") +(defvar *id-qd-rep* "qd-rep.lisp $Id$") ;; All of the following functions should be inline to reduce consing. #+(and cmu (not oct-array)) diff --git a/qd.lisp b/qd.lisp index fb3e4e1..83cd65c 100644 --- a/qd.lisp +++ b/qd.lisp @@ -38,6 +38,8 @@ (in-package #:octi) +(defvar *qd-id* "qd.lisp $Id$") + #+cmu (eval-when (:compile-toplevel) (setf ext:*inline-expansion-limit* 1600)) ----------------------------------------------------------------------- hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 11 22:38:44 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Fri, 11 Mar 2011 17:38:44 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 5c21f133b0ebb511c664ab9fd967732cca6b76ea Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 5c21f133b0ebb511c664ab9fd967732cca6b76ea (commit) from 20c7d84de0700c4f8a43d0d9436b3ba74aa281dc (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5c21f133b0ebb511c664ab9fd967732cca6b76ea Author: Raymond Toy Date: Fri Mar 11 17:19:58 2011 -0500 Remove cvs keyword experiment .gitattributes: o deleted qd-package.lisp: qd-rep.lisp: o Remove $Id$ diff --git a/.gitattributes b/.gitattributes deleted file mode 100644 index 3015fc3..0000000 --- a/.gitattributes +++ /dev/null @@ -1 +0,0 @@ -*.lisp ident diff --git a/qd-package.lisp b/qd-package.lisp index 16e1fa6..9587038 100644 --- a/qd-package.lisp +++ b/qd-package.lisp @@ -53,8 +53,6 @@ #-cmu (pushnew :oct-array *features*) -(defparameter *oct-version* "$Id$") - (defpackage #:oct-internal (:use #:cl) (:nicknames #:octi) diff --git a/qd-rep.lisp b/qd-rep.lisp index 4ee4dea..2702907 100644 --- a/qd-rep.lisp +++ b/qd-rep.lisp @@ -34,8 +34,6 @@ ;;; QD-3. A convenience function, QD-PARTS, is also provided to ;;; return all four values at once. -(defparameter *oct-rep-version* "$Id$") - ;; All of the following functions should be inline to reduce consing. #+(and cmu (not oct-array)) (declaim (inline ----------------------------------------------------------------------- Summary of changes: .gitattributes | 1 - qd-package.lisp | 2 -- qd-rep.lisp | 2 -- 3 files changed, 0 insertions(+), 5 deletions(-) delete mode 100644 .gitattributes hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Sat Mar 12 04:30:15 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Fri, 11 Mar 2011 23:30:15 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 147fa2c7aa5e99988a7c3fb35800865d22efbc51 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 147fa2c7aa5e99988a7c3fb35800865d22efbc51 (commit) via e2d8d63c0c06c474f32b76ebbb7e4cde44aac736 (commit) from 5c21f133b0ebb511c664ab9fd967732cca6b76ea (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 147fa2c7aa5e99988a7c3fb35800865d22efbc51 Author: Raymond Toy Date: Fri Mar 11 23:11:32 2011 -0500 Add tests for contagion support. diff --git a/rt-tests.lisp b/rt-tests.lisp index 85f9b95..7635611 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -864,3 +864,68 @@ (true #q1.797210352103388311159883738420485817340818994823477337395512429419599q0)) (check-accuracy 212 rd true)) nil) + +;; Test some of the contagion stuff. + +(rt:deftest oct.carlson-rf.contagion.1 + ;; Rf(0,2,1) = integrate(1/sqrt(1-s^4), s, 0 ,1) + ;; = 1/4*beta(1/2,1/2) + ;; = sqrt(%pi)/4*gamma(1/4)/gamma(3/4) + (let ((rf (carlson-rf 0 2 1)) + (true 1.31102877714605990523241979494d0)) + (check-accuracy 23 rf true)) + nil) + +(rt:deftest oct.carlson-rf.contagion.1d + ;; Rf(0,2,1) = integrate(1/sqrt(1-s^4), s, 0 ,1) + ;; = 1/4*beta(1/2,1/2) + ;; = sqrt(%pi)/4*gamma(1/4)/gamma(3/4) + (let ((rf (carlson-rf 0d0 2 1)) + (true 1.31102877714605990523241979494d0)) + (check-accuracy 53 rf true)) + nil) + +(rt:deftest oct.carlson-rf.contagion.2d + ;; Rf(0,2,1) = integrate(1/sqrt(1-s^4), s, 0 ,1) + ;; = 1/4*beta(1/2,1/2) + ;; = sqrt(%pi)/4*gamma(1/4)/gamma(3/4) + (let ((rf (carlson-rf 0 2d0 1)) + (true 1.31102877714605990523241979494d0)) + (check-accuracy 53 rf true)) + nil) + +(rt:deftest oct.carlson-rf.contagion.3d + ;; Rf(0,2,1) = integrate(1/sqrt(1-s^4), s, 0 ,1) + ;; = 1/4*beta(1/2,1/2) + ;; = sqrt(%pi)/4*gamma(1/4)/gamma(3/4) + (let ((rf (carlson-rf 0 2 1d0)) + (true 1.31102877714605990523241979494d0)) + (check-accuracy 53 rf true)) + nil) + +(rt:deftest oct.carlson-rf.contagion.1q + ;; Rf(0,2,1) = integrate(1/sqrt(1-s^4), s, 0 ,1) + ;; = 1/4*beta(1/2,1/2) + ;; = sqrt(%pi)/4*gamma(1/4)/gamma(3/4) + (let ((rf (carlson-rf #q0q0 2 1)) + (true #q1.311028777146059905232419794945559706841377475715811581408410851900395q0)) + (check-accuracy 212 rf true)) + nil) + +(rt:deftest oct.carlson-rf.contagion.2q + ;; Rf(0,2,1) = integrate(1/sqrt(1-s^4), s, 0 ,1) + ;; = 1/4*beta(1/2,1/2) + ;; = sqrt(%pi)/4*gamma(1/4)/gamma(3/4) + (let ((rf (carlson-rf 0 #q2q0 1)) + (true #q1.311028777146059905232419794945559706841377475715811581408410851900395q0)) + (check-accuracy 212 rf true)) + nil) + +(rt:deftest oct.carlson-rf.contagion.3q + ;; Rf(0,2,1) = integrate(1/sqrt(1-s^4), s, 0 ,1) + ;; = 1/4*beta(1/2,1/2) + ;; = sqrt(%pi)/4*gamma(1/4)/gamma(3/4) + (let ((rf (carlson-rf 0 2 #q1q0)) + (true #q1.311028777146059905232419794945559706841377475715811581408410851900395q0)) + (check-accuracy 212 rf true)) + nil) \ No newline at end of file commit e2d8d63c0c06c474f32b76ebbb7e4cde44aac736 Author: Raymond Toy Date: Fri Mar 11 22:57:40 2011 -0500 Clean up float-contagion stuff; use it in Carlson routines. o FLOAT-CONTAGION now only returns the real type, not a complex type. o Add APPLY-CONTAGION to make the specified conversion. This handle complex numbers and makes the components have the specified precision. o Change uses of contagion stuff to use APPLY-CONTAGION. o Use the contagion stuff in CARLSON-RD and CARLSON-RF. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 6c8070a..342290e 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -72,12 +72,16 @@ (single-float 'single-float) (double-float 'double-float) (qd-real 'qd-real)))) - (if complexp - (if (eq max-type 'qd-real) - 'qd-complex - `(cl:complex ,max-type)) - max-type))) - + max-type)) + +(defun apply-contagion (number precision) + (etypecase number + ((or cl:real qd-real) + (coerce number precision)) + ((or cl:complex qd-complex) + (complex (coerce (realpart number) precision) + (coerce (imagpart number) precision))))) + ;;; Jacobian elliptic functions (defun ascending-transform (u m) @@ -282,9 +286,10 @@ "Compute Carlson's Rf function: Rf(x, y, z) = 1/2*integrate((t+x)^(-1/2)*(t+y)^(-1/2)*(t+z)^(-1/2), t, 0, inf)" - (let* ((xn x) - (yn y) - (zn z) + (let* ((precision (float-contagion x y z)) + (xn (apply-contagion x precision)) + (yn (apply-contagion y precision)) + (zn (apply-contagion z precision)) (a (/ (+ xn yn zn) 3)) (epslon (/ (max (abs (- a xn)) (abs (- a yn)) @@ -333,9 +338,10 @@ "Compute Carlson's Rd function: Rd(x,y,z) = integrate(3/2*(t+x)^(-1/2)*(t+y)^(-1/2)*(t+z)^(-3/2), t, 0, inf)" - (let* ((xn x) - (yn y) - (zn z) + (let* ((precision (float-contagion x y z)) + (xn (apply-contagion x precision)) + (yn (apply-contagion y precision)) + (zn (apply-contagion z precision)) (a (/ (+ xn yn (* 3 zn)) 5)) (epslon (/ (max (abs (- a xn)) (abs (- a yn)) @@ -348,20 +354,20 @@ xnroot ynroot znroot lam) (loop while (> (* power4 epslon) (abs an)) do - (setf xnroot (sqrt xn)) - (setf ynroot (sqrt yn)) - (setf znroot (sqrt zn)) - (setf lam (+ (* xnroot ynroot) - (* xnroot znroot) - (* ynroot znroot))) - (setf sigma (+ sigma (/ power4 - (* znroot (+ zn lam))))) - (setf power4 (* power4 1/4)) - (setf xn (* (+ xn lam) 1/4)) - (setf yn (* (+ yn lam) 1/4)) - (setf zn (* (+ zn lam) 1/4)) - (setf an (* (+ an lam) 1/4)) - (incf n)) + (setf xnroot (sqrt xn)) + (setf ynroot (sqrt yn)) + (setf znroot (sqrt zn)) + (setf lam (+ (* xnroot ynroot) + (* xnroot znroot) + (* ynroot znroot))) + (setf sigma (+ sigma (/ power4 + (* znroot (+ zn lam))))) + (setf power4 (* power4 1/4)) + (setf xn (* (+ xn lam) 1/4)) + (setf yn (* (+ yn lam) 1/4)) + (setf zn (* (+ zn lam) 1/4)) + (setf an (* (+ an lam) 1/4)) + (incf n)) ;; c1=-3/14,c2=1/6,c3=9/88,c4=9/22,c5=-3/22,c6=-9/52,c7=3/26 (let* ((xndev (/ (* (- a x) power4) an)) (yndev (/ (* (- a y) power4) an)) @@ -384,9 +390,9 @@ (* 3/20 ee2 ee4) (* 45/272 ee2 ee2 ee3) (* -9/68 (+ (* ee2 ee5) (* ee3 ee4)))))) - (+ (* 3 sigma) - (/ (* power4 s) - (expt an 3/2)))))) + (+ (* 3 sigma) + (/ (* power4 s) + (expt an 3/2)))))) ;; Complete elliptic integral of the first kind. This can be computed ;; from Carlson's Rf function: @@ -403,7 +409,7 @@ (/ (float +pi+ m) 2)) (t (let ((precision (float-contagion m))) - (carlson-rf (coerce 0 precision) (- 1 m) (coerce 1 precision)))))) + (carlson-rf 0 (- 1 m) 1))))) ;; Elliptic integral of the first kind. This is computed using ;; Carlson's Rf function: @@ -416,8 +422,8 @@ Note for the complete elliptic integral, you can use elliptic-k" (let* ((precision (float-contagion x m)) - (x (coerce x precision)) - (m (coerce m precision))) + (x (apply-contagion x precision)) + (m (apply-contagion m precision))) (cond ((and (realp m) (realp x)) (cond ((> m 1) ;; A&S 17.4.15 @@ -425,7 +431,7 @@ ;; F(phi|m) = 1/sqrt(m)*F(theta|1/m) ;; ;; with sin(theta) = sqrt(m)*sin(phi) - (/ (elliptic-f (cl:asin (* (sqrt m) (sin x))) (/ m)) + (/ (elliptic-f (asin (* (sqrt m) (sin x))) (/ m)) (sqrt m))) ((< m 0) ;; A&S 17.4.17 @@ -445,7 +451,7 @@ ;; ;; F(phi,1) = log(sec(phi)+tan(phi)) ;; = log(tan(pi/4+pi/2)) - (log (cl:tan (+ (/ x 2) (/ (float-pi x) 4))))) + (log (tan (+ (/ x 2) (/ (float-pi x) 4))))) ((minusp x) (- (elliptic-f (- x) m))) ((> x (float-pi x)) @@ -462,7 +468,7 @@ (carlson-rf (* cos-x cos-x) (* (- 1 (* k sin-x)) (+ 1 (* k sin-x))) - 1.0)))) + 1)))) ((< x (float-pi x)) (+ (* 2 (elliptic-k m)) (elliptic-f (- x (float pi x)) m))))) @@ -485,8 +491,8 @@ E(phi, m) = integrate(sqrt(1-m*sin(x)^2), x, 0, phi)" (let* ((precision (float-contagion phi m)) - (phi (coerce phi precision)) - (m (coerce m precision))) + (phi (apply-contagion phi precision)) + (m (apply-contagion m precision))) (cond ((= m 0) ;; A&S 17.4.23 phi) @@ -500,10 +506,10 @@ E(phi, m) = integrate(sqrt(1-m*sin(x)^2), x, 0, phi)" (y (* (- 1 (* k sin-phi)) (+ 1 (* k sin-phi))))) (- (* sin-phi - (carlson-rf (* cos-phi cos-phi) y (coerce 1 precision))) + (carlson-rf (* cos-phi cos-phi) y 1)) (* (/ m 3) (expt sin-phi 3) - (carlson-rd (* cos-phi cos-phi) y (coerce 1 precision))))))))) + (carlson-rd (* cos-phi cos-phi) y 1)))))))) ;; Complete elliptic integral of second kind. ;; @@ -513,17 +519,16 @@ E(phi, m) = integrate(sqrt(1-m*sin(x)^2), x, 0, phi)" "Complete elliptic integral of the second kind: E(m) = integrate(sqrt(1-m*sin(x)^2), x, 0, %pi/2)" - (let ((precision (float-contagion m))) - (cond ((= m 0) - ;; A&S 17.4.23 - (/ (float-pi m) 2)) - ((= m 1) - ;; A&S 17.4.25 - (coerce 1 precision)) - (t - (let* ((k (sqrt m)) - (y (* (- 1 k) - (+ 1 k)))) - (- (carlson-rf 0.0 y 1.0) - (* (/ m 3) - (carlson-rd 0.0 y 1.0)))))))) + (cond ((= m 0) + ;; A&S 17.4.23 + (/ (float-pi m) 2)) + ((= m 1) + ;; A&S 17.4.25 + (float 1 m)) + (t + (let* ((k (sqrt m)) + (y (* (- 1 k) + (+ 1 k)))) + (- (carlson-rf 0 y 1) + (* (/ m 3) + (carlson-rd 0 y 1))))))) ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 111 ++++++++++++++++++++++++++++-------------------------- rt-tests.lisp | 65 +++++++++++++++++++++++++++++++ 2 files changed, 123 insertions(+), 53 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Sat Mar 12 19:00:40 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Sat, 12 Mar 2011 14:00:40 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 390a7483f5658fe802d5d239070cdaa573adf4a5 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 390a7483f5658fe802d5d239070cdaa573adf4a5 (commit) from 147fa2c7aa5e99988a7c3fb35800865d22efbc51 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 390a7483f5658fe802d5d239070cdaa573adf4a5 Author: Raymond Toy Date: Sat Mar 12 13:35:18 2011 -0500 Add prelimary support for integrals of the 3rd kind. qd-elliptic.lisp: o Clean up for unused variable in ELLIPTIC-K o Add Carlson's Rj functions o Implement elliptic-pi using Carlson's method. rt-tests.lisp: o Add many tests for elliptic-pi. Some tests pass, and some fail. The failing tests are not enabled because I don't know if the failure is because the test itself is wrong or if the integral is wrong. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 342290e..1b80f13 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -408,8 +408,7 @@ (cond ((= m 0) (/ (float +pi+ m) 2)) (t - (let ((precision (float-contagion m))) - (carlson-rf 0 (- 1 m) 1))))) + (carlson-rf 0 (- 1 m) 1)))) ;; Elliptic integral of the first kind. This is computed using ;; Carlson's Rf function: @@ -532,3 +531,186 @@ E(m) = integrate(sqrt(1-m*sin(x)^2), x, 0, %pi/2)" (- (carlson-rf 0 y 1) (* (/ m 3) (carlson-rd 0 y 1))))))) + +;; Carlson's Rc function. +;; +;; Some interesting identities: +;; +;; log(x) = (x-1)*rc(((1+x)/2)^2, x), x > 0 +;; asin(x) = x * rc(1-x^2, 1), |x|<= 1 +;; acos(x) = sqrt(1-x^2)*rc(x^2,1), 0 <= x <=1 +;; atan(x) = x * rc(1,1+x^2) +;; asinh(x) = x * rc(1+x^2,1) +;; acosh(x) = sqrt(x^2-1) * rc(x^2,1), x >= 1 +;; atanh(x) = x * rc(1,1-x^2), |x|<=1 +;; + +(defun carlson-rc (x y) + "Compute Carlson's Rc function: + + Rc(x,y) = integrate(1/2*(t+x)^(-1/2)*(t+y)^(-1), t, 0, inf)" + (let* ((precision (float-contagion x y)) + (yn (apply-contagion y precision)) + (x (apply-contagion x precision)) + xn z w a an pwr4 n epslon lambda sn s) + (cond ((and (zerop (imagpart yn)) + (minusp (realpart yn))) + (setf xn (- x y)) + (setf yn (- yn)) + (setf z yn) + (setf w (sqrt (/ x xn)))) + (t + (setf xn x) + (setf z yn) + (setf w 1))) + (setf a (/ (+ xn yn yn) 3)) + (setf epslon (/ (abs (- a xn)) (errtol x y))) + (setf an a) + (setf pwr4 1) + (setf n 0) + (loop while (> (* epslon pwr4) (abs an)) + do + (setf pwr4 (/ pwr4 4)) + (setf lambda (+ (* 2 (sqrt xn) (sqrt yn)) yn)) + (setf an (/ (+ an lambda) 4)) + (setf xn (/ (+ xn lambda) 4)) + (setf yn (/ (+ yn lambda) 4)) + (incf n)) + ;; c2=3/10,c3=1/7,c4=3/8,c5=9/22,c6=159/208,c7=9/8 + (setf sn (/ (* pwr4 (- z a)) an)) + (setf s (* sn sn (+ 3/10 + (* sn (+ 1/7 + (* sn (+ 3/8 + (* sn (+ 9/22 + (* sn (+ 159/208 + (* sn 9/8)))))))))))) + (/ (* w (+ 1 s)) + (sqrt an)))) + +(defun carlson-rj1 (x y z p) + (let* ((xn x) + (yn y) + (zn z) + (pn p) + (en (* (- pn xn) + (- pn yn) + (- pn zn))) + (sigma 0) + (power4 1) + (k 0) + (a (/ (+ xn yn zn pn pn) 5)) + (epslon (/ (max (abs (- a xn)) + (abs (- a yn)) + (abs (- a zn)) + (abs (- a pn))) + (errtol x y z p))) + (an a) + xnroot ynroot znroot pnroot lam dn) + (loop while (> (* power4 epslon) (abs an)) + do + (setf xnroot (sqrt xn)) + (setf ynroot (sqrt yn)) + (setf znroot (sqrt zn)) + (setf pnroot (sqrt pn)) + (setf lam (+ (* xnroot ynroot) + (* xnroot znroot) + (* ynroot znroot))) + (setf dn (* (+ pnroot xnroot) + (+ pnroot ynroot) + (+ pnroot znroot))) + (setf sigma (+ sigma + (/ (* power4 + (carlson-rc 1 (+ 1 (/ en (* dn dn))))) + dn))) + (setf power4 (* power4 1/4)) + (setf en (/ en 64)) + (setf xn (* (+ xn lam) 1/4)) + (setf yn (* (+ yn lam) 1/4)) + (setf zn (* (+ zn lam) 1/4)) + (setf pn (* (+ pn lam) 1/4)) + (setf an (* (+ an lam) 1/4)) + (incf k)) + (let* ((xndev (/ (* (- a x) power4) an)) + (yndev (/ (* (- a y) power4) an)) + (zndev (/ (* (- a z) power4) an)) + (pndev (* -0.5 (+ xndev yndev zndev))) + (ee2 (+ (* xndev yndev) + (* xndev zndev) + (* yndev zndev) + (* -3 pndev pndev))) + (ee3 (+ (* xndev yndev zndev) + (* 2 ee2 pndev) + (* 4 pndev pndev pndev))) + (ee4 (* (+ (* 2 xndev yndev zndev) + (* ee2 pndev) + (* 3 pndev pndev pndev)) + pndev)) + (ee5 (* xndev yndev zndev pndev pndev)) + (s (+ 1 + (* -3/14 ee2) + (* 1/6 ee3) + (* 9/88 ee2 ee2) + (* -3/22 ee4) + (* -9/52 ee2 ee3) + (* 3/26 ee5) + (* -1/16 ee2 ee2 ee2) + (* 3/10 ee3 ee3) + (* 3/20 ee2 ee4) + (* 45/272 ee2 ee2 ee3) + (* -9/68 (+ (* ee2 ee5) (* ee3 ee4)))))) + (+ (* 6 sigma) + (/ (* power4 s) + (sqrt (* an an an))))))) + +(defun carlson-rj (x y z p) + "Compute Carlson's Rj function: + + Rj(x,y,z,p) = integrate(3/2*(t+x)^(-1/2)*(t+y)^(-1/2)*(t+z)^(-1/2)*(t+p)^(-1), t, 0, inf)" + (let* ((precision (float-contagion x y z p)) + (xn (apply-contagion x precision)) + (yn (apply-contagion y precision)) + (zn (apply-contagion z precision)) + (p (apply-contagion p precision)) + (qn (- p))) + (cond ((and (and (zerop (imagpart xn)) (>= (realpart xn) 0)) + (and (zerop (imagpart yn)) (>= (realpart yn) 0)) + (and (zerop (imagpart zn)) (>= (realpart zn) 0)) + (and (zerop (imagpart qn)) (> (realpart qn) 0))) + (destructuring-bind (xn yn zn) + (sort (list xn yn zn) #'<) + (let* ((pn (+ yn (* (- zn yn) (/ (- yn xn) (+ yn qn))))) + (s (- (* (- pn yn) (carlson-rj1 xn yn zn pn)) + (* 3 (carlson-rf xn yn zn))))) + (setf s (+ s (* 3 (sqrt (/ (* xn yn zn) + (+ (* xn zn) (* pn qn)))) + (carlson-rc (+ (* xn zn) (* pn qn)) (* pn qn))))) + (/ s (+ yn qn))))) + (t + (carlson-rj1 x y z p))))) + +;; Elliptic integral of the third kind: +;; +;; (A&S 17.2.14) +;; +;; PI(n; phi|m) = integrate(1/sqrt(1-m*sin(x)^2)/(1-n*sin(x)^2), x, 0, phi) +;; +(defun elliptic-pi (n phi m) + "Compute elliptic integral of the third kind: + + PI(n; phi|m) = integrate(1/sqrt(1-m*sin(x)^2)/(1-n*sin(x)^2), x, 0, phi)" + ;; Note: Carlson's DRJ has n defined as the negative of the n given + ;; in A&S. + (let* ((precision (float-contagion n phi m)) + (n (apply-contagion n precision)) + (phi (apply-contagion phi precision)) + (m (apply-contagion m precision)) + (nn (- n)) + (sin-phi (sin phi)) + (cos-phi (cos phi)) + (k (sqrt m)) + (k2sin (* (- 1 (* k sin-phi)) + (+ 1 (* k sin-phi))))) + (- (* sin-phi (carlson-rf (expt cos-phi 2) k2sin 1)) + (* (/ nn 3) (expt sin-phi 3) + (carlson-rj (expt cos-phi 2) k2sin 1 + (+ 1 (* nn (expt sin-phi 2)))))))) diff --git a/rt-tests.lisp b/rt-tests.lisp index 7635611..80d5c57 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -928,4 +928,143 @@ (let ((rf (carlson-rf 0 2 #q1q0)) (true #q1.311028777146059905232419794945559706841377475715811581408410851900395q0)) (check-accuracy 212 rf true)) - nil) \ No newline at end of file + nil) + +;; Elliptic integral of the third kind + +;; elliptic-pi(0,phi,m) = elliptic-f(phi, m) +(rt:deftest oct.elliptic-pi.1d + (loop for k from 0 to 100 + for phi = (random (/ pi 2)) + for m = (random 1d0) + for epi = (elliptic-pi 0 phi m) + for ef = (elliptic-f phi m) + for result = (check-accuracy 53 epi ef) + unless (eq nil result) + append (list (list phi m) result)) + nil) + +(rt:deftest oct.elliptic-pi.1q + (loop for k from 0 below 100 + for phi = (random (/ +pi+ 2)) + for m = (random #q1) + for epi = (elliptic-pi 0 phi m) + for ef = (elliptic-f phi m) + for result = (check-accuracy 53 epi ef) + unless (eq nil result) + append (list (list phi m) result)) + nil) + +;; DLMF 19.6.3 +;; +;; PI(n; pi/2 | 0) = pi/(2*sqrt(1-n)) +(rt:deftest oct.elliptic-pi.19.6.3.d + (loop for k from 0 below 100 + for n = (random 1d0) + for epi = (elliptic-pi n (/ pi 2) 0) + for true = (/ pi (* 2 (sqrt (- 1 n)))) + for result = (check-accuracy 49 epi true) + unless (eq nil result) + append (list (list (list k n) result))) + nil) + +(rt:deftest oct.elliptic-pi.19.6.3.q + (loop for k from 0 below 100 + for n = (random #q1) + for epi = (elliptic-pi n (/ (float-pi n) 2) 0) + for true = (/ (float-pi n) (* 2 (sqrt (- 1 n)))) + for result = (check-accuracy 210 epi true) + unless (eq nil result) + append (list (list (list k n) result))) + nil) + +#+nil +(rt:deftest oct.elliptic-pi.19.6.2.d + (loop for k from 0 below 100 + for n = (random 1d0) + for epi = (elliptic-pi (- n) (/ (float-pi n) 2) n) + for true = (+ (/ (float-pi n) 4 (sqrt (+ 1 (sqrt n)))) + (/ (elliptic-k n) 2)) + for result = (check-accuracy 53 epi true) + when result + append (list (list (list k n) result))) + nil) + + +#|| +;; elliptic-pi(n, phi, 0) = +;; atanh(sqrt(1-n)*tan(phi))/sqrt(1-n) n < 1 +;; atanh(sqrt(n-1)*tan(phi))/sqrt(n-1) n > 1 +;; tan(phi) n = 1 +(rt:deftest oct.elliptic-pi.n0.d + (loop for k from 0 below 100 + for phi = (random (/ pi 2)) + for n = (random 1d0) + for epi = (elliptic-pi n phi 0) + for true = (/ (atanh (* (tan phi) (sqrt (- 1 n)))) + (sqrt (- 1 n))) + for result = (check-accuracy 53 epi true) + unless (eq nil result) + append (list (list (list k n phi) result))) + nil) + +(rt:deftest oct.elliptic-pi.n1.d + (loop for k from 0 below 100 + for phi = (random (/ pi 2)) + for epi = (elliptic-pi 0 phi 0) + for true = (tan phi) + for result = (check-accuracy 53 epi true) + unless (eq nil result) + append (list (list (list k phi) result))) + nil) + +(rt:deftest oct.elliptic-pi.n2.d + (loop for k from 0 below 100 + for phi = (random (/ pi 2)) + for n = (+ 1d0 (random 100d0)) + for epi = (elliptic-pi n phi 0) + for true = (/ (atanh (* (tan phi) (sqrt (- n 1)))) + (sqrt (- n 1))) + for result = (check-accuracy 52 epi true) + ;; Not sure if this formula holds when atanh gives a complex + ;; result. Wolfram doesn't say + when (and (not (complexp true)) result) + append (list (list (list k n phi) result))) + nil) + +(rt:deftest oct.elliptic-pi.n0.q + (loop for k from 0 below 100 + for phi = (random (/ +pi+ 2)) + for n = (random #q1) + for epi = (elliptic-pi n phi 0) + for true = (/ (atanh (* (tan phi) (sqrt (- 1 n)))) + (sqrt (- 1 n))) + for result = (check-accuracy 212 epi true) + unless (eq nil result) + append (list (list (list k n phi) result))) + nil) + +(rt:deftest oct.elliptic-pi.n1.q + (loop for k from 0 below 100 + for phi = (random (/ +pi+ 2)) + for epi = (elliptic-pi 0 phi 0) + for true = (tan phi) + for result = (check-accuracy 212 epi true) + unless (eq nil result) + append (list (list (list k phi) result))) + nil) + +(rt:deftest oct.elliptic-pi.n2.q + (loop for k from 0 below 100 + for phi = (random (/ +pi+ 2)) + for n = (+ #q1 (random #q1)) + for epi = (elliptic-pi n phi 0) + for true = (/ (atanh (* (tan phi) (sqrt (- n 1)))) + (sqrt (- n 1))) + for result = (check-accuracy 209 epi true) + ;; Not sure if this formula holds when atanh gives a complex + ;; result. Wolfram doesn't say + when (and (not (complexp true)) result) + append (list (list (list k n phi) result))) + nil) +||# ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 186 +++++++++++++++++++++++++++++++++++++++++++++++++++++- rt-tests.lisp | 141 ++++++++++++++++++++++++++++++++++++++++- 2 files changed, 324 insertions(+), 3 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Sat Mar 12 23:30:08 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Sat, 12 Mar 2011 18:30:08 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 5bd5df9360268fae90fc41fcdf86b728f8a54e86 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 5bd5df9360268fae90fc41fcdf86b728f8a54e86 (commit) from 390a7483f5658fe802d5d239070cdaa573adf4a5 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5bd5df9360268fae90fc41fcdf86b728f8a54e86 Author: Raymond Toy Date: Sat Mar 12 18:21:55 2011 -0500 Fix possible bug in elliptic-pi; add comments. qd-elliptic.lisp: o Add some comments o Fix a possible bug if n is a complex number or a negative number. rt-tests.lisp: o Remove one broken test. o Fix the other tests for elliptic-pi and adjust required precision down a bit so the tests can pass. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 1b80f13..eafca11 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -694,12 +694,18 @@ E(m) = integrate(sqrt(1-m*sin(x)^2), x, 0, %pi/2)" ;; ;; PI(n; phi|m) = integrate(1/sqrt(1-m*sin(x)^2)/(1-n*sin(x)^2), x, 0, phi) ;; +;; +;; Carlson writes +;; +;; P(phi,k,n) = integrate((1+n*sin(t)^2)^(-1)*(1-k^2*sin(t)^2)^(-1/2), t, 0, phi) +;; = sin(phi)*Rf(cos(phi)^2, 1-k^2*sin(phi)^2, 1) +;; - n/3*sin(phi)^3*Rj(cos(phi)^2, 1-k^2*sin(phi)^2, 1, 1+n*sin(phi)^2) +;; +;; Note that this definition as a different sign for the n parameter from A&S! (defun elliptic-pi (n phi m) "Compute elliptic integral of the third kind: PI(n; phi|m) = integrate(1/sqrt(1-m*sin(x)^2)/(1-n*sin(x)^2), x, 0, phi)" - ;; Note: Carlson's DRJ has n defined as the negative of the n given - ;; in A&S. (let* ((precision (float-contagion n phi m)) (n (apply-contagion n precision)) (phi (apply-contagion phi precision)) @@ -707,10 +713,8 @@ E(m) = integrate(sqrt(1-m*sin(x)^2), x, 0, %pi/2)" (nn (- n)) (sin-phi (sin phi)) (cos-phi (cos phi)) - (k (sqrt m)) - (k2sin (* (- 1 (* k sin-phi)) - (+ 1 (* k sin-phi))))) - (- (* sin-phi (carlson-rf (expt cos-phi 2) k2sin 1)) + (m-sin2 (- 1 (* m sin-phi sin-phi))) + (- (* sin-phi (carlson-rf (expt cos-phi 2) m-sin2 1)) (* (/ nn 3) (expt sin-phi 3) - (carlson-rj (expt cos-phi 2) k2sin 1 + (carlson-rj (expt cos-phi 2) m-sin2 1 (+ 1 (* nn (expt sin-phi 2)))))))) diff --git a/rt-tests.lisp b/rt-tests.lisp index 80d5c57..ab81f6a 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -978,32 +978,26 @@ append (list (list (list k n) result))) nil) -#+nil -(rt:deftest oct.elliptic-pi.19.6.2.d - (loop for k from 0 below 100 - for n = (random 1d0) - for epi = (elliptic-pi (- n) (/ (float-pi n) 2) n) - for true = (+ (/ (float-pi n) 4 (sqrt (+ 1 (sqrt n)))) - (/ (elliptic-k n) 2)) - for result = (check-accuracy 53 epi true) - when result - append (list (list (list k n) result))) - nil) - - -#|| ;; elliptic-pi(n, phi, 0) = -;; atanh(sqrt(1-n)*tan(phi))/sqrt(1-n) n < 1 +;; atan(sqrt(1-n)*tan(phi))/sqrt(1-n) n < 1 ;; atanh(sqrt(n-1)*tan(phi))/sqrt(n-1) n > 1 ;; tan(phi) n = 1 +;; +;; These are easy to derive if you look at the integral: +;; +;; ellipti-pi(n, phi, 0) = integrate(1/(1-n*sin(t)^2), t, 0, phi) +;; +;; and this can be easily integrated to give the above expressions for +;; the different values of n. (rt:deftest oct.elliptic-pi.n0.d + ;; Tests for random values for phi in [0, pi/2] and n in [0, 1] (loop for k from 0 below 100 for phi = (random (/ pi 2)) for n = (random 1d0) for epi = (elliptic-pi n phi 0) - for true = (/ (atanh (* (tan phi) (sqrt (- 1 n)))) + for true = (/ (atan (* (tan phi) (sqrt (- 1 n)))) (sqrt (- 1 n))) - for result = (check-accuracy 53 epi true) + for result = (check-accuracy 50 epi true) unless (eq nil result) append (list (list (list k n phi) result))) nil) @@ -1011,9 +1005,9 @@ (rt:deftest oct.elliptic-pi.n1.d (loop for k from 0 below 100 for phi = (random (/ pi 2)) - for epi = (elliptic-pi 0 phi 0) + for epi = (elliptic-pi 1 phi 0) for true = (tan phi) - for result = (check-accuracy 53 epi true) + for result = (check-accuracy 43 epi true) unless (eq nil result) append (list (list (list k phi) result))) nil) @@ -1025,7 +1019,7 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atanh (* (tan phi) (sqrt (- n 1)))) (sqrt (- n 1))) - for result = (check-accuracy 52 epi true) + for result = (check-accuracy 49 epi true) ;; Not sure if this formula holds when atanh gives a complex ;; result. Wolfram doesn't say when (and (not (complexp true)) result) @@ -1033,13 +1027,14 @@ nil) (rt:deftest oct.elliptic-pi.n0.q + ;; Tests for random values for phi in [0, pi/2] and n in [0, 1] (loop for k from 0 below 100 for phi = (random (/ +pi+ 2)) for n = (random #q1) for epi = (elliptic-pi n phi 0) - for true = (/ (atanh (* (tan phi) (sqrt (- 1 n)))) + for true = (/ (atan (* (tan phi) (sqrt (- 1 n)))) (sqrt (- 1 n))) - for result = (check-accuracy 212 epi true) + for result = (check-accuracy 208 epi true) unless (eq nil result) append (list (list (list k n phi) result))) nil) @@ -1047,9 +1042,9 @@ (rt:deftest oct.elliptic-pi.n1.q (loop for k from 0 below 100 for phi = (random (/ +pi+ 2)) - for epi = (elliptic-pi 0 phi 0) + for epi = (elliptic-pi 1 phi 0) for true = (tan phi) - for result = (check-accuracy 212 epi true) + for result = (check-accuracy 205 epi true) unless (eq nil result) append (list (list (list k phi) result))) nil) @@ -1061,10 +1056,9 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atanh (* (tan phi) (sqrt (- n 1)))) (sqrt (- n 1))) - for result = (check-accuracy 209 epi true) + for result = (check-accuracy 208 epi true) ;; Not sure if this formula holds when atanh gives a complex ;; result. Wolfram doesn't say when (and (not (complexp true)) result) append (list (list (list k n phi) result))) nil) -||# ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 18 +++++++++++------- rt-tests.lisp | 46 ++++++++++++++++++++-------------------------- 2 files changed, 31 insertions(+), 33 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Sun Mar 13 04:19:19 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Sat, 12 Mar 2011 23:19:19 -0500 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. f4a60f8cdfa0761fda8757c81432fad286cf44da Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via f4a60f8cdfa0761fda8757c81432fad286cf44da (commit) from 5bd5df9360268fae90fc41fcdf86b728f8a54e86 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f4a60f8cdfa0761fda8757c81432fad286cf44da Author: Raymond Toy Date: Sat Mar 12 23:19:11 2011 -0500 Fix typo; update accuracy requirements. qd-elliptic.lisp: o Fix missing paren. rt-tests.lisp: o Reduce accuracy requirements so the tests pass for the random arguments. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index eafca11..01a9e21 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -713,7 +713,7 @@ E(m) = integrate(sqrt(1-m*sin(x)^2), x, 0, %pi/2)" (nn (- n)) (sin-phi (sin phi)) (cos-phi (cos phi)) - (m-sin2 (- 1 (* m sin-phi sin-phi))) + (m-sin2 (- 1 (* m sin-phi sin-phi)))) (- (* sin-phi (carlson-rf (expt cos-phi 2) m-sin2 1)) (* (/ nn 3) (expt sin-phi 3) (carlson-rj (expt cos-phi 2) m-sin2 1 diff --git a/rt-tests.lisp b/rt-tests.lisp index ab81f6a..ef09cab 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -25,6 +25,9 @@ (in-package #:oct) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* *oct-readtable*)) + ;; For the tests, we need to turn off underflow for clisp. #+clisp (ext:without-package-lock () @@ -939,7 +942,7 @@ for m = (random 1d0) for epi = (elliptic-pi 0 phi m) for ef = (elliptic-f phi m) - for result = (check-accuracy 53 epi ef) + for result = (check-accuracy 51 epi ef) unless (eq nil result) append (list (list phi m) result)) nil) @@ -997,7 +1000,7 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atan (* (tan phi) (sqrt (- 1 n)))) (sqrt (- 1 n))) - for result = (check-accuracy 50 epi true) + for result = (check-accuracy 48 epi true) unless (eq nil result) append (list (list (list k n phi) result))) nil) @@ -1007,7 +1010,7 @@ for phi = (random (/ pi 2)) for epi = (elliptic-pi 1 phi 0) for true = (tan phi) - for result = (check-accuracy 43 epi true) + for result = (check-accuracy 37 epi true) unless (eq nil result) append (list (list (list k phi) result))) nil) @@ -1044,7 +1047,7 @@ for phi = (random (/ +pi+ 2)) for epi = (elliptic-pi 1 phi 0) for true = (tan phi) - for result = (check-accuracy 205 epi true) + for result = (check-accuracy 200 epi true) unless (eq nil result) append (list (list (list k phi) result))) nil) @@ -1056,7 +1059,7 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atanh (* (tan phi) (sqrt (- n 1)))) (sqrt (- n 1))) - for result = (check-accuracy 208 epi true) + for result = (check-accuracy 207 epi true) ;; Not sure if this formula holds when atanh gives a complex ;; result. Wolfram doesn't say when (and (not (complexp true)) result) ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 2 +- rt-tests.lisp | 13 ++++++++----- 2 files changed, 9 insertions(+), 6 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Sun Mar 13 23:42:37 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Sun, 13 Mar 2011 19:42:37 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 8ade177a0ce9bbb89b963ff29e46f38f377e9530 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 8ade177a0ce9bbb89b963ff29e46f38f377e9530 (commit) from f4a60f8cdfa0761fda8757c81432fad286cf44da (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 8ade177a0ce9bbb89b963ff29e46f38f377e9530 Author: Raymond Toy Date: Sun Mar 13 19:40:04 2011 -0400 Add Elliptic theta functions and tests. oct.asd: o Add qd-theta. qd-theta.lisp: o New file with Elliptic theta functions and elliptic nome function. rt-tests.lisp: o Tests for theta functions. o Relax accuracy requirements for some of the tests os that they can pass. diff --git a/oct.asd b/oct.asd index 77828aa..b1c41f2 100644 --- a/oct.asd +++ b/oct.asd @@ -62,6 +62,8 @@ :depends-on ("qd-methods" "qd-reader")) (:file "qd-elliptic" :depends-on ("qd-methods" "qd-reader")) + (:file "qd-theta" + :depends-on ("qd-methods" "qd-reader")) )) (defmethod perform ((op test-op) (c (eql (find-system :oct)))) diff --git a/qd-theta.lisp b/qd-theta.lisp new file mode 100644 index 0000000..caae788 --- /dev/null +++ b/qd-theta.lisp @@ -0,0 +1,135 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2011 Raymond Toy +;;;; Permission is hereby granted, free of charge, to any person +;;;; obtaining a copy of this software and associated documentation +;;;; files (the "Software"), to deal in the Software without +;;;; restriction, including without limitation the rights to use, +;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell +;;;; copies of the Software, and to permit persons to whom the +;;;; Software is furnished to do so, subject to the following +;;;; conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. + +(in-package #:oct) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* *oct-readtable*)) + +;; Theta functions +;; +;; theta[1](z,q) = 2*sum((-1)^n*q^((n+1/2)^2)*sin((2*n+1)*z), n, 0, inf) +;; +;; theta[2](z,q) = 2*sum(q^((n+1/2)^2)*cos((2*n+1)*z), n, 0, inf) +;; +;; theta[3](z,q) = 1+2*sum(q^(n*n)*cos(2*n*z), n, 1, inf) +;; +;; theta[4](z,q) = 1+2*sum((-1)^n*q^(n*n)*cos(2*n*z), n, 1, inf) +;; +;; where q is the nome, related to parameter tau by q = +;; exp(%i*%pi*tau), or %pi*tau = log(q)/%i. +;; +;; In all cases |q| < 1. + + +;; The algorithms for computing the theta functions were given to me +;; by Richard Gosper (yes, that Richard Gosper). These came from +;; package for maxima for the theta functions. + +;; e1 M[1,3] + e2 M[2,3] + e3, where M = prod(mat(a11 ... a23 0 0 1)) +;; where fun(k,matfn) supplies the upper six a[ij](k) to matfn. +;; +;; This is clearer if you look at the formulas below for the theta functions. +(defun 3by3rec (e1 e2 e3 fun) + (do ((k 0 (+ k 1))) + ((= e3 (funcall fun k + #'(lambda (a11 a12 a13 a21 a22 a23) ;&opt (a31 0) (a32 0) (a33 1) + (psetf e1 (+ (* a11 e1) (* a21 e2)) + e2 (+ (* a12 e1) (* a22 e2)) + e3 (+ (* a13 e1) (* a23 e2) e3)) + (+ e3 (abs e1) (abs e2))))) + e3))) + +;; inf [ 2 n 1/4 ] +;; /===\ [ - 2 q cos(2 z) 1 2 q ] +;; | | [ ] +;;[sin(z), sin(z), 0] | | [ 4 n - 2 ] = [0, 0, theta (z, q)] +;; | | [ - q 0 0 ] 1 +;; n = 1 [ ] +;; [ 0 0 1 ] + +(defun elliptic-theta-1 (z q) + (let* ((precision (float-contagion z q)) + (z (apply-contagion z precision)) + (q (apply-contagion q precision)) + (s (sin z)) + (q^2 (* q q)) + (q^4 (* q^2 q^2)) + (-q^4n-2 (/ -1 q^2)) + (-2q^2ncos (* -2 (cos (* 2 z)))) + (2q^1/4 (* 2 (sqrt (sqrt q))))) + (3by3rec s s 0 + #'(lambda (k matfun) + (funcall matfun + (setf -2q^2ncos (* q^2 -2q^2ncos)) + 1 + 2q^1/4 + (setf -q^4n-2 (* q^4 -q^4n-2)) + 0 + 0))))) + +;; inf [ 2 k + 1 ] +;; /===\ [ 2 q cos(2 z) 1 2 ] +;; | | [ ] +;;[q cos(2 z), 1, 1] | | [ 4 k ] = [0, 0, theta (z)] +;; | | [ - q 0 0 ] 3 +;; k = 1 [ ] +;; [ 0 0 1 ] +(defun elliptic-theta-3 (z q) + (let* ((precision (float-contagion z q)) + (z (apply-contagion z precision)) + (q (apply-contagion q precision)) + (q^2 (* q q)) + (q^2k 1.0) + (cos (cos (* 2 z)))) + (3by3rec (* q cos) 1 1 + #'(lambda (k matfun) + (funcall matfun + (* 2 (* (setf q^2k (* q^2 q^2k)) q cos)) + 1 + 2 + (- (* q^2k q^2k)) + 0 + 0))))) + +;; theta[2](z,q) = theta[1](z+%pi/2, q) +(defun elliptic-theta-2 (z q) + (let* ((precision (float-contagion z q)) + (z (apply-contagion z precision)) + (q (apply-contagion q precision))) + (elliptic-theta-1 (+ z (/ (float-pi z) 2)) q))) + +;; theta[4](z,q) = theta[3](z+%pi/2,q) +(defun elliptic-theta-4 (z q) + (let* ((precision (float-contagion z q)) + (z (apply-contagion z precision)) + (q (apply-contagion q precision))) + (elliptic-theta-3 (+ z (/ (float-pi z) 2)) q))) + +;; The nome, q, is given by q = exp(-%pi*K'/K) where K and %i*K' are +;; the quarter periods. +(defun elliptic-nome (m) + (exp (- (/ (* (float-pi m) (elliptic-k (- 1 m))) + (elliptic-k m))))) + diff --git a/rt-tests.lisp b/rt-tests.lisp index ef09cab..129506a 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -942,7 +942,7 @@ for m = (random 1d0) for epi = (elliptic-pi 0 phi m) for ef = (elliptic-f phi m) - for result = (check-accuracy 51 epi ef) + for result = (check-accuracy 48 epi ef) unless (eq nil result) append (list (list phi m) result)) nil) @@ -976,7 +976,7 @@ for n = (random #q1) for epi = (elliptic-pi n (/ (float-pi n) 2) 0) for true = (/ (float-pi n) (* 2 (sqrt (- 1 n)))) - for result = (check-accuracy 210 epi true) + for result = (check-accuracy 209 epi true) unless (eq nil result) append (list (list (list k n) result))) nil) @@ -1000,7 +1000,7 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atan (* (tan phi) (sqrt (- 1 n)))) (sqrt (- 1 n))) - for result = (check-accuracy 48 epi true) + for result = (check-accuracy 47.5 epi true) unless (eq nil result) append (list (list (list k n phi) result))) nil) @@ -1010,7 +1010,7 @@ for phi = (random (/ pi 2)) for epi = (elliptic-pi 1 phi 0) for true = (tan phi) - for result = (check-accuracy 37 epi true) + for result = (check-accuracy 36 epi true) unless (eq nil result) append (list (list (list k phi) result))) nil) @@ -1022,7 +1022,7 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atanh (* (tan phi) (sqrt (- n 1)))) (sqrt (- n 1))) - for result = (check-accuracy 49 epi true) + for result = (check-accuracy 47 epi true) ;; Not sure if this formula holds when atanh gives a complex ;; result. Wolfram doesn't say when (and (not (complexp true)) result) @@ -1047,7 +1047,7 @@ for phi = (random (/ +pi+ 2)) for epi = (elliptic-pi 1 phi 0) for true = (tan phi) - for result = (check-accuracy 200 epi true) + for result = (check-accuracy 194 epi true) unless (eq nil result) append (list (list (list k phi) result))) nil) @@ -1059,9 +1059,85 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atanh (* (tan phi) (sqrt (- n 1)))) (sqrt (- n 1))) - for result = (check-accuracy 207 epi true) + for result = (check-accuracy 206 epi true) ;; Not sure if this formula holds when atanh gives a complex ;; result. Wolfram doesn't say when (and (not (complexp true)) result) append (list (list (list k n phi) result))) nil) + +;; Tests for theta functions. + +(rt:deftest oct.theta3.1.d + ;; A&S 16.38.5 + ;; sqrt(2*K/%pi) = theta3(0,q) + (loop for k from 0 below 100 + for m = (random 1d0) + for t3 = (theta3 0 (elliptic-nome m)) + for true = (sqrt (/ (* 2 (elliptic-k m)) (float-pi m))) + for result = (check-accuracy 51 t3 true) + when result + append (list (list (list k m) result))) + nil) + +(rt:deftest oct.theta3.1.q + ;; A&S 16.38.5 + ;; sqrt(2*K/%pi) = theta3(0,q) + (loop for k from 0 below 100 + for m = (random #q1) + for t3 = (theta3 0 (elliptic-nome m)) + for true = (sqrt (/ (* 2 (elliptic-k m)) (float-pi m))) + for result = (check-accuracy 206 t3 true) + when result + append (list (list (list k m) result))) + nil) + +(rt:deftest oct.theta2.1.d + ;; A&S 16.38.7 + ;; sqrt(2*sqrt(m)*K/%pi) = theta2(0,q) + (loop for k from 0 below 100 + for m = (random 1d0) + for t3 = (theta2 0 (elliptic-nome m)) + for true = (sqrt (/ (* 2 (sqrt m) (elliptic-k m)) (float-pi m))) + for result = (check-accuracy 49 t3 true) + when result + append (list (list (list k m) result))) + nil) + +(rt:deftest oct.theta2.1.q + ;; A&S 16.38.7 + ;; sqrt(2*sqrt(m)*K/%pi) = theta2(0,q) + (loop for k from 0 below 100 + for m = (random #q1) + for t3 = (theta2 0 (elliptic-nome m)) + for true = (sqrt (/ (* 2 (sqrt m) (elliptic-k m)) (float-pi m))) + for result = (check-accuracy 206 t3 true) + when result + append (list (list (list k m) result))) + nil) + +(rt:deftest oct.theta4.1.d + ;; A&S 16.38.8 + ;; sqrt(2*sqrt(1-m)*K/%pi) = theta2(0,q) + (loop for k from 0 below 100 + for m = (random 1d0) + for t3 = (theta4 0 (elliptic-nome m)) + for true = (sqrt (/ (* 2 (sqrt (- 1 m)) (elliptic-k m)) + (float-pi m))) + for result = (check-accuracy 49 t3 true) + when result + append (list (list (list k m) result))) + nil) + +(rt:deftest oct.theta4.1.q + ;; A&S 16.38.8 + ;; sqrt(2*sqrt(1-m)*K/%pi) = theta2(0,q) + (loop for k from 0 below 100 + for m = (random #q1) + for t3 = (theta4 0 (elliptic-nome m)) + for true = (sqrt (/ (* 2 (sqrt (- 1 m)) (elliptic-k m)) + (float-pi m))) + for result = (check-accuracy 204 t3 true) + when result + append (list (list (list k m) result))) + nil) ----------------------------------------------------------------------- Summary of changes: oct.asd | 2 + qd-theta.lisp | 135 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ rt-tests.lisp | 90 +++++++++++++++++++++++++++++++++++--- 3 files changed, 220 insertions(+), 7 deletions(-) create mode 100644 qd-theta.lisp hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Mon Mar 14 12:45:22 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Mon, 14 Mar 2011 08:45:22 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. d2650578689f51edbdc8f0c588fcf330134490c6 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via d2650578689f51edbdc8f0c588fcf330134490c6 (commit) via d6439bd96cf670d4b164cb78dff2358293539c83 (commit) from 8ade177a0ce9bbb89b963ff29e46f38f377e9530 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit d2650578689f51edbdc8f0c588fcf330134490c6 Author: Raymond Toy Date: Mon Mar 14 08:44:47 2011 -0400 Move +pi+ and friends to its own file. qd-const2.lisp: o New file containing +pi+ and friends qd-methods.lisp: o Removed constants. oct.asd: o Add qd-const2.lisp diff --git a/oct.asd b/oct.asd index b1c41f2..89b56ee 100644 --- a/oct.asd +++ b/oct.asd @@ -52,6 +52,7 @@ :depends-on ("qd" "qd-const")) (:file "qd-class" :depends-on ("qd-fun")) + (:file "qd-const2" :depends-on ("qd-class")) (:file "qd-methods" :depends-on ("qd-class")) (:file "qd-reader" diff --git a/qd-const2.lisp b/qd-const2.lisp new file mode 100644 index 0000000..2ad911d --- /dev/null +++ b/qd-const2.lisp @@ -0,0 +1,84 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007, 2008, 2011 Raymond Toy +;;;; +;;;; Permission is hereby granted, free of charge, to any person +;;;; obtaining a copy of this software and associated documentation +;;;; files (the "Software"), to deal in the Software without +;;;; restriction, including without limitation the rights to use, +;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell +;;;; copies of the Software, and to permit persons to whom the +;;;; Software is furnished to do so, subject to the following +;;;; conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. + +(in-package #:oct) + +(defconstant +pi+ + (make-instance 'qd-real :value octi:+qd-pi+) + "Pi represented as a QD-REAL") + +(defconstant +pi/2+ + (make-instance 'qd-real :value octi:+qd-pi/2+) + "Pi/2 represented as a QD-REAL") + +(defconstant +pi/4+ + (make-instance 'qd-real :value octi:+qd-pi/4+) + "Pi/4 represented as a QD-REAL") + +(defconstant +2pi+ + (make-instance 'qd-real :value octi:+qd-2pi+) + "2*pi represented as a QD-REAL") + +(defconstant +log2+ + (make-instance 'qd-real :value octi:+qd-log2+) + "Natural log of 2 represented as a QD-REAL") + +;; How do we represent infinity for a QD-REAL? For now, we just make +;; the QD-REAL whose most significant part is infinity. Currently +;; only supported on CMUCL. +#+cmu +(defconstant +quad-double-float-positive-infinity+ + (make-instance 'qd-real :value (make-qd-d ext:double-float-positive-infinity)) + "One representation of positive infinity for QD-REAL") + +#+cmu +(defconstant +quad-double-float-negative-infinity+ + (make-instance 'qd-real :value (make-qd-d ext:double-float-negative-infinity)) + "One representation of negative infinity for QD-REAL") + +(defconstant +most-positive-quad-double-float+ + (make-instance 'qd-real + :value (octi::%make-qd-d most-positive-double-float + (cl:scale-float most-positive-double-float (cl:* 1 -53)) + (cl:scale-float most-positive-double-float (cl:* 2 -53)) + (cl:scale-float most-positive-double-float (cl:* 3 -53)))) + "Most positive representable QD-REAL") + +(defconstant +least-positive-quad-double-float+ + (make-instance 'qd-real + :value (make-qd-d least-positive-double-float)) + "Least positive QD-REAL") + +;; Not sure this is 100% correct, but I think if the first component +;; is any smaller than this, the last component would no longer be a +;; normalized double-float. +(defconstant +least-positive-normalized-quad-double-float+ + (make-instance 'qd-real + :value (make-qd-d (cl:scale-float least-positive-normalized-double-float (cl:* 3 53)))) + "Least positive normalized QD-REAL") + +(defconstant +qd-real-one+ + (make-instance 'qd-real :value (make-qd-d 1d0)) + "QD-REAL representation of 1") diff --git a/qd-methods.lisp b/qd-methods.lisp index 966d85f..814672c 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -25,65 +25,6 @@ (in-package #:oct) -(defconstant +pi+ - (make-instance 'qd-real :value octi:+qd-pi+) - "Pi represented as a QD-REAL") - -(defconstant +pi/2+ - (make-instance 'qd-real :value octi:+qd-pi/2+) - "Pi/2 represented as a QD-REAL") - -(defconstant +pi/4+ - (make-instance 'qd-real :value octi:+qd-pi/4+) - "Pi/4 represented as a QD-REAL") - -(defconstant +2pi+ - (make-instance 'qd-real :value octi:+qd-2pi+) - "2*pi represented as a QD-REAL") - -(defconstant +log2+ - (make-instance 'qd-real :value octi:+qd-log2+) - "Natural log of 2 represented as a QD-REAL") - -;; How do we represent infinity for a QD-REAL? For now, we just make -;; the QD-REAL whose most significant part is infinity. Currently -;; only supported on CMUCL. -#+cmu -(defconstant +quad-double-float-positive-infinity+ - (make-instance 'qd-real :value (make-qd-d ext:double-float-positive-infinity)) - "One representation of positive infinity for QD-REAL") - -#+cmu -(defconstant +quad-double-float-negative-infinity+ - (make-instance 'qd-real :value (make-qd-d ext:double-float-negative-infinity)) - "One representation of negative infinity for QD-REAL") - -(defconstant +most-positive-quad-double-float+ - (make-instance 'qd-real - :value (octi::%make-qd-d most-positive-double-float - (cl:scale-float most-positive-double-float (cl:* 1 -53)) - (cl:scale-float most-positive-double-float (cl:* 2 -53)) - (cl:scale-float most-positive-double-float (cl:* 3 -53)))) - "Most positive representable QD-REAL") - -(defconstant +least-positive-quad-double-float+ - (make-instance 'qd-real - :value (make-qd-d least-positive-double-float)) - "Least positive QD-REAL") - -;; Not sure this is 100% correct, but I think if the first component -;; is any smaller than this, the last component would no longer be a -;; normalized double-float. -(defconstant +least-positive-normalized-quad-double-float+ - (make-instance 'qd-real - :value (make-qd-d (cl:scale-float least-positive-normalized-double-float (cl:* 3 53)))) - "Least positive normalized QD-REAL") - -(defconstant +qd-real-one+ - (make-instance 'qd-real :value (make-qd-d 1d0)) - "QD-REAL representation of 1") - - (defmethod make-qd ((x cl:rational)) ;; We should do something better than this. (make-instance 'qd-real :value (rational-to-qd x))) commit d6439bd96cf670d4b164cb78dff2358293539c83 Author: Raymond Toy Date: Mon Mar 14 08:43:05 2011 -0400 Fix typo; update required accuracy. o The names of the elliptic functions changed and we forgot to update the tests to use the new names. o Reduce required accuracy of some tests. diff --git a/rt-tests.lisp b/rt-tests.lisp index 129506a..c624f4a 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -966,7 +966,7 @@ for n = (random 1d0) for epi = (elliptic-pi n (/ pi 2) 0) for true = (/ pi (* 2 (sqrt (- 1 n)))) - for result = (check-accuracy 49 epi true) + for result = (check-accuracy 47 epi true) unless (eq nil result) append (list (list (list k n) result))) nil) @@ -976,7 +976,7 @@ for n = (random #q1) for epi = (elliptic-pi n (/ (float-pi n) 2) 0) for true = (/ (float-pi n) (* 2 (sqrt (- 1 n)))) - for result = (check-accuracy 209 epi true) + for result = (check-accuracy 208 epi true) unless (eq nil result) append (list (list (list k n) result))) nil) @@ -1073,7 +1073,7 @@ ;; sqrt(2*K/%pi) = theta3(0,q) (loop for k from 0 below 100 for m = (random 1d0) - for t3 = (theta3 0 (elliptic-nome m)) + for t3 = (elliptic-theta-3 0 (elliptic-nome m)) for true = (sqrt (/ (* 2 (elliptic-k m)) (float-pi m))) for result = (check-accuracy 51 t3 true) when result @@ -1085,7 +1085,7 @@ ;; sqrt(2*K/%pi) = theta3(0,q) (loop for k from 0 below 100 for m = (random #q1) - for t3 = (theta3 0 (elliptic-nome m)) + for t3 = (elliptic-theta-3 0 (elliptic-nome m)) for true = (sqrt (/ (* 2 (elliptic-k m)) (float-pi m))) for result = (check-accuracy 206 t3 true) when result @@ -1097,7 +1097,7 @@ ;; sqrt(2*sqrt(m)*K/%pi) = theta2(0,q) (loop for k from 0 below 100 for m = (random 1d0) - for t3 = (theta2 0 (elliptic-nome m)) + for t3 = (elliptic-theta-2 0 (elliptic-nome m)) for true = (sqrt (/ (* 2 (sqrt m) (elliptic-k m)) (float-pi m))) for result = (check-accuracy 49 t3 true) when result @@ -1109,7 +1109,7 @@ ;; sqrt(2*sqrt(m)*K/%pi) = theta2(0,q) (loop for k from 0 below 100 for m = (random #q1) - for t3 = (theta2 0 (elliptic-nome m)) + for t3 = (elliptic-theta-2 0 (elliptic-nome m)) for true = (sqrt (/ (* 2 (sqrt m) (elliptic-k m)) (float-pi m))) for result = (check-accuracy 206 t3 true) when result @@ -1121,7 +1121,7 @@ ;; sqrt(2*sqrt(1-m)*K/%pi) = theta2(0,q) (loop for k from 0 below 100 for m = (random 1d0) - for t3 = (theta4 0 (elliptic-nome m)) + for t3 = (elliptic-theta-4 0 (elliptic-nome m)) for true = (sqrt (/ (* 2 (sqrt (- 1 m)) (elliptic-k m)) (float-pi m))) for result = (check-accuracy 49 t3 true) @@ -1134,7 +1134,7 @@ ;; sqrt(2*sqrt(1-m)*K/%pi) = theta2(0,q) (loop for k from 0 below 100 for m = (random #q1) - for t3 = (theta4 0 (elliptic-nome m)) + for t3 = (elliptic-theta-4 0 (elliptic-nome m)) for true = (sqrt (/ (* 2 (sqrt (- 1 m)) (elliptic-k m)) (float-pi m))) for result = (check-accuracy 204 t3 true) ----------------------------------------------------------------------- Summary of changes: oct.asd | 1 + qd-const2.lisp | 84 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ qd-methods.lisp | 59 -------------------------------------- rt-tests.lisp | 16 +++++----- 4 files changed, 93 insertions(+), 67 deletions(-) create mode 100644 qd-const2.lisp hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Tue Mar 15 00:52:30 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Mon, 14 Mar 2011 20:52:30 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. c6f0a5ef00138c7f504432e0d0f485c23328274a Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via c6f0a5ef00138c7f504432e0d0f485c23328274a (commit) via 80be2f3a917f7f429012985cd3a003d77de22ce7 (commit) from d2650578689f51edbdc8f0c588fcf330134490c6 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c6f0a5ef00138c7f504432e0d0f485c23328274a Author: Raymond Toy Date: Mon Mar 14 20:47:19 2011 -0400 Add docstrings; simplify elliptic-c, elliptic-ec. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 01a9e21..385f00f 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -413,7 +413,13 @@ ;; Elliptic integral of the first kind. This is computed using ;; Carlson's Rf function: ;; -;; F(phi, m) = sin(phi) * Rf(cos(phi)^2, 1 - m*sin(phi)^2, 1) +;; F(phi, m) = sin(phi) * Rf(cos(phi)^2, 1 - m*sin(phi)^2, 1) +;; +;; Also, DLMF 19.25.5 says +;; +;; F(phi, k) = Rf(c-1, c-k^2, c) +;; +;; where c = csc(phi)^2. (defun elliptic-f (x m) "Incomplete Elliptic integral of the first kind: @@ -485,6 +491,30 @@ ;; ;; E(phi, m) = integrate(sqrt(1-m*sin(x)^2), x, 0, phi) ;; +;; Carlson says +;; +;; E(phi, k) = sin(phi) * Rf(cos(phi)^2, 1-k^2*sin(phi)^2, 1) +;; - (k^2/3)*sin(phi)^3 * Rd(cos(phi)^2, 1 - k^2*sin(phi)^2, 1) +;; +;; But note that DLMF 19.25.9 says +;; +;; E(phi, k) = Rf(c-1, c - k^2, c) - k^2/3*Rd(c-1, c-k^2, c) +;; +;; where c = csc(phi)^2. Also DLMF 19.25.10 has +;; +;; E(phi, k) = k1^2*Rf(c-1,c-k^2,c) + k^/3*k1^2*Rd(c-1, c, c-k^2) +;; + k^2*sqrt((c-1)/(c*(c-k^2))) +;; +;; where k1^2 = 1-k^2 and c > k^2. Finally, DLMF 19.25.11 says +;; +;; E(phi, k) = -k1^2/3*Rd(c-k^2,c,c-1) + sqrt((c-k^2)/(c*(c-1))) +;; +;; for phi /= pi/2. +;; +;; One possible advantage is that all terms on the rhs are positive +;; for 19.25.9 if k^2 <= 0; 19.25.10 if 0 <= k^2 <= 1; 19.25.11 if 1 +;; <= k^2 <= c. It might be beneficial to use this idea so that we +;; don't have subtractive cancellation. (defun elliptic-e (phi m) "Incomplete elliptic integral of the second kind: @@ -499,21 +529,26 @@ E(phi, m) = integrate(sqrt(1-m*sin(x)^2), x, 0, phi)" ;; A&S 17.4.25 (sin phi)) (t - (let* ((sin-phi (sin phi)) - (cos-phi (cos phi)) - (k (sqrt m)) - (y (* (- 1 (* k sin-phi)) - (+ 1 (* k sin-phi))))) - (- (* sin-phi - (carlson-rf (* cos-phi cos-phi) y 1)) - (* (/ m 3) - (expt sin-phi 3) - (carlson-rd (* cos-phi cos-phi) y 1)))))))) + ;; For quad-doubles, it's significantly faster to compute + ;; cis(phi) than to compute sin and cos separately. + (multiple-value-bind (cos-phi sin-phi) + (let ((cis (cis phi))) + (values (realpart cis) (imagpart cis))) + (let ((y (- 1 (* m sin-phi sin-phi)))) + (- (* sin-phi + (carlson-rf (* cos-phi cos-phi) y 1)) + (* (/ m 3) + (expt sin-phi 3) + (carlson-rd (* cos-phi cos-phi) y 1))))))))) ;; Complete elliptic integral of second kind. ;; ;; E(phi) = integrate(sqrt(1-m*sin(x)^2), x, 0, %pi/2) ;; +;; Carlson says +;; +;; E(k) = Rf(0, 1-k^2,1) - (k^2/3)*Rd(0,1-k^2,1) +;; (defun elliptic-ec (m) "Complete elliptic integral of the second kind: @@ -525,12 +560,10 @@ E(m) = integrate(sqrt(1-m*sin(x)^2), x, 0, %pi/2)" ;; A&S 17.4.25 (float 1 m)) (t - (let* ((k (sqrt m)) - (y (* (- 1 k) - (+ 1 k)))) - (- (carlson-rf 0 y 1) + (let* ((m1 (- 1 m))) + (- (carlson-rf 0 m1 1) (* (/ m 3) - (carlson-rd 0 y 1))))))) + (carlson-rd 0 m1 1))))))) ;; Carlson's Rc function. ;; commit 80be2f3a917f7f429012985cd3a003d77de22ce7 Author: Raymond Toy Date: Mon Mar 14 20:45:28 2011 -0400 Export functions, add docstrings. qd-package.lisp: o Export the elliptic theta functions and the Carlson elliptic integrals. qd-theta.lisp: o Add simple docstrings for elliptic theta functions. o Add ELLIPTIC-THETA function. diff --git a/qd-package.lisp b/qd-package.lisp index 9587038..b102435 100644 --- a/qd-package.lisp +++ b/qd-package.lisp @@ -286,7 +286,15 @@ #:elliptic-k #:elliptic-f #:elliptic-e - #:elliptic-ec) + #:elliptic-ec + #:carlson-rd + #:carlson-rf + #:carlson-rj + #:elliptic-theta-1 + #:elliptic-theta-2 + #:elliptic-theta-3 + #:elliptic-theta-4 + #:elliptic-theta) ;; Constants (:export #:+pi+ #:+pi/2+ diff --git a/qd-theta.lisp b/qd-theta.lisp index caae788..fb41b82 100644 --- a/qd-theta.lisp +++ b/qd-theta.lisp @@ -70,6 +70,9 @@ ;; [ 0 0 1 ] (defun elliptic-theta-1 (z q) + "Elliptic theta function 1 + + theta1(z, q) = 2*q^(1/4)*sum((-1)^n*q^(n*(n+1))*sin((2*n+1)*z), n, 0, inf)" (let* ((precision (float-contagion z q)) (z (apply-contagion z precision)) (q (apply-contagion q precision)) @@ -97,6 +100,9 @@ ;; k = 1 [ ] ;; [ 0 0 1 ] (defun elliptic-theta-3 (z q) + "Elliptic theta function 3 + + theta3(z, q) = 1 + 2 * sum(q^(n^2)*cos(2*n*z), n, 1, inf)" (let* ((precision (float-contagion z q)) (z (apply-contagion z precision)) (q (apply-contagion q precision)) @@ -115,6 +121,9 @@ ;; theta[2](z,q) = theta[1](z+%pi/2, q) (defun elliptic-theta-2 (z q) + "Elliptic theta function 2 + + theta2(z, q) = 2*q^(1/4)*sum(q^(n*(n+1))*cos((2*n+1)*z), n, 0, inf)" (let* ((precision (float-contagion z q)) (z (apply-contagion z precision)) (q (apply-contagion q precision))) @@ -122,14 +131,26 @@ ;; theta[4](z,q) = theta[3](z+%pi/2,q) (defun elliptic-theta-4 (z q) + "Elliptic theta function 4 + + theta4(z, q) = 1 + 2*sum((-1)^n*q^(n^2)*cos(2*n*z), n, 1, inf)" (let* ((precision (float-contagion z q)) (z (apply-contagion z precision)) (q (apply-contagion q precision))) (elliptic-theta-3 (+ z (/ (float-pi z) 2)) q))) +(defun elliptic-theta (n z q) + "Elliptic Theta function n where n = 1, 2, 3, or 4." + (ecase n + (1 (elliptic-theta-1 z q)) + (2 (elliptic-theta-2 z q)) + (3 (elliptic-theta-3 z q)) + (4 (elliptic-theta-4 z q)))) + ;; The nome, q, is given by q = exp(-%pi*K'/K) where K and %i*K' are ;; the quarter periods. (defun elliptic-nome (m) + "Compute the elliptic nome, q, from the parameter m" (exp (- (/ (* (float-pi m) (elliptic-k (- 1 m))) (elliptic-k m))))) ----------------------------------------------------------------------- Summary of changes: qd-elliptic.lisp | 65 ++++++++++++++++++++++++++++++++++++++++------------- qd-package.lisp | 10 +++++++- qd-theta.lisp | 21 +++++++++++++++++ 3 files changed, 79 insertions(+), 17 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Wed Mar 16 23:44:02 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Wed, 16 Mar 2011 19:44:02 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. a40062c6860e8e778c1b15a48c2687c6cd2f5334 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via a40062c6860e8e778c1b15a48c2687c6cd2f5334 (commit) via a666f3923b82be0eb435ddd3e9b20697097fafe0 (commit) via a93aca9a6cfdb5b1305cb2570eea23e6f44b51c0 (commit) from c6f0a5ef00138c7f504432e0d0f485c23328274a (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit a40062c6860e8e778c1b15a48c2687c6cd2f5334 Author: Raymond Toy Date: Wed Mar 16 19:43:54 2011 -0400 Add gamma and log-gamma functions; work in progress. oct.asd: o Add qd-gamma.lisp. The implementations need some work. The accuracy is less than desired because gamma(2.0) /= 1. It's close but not quite right. rt-tests.lisp: o Basic tests of the gamma function. Accuracy is not as good as we would ike. qd-gamma.lisp: o New file for implementation of gamma function. diff --git a/oct.asd b/oct.asd index 89b56ee..e4011a9 100644 --- a/oct.asd +++ b/oct.asd @@ -65,6 +65,8 @@ :depends-on ("qd-methods" "qd-reader")) (:file "qd-theta" :depends-on ("qd-methods" "qd-reader")) + (:file "qd-gamma" + :depends-on ("qd-methods")) )) (defmethod perform ((op test-op) (c (eql (find-system :oct)))) diff --git a/qd-gamma.lisp b/qd-gamma.lisp new file mode 100644 index 0000000..bb9004a --- /dev/null +++ b/qd-gamma.lisp @@ -0,0 +1,170 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2011 Raymond Toy +;;;; Permission is hereby granted, free of charge, to any person +;;;; obtaining a copy of this software and associated documentation +;;;; files (the "Software"), to deal in the Software without +;;;; restriction, including without limitation the rights to use, +;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell +;;;; copies of the Software, and to permit persons to whom the +;;;; Software is furnished to do so, subject to the following +;;;; conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. + +(in-package #:oct) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* *oct-readtable*)) + +;; For log-gamma we use the asymptotic formula +;; +;; log(gamma(z)) ~ (z - 1/2)*log(z) + log(2*%pi)/2 +;; + sum(bern(2*k)/(2*k)/(2*k-1)/z^(2k-1), k, 1, inf) +;; +;; = (z - 1/2)*log(z) + log(2*%pi)/2 +;; + 1/12/z*(1 - 1/30/z^2 + 1/105/z^4 + 1/140/z^6 + ... +;; + 174611/10450/z^18 + ...) +;; +;; For double-floats, let's stop the series at the power z^18. The +;; next term is 77683/483/z^20. This means that for |z| > 8.09438, +;; the series has double-float precision. +;; +;; For quad-doubles, let's stop the series at the power z^62. The +;; next term is about 6.364d37/z^64. So for |z| > 38.71, the series +;; has quad-double precision. +(defparameter *log-gamma-asymp-coef* + #(-1/30 1/105 -1/140 1/99 -691/30030 1/13 -3617/10200 43867/20349 + -174611/10450 77683/483 -236364091/125580 657931/25 -3392780147/7830 + 1723168255201/207669 -7709321041217/42160 151628697551/33 + -26315271553053477373/201514950 154210205991661/37 + -261082718496449122051/1758900 1520097643918070802691/259161 + -2530297234481911294093/9890 25932657025822267968607/2115 + -5609403368997817686249127547/8725080 19802288209643185928499101/539 + -61628132164268458257532691681/27030 29149963634884862421418123812691/190323 + -354198989901889536240773677094747/31900 + 2913228046513104891794716413587449/3363 + -1215233140483755572040304994079820246041491/16752085350 + 396793078518930920708162576045270521/61 + -106783830147866529886385444979142647942017/171360 + 133872729284212332186510857141084758385627191/2103465 + )) + +#+nil +(defun log-gamma-asymp-series (z nterms) + ;; Sum the asymptotic formula for n terms + ;; + ;; 1 + sum(c[k]/z^(2*k+2), k, 0, nterms) + (let ((z2 (* z z)) + (sum 1) + (term 1)) + (dotimes (k nterms) + (setf term (* term z2)) + (incf sum (/ (aref *log-gamma-asymp-coef* k) term))) + sum)) + +(defun log-gamma-asymp-series (z nterms) + (loop with y = (* z z) + for k from 1 to nterms + for x = 0 then + (setf x (/ (+ x (aref *log-gamma-asymp-coef* (- nterms k))) + y)) + finally (return (+ 1 x)))) + + +(defun log-gamma-asymp-principal (z nterms log2pi/2) + (+ (- (* (- z 1/2) + (log z)) + z) + log2pi/2)) + +(defun log-gamma-asymp (z nterms log2pi/2) + (+ (log-gamma-asymp-principal z nterms log2pi/2) + (* 1/12 (/ (log-gamma-asymp-series z nterms) z)))) + +(defun log2pi/2 (precision) + (ecase precision + (single-float + (coerce (/ (log (* 2 pi)) 2) 'single-float)) + (double-float + (coerce (/ (log (* 2 pi)) 2) 'double-float)) + (qd-real + (/ (log +2pi+) 2)))) + +(defun log-gamma-aux (z limit nterms) + (let ((precision (float-contagion z))) + (cond ((minusp (realpart z)) + ;; Use reflection formula if realpart(z) < 0 + ;; log(gamma(-z)) = log(pi)-log(-z)-log(sin(pi*z))-log(gamma(z)) + ;; Or + ;; log(gamma(z)) = log(pi)-log(-z)-log(sin(pi*z))-log(gamma(-z)) + (- (apply-contagion (log pi) precision) + (log (- z)) + (apply-contagion (log (sin (* pi z))) precision) + (log-gamma (- z)))) + (t + (let ((absz (abs z))) + (cond ((>= absz limit) + ;; Can use the asymptotic formula directly with 9 terms + (log-gamma-asymp z nterms (log2pi/2 precision))) + (t + ;; |z| is too small. Use the formula + ;; log(gamma(z)) = log(gamma(z+1)) - log(z) + (- (log-gamma (+ z 1)) + (log z))))))))) + +(defmethod log-gamma ((z cl:number)) + (log-gamma-aux z 9 9)) + +(defmethod log-gamma ((z qd-real)) + (log-gamma-aux z 26 26)) + +(defmethod log-gamma ((z qd-complex)) + (log-gamma-aux z 26 26)) + +(defun gamma-aux (z limit nterms) + (let ((precision (float-contagion z))) + (cond ((minusp (realpart z)) + ;; Use reflection formula if realpart(z) < 0: + ;; gamma(-z) = -pi*csc(pi*z)/gamma(z+1) + ;; or + ;; gamma(z) = pi*csc(pi*z)/gamma(1-z) + (/ (float-pi z) + (sin (* (float-pi z) z)) + (gamma-aux (- 1 z) limit nterms))) + (t + (let ((absz (abs z))) + (cond ((>= absz limit) + ;; Use log gamma directly: + ;; log(gamma(z)) = principal part + 1/12/z*(series part) + ;; so + ;; gamma(z) = exp(principal part)*exp(1/12/z*series) + (exp (log-gamma z)) + #+nil + (* (exp (log-gamma-asymp-principal z nterms + (log2pi/2 precision))) + (exp (* 1/12 (/ (log-gamma-asymp-series z nterms) z))))) + (t + ;; 1 <= |z| <= limit + ;; gamma(z) = gamma(z+1)/z + (/ (gamma-aux (+ 1 z) limit nterms) z)))))))) + +(defmethod gamma ((z cl:number)) + (gamma-aux z 9 9)) + +(defmethod gamma ((z qd-real)) + (gamma-aux z 39 32)) + +(defmethod gamma ((z qd-complex)) + (gamma-aux z 39 32)) + diff --git a/rt-tests.lisp b/rt-tests.lisp index c624f4a..59d798f 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -1141,3 +1141,57 @@ when result append (list (list (list k m) result))) nil) + +(rt:deftest gamma.1.d + (let ((g (gamma 0.5d0)) + (true (sqrt pi))) + ;; This should give full accuracy but doesn't. + (check-accuracy 51 g true)) + nil) + +(rt:deftest gamma.1.q + (let ((g (gamma #q0.5)) + (true (sqrt +pi+))) + ;; This should give full accuracy but doesn't. + (check-accuracy 197 g true)) + nil) + +(rt:deftest gamma.2.d + (loop for k from 0 below 100 + for y = (+ 1 (random 100d0)) + for g = (abs (gamma (complex 0 y))) + for true = (sqrt (/ pi y (sinh (* pi y)))) + for result = (check-accuracy 45 g true) + when result + append (list (list (list k y) result))) + nil) + +(rt:deftest gamma.2.q + (loop for k from 0 below 100 + for y = (+ 1 (random #q100)) + for g = (abs (gamma (complex 0 y))) + for true = (sqrt (/ +pi+ y (sinh (* +pi+ y)))) + for result = (check-accuracy 196 g true) + when result + append (list (list (list k y) result))) + nil) + +(rt:deftest gamma.3.d + (loop for k from 0 below 100 + for y = (+ 1 (random 100d0)) + for g = (abs (gamma (complex 1/2 y))) + for true = (sqrt (/ pi (cosh (* pi y)))) + for result = (check-accuracy 44 g true) + when result + append (list (list (list k y) result))) + nil) + +(rt:deftest gamma.3.q + (loop for k from 0 below 100 + for y = (+ 1 (random #q100)) + for g = (abs (gamma (complex 1/2 y))) + for true = (sqrt (/ +pi+ (cosh (* +pi+ y)))) + for result = (check-accuracy 196 g true) + when result + append (list (list (list k y) result))) + nil) commit a666f3923b82be0eb435ddd3e9b20697097fafe0 Author: Raymond Toy Date: Wed Mar 16 19:41:33 2011 -0400 QCOMPLEX takes two required args now. Fixes issues like (complex 1/2 #q1), which was signaling an error. qd-class.lisp: o Update defgeneric for QCOMPLEX for two required args. qd-methods.lisp: o Update existing QCOMPLEX methods to take two args. o Add methods to QCOMPLEX to handle the missing cases. diff --git a/qd-class.lisp b/qd-class.lisp index 2134ef7..43cc2e9 100644 --- a/qd-class.lisp +++ b/qd-class.lisp @@ -203,8 +203,8 @@ (defgeneric qexpt (x y) (:documentation "X^Y")) -(defgeneric qcomplex (x &optional y) - (:documentation "Create a complex number with components X and Y. If Y not given, assume 0")) +(defgeneric qcomplex (x y) + (:documentation "Create a complex number with components X and Y.")) (defgeneric qinteger-decode-float (f) (:documentation "integer-decode-float")) diff --git a/qd-methods.lisp b/qd-methods.lisp index fa27ce2..9341311 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -507,13 +507,21 @@ underlying floating-point format" (return nil))) (return nil)))) -(defmethod qcomplex ((x real) &optional y) - (cl:complex x (if y y 0))) +(defmethod qcomplex ((x cl:real) (y cl:real)) + (cl:complex x y)) -(defmethod qcomplex ((x qd-real) &optional y) +(defmethod qcomplex ((x cl:real) (y qd-real)) + (qcomplex (make-qd x) y)) + +(defmethod qcomplex ((x qd-real) (y qd-real)) + (make-instance 'qd-complex + :real (qd-value x) + :imag (qd-value y))) + +(defmethod qcomplex ((x qd-real) (y cl:real)) (make-instance 'qd-complex :real (qd-value x) - :imag (if y (qd-value y) +qd-zero+))) + :imag (make-qd-d y))) (defun complex (x &optional (y 0)) (qcomplex x y)) commit a93aca9a6cfdb5b1305cb2570eea23e6f44b51c0 Author: Raymond Toy Date: Tue Mar 15 13:14:05 2011 -0400 Move float-contagion stuff to qd-methods. diff --git a/qd-elliptic.lisp b/qd-elliptic.lisp index 385f00f..475763b 100644 --- a/qd-elliptic.lisp +++ b/qd-elliptic.lisp @@ -29,59 +29,6 @@ (declaim (inline descending-transform ascending-transform)) -;; Determine which of x and y has the higher precision and return the -;; value of the higher precision number. If both x and y are -;; rationals, just return 1f0, for a single-float value. -(defun float-contagion-2 (x y) - (etypecase x - (cl:rational - (etypecase y - (cl:rational - 1f0) - (cl:float - y) - (qd-real - y))) - (single-float - (etypecase y - ((or cl:rational single-float) - x) - ((or double-float qd-real) - y))) - (double-float - (etypecase y - ((or cl:rational single-float double-float) - x) - (qd-real - y))) - (qd-real - x))) - -;; Return a floating point (or complex) type of the highest precision -;; among all of the given arguments. -(defun float-contagion (&rest args) - ;; It would be easy if we could just add the args together and let - ;; normal contagion do the work, but we could easily introduce - ;; overflows or other errors that way. So look at each argument and - ;; determine the precision and choose the highest precision. - (let ((complexp (some #'complexp args)) - (max-type - (etypecase (reduce #'float-contagion-2 (mapcar #'realpart (if (cdr args) - args - (list (car args) 0)))) - (single-float 'single-float) - (double-float 'double-float) - (qd-real 'qd-real)))) - max-type)) - -(defun apply-contagion (number precision) - (etypecase number - ((or cl:real qd-real) - (coerce number precision)) - ((or cl:complex qd-complex) - (complex (coerce (realpart number) precision) - (coerce (imagpart number) precision))))) - ;;; Jacobian elliptic functions (defun ascending-transform (u m) diff --git a/qd-methods.lisp b/qd-methods.lisp index 814672c..fa27ce2 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -1048,4 +1048,58 @@ the same precision as the argument. The argument can be complex.")) (float pi (realpart z))) (defmethod float-pi ((z qd-complex)) - +pi+) \ No newline at end of file + +pi+) + +;; Determine which of x and y has the higher precision and return the +;; value of the higher precision number. If both x and y are +;; rationals, just return 1f0, for a single-float value. +(defun float-contagion-2 (x y) + (etypecase x + (cl:rational + (etypecase y + (cl:rational + 1f0) + (cl:float + y) + (qd-real + y))) + (single-float + (etypecase y + ((or cl:rational single-float) + x) + ((or double-float qd-real) + y))) + (double-float + (etypecase y + ((or cl:rational single-float double-float) + x) + (qd-real + y))) + (qd-real + x))) + +;; Return a floating point (or complex) type of the highest precision +;; among all of the given arguments. +(defun float-contagion (&rest args) + ;; It would be easy if we could just add the args together and let + ;; normal contagion do the work, but we could easily introduce + ;; overflows or other errors that way. So look at each argument and + ;; determine the precision and choose the highest precision. + (let ((complexp (some #'complexp args)) + (max-type + (etypecase (reduce #'float-contagion-2 (mapcar #'realpart (if (cdr args) + args + (list (car args) 0)))) + (single-float 'single-float) + (double-float 'double-float) + (qd-real 'qd-real)))) + max-type)) + +(defun apply-contagion (number precision) + (etypecase number + ((or cl:real qd-real) + (coerce number precision)) + ((or cl:complex qd-complex) + (complex (coerce (realpart number) precision) + (coerce (imagpart number) precision))))) + ----------------------------------------------------------------------- Summary of changes: oct.asd | 2 + qd-class.lisp | 4 +- qd-elliptic.lisp | 53 ----------------- qd-gamma.lisp | 170 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ qd-methods.lisp | 72 +++++++++++++++++++++-- rt-tests.lisp | 54 +++++++++++++++++ 6 files changed, 295 insertions(+), 60 deletions(-) create mode 100644 qd-gamma.lisp hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Thu Mar 17 17:37:55 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Thu, 17 Mar 2011 13:37:55 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 46e7193fb5b2fad35e67366ff375d9ebbb524c5c Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 46e7193fb5b2fad35e67366ff375d9ebbb524c5c (commit) via 8227b233c4ba1f58d7928cdd5020201a5465c10d (commit) via 9d3c8cf17f1d644be01749fe91484c514eb80d3c (commit) via b725d6ef804b369ede3bc4bf037bd746a5d32406 (commit) from a40062c6860e8e778c1b15a48c2687c6cd2f5334 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 46e7193fb5b2fad35e67366ff375d9ebbb524c5c Author: Raymond Toy Date: Thu Mar 17 13:37:29 2011 -0400 Implement exponential integral E. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index 4781167..a25bc7d 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -333,3 +333,11 @@ (+ 1 (/ (incomplete-gamma 1/2 (* z z)) (sqrt (float-pi z)))))) + +(defun exp-integral-e (v z) + "Exponential integral E: + + E(v,z) = integrate(exp(-t)/t^v, t, 1, inf)" + ;; Wolfram gives E(v,z) = z^(v-1)*gamma_incomplete_tail(1-v,z) + (* (expt z (- v 1)) + (incomplete-gamma-tail (- 1 v) z))) commit 8227b233c4ba1f58d7928cdd5020201a5465c10d Author: Raymond Toy Date: Thu Mar 17 13:20:43 2011 -0400 Implement erfc; fix erf(-z), add comments. o Was returning the wrong value for erf(-z). Use erf(-z) = - erf(z). o Add implementation of erfc. o Document code and algorithms a bit better. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index dbdd4c7..4781167 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -267,6 +267,9 @@ ;; Tail of the incomplete gamma function. (defun incomplete-gamma-tail (a z) + "Tail of the incomplete gamma function defined by: + + integrate(t^(a-1)*exp(-t), t, z, inf)" (let* ((prec (float-contagion a z)) (a (apply-contagion a prec)) (z (apply-contagion z prec))) @@ -279,6 +282,9 @@ (cf-incomplete-gamma-tail a z)))) (defun incomplete-gamma (a z) + "Incomplete gamma function defined by: + + integrate(t^(a-1)*exp(-t), t, 0, z)" (let* ((prec (float-contagion a z)) (a (apply-contagion a prec)) (z (apply-contagion z prec))) @@ -289,5 +295,41 @@ (cf-incomplete-gamma a z)))) (defun erf (z) - (/ (incomplete-gamma 1/2 (* z z)) - (sqrt (float-pi z)))) + "Error function: + + erf(z) = 2/sqrt(%pi)*sum((-1)^k*z^(2*k+1)/k!/(2*k+1), k, 0, inf) + + For real z, this is equivalent to + + erf(z) = 2/sqrt(%pi)*integrate(exp(-t^2), t, 0, z) for real z." + ;; + ;; Erf is an odd function: erf(-z) = -erf(z) + (if (minusp (realpart z)) + (- (erf (- z))) + (/ (incomplete-gamma 1/2 (* z z)) + (sqrt (float-pi z))))) + +(defun erfc (z) + "Complementary error function: + + erfc(z) = 1 - erf(z)" + ;; Compute erfc(z) via 1 - erf(z) is not very accurate if erf(z) is + ;; near 1. Wolfram says + ;; + ;; erfc(z) = 1 - sqrt(z^2)/z * (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2, z^2)) + ;; + ;; For real(z) > 0, sqrt(z^2)/z is 1 so + ;; + ;; erfc(z) = 1 - (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2)) + ;; = 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2) + ;; + ;; For real(z) < 0, sqrt(z^2)/z is -1 so + ;; + ;; erfc(z) = 1 + (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2)) + ;; = 1 + 1/sqrt(pi)*gamma_incomplete(1/2,z^2) + (if (>= (realpart z) 0) + (/ (incomplete-gamma-tail 1/2 (* z z)) + (sqrt (float-pi z))) + (+ 1 + (/ (incomplete-gamma 1/2 (* z z)) + (sqrt (float-pi z)))))) commit 9d3c8cf17f1d644be01749fe91484c514eb80d3c Author: Raymond Toy Date: Thu Mar 17 11:41:45 2011 -0400 Add implementation for incomplete gamma and erf, with tests. qd-gamma.lisp: o Add implementation for Lentz's algorithm for evaluating continued fractions. o Implement incomplete-gamma and incomplete-gamma-tail using continued fractions. o Implement erf rt-tests.lisp: o Add tests diff --git a/qd-gamma.lisp b/qd-gamma.lisp index bb9004a..dbdd4c7 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -168,3 +168,126 @@ (defmethod gamma ((z qd-complex)) (gamma-aux z 39 32)) + +;; Lentz's algorithm for evaluating continued fractions. +;; +;; Let the continued fraction be: +;; +;; a1 a2 a3 +;; b0 + ---- ---- ---- +;; b1 + b2 + b3 + +;; +(defun lentz (bf af) + (flet ((value-or-tiny (v) + (if (zerop v) + (etypecase v + ((or double-float cl:complex) + least-positive-normalized-double-float) + ((or qd-real qd-complex) + (make-qd least-positive-normalized-double-float))) + v))) + (let* ((f (value-or-tiny (funcall bf 0))) + (c f) + (d 0) + (eps (epsilon f))) + (loop + for j from 1 + for an = (funcall af j) + for bn = (funcall bf j) + do (progn + (setf d (value-or-tiny (+ bn (* an d)))) + (setf c (value-or-tiny (+ bn (/ an c)))) + (setf d (/ d)) + (let ((delta (* c d))) + (setf f (* f delta)) + (when (<= (abs (- delta 1)) eps) + (return))))) + f))) + +;; Continued fraction for erf(b): +;; +;; z[n] = 1+2*n-2*z^2 +;; a[n] = 4*n*z^2 +;; +;; This works ok, but has problems for z > 3 where sometimes the +;; result is greater than 1. +#+nil +(defun erf (z) + (let* ((z2 (* z z)) + (twoz2 (* 2 z2))) + (* (/ (* 2 z) + (sqrt (float-pi z))) + (exp (- z2)) + (/ (lentz #'(lambda (n) + (- (+ 1 (* 2 n)) + twoz2)) + #'(lambda (n) + (* 4 n z2))))))) + +;; Tail of the incomplete gamma function: +;; integrate(x^(a-1)*exp(-x), x, z, inf) +;; +;; The continued fraction, valid for all z except the negative real +;; axis: +;; +;; b[n] = 1+2*n+z-a +;; a[n] = n*(a-n) +;; +;; See http://functions.wolfram.com/06.06.10.0003.01 +(defun cf-incomplete-gamma-tail (a z) + (/ (* (expt z a) + (exp (- z))) + (let ((z-a (- z a))) + (lentz #'(lambda (n) + (+ n n 1 z-a)) + #'(lambda (n) + (* n (- a n))))))) + +;; Incomplete gamma function: +;; integrate(x^(a-1)*exp(-x), x, 0, z) +;; +;; The continued fraction, valid for all z except the negative real +;; axis: +;; +;; b[n] = n - 1 + z + a +;; a[n] = -z*(a + n) +;; +;; See http://functions.wolfram.com/06.06.10.0005.01. We modified the +;; continued fraction slightly and discarded the first quotient from +;; the fraction. +(defun cf-incomplete-gamma (a z) + (/ (* (expt z a) + (exp (- z))) + (let ((za1 (+ z a 1))) + (- a (/ (* a z) + (lentz #'(lambda (n) + (+ n za1)) + #'(lambda (n) + (- (* z (+ a n)))))))))) + +;; Tail of the incomplete gamma function. +(defun incomplete-gamma-tail (a z) + (let* ((prec (float-contagion a z)) + (a (apply-contagion a prec)) + (z (apply-contagion z prec))) + (if (and (realp a) (realp z)) + ;; For real values, we split the result to compute either the + ;; tail directly or from gamma(a) - incomplete-gamma + (if (> z (- a 1)) + (cf-incomplete-gamma-tail a z) + (- (gamma a) (cf-incomplete-gamma a z))) + (cf-incomplete-gamma-tail a z)))) + +(defun incomplete-gamma (a z) + (let* ((prec (float-contagion a z)) + (a (apply-contagion a prec)) + (z (apply-contagion z prec))) + (if (and (realp a) (realp z)) + (if (< z (- a 1)) + (cf-incomplete-gamma a z) + (- (gamma a) (cf-incomplete-gamma-tail a z))) + (cf-incomplete-gamma a z)))) + +(defun erf (z) + (/ (incomplete-gamma 1/2 (* z z)) + (sqrt (float-pi z)))) diff --git a/rt-tests.lisp b/rt-tests.lisp index 59d798f..5f4cdd5 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -1111,7 +1111,7 @@ for m = (random #q1) for t3 = (elliptic-theta-2 0 (elliptic-nome m)) for true = (sqrt (/ (* 2 (sqrt m) (elliptic-k m)) (float-pi m))) - for result = (check-accuracy 206 t3 true) + for result = (check-accuracy 205 t3 true) when result append (list (list (list k m) result))) nil) @@ -1195,3 +1195,33 @@ when result append (list (list (list k y) result))) nil) + +;; gamma_incomplete(2,z) = integrate(t*exp(-t), t, z, inf) +;; = (z+1)*exp(-z) +(rt:deftest gamma-incomplete-tail.1.d + (let* ((z 5d0) + (gi (incomplete-gamma-tail 2 z)) + (true (* (+ z 1) (exp (- z))))) + (check-accuracy 52 gi true)) + nil) + +(rt:deftest gamma-incomplete-tail.2.d + (let* ((z #c(1 5d0)) + (gi (incomplete-gamma-tail 2 z)) + (true (* (+ z 1) (exp (- z))))) + (check-accuracy 50 gi true)) + nil) + +(rt:deftest gamma-incomplete-tail.1.q + (let* ((z 5d0) + (gi (incomplete-gamma-tail 2 z)) + (true (* (+ z 1) (exp (- z))))) + (check-accuracy 212 gi true)) + nil) + +(rt:deftest gamma-incomplete-tail.1.q + (let* ((z #q(1 5)) + (gi (incomplete-gamma-tail 2 z)) + (true (* (+ z 1) (exp (- z))))) + (check-accuracy 206 gi true)) + nil) commit b725d6ef804b369ede3bc4bf037bd746a5d32406 Author: Raymond Toy Date: Thu Mar 17 11:38:43 2011 -0400 Add missing methods for QEXPT. o We weren't handling the case of (expt real qd-complex). Add a method for this and other missing methods for QEXPT. o Move float contagion stuff from the end to the beginning so we can use it in this file. diff --git a/qd-methods.lisp b/qd-methods.lisp index 9341311..cbf0daa 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -29,6 +29,59 @@ ;; We should do something better than this. (make-instance 'qd-real :value (rational-to-qd x))) +;; Determine which of x and y has the higher precision and return the +;; value of the higher precision number. If both x and y are +;; rationals, just return 1f0, for a single-float value. +(defun float-contagion-2 (x y) + (etypecase x + (cl:rational + (etypecase y + (cl:rational + 1f0) + (cl:float + y) + (qd-real + y))) + (single-float + (etypecase y + ((or cl:rational single-float) + x) + ((or double-float qd-real) + y))) + (double-float + (etypecase y + ((or cl:rational single-float double-float) + x) + (qd-real + y))) + (qd-real + x))) + +;; Return a floating point (or complex) type of the highest precision +;; among all of the given arguments. +(defun float-contagion (&rest args) + ;; It would be easy if we could just add the args together and let + ;; normal contagion do the work, but we could easily introduce + ;; overflows or other errors that way. So look at each argument and + ;; determine the precision and choose the highest precision. + (let ((complexp (some #'complexp args)) + (max-type + (etypecase (reduce #'float-contagion-2 (mapcar #'realpart (if (cdr args) + args + (list (car args) 0)))) + (single-float 'single-float) + (double-float 'double-float) + (qd-real 'qd-real)))) + max-type)) + +(defun apply-contagion (number precision) + (etypecase number + ((or cl:real qd-real) + (coerce number precision)) + ((or cl:complex qd-complex) + (complex (coerce (realpart number) precision) + (coerce (imagpart number) precision))))) + (defmethod add1 ((a number)) (cl::1+ a)) @@ -425,10 +478,13 @@ underlying floating-point format" (defmethod qexpt ((x number) (y number)) (cl:expt x y)) -(defmethod qexpt ((x qd-real) (y real)) - (exp (* y (log x)))) +(defmethod qexpt ((x number) (y qd-real)) + (exp (* y (log (apply-contagion x 'qd-real))))) + +(defmethod qexpt ((x number) (y qd-complex)) + (exp (* y (log (apply-contagion x 'qd-real))))) -(defmethod qexpt ((x real) (y qd-real)) +(defmethod qexpt ((x qd-real) (y real)) (exp (* y (log x)))) (defmethod qexpt ((x qd-real) (y cl:complex)) @@ -437,12 +493,6 @@ underlying floating-point format" :imag (qd-value (imagpart y))) (log x)))) -(defmethod qexpt ((x cl:complex) (y qd-real)) - (exp (* y - (log (make-instance 'qd-complex - :real (qd-value (realpart x)) - :imag (qd-value (imagpart x))))))) - (defmethod qexpt ((x qd-real) (y qd-real)) ;; x^y = exp(y*log(x)) (exp (* y (log x)))) @@ -451,6 +501,15 @@ underlying floating-point format" (make-instance 'qd-real :value (npow (qd-value x) y))) +(defmethod qexpt ((x qd-complex) (y number)) + (exp (* y (log x)))) + +(defmethod qexpt ((x qd-complex) (y qd-real)) + (exp (* y (log x)))) + +(defmethod qexpt ((x qd-complex) (y qd-complex)) + (exp (* y (log x)))) + (declaim (inline expt)) (defun expt (x y) (qexpt x y)) @@ -1058,56 +1117,3 @@ the same precision as the argument. The argument can be complex.")) (defmethod float-pi ((z qd-complex)) +pi+) -;; Determine which of x and y has the higher precision and return the -;; value of the higher precision number. If both x and y are -;; rationals, just return 1f0, for a single-float value. -(defun float-contagion-2 (x y) - (etypecase x - (cl:rational - (etypecase y - (cl:rational - 1f0) - (cl:float - y) - (qd-real - y))) - (single-float - (etypecase y - ((or cl:rational single-float) - x) - ((or double-float qd-real) - y))) - (double-float - (etypecase y - ((or cl:rational single-float double-float) - x) - (qd-real - y))) - (qd-real - x))) - -;; Return a floating point (or complex) type of the highest precision -;; among all of the given arguments. -(defun float-contagion (&rest args) - ;; It would be easy if we could just add the args together and let - ;; normal contagion do the work, but we could easily introduce - ;; overflows or other errors that way. So look at each argument and - ;; determine the precision and choose the highest precision. - (let ((complexp (some #'complexp args)) - (max-type - (etypecase (reduce #'float-contagion-2 (mapcar #'realpart (if (cdr args) - args - (list (car args) 0)))) - (single-float 'single-float) - (double-float 'double-float) - (qd-real 'qd-real)))) - max-type)) - -(defun apply-contagion (number precision) - (etypecase number - ((or cl:real qd-real) - (coerce number precision)) - ((or cl:complex qd-complex) - (complex (coerce (realpart number) precision) - (coerce (imagpart number) precision))))) - ----------------------------------------------------------------------- Summary of changes: qd-gamma.lisp | 173 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ qd-methods.lisp | 130 ++++++++++++++++++++++-------------------- rt-tests.lisp | 32 ++++++++++- 3 files changed, 272 insertions(+), 63 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 18 02:14:45 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Thu, 17 Mar 2011 22:14:45 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. d17228b86105b8a6ac652459b1100266ad0311b3 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via d17228b86105b8a6ac652459b1100266ad0311b3 (commit) from 46e7193fb5b2fad35e67366ff375d9ebbb524c5c (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit d17228b86105b8a6ac652459b1100266ad0311b3 Author: Raymond Toy Date: Thu Mar 17 22:14:25 2011 -0400 Add Fresnel integrals; fix issue in incomplete-gamma for large args. o INCOMPLETE-GAMMA was returning bad values for large (complex) arguments. Fix this by using incomplete gamma tail function since the incomplete gamma function approaches gamma for large arguments. o Implement Fresnel S and C functions. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index a25bc7d..dfc87a6 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -292,7 +292,9 @@ (if (< z (- a 1)) (cf-incomplete-gamma a z) (- (gamma a) (cf-incomplete-gamma-tail a z))) - (cf-incomplete-gamma a z)))) + (if (< (abs z) (abs a)) + (cf-incomplete-gamma a z) + (- (gamma a) (cf-incomplete-gamma-tail a z)))))) (defun erf (z) "Error function: @@ -341,3 +343,48 @@ ;; Wolfram gives E(v,z) = z^(v-1)*gamma_incomplete_tail(1-v,z) (* (expt z (- v 1)) (incomplete-gamma-tail (- 1 v) z))) + +(defun fresnel-s (z) + "Fresnel S: + + S(z) = integrate(sin(%pi*t^2/2), t, 0, z) " + (let ((sqrt-pi (sqrt (float-pi z)))) + (flet ((fs (z) + ;; Wolfram gives + ;; + ;; S(z) = (1+%i)/4*(erf(c*z) - %i*erf(conjugate(c)*z)) + ;; + ;; where c = sqrt(%pi)/2*(1+%i). + (* #c(1/4 1/4) + (- (erf (* #c(1/2 1/2) sqrt-pi z)) + (* #c(0 1) + (erf (* #c(1/2 -1/2) sqrt-pi z))))))) + (if (realp z) + ;; FresnelS is real for a real argument. And it is odd. + (if (minusp z) + (- (realpart (fs (- z)))) + (realpart (fs z))) + (fs z))))) + +(defun fresnel-c (z) + "Fresnel C: + + C(z) = integrate(cos(%pi*t^2/2), t, 0, z) " + (let ((sqrt-pi (sqrt (float-pi z)))) + (flet ((fs (z) + ;; Wolfram gives + ;; + ;; C(z) = (1-%i)/4*(erf(c*z) + %i*erf(conjugate(c)*z)) + ;; + ;; where c = sqrt(%pi)/2*(1+%i). + (* #c(1/4 -1/4) + (+ (erf (* #c(1/2 1/2) sqrt-pi z)) + (* #c(0 1) + (erf (* #c(1/2 -1/2) sqrt-pi z))))))) + (if (realp z) + ;; FresnelS is real for a real argument. And it is odd. + (if (minusp z) + (- (realpart (fs (- z)))) + (realpart (fs z))) + (fs z))))) + \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: qd-gamma.lisp | 49 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 files changed, 48 insertions(+), 1 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Tue Mar 22 13:13:47 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Tue, 22 Mar 2011 09:13:47 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. cc23f1098858d652c66728ea85c1c331bfb0fbb8 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via cc23f1098858d652c66728ea85c1c331bfb0fbb8 (commit) via 6b8dc51d96004406780ec1faa2cd4ce3b127c287 (commit) via 97bc71a13186735474eba77043d685b0bd0a00d6 (commit) via 50fc6412a3effd9bea8f3e481f7c35c3c911f856 (commit) from d17228b86105b8a6ac652459b1100266ad0311b3 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit cc23f1098858d652c66728ea85c1c331bfb0fbb8 Author: Raymond Toy Date: Mon Mar 21 19:39:24 2011 -0400 Move the uses of foo-t before the use of foo-t. diff --git a/qd.lisp b/qd.lisp index fb3e4e1..9f1ec3d 100644 --- a/qd.lisp +++ b/qd.lisp @@ -409,11 +409,6 @@ If TARGET is given, TARGET is destructively modified to contain the result." ;; which don't do a very good job with dataflow. CMUCL is one of ;; those compilers. -(defun add-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) - "Return the sum of the %QUAD-DOUBLE numbers A and B. -If TARGET is given, TARGET is destructively modified to contain the result." - (add-qd-t a b target)) - (defun add-qd-t (a b target) (declare (type %quad-double a b #+oct-array target) @@ -476,6 +471,12 @@ If TARGET is given, TARGET is destructively modified to contain the result." (%store-qd-d target (+ a0 b0) 0d0 0d0 0d0) (%store-qd-d target s0 s1 s2 s3))))))))))) +(defun add-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) + "Return the sum of the %QUAD-DOUBLE numbers A and B. +If TARGET is given, TARGET is destructively modified to contain the result." + (add-qd-t a b target)) + + (defun neg-qd-t (a target) (declare (type %quad-double a #+oct-array target) #+(and cmu (not oct-array)) (ignore target)) @@ -666,11 +667,6 @@ If TARGET is given, TARGET is destructively modified to contain the result." ;; Clisp says ;; 14.142135623730950488016887242096980785696718753769480731766797379908L0 -(defun mul-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) - "Returns the product of the %QUAD-DOUBLE numbers A and B. -If TARGET is given, TARGET is destructively modified to contain the result." - (mul-qd-t a b target)) - (defun mul-qd-t (a b target) (declare (type %quad-double a b #+oct-array target) (optimize (speed 3) @@ -736,6 +732,10 @@ If TARGET is given, TARGET is destructively modified to contain the result." (%store-qd-d target p0 0d0 0d0 0d0) (%store-qd-d target r0 r1 s0 s1)))))))))))))) +(defun mul-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) + "Returns the product of the %QUAD-DOUBLE numbers A and B. +If TARGET is given, TARGET is destructively modified to contain the result." + (mul-qd-t a b target)) ;; This is the non-sloppy version. I think this works just fine, but ;; since qd defaults to the sloppy multiplication version, we do the @@ -838,11 +838,6 @@ If TARGET is given, TARGET is destructively modified to contain the result." (multiple-value-call #'%make-qd-d (renorm-5 p0 p1 s0 t0 t1)))))))))))))))))))) -(defun sqr-qd (a &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) - "Return the square of the %QUAD-DOUBLE number A. If TARGET is also given, -it is destructively modified with the result." - (sqr-qd-t a target)) - (defun sqr-qd-t (a target) "Square A" (declare (type %quad-double a #+oct-array target) @@ -890,12 +885,11 @@ it is destructively modified with the result." (multiple-value-bind (a0 a1 a2 a3) (renorm-5 p0 p1 p2 p3 p4) (%store-qd-d target a0 a1 a2 a3))))))))) - -(defun div-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) - "Return the quotient of the two %QUAD-DOUBLE numbers A and B. -If TARGET is given, it destrutively modified with the result." - (div-qd-t a b target)) +(defun sqr-qd (a &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) + "Return the square of the %QUAD-DOUBLE number A. If TARGET is also given, +it is destructively modified with the result." + (sqr-qd-t a target)) #+nil (defun div-qd-t (a b target) @@ -948,6 +942,11 @@ If TARGET is given, it destrutively modified with the result." (renorm-4 q0 q1 q2 q3) (%store-qd-d target q0 q1 q2 q3)))))))) +(defun div-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) + "Return the quotient of the two %QUAD-DOUBLE numbers A and B. +If TARGET is given, it destrutively modified with the result." + (div-qd-t a b target)) + (declaim (inline invert-qd)) (defun invert-qd (v) commit 6b8dc51d96004406780ec1faa2cd4ce3b127c287 Author: Raymond Toy Date: Sat Mar 19 11:38:43 2011 -0400 Add rem and mod functions that were left out. diff --git a/qd-methods.lisp b/qd-methods.lisp index cbf0daa..29b296d 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -671,6 +671,12 @@ underlying floating-point format" (ceiling x y) (floor x y))) +(defun rem (x y) + (nth-value 1 (truncate x y))) + +(defun mod (x y) + (nth-value 1 (floor x y))) + (defun ftruncate (x &optional (y 1)) (if (minusp x) (fceiling x y) diff --git a/qd-package.lisp b/qd-package.lisp index b102435..7db5cd3 100644 --- a/qd-package.lisp +++ b/qd-package.lisp @@ -188,6 +188,8 @@ #:ftruncate #:round #:fround + #:rem + #:mod #:realpart #:imagpart #:conjugate @@ -258,6 +260,8 @@ #:ftruncate #:round #:fround + #:rem + #:mod #:realpart #:imagpart #:conjugate commit 97bc71a13186735474eba77043d685b0bd0a00d6 Author: Raymond Toy Date: Fri Mar 18 09:06:10 2011 -0400 Add series for incomplete-gamma for when the fraction is slow. o Add series for incomplete gamma function for small a and z. Needed because the continued fraction is slow in this range. o In INCOMPLETE-GAMMA-TAIL, call INCOMPLETE-GAMMA instead of CF-INCOMPLETE-GAMMA just in case a and z are small. o In INCOMPLETE-GAMMA, use the series for small a and z. o Simplify evaluation of Si(z) when z is real. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index a6fc7cf..c0cacaa 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -265,6 +265,21 @@ #'(lambda (n) (- (* z (+ a n)))))))))) +;; Series expansion for incomplete gamma. Intended for |a|<1 and +;; |z|<1. The series is +;; +;; g(a,z) = z^a * sum((-z)^k/k!/(a+k), k, 0, inf) +(defun s-incomplete-gamma (a z) + (let ((-z (- z)) + (eps (epsilon z))) + (loop for k from 0 + for term = 1 then (* term (/ -z k)) + for sum = (/ a) then (+ sum (/ term (+ a k))) + when (< (abs term) (* (abs sum) eps)) + return (* sum (expt z a))))) + + + ;; Tail of the incomplete gamma function. (defun incomplete-gamma-tail (a z) "Tail of the incomplete gamma function defined by: @@ -276,9 +291,9 @@ (if (and (realp a) (realp z)) ;; For real values, we split the result to compute either the ;; tail directly or from gamma(a) - incomplete-gamma - (if (> z (- a 1)) + (if (> (abs z) (abs (- a 1))) (cf-incomplete-gamma-tail a z) - (- (gamma a) (cf-incomplete-gamma a z))) + (- (gamma a) (incomplete-gamma a z))) (cf-incomplete-gamma-tail a z)))) (defun incomplete-gamma (a z) @@ -288,13 +303,18 @@ (let* ((prec (float-contagion a z)) (a (apply-contagion a prec)) (z (apply-contagion z prec))) - (if (and (realp a) (realp z)) - (if (< z (- a 1)) - (cf-incomplete-gamma a z) - (- (gamma a) (cf-incomplete-gamma-tail a z))) - (if (< (abs z) (abs a)) - (cf-incomplete-gamma a z) - (- (gamma a) (cf-incomplete-gamma-tail a z)))))) + (if (and (< (abs a) 1) (< (abs z) 1)) + (s-incomplete-gamma a z) + (if (and (realp a) (realp z)) + (if (< z (- a 1)) + (cf-incomplete-gamma a z) + (- (gamma a) (cf-incomplete-gamma-tail a z))) + ;; The continued fraction doesn't converge very fast if a + ;; and z are small. In this case, use the series + ;; expansion instead, which converges quite rapidly. + (if (< (abs z) (abs a)) + (cf-incomplete-gamma a z) + (- (gamma a) (cf-incomplete-gamma-tail a z))))))) (defun erf (z) "Error function: @@ -405,9 +425,20 @@ (- (log -iz) (log iz))))))) (if (realp z) - (if (< z 0) - (- (sin-integral (- z))) - (si z)) + ;; Si is odd and real for real z. In this case, we have + ;; + ;; Si(x) = %i/2*(gamma_inc_tail(0, -%i*x) - gamma_inc_tail(0, %i*x) - %i*%pi) + ;; = %pi/2 + %i/2*(gamma_inc_tail(0, -%i*x) - gamma_inc_tail(0, %i*x)) + ;; But gamma_inc_tail(0, conjugate(z)) = conjugate(gamma_inc_tail(0, z)), so + ;; + ;; Si(x) = %pi/2 + imagpart(gamma_inc_tail(0, %i*x)) + (cond ((< z 0) + (- (sin-integral (- z)))) + ((= z 0) + (* 0 z)) + (t + (+ (* 1/2 (float-pi z)) + (imagpart (incomplete-gamma-tail 0 (complex 0 z)))))) (si z)))) (defun cos-integral (z) commit 50fc6412a3effd9bea8f3e481f7c35c3c911f856 Author: Raymond Toy Date: Thu Mar 17 23:12:30 2011 -0400 Implement Si and Ci, sin and cos integrals. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index dfc87a6..a6fc7cf 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -387,4 +387,49 @@ (- (realpart (fs (- z)))) (realpart (fs z))) (fs z))))) - \ No newline at end of file + +(defun sin-integral (z) + "Sin integral: + + Si(z) = integrate(sin(t)/t, t, 0, z)" + ;; Wolfram has + ;; + ;; Si(z) = %i/2*(gamma_inc_tail(0, -%i*z) - gamma_inc_tail(0, %i*z) + log(-%i*z)-log(%i*z)) + ;; + (flet ((si (z) + (* #c(0 1/2) + (let ((iz (* #c(0 1) z)) + (-iz (* #c(0 -1) z))) + (+ (- (incomplete-gamma-tail 0 -iz) + (incomplete-gamma-tail 0 iz)) + (- (log -iz) + (log iz))))))) + (if (realp z) + (if (< z 0) + (- (sin-integral (- z))) + (si z)) + (si z)))) + +(defun cos-integral (z) + "Cos integral: + + Ci(z) = integrate((cos(t) - 1)/t, t, 0, z) + log(z) + gamma + + where gamma is Euler-Mascheroni constant" + ;; Wolfram has + ;; + ;; Ci(z) = log(z) - 1/2*(gamma_inc_tail(0, -%i*z) + gamma_inc_tail(0, %i*z) + log(-%i*z)+log(%i*z)) + ;; + (flet ((ci (z) + (- (log z) + (* 1/2 + (let ((iz (* #c(0 1) z)) + (-iz (* #c(0 -1) z))) + (+ (+ (incomplete-gamma-tail 0 -iz) + (incomplete-gamma-tail 0 iz)) + (+ (log -iz) + (log iz)))))))) + (if (and (realp z) (plusp z)) + (realpart (ci z)) + (ci z)))) + \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: qd-gamma.lisp | 96 +++++++++++++++++++++++++++++++++++++++++++++++++------ qd-methods.lisp | 6 +++ qd-package.lisp | 4 ++ qd.lisp | 39 +++++++++++----------- 4 files changed, 115 insertions(+), 30 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Fri Mar 25 03:02:05 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Thu, 24 Mar 2011 23:02:05 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. a44327a2532c5afc3cbcb1194aa1f15b6dccd2cb Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via a44327a2532c5afc3cbcb1194aa1f15b6dccd2cb (commit) via 7fa2a4c33e7542f3538bfcfd15cba833120b0daf (commit) via bed5763d1250d8b3b3793861f6e17449c49dd15b (commit) via 70745f486e3ee012f02c080de0cf9daf00f37375 (commit) from cc23f1098858d652c66728ea85c1c331bfb0fbb8 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit a44327a2532c5afc3cbcb1194aa1f15b6dccd2cb Author: Raymond Toy Date: Thu Mar 24 23:01:51 2011 -0400 Update required accuracy for elliptic-pi.n0.q. diff --git a/rt-tests.lisp b/rt-tests.lisp index ecb401a..c0b59fb 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -1037,7 +1037,7 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atan (* (tan phi) (sqrt (- 1 n)))) (sqrt (- 1 n))) - for result = (check-accuracy 208 epi true) + for result = (check-accuracy 204 epi true) unless (eq nil result) append (list (list (list k n phi) result))) nil) commit 7fa2a4c33e7542f3538bfcfd15cba833120b0daf Author: Raymond Toy Date: Thu Mar 24 23:01:08 2011 -0400 Add DOMAIN-ERROR condition; fix bug in FRESNEL-S-SERIES. qd-methods.lisp: o Define DOMAIN-ERROR condition to allow signaling errors for incorrect domains. qd-gamma.lisp: o Signal domain error in CF-INCOMPLETE-GAMMA-TAIL if necessary. o Fix bug in FRESNEL-S-SERIES. We were comparing a real against a complex. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index 74a9032..78b5a99 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -235,6 +235,11 @@ ;; ;; See http://functions.wolfram.com/06.06.10.0003.01 (defun cf-incomplete-gamma-tail (a z) + (when (and (zerop (imagpart z)) (minusp (realpart z))) + (error 'domain-error + :function-name 'cf-incomplete-gamma-tail + :format-arguments (list 'z z) + :format-control "Argument ~S should not be on the negative real axis: ~S")) (/ (* (expt z a) (exp (- z))) (let ((z-a (- z a))) @@ -391,7 +396,7 @@ (sum 0) (term pi/2)) (loop for k2 from 0 by 2 - until (< (abs term) (* eps sum)) + until (< (abs term) (* eps (abs sum))) do (incf sum (/ term (+ 3 k2 k2))) (setf term (/ (* term factor) diff --git a/qd-methods.lisp b/qd-methods.lisp index 29b296d..e4df131 100644 --- a/qd-methods.lisp +++ b/qd-methods.lisp @@ -1123,3 +1123,14 @@ the same precision as the argument. The argument can be complex.")) (defmethod float-pi ((z qd-complex)) +pi+) + +(define-condition domain-error (simple-error) + ((function-name :accessor condition-function-name + :initarg :function-name)) + (:report (lambda (condition stream) + (format stream "Domain Error for function ~S:~&" + (condition-function-name condition)) + (pprint-logical-block (stream nil :per-line-prefix " ") + (apply #'format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))))) \ No newline at end of file commit bed5763d1250d8b3b3793861f6e17449c49dd15b Author: Raymond Toy Date: Thu Mar 24 14:48:55 2011 -0400 Fix incomplete-gamma-tail for negative reals, use series for Fresnel S for small arg and update tests. qd-gamma.lisp: o INCOMPLETE-GAMMA-TAIL was hanging for arguments on the negative real axis. Use INCOMPLETE-GAMMA in this case too. o Add the series expansion for Fresnel S and use it for evaluating it for small arguments. We were losing accuracy with the existing algorithm. rt-tests.lisp: o Update thresholds for elliptic-pi-n0.d, elliptic-pi.n2.q, theta3.1.d. o Fix typo in test name. gamma-incomplete-tail.1.q should have been 2.q. o Add tests for gamma-incomplete-tail for arguments on the negative real axis. o Add tests for Fresnel S. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index c0cacaa..74a9032 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -288,10 +288,17 @@ (let* ((prec (float-contagion a z)) (a (apply-contagion a prec)) (z (apply-contagion z prec))) - (if (and (realp a) (realp z)) + (if (and (zerop (imagpart a)) + (zerop (imagpart z))) ;; For real values, we split the result to compute either the - ;; tail directly or from gamma(a) - incomplete-gamma - (if (> (abs z) (abs (- a 1))) + ;; tail directly from the continued fraction or from gamma(a) + ;; - incomplete-gamma. The continued fraction doesn't + ;; converge on the negative real axis, so we can't use that + ;; there. And accuracy appears to be better if z is "small". + ;; We take this to mean |z| < |a-1|. Note that |a-1| is the + ;; peak of the integrand. + (if (and (> (abs z) (abs (- a 1))) + (not (minusp (realpart z)))) (cf-incomplete-gamma-tail a z) (- (gamma a) (incomplete-gamma a z))) (cf-incomplete-gamma-tail a z)))) @@ -364,27 +371,90 @@ (* (expt z (- v 1)) (incomplete-gamma-tail (- 1 v) z))) +;; Series for Fresnel S +;; +;; S(z) = z^3*sum((%pi/2)^(2*k+1)(-z^4)^k/(2*k+1)!/(4*k+3), k, 0, inf) +;; +;; Compute as +;; +;; S(z) = z^3*sum(a(k)/(4*k+3), k, 0, inf) +;; +;; where +;; +;; a(k+1) = -a(k) * (%pi/2)^2 * z^4 / (2*k+2) / (2*k+3) +;; +;; a(0) = %pi/2. +(defun fresnel-s-series (z) + (let* ((pi/2 (* 1/2 (float-pi z))) + (factor (- (* (expt z 4) pi/2 pi/2))) + (eps (epsilon z)) + (sum 0) + (term pi/2)) + (loop for k2 from 0 by 2 + until (< (abs term) (* eps sum)) + do + (incf sum (/ term (+ 3 k2 k2))) + (setf term (/ (* term factor) + (* (+ k2 2) + (+ k2 3))))) + (* sum (expt z 3)))) + (defun fresnel-s (z) "Fresnel S: S(z) = integrate(sin(%pi*t^2/2), t, 0, z) " - (let ((sqrt-pi (sqrt (float-pi z)))) + (let ((prec (float-contagion z)) + (sqrt-pi (sqrt (float-pi z)))) (flet ((fs (z) ;; Wolfram gives ;; ;; S(z) = (1+%i)/4*(erf(c*z) - %i*erf(conjugate(c)*z)) ;; ;; where c = sqrt(%pi)/2*(1+%i). - (* #c(1/4 1/4) - (- (erf (* #c(1/2 1/2) sqrt-pi z)) - (* #c(0 1) - (erf (* #c(1/2 -1/2) sqrt-pi z))))))) - (if (realp z) - ;; FresnelS is real for a real argument. And it is odd. - (if (minusp z) - (- (realpart (fs (- z)))) - (realpart (fs z))) - (fs z))))) + ;; + ;; But for large z, we should use erfc. Then + ;; S(z) = 1/2 - (1+%i)/4*(erfc(c*z) - %i*erfc(conjugate(c)*z)) + (if (and t (> (abs z) 2)) + (- 1/2 + (* #c(1/4 1/4) + (- (erfc (* #c(1/2 1/2) sqrt-pi z)) + (* #c(0 1) + (erfc (* #c(1/2 -1/2) sqrt-pi z)))))) + (* #c(1/4 1/4) + (- (erf (* #c(1/2 1/2) sqrt-pi z)) + (* #c(0 1) + (erf (* #c(1/2 -1/2) sqrt-pi z))))))) + (rfs (z) + ;; When z is real, recall that erf(conjugate(z)) = + ;; conjugate(erf(z)). Then + ;; + ;; S(z) = 1/2*(realpart(erf(c*z)) - imagpart(erf(c*z))) + ;; + ;; But for large z, we should use erfc. Then + ;; + ;; S(z) = 1/2 - 1/2*(realpart(erfc(c*z)) - imagpart(erf(c*z))) + (if (> (abs z) 2) + (let ((s (erfc (* #c(1/2 1/2) sqrt-pi z)))) + (- 1/2 + (* 1/2 (- (realpart s) (imagpart s))))) + (let ((s (erf (* #c(1/2 1/2) sqrt-pi z)))) + (* 1/2 (- (realpart s) (imagpart s))))))) + ;; For small z, the erf terms above suffer from subtractive + ;; cancellation. So use the series in this case. Some simple + ;; tests were done to determine that for double-floats we want + ;; to use the series for z < 1 to give max accuracy. For + ;; qd-real, the above formula is good enough for z > 1d-5. + (if (< (abs z) (ecase prec + (single-float 1.5f0) + (double-float 1d0) + (qd-real #q1))) + (fresnel-s-series z) + (if (realp z) + ;; FresnelS is real for a real argument. And it is odd. + (if (minusp z) + (- (rfs (- z))) + (rfs z)) + (fs z)))))) (defun fresnel-c (z) "Fresnel C: diff --git a/rt-tests.lisp b/rt-tests.lisp index 5f4cdd5..ecb401a 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -1000,7 +1000,7 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atan (* (tan phi) (sqrt (- 1 n)))) (sqrt (- 1 n))) - for result = (check-accuracy 47.5 epi true) + for result = (check-accuracy 46.5 epi true) unless (eq nil result) append (list (list (list k n phi) result))) nil) @@ -1059,7 +1059,7 @@ for epi = (elliptic-pi n phi 0) for true = (/ (atanh (* (tan phi) (sqrt (- n 1)))) (sqrt (- n 1))) - for result = (check-accuracy 206 epi true) + for result = (check-accuracy 202 epi true) ;; Not sure if this formula holds when atanh gives a complex ;; result. Wolfram doesn't say when (and (not (complexp true)) result) @@ -1075,7 +1075,7 @@ for m = (random 1d0) for t3 = (elliptic-theta-3 0 (elliptic-nome m)) for true = (sqrt (/ (* 2 (elliptic-k m)) (float-pi m))) - for result = (check-accuracy 51 t3 true) + for result = (check-accuracy 50.5 t3 true) when result append (list (list (list k m) result))) nil) @@ -1213,15 +1213,74 @@ nil) (rt:deftest gamma-incomplete-tail.1.q - (let* ((z 5d0) + (let* ((z #q5) (gi (incomplete-gamma-tail 2 z)) (true (* (+ z 1) (exp (- z))))) - (check-accuracy 212 gi true)) + (check-accuracy 207 gi true)) nil) -(rt:deftest gamma-incomplete-tail.1.q +(rt:deftest gamma-incomplete-tail.2.q (let* ((z #q(1 5)) (gi (incomplete-gamma-tail 2 z)) (true (* (+ z 1) (exp (- z))))) (check-accuracy 206 gi true)) nil) + +(rt:deftest gamma-incomplete-tail.3.d + (let* ((z -5d0) + (gi (incomplete-gamma-tail 2 z)) + (true (* (+ z 1) (exp (- z))))) + (check-accuracy 52 gi true)) + nil) + +(rt:deftest gamma-incomplete-tail.3.q + (let* ((z #q-5) + (gi (incomplete-gamma-tail 2 z)) + (true (* (+ z 1) (exp (- z))))) + (check-accuracy 206 gi true)) + nil) + + +;; Fresnel integrals. +;; +;; For x small, Fresnel +;; +;; S(z) = %pi/6*z^3*(1 - %pi^2*z^4/56 + %pi^4*z^8/2040 - ...) +;; +(defun fresnel-s-series (z) + (let* ((fpi (float-pi z)) + (z^3 (expt z 3)) + (z^4 (* z^3 z))) + (* fpi 1/6 z^3 + (+ 1 (/ (* fpi fpi z^4) + -56) + (/ (* (expt fpi 4) (expt z^4 2)) + 7040))))) + +(rt:deftest fresnel-s.1d + (let* ((z 1d-3) + (s (fresnel-s z)) + (true (fresnel-s-series z))) + (check-accuracy 52 s true)) + nil) + +(rt:deftest fresnel-s.2d + (let* ((z #c(1d-3 1d-3)) + (s (fresnel-s z)) + (true (fresnel-s-series z))) + (check-accuracy 52 s true)) + nil) + +(rt:deftest fresnel-s.1q + (let* ((z #q1q-20) + (s (fresnel-s z)) + (true (fresnel-s-series z))) + (check-accuracy 212 s true)) + nil) + +(rt:deftest fresnel-s.2q + (let* ((z #q(1q-3 1q-3)) + (s (fresnel-s z)) + (true (fresnel-s-series z))) + (check-accuracy 212 s true)) + nil) commit 70745f486e3ee012f02c080de0cf9daf00f37375 Author: Raymond Toy Date: Thu Mar 24 14:25:53 2011 -0400 qd-gamma depends on qd-reader. diff --git a/oct.asd b/oct.asd index e4011a9..7df866c 100644 --- a/oct.asd +++ b/oct.asd @@ -66,7 +66,7 @@ (:file "qd-theta" :depends-on ("qd-methods" "qd-reader")) (:file "qd-gamma" - :depends-on ("qd-methods")) + :depends-on ("qd-methods" "qd-reader")) )) (defmethod perform ((op test-op) (c (eql (find-system :oct)))) ----------------------------------------------------------------------- Summary of changes: oct.asd | 2 +- qd-gamma.lisp | 103 +++++++++++++++++++++++++++++++++++++++++++++++------- qd-methods.lisp | 11 ++++++ rt-tests.lisp | 73 +++++++++++++++++++++++++++++++++++---- 4 files changed, 167 insertions(+), 22 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Tue Mar 29 02:37:47 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Mon, 28 Mar 2011 22:37:47 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. c31b1cdd112f26334b7762014d3afb781917ebda Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via c31b1cdd112f26334b7762014d3afb781917ebda (commit) via 88cff63cfb4996e2e90e499afd34e1fe16ecc179 (commit) from a44327a2532c5afc3cbcb1194aa1f15b6dccd2cb (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c31b1cdd112f26334b7762014d3afb781917ebda Author: Raymond Toy Date: Mon Mar 28 22:37:32 2011 -0400 More accurate incomplete-gamma function, add debugging to lentz, and some random clean ups. o Add *DEBUG-CF-EVAL* to enable debugging prints in LENTZ. o Modify LENTZ to terminate with an error if *MAX-CF-ITERATIONS* is reached. o Modify LENTZ to return the function value, the number of iterations, and the number of times a zero value had to be replaced. o Adjust cf-incomplete-gamma and cf-incomplete-gamma-tail not to signal overflow prematurely when calculating z^a*exp(-z). o Fix doc bug in reference for continued fraction for (original) cf-incomplete-gamma. o Add new version of cf-incomplete-gamma using a different continued fraction. This appears to converge faster and to be more accurate than the original, especially for points near the negative real axis. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index 78b5a99..e020a91 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -177,32 +177,62 @@ ;; b0 + ---- ---- ---- ;; b1 + b2 + b3 + ;; + +(defvar *debug-cf-eval* + nil + "When true, enable some debugging prints when evaluating a + continued fraction.") + +;; Max number of iterations allowed when evaluating the continued +;; fraction. When this is reached, we assume that the continued +;; fraction did not converge. +(defvar *max-cf-iterations* + 10000 + "Max number of iterations allowed when evaluating the continued + fraction. When this is reached, we assume that the continued + fraction did not converge.") + (defun lentz (bf af) - (flet ((value-or-tiny (v) - (if (zerop v) - (etypecase v - ((or double-float cl:complex) - least-positive-normalized-double-float) - ((or qd-real qd-complex) - (make-qd least-positive-normalized-double-float))) - v))) - (let* ((f (value-or-tiny (funcall bf 0))) - (c f) - (d 0) - (eps (epsilon f))) - (loop - for j from 1 - for an = (funcall af j) - for bn = (funcall bf j) - do (progn - (setf d (value-or-tiny (+ bn (* an d)))) - (setf c (value-or-tiny (+ bn (/ an c)))) - (setf d (/ d)) - (let ((delta (* c d))) - (setf f (* f delta)) - (when (<= (abs (- delta 1)) eps) - (return))))) - f))) + (let ((tiny-value-count 0)) + (flet ((value-or-tiny (v) + (if (zerop v) + (progn + (incf tiny-value-count) + (etypecase v + ((or double-float cl:complex) + least-positive-normalized-double-float) + ((or qd-real qd-complex) + (make-qd least-positive-normalized-double-float)))) + v))) + (let* ((f (value-or-tiny (funcall bf 0))) + (c f) + (d 0) + (eps (epsilon f))) + (loop + for j from 1 upto *max-cf-iterations* + for an = (funcall af j) + for bn = (funcall bf j) + do (progn + (setf d (value-or-tiny (+ bn (* an d)))) + (setf c (value-or-tiny (+ bn (/ an c)))) + (when *debug-cf-eval* + (format t "~&j = ~d~%" j) + (format t " an = ~s~%" an) + (format t " bn = ~s~%" bn) + (format t " c = ~s~%" c) + (format t " d = ~s~%" d)) + (let ((delta (/ c d))) + (setf d (/ d)) + (setf f (* f delta)) + (when *debug-cf-eval* + (format t " dl= ~S~%" delta) + (format t " f = ~S~%" f)) + (when (<= (abs (- delta 1)) eps) + (return-from lentz (values f j tiny-value-count))))) + finally + (error 'simple-error + :format-control "~" + :format-arguments (list *max-cf-iterations* (/ c d)))))))) ;; Continued fraction for erf(b): ;; @@ -240,8 +270,13 @@ :function-name 'cf-incomplete-gamma-tail :format-arguments (list 'z z) :format-control "Argument ~S should not be on the negative real axis: ~S")) - (/ (* (expt z a) - (exp (- z))) + (/ (handler-case (* (expt z a) + (exp (- z))) + (arithmetic-error () + ;; z^a*exp(-z) can overflow prematurely. In this case, use + ;; the equivalent exp(a*log(z)-z). We don't use this latter + ;; form because it has more roundoff error than the former. + (exp (- (* a (log z)) z)))) (let ((z-a (- z a))) (lentz #'(lambda (n) (+ n n 1 z-a)) @@ -251,18 +286,23 @@ ;; Incomplete gamma function: ;; integrate(x^(a-1)*exp(-x), x, 0, z) ;; -;; The continued fraction, valid for all z except the negative real -;; axis: +;; The continued fraction, valid for all z: ;; ;; b[n] = n - 1 + z + a ;; a[n] = -z*(a + n) ;; -;; See http://functions.wolfram.com/06.06.10.0005.01. We modified the +;; See http://functions.wolfram.com/06.06.10.0007.01. We modified the ;; continued fraction slightly and discarded the first quotient from ;; the fraction. +#+nil (defun cf-incomplete-gamma (a z) - (/ (* (expt z a) - (exp (- z))) + (/ (handler-case (* (expt z a) + (exp (- z))) + (arithmetic-error () + ;; z^a*exp(-z) can overflow prematurely. In this case, use + ;; the equivalent exp(a*log(z)-z). We don't use this latter + ;; form because it has more roundoff error than the former. + (exp (- (* a (log z)) z)))) (let ((za1 (+ z a 1))) (- a (/ (* a z) (lentz #'(lambda (n) @@ -270,6 +310,35 @@ #'(lambda (n) (- (* z (+ a n)))))))))) +;; Incomplete gamma function: +;; integrate(x^(a-1)*exp(-x), x, 0, z) +;; +;; The continued fraction, valid for all z: +;; +;; b[n] = a + n +;; a[n] = -(a+n/2)*z if n odd +;; n/2*z if n even +;; +;; See http://functions.wolfram.com/06.06.10.0009.01. +;; +;; Some experiments indicate that this converges faster than the above +;; and is actually quite a bit more accurate, expecially near the +;; negative real axis. +(defun cf-incomplete-gamma (a z) + (/ (handler-case (* (expt z a) + (exp (- z))) + (arithmetic-error () + ;; z^a*exp(-z) can overflow prematurely. In this case, use + ;; the equivalent exp(a*log(z)-z). We don't use this latter + ;; form because it has more roundoff error than the former. + (exp (- (* a (log z)) z)))) + (lentz #'(lambda (n) + (+ n a)) + #'(lambda (n) + (if (evenp n) + (* (ash n -1) z) + (- (* (+ a (ash n -1)) z))))))) + ;; Series expansion for incomplete gamma. Intended for |a|<1 and ;; |z|<1. The series is ;; @@ -283,8 +352,6 @@ when (< (abs term) (* (abs sum) eps)) return (* sum (expt z a))))) - - ;; Tail of the incomplete gamma function. (defun incomplete-gamma-tail (a z) "Tail of the incomplete gamma function defined by: commit 88cff63cfb4996e2e90e499afd34e1fe16ecc179 Author: Raymond Toy Date: Mon Mar 28 09:08:37 2011 -0400 Fix typo in #q() number in fresnel-s.2q test. diff --git a/rt-tests.lisp b/rt-tests.lisp index c0b59fb..66aab0c 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -1279,7 +1279,7 @@ nil) (rt:deftest fresnel-s.2q - (let* ((z #q(1q-3 1q-3)) + (let* ((z #q(#q1q-3 #q1q-3)) (s (fresnel-s z)) (true (fresnel-s-series z))) (check-accuracy 212 s true)) ----------------------------------------------------------------------- Summary of changes: qd-gamma.lisp | 135 ++++++++++++++++++++++++++++++++++++++++++-------------- rt-tests.lisp | 2 +- 2 files changed, 102 insertions(+), 35 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Tue Mar 29 03:47:14 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Mon, 28 Mar 2011 23:47:14 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. 08d254374188f97026d114451bba5d839dbdad11 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via 08d254374188f97026d114451bba5d839dbdad11 (commit) from c31b1cdd112f26334b7762014d3afb781917ebda (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 08d254374188f97026d114451bba5d839dbdad11 Author: Raymond Toy Date: Mon Mar 28 22:54:32 2011 -0400 Make INCOMPLETE-GAMMA-TAIL more accurate. o Use the new continued fraction for the incomplete-gamma when the argument z is close enough to the negative real axis. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index e020a91..7048b80 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -372,8 +372,15 @@ (if (and (> (abs z) (abs (- a 1))) (not (minusp (realpart z)))) (cf-incomplete-gamma-tail a z) - (- (gamma a) (incomplete-gamma a z))) - (cf-incomplete-gamma-tail a z)))) + (- (gamma a) (cf-incomplete-gamma a z))) + ;; If the argument is close enough to the negative real axis, + ;; the continued fraction for the tail is not very accurate. + ;; Use the incomplete gamma function to evaluate in this + ;; region. (Arbitrarily selected the region to be a sector. + ;; But what is the correct size of this sector?) + (if (<= (phase z) 3.1) + (cf-incomplete-gamma-tail a z) + (- (gamma a) (cf-incomplete-gamma a z)))))) (defun incomplete-gamma (a z) "Incomplete gamma function defined by: ----------------------------------------------------------------------- Summary of changes: qd-gamma.lisp | 11 +++++++++-- 1 files changed, 9 insertions(+), 2 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats From rtoy at common-lisp.net Tue Mar 29 13:59:14 2011 From: rtoy at common-lisp.net (Raymond Toy) Date: Tue, 29 Mar 2011 09:59:14 -0400 Subject: [oct-scm] [oct-git]OCT: A portable Lisp implementation for quad-double precision floats branch master updated. af9fc6fcdb824757c5aeeadc6ccae2098d243313 Message-ID: This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "OCT: A portable Lisp implementation for quad-double precision floats". The branch, master has been updated via af9fc6fcdb824757c5aeeadc6ccae2098d243313 (commit) from 08d254374188f97026d114451bba5d839dbdad11 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit af9fc6fcdb824757c5aeeadc6ccae2098d243313 Author: Raymond Toy Date: Tue Mar 29 09:58:45 2011 -0400 Make gamma accurate for integers; add precision test for incomplete-gamma-tail. qd-gamma.lisp: o For integer values, just compute the gamma value directly by multiplication. This works around the problem that the current algorithm is not as accurate as we would like. rt-test.lisp: o Reduce required accuracy in gamma-incomplete-tail.3.d. o Add precision test for gamm incomplete tail near the negative real axis. diff --git a/qd-gamma.lisp b/qd-gamma.lisp index 7048b80..8cab1bb 100644 --- a/qd-gamma.lisp +++ b/qd-gamma.lisp @@ -142,6 +142,18 @@ (/ (float-pi z) (sin (* (float-pi z) z)) (gamma-aux (- 1 z) limit nterms))) + ((and (zerop (imagpart z)) + (= z (truncate z))) + ;; We have gamma(n) where an integer value n and is small + ;; enough. In this case, just compute the product + ;; directly. We do this because our current implementation + ;; has some round-off for these values, and that's annoying + ;; and unexpected. + (let ((n (truncate z))) + (loop + for prod = (apply-contagion 1 precision) then (* prod k) + for k from 2 below n + finally (return (apply-contagion prod precision))))) (t (let ((absz (abs z))) (cond ((>= absz limit) @@ -168,7 +180,6 @@ (defmethod gamma ((z qd-complex)) (gamma-aux z 39 32)) - ;; Lentz's algorithm for evaluating continued fractions. ;; ;; Let the continued fraction be: diff --git a/rt-tests.lisp b/rt-tests.lisp index 66aab0c..acc8b74 100644 --- a/rt-tests.lisp +++ b/rt-tests.lisp @@ -1230,7 +1230,7 @@ (let* ((z -5d0) (gi (incomplete-gamma-tail 2 z)) (true (* (+ z 1) (exp (- z))))) - (check-accuracy 52 gi true)) + (check-accuracy 50 gi true)) nil) (rt:deftest gamma-incomplete-tail.3.q @@ -1240,6 +1240,16 @@ (check-accuracy 206 gi true)) nil) +;; See http://www.wolframalpha.com/input/?i=Gamma[1%2F2%2C-100%2Bi%2F%2810^10%29] + +(rt:deftest gamma-incomplete-tail.4.q + (let* ((z #q(#q-100 #q1q-10)) + (gi (incomplete-gamma-tail 1/2 z)) + (true #q(#q-2.68811714181613544840818982228135651231579313476267430888499241497530341422025007816745898370049200133136q32 + #q-2.70176456134384383878883307528351227886457379834795655467745609829086928772079968479767583764284583465328q42))) + (check-accuracy 205 gi true)) + nil) + ;; Fresnel integrals. ;; ----------------------------------------------------------------------- Summary of changes: qd-gamma.lisp | 13 ++++++++++++- rt-tests.lisp | 12 +++++++++++- 2 files changed, 23 insertions(+), 2 deletions(-) hooks/post-receive -- OCT: A portable Lisp implementation for quad-double precision floats